From 357ccc987dee33b7b9780145e17f3205d462ceda Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Thu, 12 Dec 2024 13:04:18 +1100 Subject: [PATCH 1/4] access: relax conditions -Remove various instances of pspace_aligned, valid_vspace_objs, and valid_asid_table/valid_arch_state from preconditions -Relax the is_subject predicate in various Syscall_AC lemmas Signed-off-by: Ryan Barry --- proof/access-control/ARM/ArchDomainSepInv.thy | 32 +-- proof/access-control/ARM/ArchInterrupt_AC.thy | 5 +- proof/access-control/ARM/ArchSyscall_AC.thy | 2 +- proof/access-control/Arch_AC.thy | 16 +- proof/access-control/CNode_AC.thy | 60 ++--- proof/access-control/DomainSepInv.thy | 206 ++++++++--------- proof/access-control/Finalise_AC.thy | 71 ++---- proof/access-control/Interrupt_AC.thy | 6 +- proof/access-control/Ipc_AC.thy | 115 +++------- proof/access-control/RISCV64/ArchArch_AC.thy | 15 +- proof/access-control/RISCV64/ArchCNode_AC.thy | 45 ++-- .../RISCV64/ArchDomainSepInv.thy | 42 ++-- .../RISCV64/ArchFinalise_AC.thy | 17 +- .../RISCV64/ArchInterrupt_AC.thy | 3 +- proof/access-control/RISCV64/ArchIpc_AC.thy | 5 - .../access-control/RISCV64/ArchSyscall_AC.thy | 3 +- proof/access-control/Retype_AC.thy | 80 ++----- proof/access-control/Syscall_AC.thy | 207 ++++++++++-------- proof/access-control/Tcb_AC.thy | 27 +-- 19 files changed, 383 insertions(+), 574 deletions(-) diff --git a/proof/access-control/ARM/ArchDomainSepInv.thy b/proof/access-control/ARM/ArchDomainSepInv.thy index a71f853432..74d5be62f2 100644 --- a/proof/access-control/ARM/ArchDomainSepInv.thy +++ b/proof/access-control/ARM/ArchDomainSepInv.thy @@ -25,6 +25,21 @@ lemma arch_finalise_cap_rv[DomainSepInv_assms]: "\\_. P (NullCap,NullCap)\ arch_finalise_cap c x \\rv _. P rv\" unfolding arch_finalise_cap_def by wpsimp +crunch + invalidate_tlb_by_asid, handle_reserved_irq, handle_vm_fault, + handle_hypervisor_fault, handle_arch_fault_reply, arch_mask_irq_signal, + arch_switch_to_thread, arch_switch_to_idle_thread, arch_activate_idle_thread + for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" + +lemma arch_derive_cap_domain_sep_inv[DomainSepInv_assms, wp]: + "\\\ arch_derive_cap acap \\rv _. domain_sep_inv_cap irqs rv\,-" + unfolding arch_derive_cap_def + by wpsimp + +lemma arch_post_modify_registers_domain_sep_inv[DomainSepInv_assms, wp]: + "arch_post_modify_registers cur x31 \domain_sep_inv irqs st\" + unfolding arch_post_modify_registers_def by wpsimp + end @@ -38,12 +53,6 @@ qed context Arch begin global_naming ARM_A -crunch - invalidate_tlb_by_asid, handle_reserved_irq, handle_vm_fault, - handle_hypervisor_fault, handle_arch_fault_reply, arch_mask_irq_signal, - arch_switch_to_thread, arch_switch_to_idle_thread, arch_activate_idle_thread - for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" - lemma perform_page_invocation_domain_sep_inv: "\domain_sep_inv irqs st and valid_page_inv pgi\ perform_page_invocation pgi @@ -120,15 +129,6 @@ lemma arch_invoke_irq_control_domain_sep_inv[DomainSepInv_assms]: apply (wpsimp wp: do_machine_op_domain_sep_inv simp: arch_irq_control_inv_valid_def)+ done -lemma arch_derive_cap_domain_sep_inv[DomainSepInv_assms, wp]: - "\\\ arch_derive_cap acap \\rv _. domain_sep_inv_cap irqs rv\,-" - unfolding arch_derive_cap_def - by wpsimp - -lemma arch_post_modify_registers_domain_sep_inv[DomainSepInv_assms, wp]: - "arch_post_modify_registers cur x31 \domain_sep_inv irqs st\" - unfolding arch_post_modify_registers_def by wpsimp - end @@ -136,7 +136,7 @@ global_interpretation DomainSepInv_2?: DomainSepInv_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; fact DomainSepInv_assms) + by (unfold_locales; wpsimp wp: DomainSepInv_assms) qed end diff --git a/proof/access-control/ARM/ArchInterrupt_AC.thy b/proof/access-control/ARM/ArchInterrupt_AC.thy index 78abd12d2b..9ac28a213a 100644 --- a/proof/access-control/ARM/ArchInterrupt_AC.thy +++ b/proof/access-control/ARM/ArchInterrupt_AC.thy @@ -21,8 +21,7 @@ definition arch_authorised_irq_ctl_inv :: (pasSubject aag, Control, pasIRQAbs aag irq) \ pasPolicy aag" lemma arch_invoke_irq_control_pas_refined[Interrupt_AC_assms]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_mdb and arch_irq_control_inv_valid irq_ctl_inv + "\pas_refined aag and valid_mdb and arch_irq_control_inv_valid irq_ctl_inv and K (arch_authorised_irq_ctl_inv aag irq_ctl_inv)\ arch_invoke_irq_control irq_ctl_inv \\_. pas_refined aag\" @@ -75,7 +74,7 @@ global_interpretation Interrupt_AC_1?: Interrupt_AC_1 "arch_authorised_irq_ctl_i proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Interrupt_AC_assms)?) + by (unfold_locales; fact Interrupt_AC_assms) qed diff --git a/proof/access-control/ARM/ArchSyscall_AC.thy b/proof/access-control/ARM/ArchSyscall_AC.thy index 068449213b..c717a31f5e 100644 --- a/proof/access-control/ARM/ArchSyscall_AC.thy +++ b/proof/access-control/ARM/ArchSyscall_AC.thy @@ -179,7 +179,7 @@ global_interpretation Syscall_AC_1?: Syscall_AC_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Syscall_AC_assms)?) + by (unfold_locales; wpsimp wp: Syscall_AC_assms) qed end diff --git a/proof/access-control/Arch_AC.thy b/proof/access-control/Arch_AC.thy index 512058f6b9..195dc942d5 100644 --- a/proof/access-control/Arch_AC.thy +++ b/proof/access-control/Arch_AC.thy @@ -68,9 +68,7 @@ lemma mapM_set'': done lemma as_user_state_vrefs: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ - as_user t f - \\_ s :: det_ext state. P (state_vrefs s)\" + "as_user t f \\s :: det_ext state. P (state_vrefs s)\" apply (simp add: as_user_def) apply (wpsimp wp: set_object_wp) apply (clarsimp simp: state_vrefs_tcb_upd obj_at_def is_obj_defs @@ -79,9 +77,7 @@ lemma as_user_state_vrefs: done lemma as_user_pas_refined[wp]: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and pas_refined aag\ - as_user t f - \\_. pas_refined aag\" + "as_user t f \pas_refined aag\" apply (simp add: pas_refined_def state_objs_to_policy_def) apply (rule hoare_pre) apply wps @@ -151,9 +147,7 @@ lemma is_subject_asid_into_loas: locale Arch_AC_1 = assumes set_mrs_state_vrefs[wp]: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ - set_mrs thread buf msgs - \\_ s :: det_ext state. P (state_vrefs s)\" + "set_mrs thread buf msgs \\s :: det_ext state. P (state_vrefs s)\" and mul_add_word_size_lt_msg_align_bits_ofnat: "\ p < 2 ^ (msg_align_bits - word_size_bits); k < word_size \ \ of_nat p * of_nat word_size + k < (2 :: obj_ref) ^ msg_align_bits" @@ -196,9 +190,7 @@ lemma store_word_offs_integrity_autarch: done lemma set_mrs_pas_refined[wp]: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and pas_refined aag\ - set_mrs thread buf msgs - \\_. pas_refined aag\" + "set_mrs thread buf msgs \pas_refined aag\" apply (simp add: pas_refined_def state_objs_to_policy_def) apply (rule hoare_pre) apply (wp | wps)+ diff --git a/proof/access-control/CNode_AC.thy b/proof/access-control/CNode_AC.thy index b79309883c..d45ce00054 100644 --- a/proof/access-control/CNode_AC.thy +++ b/proof/access-control/CNode_AC.thy @@ -67,18 +67,14 @@ locale CNode_AC_1 = state_asids_to_policy_arch aag caps (as :: arch_state) vrefs \ pasPolicy aag \ \ state_asids_to_policy_arch aag (caps(ptr \ cap, ptr' \ cap')) as vrefs \ pasPolicy aag" and state_vrefs_tcb_upd: - "\ pspace_aligned s; valid_vspace_objs s; valid_arch_state s; tcb_at tptr s \ - \ state_vrefs (s\kheap := (kheap s)(tptr \ TCB tcb)\) = state_vrefs s" + "tcb_at tptr s \ state_vrefs (s\kheap := (kheap s)(tptr \ TCB tcb)\) = state_vrefs s" and state_vrefs_simple_type_upd: - "\ pspace_aligned s; valid_vspace_objs s; valid_arch_state s; - ko_at ko p s; is_simple_type ko; a_type ko = a_type (f (val :: 'b)) \ + "\ ko_at ko p s; is_simple_type ko; a_type ko = a_type (f (val :: 'b)) \ \ state_vrefs (s\kheap := (kheap s)(p \ f val)\) = state_vrefs s" and a_type_arch_object_not_tcb[simp]: "a_type (ArchObj arch_kernel_obj) \ ATCB" and set_cap_state_vrefs: - "\P. \pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ - set_cap cap slot - \\_ s :: det_ext state. P (state_vrefs s)\" + "\P. set_cap cap slot \\s :: det_ext state. P (state_vrefs s)\" and set_cdt_state_vrefs[wp]: "\P. set_cdt t \\s :: det_ext state. P (state_vrefs s)\" and set_cdt_state_asids_to_policy[wp]: @@ -308,7 +304,7 @@ lemma sita_caps_update2: context CNode_AC_1 begin lemma set_cap_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and + "\pas_refined aag and (\s. (is_transferable_in ptr s \ (\ Option.is_none (cdt s ptr))) \ is_transferable_cap cap \ abs_has_auth_to aag Control (fst $ the $ cdt s ptr) (fst ptr)) and @@ -330,8 +326,7 @@ lemma set_cap_pas_refined: done lemma set_cap_pas_refined_not_transferable: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and cte_wp_at (\c. \is_transferable (Some c)) ptr + "\pas_refined aag and cte_wp_at (\c. \is_transferable (Some c)) ptr and K (aag_cap_auth aag (pasObjectAbs aag (fst ptr)) cap)\ set_cap cap ptr \\_. pas_refined aag\" @@ -1025,7 +1020,7 @@ locale CNode_AC_3 = CNode_AC_2 + begin lemma cap_insert_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and valid_mdb and + "\pas_refined aag and valid_mdb and (\s. (is_transferable_in src_slot s \ (\ Option.is_none (cdt s src_slot))) \ is_transferable_cap new_cap) and K (is_subject aag (fst dest_slot) \ is_subject aag (fst src_slot) @@ -1049,7 +1044,7 @@ lemma cap_insert_pas_refined: dest: aag_cdt_link_Control aag_cdt_link_DeleteDerived cap_auth_caps_of_state) lemma cap_insert_pas_refined': - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and valid_mdb and + "\pas_refined aag and valid_mdb and (\s. cte_wp_at is_transferable_cap src_slot s \ is_transferable_cap new_cap) and K (is_subject aag (fst dest_slot) \ is_subject aag (fst src_slot) \ pas_cap_cur_auth aag new_cap) \ @@ -1060,7 +1055,7 @@ lemma cap_insert_pas_refined': simp: cte_wp_at_caps_of_state Option.is_none_def) lemma cap_insert_pas_refined_not_transferable: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and valid_mdb + "\pas_refined aag and valid_mdb and not cte_wp_at is_transferable_cap src_slot and K (is_subject aag (fst dest_slot) \ is_subject aag (fst src_slot) \ pas_cap_cur_auth aag new_cap) \ @@ -1069,7 +1064,7 @@ lemma cap_insert_pas_refined_not_transferable: by (wpsimp wp: cap_insert_pas_refined') lemma cap_insert_pas_refined_same_object_as: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and valid_mdb + "\pas_refined aag and valid_mdb and cte_wp_at (same_object_as new_cap) src_slot and K (is_subject aag (fst dest_slot) \ is_subject aag (fst src_slot) \ (\ is_master_reply_cap new_cap) \ pas_cap_cur_auth aag new_cap)\ @@ -1081,8 +1076,7 @@ lemma cap_insert_pas_refined_same_object_as: elim: is_transferable_capE split: cap.splits) lemma cap_move_pas_refined[wp]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_mdb and cte_wp_at (weak_derived new_cap) src_slot + "\pas_refined aag and valid_mdb and cte_wp_at (weak_derived new_cap) src_slot and cte_wp_at ((=) NullCap) dest_slot and K (is_subject aag (fst dest_slot) \ is_subject aag (fst src_slot) \ pas_cap_cur_auth aag new_cap)\ @@ -1099,14 +1093,8 @@ lemma cap_move_pas_refined[wp]: dest: invs_mdb pas_refined_mem[OF sta_cdt] pas_refined_mem[OF sta_cdt_transferable]) -crunch set_original, set_cdt - for pspace_aligned[wp]: pspace_aligned - and valid_vspace_objs[wp]: valid_vspace_objs - and valid_arch_state[wp]: valid_arch_state - lemma empty_slot_pas_refined[wp, wp_not_transferable]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_mdb and K (is_subject aag (fst slot))\ + "\pas_refined aag and valid_mdb and K (is_subject aag (fst slot))\ empty_slot slot irqopt \\_. pas_refined aag\" apply (simp add: empty_slot_def post_cap_deletion_def) @@ -1119,8 +1107,7 @@ lemma empty_slot_pas_refined[wp, wp_not_transferable]: lemma empty_slot_pas_refined_transferable[wp_transferable]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_mdb and (\s. is_transferable (caps_of_state s slot))\ + "\pas_refined aag and valid_mdb and (\s. is_transferable (caps_of_state s slot))\ empty_slot slot irqopt \\_. pas_refined aag\" apply (simp add: empty_slot_def post_cap_deletion_def) @@ -1178,7 +1165,7 @@ lemma cap_swap_pas_refined[wp]: by (erule subsetD; force simp: is_transferable_weak_derived intro!: sbta_cdt_transferable auth_graph_map_memI)+ apply (blast intro: state_bits_to_policy.intros auth_graph_map_memI) - by fastforce+ + done lemma cap_swap_for_delete_pas_refined[wp]: "\pas_refined aag and invs and K (is_subject aag (fst slot) \ is_subject aag (fst slot'))\ @@ -1305,9 +1292,7 @@ lemma set_simple_ko_ekheap[wp]: context CNode_AC_3 begin lemma sts_st_vrefs[wp]: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ - set_thread_state t st - \\_ s :: det_ext state. P (state_vrefs s)\" + "set_thread_state t st \\s :: det_ext state. P (state_vrefs s)\" apply (simp add: set_thread_state_def del: set_thread_state_ext_extended.dxo_eq) apply (wpsimp wp: set_object_wp dxo_wp_weak) apply (clarsimp simp: state_vrefs_tcb_upd obj_at_def is_obj_defs @@ -1316,8 +1301,7 @@ lemma sts_st_vrefs[wp]: done lemma set_thread_state_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and - K (\r \ tcb_st_to_auth st. abs_has_auth_to aag (snd r) t (fst r))\ + "\pas_refined aag and K (\r \ tcb_st_to_auth st. abs_has_auth_to aag (snd r) t (fst r))\ set_thread_state t st \\_. pas_refined aag\" apply (simp add: pas_refined_def state_objs_to_policy_def) @@ -1330,17 +1314,14 @@ lemma set_thread_state_pas_refined: done lemma set_simple_ko_vrefs[wp]: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ - set_simple_ko f ptr (val :: 'b) - \\_ s :: det_ext state. P (state_vrefs s)\" + "set_simple_ko f ptr (val :: 'b) \\s :: det_ext state. P (state_vrefs s)\" apply (simp add: set_simple_ko_def set_object_def) apply (wp get_object_wp) apply (fastforce simp: state_vrefs_simple_type_upd obj_at_def elim!: rsubst[where P=P, OF _ ext]) done lemma set_simple_ko_pas_refined[wp]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - set_simple_ko f ptr (ep :: 'b) \\_. pas_refined aag\" + "set_simple_ko f ptr (ep :: 'b) \pas_refined aag\" apply (simp add: pas_refined_def state_objs_to_policy_def) apply (rule hoare_pre) apply (wp tcb_domain_map_wellformed_lift | wps)+ @@ -1348,9 +1329,7 @@ lemma set_simple_ko_pas_refined[wp]: done lemma thread_set_state_vrefs: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ - thread_set f t - \\_ s :: det_ext state. P (state_vrefs s)\" + "thread_set f t \\s :: det_ext state. P (state_vrefs s)\" apply (simp add: thread_set_def) apply (wpsimp wp: set_object_wp) apply (clarsimp simp: state_vrefs_tcb_upd obj_at_def is_obj_defs @@ -1387,8 +1366,7 @@ lemma thread_set_pas_refined_triv: 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" - shows "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - thread_set f t \\_. pas_refined aag\" + shows "thread_set f t \pas_refined aag\" by (wpsimp wp: tcb_domain_map_wellformed_lift thread_set_state_vrefs simp: pas_refined_def state_objs_to_policy_def | wps thread_set_caps_of_state_trivial[OF cps] diff --git a/proof/access-control/DomainSepInv.thy b/proof/access-control/DomainSepInv.thy index 7d2c2c6421..0650010cc8 100644 --- a/proof/access-control/DomainSepInv.thy +++ b/proof/access-control/DomainSepInv.thy @@ -320,6 +320,22 @@ locale DomainSepInv_1 = "prepare_thread_delete t \\s :: det_ext state. domain_sep_inv irqs st s\" and arch_finalise_cap_rv: "\\_. P (NullCap,NullCap)\ arch_finalise_cap c x \\rv s :: det_ext state. P rv\" + and arch_switch_to_thread_domain_sep_inv[wp]: + "arch_switch_to_thread t \\s :: det_ext state. domain_sep_inv irqs (st :: 'state_ext state) s\" + and arch_switch_to_idle_thread_domain_sep_inv[wp]: + "arch_switch_to_idle_thread \\s :: det_ext state. domain_sep_inv irqs st s\" + and arch_activate_idle_thread_domain_sep_inv[wp]: + "arch_activate_idle_thread t \\s :: det_ext state. domain_sep_inv irqs st s\" + and arch_mask_irq_signal_domain_sep_inv[wp]: + "arch_mask_irq_signal irq \\s :: det_ext state. domain_sep_inv irqs st s\" + and arch_derive_cap_domain_sep_inv[wp]: + "\\\ arch_derive_cap acap \\rv s :: det_ext state. domain_sep_inv_cap irqs rv\,-" + and arch_post_modify_registers_domain_sep_inv[wp]: + "arch_post_modify_registers cur t \\s :: det_ext state. domain_sep_inv irqs st s\" + and handle_arch_fault_reply_domain_sep_inv[wp]: + "handle_arch_fault_reply vmf thread d ds \\s :: det_ext state. domain_sep_inv irqs st s\" + and handle_vm_fault_domain_sep_inv[wp]: + "handle_vm_fault t vmf_t \\s :: det_ext state. domain_sep_inv irqs st s\" begin lemma deleted_irq_handler_domain_sep_inv: @@ -739,83 +755,6 @@ lemma domain_sep_inv_cap_ArchObjectCap[simp]: "domain_sep_inv_cap irqs (ArchObjectCap arch_cap)" by (simp add: domain_sep_inv_cap_def) - -locale DomainSepInv_2 = DomainSepInv_1 state_ext_t - for state_ext_t :: "'state_ext :: state_ext itself" + - assumes arch_switch_to_thread_domain_sep_inv[wp]: - "arch_switch_to_thread t \\s :: det_ext state. domain_sep_inv irqs (st :: 'state_ext state) s\" - and arch_switch_to_idle_thread_domain_sep_inv[wp]: - "arch_switch_to_idle_thread \\s :: det_ext state. domain_sep_inv irqs st s\" - and arch_activate_idle_thread_domain_sep_inv[wp]: - "arch_activate_idle_thread t \\s :: det_ext state. domain_sep_inv irqs st s\" - and arch_mask_irq_signal_domain_sep_inv[wp]: - "arch_mask_irq_signal irq \\s :: det_ext state. domain_sep_inv irqs st s\" - and arch_derive_cap_domain_sep_inv[wp]: - "\\\ arch_derive_cap acap \\rv s :: det_ext state. domain_sep_inv_cap irqs rv\,-" - and arch_post_modify_registers_domain_sep_inv[wp]: - "arch_post_modify_registers cur x31 \\s :: det_ext state. domain_sep_inv irqs st s\" - and arch_perform_invocation_domain_sep_inv[wp]: - "\domain_sep_inv irqs st and valid_arch_inv ai\ - arch_perform_invocation ai - \\_ s :: det_ext state. domain_sep_inv irqs st s\" - and arch_invoke_irq_handler_domain_sep_inv[wp]: - "arch_invoke_irq_handler ihi \\s :: det_ext state. domain_sep_inv irqs st s\" - and arch_invoke_irq_control_domain_sep_inv: - "\domain_sep_inv irqs st and arch_irq_control_inv_valid ivk\ - arch_invoke_irq_control ivk - \\_ s :: det_ext state. domain_sep_inv irqs st s\" - and handle_arch_fault_reply_domain_sep_inv[wp]: - "handle_arch_fault_reply vmf thread x y \\s :: det_ext state. domain_sep_inv irqs st s\" - and handle_hypervisor_fault_domain_sep_inv[wp]: - "handle_hypervisor_fault t hf_t \\s :: det_ext state. domain_sep_inv irqs st s\" - and handle_vm_fault_domain_sep_inv[wp]: - "handle_vm_fault t vmf_t \\s :: det_ext state. domain_sep_inv irqs st s\" - and handle_reserved_irq_domain_sep_inv[wp]: - "handle_reserved_irq irq \\s :: det_ext state. domain_sep_inv irqs st s\" -begin - -(* when i is AckIRQ the preconditions here contradict each other, which - is why this lemma is true *) -lemma invoke_irq_handler_domain_sep_inv: - "\domain_sep_inv irqs st and irq_handler_inv_valid i\ - invoke_irq_handler i - \\_ s. domain_sep_inv irqs (st :: 'state_ext state) (s :: det_ext state)\" - apply (case_tac i) - apply (wp cap_insert_domain_sep_inv' | simp)+ - apply (rename_tac irq cap cslot_ptr s) - apply (case_tac cap, simp_all add: domain_sep_inv_cap_def)[1] - apply (wp | clarsimp)+ - done - -(* similarly, the preconditions here tend to contradict one another *) -lemma invoke_control_domain_sep_inv: - "\domain_sep_inv irqs st and irq_control_inv_valid i\ - invoke_irq_control i - \\_ s. domain_sep_inv irqs (st :: 'state_ext state) (s :: det_ext state)\" - including classic_wp_pre - apply (case_tac i) - apply (case_tac irqs) - apply (wp cap_insert_domain_sep_inv' | simp )+ - apply (simp add: set_irq_state_def, wp, simp) - apply (fastforce simp: domain_sep_inv_def domain_sep_inv_cap_def) - apply (fastforce simp: valid_def domain_sep_inv_def) - apply simp - apply (wp arch_invoke_irq_control_domain_sep_inv) - done - -lemma derive_cap_domain_sep_inv_cap: - "\\s. domain_sep_inv_cap irqs cap\ - derive_cap slot cap - \\rv s :: det_ext state. domain_sep_inv_cap irqs rv\,-" - apply (simp add: derive_cap_def) - apply (rule hoare_pre) - apply (wp | wpc | simp add: )+ - apply auto - done - -end - - crunch receive_signal, complete_signal for domain_sep_inv[wp]: "domain_sep_inv irqs st" @@ -850,7 +789,7 @@ lemma transfer_caps_domain_sep_inv: done -context DomainSepInv_2 begin +context DomainSepInv_1 begin lemma do_normal_transfer_domain_sep_inv: "\domain_sep_inv irqs st and valid_objs and valid_mdb\ @@ -918,8 +857,9 @@ lemma receive_ipc_domain_sep_inv: done lemma send_fault_ipc_domain_sep_inv: - "\domain_sep_inv irqs st and valid_objs and sym_refs \ state_refs_of - and valid_mdb and K (valid_fault fault)\ + "\domain_sep_inv irqs st and valid_objs and valid_mdb + and sym_refs \ state_refs_of + and K (valid_fault fault)\ send_fault_ipc thread fault \\_ s. domain_sep_inv irqs (st :: 'state_ext state) (s :: det_ext state)\" unfolding send_fault_ipc_def @@ -1035,7 +975,7 @@ lemma invoke_domain_domain_set_inv: done -context DomainSepInv_2 begin +context DomainSepInv_1 begin lemma invoke_tcb_domain_sep_inv: "\domain_sep_inv irqs st and tcb_inv_wf tinv\ @@ -1060,6 +1000,70 @@ lemma invoke_tcb_domain_sep_inv: del: set_priority_extended.dxo_eq)+ done +end + + +locale DomainSepInv_2 = DomainSepInv_1 state_ext_t + for state_ext_t :: "'state_ext :: state_ext itself" + + assumes arch_perform_invocation_domain_sep_inv[wp]: + "\domain_sep_inv irqs st and valid_arch_inv ai\ + arch_perform_invocation ai + \\_ s :: det_ext state. domain_sep_inv irqs st s\" + and arch_invoke_irq_handler_domain_sep_inv[wp]: + "arch_invoke_irq_handler ihi \\s :: det_ext state. domain_sep_inv irqs st s\" + and arch_invoke_irq_control_domain_sep_inv: + "\domain_sep_inv irqs st and arch_irq_control_inv_valid ivk\ + arch_invoke_irq_control ivk + \\_ s :: det_ext state. domain_sep_inv irqs st s\" + and handle_hypervisor_fault_domain_sep_inv[wp]: + "\domain_sep_inv irqs st and valid_objs and valid_mdb and sym_refs \ state_refs_of\ + handle_hypervisor_fault t hf_t + \\_ s :: det_ext state. domain_sep_inv irqs st s\" + and handle_reserved_irq_domain_sep_inv[wp]: + "\domain_sep_inv irqs st and valid_objs and valid_mdb and sym_refs \ state_refs_of\ + handle_reserved_irq irq + \\_ s :: det_ext state. domain_sep_inv irqs (st :: 'state_ext state) s\" +begin + +(* when i is AckIRQ the preconditions here contradict each other, which + is why this lemma is true *) +lemma invoke_irq_handler_domain_sep_inv: + "\domain_sep_inv irqs st and irq_handler_inv_valid i\ + invoke_irq_handler i + \\_ s. domain_sep_inv irqs (st :: 'state_ext state) (s :: det_ext state)\" + apply (case_tac i) + apply (wp cap_insert_domain_sep_inv' | simp)+ + apply (rename_tac irq cap cslot_ptr s) + apply (case_tac cap, simp_all add: domain_sep_inv_cap_def)[1] + apply (wp | clarsimp)+ + done + +(* similarly, the preconditions here tend to contradict one another *) +lemma invoke_control_domain_sep_inv: + "\domain_sep_inv irqs st and irq_control_inv_valid i\ + invoke_irq_control i + \\_ s. domain_sep_inv irqs (st :: 'state_ext state) (s :: det_ext state)\" + including classic_wp_pre + apply (case_tac i) + apply (case_tac irqs) + apply (wp cap_insert_domain_sep_inv' | simp )+ + apply (simp add: set_irq_state_def, wp, simp) + apply (fastforce simp: domain_sep_inv_def domain_sep_inv_cap_def) + apply (fastforce simp: valid_def domain_sep_inv_def) + apply simp + apply (wp arch_invoke_irq_control_domain_sep_inv) + done + +lemma derive_cap_domain_sep_inv_cap: + "\\s. domain_sep_inv_cap irqs cap\ + derive_cap slot cap + \\rv s :: det_ext state. domain_sep_inv_cap irqs rv\,-" + apply (simp add: derive_cap_def) + apply (rule hoare_pre) + apply (wp | wpc | simp add: )+ + apply auto + done + lemma perform_invocation_domain_sep_inv': "\domain_sep_inv irqs st and valid_invocation iv and valid_objs and valid_mdb and sym_refs \ state_refs_of\ @@ -1150,7 +1154,8 @@ lemma domain_sep_inv_cur_thread_update[simp]: lemma (in is_extended') domain_sep_inv[wp]: "I (domain_sep_inv irqs st)" by (rule lift_inv, simp) -context DomainSepInv_2 begin +context DomainSepInv_2 +begin lemma handle_recv_domain_sep_inv: "\domain_sep_inv irqs st and invs\ @@ -1181,35 +1186,30 @@ lemma handle_event_domain_sep_inv: "\domain_sep_inv irqs st and invs and (\s. ev \ Interrupt \ ct_active s)\ handle_event ev \\_ s. domain_sep_inv irqs (st :: 'state_ext state) (s :: det_ext state)\" - apply (case_tac ev, simp_all) - apply (rule hoare_pre) - apply (wpsimp wp: handle_send_domain_sep_inv handle_call_domain_sep_inv - handle_recv_domain_sep_inv handle_reply_domain_sep_inv hy_inv - | simp add: invs_valid_objs invs_mdb invs_sym_refs valid_fault_def)+ - apply (rule_tac E'="\rv s. domain_sep_inv irqs (st :: 'state_ext state) (s :: det_ext state) \ - invs s \ valid_fault rv" - and Q="Q" and Q'=Q for Q - in hoare_strengthen_postE) - apply (wp | simp add: invs_valid_objs invs_mdb invs_sym_refs valid_fault_def | auto)+ - done + apply (case_tac ev) + by (wpsimp wp: handle_send_domain_sep_inv handle_call_domain_sep_inv + handle_recv_domain_sep_inv handle_reply_domain_sep_inv hy_inv + | strengthen invs_valid_objs invs_mdb invs_sym_refs + | simp add: valid_fault_def + | wp hoare_drop_imps)+ lemma schedule_domain_sep_inv: "(schedule :: (unit,det_ext) s_monad) \domain_sep_inv irqs (st :: 'state_ext state)\" - apply (simp add: schedule_def allActiveTCBs_def) - apply (wp add: guarded_switch_to_lift hoare_drop_imps - del: ethread_get_wp - | wpc | clarsimp simp: get_thread_state_def thread_get_def trans_state_update'[symmetric] - schedule_choose_new_thread_def)+ - done + unfolding schedule_def allActiveTCBs_def + by (wp add: guarded_switch_to_lift hoare_drop_imps + del: ethread_get_wp + | wpc | clarsimp simp: get_thread_state_def thread_get_def trans_state_update'[symmetric] + schedule_choose_new_thread_def)+ lemma call_kernel_domain_sep_inv: "\domain_sep_inv irqs st and invs and (\s. ev \ Interrupt \ ct_active s)\ call_kernel ev :: (unit,det_ext) s_monad \\_ s. domain_sep_inv irqs (st :: 'state_ext state) s\" - apply (simp add: call_kernel_def) - apply (wp handle_interrupt_domain_sep_inv handle_event_domain_sep_inv schedule_domain_sep_inv - | simp)+ - done + unfolding call_kernel_def + by (wpsimp wp: handle_event_domain_sep_inv schedule_domain_sep_inv + simp: if_fun_split + | strengthen invs_valid_objs invs_mdb invs_sym_refs + | wp hoare_drop_imps)+ end diff --git a/proof/access-control/Finalise_AC.thy b/proof/access-control/Finalise_AC.thy index 36f064cfa3..488311bb13 100644 --- a/proof/access-control/Finalise_AC.thy +++ b/proof/access-control/Finalise_AC.thy @@ -23,9 +23,7 @@ NB: the @{term is_subject} assumption is not appropriate for some of locale Finalise_AC_1 = fixes aag :: "'a PAS" assumes sbn_st_vrefs: - "\P. \(\s. P (state_vrefs s)) and pspace_aligned and valid_vspace_objs and valid_arch_state\ - set_bound_notification ref ntfn - \\_ s :: det_ext state. P (state_vrefs s)\" + "\P. set_bound_notification ref ntfn \\s :: det_ext state. P (state_vrefs s)\" and arch_finalise_cap_auth': "\pas_refined aag\ arch_finalise_cap acap final \\rv _. pas_cap_cur_auth aag (fst rv)\" and arch_finalise_cap_obj_refs: @@ -48,12 +46,12 @@ locale Finalise_AC_1 = and prepare_thread_delete_pas_refined[wp]: "prepare_thread_delete p \pas_refined aag\" and prepare_thread_delete_respects[wp]: - "prepare_thread_delete p \integrity aag X st\" + "\integrity aag X st and K (is_subject aag p)\ prepare_thread_delete p \\_. integrity aag X st\" and finalise_cap_replaceable: "\\s :: det_ext state. s \ cap \ x = is_final_cap' cap s \ valid_mdb s \ cte_wp_at ((=) cap) sl s \ valid_objs s \ sym_refs (state_refs_of s) \ (cap_irqs cap \ {} \ if_unsafe_then_cap s \ valid_global_refs s) \ - (is_arch_cap cap \ pspace_aligned s \ valid_vspace_objs s \ + (is_arch_cap cap \ pspace_aligned s \ pspace_distinct s \ valid_vspace_objs s \ valid_arch_state s \ valid_arch_caps s)\ finalise_cap cap x \\rv s. replaceable s sl (fst rv) cap\" @@ -62,12 +60,6 @@ locale Finalise_AC_1 = and K (pas_cap_cur_auth aag (ArchObjectCap acap))\ arch_finalise_cap acap final \\_. integrity aag X st\" - and arch_post_cap_deletion[wp]: - "arch_post_cap_deletion acap \\s :: det_ext state. pspace_aligned s\" - and arch_post_cap_deletion_valid_vspace_objs[wp]: - "arch_post_cap_deletion acap \\s :: det_ext state. valid_vspace_objs s\" - and arch_post_cap_deletion_valid_arch_state[wp]: - "arch_post_cap_deletion acap \\s :: det_ext state. valid_arch_state s\" begin lemma tcb_sched_action_dequeue_integrity': @@ -250,7 +242,7 @@ crunch fast_finalise context Finalise_AC_1 begin lemma sbn_pas_refined[wp]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and + "\pas_refined aag and K (case ntfn of None \ True | Some ntfn' \ \auth \ {Receive, Reset}. abs_has_auth_to aag auth t ntfn')\ set_bound_notification t ntfn @@ -264,52 +256,29 @@ lemma sbn_pas_refined[wp]: split: if_split_asm) lemma unbind_notification_pas_refined[wp]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - unbind_notification tptr - \\_. pas_refined aag\" + "unbind_notification tptr \pas_refined aag\" apply (clarsimp simp: unbind_notification_def) apply (wp set_simple_ko_pas_refined hoare_drop_imps | wpc | simp)+ done lemma unbind_maybe_notification_pas_refined[wp]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - unbind_maybe_notification nptr \\_. pas_refined aag\" + "unbind_maybe_notification nptr \pas_refined aag\" apply (clarsimp simp: unbind_maybe_notification_def) apply (wp set_simple_ko_pas_refined hoare_drop_imps | wpc | simp)+ done lemma cancel_all_ipc_pas_refined[wp]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - cancel_all_ipc epptr - \\_. pas_refined aag\" + "cancel_all_ipc epptr \pas_refined aag\" apply (clarsimp simp: cancel_all_ipc_def get_ep_queue_def cong: endpoint.case_cong) - apply (rule_tac Q'="\_. pas_refined aag and pspace_aligned - and valid_vspace_objs - and valid_arch_state" - in hoare_strengthen_post) - apply (wpsimp wp: mapM_x_wp_inv set_thread_state_pas_refined get_simple_ko_wp)+ + apply (wpsimp wp: mapM_x_wp_inv set_thread_state_pas_refined get_simple_ko_wp)+ done lemma cancel_all_signals_pas_refined[wp]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and - valid_arch_state\ - cancel_all_signals ntfnptr - \\_. pas_refined aag\" + "cancel_all_signals ntfnptr \pas_refined aag\" apply (clarsimp simp: cancel_all_signals_def cong: ntfn.case_cong) - apply (rule_tac Q'="\_. pas_refined aag and pspace_aligned - and valid_vspace_objs - and valid_arch_state" - in hoare_strengthen_post) - apply (wpsimp wp: mapM_x_wp_inv set_thread_state_pas_refined get_simple_ko_wp)+ + apply (wpsimp wp: mapM_x_wp_inv set_thread_state_pas_refined get_simple_ko_wp)+ done -crunch unbind_maybe_notification, cancel_all_ipc, cancel_all_signals, - fast_finalise, blocked_cancel_ipc, cap_move - for pspace_aligned[wp]: pspace_aligned - and valid_vspace_objs[wp]: valid_vspace_objs - and valid_arch_state[wp]: valid_arch_state - (ignore: cap_move_ext tcb_sched_action reschedule_required wp: dxo_wp_weak mapM_x_inv_wp) - crunch cap_delete_one for pas_refined_transferable[wp_transferable]: "pas_refined aag" and pas_refined[wp, wp_not_transferable]: "pas_refined aag" @@ -368,12 +337,6 @@ lemma deleting_irq_handler_pas_refined[wp]: apply (fastforce simp: pas_refined_def irq_map_wellformed_aux_def) done -crunch suspend - for pspace_aligned[wp]: "\s :: det_ext state. pspace_aligned s" - and valid_vspace_objs[wp]: "\s :: det_ext state. valid_vspace_objs s" - and valid_arch_state[wp]: "\s :: det_ext state. valid_arch_state s" - (wp: dxo_wp_weak hoare_drop_imps simp: crunch_simps simp: tcb_cap_cases_def) - crunch suspend for pas_refined[wp]: "pas_refined aag" @@ -541,7 +504,6 @@ lemma reply_cancel_ipc_respects[wp]: thread_set_not_state_valid_sched hoare_weak_lift_imp thread_set_cte_wp_at_trivial thread_set_pas_refined simp: ran_tcb_cap_cases)+ - apply (strengthen invs_psp_aligned invs_vspace_objs invs_arch_state, clarsimp) apply (rule conjI) apply (fastforce simp: cte_wp_at_caps_of_state intro:is_transferable.intros dest!: reply_cap_descends_from_master0) @@ -594,7 +556,6 @@ lemma suspend_respects[wp]: apply (rule hoare_conjI) apply (wp hoare_drop_imps)+ apply wpsimp+ - apply fastforce done end @@ -997,9 +958,7 @@ lemma set_eobject_integrity_autarch: done lemma cancel_badged_sends_pas_refined[wp]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - cancel_badged_sends epptr badge - \\_. pas_refined aag\" + "cancel_badged_sends epptr badge \pas_refined aag\" unfolding cancel_badged_sends_def by (wpsimp simp: filterM_mapM wp: mapM_wp_inv set_thread_state_pas_refined get_simple_ko_wp) @@ -1015,8 +974,7 @@ lemma thread_set_pas_refined_triv_idleT: and st: "\tcb. P (tcb_state tcb) \ tcb_state (f tcb) = tcb_state tcb" and ba: "\tcb. Q (tcb_bound_notification tcb) \ tcb_bound_notification (f tcb) = tcb_bound_notification tcb" - shows "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and idle_tcb_at (\(st, ntfn, arch). P st \ Q ntfn \ R arch) t\ + shows "\pas_refined aag and idle_tcb_at (\(st, ntfn, arch). P st \ Q ntfn \ R arch) t\ thread_set f t \\_. pas_refined aag\" apply (simp add: pas_refined_def state_objs_to_policy_def) @@ -1026,10 +984,7 @@ lemma thread_set_pas_refined_triv_idleT: apply (wpsimp wp: set_object_wp) apply (clarsimp simp: pred_tcb_def2 fun_upd_def[symmetric] del: subsetI) - apply (subst state_vrefs_tcb_upd, fastforce+) - apply (clarsimp simp: tcb_at_def) - apply (subst state_vrefs_tcb_upd, fastforce+) - apply (clarsimp simp: tcb_at_def) + apply (subst state_vrefs_tcb_upd, clarsimp simp: tcb_at_def)+ apply (rule conjI) apply (erule_tac P="\ ts ba. auth_graph_map a (state_bits_to_policy cps ts ba cd vr) \ ag" for a cps cd vr ag in rsubst') diff --git a/proof/access-control/Interrupt_AC.thy b/proof/access-control/Interrupt_AC.thy index 42dee66806..19e434a611 100644 --- a/proof/access-control/Interrupt_AC.thy +++ b/proof/access-control/Interrupt_AC.thy @@ -30,8 +30,7 @@ lemma pas_refined_is_subject_irqD: locale Interrupt_AC_1 = fixes arch_authorised_irq_ctl_inv :: "'a PAS \ arch_irq_control_invocation \ bool" assumes arch_invoke_irq_control_pas_refined: - "\pas_refined (aag :: 'a PAS) and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_mdb and arch_irq_control_inv_valid irq_ctl_inv + "\pas_refined (aag :: 'a PAS) and valid_mdb and arch_irq_control_inv_valid irq_ctl_inv and K (arch_authorised_irq_ctl_inv aag irq_ctl_inv)\ arch_invoke_irq_control irq_ctl_inv \\_. pas_refined aag\" @@ -59,8 +58,7 @@ definition authorised_irq_ctl_inv :: "'a PAS \ Invocations_A.irq_con | ArchIRQControl acinv \ arch_authorised_irq_ctl_inv aag acinv" lemma invoke_irq_control_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_mdb and irq_control_inv_valid irq_ctl_inv + "\pas_refined aag and valid_mdb and irq_control_inv_valid irq_ctl_inv and K (authorised_irq_ctl_inv aag irq_ctl_inv)\ invoke_irq_control irq_ctl_inv \\_. pas_refined aag\" diff --git a/proof/access-control/Ipc_AC.thy b/proof/access-control/Ipc_AC.thy index eb7a8cc056..4289021a27 100644 --- a/proof/access-control/Ipc_AC.thy +++ b/proof/access-control/Ipc_AC.thy @@ -67,15 +67,13 @@ crunch possible_switch_to for tcb_domain_map_wellformed[wp]: "tcb_domain_map_wellformed aag" lemma update_waiting_ntfn_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and ko_at (Notification ntfn) ntfnptr and K (ntfn_obj ntfn = WaitingNtfn queue)\ + "\pas_refined aag and ko_at (Notification ntfn) ntfnptr and K (ntfn_obj ntfn = WaitingNtfn queue)\ update_waiting_ntfn ntfnptr queue badge val \\_. pas_refined aag\" by (wpsimp wp: set_thread_state_pas_refined set_simple_ko_pas_refined simp: update_waiting_ntfn_def) lemma cancel_ipc_receive_blocked_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs - and valid_arch_state and st_tcb_at receive_blocked t\ + "\pas_refined aag and st_tcb_at receive_blocked t\ cancel_ipc t \\_. pas_refined aag\" apply (clarsimp simp: cancel_ipc_def) @@ -85,9 +83,7 @@ lemma cancel_ipc_receive_blocked_pas_refined: done lemma send_signal_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - send_signal ntfnptr badge - \\_. pas_refined aag\" + "send_signal ntfnptr badge \pas_refined aag\" apply (simp add: send_signal_def) apply (rule bind_wp[OF _ get_simple_ko_sp]) apply (wpsimp wp: set_simple_ko_pas_refined update_waiting_ntfn_pas_refined gts_wp @@ -96,8 +92,7 @@ lemma send_signal_pas_refined: done lemma receive_signal_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and K (\ntfnptr \ obj_refs_ac cap. abs_has_auth_to aag Receive thread ntfnptr)\ + "\pas_refined aag and K (\ntfnptr \ obj_refs_ac cap. abs_has_auth_to aag Receive thread ntfnptr)\ receive_signal thread cap is_blocking \\_. pas_refined aag\" apply (simp add: receive_signal_def) @@ -172,9 +167,6 @@ locale Ipc_AC_1 = "\P. make_fault_msg ft t \\s :: det_ext state. P s\" and tcb_context_no_change: "\ctxt. (tcb :: tcb) = tcb\tcb_arch := arch_tcb_context_set ctxt (tcb_arch tcb)\" - (* This assumption excludes x64 (its valid_arch_state includes caps) *) - and transfer_caps_loop_valid_arch[wp]: - "transfer_caps_loop ep buffer n caps slots mi \valid_arch_state :: det_ext state \ _\" begin lemma send_upd_ctxintegrity: @@ -736,8 +728,7 @@ lemma derive_cap_is_derived_foo': lemma transfer_caps_loop_presM_extended: fixes P vo em ex buffer slots caps n mi assumes x: "\cap src dest. - \\s. P s \ (vo \ pspace_aligned s \ valid_vspace_objs s \ valid_arch_state s - \ valid_objs s \ valid_mdb s \ real_cte_at dest s + \\s. P s \ (vo \ valid_objs s \ valid_mdb s \ real_cte_at dest s \ s \ cap \ Psrc src \ Pdest dest \ Pcap cap \ tcb_cap_valid cap dest s \ real_cte_at src s \ cte_wp_at (is_derived (cdt s) src cap) src s @@ -748,8 +739,7 @@ lemma transfer_caps_loop_presM_extended: \\_ s :: det_ext state. P s\" assumes eb: "\b n. set_extra_badge buffer b n \P\" assumes pcap_auth_derived: "\cap cap'. \ auth_derived cap cap'; Pcap cap' \ \ Pcap cap" - shows "\\s. P s \ (vo \ pspace_aligned s \ valid_vspace_objs s \ valid_arch_state s - \ valid_objs s \ valid_mdb s \ distinct slots + shows "\\s. P s \ (vo \ valid_objs s \ valid_mdb s \ distinct slots \ (\x \ set slots. cte_wp_at (\cap. cap = NullCap) x s \ real_cte_at x s \ Pdest x) \ (\x \ set caps. valid_cap (fst x) s \ Psrc (snd x) \ Pcap (fst x) @@ -807,8 +797,7 @@ lemma transfer_caps_loop_presM_extended: by (clarsimp simp: masked_as_full_def is_cap_simps split: if_splits)+ lemma transfer_caps_loop_pas_refined: - "\\s. pas_refined aag s \ pspace_aligned s \ valid_vspace_objs s \ - valid_arch_state s \ valid_objs s \ valid_mdb s \ + "\\s. pas_refined aag s \ valid_objs s \ valid_mdb s \ (\x \ set caps. valid_cap (fst x) s \ real_cte_at (snd x) s \ cte_wp_at (\cp. fst x \ NullCap \ cp = fst x) (snd x) s) \ (\x\set slots. real_cte_at x s \ cte_wp_at (\cap. cap = NullCap) x s) \ @@ -831,8 +820,7 @@ lemma transfer_caps_loop_pas_refined: done lemma transfer_caps_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs - and valid_arch_state and valid_objs and valid_mdb + "\pas_refined aag and valid_objs and valid_mdb and (\s. (\x \ set caps. valid_cap (fst x) s \ cte_wp_at (\cp. fst x \ NullCap \ cp = fst x) (snd x) s \ real_cte_at (snd x) s)) @@ -849,16 +837,9 @@ lemma transfer_caps_pas_refined: end lemma copy_mrs_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - copy_mrs sender sbuf receiver rbuf n - \\_. pas_refined aag\" + "copy_mrs sender sbuf receiver rbuf n \pas_refined aag\" unfolding copy_mrs_def - apply (rule_tac Q'="\_. pas_refined aag and pspace_aligned - and valid_vspace_objs - and valid_arch_state" - in hoare_strengthen_post[rotated], clarsimp) - apply (wpsimp wp: mapM_wp_inv) - done + by (wpsimp wp: mapM_wp_inv) lemma lookup_cap_and_slot_authorised: "\pas_refined aag and K (is_subject aag thread)\ @@ -916,13 +897,8 @@ context Ipc_AC_1 begin crunch do_fault_transfer for pas_refined[wp]: "\s :: det_ext state. pas_refined aag s" -crunch transfer_caps, copy_mrs - for valid_arch_state[wp]: "valid_arch_state :: det_ext state \ _" - (wp: crunch_wps) - lemma do_normal_transfer_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_objs and valid_mdb + "\pas_refined aag and valid_objs and valid_mdb and K (grant \ is_subject aag sender) and K (grant \ is_subject aag receiver)\ do_normal_transfer sender sbuf endpoint badge grant receiver rbuf @@ -945,8 +921,7 @@ next qed lemma do_ipc_transfer_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_objs and valid_mdb + "\pas_refined aag and valid_objs and valid_mdb and K (grant \ is_subject aag sender) and K (grant \ is_subject aag receiver)\ do_ipc_transfer sender ep badge grant receiver @@ -959,7 +934,7 @@ end (* FIXME MOVE*) lemma cap_insert_pas_refined_transferable: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and valid_mdb and + "\pas_refined aag and valid_mdb and K (is_transferable_cap new_cap \ aag_cap_auth aag (pasObjectAbs aag (fst dest_slot)) new_cap \ abs_has_auth_to aag DeleteDerived (fst src_slot) (fst dest_slot))\ cap_insert new_cap src_slot dest_slot @@ -982,7 +957,7 @@ lemma cap_insert_pas_refined_transferable: intro: aag_wellformed_delete_derived_trans[OF _ _ pas_refined_wellformed]) lemma setup_caller_cap_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and valid_mdb and + "\pas_refined aag and valid_mdb and K ((grant \ is_subject aag sender \ is_subject aag receiver) \ abs_has_auth_to aag Reply receiver sender)\ setup_caller_cap sender receiver grant @@ -1061,12 +1036,11 @@ lemma send_ipc_pas_refined: apply (wpc | wp set_thread_state_pas_refined)+ apply (simp add: hoare_if_r_and split del:if_split) apply (wp setup_caller_cap_pas_refined set_thread_state_pas_refined)+ - apply (simp split del:if_split) - apply (rule_tac Q'="\rv. pas_refined aag and pspace_aligned and valid_vspace_objs and - valid_arch_state and valid_mdb and - K (can_grant \ can_grant_reply - \ (reply_can_grant \ is_subject aag x21) \ - (pasObjectAbs aag x21, Reply, pasSubject aag) \ pasPolicy aag)" + apply (simp split del: if_split) + apply (rule_tac Q'="\rv. pas_refined aag and valid_mdb and + K (can_grant \ can_grant_reply + \ (reply_can_grant \ is_subject aag x21) \ + (pasObjectAbs aag x21, Reply, pasSubject aag) \ pasPolicy aag)" in hoare_strengthen_post[rotated]) apply simp apply (wp set_thread_state_pas_refined do_ipc_transfer_pas_refined hoare_weak_lift_imp gts_wp @@ -1180,8 +1154,7 @@ lemma receive_ipc_sender_can_grant_helper: done lemma complete_signal_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and bound_tcb_at ((=) (Some ntfnptr)) thread\ + "\pas_refined aag and bound_tcb_at ((=) (Some ntfnptr)) thread\ complete_signal ntfnptr thread \\_. pas_refined aag\" apply (simp add: complete_signal_def) @@ -1207,8 +1180,7 @@ lemma receive_ipc_base_pas_refined: apply (wp set_thread_state_pas_refined get_simple_ko_wp setup_caller_cap_pas_refined | wpc | simp add: thread_get_def do_nbrecv_failed_transfer_def split del: if_split)+ apply (rename_tac list sss data) - apply (rule_tac Q'="\rv s. pas_refined aag s \ pspace_aligned s \ valid_vspace_objs s \ - valid_arch_state s \ valid_mdb s \ + apply (rule_tac Q'="\rv s. pas_refined aag s \ valid_mdb s \ (sender_can_grant data \ is_subject aag (hd list)) \ (sender_can_grant_reply data \ (AllowGrant \ rights \ is_subject aag (hd list)) \ @@ -1286,7 +1258,6 @@ lemma receive_ipc_pas_refined: apply (rule bind_wp[OF _ get_simple_ko_sp]) apply (case_tac "isActive ntfn", simp_all) apply (wp complete_signal_pas_refined, clarsimp) - apply fastforce (* regular case again *) apply (rule hoare_pre, wp receive_ipc_base_pas_refined) apply (fastforce simp: aag_cap_auth_def cap_auth_conferred_def cap_rights_to_auth_def) @@ -1365,8 +1336,7 @@ lemma transfer_caps_integrity_autarch: lemma do_normal_transfer_send_integrity_autarch: notes lec_valid_cap[wp del] shows - "\pas_refined aag and integrity aag X st and pspace_aligned and - valid_vspace_objs and valid_arch_state and valid_objs and valid_mdb and + "\pas_refined aag and integrity aag X st and valid_objs and valid_mdb and K (is_subject aag receiver \ ipc_buffer_has_auth aag receiver rbuf \ (grant \ is_subject aag sender))\ do_normal_transfer sender sbuf endpoint badge grant receiver rbuf @@ -1390,8 +1360,7 @@ lemma do_fault_transfer_integrity_autarch: set_mrs_integrity_autarch thread_get_wp') lemma do_ipc_transfer_integrity_autarch: - "\pas_refined aag and integrity aag X st and - pspace_aligned and valid_vspace_objs and valid_arch_state and valid_objs and valid_mdb and + "\pas_refined aag and integrity aag X st and valid_objs and valid_mdb and K (is_subject aag receiver \ (grant \ is_subject aag sender))\ do_ipc_transfer sender ep badge grant receiver \\_. integrity aag X st\" @@ -1768,12 +1737,6 @@ locale Ipc_AC_2 = Ipc_AC_1 + and handle_arch_fault_reply_integrity_tcb_in_fault_reply_TRFContext[wp]: "handle_arch_fault_reply vmf thread x y \integrity_tcb_in_fault_reply aag X thread TRFContext st\" - and handle_arch_fault_reply_pspace_aligned[wp]: - "handle_arch_fault_reply vmf thread x y \\s :: det_ext state. pspace_aligned s\" - and handle_arch_fault_reply_valid_vspace_objs[wp]: - "handle_arch_fault_reply vmf thread x y \\s :: det_ext state. valid_vspace_objs s\" - and handle_arch_fault_reply_valid_arch_state[wp]: - "handle_arch_fault_reply vmf thread x y \\s :: det_ext state. valid_arch_state s\" and cap_insert_ext_integrity_asids_in_ipc[wp]: "cap_insert_ext src_parent src_slot dest_slot src_p dest_p \\s. integrity_asids aag subjects x asid st @@ -2072,8 +2035,7 @@ lemma do_normal_transfer_respects_in_ipc: notes lec_valid_cap[wp del] shows "\integrity_tcb_in_ipc aag X receiver epptr TRContext st and pas_refined aag and - pspace_aligned and valid_vspace_objs and valid_arch_state and -valid_objs and valid_mdb and st_tcb_at can_receive_ipc receiver and + valid_objs and valid_mdb and st_tcb_at can_receive_ipc receiver and (\s. grant \ is_subject aag sender \ is_subject aag receiver) and K ((\ is_subject aag receiver \ (case recv_buf of None \ True | Some buf' \ auth_ipc_buffers st receiver = @@ -2105,7 +2067,6 @@ lemma do_fault_transfer_respects_in_ipc: lemma do_ipc_transfer_respects_in_ipc: "\integrity_tcb_in_ipc aag X receiver epptr TRContext st and pas_refined aag and - pspace_aligned and valid_vspace_objs and valid_arch_state and valid_objs and valid_mdb and st_tcb_at can_receive_ipc receiver and (\s. grant \ is_subject aag sender \ is_subject aag receiver)\ do_ipc_transfer sender epopt badge grant receiver @@ -2330,7 +2291,7 @@ lemma setup_caller_cap_respects_in_ipc_reply: by (wpsimp wp: cap_insert_reply_cap_respects_in_ipc set_thread_state_respects_in_ipc_autarch) lemma send_ipc_integrity_autarch: - "\integrity aag X st and pas_refined aag and invs and is_subject aag \ cur_thread and + "\integrity aag X st and pas_refined aag and invs and obj_at (\ep. can_grant \ (\r \ refs_of ep. snd r = EPRecv \ is_subject aag (fst r))) epptr and K (is_subject aag sender \ aag_has_auth_to aag SyncSend epptr \ (can_grant_reply \ aag_has_auth_to aag Call epptr))\ @@ -2409,15 +2370,13 @@ lemma valid_tcb_fault_update: context Ipc_AC_2 begin lemma thread_set_fault_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ + "\pas_refined aag\ thread_set (tcb_fault_update (\_. Some fault)) thread \\_. pas_refined aag\" - by (wpsimp wp: send_ipc_pas_refined thread_set_pas_refined - thread_set_refs_trivial thread_set_obj_at_impossible) + by (wpsimp wp: thread_set_pas_refined) lemma send_fault_ipc_pas_refined: - "\pas_refined aag and invs and is_subject aag \ cur_thread - and K (valid_fault fault) and K (is_subject aag thread)\ + "\pas_refined aag and invs and K (valid_fault fault) and K (is_subject aag thread)\ send_fault_ipc thread fault \\_. pas_refined aag\" apply (rule hoare_gen_asm)+ @@ -2426,8 +2385,7 @@ lemma send_fault_ipc_pas_refined: thread_set_refs_trivial thread_set_obj_at_impossible get_cap_wp thread_set_valid_objs'' hoare_vcg_conj_lift hoare_vcg_ex_lift hoare_vcg_all_lift simp: split_def) - apply (rule_tac Q'="\rv s. pas_refined aag s \ is_subject aag (cur_thread s) \ - invs s \ valid_fault fault \ is_subject aag (fst (fst rv))" + apply (rule_tac Q'="\rv s. pas_refined aag s \ invs s \ valid_fault fault \ is_subject aag (fst (fst rv))" in hoare_strengthen_postE_R[rotated]) apply (fastforce dest!: cap_auth_caps_of_state simp: invs_valid_objs invs_sym_refs cte_wp_at_caps_of_state aag_cap_auth_def @@ -2437,8 +2395,7 @@ lemma send_fault_ipc_pas_refined: done lemma handle_fault_pas_refined: - "\pas_refined aag and invs and is_subject aag \ cur_thread - and K (valid_fault fault) and K (is_subject aag thread)\ + "\pas_refined aag and invs and K (valid_fault fault) and K (is_subject aag thread)\ handle_fault thread fault \\_. pas_refined aag\" apply (wpsimp wp: set_thread_state_pas_refined simp: handle_fault_def handle_double_fault_def) @@ -2449,7 +2406,6 @@ lemma handle_fault_pas_refined: apply (rule hoare_strengthen_postE[where E'=E and E=E for E]) apply (rule valid_validE) apply (wpsimp wp: send_fault_ipc_pas_refined)+ - apply fastforce done end @@ -2471,7 +2427,7 @@ lemma obj_at_conj_distrib: context Ipc_AC_2 begin lemma send_fault_ipc_integrity_autarch: - "\pas_refined aag and invs and integrity aag X st and is_subject aag \ cur_thread + "\pas_refined aag and invs and integrity aag X st and K (valid_fault fault) and K (is_subject aag thread)\ send_fault_ipc thread fault \\_. integrity aag X st\" @@ -2492,7 +2448,6 @@ lemma send_fault_ipc_integrity_autarch: apply (rule_tac Q'="\rv s. integrity aag X st s \ pas_refined aag s \ invs s \ valid_fault fault - \ is_subject aag (cur_thread s) \ is_subject aag (fst (fst rv))" in hoare_strengthen_postE_R[rotated]) apply (clarsimp simp: invs_valid_objs invs_sym_refs cte_wp_at_caps_of_state obj_at_def) @@ -2512,7 +2467,7 @@ lemma send_fault_ipc_integrity_autarch: done lemma handle_fault_integrity_autarch: - "\pas_refined aag and integrity aag X st and is_subject aag \ cur_thread and invs + "\integrity aag X st and pas_refined aag and invs and K (valid_fault fault) and K (is_subject aag thread)\ handle_fault thread fault \\_. integrity aag X st\" @@ -2533,12 +2488,6 @@ lemma tcb_st_to_auth_Restart_Inactive [simp]: context Ipc_AC_2 begin -crunch handle_fault_reply - for pspace_aligned[wp]: "\s :: det_ext state. pspace_aligned s" - and valid_vspace_objs[wp]: "\s :: det_ext state. valid_vspace_objs s" - and valid_arch_state[wp]: "\s :: det_ext state. valid_arch_state s" - (wp: arch_get_sanitise_register_info_inv) - lemma do_reply_transfer_pas_refined: "\pas_refined aag and invs and K (is_subject aag sender) and K ((grant \ is_subject aag receiver) \ is_subject aag (fst slot))\ diff --git a/proof/access-control/RISCV64/ArchArch_AC.thy b/proof/access-control/RISCV64/ArchArch_AC.thy index 4519236a7b..90075ebf16 100644 --- a/proof/access-control/RISCV64/ArchArch_AC.thy +++ b/proof/access-control/RISCV64/ArchArch_AC.thy @@ -19,20 +19,13 @@ context Arch begin global_naming RISCV64 named_theorems Arch_AC_assms lemma set_mrs_state_vrefs[Arch_AC_assms, wp]: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ - set_mrs thread buf msgs - \\_ s. P (state_vrefs s)\" + "set_mrs thread buf msgs \\s. P (state_vrefs s)\" apply (simp add: set_mrs_def split_def set_object_def get_object_def split del: if_split) apply (wpsimp wp: gets_the_wp get_wp put_wp mapM_x_wp' simp: zipWithM_x_mapM_x split_def store_word_offs_def split_del: if_split) - apply (subst state_vrefs_eqI) - prefer 7 - apply assumption - apply (clarsimp simp: opt_map_def) - apply (fastforce simp: opt_map_def aobj_of_def) - apply clarsimp - apply (auto simp: valid_arch_state_def) + apply (subst (asm) state_vrefs_tcb_upd[symmetric]) + apply (auto simp: fun_upd_def get_tcb_def tcb_at_def) done lemma mul_add_word_size_lt_msg_align_bits_ofnat[Arch_AC_assms]: @@ -503,11 +496,9 @@ lemma perform_pt_inv_unmap_pas_refined: \\_. pas_refined aag\" unfolding perform_pt_inv_unmap_def apply (wpsimp wp: set_cap_pas_refined get_cap_wp) - apply (strengthen invs_psp_aligned invs_vspace_objs invs_arch_state) apply wps apply (rule hoare_vcg_all_lift[OF hoare_vcg_imp_lift'[OF mapM_x_wp_inv]], wpsimp wp: mapM_x_wp_inv) apply (rule hoare_vcg_conj_lift[OF hoare_strengthen_post[OF mapM_x_swp_store_InvalidPTE_pas_refined]], assumption) - apply (rule hoare_vcg_conj_lift[OF hoare_strengthen_post[OF mapM_x_swp_store_pte_invs_unmap]], assumption) apply (wpsimp wp: pt_lookup_from_level_wrp store_pte_invs_unmap store_pte_pas_refined mapM_x_wp_inv unmap_page_table_pas_refined hoare_vcg_imp_lift' hoare_vcg_ball_lift hoare_vcg_all_lift)+ diff --git a/proof/access-control/RISCV64/ArchCNode_AC.thy b/proof/access-control/RISCV64/ArchCNode_AC.thy index 39053ab651..38662c773e 100644 --- a/proof/access-control/RISCV64/ArchCNode_AC.thy +++ b/proof/access-control/RISCV64/ArchCNode_AC.thy @@ -56,29 +56,28 @@ lemma sata_update2[CNode_AC_assms]: simp: cap_links_asid_slot_def label_owns_asid_slot_def split: if_split_asm) +lemma vs_lookup_table_eqI': + "\ asid_table s' (asid_high_bits_of asid) = asid_table s (asid_high_bits_of asid); + \pool_ptr. asid_table s' (asid_high_bits_of asid) = Some pool_ptr + \ bot_level \ max_pt_level + \ vspace_for_pool pool_ptr asid (asid_pools_of s') = + vspace_for_pool pool_ptr asid (asid_pools_of s); + bot_level < max_pt_level \ pts_of s' = pts_of s \ + \ vs_lookup_table bot_level asid vref s' = vs_lookup_table bot_level asid vref s" + by (auto simp: obind_def vs_lookup_table_def asid_pool_level_eq[symmetric] + pool_for_asid_def vspace_for_pool_def + split: option.splits) + lemma state_vrefs_eqI: - "\ \bot_level asid vref level p. - bot_level < level \ vs_lookup_table level asid vref s = Some (level, p) - \ (if level \ max_pt_level - then pts_of s' p = pts_of s p - else asid_pools_of s' p = asid_pools_of s p); - aobjs_of s' = aobjs_of s; asid_table s' = asid_table s; - pspace_aligned s; valid_vspace_objs s; valid_asid_table s \ - \ state_vrefs (s' :: 'a :: state_ext state) = state_vrefs (s :: 'a :: state_ext state)" - apply (rule ext) - apply safe - apply (subst (asm) state_vrefs_def, clarsimp) - apply (fastforce intro: state_vrefsD elim: subst[OF vs_lookup_table_eqI,rotated -1]) - apply (subst (asm) state_vrefs_def, clarsimp) - apply (rule state_vrefsD) - apply (subst vs_lookup_table_eqI; fastforce) - apply fastforce+ - done + assumes "asid_table s' = asid_table s" + and "aobjs_of s' = aobjs_of s" + shows "state_vrefs s' = state_vrefs s" + apply (prop_tac "\level asid vref. vs_lookup_table level asid vref s = vs_lookup_table level asid vref s'") + apply (intro allI vs_lookup_table_eqI') + using assms by (auto simp: vspace_for_pool_def state_vrefs_def) lemma set_cap_state_vrefs[CNode_AC_assms, wp]: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ - set_cap cap slot - \\_ s :: det_ext state. P (state_vrefs s)\" + "set_cap cap slot \\s :: det_ext state. P (state_vrefs s)\" apply (simp add: set_cap_def set_object_def) apply (wpsimp wp: get_object_wp) apply safe @@ -100,14 +99,12 @@ crunch prepare_thread_delete, arch_finalise_cap (wp: crunch_wps hoare_vcg_if_lift2 simp: unless_def) lemma state_vrefs_tcb_upd[CNode_AC_assms]: - "\ pspace_aligned s; valid_vspace_objs s; valid_arch_state s; tcb_at t s \ - \ state_vrefs (s\kheap := (kheap s)(t \ TCB tcb)\) = state_vrefs s" + "tcb_at t s \ state_vrefs (s\kheap := (kheap s)(t \ TCB tcb)\) = state_vrefs s" apply (rule state_vrefs_eqI) by (fastforce simp: opt_map_def obj_at_def is_obj_defs valid_arch_state_def)+ lemma state_vrefs_simple_type_upd[CNode_AC_assms]: - "\ pspace_aligned s; valid_vspace_objs s; valid_arch_state s; - ko_at ko ptr s; is_simple_type ko; a_type ko = a_type (f val) \ + "\ ko_at ko ptr s; is_simple_type ko; a_type ko = a_type (f val) \ \ state_vrefs (s\kheap := (kheap s)(ptr \ f val)\) = state_vrefs s" apply (case_tac ko; case_tac "f val"; clarsimp) by (fastforce intro!: state_vrefs_eqI simp: opt_map_def obj_at_def is_obj_defs valid_arch_state_def)+ diff --git a/proof/access-control/RISCV64/ArchDomainSepInv.thy b/proof/access-control/RISCV64/ArchDomainSepInv.thy index 6d295b84e4..f749c22af8 100644 --- a/proof/access-control/RISCV64/ArchDomainSepInv.thy +++ b/proof/access-control/RISCV64/ArchDomainSepInv.thy @@ -25,6 +25,26 @@ lemma arch_finalise_cap_rv[DomainSepInv_assms]: "\\_. P (NullCap,NullCap)\ arch_finalise_cap c x \\rv _. P rv\" unfolding arch_finalise_cap_def by wpsimp +crunch + handle_reserved_irq, handle_vm_fault, perform_pg_inv_map, perform_pg_inv_unmap, + perform_pg_inv_get_addr, perform_pt_inv_map, perform_pt_inv_unmap, + handle_hypervisor_fault, handle_arch_fault_reply, arch_mask_irq_signal, + arch_switch_to_thread, arch_switch_to_idle_thread, arch_activate_idle_thread, + store_asid_pool_entry, copy_global_mappings + for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" + (wp: crunch_wps) + +lemma arch_derive_cap_domain_sep_inv[DomainSepInv_assms, wp]: + "\\\ arch_derive_cap acap \\rv _. domain_sep_inv_cap irqs rv\,-" + unfolding arch_derive_cap_def + by wpsimp + +lemma arch_post_modify_registers_domain_sep_inv[DomainSepInv_assms, wp]: + "arch_post_modify_registers cur t \domain_sep_inv irqs st\" + unfolding arch_post_modify_registers_def by wpsimp + +declare init_arch_objects_inv[DomainSepInv_assms] + end @@ -32,21 +52,12 @@ global_interpretation DomainSepInv_1?: DomainSepInv_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact DomainSepInv_assms | wp init_arch_objects_inv)) + by (unfold_locales; fact DomainSepInv_assms) qed context Arch begin global_naming RISCV64 -crunch - handle_reserved_irq, handle_vm_fault, perform_pg_inv_map, perform_pg_inv_unmap, - perform_pg_inv_get_addr, perform_pt_inv_map, perform_pt_inv_unmap, - handle_hypervisor_fault, handle_arch_fault_reply, arch_mask_irq_signal, - arch_switch_to_thread, arch_switch_to_idle_thread, arch_activate_idle_thread, - store_asid_pool_entry, copy_global_mappings - for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" - (wp: crunch_wps) - lemma perform_page_invocation_domain_sep_inv: "\domain_sep_inv irqs st and valid_page_inv pgi\ perform_page_invocation pgi @@ -112,15 +123,6 @@ lemma arch_invoke_irq_control_domain_sep_inv[DomainSepInv_assms]: apply (wpsimp wp: do_machine_op_domain_sep_inv simp: arch_irq_control_inv_valid_def)+ done -lemma arch_derive_cap_domain_sep_inv[DomainSepInv_assms, wp]: - "\\\ arch_derive_cap acap \\rv _. domain_sep_inv_cap irqs rv\,-" - unfolding arch_derive_cap_def - by wpsimp - -lemma arch_post_modify_registers_domain_sep_inv[DomainSepInv_assms, wp]: - "arch_post_modify_registers cur t \domain_sep_inv irqs st\" - unfolding arch_post_modify_registers_def by wpsimp - end @@ -128,7 +130,7 @@ global_interpretation DomainSepInv_2?: DomainSepInv_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; fact DomainSepInv_assms) + by (unfold_locales; wpsimp wp: DomainSepInv_assms) qed end diff --git a/proof/access-control/RISCV64/ArchFinalise_AC.thy b/proof/access-control/RISCV64/ArchFinalise_AC.thy index c523ccf513..7c769a04cd 100644 --- a/proof/access-control/RISCV64/ArchFinalise_AC.thy +++ b/proof/access-control/RISCV64/ArchFinalise_AC.thy @@ -111,9 +111,7 @@ crunch prepare_thread_delete for respects[Finalise_AC_assms, wp]: "integrity aag X st" lemma sbn_st_vrefs[Finalise_AC_assms]: - "\(\s. P (state_vrefs s)) and pspace_aligned and valid_vspace_objs and valid_arch_state\ - set_bound_notification t st - \\_ s. P (state_vrefs s)\" + "set_bound_notification t st \\s. P (state_vrefs s)\" apply (simp add: set_bound_notification_def) apply (wpsimp wp: set_object_wp dxo_wp_weak) apply (subst state_vrefs_tcb_upd) @@ -216,7 +214,7 @@ lemma delete_asid_respects: apply (clarsimp simp: pas_refined_refl obj_at_def asid_pool_integrity_def) done -lemma arch_finalise_cap_respects[wp]: +lemma arch_finalise_cap_respects[Finalise_AC_assms, wp]: "\integrity aag X st and invs and pas_refined aag and valid_cap (ArchObjectCap cap) and K (pas_cap_cur_auth aag (ArchObjectCap cap))\ arch_finalise_cap cap final @@ -229,10 +227,11 @@ lemma arch_finalise_cap_respects[wp]: intro: pas_refined_Control_into_is_subject_asid) done -crunch arch_post_cap_deletion - for pspace_aligned[Finalise_AC_assms, wp]: "\s :: det_ext state. pspace_aligned s" - and valid_vspace_objs[Finalise_AC_assms, wp]: "\s :: det_ext state. valid_vspace_objs s" - and valid_arch_state[Finalise_AC_assms, wp]: "\s :: det_ext state. valid_arch_state s" +declare prepare_thread_delete_st_tcb_at_halted[Finalise_AC_assms] +declare finalise_cap_valid_list[Finalise_AC_assms] +declare arch_finalise_cap_pas_refined[Finalise_AC_assms] +declare prepare_thread_delete_pas_refined[Finalise_AC_assms] +declare finalise_cap_replaceable[Finalise_AC_assms] end @@ -241,7 +240,7 @@ global_interpretation Finalise_AC_1?: Finalise_AC_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Finalise_AC_assms | wp finalise_cap_replaceable)) + by (unfold_locales; wpsimp wp: Finalise_AC_assms) qed diff --git a/proof/access-control/RISCV64/ArchInterrupt_AC.thy b/proof/access-control/RISCV64/ArchInterrupt_AC.thy index 09ff7a783c..938d3bc052 100644 --- a/proof/access-control/RISCV64/ArchInterrupt_AC.thy +++ b/proof/access-control/RISCV64/ArchInterrupt_AC.thy @@ -21,8 +21,7 @@ definition arch_authorised_irq_ctl_inv :: (pasSubject aag, Control, pasIRQAbs aag irq) \ pasPolicy aag" lemma arch_invoke_irq_control_pas_refined[Interrupt_AC_assms]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_mdb and arch_irq_control_inv_valid irq_ctl_inv + "\pas_refined aag and valid_mdb and arch_irq_control_inv_valid irq_ctl_inv and K (arch_authorised_irq_ctl_inv aag irq_ctl_inv)\ arch_invoke_irq_control irq_ctl_inv \\_. pas_refined aag\" diff --git a/proof/access-control/RISCV64/ArchIpc_AC.thy b/proof/access-control/RISCV64/ArchIpc_AC.thy index 211262fde4..30a9994e71 100644 --- a/proof/access-control/RISCV64/ArchIpc_AC.thy +++ b/proof/access-control/RISCV64/ArchIpc_AC.thy @@ -188,11 +188,6 @@ lemma auth_ipc_buffers_machine_state_update[Ipc_AC_assms, simp]: "auth_ipc_buffers (machine_state_update f s) = auth_ipc_buffers s" by (clarsimp simp: auth_ipc_buffers_def get_tcb_def) -crunch handle_arch_fault_reply - for pspace_aligned[Ipc_AC_assms, wp]: "\s :: det_ext state. pspace_aligned s" - and valid_vspace_objs[Ipc_AC_assms, wp]: "\s :: det_ext state. valid_vspace_objs s" - and valid_arch_state[Ipc_AC_assms, wp]: "\s :: det_ext state. valid_arch_state s" - lemma cap_insert_ext_integrity_asids_in_ipc[Ipc_AC_assms, wp]: "cap_insert_ext src_parent src_slot dest_slot src_p dest_p \\s. integrity_asids aag subjects x asid st diff --git a/proof/access-control/RISCV64/ArchSyscall_AC.thy b/proof/access-control/RISCV64/ArchSyscall_AC.thy index e9c7f0ee17..e8db944cac 100644 --- a/proof/access-control/RISCV64/ArchSyscall_AC.thy +++ b/proof/access-control/RISCV64/ArchSyscall_AC.thy @@ -160,6 +160,7 @@ crunch \ \These aren't proved in the previous crunch, and hence need to be declared\ declare handle_arch_fault_reply_cur_thread[Syscall_AC_assms] declare handle_arch_fault_reply_it[Syscall_AC_assms] +declare init_arch_objects_inv[Syscall_AC_assms] end @@ -168,7 +169,7 @@ global_interpretation Syscall_AC_1?: Syscall_AC_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Syscall_AC_assms | wp init_arch_objects_inv)) + by (unfold_locales; wpsimp wp: Syscall_AC_assms) qed end diff --git a/proof/access-control/Retype_AC.thy b/proof/access-control/Retype_AC.thy index b81ad611ab..c432e6910b 100644 --- a/proof/access-control/Retype_AC.thy +++ b/proof/access-control/Retype_AC.thy @@ -373,7 +373,7 @@ lemma obj_refs_default': by (cases tp; auto simp: ptr_range_memI obj_bits_api_def dest: rev_subsetD[OF _ aobj_refs'_default']) lemma create_cap_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and + "\pas_refined aag and K (tp \ ArchObject ASIDPoolObj \ is_subject aag (fst p) \ is_subject aag (fst (fst ref)) \ (\x \ ptr_range (snd ref) (obj_bits_api tp sz). is_subject aag x) \ is_aligned (snd ref) (obj_bits_api tp sz))\ @@ -787,28 +787,6 @@ lemma set_free_index_invs': apply (fastforce simp: cte_wp_at_def) done -lemma delete_objects_pspace_no_overlap: - "\pspace_aligned and valid_objs and cte_wp_at ((=) (UntypedCap dev ptr sz idx)) slot\ - delete_objects ptr sz - \\_. pspace_no_overlap_range_cover ptr sz\" - unfolding delete_objects_def do_machine_op_def - apply (wp | simp add: split_def detype_machine_state_update_comm)+ - apply clarsimp - apply (rule pspace_no_overlap_detype) - apply (auto dest: cte_wp_at_valid_objs_valid_cap) - done - -lemma delete_objects_pspace_no_overlap': - "\pspace_aligned and valid_objs and cte_wp_at ((=) (UntypedCap dev ptr sz idx)) slot\ - delete_objects ptr sz - \\_. pspace_no_overlap_range_cover (ptr && ~~ mask sz) sz\" - apply (clarsimp simp: valid_def) - apply (frule untyped_cap_aligned, simp) - apply (clarsimp) - apply (frule(1) cte_wp_at_valid_objs_valid_cap) - apply (erule use_valid, wp delete_objects_pspace_no_overlap, auto) - done - (* FIXME: move *) lemma valid_cap_range_untyped: "\ valid_objs s; cte_wp_at ((=) (UntypedCap dev (ptr && ~~ mask sz) sz idx)) slot s \ @@ -924,22 +902,6 @@ lemma delete_objects_pas_refined: apply simp done -lemma delete_objects_pspace_aligned[wp]: - "delete_objects ptr sz \pspace_aligned\" - unfolding delete_objects_def do_machine_op_def - apply (wp | simp add: split_def detype_machine_state_update_comm)+ - apply clarsimp - apply (auto simp add: detype_def pspace_aligned_def) - done - -lemma reset_untyped_cap_pspace_aligned[wp]: - "reset_untyped_cap slot \pspace_aligned\" - apply (clarsimp simp: reset_untyped_cap_def) - apply (wpsimp wp: mapME_x_inv_wp ) - apply (rule valid_validE) - apply (wpsimp wp: preemption_point_inv dxo_wp_weak hoare_drop_imps)+ - done - lemma valid_vspace_objs_detype: assumes "invs s" assumes "cte_wp_at (\c. is_untyped_cap c \ descendants_range c ptr s @@ -1028,8 +990,7 @@ lemma reset_untyped_cap_pas_refined[wp]: apply (wps | wp set_cap_pas_refined_not_transferable | simp add: unless_def)+ apply (rule valid_validE) apply (rule_tac P="is_untyped_cap cap \ pas_cap_cur_auth aag cap" in hoare_gen_asm) - apply (rule_tac Q'="\_. cte_wp_at (\ c. \ is_transferable (Some c)) slot and pas_refined aag and - pspace_aligned and valid_vspace_objs and valid_arch_state" + apply (rule_tac Q'="\_. cte_wp_at (\ c. \ is_transferable (Some c)) slot and pas_refined aag" in hoare_strengthen_post) apply (rule validE_valid, rule mapME_x_inv_wp) apply (rule hoare_pre) @@ -1046,7 +1007,6 @@ lemma reset_untyped_cap_pas_refined[wp]: apply (fastforce simp: cte_wp_at_caps_of_state)+ apply (cases slot) apply (auto elim: caps_pas_cap_cur_auth_UntypedCap_idx_dev) - apply (fastforce simp: bits_of_def is_cap_simps)+ done lemma invoke_untyped_pas_refined: @@ -1056,9 +1016,8 @@ lemma invoke_untyped_pas_refined: \\_. pas_refined aag\" apply (rule hoare_gen_asm) apply (rule hoare_pre) - apply (rule_tac Q'="\_. pas_refined aag and pspace_aligned and valid_vspace_objs - and valid_arch_state and pas_cur_domain aag" in hoare_strengthen_post) - apply (rule invoke_untyped_Q) + apply (rule_tac Q'="\_. pas_refined aag and pas_cur_domain aag" in hoare_strengthen_post) + apply (rule invoke_untyped_Q) apply (rule hoare_pre, wp create_cap_pas_refined) apply (clarsimp simp: authorised_untyped_inv_def range_cover.aligned ptr_range_def[symmetric] @@ -1074,31 +1033,20 @@ lemma invoke_untyped_pas_refined: | strengthen invs_psp_aligned invs_vspace_objs invs_arch_state)+ apply (clarsimp simp: retype_addrs_aligned_range_cover cte_wp_at_caps_of_state) - apply (rule context_conjI, clarsimp) - apply (drule valid_global_refsD[rotated 2]) - apply (clarsimp simp: post_retype_invs_def split: if_split_asm) - apply (erule caps_of_state_cteD) - apply (erule notE, erule subsetD[rotated]) - apply (rule order_trans, erule retype_addrs_subset_ptr_bits) - apply (simp add: field_simps word_and_le2) - apply blast + apply (drule valid_global_refsD[rotated 2]) + apply (clarsimp simp: post_retype_invs_def split: if_split_asm) + apply (erule caps_of_state_cteD) + apply (erule notE, erule subsetD[rotated]) + apply (rule order_trans, erule retype_addrs_subset_ptr_bits) + apply (simp add: field_simps word_and_le2) apply (rule hoare_name_pre_state, clarsimp) apply (rule hoare_pre, wp retype_region_pas_refined) - apply (rule_tac Q'="\rv. post_retype_invs tp rv and pas_cur_domain aag" in hoare_strengthen_post) - apply (wp retype_region_post_retype_invs_spec) - apply (clarsimp simp: post_retype_invs_def invs_def valid_state_def valid_pspace_def split: if_splits) apply (clarsimp simp: authorised_untyped_inv_def) apply (strengthen range_cover_le[mk_strg I E], simp) - apply (intro conjI) - apply (intro conjI exI; - (erule cte_wp_at_weakenE)?, - clarsimp simp: field_simps word_and_le2) - apply (clarsimp simp: cte_wp_at_caps_of_state) - apply (erule caps_region_kernel_window_imp) - apply clarsimp - apply clarsimp - apply (fastforce simp: word_and_le2) - apply (fastforce simp: cte_wp_at_caps_of_state) + apply (intro conjI exI; + (erule cte_wp_at_weakenE)?, + clarsimp simp: field_simps word_and_le2) + apply (clarsimp simp: cte_wp_at_caps_of_state) apply (rule hoare_pre, wp set_cap_pas_refined) apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps) apply (cases ui, diff --git a/proof/access-control/Syscall_AC.thy b/proof/access-control/Syscall_AC.thy index ad13ff9fb8..82963b0fb8 100644 --- a/proof/access-control/Syscall_AC.thy +++ b/proof/access-control/Syscall_AC.thy @@ -371,7 +371,6 @@ lemma handle_recv_integrity: apply (fastforce simp: aag_cap_auth_def cap_auth_conferred_def cap_rights_to_auth_def valid_fault_def) apply wpsimp+ - apply fastforce done lemma handle_reply_pas_refined[wp]: @@ -469,30 +468,42 @@ locale Syscall_AC_1 = "Syscall_AC_wps (arch_activate_idle_thread t) aag" and arch_mask_irq_signal_integrity[simp]: "Syscall_AC_wps (arch_mask_irq_signal irq) aag" - and handle_reserved_irq_integrity[simp]: - "Syscall_AC_wps (handle_reserved_irq irq) aag" - and handle_hypervisor_fault_integrity[simp]: - "Syscall_AC_wps (handle_hypervisor_fault t hf_t) aag" and arch_switch_to_idle_thread_pas_refined[wp]: "arch_switch_to_idle_thread \pas_refined aag\" and arch_activate_idle_thread_pas_refined[wp]: "arch_activate_idle_thread t \pas_refined aag\" and arch_mask_irq_signal_pas_refined[wp]: "arch_mask_irq_signal irq \pas_refined aag\" - and handle_reserved_irq_pas_refined[wp]: - "handle_reserved_irq irq \pas_refined aag\" - and handle_hypervisor_fault_pas_refined[wp]: - "handle_hypervisor_fault t hf_t \pas_refined aag\" + and arch_mask_irq_signal_pas_cur_domain: + "arch_mask_irq_signal irq \pas_cur_domain aag\" + and handle_reserved_irq_integrity_autarch: + "\integrity aag X st and pas_refined aag and invs and (\s. is_subject aag (cur_thread s))\ + handle_reserved_irq irq + \\_. integrity aag X st\" + and handle_reserved_irq_integrity_idle: + "\integrity aag X st and invs and ct_idle\ + handle_reserved_irq irq + \\_. integrity aag X st\" + and handle_reserved_irq_pas_refined: + "\\s. pas_refined aag s \ invs s \ (ct_active s \ is_subject aag (cur_thread s))\ + handle_reserved_irq irq \\_. pas_refined aag\" + and handle_reserved_irq_pas_cur_domain: + "handle_reserved_irq irq \pas_cur_domain aag\" + and handle_hypervisor_fault_integrity_autarch: + "\\s. integrity aag X st s \ pas_refined aag s \ invs s \ is_subject aag thread + \ (ct_active s \ is_subject aag (cur_thread s))\ + handle_hypervisor_fault thread fault + \\_ s. integrity aag X st s\" + and handle_hypervisor_fault_pas_refined: + "\\s. pas_refined aag s \ is_subject aag (cur_thread s) \ is_subject aag thread \ invs s\ + handle_hypervisor_fault thread fault + \\_ s. pas_refined aag s\" and handle_vm_fault_integrity: "\integrity aag X st and K (is_subject aag thread)\ handle_vm_fault thread vmfault_type \\rv. integrity aag X st\" and handle_vm_fault_pas_refined[wp]: "handle_vm_fault t vmf_t \pas_refined aag\" - and arch_mask_irq_signal_pas_cur_domain: - "arch_mask_irq_signal irq \pas_cur_domain aag\" - and handle_reserved_irq_pas_cur_domain: - "handle_reserved_irq irq \pas_cur_domain aag\" and ackInterrupt_underlying_memory_inv[wp]: "\P. ackInterrupt irq \\s. P (underlying_memory s)\" and resetTimer_underlying_memory_inv[wp]: @@ -555,20 +566,17 @@ sublocale Syscall_AC_1 \ arch_activate_idle_thread: Syscall_AC_wps "ar by simp sublocale Syscall_AC_1 \ arch_mask_irq_signal: Syscall_AC_wps "arch_mask_irq_signal irq" aag by simp -sublocale Syscall_AC_1 \ handle_reserved_irq: Syscall_AC_wps "handle_reserved_irq irq" aag - by simp -sublocale Syscall_AC_1 \ handle_hypervisor_fault: Syscall_AC_wps "handle_hypervisor_fault t hf_t" aag - by simp context Syscall_AC_1 begin lemma handle_interrupt_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - handle_interrupt irq \\_. pas_refined aag\" + "\pas_refined aag and invs and (\s. ct_active s \ is_subject aag (cur_thread s))\ + handle_interrupt irq + \\_. pas_refined aag\" apply (simp add: handle_interrupt_def) apply (rule conjI; rule impI;rule hoare_pre) - apply (wp send_signal_pas_refined get_cap_wp + apply (wp send_signal_pas_refined get_cap_wp handle_reserved_irq_pas_refined | wpc | simp add: get_irq_slot_def get_irq_state_def )+ done @@ -589,23 +597,6 @@ lemma timer_tick_integrity[wp]: apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) done -lemma handle_interrupt_integrity_autarch: - "\integrity aag X st and pas_refined aag and invs - and (\s. ct_active s \ is_subject aag (cur_thread s)) - and K (is_subject_irq aag irq)\ - handle_interrupt irq - \\_. integrity aag X st\" - apply (simp add: handle_interrupt_def cong: irq_state.case_cong) - apply (rule conjI; rule impI; rule hoare_pre) - apply (wp (once) send_signal_respects get_cap_auth_wp [where aag = aag] dmo_mol_respects - ackInterrupt_device_state_inv resetTimer_device_state_inv - | simp add: get_irq_slot_def get_irq_state_def - | wp dmo_no_mem_respects - | wpc)+ - apply (fastforce simp: is_cap_simps aag_cap_auth_def cap_auth_conferred_def - cap_rights_to_auth_def) - done - lemma hacky_ipc_Send: "\ abs_has_auth_to aag Notify (interrupt_irq_node s irq) p; pas_refined aag s; pasMaySendIrqs aag \ @@ -617,27 +608,50 @@ lemma hacky_ipc_Send: apply simp done +lemma handle_interrupt_integrity_autarch: + "\integrity aag X st and pas_refined aag and invs + and (\s. pasMaySendIrqs aag \ interrupt_states s irq \ IRQSignal) + and (\s. is_subject aag (cur_thread s))\ + handle_interrupt irq + \\_. integrity aag X st\" + apply (simp add: handle_interrupt_def cong: irq_state.case_cong bind_cong) + apply (rule conjI; rule impI; rule hoare_pre) + apply (wpsimp wp: send_signal_respects get_cap_wp dmo_mol_respects dmo_no_mem_respects + ackInterrupt_device_state_inv resetTimer_device_state_inv + handle_reserved_irq_integrity_autarch + simp: get_irq_slot_def get_irq_state_def)+ + apply (rule conjI, fastforce)+ \ \valid_objs etc.\ + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (rule_tac s = s in hacky_ipc_Send [where irq = irq]) + apply (drule (1) cap_auth_caps_of_state) + apply (clarsimp simp: aag_cap_auth_def is_cap_simps cap_auth_conferred_def + cap_rights_to_auth_def split: if_split_asm) + apply assumption+ + done + lemma handle_interrupt_integrity: "\integrity aag X st and pas_refined aag and invs and (\s. pasMaySendIrqs aag \ interrupt_states s irq \ IRQSignal) - and (\s. ct_active s \ is_subject aag (cur_thread s))\ + and (\s. ct_active s \ is_subject aag (cur_thread s)) + and (ct_active or ct_idle)\ handle_interrupt irq \\_. integrity aag X st\" - apply (simp add: handle_interrupt_def - cong: irq_state.case_cong bind_cong) + apply (subst distrib(3)) + apply (rule hoare_pre_disj) + apply (wpsimp wp: handle_interrupt_integrity_autarch) + apply (simp add: handle_interrupt_def cong: irq_state.case_cong bind_cong) apply (rule conjI; rule impI; rule hoare_pre) - apply (wp (once) send_signal_respects get_cap_wp dmo_mol_respects dmo_no_mem_respects - ackInterrupt_device_state_inv resetTimer_device_state_inv - | wpc - | simp add: get_irq_slot_def get_irq_state_def)+ - apply clarsimp + apply (wpsimp wp: send_signal_respects get_cap_wp dmo_mol_respects dmo_no_mem_respects + ackInterrupt_device_state_inv resetTimer_device_state_inv + handle_reserved_irq_integrity_idle + simp: get_irq_slot_def get_irq_state_def)+ apply (rule conjI, fastforce)+ \ \valid_objs etc.\ apply (clarsimp simp: cte_wp_at_caps_of_state) apply (rule_tac s = s in hacky_ipc_Send [where irq = irq]) - apply (drule (1) cap_auth_caps_of_state) - apply (clarsimp simp: aag_cap_auth_def is_cap_simps cap_auth_conferred_def - cap_rights_to_auth_def split: if_split_asm) - apply assumption+ + apply (drule (1) cap_auth_caps_of_state) + apply (clarsimp simp: aag_cap_auth_def is_cap_simps cap_auth_conferred_def + cap_rights_to_auth_def split: if_split_asm) + apply assumption+ done lemma handle_yield_pas_refined[wp]: @@ -647,25 +661,22 @@ lemma handle_yield_pas_refined[wp]: lemma handle_event_pas_refined: "\pas_refined aag and guarded_pas_domain aag and domain_sep_inv (pasMaySendIrqs aag) st' and einvs and schact_is_rct - and (\s. ev \ Interrupt \ is_subject aag (cur_thread s)) + and (\s. ct_active s \ is_subject aag (cur_thread s)) and (\s. ev \ Interrupt \ ct_active s) \ handle_event ev \\_. pas_refined aag\" apply (case_tac ev; simp) - apply (rename_tac syscall) - apply (case_tac syscall; simp add: handle_send_def handle_call_def) - apply ((wp handle_invocation_pas_refined handle_recv_pas_refined - handle_fault_pas_refined - | simp | clarsimp)+) + apply (rename_tac syscall) + apply (case_tac syscall; simp add: handle_send_def handle_call_def) + apply ((wp handle_invocation_pas_refined handle_recv_pas_refined + handle_fault_pas_refined + | simp | clarsimp)+) + apply (fastforce simp: valid_fault_def) + apply (wp handle_fault_pas_refined | simp)+ apply (fastforce simp: valid_fault_def) - apply (wp handle_fault_pas_refined | simp)+ - apply (fastforce simp: valid_fault_def) - apply (wp handle_interrupt_pas_refined handle_fault_pas_refined - hoare_vcg_conj_lift hoare_vcg_all_lift - | wpc - | rule hoare_drop_imps - | strengthen invs_vobjs_strgs invs_psp_aligned invs_vspace_objs invs_arch_state - | simp)+ + apply (wpsimp wp: handle_fault_pas_refined handle_hypervisor_fault_pas_refined hoare_drop_imps + handle_interrupt_pas_refined hoare_vcg_conj_lift hoare_vcg_all_lift + simp: ct_in_state_def)+ done lemma valid_fault_Unknown[simp]: @@ -692,7 +703,7 @@ lemma handle_event_integrity: "\integrity aag X st and pas_refined aag and guarded_pas_domain aag and domain_sep_inv (pasMaySendIrqs aag) st' and einvs and schact_is_rct - and (\s. ct_active s \ is_subject aag (cur_thread s)) + and (\s. is_subject aag (cur_thread s)) and (\s. ev \ Interrupt \ ct_active s) and ((=) st)\ handle_event ev \\_. integrity aag X st\" @@ -700,9 +711,9 @@ lemma handle_event_integrity: apply (unfold handle_send_def handle_call_def) by (wpsimp wp: handle_recv_integrity handle_invocation_respects handle_reply_respects handle_fault_integrity_autarch - handle_interrupt_integrity handle_vm_fault_integrity + handle_interrupt_integrity_autarch handle_vm_fault_integrity handle_reply_pas_refined handle_vm_fault_valid_fault - handle_reply_valid_sched + handle_reply_valid_sched handle_hypervisor_fault_integrity_autarch hoare_vcg_conj_lift hoare_vcg_all_lift hoare_drop_imps simp: domain_sep_inv_def | rule dmo_wp hoare_vcg_conj_elimE @@ -730,12 +741,9 @@ lemma activate_thread_integrity: done lemma activate_thread_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state\ - activate_thread - \\_. pas_refined aag\" + "activate_thread \pas_refined aag\" unfolding activate_thread_def get_thread_state_def thread_get_def - apply (wpsimp wp: set_thread_state_pas_refined hoare_drop_imps) - done + by (wpsimp wp: set_thread_state_pas_refined hoare_drop_imps) lemma integrity_cur_thread[iff]: "integrity aag X st (s\cur_thread := v\) = integrity aag X st s" @@ -1144,39 +1152,46 @@ lemma guarded_pas_domain_machine_state_update[simp]: by (simp add: guarded_pas_domain_def) lemma call_kernel_integrity': - "st \ \einvs and pas_refined aag and is_subject aag \ cur_thread and schact_is_rct and guarded_pas_domain aag + "st \ \einvs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s)) + and schact_is_rct and guarded_pas_domain aag and domain_sep_inv (pasMaySendIrqs aag) st' and (\s. ev \ Interrupt \ ct_active s) and (ct_active or ct_idle) and K (pasMayActivate aag \ pasMayEditReadyQueues aag)\ call_kernel ev \\_. integrity aag X st\" - apply (simp add: call_kernel_def) - apply (simp only: spec_valid_def) - apply (wpsimp wp: activate_thread_respects schedule_integrity_pasMayEditReadyQueues - handle_interrupt_integrity dmo_wp handle_interrupt_pas_refined) + apply (case_tac "ev = Interrupt"; clarsimp simp: call_kernel_def spec_valid_def) + apply (wpsimp wp: activate_thread_respects schedule_integrity_pasMayEditReadyQueues + handle_interrupt_integrity handle_interrupt_pas_refined) + apply (rule_tac Q="\rv s. (rv = None \ P s) \ (\x. rv = Some x \ Q x s)" + and Q'="\rv s. P s \ (\x. rv = Some x \ Q x s)" + for P Q in hoare_strengthen_post[rotated]; clarsimp cong: conj_cong) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imps) + apply (fastforce intro!: valid_sched_ct_not_queued + simp: schact_is_rct_def domain_sep_inv_def guarded_pas_domain_def) + apply (wpsimp wp: activate_thread_respects schedule_integrity_pasMayEditReadyQueues dmo_wp + handle_interrupt_integrity_autarch handle_interrupt_pas_refined ) apply (clarsimp simp: if_fun_split) apply (rule_tac Q'="\rv ms. (rv \ None \ the rv \ non_kernel_IRQs) \ Q True (domain_sep_inv (pasMaySendIrqs aag) st' s) rv ms" and Q="\rv ms. Q (the rv \ non_kernel_IRQs \ scheduler_act_sane s \ ct_not_queued s) (pasMaySendIrqs aag \ interrupt_states s (the rv) \ IRQSignal) rv ms" for Q in hoare_strengthen_post[rotated], fastforce simp: domain_sep_inv_def) - apply (wpsimp wp: getActiveIRQ_rv_None hoare_drop_imps getActiveIRQ_inv) + apply (wpsimp wp: getActiveIRQ_rv_None getActiveIRQ_inv hoare_drop_imps) apply (rule hoare_strengthen_postE, - rule_tac Q="integrity aag X st and pas_refined aag and einvs and guarded_pas_domain aag - and domain_sep_inv (pasMaySendIrqs aag) st' - and is_subject aag \ cur_thread - and K (pasMayActivate aag \ pasMayEditReadyQueues aag)" - in valid_validE) - apply (wpsimp wp: handle_event_integrity he_invs handle_event_pas_refined - handle_event_cur_thread handle_event_cur_domain + rule_tac Q="integrity aag X st and pas_refined aag and einvs and guarded_pas_domain aag + and domain_sep_inv (pasMaySendIrqs aag) st' + and is_subject aag \ cur_thread + and K (pasMayActivate aag \ pasMayEditReadyQueues aag)" + in valid_validE) + apply (wpsimp wp: handle_event_integrity handle_event_pas_refined handle_event_domain_sep_inv handle_event_valid_sched)+ - apply (fastforce simp: domain_sep_inv_def guarded_pas_domain_def)+ + apply (fastforce simp: domain_sep_inv_def guarded_pas_domain_def) done lemma call_kernel_integrity: "\pas_refined aag and einvs and (\s. ev \ Interrupt \ ct_active s) and (ct_active or ct_idle) and domain_sep_inv (pasMaySendIrqs aag) st' and schact_is_rct - and guarded_pas_domain aag and is_subject aag o cur_thread + and guarded_pas_domain aag and (\s. ct_active s \ is_subject aag (cur_thread s)) and K (pasMayActivate aag \ pasMayEditReadyQueues aag) and (\s. s = st)\ call_kernel ev \\_. integrity aag X st\" @@ -1188,18 +1203,22 @@ lemma call_kernel_integrity: done lemma call_kernel_pas_refined: - "\einvs and pas_refined aag and is_subject aag \ cur_thread and guarded_pas_domain aag + "\einvs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s)) + and guarded_pas_domain aag and (\s. ev \ Interrupt \ ct_active s) and (ct_active or ct_idle) and schact_is_rct and pas_cur_domain aag and domain_sep_inv (pasMaySendIrqs aag) st'\ call_kernel ev \\_. pas_refined aag\" - apply (simp add: call_kernel_def ) - apply (wp activate_thread_pas_refined schedule_pas_refined handle_interrupt_pas_refined - do_machine_op_pas_refined dmo_wp hoare_drop_imps getActiveIRQ_inv - | simp add: if_fun_split - | strengthen invs_psp_aligned invs_vspace_objs invs_arch_state)+ - apply (wp he_invs handle_event_pas_refined) - apply auto + apply (case_tac "ev = Interrupt"; clarsimp simp: call_kernel_def) + apply (wpsimp wp: activate_thread_pas_refined schedule_pas_refined handle_interrupt_pas_refined + do_machine_op_pas_refined dmo_wp hoare_drop_imps getActiveIRQ_inv + | simp add: if_fun_split + | strengthen invs_psp_aligned invs_vspace_objs invs_arch_state)+ + apply (rule hoare_strengthen_postE, + rule_tac Q="pas_refined aag and invs and is_subject aag \ cur_thread" + in valid_validE) + apply (wpsimp wp: he_invs handle_event_pas_refined) + apply auto done end diff --git a/proof/access-control/Tcb_AC.thy b/proof/access-control/Tcb_AC.thy index 9555729fdf..f1f7f54454 100644 --- a/proof/access-control/Tcb_AC.thy +++ b/proof/access-control/Tcb_AC.thy @@ -96,8 +96,7 @@ lemma cdt_NullCap: by (rule ccontr) (force dest: mdb_cte_atD simp: valid_mdb_def2) lemma setup_reply_master_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_mdb and K (is_subject aag t)\ + "\pas_refined aag and valid_mdb and K (is_subject aag t)\ setup_reply_master t \\_. pas_refined aag\" apply (simp add: setup_reply_master_def) @@ -108,7 +107,7 @@ crunch possible_switch_to for tcb_domain_map_wellformed[wp]: "tcb_domain_map_wellformed aag" crunch setup_reply_master - for pspace_aligned[wp]: pspace_aligned + for pas_refined[wp]: "pas_refined aag" lemma restart_pas_refined: "\pas_refined aag and invs and tcb_at t and K (is_subject aag t)\ @@ -116,8 +115,8 @@ lemma restart_pas_refined: \\_. pas_refined aag\" apply (simp add: restart_def get_thread_state_def) apply (wp set_thread_state_pas_refined setup_reply_master_pas_refined thread_get_wp' - | strengthen invs_mdb - | fastforce)+ + | strengthen invs_mdb)+ + apply fastforce done lemma option_update_thread_set_safe_lift: @@ -177,7 +176,7 @@ lemma (in is_extended') cte_wp_at[wp]: "I (cte_wp_at P a)" by (rule lift_inv, simp) lemma checked_insert_pas_refined: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and valid_mdb and + "\pas_refined aag and valid_mdb and K (\ is_master_reply_cap new_cap \ is_subject aag target \ is_subject aag (fst src_slot) \ pas_cap_cur_auth aag new_cap)\ check_cap_at new_cap src_slot @@ -340,8 +339,7 @@ lemma hoare_st_refl: done lemma bind_notification_pas_refined[wp]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state and - K (\auth \ {Receive, Reset}. abs_has_auth_to aag auth t ntfn)\ + "\pas_refined aag and K (\auth \ {Receive, Reset}. abs_has_auth_to aag auth t ntfn)\ bind_notification t ntfn \\_. pas_refined aag\" apply (clarsimp simp: bind_notification_def) @@ -358,13 +356,6 @@ lemma invoke_tcb_ntfn_control_pas_refined[wp]: apply (wp | fastforce simp: authorised_tcb_inv_def)+ done -crunch suspend, restart - for pspace_aligned[wp]: "\s :: det_ext state. pspace_aligned s" - and valid_vspace_objs[wp]: "\s :: det_ext state. valid_vspace_objs s" - and valid_arch_state[wp]: "\s :: det_ext state. valid_arch_state s" - (wp: dxo_wp_weak) - - context Tcb_AC_1 begin lemma invoke_tcb_pas_refined: @@ -382,11 +373,7 @@ lemma invoke_tcb_pas_refined: apply assumption apply (rule hoare_gen_asm) apply (cases ti, simp_all add: authorised_tcb_inv_def) - apply (wp ita_wps hoare_drop_imps - hoare_strengthen_post[where Q'="\_. pas_refined aag and pspace_aligned - and valid_vspace_objs - and valid_arch_state", - OF mapM_x_wp'] + apply (wp ita_wps hoare_drop_imps mapM_x_wp' | simp add: emptyable_def if_apply_def2 authorised_tcb_inv_def | rule ball_tcb_cap_casesI | wpc From ea0ab79f952e108950f31fcf3d2216a38a7cdd27 Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Thu, 28 Nov 2024 11:53:06 +1100 Subject: [PATCH 2/4] aarch64 access: copy riscv64 theories Signed-off-by: Ryan Barry --- proof/access-control/AARCH64/ArchADT_AC.thy | 124 ++ proof/access-control/AARCH64/ArchAccess.thy | 278 +++ .../access-control/AARCH64/ArchAccess_AC.thy | 175 ++ proof/access-control/AARCH64/ArchArch_AC.thy | 1954 +++++++++++++++++ proof/access-control/AARCH64/ArchCNode_AC.thy | 334 +++ .../AARCH64/ArchDomainSepInv.thy | 134 ++ .../AARCH64/ArchFinalise_AC.thy | 302 +++ .../AARCH64/ArchInterrupt_AC.thy | 112 + proof/access-control/AARCH64/ArchIpc_AC.thy | 238 ++ .../access-control/AARCH64/ArchRetype_AC.thy | 383 ++++ .../access-control/AARCH64/ArchSyscall_AC.thy | 174 ++ proof/access-control/AARCH64/ArchTcb_AC.thy | 110 + proof/access-control/AARCH64/ArchTypes.thy | 17 + .../access-control/AARCH64/ExampleSystem.thy | 1103 ++++++++++ 14 files changed, 5438 insertions(+) create mode 100644 proof/access-control/AARCH64/ArchADT_AC.thy create mode 100644 proof/access-control/AARCH64/ArchAccess.thy create mode 100644 proof/access-control/AARCH64/ArchAccess_AC.thy create mode 100644 proof/access-control/AARCH64/ArchArch_AC.thy create mode 100644 proof/access-control/AARCH64/ArchCNode_AC.thy create mode 100644 proof/access-control/AARCH64/ArchDomainSepInv.thy create mode 100644 proof/access-control/AARCH64/ArchFinalise_AC.thy create mode 100644 proof/access-control/AARCH64/ArchInterrupt_AC.thy create mode 100644 proof/access-control/AARCH64/ArchIpc_AC.thy create mode 100644 proof/access-control/AARCH64/ArchRetype_AC.thy create mode 100644 proof/access-control/AARCH64/ArchSyscall_AC.thy create mode 100644 proof/access-control/AARCH64/ArchTcb_AC.thy create mode 100644 proof/access-control/AARCH64/ArchTypes.thy create mode 100644 proof/access-control/AARCH64/ExampleSystem.thy diff --git a/proof/access-control/AARCH64/ArchADT_AC.thy b/proof/access-control/AARCH64/ArchADT_AC.thy new file mode 100644 index 0000000000..d49d34b5b4 --- /dev/null +++ b/proof/access-control/AARCH64/ArchADT_AC.thy @@ -0,0 +1,124 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchADT_AC +imports ADT_AC +begin + +context Arch begin global_naming RISCV64 + +named_theorems ADT_AC_assms + +lemma mask_ptTranslationBits_ucast_ucast: + "(asid && mask ptTranslationBits) = ucast (ucast asid :: 9 word)" + by (word_eqI_solve simp: ptTranslationBits_def) + +lemma ptr_offset_in_ptr_range: + "\ invs s; x \ kernel_mappings; + get_vspace_of_thread (kheap s) (arch_state s) tcb \ global_pt s; + get_page_info (aobjs_of s) + (get_vspace_of_thread (kheap s) (arch_state s) tcb) x = Some (base, sz, attr, r) \ + \ ptrFromPAddr base + (x && mask sz) \ ptr_range (ptrFromPAddr base) sz" + apply (simp add: ptr_range_def mask_def) + apply (rule conjI) + apply (rule_tac b="2 ^ sz - 1" in word_plus_mono_right2) + apply (frule some_get_page_info_umapsD) + apply (fastforce dest: get_vspace_of_thread_reachable + simp: canonical_not_kernel_is_user get_page_info_def)+ + apply clarsimp + apply (drule is_aligned_ptrFromPAddr_n) + apply (simp add: pageBitsForSize_def pageBits_def canonical_bit_def ptTranslationBits_def + split: vmpage_size.splits) + apply (clarsimp simp: is_aligned_no_overflow' word_and_le1)+ + apply (subst p_assoc_help) + apply (rule word_plus_mono_right) + apply (rule word_and_le1) + apply (frule some_get_page_info_umapsD) + apply (fastforce dest: get_vspace_of_thread_reachable + simp: canonical_not_kernel_is_user get_page_info_def)+ + apply clarsimp + apply (drule is_aligned_ptrFromPAddr_n) + apply (simp add: pageBitsForSize_def pageBits_def canonical_bit_def ptTranslationBits_def + split: vmpage_size.splits) + apply (clarsimp simp: is_aligned_no_overflow') + done + +lemma user_op_access[ADT_AC_assms]: + "\ invs s; pas_refined aag s; is_subject aag tcb; ptable_lift tcb s x = Some ptr; + auth \ vspace_cap_rights_to_auth (ptable_rights tcb s x) \ + \ abs_has_auth_to aag auth tcb (ptrFromPAddr ptr)" + apply (case_tac "x \ kernel_mappings") + using get_vspace_of_thread_asid_or_global_pt + apply (fastforce simp: ptable_rights_def vspace_cap_rights_to_auth_def invs_def + valid_state_def valid_arch_state_def kernel_mappings_canonical + dest: some_get_page_info_kmapsD split: option.splits) + apply (clarsimp simp: ptable_lift_def split: option.splits) + apply (insert get_vspace_of_thread_asid_or_global_pt) + apply (erule_tac x=s in meta_allE) + apply (erule_tac x=tcb in meta_allE) + apply (cases "get_vspace_of_thread (kheap s) (arch_state s) tcb = global_pt s"; clarsimp) + apply (frule get_page_info_gpd_kmaps[rotated 2]; fastforce simp: get_page_info_def) + apply (frule (3) ptr_offset_in_ptr_range) + apply (frule get_vspace_of_thread_reachable; clarsimp) + apply (frule vs_lookup_table_vspace) + apply fastforce+ + apply (clarsimp simp: get_vspace_of_thread_def get_page_info_def ptable_rights_def pt_lookup_slot_def + split: if_splits option.splits kernel_object.splits cap.splits arch_cap.splits) + apply (frule (1) canonical_not_kernel_is_user) + apply (frule pt_lookup_slot_from_level_is_subject) + apply (fastforce elim: vs_lookup_table_vref_independent)+ + apply (rule aag_Control_into_owns) + apply (clarsimp simp: pas_refined_def auth_graph_map_def state_objs_to_policy_def) + apply (erule subsetD) + apply (drule_tac addr="tcb_cnode_index 1" in caps_of_state_tcb) + apply (clarsimp simp: tcb_cnode_map_def) + apply (drule sbta_caps) + apply (fastforce simp: obj_refs_def) + apply (fastforce simp: cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (rule_tac x=tcb in exI, fastforce) + apply simp + apply (clarsimp simp: pt_lookup_slot_from_level_def) + apply (drule_tac vref'=x in vs_lookup_table_vref_independent, rule order_refl) + apply (drule pt_walk_level) + apply (drule (1) vs_lookup_table_extend, rule order_refl) + apply (rename_tac level vref) + apply (case_tac "level = asid_pool_level", simp add: pt_walk_top) + apply (frule vs_lookup_table_is_aligned; clarsimp simp: canonical_not_kernel_is_user) + apply (clarsimp simp: pas_refined_def pte_info_def split: pte.splits) + apply (erule subsetD) + apply (clarsimp simp: auth_graph_map_def state_objs_to_policy_def) + apply (intro exI conjI sbta_vref | erule sym | rule refl)+ + apply (clarsimp simp: state_vrefs_def ptes_of_Some pts_of_Some) + apply (intro exI conjI) + apply (simp add: canonical_not_kernel_is_user)+ + apply (clarsimp simp: vs_refs_aux_def) + apply (rule conjI; clarsimp) + apply (clarsimp simp: graph_of_def pte_ref2_def Bex_def ptes_of_Some pts_of_Some aobjs_of_Some) + apply (rule_tac x="table_index (pt_slot_offset max_pt_level vref x)" in exI) + apply (fastforce simp: table_index_max_level_slots canonical_not_kernel_is_user + image_iff ptrFromPAddr_def mult_is_add.mult_ac) + apply (clarsimp simp: graph_of_def pte_ref2_def ptes_of_Some pts_of_Some aobjs_of_Some) + apply (rule_tac x="table_index (pt_slot_offset level vref x)" in exI) + apply (fastforce simp: image_iff table_index_offset_pt_bits_left + ptrFromPAddr_def mult_is_add.mult_ac) + done + +lemma write_in_vspace_cap_rights[ADT_AC_assms]: + "AllowWrite \ ptable_rights (cur_thread s) s va + \ Write \ vspace_cap_rights_to_auth (ptable_rights (cur_thread s) s va)" + by (clarsimp simp: vspace_cap_rights_to_auth_def) + +end + + +global_interpretation ADT_AC_1?: ADT_AC_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact ADT_AC_assms) +qed + +end diff --git a/proof/access-control/AARCH64/ArchAccess.thy b/proof/access-control/AARCH64/ArchAccess.thy new file mode 100644 index 0000000000..8c48f69eb3 --- /dev/null +++ b/proof/access-control/AARCH64/ArchAccess.thy @@ -0,0 +1,278 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchAccess +imports Types +begin + +context Arch begin global_naming RISCV64 + +subsection \Arch-specific transformation of caps into authorities\ + +definition vspace_cap_rights_to_auth :: "cap_rights \ auth set" where + "vspace_cap_rights_to_auth r \ + (if AllowWrite \ r then {Write} else {}) + \ (if AllowRead \ r then {Read} else {})" + +definition arch_cap_auth_conferred where + "arch_cap_auth_conferred arch_cap \ + (if is_FrameCap arch_cap then vspace_cap_rights_to_auth (acap_rights arch_cap) else {Control})" + +subsection \Generating a policy from the current ASID distribution\ + +definition pte_ref2 where + "pte_ref2 level pte \ case pte of + PagePTE ppn atts rights + \ Some (ptrFromPAddr (addr_from_ppn ppn), + pageBitsForSize (vmpage_size_of_level level), + vspace_cap_rights_to_auth rights) + | PageTablePTE ppn atts + \ Some (ptrFromPAddr (addr_from_ppn ppn), 0, {Control}) + | _ \ None" + +definition vs_refs_aux :: "vm_level \ arch_kernel_obj \ (obj_ref \ obj_ref \ aa_type \ auth) set" + where + "vs_refs_aux level \ \ko. case ko of + ASIDPool pool \ (\(r,p). (p, ucast r, AASIDPool, Control)) ` graph_of pool + | PageTable pt \ + \(r,(p, sz, auth)) \ graph_of (pte_ref2 level o pt) - {(x,y). x \ kernel_mapping_slots \ level = max_pt_level}. + (\(p, a). (p, ucast r, APageTable, a)) ` (ptr_range p sz \ auth) + | _ \ {}" + +definition state_vrefs where + "state_vrefs s \ \p. + \{vs_refs_aux lvl ao | lvl ao bot asid vref. vs_lookup_table bot asid vref s = Some (lvl, p) + \ aobjs_of s p = Some ao \ vref \ user_region}" + +lemma state_vrefsD: + "\ vs_lookup_table level asid vref s = Some (lvl, p); + aobjs_of s p = Some ao; vref \ user_region; x \ vs_refs_aux lvl ao \ + \ x \ state_vrefs s p" + unfolding state_vrefs_def by fastforce + +end + +context Arch_p_arch_update_eq begin global_naming RISCV64 + +interpretation Arch . + +lemma state_vrefs[iff]: "state_vrefs (f s) = state_vrefs s" + by (simp add: state_vrefs_def pspace) + +end + +context Arch begin global_naming RISCV64 + +lemmas state_vrefs_upd = + cur_thread_update.state_vrefs + cdt_update.state_vrefs + irq_node_update_arch.state_vrefs + interrupt_update.state_vrefs + revokable_update.state_vrefs + machine_state_update.state_vrefs + more_update.state_vrefs + +end + +context Arch begin + +primrec aobj_ref' where + "aobj_ref' (ASIDPoolCap p as) = {p}" +| "aobj_ref' ASIDControlCap = {}" +| "aobj_ref' (FrameCap ref cR sz dev as) = ptr_range ref (pageBitsForSize sz)" +| "aobj_ref' (PageTableCap x as3) = {x}" + +fun acap_asid' :: "arch_cap \ asid set" where + "acap_asid' (FrameCap _ _ _ _ mapping) = fst ` set_option mapping" +| "acap_asid' (PageTableCap _ mapping) = fst ` set_option mapping" +| "acap_asid' (ASIDPoolCap _ asid) + = {x. asid_high_bits_of x = asid_high_bits_of asid \ x \ 0}" +| "acap_asid' ASIDControlCap = UNIV" + +inductive_set state_asids_to_policy_aux for aag caps asid_tab vrefs where + sata_asid: + "\ caps ptr = Some (ArchObjectCap acap); asid \ acap_asid' acap \ + \ (pasObjectAbs aag (fst ptr), Control, pasASIDAbs aag asid) + \ state_asids_to_policy_aux aag caps asid_tab vrefs" +| sata_asid_lookup: + "\ asid_tab (asid_high_bits_of asid) = Some poolptr; + (pdptr, ucast (asid && mask asid_low_bits), AASIDPool, a) \ vrefs poolptr \ + \ (pasASIDAbs aag asid, a, pasObjectAbs aag pdptr) + \ state_asids_to_policy_aux aag caps asid_tab vrefs" +| sata_asidpool: + "\ asid_tab (asid_high_bits_of asid) = Some poolptr; asid \ 0 \ + \ (pasObjectAbs aag poolptr, AAuth ASIDPoolMapsASID, pasASIDAbs aag asid) + \ state_asids_to_policy_aux aag caps asid_tab vrefs" + +definition + "state_asids_to_policy_arch aag caps astate vrefs \ + state_asids_to_policy_aux aag caps (riscv_asid_table astate) + (vrefs :: 64 word \ (64 word \ 64 word \ aa_type \ auth) set)" +declare state_asids_to_policy_arch_def[simp] + +section \Arch-specific integrity definition\ + +subsection \How ASIDs can change\ + +abbreviation integrity_asids_aux :: "'a PAS \ 'a set \ obj_ref \ asid \ + (asid_high_index \ obj_ref) \ (asid_high_index \ obj_ref) \ + (obj_ref \ asid_pool) \ (obj_ref \ asid_pool) \ bool" where + "integrity_asids_aux aag subjects x asid atab atab' pools pools' \ + (atab (asid_high_bits_of asid) \ atab' (asid_high_bits_of asid) + \ (\x. atab' (asid_high_bits_of asid) = Some x \ pasObjectAbs aag x \ subjects) \ + (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of asid + \ pasASIDAbs aag asid' \ subjects)) \ + (pasObjectAbs aag x \ subjects + \ (\pool. pools x = Some pool + \ pools' x \ None \ + (\pool'. pools' x = Some pool' \ + (pool \ pool' \ (\asid. atab (asid_high_bits_of asid) = Some x)))))" + +definition integrity_asids :: + "'a PAS \ 'a set \ obj_ref \ asid \ 'y::state_ext state \ 'z::state_ext state \ bool" where + "integrity_asids aag subjects x asid s s' \ + integrity_asids_aux aag subjects x asid (asid_table s) (asid_table s') + (asid_pools_of s) (asid_pools_of s')" + +sublocale kheap_update: Arch_arch_update_eq "kheap_update f" + by unfold_locales simp + +lemma (in Arch_p_arch_update_eq) integrity_asids_update[simp]: + "integrity_asids aag subjects x a (f st) s = integrity_asids aag subjects x a st s" + "integrity_asids aag subjects x a st (f s) = integrity_asids aag subjects x a st s" + by (auto simp: integrity_asids_def arch pspace) + +lemmas integrity_asids_updates = + cdt_update.integrity_asids_update + more_update.integrity_asids_update + revokable_update.integrity_asids_update + interrupt_update.integrity_asids_update + cur_thread_update.integrity_asids_update + machine_state_update.integrity_asids_update + +lemma integrity_asids_cnode_update': + "\ kheap st p = Some (CNode sz cs); integrity_asids aag subjects x a st (s\kheap := rest\) \ + \ integrity_asids aag subjects x a st (s\kheap := \x. if x = p then v else rest x\)" + by (auto simp: integrity_asids_def opt_map_def split: option.splits) + +lemma integrity_asids_tcb_update': + "\ kheap st p = Some (TCB tcb); integrity_asids aag subjects x a st (s\kheap := rest\) \ + \ integrity_asids aag subjects x a st (s\kheap := \x. if x = p then v else rest x\)" + by (auto simp: integrity_asids_def opt_map_def split: option.splits) + +lemma integrity_asids_ep_update': + "\ kheap st p = Some (Endpoint ep); integrity_asids aag subjects x a st (s\kheap := rest\) \ + \ integrity_asids aag subjects x a st (s\kheap := \x. if x = p then v else rest x\)" + by (auto simp: integrity_asids_def opt_map_def split: option.splits) + +lemma integrity_asids_ntfn_update': + "\ kheap st p = Some (Notification ntfn); integrity_asids aag subjects x a st (s\kheap := rest\) \ + \ integrity_asids aag subjects x a st (s\kheap := \x. if x = p then v else rest x\)" + by (auto simp: integrity_asids_def opt_map_def split: option.splits) + +lemmas integrity_asids_kh_upds'' = + integrity_asids_cnode_update' + integrity_asids_tcb_update' + integrity_asids_ep_update' + integrity_asids_ntfn_update' + +lemmas integrity_asids_kh_upds = + integrity_asids_kh_upds'' + integrity_asids_kh_upds''[where rest="kheap s" and s=s for s, folded fun_upd_def, simplified] + +declare integrity_asids_def[simp] + +lemma integrity_asids_kh_upds': + "integrity_asids aag subjects x a (s\kheap := (kheap s)(p \ CNode sz cs)\) s" + "integrity_asids aag subjects x a (s\kheap := (kheap s)(p \ TCB tcb)\) s" + "integrity_asids aag subjects x a (s\kheap := (kheap s)(p \ Endpoint ep)\) s" + "integrity_asids aag subjects x a (s\kheap := (kheap s)(p \ Notification ntfn)\) s" + by (auto simp: opt_map_def split: option.splits) + +lemma integrity_asids_kh_update: + "integrity_asids aag subject x a (s\kheap := kh\) (s\kheap := kh'\) + \ integrity_asids aag subject x a (s\kheap := kh(p := v)\) (s\kheap := kh'(p := v)\)" + by (clarsimp simp: opt_map_def) + + +subsection \Misc definitions\ + +fun ctxt_IP_update where + "ctxt_IP_update (UserContext ctxt) = UserContext (ctxt(NextIP := ctxt FaultIP))" + +lemma ctxt_IP_update_def: + "ctxt_IP_update ctxt = + (case ctxt of (UserContext ctxt') \ UserContext (ctxt'(NextIP := ctxt' FaultIP)))" + by (cases ctxt; clarsimp) + +abbreviation arch_IP_update where + "arch_IP_update arch \ arch_tcb_context_set (ctxt_IP_update (arch_tcb_context_get arch)) arch" + +definition asid_pool_integrity :: + "'a set \ 'a PAS \ (asid_low_index \ obj_ref) \ (asid_low_index \ obj_ref) \ bool" where + "asid_pool_integrity subjects aag pool pool' \ + \x. pool' x \ pool x + \ pool' x = None \ aag_subjects_have_auth_to subjects aag Control (the (pool x))" + +inductive arch_integrity_obj_atomic :: + "'a PAS \ 'a set \ 'a \ arch_kernel_obj \ arch_kernel_obj \ bool" + for aag subjects l ao ao' where + arch_troa_asidpool_clear: + "\ ao = ASIDPool pool; ao' = ASIDPool pool'; + asid_pool_integrity subjects aag pool pool' \ + \ arch_integrity_obj_atomic aag subjects l ao ao'" + +inductive arch_integrity_obj_alt :: + "'a PAS \ 'a set \ 'a \ arch_kernel_obj \ arch_kernel_obj \ bool" + for aag subjects l' ao ao' where + arch_tro_alt_asidpool_clear: + "\ ao = ASIDPool pool; ao' = ASIDPool pool'; + asid_pool_integrity subjects aag pool pool'\ + \ arch_integrity_obj_alt aag subjects l' ao ao'" + +definition auth_ipc_buffers :: "'z::state_ext state \ obj_ref \ obj_ref set" where + "auth_ipc_buffers s \ \p. case (get_tcb p s) of + None \ {} + | Some tcb \ + (case tcb_ipcframe tcb of + ArchObjectCap (FrameCap p' R vms False _) \ + if AllowWrite \ R + then (ptr_range (p' + (tcb_ipc_buffer tcb && mask (pageBitsForSize vms))) msg_align_bits) + else {} + | _ \ {})" + +end + + +context begin interpretation Arch . + +requalify_consts + vspace_cap_rights_to_auth + aobj_ref' + acap_asid' + state_vrefs + state_asids_to_policy_arch + integrity_asids + ctxt_IP_update + arch_IP_update + arch_cap_auth_conferred + arch_integrity_obj_atomic + arch_integrity_obj_alt + auth_ipc_buffers + +requalify_facts + integrity_asids_updates + state_vrefs_upd + integrity_asids_kh_upds + integrity_asids_kh_upds' + integrity_asids_kh_update + +end + +declare state_vrefs_upd[simp] +declare integrity_asids_updates[simp] + +end diff --git a/proof/access-control/AARCH64/ArchAccess_AC.thy b/proof/access-control/AARCH64/ArchAccess_AC.thy new file mode 100644 index 0000000000..0d5405dbed --- /dev/null +++ b/proof/access-control/AARCH64/ArchAccess_AC.thy @@ -0,0 +1,175 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchAccess_AC +imports Access_AC +begin + +section\Arch-specific AC proofs\ + +context Arch begin global_naming RISCV64 + +named_theorems Access_AC_assms + +lemma acap_class_reply[Access_AC_assms]: + "acap_class acap \ ReplyClass t" + by (cases acap; simp) + +lemma arch_troa_tro_alt[Access_AC_assms, elim!]: + "arch_integrity_obj_atomic aag subjects l ko ko' + \ arch_integrity_obj_alt aag subjects l ko ko'" + by (fastforce elim: arch_integrity_obj_atomic.cases intro: arch_integrity_obj_alt.intros) + +lemma clear_asidpool_trans[elim]: + "\ asid_pool_integrity subjects aag pool pool'; + asid_pool_integrity subjects aag pool' pool'' \ + \ asid_pool_integrity subjects aag pool pool''" + unfolding asid_pool_integrity_def by metis + +lemma cap_asid'_member[simp]: + "asid \ cap_asid' cap = (\acap. cap = ArchObjectCap acap \ asid \ acap_asid' acap)" + by (cases cap; clarsimp) + +lemma clas_caps_of_state[Access_AC_assms]: + "\ caps_of_state s slot = Some cap; pas_refined aag s \ + \ cap_links_asid_slot aag (pasObjectAbs aag (fst slot)) cap" + apply (clarsimp simp: cap_links_asid_slot_def label_owns_asid_slot_def pas_refined_def) + apply (drule state_asids_to_policy_aux.intros) + apply assumption + apply (blast dest: state_asids_to_policy_aux.intros) + done + +lemma arch_tro_alt_trans_spec[Access_AC_assms]: + "\ arch_integrity_obj_alt aag subjects l ko ko'; + arch_integrity_obj_alt aag subjects l ko' ko'' \ + \ arch_integrity_obj_alt aag subjects l ko ko''" + by (fastforce simp: arch_integrity_obj_alt.simps) + +end + + +global_interpretation Access_AC_1?: Access_AC_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact Access_AC_assms) +qed + + +context Arch begin global_naming RISCV64 + +lemma auth_ipc_buffers_tro[Access_AC_assms]: + "\ integrity_obj_state aag activate subjects s s'; + x \ auth_ipc_buffers s' p; pasObjectAbs aag p \ subjects \ + \ x \ auth_ipc_buffers s p " + by (drule_tac x = p in spec) + (erule integrity_objE; + fastforce simp: tcb_states_of_state_def get_tcb_def auth_ipc_buffers_def + split: cap.split_asm arch_cap.split_asm if_split_asm bool.splits) + +lemma trasids_trans[Access_AC_assms]: + "\ (\x a. integrity_asids aag subjects x a s s'); + (\x a. integrity_asids aag subjects x a s' s'') \ + \ (\x a. integrity_asids aag subjects x a s s'')" + by clarsimp metis + +lemma integrity_asids_refl[Access_AC_assms, simp]: + "integrity_asids aag subjects x a s s" + by simp + +lemma integrity_asids_update_autarch[Access_AC_assms]: + "\ \x a. integrity_asids aag {pasSubject aag} x a st s; is_subject aag ptr \ + \ \x a. integrity_asids aag {pasSubject aag} x a st (s\kheap := (kheap s)(ptr \ obj)\)" + by (auto simp: opt_map_def) + +end + + +global_interpretation Access_AC_2?: Access_AC_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Access_AC_assms)?) +qed + + +context Arch begin global_naming RISCV64 + +lemma ipcframe_subset_page: + "\ valid_objs s; get_tcb p s = Some tcb; + tcb_ipcframe tcb = ArchObjectCap (FrameCap p' R vms d xx); + x \ ptr_range (p' + (tcb_ipc_buffer tcb && mask (pageBitsForSize vms))) msg_align_bits \ + \ x \ ptr_range p' (pageBitsForSize vms)" + apply (frule (1) valid_tcb_objs) + apply (clarsimp simp add: valid_tcb_def ran_tcb_cap_cases) + apply (erule set_mp[rotated]) + apply (rule ptr_range_subset) + apply (simp add: valid_cap_def cap_aligned_def) + apply (simp add: valid_tcb_def valid_ipc_buffer_cap_def is_aligned_andI1 split:bool.splits) + apply (rule order_trans [OF _ pbfs_atleast_pageBits]) + apply (simp add: msg_align_bits pageBits_def) + apply (rule and_mask_less') + apply (simp add: pbfs_less_wb' [unfolded word_bits_conv]) + done + +lemma auth_ipc_buffers_member_def: + "x \ auth_ipc_buffers s p = + (\tcb p' R vms xx. get_tcb p s = Some tcb + \ tcb_ipcframe tcb = (ArchObjectCap (FrameCap p' R vms False xx)) + \ caps_of_state s (p, tcb_cnode_index 4) = + Some (ArchObjectCap (FrameCap p' R vms False xx)) + \ AllowWrite \ R + \ x \ ptr_range (p' + (tcb_ipc_buffer tcb && mask (pageBitsForSize vms))) + msg_align_bits)" + unfolding auth_ipc_buffers_def + by (clarsimp simp: caps_of_state_tcb' split: option.splits cap.splits arch_cap.splits bool.splits) + +lemma auth_ipc_buffers_member[Access_AC_assms]: + "\ x \ auth_ipc_buffers s p; valid_objs s \ + \ \tcb acap. get_tcb p s = Some tcb + \ tcb_ipcframe tcb = (ArchObjectCap acap) + \ caps_of_state s (p, tcb_cnode_index 4) = Some (ArchObjectCap acap) + \ Write \ arch_cap_auth_conferred acap + \ x \ aobj_ref' acap" + by (fastforce simp: auth_ipc_buffers_def caps_of_state_tcb' arch_cap_auth_conferred_def + vspace_cap_rights_to_auth_def ipcframe_subset_page + split: option.splits cap.splits arch_cap.splits bool.splits if_splits) + +lemma asid_pool_integrity_mono[Access_AC_assms]: + "\ asid_pool_integrity S aag cont cont'; S \ T \ \ asid_pool_integrity T aag cont cont'" + unfolding asid_pool_integrity_def by fastforce + +lemma integrity_asids_mono[Access_AC_assms]: + "\ integrity_asids aag S x a s s'; S \ T; pas_refined aag s; valid_objs s \ + \ integrity_asids aag T x a s s'" + by fastforce + +lemma arch_integrity_obj_atomic_mono[Access_AC_assms]: + "\ arch_integrity_obj_atomic aag S l ao ao'; S \ T; pas_refined aag s; valid_objs s \ + \ arch_integrity_obj_atomic aag T l ao ao'" + by (clarsimp simp: arch_integrity_obj_atomic.simps asid_pool_integrity_mono) + +end + + +global_interpretation Access_AC_3?: Access_AC_3 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact Access_AC_assms) +qed + + +context Arch begin global_naming RISCV64 + +lemma pas_refined_irq_state_independent[intro!, simp]: + "pas_refined x (s\machine_state := machine_state s\irq_state := f (irq_state (machine_state s))\\) = + pas_refined x s" + by (simp add: pas_refined_def) + +end + +end diff --git a/proof/access-control/AARCH64/ArchArch_AC.thy b/proof/access-control/AARCH64/ArchArch_AC.thy new file mode 100644 index 0000000000..4519236a7b --- /dev/null +++ b/proof/access-control/AARCH64/ArchArch_AC.thy @@ -0,0 +1,1954 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchArch_AC +imports Arch_AC +begin + +text\ + +Arch-specific access control. + +\ + +context Arch begin global_naming RISCV64 + +named_theorems Arch_AC_assms + +lemma set_mrs_state_vrefs[Arch_AC_assms, wp]: + "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ + set_mrs thread buf msgs + \\_ s. P (state_vrefs s)\" + apply (simp add: set_mrs_def split_def set_object_def get_object_def split del: if_split) + apply (wpsimp wp: gets_the_wp get_wp put_wp mapM_x_wp' + simp: zipWithM_x_mapM_x split_def store_word_offs_def + split_del: if_split) + apply (subst state_vrefs_eqI) + prefer 7 + apply assumption + apply (clarsimp simp: opt_map_def) + apply (fastforce simp: opt_map_def aobj_of_def) + apply clarsimp + apply (auto simp: valid_arch_state_def) + done + +lemma mul_add_word_size_lt_msg_align_bits_ofnat[Arch_AC_assms]: + "\ p < 2 ^ (msg_align_bits - word_size_bits); k < word_size \ + \ of_nat p * of_nat word_size + k < (2 :: obj_ref) ^ msg_align_bits" + apply (rule is_aligned_add_less_t2n[where n=word_size_bits]) + apply (simp_all add: msg_align_bits' word_size_word_size_bits is_aligned_mult_triv2) + apply (simp_all add: word_size_word_size_bits word_size_bits_def) + apply (erule word_less_power_trans_ofnat[where k=3 and m=10, simplified], simp) + done + +lemma zero_less_word_size[Arch_AC_assms, simp]: + "0 < (word_size :: obj_ref)" + by (simp add: word_size_def) + +end + + +global_interpretation Arch_AC_1?: Arch_AC_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact Arch_AC_assms) +qed + + +context Arch begin global_naming RISCV64 + +definition level_of_table :: "obj_ref \ 'z :: state_ext state \ vm_level" + where + "level_of_table p s \ + GREATEST lvl. \asid vref. vref \ user_region \ vs_lookup_table lvl asid vref s = Some (lvl, p)" + +lemma level_of_table_vs_lookup_table: + "\ vs_lookup_table level asid vref s = Some (level, p); + ptes_of s p = Some pte; level \ max_pt_level; vref \ user_region; invs s \ + \ level_of_table p s = level" + apply (subst level_of_table_def) + apply (rule Greatest_equality, fastforce) + apply (case_tac "y = asid_pool_level") + apply (fastforce dest: vs_lookup_table_no_asid) + apply (fastforce dest: vs_lookup_table_unique_level) + done + +lemma vs_lookup_slot_level_of_slot: + "\ vs_lookup_slot level asid vref s = Some (level, p); + ptes_of s p = Some pte; level \ max_pt_level; vref \ user_region; invs s \ + \ level_of_slot asid vref p s = level" + apply (subst level_of_slot_def) + apply (rule Greatest_equality) + apply clarsimp + apply (case_tac "y = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid) + apply (fastforce dest: vs_lookup_slot_unique_level) + done + +lemma pool_for_asid_vs_lookupD: + "pool_for_asid asid s = Some p \ + vs_lookup_table asid_pool_level asid vref s = Some (asid_pool_level, p)" + by (simp add: pool_for_asid_vs_lookup) + +lemma vs_lookup_table_vref_independent: + "\ vs_lookup_table level asid vref s = opt; level \ max_pt_level \ + \ vs_lookup_table level asid vref' s = opt" + by (cases "level = asid_pool_level"; clarsimp simp: vs_lookup_table_def) + +lemma state_vrefs_store_NonPageTablePTE: + "\ invs s; is_aligned p pte_bits; vs_lookup_slot level asid vref s = Some (level, p); + vref \ user_region; \ is_PageTablePTE pte; + kheap s (table_base p) = Some (ArchObj (PageTable pt)) \ + \ state_vrefs (s\kheap := \a. if a = table_base p + then Some (ArchObj (PageTable (\a. if a = table_index p + then pte + else pt a))) + else kheap s a\) = + (\x. if \level' vref'. vref_for_level vref' (level + 1) = vref_for_level vref (level + 1) \ + vref' \ user_region \ p = pt_slot_offset level (table_base p) vref' \ + pt_walk level level' (table_base p) vref' (ptes_of s) = Some (level',x) + then (if x = table_base p + then vs_refs_aux level (PageTable (\a. if a = table_index p then pte else pt a)) + else {}) + else state_vrefs s x)" + apply (rule all_ext) + apply (case_tac "level = asid_pool_level") + apply (fastforce simp: vs_lookup_slot_def vs_lookup_table_def + ptes_of_Some pts_of_Some aobjs_of_Some + dest: pool_for_asid_no_pte) + apply (prop_tac "ptes_of s p \ None") + apply (drule valid_vspace_objs_strong_slotD; clarsimp split del: if_split) + apply (frule vs_lookup_slot_table_base; clarsimp split del: if_split) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp split del: if_split) + apply safe + apply (subst (asm) state_vrefs_def opt_map_def)+ + apply (clarsimp split: option.splits split del: if_split) + apply (subst (asm) vs_lookup_non_PageTablePTE[where s=s and s'="kheap_update _ s" and p=p]) + apply (fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some + opt_map_def pte_of_def obind_def + dest: pte_ptr_eq)+ + apply (case_tac "x = table_base p"; clarsimp) + apply (case_tac "lvl = asid_pool_level") + apply (fastforce dest: vs_lookup_table_no_asid[OF vs_lookup_level] + simp: ptes_of_Some pts_of_Some aobjs_of_Some split: if_splits) + apply (fastforce dest: vs_lookup_table_unique_level[OF vs_lookup_level] + elim: allE[where x=level] split: if_splits) + apply (clarsimp split: if_splits) + apply (case_tac "level' = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some) + apply (frule vs_lookup_slot_level_of_slot) + apply (fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some split: option.splits) + apply fastforce+ + apply (subst (asm) vs_lookup_slot_table_unfold; fastforce) + apply (rule conjI; clarsimp) + apply (case_tac "level' < level") + apply (subst (asm) vs_lookup_vref_for_level_eq1, rule sym, assumption) + apply (frule (2) vs_lookup_table_extend) + apply (case_tac "lvl = asid_pool_level") + apply (fastforce dest: vs_lookup_table_pt_at vs_lookup_asid_pool + simp: asid_pools_of_ko_at obj_at_def) + apply (frule_tac level=lvl in vs_lookup_level) + apply (drule (1) vs_lookup_table_unique_level, rule refl) + apply fastforce+ + apply (frule bit0.plus_one_leq) + apply (erule_tac x=level in allE) + apply (subst (asm) vs_lookup_slot_vref_for_level[symmetric], assumption) + apply (frule_tac bot_level=bot in vs_lookup_min_level) + apply (fastforce simp: vs_lookup_slot_vref_for_level vs_lookup_slot_table_unfold) + apply (subst (asm) pt_walk.simps, clarsimp) + apply (fastforce simp: state_vrefs_def opt_map_def) + apply (prop_tac "level_of_slot asid vref p s = level") + apply (fastforce simp: vs_lookup_slot_table_unfold vs_lookup_slot_level_of_slot) + apply (clarsimp split: if_splits) + apply (rule state_vrefsD) + apply (subst vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte]) + apply (fastforce dest: pte_ptr_eq + simp: ptes_of_Some pts_of_Some aobjs_of_Some + opt_map_def pte_of_def obind_def)+ + apply (case_tac "x = table_base p") + apply (fastforce elim: allE[where x=level]) + apply (subst (asm) state_vrefs_def, clarsimp) + apply (rule_tac level=lvl and asid=asida and vref=vrefa in state_vrefsD) + apply (subst vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte]) + apply (fastforce dest: pte_ptr_eq + simp: ptes_of_Some pts_of_Some aobjs_of_Some + opt_map_def pte_of_def obind_def)+ + apply (clarsimp split: if_splits) + apply (intro conjI; clarsimp) + apply (case_tac "level' = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (case_tac "lvl < level") + apply (drule_tac bot_level=bot in vs_lookup_level) + apply (subst (asm) vs_lookup_split_Some, erule dual_order.strict_implies_order) + apply fastforce + apply (drule (1) vs_lookup_table_unique_level; fastforce) + apply (metis vs_lookup_slot_table vs_lookup_slot_unique_level) + apply (fastforce dest: vs_lookup_level) + apply (fastforce simp: aobjs_of_Some opt_map_def) + apply clarsimp + apply clarsimp + done + +lemma state_vrefs_store_NonPageTablePTE': + "\ invs s; is_aligned p pte_bits; \ is_PageTablePTE pte; + kheap s (table_base p) = Some (ArchObj (PageTable pt)); + \level asid vref. vref \ user_region \ vs_lookup_slot level asid vref s \ Some (level, p) \ + \ state_vrefs (s\kheap := \a. if a = table_base p + then Some (ArchObj (PageTable (\a. if a = table_index p + then pte + else pt a))) + else kheap s a\) = + (\x. if x = table_base p \ (\level. \\ (level, table_base p) s) + then vs_refs_aux (level_of_table (table_base p) s) (PageTable (\a. if a = table_index p + then pte + else pt a)) + else state_vrefs s x)" + apply (rule all_ext) + apply safe + apply (subst (asm) state_vrefs_def opt_map_def)+ + apply (clarsimp split: option.splits split del: if_split) + apply (clarsimp split: if_split_asm option.splits split del: if_split) + apply (subst (asm) vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte]) + apply (fastforce dest: pte_ptr_eq + simp: ptes_of_Some pts_of_Some aobjs_of_Some + opt_map_def pte_of_def obind_def)+ + apply (clarsimp split: if_splits) + apply (drule vs_lookup_level) + apply (rule conjI; clarsimp) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_table_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some) + apply (case_tac "lvl = asid_pool_level") + apply (fastforce dest: vs_lookup_table_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some) + apply (subst level_of_table_vs_lookup_table; fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some) + apply (subst (asm) vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte]) + apply (fastforce dest: pte_ptr_eq + simp: ptes_of_Some pts_of_Some aobjs_of_Some + opt_map_def pte_of_def obind_def)+ + apply (fastforce simp: state_vrefs_def aobjs_of_Some) + apply (clarsimp split: if_splits) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_table_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some) + apply (subst (asm) level_of_table_vs_lookup_table) + apply (fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some)+ + apply (rule state_vrefsD) + apply (subst vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte ]) + apply ((fastforce dest: pte_ptr_eq + simp: ptes_of_Some pts_of_Some aobjs_of_Some + opt_map_def pte_of_def obind_def)+)[7] + apply auto[1] + apply (fastforce simp: aobjs_of_Some opt_map_def) + apply clarsimp + apply clarsimp + apply (case_tac "x = table_base p") + apply (fastforce dest: vs_lookup_level simp: state_vrefs_def) + apply (subst (asm) state_vrefs_def, clarsimp) + apply (rule state_vrefsD) + apply (subst vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte ]) + apply ((fastforce dest: pte_ptr_eq + simp: ptes_of_Some pts_of_Some aobjs_of_Some + opt_map_def pte_of_def obind_def)+)[7] + apply auto[1] + apply (fastforce simp: aobjs_of_Some opt_map_def split: option.splits) + apply clarsimp + apply clarsimp + done + +(* FIXME AC: make this less ugly *) +lemma state_vrefs_store_NonPageTablePTE_wp: + "\\s. invs s \ \ is_PageTablePTE pte \ + (\pt. ako_at (PageTable pt) (table_base p) s \ is_aligned p pte_bits \ + (if \level asid vref. vs_lookup_slot level asid vref s = Some (level, p) \ vref \ user_region + then (\level asid vref. vs_lookup_slot level asid vref s = Some (level, p) \ vref \ user_region \ + P (\x. (if \level' vref'. vref_for_level vref' (level + 1) = vref_for_level vref (level + 1) \ + vref' \ user_region \ p = pt_slot_offset level (table_base p) vref' \ + pt_walk level level' (table_base p) vref' (ptes_of s) = Some (level', x) + then (if x = table_base p + then vs_refs_aux level (PageTable (\a. if a = table_index p then pte else pt a)) + else {}) + else state_vrefs s x))) + else P (\x. (if x = table_base p \ (\level. \\ (level, table_base p) s) + then vs_refs_aux (level_of_table (table_base p) s) (PageTable (\a. if a = table_index p then pte else pt a)) + else state_vrefs s x))))\ + store_pte p pte + \\_ s. P (state_vrefs s)\" + unfolding store_pte_def set_pt_def + apply (wpsimp wp: set_object_wp) + apply (case_tac "\level asid vref. vs_lookup_slot level asid vref s = Some (level, p) \ + vref \ user_region") + apply (erule_tac x=pt in allE) + apply (clarsimp simp: fun_upd_def) + apply (subst state_vrefs_store_NonPageTablePTE) + apply fastforce+ + apply (clarsimp simp: obj_at_def) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (case_tac "levela = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (drule (1) vs_lookup_slot_unique_level) + apply fastforce+ + apply clarsimp + apply (frule_tac level'="level+1" in vref_for_level_eq_mono) + apply (fastforce intro: vm_level_less_le_1) + apply clarsimp + apply (erule_tac x=pt in allE) + apply (clarsimp simp: fun_upd_def) + apply (subst state_vrefs_store_NonPageTablePTE'; fastforce simp: obj_at_def) + done + +lemma store_pte_thread_st_auth[wp]: + "store_pte p pte \\s. P (thread_st_auth s)\" + unfolding store_pte_def set_pt_def + apply (wpsimp wp: set_object_wp) + apply (clarsimp simp: get_tcb_def thread_st_auth_def tcb_states_of_state_def obj_at_def + elim!: rsubst[where P=P, OF _ ext]) + done + +lemma store_pte_thread_bound_ntfns[wp]: + "store_pte p pte \\s. P (thread_bound_ntfns s)\" + unfolding store_pte_def set_pt_def + apply (wpsimp wp: set_object_wp) + apply (clarsimp simp: get_tcb_def thread_bound_ntfns_def obj_at_def + elim!: rsubst[where P=P, OF _ ext]) + done + +lemma store_pte_domains_of_state[wp]: + "store_pte p pte \\s. P (domains_of_state s)\" + unfolding store_pte_def set_pt_def by (wpsimp wp: set_object_wp) + +lemma mapM_x_store_pte_caps_of_state[wp]: + "mapM_x (swp store_pte InvalidPTE) slots \\s. P (asid_table s)\" + by (wpsimp wp: mapM_x_wp') + +lemma state_bits_to_policy_vrefs_subseteq: + "\cdt. \ x \ state_bits_to_policy caps ts tbn cdt vrefs; caps = caps'; + ts = ts'; tbn = tbn'; cdt = cdt'; \x. vrefs x \ state_vrefs s x \ + \ x \ state_bits_to_policy caps' ts' tbn' cdt' (state_vrefs s)" + apply (cases x; clarsimp) + apply (erule state_bits_to_policy.cases; fastforce intro: state_bits_to_policy.intros) + done + +lemma state_asids_to_policy_vrefs_subseteq: + "\ x \ state_asids_to_policy_aux aag caps asid_tab vrefs; caps = caps'; + \x. vrefs x \ state_vrefs s x; \x y. asid_tab x = Some y \ asid_table s x = Some y \ + \ x \ state_asids_to_policy_aux aag caps' (asid_table s) (state_vrefs s)" + apply (cases x; clarsimp) + apply (erule state_asids_to_policy_aux.cases; fastforce intro: state_asids_to_policy_aux.intros) + done + +lemma store_InvalidPTE_state_objs_in_policy: + "\\s. state_objs_in_policy aag s \ invs s \ table_base p \ global_refs s \ + ((\a. vspace_for_asid a s = Some (table_base p)) \ table_index p \ kernel_mapping_slots)\ + store_pte p InvalidPTE + \\_ s. state_objs_in_policy aag s\" + apply (rule hoare_weaken_pre) + apply (clarsimp simp: state_objs_to_policy_def pred_conj_def) + apply wps + apply (rule state_vrefs_store_NonPageTablePTE_wp) + apply clarsimp + apply (rule conjI; clarsimp) + apply (intro exI conjI) + apply assumption + apply clarsimp + apply (clarsimp simp: state_objs_to_policy_def) + apply (erule subsetD) + apply (clarsimp simp: auth_graph_map_def) + apply (rule exI, rule conjI, rule refl)+ + apply (erule state_bits_to_policy_vrefs_subseteq; clarsimp) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (erule state_vrefsD) + apply (fastforce simp: aobjs_of_Some obj_at_def) + apply clarsimp + apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits) + apply (clarsimp simp: state_objs_to_policy_def) + apply (erule subsetD) + apply (clarsimp simp: auth_graph_map_def) + apply (rule exI, rule conjI, rule refl)+ + apply (erule state_bits_to_policy_vrefs_subseteq; clarsimp) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_table_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (frule level_of_table_vs_lookup_table) + apply (fastforce dest: vs_lookup_slot_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def)+ + apply (erule state_vrefsD) + apply (fastforce simp: aobjs_of_Some obj_at_def) + apply clarsimp + apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits) + done + +lemma store_InvalidPTE_state_asids_to_policy: + "\\s. state_asids_to_policy aag s \ pasPolicy aag \ invs s \ table_base p \ global_refs s \ + ((\a. vspace_for_asid a s = Some (table_base p)) \ table_index p \ kernel_mapping_slots)\ + store_pte p InvalidPTE + \\_ s. state_asids_to_policy aag s \ pasPolicy aag\" + apply (rule hoare_weaken_pre) + apply (clarsimp simp: state_objs_to_policy_def pred_conj_def) + apply wps + apply (rule state_vrefs_store_NonPageTablePTE_wp) + apply clarsimp + apply (rule conjI; clarsimp) + apply (intro exI conjI) + apply assumption + apply clarsimp + apply clarsimp + apply (erule subsetD) + apply (erule state_asids_to_policy_vrefs_subseteq; clarsimp) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (erule state_vrefsD) + apply (fastforce simp: aobjs_of_Some obj_at_def) + apply clarsimp + apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits) + apply (erule subsetD) + apply (erule state_asids_to_policy_vrefs_subseteq; clarsimp) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_table_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (frule level_of_table_vs_lookup_table) + apply (fastforce dest: vs_lookup_slot_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def)+ + apply (erule state_vrefsD) + apply (fastforce simp: aobjs_of_Some obj_at_def) + apply clarsimp + apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits) + done + +lemma mapM_x_swp_store_InvalidPTE_pas_refined: + "\pas_refined aag and invs and + (\s. \x \ set slots. table_base x \ global_refs s \ + (\asid. vspace_for_asid asid s \ Some (table_base x)))\ + mapM_x (swp store_pte InvalidPTE) slots + \\_ s. pas_refined aag s\" + supply state_asids_to_policy_arch_def[simp del] + apply (rule hoare_strengthen_post) + apply (rule mapM_x_wp[where S="set slots"]) + apply (simp add: pas_refined_def) + apply (wpsimp wp: store_InvalidPTE_state_objs_in_policy store_InvalidPTE_state_asids_to_policy + store_pte_invs hoare_vcg_const_Ball_lift hoare_vcg_all_lift) + apply (auto simp: wellformed_pte_def) + done + +lemma mapM_swp_store_pte_invs_unmap: + "\\s. invs s \ pte = InvalidPTE \ table_base p \ global_refs s + \ (\asid. vspace_for_asid asid s \ Some (table_base p))\ + store_pte p pte + \\_. invs\" + by (wpsimp wp: store_pte_invs simp: wellformed_pte_def) + +lemma store_pte_pas_refined: + "\\s. pas_refined aag s \ invs s \ table_base p \ global_refs s \ + (\slot ref. caps_of_state s slot = Some (ArchObjectCap (PageTableCap (table_base p) ref))) \ + ((\asid. vspace_for_asid asid s = Some (table_base p)) \ table_index p \ kernel_mapping_slots)\ + store_pte p InvalidPTE + \\_. pas_refined aag\" + supply state_asids_to_policy_arch_def[simp del] + apply (clarsimp simp: pas_refined_def) + apply (wpsimp wp: store_InvalidPTE_state_objs_in_policy store_InvalidPTE_state_asids_to_policy) + done + +lemma unmap_page_table_pas_refined: + "\pas_refined aag and invs and K (vaddr \ user_region)\ + unmap_page_table asid vaddr pt + \\_. pas_refined aag\" + unfolding unmap_page_table_def + apply (rule hoare_gen_asm) + apply (wpsimp wp: set_cap_pas_refined get_cap_wp pt_lookup_from_level_wrp store_pte_invs_unmap + store_pte_pas_refined hoare_vcg_imp_lift' hoare_vcg_ball_lift hoare_vcg_all_lift) + apply (rule_tac x=asid in exI) + apply clarsimp + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (intro conjI) + apply (clarsimp simp: reachable_page_table_not_global) + apply (frule vs_lookup_table_pt_at; clarsimp?) + apply (drule vs_lookup_table_valid_cap; clarsimp?) + apply (fastforce simp: valid_cap_def valid_arch_cap_def valid_arch_cap_ref_def obj_at_def + dest: caps_of_state_valid split: cap.splits arch_cap.splits) + apply (metis vs_lookup_table_vspace user_region_slots is_aligned_neg_mask2 pt_slot_offset_offset) + done + +crunch unmap_page_table + for cdt[wp]: "\s. P (cdt s)" + +definition authorised_page_table_inv :: "'a PAS \ page_table_invocation \ bool" where + "authorised_page_table_inv aag pti \ + case pti of PageTableMap cap cslot_ptr pde obj_ref \ + is_subject aag (fst cslot_ptr) \ is_subject aag (obj_ref && ~~ mask pt_bits) \ + pas_cap_cur_auth aag (ArchObjectCap cap) + | PageTableUnmap cap cslot_ptr \ + is_subject aag (fst cslot_ptr) \ + aag_cap_auth aag (pasSubject aag) (ArchObjectCap cap) \ + (\p asid vspace_ref. cap = PageTableCap p (Some (asid, vspace_ref)) + \ is_subject_asid aag asid \ + (\x \ set [p, p + 2 ^ pte_bits .e. p + 2 ^ pt_bits - 1]. + is_subject aag (x && ~~ mask pt_bits)))" + +lemma perform_pt_inv_unmap_pas_refined: + "\pas_refined aag and invs and valid_pti (PageTableUnmap cap ct_slot) + and K (authorised_page_table_inv aag (PageTableUnmap cap ct_slot))\ + perform_pt_inv_unmap cap ct_slot + \\_. pas_refined aag\" + unfolding perform_pt_inv_unmap_def + apply (wpsimp wp: set_cap_pas_refined get_cap_wp) + apply (strengthen invs_psp_aligned invs_vspace_objs invs_arch_state) + apply wps + apply (rule hoare_vcg_all_lift[OF hoare_vcg_imp_lift'[OF mapM_x_wp_inv]], wpsimp wp: mapM_x_wp_inv) + apply (rule hoare_vcg_conj_lift[OF hoare_strengthen_post[OF mapM_x_swp_store_InvalidPTE_pas_refined]], assumption) + apply (rule hoare_vcg_conj_lift[OF hoare_strengthen_post[OF mapM_x_swp_store_pte_invs_unmap]], assumption) + apply (wpsimp wp: pt_lookup_from_level_wrp store_pte_invs_unmap store_pte_pas_refined + mapM_x_wp_inv unmap_page_table_pas_refined + hoare_vcg_imp_lift' hoare_vcg_ball_lift hoare_vcg_all_lift)+ + apply (rule conjI) + apply (fastforce simp: is_PageTableCap_def authorised_page_table_inv_def + valid_pti_def update_map_data_def cte_wp_at_caps_of_state) + apply (clarsimp simp: is_PageTableCap_def authorised_page_table_inv_def valid_arch_cap_def + valid_pti_def cte_wp_at_caps_of_state update_map_data_def aag_cap_auth_def + cap_auth_conferred_def arch_cap_auth_conferred_def wellformed_mapdata_def + cap_links_asid_slot_def cap_links_irq_def is_transferable.simps) + apply (prop_tac "table_base x = acap_obj cap") + apply (drule (1) caps_of_state_aligned_page_table) + 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 (rule conjI; clarsimp) + apply (fastforce simp: cte_wp_at_caps_of_state cap_range_def + dest: invs_valid_global_refs valid_global_refsD) + apply (frule vspace_for_asid_target) + apply (drule valid_vs_lookupD; clarsimp) + apply (drule (1) unique_table_refsD[rotated]; clarsimp) + apply (drule (1) cap_to_pt_is_pt_cap) + apply (clarsimp simp: in_omonad obj_at_def) + apply (fastforce intro: valid_objs_caps) + apply (clarsimp simp: is_cap_simps) + done + +lemma vs_lookup_PageTablePTE: + "\ vs_lookup_table level asid vref s' = Some (lvl', pt); + pspace_aligned s; valid_vspace_objs s; valid_asid_table s; + invalid_pte_at p s; ptes_of s' = (ptes_of s)(p \ pte); is_PageTablePTE pte; + asid_pools_of s' = asid_pools_of s; asid_table s' = asid_table s; + vref \ user_region; + pts_of s (the (pte_ref pte)) = Some empty_pt; pt \ pptr_from_pte pte \ + \ \level' \ level. vs_lookup_table level' asid vref s = Some (lvl', pt)" + apply (induct level arbitrary: lvl' pt rule: bit0.from_top_full_induct[where y=max_pt_level]) + apply (fastforce simp: geq_max_pt_level vs_lookup_table_def pool_for_asid_def obind_def) + apply (rule_tac x=lvl' in exI) + apply (frule vs_lookup_min_level, clarsimp) + apply (drule vs_lookup_level) + apply (case_tac "lvl' < max_pt_level") + apply (frule vs_lookup_table_split_last_Some; clarsimp) + apply (erule_tac x="lvl'+1" in allE) + apply (drule mp) + apply (fastforce elim: le_less_trans dest: vm_level_less_plus_1_mono) + apply (erule_tac x="lvl'+1" in allE) + apply clarsimp + apply (frule subst[where s="ptes_of s'" and P="\ptes. ptes _ = _"]) + apply assumption + apply (drule mp, fastforce simp: pte_ref_def2 ptes_of_Some split: if_splits) + apply (cases pte; clarsimp) + apply (drule_tac bot_level=level' in vs_lookup_level) + apply (subst vs_lookup_split_Some) + prefer 3 + apply (rule exI, rule conjI, assumption) + apply (frule_tac P="\x. x" and level1=lvl' and level'1="lvl'+1" + in subst[OF vs_lookup_split_Some, rotated 2]) + apply (fastforce dest: vm_level_less_le_1) + apply (fastforce dest: vm_level_less_max_pt_level vm_level_less_plus_1_mono) + apply clarsimp + apply (subst (asm) pt_walk.simps) + apply (clarsimp simp: obind_def) + apply (subst pt_walk.simps) + apply (clarsimp split: if_splits simp: obind_def) + apply (fastforce dest: vm_level_less_le_1) + apply (fastforce dest: vm_level_less_max_pt_level vm_level_less_plus_1_mono) + apply (case_tac "lvl' = asid_pool_level") + apply (auto simp: geq_max_pt_level vs_lookup_table_def pool_for_asid_def obind_def) + done + +lemma vs_lookup_PageTablePTE': + "\ vs_lookup_table level asid vref s = Some (lvl', pt); + pspace_aligned s; valid_vspace_objs s; valid_asid_table s; + invalid_pte_at p s; ptes_of s' = (ptes_of s)(p \ pte); is_PageTablePTE pte; + asid_pools_of s' = asid_pools_of s; asid_table s' = asid_table s; vref \ user_region \ + \ \level' \ level. vs_lookup_table level' asid vref s' = Some (lvl', pt)" + apply (induct level arbitrary: lvl' pt rule: bit0.from_top_full_induct[where y=max_pt_level]) + apply (fastforce simp: geq_max_pt_level vs_lookup_table_def pool_for_asid_def obind_def) + apply (rule_tac x=lvl' in exI) + apply (frule vs_lookup_min_level, clarsimp) + apply (drule vs_lookup_level) + apply (case_tac "lvl' < max_pt_level") + apply (frule vs_lookup_table_split_last_Some; clarsimp) + apply (erule_tac x="lvl'+1" in allE) + apply (drule mp) + apply (fastforce elim: le_less_trans dest: vm_level_less_plus_1_mono) + apply (erule_tac x="lvl'+1" in allE) + apply clarsimp + apply (drule_tac bot_level=level' in vs_lookup_level) + apply (subst vs_lookup_split_Some) + prefer 3 + apply (rule exI, rule conjI, assumption) + apply (frule_tac P="\x. x" and level1=lvl' and level'1="lvl'+1" + in subst[OF vs_lookup_split_Some, rotated 2]) + apply (fastforce dest: vm_level_less_le_1) + apply (fastforce dest: vm_level_less_max_pt_level vm_level_less_plus_1_mono) + apply clarsimp + apply (subst (asm) pt_walk.simps) + apply (clarsimp simp: obind_def split: if_splits) + apply (subst pt_walk.simps) + apply (clarsimp simp: obind_def split: if_splits) + apply (cases pte; clarsimp) + apply (frule is_aligned_pt[rotated]) + apply (erule vs_lookup_table_pt_at; fastforce) + apply (clarsimp simp: invalid_pte_at_def ptes_of_Some pts_of_Some aobjs_of_Some) + apply (fastforce dest: vm_level_less_le_1) + apply (fastforce dest: vm_level_less_max_pt_level vm_level_less_plus_1_mono) + apply (case_tac "lvl' = asid_pool_level") + apply (auto simp: geq_max_pt_level vs_lookup_table_def pool_for_asid_def obind_def) + done + +lemma state_vrefs_store_PageTablePTE: + assumes "invs s" + and "is_aligned p pte_bits" + and "vs_lookup_slot level asid vref s = Some (level, p)" + and "vref \ user_region" + and "is_PageTablePTE pte" + and "invalid_pte_at p s" + and "pts_of s (the (pte_ref pte)) = Some empty_pt" + and "the (pte_ref pte) \ table_base p" + and "kheap s (table_base p) = Some (ArchObj (PageTable pt))" + shows "state_vrefs (s\kheap := \a. if a = table_base p + then Some (ArchObj (PageTable (\a. if a = table_index p + then pte + else pt a))) + else kheap s a\) = + (\x. if x = table_base p + then vs_refs_aux level (PageTable (\a. if a = table_index p then pte else pt a)) + else state_vrefs s x)" + (is "state_vrefs ?s' = _") + using assms + apply - + apply (rule all_ext) + apply (case_tac "level = asid_pool_level") + apply (fastforce simp: vs_lookup_slot_def vs_lookup_table_def + ptes_of_Some pts_of_Some aobjs_of_Some + dest: pool_for_asid_no_pte split: if_splits) + apply safe + apply (clarsimp simp: state_vrefs_def opt_map_def split: option.splits) + apply (case_tac "x = pptr_from_pte pte") + apply (clarsimp simp: pte_ref_def2 split: if_splits) + apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def) + apply (drule_tac s=s and pte=pte and p=p in vs_lookup_PageTablePTE) + apply (fastforce simp: pts_of_Some aobjs_of_Some opt_map_def pte_of_def obind_def + dest: pte_ptr_eq)+ + apply clarsimp + apply (drule vs_lookup_level) + apply (case_tac "lvl = asid_pool_level") + apply (fastforce dest: vs_lookup_asid_pool simp: asid_pools_of_ko_at obj_at_def) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (fastforce dest: vs_lookup_table_unique_level split: if_splits) + apply (clarsimp simp: state_vrefs_def opt_map_def) + apply (frule vs_lookup_slot_table_base) + apply clarsimp+ + apply (case_tac "x = table_base p"; clarsimp) + apply (drule_tac pte=pte and s'="?s'" in vs_lookup_PageTablePTE'; + fastforce dest: pte_ptr_eq simp: pts_of_Some aobjs_of_Some opt_map_def pte_of_def obind_def) + apply (drule_tac level=bot and pte=pte and s'="?s'" in vs_lookup_PageTablePTE'; + fastforce dest: pte_ptr_eq simp: pts_of_Some aobjs_of_Some opt_map_def pte_of_def obind_def) + done + +lemma state_vrefs_store_PageTablePTE_wp: + "\\s. invs s \ is_PageTablePTE pte \ invalid_pte_at p s \ + pts_of s (the (pte_ref pte)) = Some empty_pt \ the (pte_ref pte) \ table_base p \ + (\level asid vref. vs_lookup_slot level asid vref s = Some (level, p) \ vref \ user_region \ + (\pt. ako_at (PageTable pt) (table_base p) s \ + P (\x. if x = table_base p + then vs_refs_aux level (PageTable (\a. if a = table_index p + then pte + else pt a)) + else state_vrefs s x)))\ + store_pte p pte + \\_ s. P (state_vrefs s)\" + unfolding store_pte_def set_pt_def + apply (wpsimp wp: set_object_wp) + apply (fastforce simp: fun_upd_def obj_at_def state_vrefs_store_PageTablePTE) + done + +lemma perform_pt_inv_map_pas_refined[wp]: + "\pas_refined aag and invs and valid_pti (PageTableMap acap (a, b) pte p) + and K (authorised_page_table_inv aag (PageTableMap acap (a, b) pte p))\ + perform_pt_inv_map acap (a,b) pte p + \\_. pas_refined aag\" + unfolding perform_pt_inv_map_def + apply (rule hoare_gen_asm) + apply (wpsimp simp: pas_refined_def state_objs_to_policy_def) + apply (wps | wpsimp wp: state_vrefs_store_PageTablePTE_wp arch_update_cap_invs_map + vs_lookup_slot_lift set_cap_arch_obj_neg set_cap_state_vrefs + hoare_vcg_ex_lift hoare_vcg_all_lift hoare_vcg_imp_lift')+ + apply (clarsimp simp: invs_psp_aligned invs_vspace_objs invs_arch_state + valid_pti_def cte_wp_at_cte_at) + apply (case_tac acap; clarsimp) + apply (intro conjI; (solves \simp add: pas_refined_def\)?) + apply (fastforce simp: cte_wp_at_caps_of_state vs_cap_ref_def + is_arch_update_def cap_master_cap_def + split: arch_cap.splits) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (fastforce dest: caps_of_state_valid + simp: vs_cap_ref_def is_arch_update_def cap_master_cap_def + valid_cap_def cap_aligned_def valid_arch_cap_def + split: cap.splits arch_cap.splits) + apply (clarsimp simp: vs_lookup_slot_def split: if_splits) + apply (fastforce dest: pool_for_asid_no_pte simp: vs_lookup_table_def invalid_pte_at_def) + apply (frule (2) vs_lookup_table_is_aligned; clarsimp) + apply (drule (1) vs_lookup_table_target) + apply (drule valid_vs_lookupD, erule vref_for_level_user_region; clarsimp) + apply (frule (1) cap_to_pt_is_pt_cap, simp, fastforce intro: valid_objs_caps) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (clarsimp simp: is_cap_simps is_arch_update_def cap_master_cap_def + split: cap.splits arch_cap.splits) + apply (drule (1) unique_table_refsD[rotated]; fastforce simp: table_cap_ref_def) + apply (intro exI conjI; (simp | clarsimp)) + apply (intro conjI) + apply (clarsimp simp: pas_refined_def cte_wp_at_caps_of_state auth_graph_map_def) + apply (erule state_bits_to_policy.cases) + apply (clarsimp simp: is_arch_update_def cap_master_cap_def state_objs_to_policy_def + split: if_splits cap.splits arch_cap.splits option.splits; + fastforce dest: sbta_caps simp: cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (fastforce dest: sbta_untyped simp: state_objs_to_policy_def split: if_splits) + apply (fastforce dest: sbta_ts simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_bounds simp: state_objs_to_policy_def) + apply (clarsimp simp: state_objs_to_policy_def is_arch_update_def cap_master_cap_def) + apply (drule_tac caps="caps_of_state s" in sbta_cdt; fastforce elim: is_transferable.cases + split: if_splits) + apply (fastforce dest: sbta_cdt_transferable simp: state_objs_to_policy_def) + apply (clarsimp split: if_splits) + apply (clarsimp simp: authorised_page_table_inv_def vs_refs_aux_def split: arch_kernel_obj.splits) + apply (erule swap) + apply (clarsimp simp: graph_of_def pte_ref2_def split: if_split_asm) + apply (cases pte; clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (erule subsetD) + apply (clarsimp simp: auth_graph_map_def state_objs_to_policy_def) + apply (rule_tac x="table_base p" in exI, rule conjI, erule sym) + apply (rule exI, rule conjI, rule refl) + apply (rule sbta_vref) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: pool_for_asid_no_pte + simp: vs_lookup_slot_def vs_lookup_table_def invalid_pte_at_def) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (erule state_vrefsD) + apply (fastforce simp: aobjs_of_Some obj_at_def) + apply clarsimp + apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def) + apply (clarsimp simp: is_arch_update_def cap_master_cap_def + split: cap.splits arch_cap.splits option.splits) + apply (fastforce dest: sbta_vref simp: pas_refined_def auth_graph_map_def state_objs_to_policy_def) + apply (clarsimp simp: pas_refined_def) + apply (erule state_asids_to_policy_aux.cases) + apply (clarsimp simp: cte_wp_at_caps_of_state split: if_splits) + apply (clarsimp simp: authorised_page_table_inv_def aag_cap_auth_def + cap_auth_conferred_def arch_cap_auth_conferred_def + cap_links_asid_slot_def label_owns_asid_slot_def) + apply (fastforce dest: sata_asid) + apply (clarsimp split: if_splits) + apply (fastforce dest!: state_asids_to_policy_aux.intros simp: vs_refs_aux_def) + apply (fastforce dest!: sata_asid_lookup) + apply (fastforce dest!: sata_asidpool) + apply (clarsimp simp: pas_refined_def) + apply (erule state_irqs_to_policy_aux.cases) + apply (clarsimp split: if_splits) + apply (fastforce dest: sita_controlled) + done + +lemma perform_page_table_invocation_pas_refined: + "\pas_refined aag and invs and valid_pti iv and K (authorised_page_table_inv aag iv)\ + perform_page_table_invocation iv + \\_. pas_refined aag\" + unfolding perform_page_table_invocation_def + apply wpsimp + apply (wpsimp wp: perform_pt_inv_unmap_pas_refined perform_pt_inv_map_pas_refined)+ + apply (case_tac iv; clarsimp) + done + +(* FIXME move to AInvs *) +lemma store_pte_ekheap[wp]: + "store_pte p pte \\s. P (ekheap s)\" + apply (simp add: store_pte_def set_pt_def) + apply (wp get_object_wp) + apply simp + done + +lemma set_asid_pool_thread_st_auth[wp]: + "set_asid_pool p pool \\s. P (thread_st_auth s)\" + apply (simp add: set_asid_pool_def) + apply (wpsimp wp: set_object_wp_strong) + apply (clarsimp simp: thread_st_auth_def obj_at_def get_tcb_def tcb_states_of_state_def + elim!: rsubst[where P=P, OF _ ext] + split: kernel_object.split_asm option.split) + done + +lemma set_asid_pool_thread_bound_ntfns[wp]: + "set_asid_pool p pool \\s. P (thread_bound_ntfns s)\" + apply (simp add: set_asid_pool_def) + apply (wpsimp wp: set_object_wp_strong) + apply (clarsimp simp: thread_bound_ntfns_def obj_at_def get_tcb_def tcb_states_of_state_def + elim!: rsubst[where P=P, OF _ ext] + split: kernel_object.split_asm option.split) + done + +(* FIXME move to AInvs *) +lemma set_asid_pool_ekheap[wp]: + "set_asid_pool p pool \\s. P (ekheap s)\" + apply (simp add: set_asid_pool_def) + apply (wp get_object_wp | simp)+ + done + +crunch set_asid_pool + for integrity_autarch: "integrity aag X st" + (wp: crunch_wps) + +lemma store_pte_respects: + "\integrity aag X st and K (is_subject aag (table_base p))\ + store_pte p pte + \\_. integrity aag X st\" + apply (simp add: store_pte_def set_pt_def) + apply (wp get_object_wp set_object_integrity_autarch) + apply simp + done + +lemma integrity_arch_state[iff]: + "riscv_asid_table v = riscv_asid_table (arch_state s) + \ integrity aag X st (s\arch_state := v\) = integrity aag X st s" + unfolding integrity_def by simp + +lemma integrity_riscv_global_pts[iff]: + "integrity aag X st (s\arch_state := ((arch_state s)\riscv_global_pts := v\)\) = + integrity aag X st s" + unfolding integrity_def by simp + +lemma integrity_riscv_kernel_vspace[iff]: + "integrity aag X st (s\arch_state := ((arch_state s)\riscv_kernel_vspace := v\)\) = + integrity aag X st s" + unfolding integrity_def by simp + +lemma is_subject_trans: + "\ is_subject aag x; pas_refined aag s; + (pasObjectAbs aag x, Control, pasObjectAbs aag y) \ pasPolicy aag \ + \ is_subject aag y" + by (subst aag_has_Control_iff_owns[symmetric]; simp) + +lemma is_subject_asid_trans: + "\ is_subject_asid aag x; pas_refined aag s; + (pasASIDAbs aag x, Control, pasObjectAbs aag y) \ pasPolicy aag \ + \ is_subject aag y" + by (subst aag_has_Control_iff_owns[symmetric]; simp) + +lemma pt_walk_is_subject: + "\ pas_refined aag s; valid_vspace_objs s; valid_asid_table s; pspace_aligned s; + pt_walk level bot_level pt_ptr vptr (ptes_of s) = Some (level', pt); + vs_lookup_table level asid vptr s = Some (level, pt_ptr); + level \ max_pt_level; vptr \ user_region; is_subject aag pt_ptr \ + \ is_subject aag pt" + apply (induct level arbitrary: pt_ptr; clarsimp) + apply (erule_tac x="pptr_from_pte (the (ptes_of s (pt_slot_offset level pt_ptr vptr)))" in meta_allE) + apply (subst (asm) pt_walk.simps) + apply (clarsimp simp: obind_def split: if_splits option.splits) + apply (drule meta_mp) + apply (erule vs_lookup_table_extend) + apply (subst pt_walk.simps, clarsimp simp: obind_def) + apply clarsimp + apply (erule meta_mp) + apply (frule vs_lookup_table_pt_at; clarsimp simp: pt_at_eq) + apply (erule (1) is_subject_trans) + apply (clarsimp simp: pas_refined_def auth_graph_map_def) + apply (erule subsetD, clarsimp) + apply (rule exI conjI refl sta_vref)+ + apply (erule state_vrefsD) + apply (fastforce simp: pts_of_Some) + apply clarsimp + apply (frule_tac pt_ptr=pt_ptr in pspace_aligned_pts_ofD, simp) + apply (clarsimp simp: ptes_of_def obind_def is_PageTablePTE_def vs_refs_aux_def split: option.splits) + apply (drule_tac g=y and f="pte_ref2 level" in graph_of_comp) + apply (fastforce simp: pte_ref2_def) + apply (fastforce simp: aobjs_of_Some pts_of_Some pptr_from_pte_def + dest: table_index_max_level_slots + elim: rev_bexI bexI_minus[rotated] + intro!: pts_of_Some_alignedD) + done + +lemma pt_lookup_slot_from_level_is_subject: + "\ pas_refined aag s; valid_vspace_objs s; valid_asid_table s; pspace_aligned s; + pt_lookup_slot_from_level level bot_level pt_ptr vptr (ptes_of s) = Some (level', pt); + (\asid. vs_lookup_table level asid vptr s = Some (level, pt_ptr)); + level \ max_pt_level; vptr \ user_region; is_subject aag pt_ptr \ + \ is_subject aag (table_base pt)" + by (fastforce dest: pt_walk_is_aligned vs_lookup_table_is_aligned pt_walk_is_subject + simp: pt_lookup_slot_from_level_def obind_def split: option.splits) + +lemma pt_lookup_from_level_is_subject: + "\\s. pas_refined aag s \ pspace_aligned s \ valid_vspace_objs s \ valid_asid_table s \ + is_subject aag pt_ptr \ level \ max_pt_level \ vref \ user_region \ + (\asid. vs_lookup_table level asid vref s = Some (level, pt_ptr))\ + pt_lookup_from_level level pt_ptr vref pt + \\rv _. is_subject aag (table_base rv)\, -" + apply (wpsimp wp: pt_lookup_from_level_wp) + apply (erule_tac level=level and bot_level=levela and pt_ptr=pt_ptr and vptr=vref + in pt_lookup_slot_from_level_is_subject) + by (auto simp: pt_lookup_slot_from_level_def obind_def) + +lemma unmap_page_table_respects: + "\integrity aag X st and pas_refined aag and invs + and K (is_subject_asid aag asid \ vaddr \ user_region)\ + unmap_page_table asid vaddr pt + \\_. integrity aag X st\" + apply (simp add: unmap_page_table_def sfence_def) + apply (wpsimp wp: pt_lookup_from_level_is_subject dmo_mol_respects hoare_vcg_conj_liftE_weaker + store_pte_respects pt_lookup_from_level_wrp[where Q="\_. integrity aag X st"] + | wp (once) hoare_drop_imps hoare_vcg_conj_elimE)+ + apply (intro conjI; clarsimp) + apply fastforce + apply (rule aag_Control_into_owns[rotated], assumption) + apply (drule sym) + apply (clarsimp simp: vspace_for_asid_def obj_at_def pas_refined_def) + apply (erule_tac A="state_asids_to_policy_aux _ _ _ _" in subsetD) + apply (rule sata_asid_lookup) + apply (simp add: vspace_for_pool_def pool_for_asid_def) + apply (clarsimp simp: vspace_for_pool_def) + apply (drule pool_for_asid_vs_lookupD) + apply (erule state_vrefsD) + apply (fastforce simp: aobjs_of_Some asid_pools_of_ko_at obj_at_def) + apply assumption + apply (fastforce simp: vs_refs_aux_def graph_of_def asid_low_bits_of_mask_eq[symmetric] + word_size ucast_ucast_b is_up_def source_size_def target_size_def) + apply (fastforce dest: vs_lookup_table_vref_independent[OF vspace_for_asid_vs_lookup]) + done + +lemma perform_page_table_invocation_respects: + "\integrity aag X st and pas_refined aag and invs and valid_pti page_table_invocation + and K (authorised_page_table_inv aag page_table_invocation)\ + perform_page_table_invocation page_table_invocation + \\_. integrity aag X st\" + apply (rule hoare_gen_asm) + apply (simp add: perform_page_table_invocation_def perform_pt_inv_map_def perform_pt_inv_unmap_def + cong: page_table_invocation.case_cong option.case_cong prod.case_cong + cap.case_cong arch_cap.case_cong) + apply (cases page_table_invocation; clarsimp) + apply (wpsimp wp: set_cap_integrity_autarch store_pte_respects + simp: authorised_page_table_inv_def sfence_def) + apply (rename_tac cap fst_cslot_ptr snd_cslot_ptr) + apply (wpsimp wp: set_cap_integrity_autarch) + apply (rule_tac I="\s. integrity aag X st s \ is_subject aag fst_cslot_ptr \ is_PageTableCap cap" + in mapM_x_inv_wp; clarsimp) + apply (rule_tac P="\s. integrity aag X st s \ is_PageTableCap cap" in hoare_vcg_conj_lift) + apply (wpsimp wp: store_pte_respects) + apply (clarsimp simp: authorised_page_table_inv_def) + apply (case_tac cap; clarsimp) + apply (wpsimp wp: unmap_page_table_respects)+ + apply (clarsimp simp: authorised_page_table_inv_def valid_pti_def valid_arch_cap_def + wellformed_acap_def wellformed_mapdata_def + split: arch_cap.splits) + done + +lemma perform_pg_inv_get_addr_pas_refined [wp]: + "\pas_refined aag and invs\ + perform_pg_inv_get_addr ptr + \\_. pas_refined aag\" + unfolding perform_pg_inv_get_addr_def + by wpsimp + +lemma unmap_page_pas_refined: + "\pas_refined aag and invs and K (vptr \ user_region)\ + unmap_page pgsz asid vptr pptr + \\_. pas_refined aag\" + unfolding unmap_page_def + apply (clarsimp simp: conj_ac | wpsimp wp: set_cap_pas_refined_not_transferable hoare_vcg_all_lift + hoare_vcg_imp_lift' get_cap_wp store_pte_pas_refined + store_pte_valid_arch_state_unreachable)+ + 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) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (intro conjI) + apply (clarsimp simp: reachable_page_table_not_global) + apply (frule vs_lookup_table_pt_at; clarsimp?) + apply (drule vs_lookup_table_valid_cap; clarsimp?) + apply (fastforce simp: valid_cap_def valid_arch_cap_def valid_arch_cap_ref_def obj_at_def + dest: caps_of_state_valid split: cap.splits arch_cap.splits) + apply (metis vs_lookup_table_vspace user_region_slots is_aligned_neg_mask2 pt_slot_offset_offset) + done + +definition authorised_slots :: "'a PAS \ pte \ obj_ref \ 's :: state_ext state \ bool" where + "authorised_slots aag m s \ case m of (pte, slot) \ + (\level asid vref x. + vs_lookup_slot level asid vref s = Some (level, slot) \ + vref \ user_region \ + level \ max_pt_level \ + pte_ref2 level pte = Some x \ + (\a \ snd (snd x). \p \ ptr_range (fst x) (fst (snd x)). aag_has_auth_to aag a p)) \ + is_subject aag (table_base slot)" + +definition authorised_page_inv :: "'a PAS \ page_invocation \ 's :: state_ext state \ bool" where + "authorised_page_inv aag pgi s \ case pgi of + PageMap cap ptr slots \ pas_cap_cur_auth aag (ArchObjectCap cap) \ + is_subject aag (fst ptr) \ authorised_slots aag slots s + | PageUnmap cap ptr \ pas_cap_cur_auth aag (ArchObjectCap cap) \ is_subject aag (fst ptr) + | PageGetAddr ptr \ True" + +lemma perform_pg_inv_unmap_pas_refined: + "\pas_refined aag and invs and valid_page_inv (PageUnmap cap ct_slot) + and authorised_page_inv aag (PageUnmap cap ct_slot)\ + perform_pg_inv_unmap cap ct_slot + \\_. pas_refined aag\" + unfolding perform_pg_inv_unmap_def + apply (strengthen invs_psp_aligned invs_vspace_objs invs_arch_state + | wpsimp wp: unmap_page_pas_refined set_cap_pas_refined_not_transferable + unmap_page_invs get_cap_wp hoare_vcg_all_lift hoare_vcg_imp_lift)+ + apply (fastforce simp: authorised_page_inv_def valid_page_inv_def valid_arch_cap_def + cte_wp_at_caps_of_state update_map_data_def aag_cap_auth_def + cap_auth_conferred_def arch_cap_auth_conferred_def + cap_links_asid_slot_def cap_links_irq_def wellformed_mapdata_def) + done + +lemma set_cap_vs_lookup_slot[wp]: + "set_cap param_a param_b \\s. P (vs_lookup_slot level asid vref s)\ " + apply (clarsimp simp: vs_lookup_slot_def obind_def) + apply (rule hoare_pre) + apply (rule hoare_lift_Pf3[where f="\s level asid vref. vs_lookup_table level asid vref s"]) + apply (clarsimp split: option.splits) + apply wpsimp + apply wpsimp + apply (auto split: if_splits) + done + +crunch set_cap + for level_of_table[wp]: "\s. P (level_of_table p s)" + (simp: level_of_table_def) + +lemma set_cap_authorised_page_inv[wp]: + "set_cap param_a param_b \\s. P (authorised_page_inv aag (PageMap cap ct_slot entries) s)\ " + apply (clarsimp simp: authorised_page_inv_def authorised_slots_def) + apply (rule hoare_pre) + apply wps + apply wp + apply clarsimp + done + +lemma set_cap_same_ref[wp]: + "set_cap param_a param_b \\s. P (same_ref pte_slot cap s)\ " + apply (case_tac pte_slot; clarsimp) + apply (clarsimp simp: same_ref_def) + apply (rule hoare_pre) + apply wps + apply wp + apply clarsimp + done + +lemma perform_pg_inv_map_pas_refined: + "\pas_refined aag and invs and valid_page_inv (PageMap cap ct_slot (pte,slot)) + and authorised_page_inv aag (PageMap cap ct_slot (pte,slot))\ + perform_pg_inv_map cap ct_slot pte slot + \\_. pas_refined aag\" + unfolding perform_pg_inv_map_def + apply (wpsimp simp: simp: pas_refined_def state_objs_to_policy_def) + apply (subst conj_commute, subst conj_commute) + apply clarsimp + apply (rule hoare_vcg_conj_lift, wpsimp) + apply wps + apply (rule state_vrefs_store_NonPageTablePTE_wp) + apply (rule_tac Q'="\_. invs and pas_refined aag and K (\ is_PageTablePTE pte) + and authorised_page_inv aag (PageMap cap ct_slot (pte,slot)) + and same_ref (pte,slot) (ArchObjectCap cap)" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: pas_refined_def) + apply (rule conjI) + apply clarsimp + apply (intro exI, rule conjI, assumption) + apply clarsimp + apply (rule conjI) + apply clarsimp + apply (erule_tac A="state_asids_to_policy_aux _ _ _ _" in subsetD) + apply (erule state_asids_to_policy_aux.cases) + apply (fastforce dest: sata_asid) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (clarsimp simp only: split: if_splits) + apply (clarsimp simp: vs_refs_aux_def) + apply (erule sata_asid_lookup) + apply assumption + apply (fastforce dest: sata_asidpool) + apply (clarsimp simp: auth_graph_map_def authorised_page_inv_def) + apply (erule state_bits_to_policy.cases) + apply (fastforce dest: sbta_caps simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_untyped simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_ts simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_bounds simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_cdt simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_cdt_transferable simp: state_objs_to_policy_def) + apply (clarsimp split: if_split_asm) + apply (clarsimp simp: vs_refs_aux_def graph_of_def) + apply (erule_tac P="_ \ _" in swap) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest!: vs_lookup_slot_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (clarsimp split: if_split_asm) + apply (case_tac pte; clarsimp simp: authorised_slots_def) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (erule subsetD) + apply (clarsimp simp: state_objs_to_policy_def) + apply (rule exI, rule conjI, rule refl)+ + apply (rule sbta_vref) + apply (erule state_vrefsD) + apply (fastforce simp: aobjs_of_Some obj_at_def) + apply fastforce + apply (fastforce simp: vs_refs_aux_def graph_of_def) + apply (fastforce dest: sbta_vref simp: state_objs_to_policy_def) + apply (clarsimp simp: same_ref_def) + apply (wpsimp wp: arch_update_cap_invs_map set_cap_pas_refined_not_transferable) + apply (clarsimp simp: valid_page_inv_def authorised_page_inv_def cte_wp_at_caps_of_state + is_frame_cap_def is_arch_update_def cap_master_cap_def + split: arch_cap.splits) + apply (rule conjI) + apply (fastforce dest: vs_lookup_slot_unique_level simp: same_ref_def parent_for_refs_def) + apply (fastforce dest: vs_lookup_slot_unique_level caps_of_state_valid + simp: valid_arch_cap_def valid_cap_def cap_aligned_def) + done + +lemma perform_page_invocation_pas_refined: + "\pas_refined aag and invs and authorised_page_inv aag pgi and valid_page_inv pgi\ + perform_page_invocation pgi + \\_. pas_refined aag\" + apply (simp add: perform_page_invocation_def) + apply (wpsimp wp: perform_pg_inv_map_pas_refined perform_pg_inv_unmap_pas_refined) + apply auto + done + +lemma unmap_page_respects: + "\integrity aag X st and pspace_aligned and valid_vspace_objs and valid_arch_state + and K (is_subject_asid aag asid) and pas_refined aag + and K (vptr \ user_region)\ + unmap_page sz asid vptr pptr + \\_. integrity aag X st\" + apply (rule hoare_gen_asm) + apply (simp add: unmap_page_def swp_def cong: vmpage_size.case_cong) + apply (rule hoare_pre) + apply (wpsimp wp: store_pte_respects + hoare_drop_imps[where Q="\rv. integrity aag X st"] + simp: sfence_def is_aligned_mask[symmetric] + | wp (once) hoare_drop_imps + mapM_set''[where f="(\a. store_pte a InvalidPTE)" + and I="\x s. is_subject aag (x && ~~ mask pt_bits)" + and Q="integrity aag X st"] + | wp (once) hoare_drop_imps[where Q'="\rv s. rv"])+ + apply (clarsimp simp: pt_lookup_slot_def) + apply (frule pt_lookup_slot_from_level_is_subject) + apply (fastforce simp: valid_arch_state_asid_table + dest: vs_lookup_table_vref_independent[OF vspace_for_asid_vs_lookup])+ + apply (erule (1) is_subject_asid_trans) + apply (clarsimp simp: pas_refined_def vspace_for_asid_def vspace_for_pool_def) + apply (erule subsetD[where A="state_asids_to_policy_aux _ _ _ _"]) + apply (rule sata_asid_lookup) + apply (fastforce simp: pool_for_asid_def) + apply (frule pool_for_asid_vs_lookupD) + apply (erule state_vrefsD) + apply (fastforce simp: vspace_for_pool_def opt_map_def split: option.splits) + apply assumption + apply (fastforce simp: vs_refs_aux_def graph_of_def asid_low_bits_of_mask_eq[symmetric] word_size + ucast_ucast_b ucast_up_ucast_id is_up_def source_size_def target_size_def) + apply simp + done + +lemma perform_page_invocation_respects: + "\integrity aag X st and pas_refined aag and authorised_page_inv aag pgi + and valid_page_inv pgi and valid_vspace_objs + and pspace_aligned and valid_vspace_objs and valid_arch_state + and is_subject aag \ cur_thread\ + perform_page_invocation pgi + \\_. integrity aag X st\" +proof - + have set_tl_subset_mp: "\xs a. a \ set (tl xs) \ a \ set xs" by (case_tac xs; clarsimp) + show ?thesis + apply (unfold authorised_page_inv_def) + apply (simp add: perform_page_invocation_def mapM_discarded swp_def valid_page_inv_def + valid_unmap_def authorised_page_inv_def authorised_slots_def + perform_pg_inv_map_def perform_pg_inv_unmap_def sfence_def + split: page_invocation.split sum.split + arch_cap.split option.split, safe) + apply ((wp set_cap_integrity_autarch unmap_page_respects + mapM_x_and_const_wp[OF store_pte_respects] store_pte_respects + | elim conjE + | clarsimp dest!: set_tl_subset_mp + | wpc)+) + apply (rule conjI) + apply (case_tac m; clarsimp) + apply (clarsimp simp: aag_cap_auth_def cte_wp_at_caps_of_state) + apply (prop_tac "a \ acap_asid' (FrameCap r R sz dev (Some (a,b)))", clarsimp) + apply (drule (1) sata_asid[where aag=aag]) + apply (clarsimp simp: pas_refined_def) + apply (drule (1) subsetD) + apply (fastforce dest: aag_wellformed_Control) + apply (fastforce simp: valid_arch_cap_def wellformed_mapdata_def split: if_splits) + apply (wpsimp wp: set_mrs_integrity_autarch set_message_info_integrity_autarch + simp: ipc_buffer_has_auth_def perform_pg_inv_get_addr_def) + done +qed + +lemma integrity_asid_table_entry_update': + "\ integrity aag X st s; atable = riscv_asid_table (arch_state s); is_subject aag v; + (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of asid \ is_subject_asid aag asid') \ + \ integrity aag X st (s\arch_state := + arch_state s\riscv_asid_table := \a. if a = asid_high_bits_of asid + then (Some v) + else atable a\\)" + by (clarsimp simp: integrity_def) + +lemma asid_table_entry_update_integrity: + "\integrity aag X st and (\s. atable = riscv_asid_table (arch_state s)) and K (is_subject aag v) + and K (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of asid + \ is_subject_asid aag asid')\ + modify (\s. s\arch_state := arch_state s\riscv_asid_table := atable(asid_high_bits_of asid := Some v)\\) + \\_. integrity aag X st\" + by wpsimp (blast intro: integrity_asid_table_entry_update') + +definition authorised_asid_control_inv :: "'a PAS \ asid_control_invocation \ bool" where + "authorised_asid_control_inv aag aci \ + case aci of MakePool frame slot parent base \ + is_subject aag (fst slot) \ is_aligned frame pageBits \ + (\asid. is_subject_asid aag asid) \ is_subject aag (fst parent) \ + (\x \ {frame..frame + 2 ^ pageBits - 1}. is_subject aag x)" + +lemma perform_asid_control_invocation_respects: + "\integrity aag X st and invs and valid_aci aci and K (authorised_asid_control_inv aag aci)\ + perform_asid_control_invocation aci + \\_. integrity aag X st\" + apply (simp add: perform_asid_control_invocation_def) + apply (wpc, simp) + apply (wpsimp wp: set_cap_integrity_autarch cap_insert_integrity_autarch + asid_table_entry_update_integrity retype_region_integrity[where sz=12] + hoare_weak_lift_imp delete_objects_valid_vspace_objs delete_objects_valid_arch_state) + apply (clarsimp simp: authorised_asid_control_inv_def ptr_range_def add.commute range_cover_def + obj_bits_api_def default_arch_object_def pageBits_def word_bits_def) + apply (subst is_aligned_neg_mask_eq[THEN sym], assumption) + apply (clarsimp simp: and_mask_eq_iff_shiftr_0 mask_zero word_size_bits_def) + apply (frule is_aligned_no_overflow_mask) + apply (clarsimp simp: mask_def) + done + +lemma state_vrefs_asid_pool_map: + "\ ako_at (ASIDPool Map.empty) frame s; asid_table s (asid_high_bits_of base) = None \ + \ state_vrefs (s\arch_state := arch_state s\riscv_asid_table := \a. if a = asid_high_bits_of base + then Some frame + else asid_table s a\\) + = state_vrefs s" + apply (rule all_ext) + apply clarsimp + apply safe + apply (subst (asm) state_vrefs_def, clarsimp) + apply (case_tac "asid_high_bits_of asid = asid_high_bits_of base") + apply (clarsimp simp: vs_lookup_table_def pool_for_asid_def vspace_for_pool_def graph_of_def + asid_pools_of_ko_at obj_at_def vs_refs_aux_def aobjs_of_Some + split: if_splits) + apply (subst (asm) asid_update.vs_lookup_table[simplified fun_upd_def]) + apply (clarsimp simp: asid_update_def asid_pools_of_ko_at) + apply (clarsimp split: if_splits) + apply (erule (3) state_vrefsD) + apply (subst (asm) state_vrefs_def, clarsimp) + apply (case_tac "asid_high_bits_of asid = asid_high_bits_of base") + apply (clarsimp simp: vs_lookup_table_def pool_for_asid_def) + apply (rule_tac level=bot and asid=asid and vref=vref in state_vrefsD) + apply (subst asid_update.vs_lookup_table[simplified fun_upd_def]) + apply (clarsimp simp: asid_update_def asid_pools_of_ko_at) + apply fastforce + apply (fastforce simp: aobjs_of_Some) + apply clarsimp + apply clarsimp + done + +lemma pas_refined_asid_control_helper: + "authorised_asid_control_inv aag (MakePool frame slot parent base) \ + \\s. pas_refined aag s \ ko_at (ArchObj (ASIDPool Map.empty)) frame s + \ asid_table s (asid_high_bits_of base) = None\ + do asid_table <- gets (riscv_asid_table \ arch_state); + asid_table' <- return (asid_table(asid_high_bits_of base \ frame)); + modify (\s. s\arch_state := arch_state s\riscv_asid_table := asid_table'\\) + od + \\_. pas_refined aag\" + unfolding pas_refined_def + apply wpsimp + apply (rule conjI) + apply (clarsimp simp: auth_graph_map_def state_objs_to_policy_def) + apply (erule state_bits_to_policy.cases) + apply (fastforce dest: sbta_caps) + apply (fastforce dest: sbta_untyped) + apply (fastforce dest: sbta_ts) + apply (fastforce dest: sbta_bounds) + apply (fastforce dest: sbta_cdt) + apply (fastforce dest: sbta_cdt_transferable) + apply (fastforce dest: sbta_vref simp: state_vrefs_asid_pool_map) + apply clarsimp + apply (erule state_asids_to_policy_aux.cases) + apply (fastforce dest: sata_asid) + apply (subst (asm) state_vrefs_asid_pool_map; clarsimp) + apply (case_tac "asid_high_bits_of asid = asid_high_bits_of base") + apply (clarsimp simp: state_vrefs_def aobjs_of_Some obj_at_def vs_refs_aux_def graph_of_def) + apply (drule sata_asid_lookup[rotated]; fastforce) + apply (clarsimp split: if_splits) + apply (fastforce simp: authorised_asid_control_inv_def is_aligned_no_overflow aag_wellformed_refl) + apply (fastforce dest: sata_asidpool) + done + +lemma perform_asid_control_invocation_pas_refined: + "\pas_refined aag and pas_cur_domain aag and invs and valid_aci aci and ct_active + and K (authorised_asid_control_inv aag aci)\ + perform_asid_control_invocation aci + \\_. pas_refined aag\" + apply (rule hoare_gen_asm) + apply (simp add: perform_asid_control_invocation_def ) + apply wpc + apply (rule pas_refined_asid_control_helper bind_wp hoare_K_bind)+ + apply (wp cap_insert_pas_refined' hoare_weak_lift_imp | simp)+ + apply ((wp retype_region_pas_refined'[where sz=pageBits] + hoare_vcg_ex_lift hoare_vcg_all_lift hoare_weak_lift_imp hoare_wp_combs hoare_drop_imp + retype_region_invs_extras(1)[where sz = pageBits] + retype_region_invs_extras(4)[where sz = pageBits] + retype_region_invs_extras(6)[where sz = pageBits] + retype_region_invs_extras(7)[where sz = pageBits] + retype_region_cte_at_other'[where sz=pageBits] + max_index_upd_invs_simple max_index_upd_caps_overlap_reserved + hoare_vcg_ex_lift set_cap_cte_wp_at hoare_vcg_disj_lift set_free_index_valid_pspace + set_cap_descendants_range_in set_cap_no_overlap get_cap_wp set_cap_caps_no_overlap + hoare_vcg_all_lift hoare_weak_lift_imp retype_region_invs_extras + set_cap_pas_refined_not_transferable arch_update_cap_valid_mdb + | simp add: do_machine_op_def region_in_kernel_window_def cte_wp_at_neg2)+)[3] + apply (rename_tac frame slot parent base ) + apply (case_tac slot, rename_tac slot_ptr slot_idx) + apply (case_tac parent, rename_tac parent_ptr parent_idx) + apply (rule_tac Q'="\rv s. + (\idx. cte_wp_at ((=) (UntypedCap False frame pageBits idx)) parent s) \ + (\x\ptr_range frame pageBits. is_subject aag x) \ + pas_refined aag s \ pas_cur_domain aag s \ + pspace_no_overlap_range_cover frame pageBits s \ + invs s \ asid_table s (asid_high_bits_of base) = None \ + descendants_range_in {frame..(frame && ~~ mask pageBits) + 2 ^ pageBits - 1} parent s \ + range_cover frame pageBits (obj_bits_api (ArchObject ASIDPoolObj) 0) (Suc 0) \ + is_subject aag slot_ptr \ is_subject aag parent_ptr \ is_subject aag frame \ + pas_cap_cur_auth aag (ArchObjectCap (ASIDPoolCap frame base)) \ + (\x. asid_high_bits_of x = asid_high_bits_of base \ is_subject_asid aag x)" + in hoare_strengthen_post) + apply (simp add: page_bits_def) + apply (wp add: delete_objects_pspace_no_overlap hoare_vcg_ex_lift + delete_objects_descendants_range_in delete_objects_invs_ex + delete_objects_pas_refined + del: Untyped_AI.delete_objects_pspace_no_overlap + | simp add: page_bits_def)+ + apply clarsimp + apply (rename_tac s idx) + apply (frule untyped_cap_aligned, simp add: invs_valid_objs) + apply (clarsimp simp: cte_wp_at_def aag_cap_auth_def ptr_range_def pas_refined_refl + cap_links_asid_slot_def cap_links_irq_def obj_bits_api_def + default_arch_object_def retype_addrs_def conj_ac + invs_psp_aligned invs_valid_pspace invs_vspace_objs invs_arch_state) + apply (rule conjI, force intro: descendants_range_caps_no_overlapI simp: cte_wp_at_def) + apply (rule conjI, clarsimp simp: max_free_index_def) + apply (prop_tac "valid_cap (UntypedCap False frame pageBits idx) s") + apply (clarsimp simp: get_cap_caps_of_state) + apply (simp add: Untyped_AI.caps_of_state_valid) + apply (clarsimp simp: free_index_of_def max_free_index_def valid_cap_def) + apply (rule conjI) + apply (cut_tac s=s and ptr="(parent_ptr, parent_idx)" in cap_refs_in_kernel_windowD) + apply ((fastforce simp: caps_of_state_def cap_range_def)+)[3] + apply (fastforce simp: x_power_minus_1 is_aligned_no_overflow') + apply (clarsimp simp: valid_aci_def authorised_asid_control_inv_def cte_wp_at_caps_of_state) + apply (rule conjI) + apply (drule untyped_slots_not_in_untyped_range) + apply (erule empty_descendants_range_in) + apply (simp add: cte_wp_at_caps_of_state) + apply simp + apply simp + apply (rule subset_refl) + apply (simp add: page_bits_def) + apply (frule_tac x=x in bspec) + apply (simp add: is_aligned_no_overflow) + apply (clarsimp simp: ptr_range_def invs_psp_aligned invs_valid_objs aag_cap_auth_def + descendants_range_def2 empty_descendants_range_in page_bits_def + pas_refined_refl cap_links_asid_slot_def label_owns_asid_slot_def + cap_links_irq_def range_cover_def obj_bits_api_def pageBits_def + default_arch_object_def and_mask_eq_iff_shiftr_0 mask_zero) + apply (subst is_aligned_neg_mask_eq[THEN sym], assumption) + apply (intro conjI; fastforce intro: empty_descendants_range_in) + done + +lemma copy_global_mappings_integrity: + "\integrity aag X st and K (is_aligned x pt_bits \ is_subject aag x)\ + copy_global_mappings x + \\_. integrity aag X st\" + apply (rule hoare_gen_asm) + apply (simp add: copy_global_mappings_def) + apply (wp mapM_x_wp[OF _ subset_refl] store_pte_respects) + apply (simp only: pt_index_def) + apply (subst table_base_offset_id) + apply simp + 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+ + done + +definition authorised_asid_pool_inv :: "'a PAS \ asid_pool_invocation \ bool" where + "authorised_asid_pool_inv aag api \ + case api of Assign asid pool_ptr ct_slot \ + is_subject aag pool_ptr \ is_subject aag (fst ct_slot) \ is_subject_asid aag asid" + +lemma perform_asid_pool_invocation_respects: + "\integrity aag X st and pas_refined aag and invs and valid_apinv api + and K (authorised_asid_pool_inv aag api)\ + perform_asid_pool_invocation api + \\_. integrity aag X st\" + apply (unfold perform_asid_pool_invocation_def store_asid_pool_entry_def) + apply (wpsimp wp: set_asid_pool_integrity_autarch get_cap_wp set_cap_integrity_autarch + copy_global_mappings_integrity hoare_drop_imps) + apply (clarsimp simp: authorised_asid_pool_inv_def valid_apinv_def cte_wp_at_caps_of_state is_cap_simps) + apply (rule conjI) + apply (rule is_aligned_pt; fastforce simp: valid_cap_def dest: caps_of_state_valid) + apply (frule_tac ptr="(a,b)" in sbta_caps) + apply simp + apply (simp add: cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (erule_tac x=a in is_subject_trans, assumption) + apply (fastforce simp: pas_refined_def auth_graph_map_def state_objs_to_policy_def) + done + +lemma store_pte_state_vrefs_unreachable: + "\\s. P (state_vrefs s) \ pspace_aligned s \ valid_vspace_objs s \ + valid_asid_table s \ (\level. \ \\ (level, table_base p) s)\ + store_pte p pte + \\_ s. P (state_vrefs s)\" + supply fun_upd_apply[simp del] + apply (wpsimp simp: store_pte_def set_pt_def wp: set_object_wp) + apply (erule rsubst[where P=P]) + apply (rule all_ext) + apply (rule allI, rename_tac x) + apply safe + apply (subst (asm) state_vrefs_def, clarsimp) + apply (rule state_vrefsD) + apply (subst vs_lookup_table_unreachable_upd_idem; fastforce) + apply (drule vs_lookup_level) + apply (prop_tac "x \ table_base p", clarsimp) + apply (fastforce simp: fun_upd_def aobjs_of_Some opt_map_def) + apply clarsimp + apply fastforce + apply (subst (asm) state_vrefs_def, clarsimp) + apply (rule state_vrefsD) + apply (subst (asm) vs_lookup_table_unreachable_upd_idem; fastforce) + apply (prop_tac "x \ table_base p") + apply (subst (asm) vs_lookup_table_unreachable_upd_idem; fastforce dest: vs_lookup_level) + apply (fastforce simp: fun_upd_def aobjs_of_Some) + apply clarsimp + apply clarsimp + done + +lemma copy_global_mappings_state_vrefs: + "\\s. P (state_vrefs s) \ invs s \ is_aligned pt_ptr pt_bits \ (\level. \ \\ (level, pt_ptr) s)\ + copy_global_mappings pt_ptr + \\_ s. P (state_vrefs s)\" + unfolding copy_global_mappings_def + apply clarsimp + apply wp + apply (rule_tac Q'="\_ s. P (state_vrefs s) \ pspace_aligned s \ valid_vspace_objs s \ + valid_asid_table s \ unique_table_refs s \ valid_vs_lookup s \ + valid_objs s \ is_aligned pt_ptr pt_bits \ is_aligned global_pt pt_bits \ + (\level. \ \\ (level, table_base (pt_ptr)) s) \ + (\level. \ \\ (level, table_base (global_pt)) s)" + in hoare_strengthen_post[rotated], clarsimp) + apply (wpsimp wp: store_pte_state_vrefs_unreachable store_pte_valid_vs_lookup_unreachable + store_pte_vs_lookup_table_unreachable store_pte_valid_vspace_objs + hoare_vcg_all_lift hoare_vcg_imp_lift' mapM_x_wp') + apply (prop_tac "table_base (pt_ptr + (x << pte_bits)) = pt_ptr \ + table_base (global_pt + (x << pte_bits)) = global_pt") + apply (metis mask_2pm1 table_base_plus) + apply (fastforce simp: valid_objs_caps ptes_of_wellformed_pte) + apply wpsimp+ + apply (simp add: invs_valid_global_vspace_mappings) + apply (intro conjI; clarsimp) + apply (frule invs_valid_global_arch_objs) + apply (frule valid_global_arch_objs_pt_at) + using not_in_global_refs_vs_lookup apply fastforce + done + +crunch copy_global_mappings + for tcb_domain_map_wellformed[wp]: "\s. P (tcb_domain_map_wellformed aag s)" + and asid_table[wp]: "\s. P (asid_table s)" + and cdt[wp]: "\s. P (cdt s)" + and thread_st_auth[wp]: "\s. P (thread_st_auth s)" + and thread_bound_ntfns[wp]: "\s. P (thread_bound_ntfns s)" + (wp: crunch_wps) + +lemma copy_global_mappings_pas_refined: + "\\s. pas_refined aag s \ invs s \ is_aligned pt_ptr pt_bits \ (\level. \ \\ (level, pt_ptr) s)\ + copy_global_mappings pt_ptr + \\_. pas_refined aag\" + apply (clarsimp simp: pas_refined_def state_objs_to_policy_def) + apply (rule hoare_pre) + apply (wps) + apply (wpsimp wp: copy_global_mappings_state_vrefs)+ + done + +lemma store_asid_pool_entry_state_vrefs: + "\\s. P (\x. if x = pool_ptr + then vs_refs_aux asid_pool_level (ASIDPool (\a. if a = asid_low_bits_of asid + then Some pt_base + else the (asid_pools_of s pool_ptr) a)) + else if x = pt_base + then vs_refs_aux max_pt_level (the (aobjs_of s x)) + else state_vrefs s x) \ + pspace_aligned s \ valid_vspace_objs s \ valid_asid_table s \ + pool_for_asid asid s = Some pool_ptr \ + (\pool. ako_at (ASIDPool pool) pool_ptr s \ pool (asid_low_bits_of asid) = None) \ + (\level. \\\ (level, pt_base) s) \ + (\pt. pts_of s pt_base = Some pt \ kernel_mappings_only pt s)\ + store_asid_pool_entry pool_ptr asid (Some pt_base) + \\_ s. P (state_vrefs s)\" + unfolding store_asid_pool_entry_def set_asid_pool_def + apply (wpsimp wp: set_object_wp get_cap_wp) + apply (erule rsubst[where P=P]) + apply (rule all_ext) + apply (clarsimp split del: if_split) + apply (prop_tac "is_aligned pt_base pt_bits") + apply (fastforce elim: pspace_aligned_pts_ofD dest: invs_psp_aligned) + apply safe + apply (clarsimp split: if_splits) + apply (frule pool_for_asid_vs_lookupD) + apply (rule_tac level=asid_pool_level in state_vrefsD) + apply (simp only: fun_upd_def) + apply (subst asid_pool_map.vs_lookup_table[simplified fun_upd_def]) + apply (fastforce simp: asid_pool_map_def asid_pools_of_ko_at + valid_apinv_def asid_low_bits_of_def aobjs_of_Some) + apply fastforce + apply fastforce + apply fastforce + apply (fastforce simp: ako_asid_pools_of) + apply (clarsimp simp: ako_asid_pools_of) + apply (rule_tac level=max_pt_level and vref=0 in state_vrefsD) + apply (simp only: fun_upd_def) + apply (subst asid_pool_map.vs_lookup_table[simplified fun_upd_def]) + apply (fastforce simp: asid_pool_map_def asid_pools_of_ko_at + valid_apinv_def asid_low_bits_of_def aobjs_of_Some) + apply clarsimp + apply fastforce + apply (fastforce simp: pts_of_Some) + apply (fastforce simp: pts_of_Some) + apply (fastforce simp: pts_of_Some) + apply (clarsimp simp: obj_at_def) + apply (subst (asm) state_vrefs_def, clarsimp) + apply (rename_tac asida vref) + apply (rule_tac asid=asida in state_vrefsD) + apply (simp only: fun_upd_def) + apply (subst asid_pool_map.vs_lookup_table[simplified fun_upd_def]) + apply (fastforce simp: asid_pool_map_def asid_pools_of_ko_at obj_at_def + valid_apinv_def asid_low_bits_of_def aobjs_of_Some) + apply fastforce + apply (prop_tac "asid \ asida") + apply (fastforce simp: vs_lookup_table_def vspace_for_pool_def asid_pools_of_ko_at obj_at_def + split: if_splits) + apply fastforce + apply fastforce + apply fastforce + apply clarsimp + apply (subst (asm) state_vrefs_def, clarsimp split del: if_split) + apply (simp only: fun_upd_def) + apply (subst (asm) asid_pool_map.vs_lookup_table[simplified fun_upd_def]) + apply (fastforce simp: asid_pool_map_def asid_pools_of_ko_at + valid_apinv_def asid_low_bits_of_def aobjs_of_Some) + apply clarsimp + apply (case_tac "x = pool_ptr") + apply (prop_tac "asid_pools_of s pool_ptr = Some pool") + apply (clarsimp simp: asid_pools_of_ko_at obj_at_def) + apply (clarsimp simp: vs_refs_aux_def) + apply (case_tac "asida = asid \ bot \ max_pt_level"; clarsimp) + apply (case_tac "x = pt_base") + apply (fastforce dest: vs_lookup_level) + apply (fastforce simp: state_vrefs_def) + done + +crunch store_asid_pool_entry + for irq_map_wellformed[wp]: "\s. P (irq_map_wellformed aag s)" + and tcb_domain_map_wellformed[wp]: "\s. P (tcb_domain_map_wellformed aag s)" + and state_irqs_to_policy[wp]: "\s. P (state_irqs_to_policy aag s)" + and caps_of_state[wp]: "\s. P (caps_of_state s)" + and asid_table[wp]: "\s. P (asid_table s)" + and cdt[wp]: "\s. P (cdt s)" + and thread_st_auth[wp]: "\s. P (thread_st_auth s)" + and thread_bound_ntfns[wp]: "\s. P (thread_bound_ntfns s)" + +lemma store_asid_pool_entry_pas_refined: + "\\s. pas_refined aag s \ pspace_aligned s \ valid_vspace_objs s \ valid_asid_table s \ + pool_for_asid asid s = Some pool_ptr \ is_subject aag pool_ptr \ + is_subject aag pt_base \ is_subject_asid aag asid \ + (\level. \\\ (level, pt_base) s) \ + (\pool. ako_at (ASIDPool pool) pool_ptr s \ pool (asid_low_bits_of asid) = None) \ + (\pt. pts_of s pt_base = Some pt \ kernel_mappings_only pt s)\ + store_asid_pool_entry pool_ptr asid (Some pt_base) + \\_ s. pas_refined aag s\" + apply (clarsimp simp: pas_refined_def state_objs_to_policy_def) + apply (rule hoare_pre) + apply wps + apply (wp store_asid_pool_entry_state_vrefs store_asid_pool_entry_state_vrefs) + apply (clarsimp simp: auth_graph_map_def) + apply (frule (1) pool_for_asid_validD) + apply clarsimp + apply (rule conjI; clarsimp) + apply (erule state_bits_to_policy.cases) + apply (fastforce simp: state_objs_to_policy_def dest: sbta_caps) + apply (fastforce simp: state_objs_to_policy_def dest: sbta_untyped) + apply (fastforce simp: state_objs_to_policy_def dest: sbta_ts) + apply (fastforce simp: state_objs_to_policy_def dest: sbta_bounds) + apply (fastforce simp: state_objs_to_policy_def dest: sbta_cdt) + apply (fastforce simp: state_objs_to_policy_def dest: sbta_cdt_transferable) + apply (case_tac "ptr = pool_ptr") + apply (clarsimp simp: vs_refs_aux_def graph_of_def aag_wellformed_refl split: if_splits) + apply (erule subsetD) + apply clarsimp + apply (rule_tac x=pool_ptr in exI, clarsimp) + apply (rule exI, rule conjI, rule refl) + apply (rule sbta_vref) + apply (drule pool_for_asid_vs_lookupD) + apply (erule_tac vref=0 in state_vrefsD) + apply (simp add: asid_pools_of_ko_at aobjs_of_ako_at_Some) + apply clarsimp + apply (fastforce simp: vs_refs_aux_def graph_of_def) + apply (fastforce simp: vs_refs_aux_def kernel_mappings_only_def + graph_of_def pts_of_Some pte_ref2_def + dest: sbta_vref split: if_splits) + apply (erule state_asids_to_policy_aux.cases) + apply (erule subsetD[where A="state_asids_to_policy_aux _ _ _ _"]) + apply (fastforce dest: sata_asid) + apply (case_tac "poolptr = pool_ptr") + apply (clarsimp simp: vs_refs_aux_def graph_of_def obj_at_def split: if_splits) + apply (clarsimp simp: pool_for_asid_def asid_pools_of_ko_at valid_asid_table_def inj_on_def) + apply (drule_tac x="asid_high_bits_of asid" in bspec, clarsimp) + apply (drule_tac x="asid_high_bits_of asida" in bspec, clarsimp) + apply clarsimp + apply (drule asid_high_low) + apply (simp add: asid_low_bits_of_mask_eq[symmetric]) + apply (prop_tac "is_up UCAST(9 \ 16) \ is_up UCAST(9 \ 64)") + apply (clarsimp simp: is_up_def source_size_def target_size_def word_size) + apply (clarsimp simp: ucast_ucast_b) + apply (metis ucast_up_ucast_id) + apply (fastforce simp: aag_wellformed_refl) + apply (erule subsetD[where A="state_asids_to_policy_aux _ _ _ _"]) + apply (rule sata_asid_lookup, fastforce) + apply (frule pool_for_asid_vs_lookupD) + apply (erule_tac vref=0 in state_vrefsD) + apply (simp add: asid_pools_of_ko_at aobjs_of_ako_at_Some) + apply simp + apply (fastforce simp: vs_refs_aux_def graph_of_def) + apply (case_tac "poolptr = pt_base") + apply (clarsimp simp: vs_refs_aux_def pts_of_Some) + apply (erule subsetD[where A="state_asids_to_policy_aux _ _ _ _"]) + apply (fastforce simp: sata_asid_lookup) + apply (erule subsetD[where A="state_asids_to_policy_aux _ _ _ _"]) + apply (fastforce simp: sata_asidpool) + done + + +lemma copy_global_mappings_vs_lookup_table_noteq: + "\\s. vs_lookup_table level asid vref s \ Some (level, pt_ptr) \ invs s \ + is_aligned pt_ptr pt_bits \ vref \ user_region \ (\level. \ \\ (level, pt_ptr) s)\ + copy_global_mappings pt_ptr + \\_ s. vs_lookup_table level asid vref s \ Some (level, pt_ptr)\" + unfolding copy_global_mappings_def + apply clarsimp + apply wp + apply (rule_tac Q'="\_. pspace_aligned and valid_vspace_objs and valid_asid_table and + unique_table_refs and valid_vs_lookup and valid_objs and + (\s. vs_lookup_table level asid vref s \ Some (level, pt_ptr) \ + vref \ user_region \ is_aligned pt_ptr pt_bits \ + (\level. \ \\ (level, table_base pt_ptr) s))" + in hoare_strengthen_post[rotated], clarsimp) + apply (wpsimp wp: mapM_x_wp' store_pte_valid_vspace_objs store_pte_vs_lookup_table_unreachable + store_pte_valid_vs_lookup_unreachable hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (metis valid_objs_caps ptes_of_wellformed_pte mask_2pm1 table_base_plus) + apply wpsimp + apply fastforce + done + +lemma perform_asid_pool_invocation_pas_refined [wp]: + "\pas_refined aag and invs and valid_apinv api and K (authorised_asid_pool_inv aag api)\ + perform_asid_pool_invocation api + \\_. pas_refined aag\" + apply (simp add: perform_asid_pool_invocation_def) + apply (strengthen invs_psp_aligned invs_vspace_objs valid_arch_state_asid_table invs_arch_state | + wpsimp simp: ako_asid_pools_of + wp: copy_global_mappings_invs copy_global_mappings_pas_refined + copy_global_mappings_copies copy_global_mappings_vs_lookup_table_noteq + store_asid_pool_entry_pas_refined set_cap_pas_refined get_cap_wp + arch_update_cap_invs_map hoare_vcg_all_lift hoare_vcg_imp_lift')+ + apply (clarsimp simp: cte_wp_at_caps_of_state valid_apinv_def cong: conj_cong) + apply (clarsimp simp: is_PageTableCap_def is_ArchObjectCap_def) + apply (clarsimp split: option.splits) + apply (clarsimp simp: authorised_asid_pool_inv_def) + apply (prop_tac "(\x xa xb. vs_lookup_table x xa xb s = Some (x, x41) \ xb \ user_region)") + apply (frule (1) caps_of_state_valid) + apply (clarsimp simp: valid_cap_def) + apply (clarsimp simp: obj_at_def) + apply (rename_tac asid' pool_ptr a b acap_obj level asid vref pt) + apply (drule (1) vs_lookup_table_valid_cap; clarsimp) + apply (frule (1) cap_to_pt_is_pt_cap, simp add: pts_of_Some aobjs_of_Some, fastforce intro: valid_objs_caps) + apply (drule (1) unique_table_refsD[rotated]; clarsimp) + apply (clarsimp simp: is_cap_simps) + apply (clarsimp simp: is_arch_update_def update_map_data_def is_cap_simps cap_master_cap_def asid_bits_of_defs) + apply (intro conjI) + apply (fastforce dest: cap_cur_auth_caps_of_state pas_refined_refl + simp: update_map_data_def aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + cap_links_asid_slot_def label_owns_asid_slot_def cap_links_irq_def) + apply (fastforce dest: caps_of_state_valid + simp: update_map_data_def valid_cap_def cap_aligned_def wellformed_mapdata_def) + apply (fastforce dest: caps_of_state_aligned_page_table) + apply (fastforce dest: unique_table_capsD[rotated]) + apply (fastforce dest: cap_not_in_valid_global_refs) + apply (fastforce dest: cap_cur_auth_caps_of_state pas_refined_Control + simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def) + apply fastforce + apply (fastforce dest: invs_valid_table_caps simp: valid_table_caps_def) + done + + +definition authorised_arch_inv :: "'a PAS \ arch_invocation \ 's :: state_ext state \ bool" where + "authorised_arch_inv aag ai s \ case ai of + InvokePageTable pti \ authorised_page_table_inv aag pti + | InvokePage pgi \ authorised_page_inv aag pgi s + | InvokeASIDControl aci \ authorised_asid_control_inv aag aci + | InvokeASIDPool api \ authorised_asid_pool_inv aag api" + +lemma invoke_arch_respects: + "\integrity aag X st and authorised_arch_inv aag ai and + pas_refined aag and invs and valid_arch_inv ai and is_subject aag \ cur_thread\ + arch_perform_invocation ai + \\_. integrity aag X st\" + apply (simp add: arch_perform_invocation_def) + apply (wpsimp wp: perform_page_table_invocation_respects perform_page_invocation_respects + perform_asid_control_invocation_respects perform_asid_pool_invocation_respects) + apply (auto simp: authorised_arch_inv_def valid_arch_inv_def) + done + +lemma invoke_arch_pas_refined: + "\pas_refined aag and pas_cur_domain aag and invs and ct_active + and valid_arch_inv ai and authorised_arch_inv aag ai\ + arch_perform_invocation ai + \\_. pas_refined aag\" + apply (simp add: arch_perform_invocation_def valid_arch_inv_def) + apply (wpsimp wp: perform_page_table_invocation_pas_refined perform_asid_pool_invocation_pas_refined + perform_page_invocation_pas_refined perform_asid_control_invocation_pas_refined)+ + apply (auto simp: authorised_arch_inv_def) + done + +lemma vspace_for_asid_is_subject: + "\ vspace_for_asid a s = Some xaa; pas_refined aag s; valid_asid_table s; is_subject_asid aag a \ + \ is_subject aag xaa" + apply (frule vspace_for_asid_vs_lookup) + apply (clarsimp simp: vspace_for_asid_def) + apply (frule pool_for_asid_vs_lookupD) + apply (frule (1) pool_for_asid_validD) + apply (clarsimp simp: vspace_for_pool_def pool_for_asid_def asid_pools_of_ko_at obj_at_def) + apply (frule_tac vrefs="state_vrefs s" in sata_asid_lookup) + apply (rule_tac level=asid_pool_level and asid=a and vref=0 in state_vrefsD) + by (fastforce simp: aobjs_of_Some vs_refs_aux_def graph_of_def asid_low_bits_of_mask_eq[symmetric] + ucast_ucast_b is_up_def source_size_def target_size_def word_size pas_refined_def + dest: aag_wellformed_Control)+ + +lemma decode_page_table_invocation_authorised: + "\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 K (is_PageTableCap cap \ (\(cap, slot) \ {(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 msg slot cap excaps + \\rv. authorised_arch_inv aag rv\, -" + apply (rule hoare_gen_asmE) + apply (clarsimp simp: is_PageTableCap_def) + apply (rename_tac x xa) + apply (unfold decode_page_table_invocation_def decode_pt_inv_map_def authorised_arch_inv_def) + apply (wpsimp simp: Let_def is_final_cap_def if_fun_split) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (prop_tac "\y \ set [x, x + 2 ^ pte_bits .e. x + 2 ^ pt_bits - 1]. table_base y = x") + apply (drule (1) caps_of_state_aligned_page_table) + apply (clarsimp simp only: is_aligned_neg_mask_eq' 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 (intro conjI; clarsimp) + apply (clarsimp simp: authorised_page_table_inv_def) + apply (case_tac excaps; clarsimp) + apply (rule conjI) + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) + apply (subst table_base_pt_slot_offset) + apply (fastforce simp: cte_wp_at_caps_of_state + dest: caps_of_state_aligned_page_table pt_walk_is_aligned) + apply (frule vs_lookup_table_vref_independent[OF vspace_for_asid_vs_lookup, simplified]) + apply (erule pt_walk_is_subject[rotated 4]; fastforce intro: vspace_for_asid_is_subject + simp: user_vtop_canonical_user + user_region_def) + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + cap_links_asid_slot_def label_owns_asid_slot_def cap_links_irq_def) + apply (auto simp: caps_of_state_pasObjectAbs_eq authorised_page_table_inv_def + cap_auth_conferred_def arch_cap_auth_conferred_def) + done + +lemma decode_frame_invocation_authorised: + "\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 K (is_FrameCap cap \ (\(cap, slot) \ {(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 msg slot cap excaps + \\rv. authorised_arch_inv aag rv\,-" + unfolding decode_frame_invocation_def authorised_arch_inv_def decode_fr_inv_map_def + apply (wpsimp wp: check_vp_wpR simp: Let_def authorised_page_inv_def) + apply (rule conj_imp_strg) + apply (cases excaps; clarsimp) + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + cap_links_asid_slot_def cap_links_irq_def authorised_slots_def) + apply (prop_tac "msg ! 0 \ user_region") + apply (fastforce dest: not_le_imp_less user_vtop_canonical_user + elim: dual_order.trans is_aligned_no_overflow_mask + simp: user_region_def vmsz_aligned_def) + apply (rule conjI) + apply (frule (1) pt_lookup_slot_vs_lookup_slotI, clarsimp) + apply (drule (1) vs_lookup_slot_unique_level; clarsimp) + apply (clarsimp simp: cte_wp_at_caps_of_state make_user_pte_def pte_ref2_def split: if_splits) + apply (subst (asm) ptrFromPAddr_addr_from_ppn[OF is_aligned_pageBitsForSize_table_size]) + apply (fastforce dest: caps_of_state_valid + simp: valid_cap_def cap_aligned_def pageBitsForSize_pt_bits_left) + apply (fastforce simp: vspace_cap_rights_to_auth_def mask_vm_rights_def validate_vm_rights_def + vm_kernel_only_def vm_read_only_def + split: if_splits) + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) + apply (subst table_base_pt_slot_offset) + apply (fastforce simp: cte_wp_at_caps_of_state + dest: caps_of_state_aligned_page_table pt_walk_is_aligned) + apply (frule vs_lookup_table_vref_independent[OF vspace_for_asid_vs_lookup, simplified]) + apply (erule pt_walk_is_subject[rotated 4]; fastforce intro: vspace_for_asid_is_subject) + done + +lemma decode_asid_control_invocation_authorised: + "\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 K (cap = ASIDControlCap \ (\(cap, slot) \ {(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 msg slot cap excaps + \authorised_arch_inv aag\, -" + unfolding decode_asid_control_invocation_def authorised_arch_inv_def authorised_asid_control_inv_def + apply wpsimp + apply (cases excaps; clarsimp) + apply (rename_tac excaps_tail) + apply (case_tac excaps_tail; clarsimp) + apply (clarsimp simp: aag_cap_auth_def cte_wp_at_caps_of_state) + apply (drule (1) caps_of_state_valid[where cap="UntypedCap _ _ _ _"]) + apply (fastforce simp: valid_cap_def cap_aligned_def is_cap_simps cap_auth_conferred_def + dest: pas_refined_Control) + done + +lemma decode_asid_pool_invocation_authorised: + "\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 K (is_ASIDPoolCap cap \ (\(cap, slot) \ {(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 msg slot cap excaps + \authorised_arch_inv aag\, -" + unfolding decode_asid_pool_invocation_def authorised_arch_inv_def Let_def + apply wpsimp + apply (erule swap[where P="authorised_asid_pool_inv _ _"]) + apply (cases excaps; clarsimp) + apply (clarsimp simp: authorised_asid_pool_inv_def is_ASIDPoolCap_def) + apply (rule conjI) + apply (clarsimp simp: pas_refined_def state_objs_to_policy_def auth_graph_map_def) + apply (drule subsetD) + apply (fastforce dest!: sbta_caps + simp: obj_refs_def cte_wp_at_caps_of_state + cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (fastforce dest: aag_wellformed_Control) + apply (erule allE, erule mp) + apply (fastforce dest: caps_of_state_valid asid_high_bits_of_add_ucast + simp: cte_wp_at_caps_of_state valid_cap_def) + done + +lemma decode_arch_invocation_authorised: + "\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 K (\(cap, slot) \ {(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 msg x_slot slot cap excaps + \authorised_arch_inv aag\, -" + unfolding arch_decode_invocation_def + apply (wpsimp wp: decode_page_table_invocation_authorised decode_asid_pool_invocation_authorised + decode_asid_control_invocation_authorised decode_frame_invocation_authorised) + apply auto + done + +lemma authorised_arch_inv_sa_update: + "authorised_arch_inv aag i (scheduler_action_update (\_. act) s) = + authorised_arch_inv aag i s" + by (clarsimp simp: authorised_arch_inv_def authorised_page_inv_def authorised_slots_def + split: arch_invocation.splits page_invocation.splits) + +lemma set_thread_state_authorised_arch_inv[wp]: + "set_thread_state ref ts \authorised_arch_inv aag i\" + unfolding set_thread_state_def + apply (wpsimp wp: dxo_wp_weak) + apply (clarsimp simp: authorised_arch_inv_def authorised_page_inv_def authorised_slots_def + split: arch_invocation.splits page_invocation.splits) + apply (wpsimp wp: set_object_wp)+ + apply (clarsimp simp: authorised_arch_inv_def authorised_page_inv_def + authorised_slots_def vs_lookup_slot_def obind_def + split: arch_invocation.splits page_invocation.splits if_splits option.splits) + apply (clarsimp simp: vs_lookup_table_def obind_def vspace_for_pool_def + split: option.splits if_splits) + apply (subgoal_tac "(\p. pte_of p ((pts_of s)(ref := None))) = ptes_of s") + apply fastforce + apply (fastforce simp: pte_of_def obind_def pts_of_Some aobjs_of_Some get_tcb_def + split: option.splits) + done + +end + + +context begin interpretation Arch . + +requalify_facts + invoke_arch_pas_refined + invoke_arch_respects + decode_arch_invocation_authorised + authorised_arch_inv_sa_update + set_thread_state_authorised_arch_inv + +requalify_consts + authorised_arch_inv + +end + +declare authorised_arch_inv_sa_update[simp] +declare set_thread_state_authorised_arch_inv[wp] + +end diff --git a/proof/access-control/AARCH64/ArchCNode_AC.thy b/proof/access-control/AARCH64/ArchCNode_AC.thy new file mode 100644 index 0000000000..39053ab651 --- /dev/null +++ b/proof/access-control/AARCH64/ArchCNode_AC.thy @@ -0,0 +1,334 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchCNode_AC +imports CNode_AC +begin + +section\Arch-specific CNode AC.\ + +context Arch begin global_naming RISCV64 + +declare arch_post_modify_registers_def[simp] +declare arch_post_cap_deletion_def[simp] +declare arch_cap_cleanup_opt_def[simp] +declare arch_mask_irq_signal_def[simp] + +named_theorems CNode_AC_assms + +lemma sata_cdt_update[CNode_AC_assms, simp]: + "state_asids_to_policy aag (cdt_update f s) = state_asids_to_policy aag s" + by simp + +lemma sata_is_original_cap_update[CNode_AC_assms, simp]: + "state_asids_to_policy aag (is_original_cap_update f s) = state_asids_to_policy aag s" + by simp + +lemma sata_interrupt_states_update[CNode_AC_assms, simp]: + "state_asids_to_policy aag (interrupt_states_update f s) = state_asids_to_policy aag s" + by simp + +lemma sata_machine_state_update[CNode_AC_assms, simp]: + "state_asids_to_policy aag (machine_state_update f s) = state_asids_to_policy aag s" + by simp + +lemma sata_update[CNode_AC_assms]: + "\ pas_wellformed aag; + cap_links_asid_slot aag (pasObjectAbs aag (fst ptr)) cap; + state_asids_to_policy_arch aag caps as vrefs \ pasPolicy aag \ + \ state_asids_to_policy_arch aag (caps(ptr \ cap)) as vrefs \ pasPolicy aag" + by (fastforce intro: state_asids_to_policy_aux.intros + elim!: state_asids_to_policy_aux.cases + simp: cap_links_asid_slot_def label_owns_asid_slot_def + split: if_split_asm) + +lemma sata_update2[CNode_AC_assms]: + "\ pas_wellformed aag; + cap_links_asid_slot aag (pasObjectAbs aag (fst ptr)) cap; + cap_links_asid_slot aag (pasObjectAbs aag (fst ptr')) cap'; + state_asids_to_policy_arch aag caps as vrefs \ pasPolicy aag \ + \ state_asids_to_policy_arch aag (caps(ptr \ cap, ptr' \ cap')) as vrefs \ pasPolicy aag" + by (fastforce intro: state_asids_to_policy_aux.intros + elim!: state_asids_to_policy_aux.cases + simp: cap_links_asid_slot_def label_owns_asid_slot_def + split: if_split_asm) + +lemma state_vrefs_eqI: + "\ \bot_level asid vref level p. + bot_level < level \ vs_lookup_table level asid vref s = Some (level, p) + \ (if level \ max_pt_level + then pts_of s' p = pts_of s p + else asid_pools_of s' p = asid_pools_of s p); + aobjs_of s' = aobjs_of s; asid_table s' = asid_table s; + pspace_aligned s; valid_vspace_objs s; valid_asid_table s \ + \ state_vrefs (s' :: 'a :: state_ext state) = state_vrefs (s :: 'a :: state_ext state)" + apply (rule ext) + apply safe + apply (subst (asm) state_vrefs_def, clarsimp) + apply (fastforce intro: state_vrefsD elim: subst[OF vs_lookup_table_eqI,rotated -1]) + apply (subst (asm) state_vrefs_def, clarsimp) + apply (rule state_vrefsD) + apply (subst vs_lookup_table_eqI; fastforce) + apply fastforce+ + done + +lemma set_cap_state_vrefs[CNode_AC_assms, wp]: + "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ + set_cap cap slot + \\_ s :: det_ext state. P (state_vrefs s)\" + apply (simp add: set_cap_def set_object_def) + apply (wpsimp wp: get_object_wp) + apply safe + apply (all \subst state_vrefs_eqI\) + by (fastforce simp: valid_arch_state_def obj_at_def opt_map_def + split: option.splits kernel_object.splits)+ + +crunch maskInterrupt + for underlying_memory[CNode_AC_assms, wp]: "\s. P (underlying_memory s)" + and device_state[CNode_AC_assms, wp]: "\s. P (device_state s)" + (simp: maskInterrupt_def) + +crunch set_cdt + for state_vrefs[CNode_AC_assms, wp]: "\s. P (state_vrefs s)" + and state_asids_to_policy[CNode_AC_assms, wp]: "\s. P (state_asids_to_policy aag s)" + +crunch prepare_thread_delete, arch_finalise_cap + for cur_domain[CNode_AC_assms, wp]:"\s. P (cur_domain s)" + (wp: crunch_wps hoare_vcg_if_lift2 simp: unless_def) + +lemma state_vrefs_tcb_upd[CNode_AC_assms]: + "\ pspace_aligned s; valid_vspace_objs s; valid_arch_state s; tcb_at t s \ + \ state_vrefs (s\kheap := (kheap s)(t \ TCB tcb)\) = state_vrefs s" + apply (rule state_vrefs_eqI) + by (fastforce simp: opt_map_def obj_at_def is_obj_defs valid_arch_state_def)+ + +lemma state_vrefs_simple_type_upd[CNode_AC_assms]: + "\ pspace_aligned s; valid_vspace_objs s; valid_arch_state s; + ko_at ko ptr s; is_simple_type ko; a_type ko = a_type (f val) \ + \ state_vrefs (s\kheap := (kheap s)(ptr \ f val)\) = state_vrefs s" + apply (case_tac ko; case_tac "f val"; clarsimp) + by (fastforce intro!: state_vrefs_eqI simp: opt_map_def obj_at_def is_obj_defs valid_arch_state_def)+ + +lemma a_type_arch_object_not_tcb[CNode_AC_assms, simp]: + "a_type (ArchObj arch_kernel_obj) \ ATCB" + by auto + +lemma arch_post_cap_deletion_cur_domain[CNode_AC_assms, wp]: + "arch_post_cap_deletion acap \\s. P (cur_domain s)\" + by wpsimp + +lemma arch_post_cap_deletion_integrity[CNode_AC_assms]: + "arch_post_cap_deletion acap \integrity aag X st\" + by wpsimp + +end + + +context is_extended begin interpretation Arch . + +lemma list_integ_lift[CNode_AC_assms]: + assumes li: + "\list_integ (cdt_change_allowed aag {pasSubject aag} (cdt st) (tcb_states_of_state st)) st and Q\ + f + \\_. list_integ (cdt_change_allowed aag {pasSubject aag} (cdt st) (tcb_states_of_state st)) st\" + assumes ekh: "\P. f \\s. P (ekheap s)\" + assumes rq: "\P. f \\s. P (ready_queues s)\" + shows "\integrity aag X st and Q\ f \\_. integrity aag X st\" + apply (rule hoare_pre) + apply (unfold integrity_def[abs_def] integrity_asids_def) + apply (simp only: integrity_cdt_list_as_list_integ) + apply (rule hoare_lift_Pf2[where f="ekheap"]) + apply (simp add: tcb_states_of_state_def get_tcb_def) + apply (wp li[simplified tcb_states_of_state_def get_tcb_def] ekh rq)+ + apply (simp only: integrity_cdt_list_as_list_integ) + apply (simp add: tcb_states_of_state_def get_tcb_def) + done + +end + + +global_interpretation CNode_AC_1?: CNode_AC_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact CNode_AC_assms) +qed + + +context Arch begin global_naming RISCV64 + +lemma integrity_asids_set_cap_Nullcap[CNode_AC_assms]: + "\(=) s\ set_cap NullCap slot \\_. integrity_asids aag subjects x a s\" + unfolding integrity_asids_def by wpsimp + +crunch set_original + for state_asids_to_policy[CNode_AC_assms, wp]: "\s. P (state_asids_to_policy aag s)" + and state_objs_to_policy[CNode_AC_assms, wp]: "\s. P (state_objs_to_policy s)" + (simp: state_objs_to_policy_def) + +crunch set_cdt_list, update_cdt_list + for state_vrefs[CNode_AC_assms, wp]: "\s. P (state_vrefs s)" + and state_asids_to_policy[CNode_AC_assms, wp]: "\s. P (state_asids_to_policy aag s)" + (simp: set_cdt_list_def) + +end + + +global_interpretation CNode_AC_2?: CNode_AC_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact CNode_AC_assms) +qed + + +context Arch begin global_naming RISCV64 + +lemma arch_post_cap_deletion_pas_refined[CNode_AC_assms, wp]: + "arch_post_cap_deletion irqopt \pas_refined aag\" + by (wpsimp simp: post_cap_deletion_def) + +lemma aobj_ref'_same_aobject[CNode_AC_assms]: + "same_aobject_as ao' ao \ aobj_ref' ao = aobj_ref' ao'" + by (cases ao; clarsimp split: arch_cap.splits) + +crunch set_untyped_cap_as_full + for valid_arch_state[CNode_AC_assms, wp]: valid_arch_state + +end + + +context is_extended begin interpretation Arch . + +lemma pas_refined_tcb_domain_map_wellformed[CNode_AC_assms, wp]: + assumes tdmw: "f \tcb_domain_map_wellformed aag\" + shows "f \pas_refined aag\" + apply (simp add: pas_refined_def) + apply (wp tdmw) + apply (wp lift_inv) + apply simp+ + done + +end + + +global_interpretation CNode_AC_3?: CNode_AC_3 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact CNode_AC_assms) +qed + + +context Arch begin global_naming RISCV64 + +lemma arch_derive_cap_auth_derived[CNode_AC_assms]: + "\\s. cte_wp_at (auth_derived (ArchObjectCap cap)) src_slot s\ + arch_derive_cap cap + \\rv s. cte_wp_at (auth_derived rv) src_slot s\, -" + apply (rule hoare_pre) + apply (wp | wpc | simp add: arch_derive_cap_def)+ + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (safe) + apply (clarsimp simp: auth_derived_def arch_cap_auth_conferred_def cap_auth_conferred_def) + done + +lemma cap_asid'_cap_rights_update[CNode_AC_assms, simp]: + "acap_asid' (acap_rights_update rights ao) = acap_asid' ao" + by (cases ao; clarsimp simp: cap_rights_update_def acap_rights_update_def) + +lemma untyped_range_cap_rights_update[CNode_AC_assms, simp]: + "untyped_range (cap_rights_update rights (ArchObjectCap ao)) = untyped_range (ArchObjectCap ao)" + by (cases ao; clarsimp simp: cap_rights_update_def) + +lemma obj_refs_cap_rights_update[CNode_AC_assms, simp]: + "aobj_ref' (acap_rights_update rights ao) = aobj_ref' ao" + by (cases ao; clarsimp simp: cap_rights_update_def acap_rights_update_def) + +lemma auth_derived_arch_update_cap_data[CNode_AC_assms]: + "auth_derived (ArchObjectCap ao) cap' \ auth_derived (arch_update_cap_data pres w ao) cap'" + by (simp add: update_cap_data_def is_cap_simps arch_update_cap_data_def + split del: if_split cong: if_cong) + +lemma acap_auth_conferred_acap_rights_update[CNode_AC_assms]: + "arch_cap_auth_conferred (acap_rights_update (acap_rights acap \ R) acap) + \ arch_cap_auth_conferred acap" + by (auto simp: arch_cap_auth_conferred_def vspace_cap_rights_to_auth_def acap_rights_update_def + validate_vm_rights_def vm_kernel_only_def vm_read_only_def + split: arch_cap.splits) + +lemma arch_derive_cap_clas[CNode_AC_assms]: + "\\s. cap_links_asid_slot aag p (ArchObjectCap acap)\ + arch_derive_cap acap + \\rv s. cap_links_asid_slot aag p rv\, -" + apply (simp add: arch_derive_cap_def cong: cap.case_cong) + apply (rule hoare_pre) + apply (wp | wpc)+ + apply (auto simp: is_cap_simps cap_links_asid_slot_def) + done + +lemma arch_derive_cap_obj_refs_auth[CNode_AC_assms]: + "\K (\r\obj_refs_ac (ArchObjectCap cap). + \auth\cap_auth_conferred (ArchObjectCap cap). aag_has_auth_to aag auth r)\ + arch_derive_cap cap + \(\x s. \r\obj_refs_ac x. \auth\cap_auth_conferred x. aag_has_auth_to aag auth r)\, -" + unfolding arch_derive_cap_def + apply (rule hoare_pre) + apply (wp | wpc)+ + apply (clarsimp simp: cap_auth_conferred_def arch_cap_auth_conferred_def) + done + +(* FIXME: move *) +lemma arch_derive_cap_obj_refs_subset[CNode_AC_assms]: + "\\s. (\x \ aobj_ref' acap. P x s)\ arch_derive_cap acap \\rv s. \x \ obj_refs_ac rv. P x s\, -" + by (wpsimp simp: arch_derive_cap_def) fastforce + +lemma arch_derive_cap_clip[CNode_AC_assms]: + "\K (cap_links_irq aag l (ArchObjectCap ac))\ + arch_derive_cap ac + \\x s. cap_links_irq aag l x\, -" + by (wpsimp simp: arch_derive_cap_def comp_def cli_no_irqs) + +(* FIXME: move *) +lemma arch_derive_cap_untyped_range_subset[CNode_AC_assms]: + "\\s. \x \ untyped_range (ArchObjectCap acap). P x s\ + arch_derive_cap acap + \\rv s. \x \ untyped_range rv. P x s\, -" + by (wpsimp simp: arch_derive_cap_def) + +lemma arch_update_cap_obj_refs_subset[CNode_AC_assms]: + "\ x \ obj_refs_ac (arch_update_cap_data pres data cap) \ \ x \ aobj_ref' cap" + by (simp add: arch_update_cap_data_def) + +lemma arch_update_cap_untyped_range_empty[CNode_AC_assms, simp]: + "untyped_range (arch_update_cap_data pres data cap) = {}" + by (simp add: arch_update_cap_data_def) + +lemma arch_update_cap_irqs_controlled_empty[CNode_AC_assms, simp]: + "cap_irqs_controlled (arch_update_cap_data pres data cap) = {}" + by (simp add: arch_update_cap_data_def) + +lemma arch_update_cap_links_asid_slot[CNode_AC_assms]: + "cap_links_asid_slot aag p (arch_update_cap_data pres w acap) = + cap_links_asid_slot aag p (ArchObjectCap acap)" + by (simp add: arch_update_cap_data_def) + +lemma arch_update_cap_cap_auth_conferred_subset[CNode_AC_assms]: + "y \ cap_auth_conferred (arch_update_cap_data b w acap) \ y \ arch_cap_auth_conferred acap" + by (simp add: arch_update_cap_data_def cap_auth_conferred_def) + +end + + +global_interpretation CNode_AC_4?: CNode_AC_4 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact CNode_AC_assms)?) +qed + + +end diff --git a/proof/access-control/AARCH64/ArchDomainSepInv.thy b/proof/access-control/AARCH64/ArchDomainSepInv.thy new file mode 100644 index 0000000000..6d295b84e4 --- /dev/null +++ b/proof/access-control/AARCH64/ArchDomainSepInv.thy @@ -0,0 +1,134 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchDomainSepInv +imports + "DomainSepInv" +begin + +context Arch begin global_naming RISCV64 + +named_theorems DomainSepInv_assms + +crunch arch_post_cap_deletion, set_pt, set_asid_pool, prepare_thread_delete, init_arch_objects + for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" + (wp: domain_sep_inv_triv crunch_wps set_asid_pool_cte_wp_at set_pt_cte_wp_at) + +crunch arch_finalise_cap + for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" + (wp: crunch_wps simp: crunch_simps) + +lemma arch_finalise_cap_rv[DomainSepInv_assms]: + "\\_. P (NullCap,NullCap)\ arch_finalise_cap c x \\rv _. P rv\" + unfolding arch_finalise_cap_def by wpsimp + +end + + +global_interpretation DomainSepInv_1?: DomainSepInv_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact DomainSepInv_assms | wp init_arch_objects_inv)) +qed + + +context Arch begin global_naming RISCV64 + +crunch + handle_reserved_irq, handle_vm_fault, perform_pg_inv_map, perform_pg_inv_unmap, + perform_pg_inv_get_addr, perform_pt_inv_map, perform_pt_inv_unmap, + handle_hypervisor_fault, handle_arch_fault_reply, arch_mask_irq_signal, + arch_switch_to_thread, arch_switch_to_idle_thread, arch_activate_idle_thread, + store_asid_pool_entry, copy_global_mappings + for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" + (wp: crunch_wps) + +lemma perform_page_invocation_domain_sep_inv: + "\domain_sep_inv irqs st and valid_page_inv pgi\ + perform_page_invocation pgi + \\_. domain_sep_inv irqs st\" + apply (rule hoare_pre) + apply (wp mapM_wp[OF _ subset_refl] set_cap_domain_sep_inv mapM_x_wp[OF _ subset_refl] + perform_page_invocation_domain_sep_inv_get_cap_helper hoare_weak_lift_imp + | simp add: perform_page_invocation_def o_def | wpc)+ + done + +lemma perform_page_table_invocation_domain_sep_inv: + "\domain_sep_inv irqs st and valid_pti pgi\ + perform_page_table_invocation pgi + \\_. domain_sep_inv irqs st\" + apply (rule hoare_pre) + apply (simp add: perform_page_table_invocation_def) + apply (wpsimp wp: perform_page_invocation_domain_sep_inv_get_cap_helper + crunch_wps set_cap_domain_sep_inv) + apply (clarsimp simp: valid_pti_def) + done + +lemma perform_asid_control_invocation_domain_sep_inv: + "perform_asid_control_invocation iv \domain_sep_inv irqs st\" + unfolding perform_asid_control_invocation_def + apply (rule hoare_pre) + apply (wp modify_wp cap_insert_domain_sep_inv' set_cap_domain_sep_inv + get_cap_domain_sep_inv_cap[where st=st] hoare_weak_lift_imp + | wpc | simp )+ + done + +lemma perform_asid_pool_invocation_domain_sep_inv: + "perform_asid_pool_invocation iv \domain_sep_inv irqs st\" + apply (simp add: perform_asid_pool_invocation_def) + apply (rule hoare_pre) + apply (wp set_cap_domain_sep_inv get_cap_wp | wpc | simp)+ + done + +lemma arch_perform_invocation_domain_sep_inv[DomainSepInv_assms]: + "\domain_sep_inv irqs st and valid_arch_inv ai\ + arch_perform_invocation ai + \\_. domain_sep_inv irqs st\" + unfolding arch_perform_invocation_def + apply (wpsimp wp: perform_page_table_invocation_domain_sep_inv + perform_page_invocation_domain_sep_inv + perform_asid_control_invocation_domain_sep_inv + perform_asid_pool_invocation_domain_sep_inv) + apply (clarsimp simp: valid_arch_inv_def split: arch_invocation.splits) + done + +lemma arch_invoke_irq_handler_domain_sep_inv[DomainSepInv_assms, wp]: + "arch_invoke_irq_handler ihi \domain_sep_inv irqs st\" + by (cases ihi; wpsimp) + +lemma arch_invoke_irq_control_domain_sep_inv[DomainSepInv_assms]: + "\domain_sep_inv irqs st and arch_irq_control_inv_valid ivk\ + arch_invoke_irq_control ivk + \\_. domain_sep_inv irqs st\" + apply (cases ivk) + apply (wpsimp wp: cap_insert_domain_sep_inv' simp: set_irq_state_def) + apply (rule_tac Q'="\_. domain_sep_inv irqs st and arch_irq_control_inv_valid ivk" + in hoare_strengthen_post[rotated]) + apply (fastforce simp: domain_sep_inv_def domain_sep_inv_cap_def arch_irq_control_inv_valid_def) + apply (wpsimp wp: do_machine_op_domain_sep_inv simp: arch_irq_control_inv_valid_def)+ + done + +lemma arch_derive_cap_domain_sep_inv[DomainSepInv_assms, wp]: + "\\\ arch_derive_cap acap \\rv _. domain_sep_inv_cap irqs rv\,-" + unfolding arch_derive_cap_def + by wpsimp + +lemma arch_post_modify_registers_domain_sep_inv[DomainSepInv_assms, wp]: + "arch_post_modify_registers cur t \domain_sep_inv irqs st\" + unfolding arch_post_modify_registers_def by wpsimp + +end + + +global_interpretation DomainSepInv_2?: DomainSepInv_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact DomainSepInv_assms) +qed + +end diff --git a/proof/access-control/AARCH64/ArchFinalise_AC.thy b/proof/access-control/AARCH64/ArchFinalise_AC.thy new file mode 100644 index 0000000000..c523ccf513 --- /dev/null +++ b/proof/access-control/AARCH64/ArchFinalise_AC.thy @@ -0,0 +1,302 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchFinalise_AC +imports Finalise_AC +begin + +context Arch begin global_naming RISCV64 + +named_theorems Finalise_AC_assms + +lemma state_vrefs_clear_asid_table: + "state_vrefs (s\arch_state := arch_state s\riscv_asid_table := \a. if a = asid_high_bits_of base + then None + else asid_table s a\\) x + \ state_vrefs s x" + by (fastforce simp: state_vrefs_def dest: vs_lookup_clear_asid_table[simplified fun_upd_def]) + +lemma state_vrefs_clear_asid_pool: + assumes "asid_table s (asid_high_bits_of asid) = Some pool_ptr" + and "ako_at (ASIDPool pool) pool_ptr s" + shows "state_vrefs (s\kheap := \a. if a = pool_ptr + then Some (ArchObj (ASIDPool (\a. if a = asid_low_bits_of asid + then None + else pool a))) + else kheap s a\) x + \ state_vrefs s x" + (is "state_vrefs ?s' _ \ state_vrefs _ _") + using assms + apply - + apply (clarsimp simp: state_vrefs_def) + apply (rule exI, rule conjI) + apply (rule_tac x=lvl in exI) + apply (rule_tac x="if x = pool_ptr then ASIDPool pool else ao" in exI) + apply (rule conjI, rule refl) + apply (rule_tac x=bot in exI) + apply (rule_tac x=asida in exI) + apply (rule_tac x=vref in exI) + apply (prop_tac "ptes_of ?s' = ptes_of s") + apply (fastforce simp: obj_at_def all_ext ptes_of_def obind_def opt_map_def) + apply (fastforce simp: vs_lookup_table_def vspace_for_pool_def obj_at_def obind_def opt_map_def + split: option.split_asm if_split_asm) + apply (fastforce simp: vs_refs_aux_def graph_of_def opt_map_def split: if_splits) + done + +crunch set_vm_root for pas_refined[wp]: "pas_refined aag" + +lemma delete_asid_pool_pas_refined[wp]: + "delete_asid_pool base ptr \pas_refined aag\" + unfolding delete_asid_pool_def + apply wpsimp + apply (clarsimp simp: pas_refined_def state_objs_to_policy_def) + apply (rule conjI; clarsimp) + apply (erule subsetD) + apply (clarsimp simp: auth_graph_map_def) + apply (rule exI, rule conjI, rule refl)+ + apply (erule state_bits_to_policy_vrefs_subseteq; fastforce?) + apply (clarsimp simp: allI state_vrefs_clear_asid_table) + apply (erule subsetD, erule state_asids_to_policy_vrefs_subseteq) + apply clarsimp + apply (clarsimp simp: allI state_vrefs_clear_asid_table) + apply clarsimp + done + +lemma delete_asid_pas_refined[wp]: + "delete_asid asid pt \pas_refined aag\" + unfolding delete_asid_def + apply (rule bind_wp) + apply (wpsimp simp: set_asid_pool_def wp: set_object_wp hoare_vcg_imp_lift' hoare_vcg_all_lift) + apply (rule_tac Q'="\_ s. riscv_asid_table (arch_state s) = asid_table \ + ako_at (ASIDPool pool) x2 s \ pas_refined aag s" + in hoare_strengthen_post[rotated]) + defer + apply wpsimp+ + apply (clarsimp simp: pas_refined_def) + apply (intro conjI) + apply (clarsimp simp: state_objs_to_policy_def) + apply (subst (asm) caps_of_state_fun_upd[simplified fun_upd_def]) + apply (clarsimp simp: obj_at_def) + apply (erule subsetD) + apply (clarsimp simp: auth_graph_map_def) + apply (rule exI, rule conjI, rule refl)+ + apply (erule state_bits_to_policy_vrefs_subseteq) + apply clarsimp + apply (clarsimp simp: all_ext thread_st_auth_def tcb_states_of_state_def get_tcb_def obj_at_def) + apply (clarsimp simp: all_ext thread_bound_ntfns_def get_tcb_def obj_at_def) + apply clarsimp + apply (rule allI[OF state_vrefs_clear_asid_pool]; simp) + apply clarsimp + apply (erule subsetD, erule state_asids_to_policy_vrefs_subseteq) + apply (fastforce simp: obj_at_def caps_of_state_fun_upd[simplified fun_upd_def]) + apply (rule allI[OF state_vrefs_clear_asid_pool]; fastforce) + apply fastforce + apply (fastforce simp: obj_at_def caps_of_state_fun_upd[simplified fun_upd_def]) + done + +lemma arch_finalise_cap_pas_refined[wp]: + "\pas_refined aag and invs and valid_arch_cap c\ arch_finalise_cap c x \\_. pas_refined aag\" + unfolding arch_finalise_cap_def + apply (wpsimp wp: unmap_page_pas_refined unmap_page_table_pas_refined) + apply (auto simp: valid_arch_cap_def wellformed_mapdata_def) + done + +crunch prepare_thread_delete + for pas_refined[wp]: "pas_refined aag" + +crunch prepare_thread_delete + for respects[Finalise_AC_assms, wp]: "integrity aag X st" + +lemma sbn_st_vrefs[Finalise_AC_assms]: + "\(\s. P (state_vrefs s)) and pspace_aligned and valid_vspace_objs and valid_arch_state\ + set_bound_notification t st + \\_ s. P (state_vrefs s)\" + apply (simp add: set_bound_notification_def) + apply (wpsimp wp: set_object_wp dxo_wp_weak) + apply (subst state_vrefs_tcb_upd) + apply (auto simp: tcb_at_def) + done + +lemma arch_finalise_cap_auth'[Finalise_AC_assms]: + "\pas_refined aag\ arch_finalise_cap x12 final \\rv s. pas_cap_cur_auth aag (fst rv)\" + unfolding arch_finalise_cap_def + by (wp | wpc | simp add: comp_def hoare_TrueI[where P = \] split del: if_split)+ + +lemma arch_finalise_cap_obj_refs[Finalise_AC_assms]: + "\\s. \x \ aobj_ref' acap. P x\ + arch_finalise_cap acap slot + \\rv s. \x \ obj_refs_ac (fst rv). P x\" + by (wpsimp simp: arch_finalise_cap_def) + +lemma arch_finalise_cap_makes_halted[Finalise_AC_assms]: + "\\\ arch_finalise_cap arch_cap ex \\rv s. \t\obj_refs_ac (fst rv). halted_if_tcb t s\" + apply (case_tac arch_cap, simp_all add: arch_finalise_cap_def) + by (wpsimp simp: valid_cap_def split: option.split bool.split)+ + +lemma arch_cap_cleanup_wf[Finalise_AC_assms]: + "\ arch_cap_cleanup_opt acap \ NullCap; \ is_arch_cap (arch_cap_cleanup_opt acap) \ + \ (\irq. arch_cap_cleanup_opt acap = IRQHandlerCap irq \ is_subject_irq aag irq)" + by simp + +lemma set_vm_root_integrity[wp]: + "set_vm_root param_a \integrity aag X st\ " + unfolding set_vm_root_def + by (wpsimp wp: dmo_wp mol_respects get_cap_wp simp: setVSpaceRoot_def) + +lemma delete_asid_pool_respects[wp]: + "\integrity aag X st and + K (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of x + \ is_subject_asid aag asid')\ + delete_asid_pool x y + \\_. integrity aag X st\" + unfolding delete_asid_pool_def + by (wpsimp wp: mapM_wp[OF _ subset_refl] simp: integrity_asid_table_entry_update' integrity_def) + +crunch set_vm_root + for integrity_obj[wp]: "integrity_obj_state aag activate subjects st" + and cdt[wp]: "\s. P (cdt s)" + and is_original_cap[wp]: "\s. P (is_original_cap s x)" + and interrupt_irq_node[wp]: "\s. P (interrupt_states s x)" + and underlying_memory[wp]: "\s. P (underlying_memory (machine_state s) x)" + and device_state[wp]: "\s. P (device_state (machine_state s) x)" + and tcb_states_of_state[wp]: "\s. P (tcb_states_of_state s)" + (wp: dmo_wp) + +crunch set_asid_pool + for is_original_cap[wp]: "\s. P (is_original_cap s x)" + and cdt_list[wp]: "\s. P (cdt_list s x)" + and ready_queues[wp]: "\s. P (ready_queues s x y)" + and machine_state[wp]: "\s. P (machine_state s)" + +lemma set_asid_pool_tcb_states_of_state[wp]: + "set_asid_pool p pool \\s. P (tcb_states_of_state s)\" + apply (wpsimp wp: set_object_wp_strong simp: obj_at_def set_asid_pool_def) + apply (prop_tac "\x. get_tcb x (s\kheap := (kheap s)(p \ ArchObj (ASIDPool pool))\) = get_tcb x s") + apply (auto simp: tcb_states_of_state_def get_tcb_def) + done + +lemma delete_asid_integrity_asids: + "\\s. pas_refined aag s \ invs s \ is_subject aag pt \ + (\x a. integrity_asids aag {pasSubject aag} x a st s)\ + delete_asid asid pt + \\_ s. integrity_asids aag {pasSubject aag} x a st s\" + unfolding integrity_def + apply (wpsimp wp: dmo_wp mol_respects set_object_wp hoare_vcg_all_lift hoare_vcg_imp_lift + simp: delete_asid_def hwASIDFlush_def set_asid_pool_def) + apply (intro conjI impI allI; clarsimp) + apply fastforce + apply (clarsimp simp: opt_map_def) + apply (erule_tac x=asid in allE, fastforce) + done + +lemma set_asid_pool_respects_clear: + "\integrity_obj_state aag activate subjects st and + (\s. \pool'. ako_at (ASIDPool pool') ptr s \ asid_pool_integrity subjects aag pool' pool)\ + set_asid_pool ptr pool + \\_. integrity_obj_state aag activate subjects st\" + apply (wpsimp wp: set_object_wp_strong simp: obj_at_def set_asid_pool_def) + using arch_troa_asidpool_clear tro_arch tro_trans_spec by fastforce + +lemma delete_asid_respects: + "\integrity aag X st and pas_refined aag and invs and K (is_subject aag pd)\ + delete_asid asid pd + \\_. integrity aag X st\" + unfolding integrity_def + supply integrity_asids_def[simp del] + apply (rule hoare_pre) + apply (simp only: conj_assoc[symmetric]) + apply (rule hoare_vcg_conj_lift) + apply (simp add: delete_asid_def) + apply (wp | wpc | wps)+ + apply (wpsimp wp: set_asid_pool_respects_clear dmo_wp + delete_asid_integrity_asids hoare_vcg_all_lift)+ + apply (clarsimp simp: pas_refined_refl obj_at_def asid_pool_integrity_def) + done + +lemma arch_finalise_cap_respects[wp]: + "\integrity aag X st and invs and pas_refined aag and valid_cap (ArchObjectCap cap) + and K (pas_cap_cur_auth aag (ArchObjectCap cap))\ + arch_finalise_cap cap final + \\_. integrity aag X st\" + apply (simp add: arch_finalise_cap_def) + apply (wpsimp wp: unmap_page_respects unmap_page_table_respects delete_asid_respects) + apply (auto simp: cap_auth_conferred_def arch_cap_auth_conferred_def wellformed_mapdata_def + aag_cap_auth_def pas_refined_all_auth_is_owns valid_cap_simps + cap_links_asid_slot_def label_owns_asid_slot_def + intro: pas_refined_Control_into_is_subject_asid) + done + +crunch arch_post_cap_deletion + for pspace_aligned[Finalise_AC_assms, wp]: "\s :: det_ext state. pspace_aligned s" + and valid_vspace_objs[Finalise_AC_assms, wp]: "\s :: det_ext state. valid_vspace_objs s" + and valid_arch_state[Finalise_AC_assms, wp]: "\s :: det_ext state. valid_arch_state s" + +end + + +global_interpretation Finalise_AC_1?: Finalise_AC_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Finalise_AC_assms | wp finalise_cap_replaceable)) +qed + + +context Arch begin global_naming RISCV64 + +lemma cap_revoke_respects'[Finalise_AC_assms]: + "s \ \(\s. trp \ integrity aag X st s) and K (is_subject aag (fst slot)) + and pas_refined aag and einvs and simple_sched_action\ + cap_revoke slot + \\_. (\s. trp \ integrity aag X st s) and pas_refined aag\, + \\_. (\s. trp \ integrity aag X st s) and pas_refined aag\" +proof (induct rule: cap_revoke.induct[where ?a1.0=s]) + case (1 slot s) + show ?case + apply (subst cap_revoke.simps) + apply (rule hoare_pre_spec_validE) + apply (wp "1.hyps") + apply ((wp preemption_point_inv' | simp add: integrity_subjects_def pas_refined_def)+)[1] + apply (wp select_ext_weak_wp cap_delete_respects cap_delete_pas_refined + | simp split del: if_split | wp (once) hoare_vcg_const_imp_lift hoare_drop_imps)+ + by (auto simp: emptyable_def descendants_of_def + dest: reply_slot_not_descendant + intro: cca_owned) +qed + +lemma finalise_cap_caps_of_state_nullinv[Finalise_AC_assms]: + "\\s. P (caps_of_state s) \ (\p. P ((caps_of_state s)(p \ NullCap)))\ + finalise_cap cap final + \\_ s. P (caps_of_state s)\" + by (cases cap; + wpsimp wp: suspend_caps_of_state unbind_notification_caps_of_state + unbind_notification_cte_wp_at + hoare_vcg_all_lift hoare_drop_imps + deleting_irq_handler_caps_of_state_nullinv + simp: fun_upd_def[symmetric] if_apply_def2 split_del: if_split) + +lemma finalise_cap_fst_ret[Finalise_AC_assms]: + "\\_. P NullCap \ (\a b c. P (Zombie a b c))\ + finalise_cap cap is_final + \\rv _. P (fst rv)\" + including classic_wp_pre + apply (cases cap, simp_all add: arch_finalise_cap_def split del: if_split) + apply (wp | simp add: comp_def split del: if_split | fastforce)+ + apply (rule hoare_pre) + apply (wp | simp | (rule hoare_pre, wpc))+ + done + +end + + +global_interpretation Finalise_AC_2?: Finalise_AC_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact Finalise_AC_assms) +qed + +end \ No newline at end of file diff --git a/proof/access-control/AARCH64/ArchInterrupt_AC.thy b/proof/access-control/AARCH64/ArchInterrupt_AC.thy new file mode 100644 index 0000000000..09ff7a783c --- /dev/null +++ b/proof/access-control/AARCH64/ArchInterrupt_AC.thy @@ -0,0 +1,112 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchInterrupt_AC +imports + Interrupt_AC +begin + +context Arch begin global_naming RISCV64 + +named_theorems Interrupt_AC_assms + +definition arch_authorised_irq_ctl_inv :: + "'a PAS \ Invocations_A.arch_irq_control_invocation \ bool" where + "arch_authorised_irq_ctl_inv aag cinv \ + case cinv of (RISCVIRQControlInvocation irq x1 x2 trigger) \ + is_subject aag (fst x1) \ is_subject aag (fst x2) \ + (pasSubject aag, Control, pasIRQAbs aag irq) \ pasPolicy aag" + +lemma arch_invoke_irq_control_pas_refined[Interrupt_AC_assms]: + "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state + and valid_mdb and arch_irq_control_inv_valid irq_ctl_inv + and K (arch_authorised_irq_ctl_inv aag irq_ctl_inv)\ + arch_invoke_irq_control irq_ctl_inv + \\_. pas_refined aag\" + apply (cases irq_ctl_inv; simp) + apply (wpsimp wp: cap_insert_pas_refined_not_transferable) + apply (clarsimp simp: cte_wp_at_caps_of_state clas_no_asid cap_links_irq_def + arch_authorised_irq_ctl_inv_def aag_cap_auth_def + arch_irq_control_inv_valid_def) + done + +lemma arch_invoke_irq_handler_pas_refined[Interrupt_AC_assms]: + "\pas_refined aag and invs and (\s. interrupt_states s x1 \ IRQInactive)\ + arch_invoke_irq_handler (ACKIrq x1) + \\_. pas_refined aag\" + by wpsimp + +lemma arch_invoke_irq_control_respects[Interrupt_AC_assms]: + "\integrity aag X st and pas_refined aag and K (arch_authorised_irq_ctl_inv aag acinv)\ + arch_invoke_irq_control acinv + \\_. integrity aag X st\" + apply (case_tac acinv, clarsimp simp add: setIRQTrigger_def arch_authorised_irq_ctl_inv_def) + apply (wpsimp wp: cap_insert_integrity_autarch aag_Control_into_owns_irq + dmo_mol_respects do_machine_op_pas_refined) + done + +lemma integrity_irq_masks [iff]: + "integrity aag X st (s\machine_state := machine_state s \irq_masks := v\\) = + integrity aag X st s" + unfolding integrity_def by simp + +lemma arch_invoke_irq_handler_respects[Interrupt_AC_assms]: + "\integrity aag X st and pas_refined aag and einvs\ + arch_invoke_irq_handler (ACKIrq x1) + \\_. integrity aag X st\" + by (wpsimp wp: dmo_wp mol_respects simp: maskInterrupt_def plic_complete_claim_def) + +crunch arch_check_irq for inv[Interrupt_AC_assms, wp]: P + +end + + +context begin interpretation Arch . + +requalify_consts arch_authorised_irq_ctl_inv + +end + + +global_interpretation Interrupt_AC_1?: Interrupt_AC_1 "arch_authorised_irq_ctl_inv" +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Interrupt_AC_assms)?) +qed + + +context Arch begin global_naming RISCV64 + +lemma arch_decode_irq_control_invocation_authorised[Interrupt_AC_assms]: + "\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 info_label args slot caps + \\x _. arch_authorised_irq_ctl_inv aag x\, -" + unfolding decode_irq_control_invocation_def arch_decode_irq_control_invocation_def Let_def + authorised_irq_ctl_inv_def arch_authorised_irq_ctl_inv_def arch_check_irq_def + apply (rule hoare_gen_asmE) + apply (wpsimp wp: weak_if_wp) + apply (cases args, simp_all) + apply (cases caps, simp_all) + apply (auto simp: is_cap_simps cap_auth_conferred_def + pas_refined_wellformed + pas_refined_all_auth_is_owns aag_cap_auth_def) + done + +end + + +global_interpretation Interrupt_AC_2?: Interrupt_AC_2 "arch_authorised_irq_ctl_inv" +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Interrupt_AC_assms)?) +qed + + +end diff --git a/proof/access-control/AARCH64/ArchIpc_AC.thy b/proof/access-control/AARCH64/ArchIpc_AC.thy new file mode 100644 index 0000000000..7be518e246 --- /dev/null +++ b/proof/access-control/AARCH64/ArchIpc_AC.thy @@ -0,0 +1,238 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchIpc_AC +imports Ipc_AC +begin + +context Arch begin global_naming RISCV64 + +named_theorems Ipc_AC_assms + +lemma make_fault_message_inv[Ipc_AC_assms, wp]: + "make_fault_msg ft t \P\" + apply (cases ft, simp_all split del: if_split) + by (wp as_user_inv getRestartPC_inv mapM_wp' make_arch_fault_msg_inv | simp add: getRegister_def)+ + +declare handle_arch_fault_reply_typ_at[Ipc_AC_assms] + +crunch cap_insert_ext + for integrity_asids[Ipc_AC_assms, wp]: "integrity_asids aag subjects x a st" + +lemma arch_derive_cap_auth_derived[Ipc_AC_assms]: + "\\\ arch_derive_cap acap \\rv _. rv \ NullCap \ auth_derived rv (ArchObjectCap acap)\, -" + by (case_tac acap; + simp add: derive_cap_def arch_derive_cap_def; + wpc?; + wp?; + simp add: auth_derived_def cap_auth_conferred_def arch_cap_auth_conferred_def) + +lemma lookup_ipc_buffer_has_auth[Ipc_AC_assms, wp]: + "\pas_refined aag and valid_objs\ + lookup_ipc_buffer True receiver + \\rv _. ipc_buffer_has_auth aag receiver 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_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 (rule conjI) + apply (clarsimp simp: valid_cap_simps cap_aligned_def) + 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 simp + 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_write_def) + apply (drule bspec) + apply (erule (3) ipcframe_subset_page) + apply simp + done + +lemma tcb_context_no_change[Ipc_AC_assms]: + "\ctxt. tcb = tcb\tcb_arch := arch_tcb_context_set ctxt (tcb_arch tcb)\" + apply (cases tcb, clarsimp) + apply (case_tac tcb_arch) + apply (auto simp: arch_tcb_context_set_def) + done + +end + + +global_interpretation Ipc_AC_1?: Ipc_AC_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Ipc_AC_assms)?) +qed + + +context Arch begin global_naming RISCV64 + +lemma store_word_offs_respects_in_ipc[Ipc_AC_assms]: + "\integrity_tcb_in_ipc aag X receiver epptr TRContext st and + K ((\ is_subject aag receiver \ auth_ipc_buffers st receiver = ptr_range buf msg_align_bits) + \ is_aligned buf msg_align_bits \ r < 2 ^ (msg_align_bits - word_size_bits))\ + store_word_offs buf r v + \\_. integrity_tcb_in_ipc aag X receiver epptr TRContext st\" + apply (simp add: store_word_offs_def storeWord_def pred_conj_def) + apply (wp dmo_wp) + apply (clarsimp simp: integrity_tcb_in_ipc_def) + apply (erule integrity_trans) + apply (clarsimp simp: integrity_def) + apply (subgoal_tac "\i \ set [0..7]. + buf + of_nat r * of_nat word_size + of_int i \ ptr_range buf msg_align_bits") + apply (fastforce simp: word_rsplit_0 upto.simps atLeastAtMost_upto) + apply (fastforce simp add: unat_def word_size_def of_nat_nat[symmetric] word_of_nat_less + simp del: of_nat_nat intro: ptr_range_off_off_mems) + done + +crunch set_extra_badge + for respects_in_ipc[Ipc_AC_assms, wp]: "integrity_tcb_in_ipc aag X receiver epptr TRContext st" + (wp: store_word_offs_respects_in_ipc) + +crunch handle_arch_fault_reply + for pas_refined[Ipc_AC_assms, wp]: "pas_refined aag" + +lemma set_mrs_respects_in_ipc[Ipc_AC_assms]: + "\integrity_tcb_in_ipc aag X receiver epptr TRContext st and + K ((\ is_subject aag receiver \ + (case recv_buf of None \ True | Some buf' \ auth_ipc_buffers st receiver = + ptr_range buf' msg_align_bits)) \ + (case recv_buf of None \ True | Some buf' \ is_aligned buf' msg_align_bits))\ + set_mrs receiver recv_buf msgs + \\rv. integrity_tcb_in_ipc aag X receiver epptr TRContext st\" + unfolding set_mrs_def set_object_def get_object_def + apply (rule hoare_gen_asm) + apply (wp mapM_x_wp' store_word_offs_respects_in_ipc + | wpc + | simp split del: if_split add: zipWithM_x_mapM_x split_def)+ + apply (clarsimp simp add: set_zip nth_append simp: msg_align_bits' msg_max_length_def + split: if_split_asm) + apply (simp add: msg_registers_def msgRegisters_def upto_enum_def fromEnum_def enum_register) + apply arith + apply simp + apply wp+ + apply (clarsimp simp: arch_tcb_set_registers_def) + apply (rule update_tcb_context_in_ipc [unfolded fun_upd_def]; fastforce simp: arch_tcb_context_set_def) + done + +lemma lookup_ipc_buffer_ptr_range_in_ipc[Ipc_AC_assms]: + "\valid_objs and integrity_tcb_in_ipc aag X thread epptr tst st\ + lookup_ipc_buffer True thread + \\rv _. \ is_subject aag thread \ + (case rv of None \ True | Some buf' \ auth_ipc_buffers st 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] integrity_tcb_in_ipc_def) + apply (drule get_tcb_SomeD) + apply (erule(1) valid_objsE) + apply (clarsimp simp: valid_obj_def valid_tcb_def valid_ipc_buffer_cap_def case_bool_if + split: if_split_asm) + apply (erule tcb_in_ipc.cases; clarsimp simp: get_tcb_def vm_read_write_def) + done + +lemma lookup_ipc_buffer_aligned[Ipc_AC_assms]: + "\valid_objs\ + lookup_ipc_buffer True thread + \\rv _. (case rv of None \ True | Some buf' \ is_aligned 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 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: valid_cap_simps cap_aligned_def) + 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) + done + +lemma handle_arch_fault_reply_respects[Ipc_AC_assms]: + "\integrity aag X st and K (is_subject aag thread)\ + handle_arch_fault_reply fault thread x y + \\_. integrity aag X st\" + by (wpsimp simp: handle_arch_fault_reply_def) + +lemma auth_ipc_buffers_kheap_update[Ipc_AC_assms]: + "\ x \ auth_ipc_buffers st thread; kheap st thread = Some (TCB tcb); + kheap s thread = Some (TCB tcb'); tcb_ipcframe tcb = tcb_ipcframe tcb' \ + \ x \ auth_ipc_buffers (s\kheap := (kheap s)(thread \ TCB tcb)\) thread" + by (clarsimp simp: auth_ipc_buffers_member_def get_tcb_def caps_of_state_tcb) + +lemma auth_ipc_buffers_machine_state_update[Ipc_AC_assms, simp]: + "auth_ipc_buffers (machine_state_update f s) = auth_ipc_buffers s" + by (clarsimp simp: auth_ipc_buffers_def get_tcb_def) + +crunch handle_arch_fault_reply + for pspace_aligned[Ipc_AC_assms, wp]: "\s :: det_ext state. pspace_aligned s" + and valid_vspace_objs[Ipc_AC_assms, wp]: "\s :: det_ext state. valid_vspace_objs s" + and valid_arch_state[Ipc_AC_assms, wp]: "\s :: det_ext state. valid_arch_state s" + +lemma cap_insert_ext_integrity_asids_in_ipc[Ipc_AC_assms, wp]: + "cap_insert_ext src_parent src_slot dest_slot src_p dest_p + \\s. integrity_asids aag subjects x asid st + (s\kheap := \a. if a = receiver then kheap st receiver else kheap s a\)\" + by wpsimp + +declare handle_arch_fault_reply_inv[Ipc_AC_assms] +declare arch_get_sanitise_register_info_inv[Ipc_AC_assms] + +end + + +context is_extended begin interpretation Arch . + +lemma list_integ_lift_in_ipc[Ipc_AC_assms]: + assumes li: + "\list_integ (cdt_change_allowed aag {pasSubject aag} (cdt st) (tcb_states_of_state st)) st and Q\ + f + \\_. list_integ (cdt_change_allowed aag {pasSubject aag} (cdt st) (tcb_states_of_state st)) st\" + assumes ekh: "\P. \\s. P (ekheap s)\ f \\rv s. P (ekheap s)\" + assumes rq: "\P. \ \s. P (ready_queues s) \ f \ \rv s. P (ready_queues s) \" + shows "\integrity_tcb_in_ipc aag X receiver epptr ctxt st and Q\ + f + \\_. integrity_tcb_in_ipc aag X receiver epptr ctxt st\" + apply (unfold integrity_tcb_in_ipc_def integrity_def[abs_def] pool_for_asid_def) + apply (simp del:split_paired_All) + apply (rule hoare_pre) + apply (simp only: integrity_cdt_list_as_list_integ) + apply (rule hoare_lift_Pf2[where f="ekheap"]) + apply (simp add: tcb_states_of_state_def get_tcb_def) + apply (wp li[simplified tcb_states_of_state_def get_tcb_def] ekh rq)+ + apply (simp only: integrity_cdt_list_as_list_integ) + apply (simp add: tcb_states_of_state_def get_tcb_def) + apply (fastforce simp: opt_map_def) + done + +end + + +global_interpretation Ipc_AC_2?: Ipc_AC_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Ipc_AC_assms)?) +qed + +end diff --git a/proof/access-control/AARCH64/ArchRetype_AC.thy b/proof/access-control/AARCH64/ArchRetype_AC.thy new file mode 100644 index 0000000000..93b34a9022 --- /dev/null +++ b/proof/access-control/AARCH64/ArchRetype_AC.thy @@ -0,0 +1,383 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchRetype_AC +imports Retype_AC +begin + + +lemma invs_mdb_cte': + "invs s \ mdb_cte_at (\p. \c. caps_of_state s p = Some c \ NullCap \ c) (cdt s)" + by (drule invs_mdb) (simp add: valid_mdb_def2) + + +context retype_region_proofs begin interpretation Arch . + +lemma state_vrefs_eq: + "\ valid_vspace_objs s; valid_arch_state s \ + \ state_vrefs s' = state_vrefs s" + apply (insert dev vp) + apply (intro ext subset_antisym subsetI) + apply (clarsimp simp: state_vrefs_def) + apply (frule vs_lookup_level) + apply (simp add: vs_lookup_table') + apply (prop_tac "kheap s x = kheap s' x") + apply (clarsimp simp: s'_def ps_def split: if_splits) + apply (case_tac "lvl > max_pt_level") + apply (fastforce simp: valid_arch_state_def opt_map_def orthr + dest: vs_lookup_asid_pool + split: option.splits) + apply (fastforce simp: valid_arch_state_def valid_pspace_def obj_at_def orthr + dest!: vs_lookup_table_pt_at ) + apply (fastforce simp: opt_map_def) + apply (clarsimp simp: state_vrefs_def) + apply (frule vs_lookup_level) + apply (prop_tac "kheap s x = kheap s' x") + apply (clarsimp simp: s'_def ps_def split: if_splits) + apply (case_tac "lvl > max_pt_level") + apply (fastforce simp: valid_arch_state_def opt_map_def orthr + dest: vs_lookup_asid_pool + split: option.splits) + apply (fastforce simp: valid_arch_state_def valid_pspace_def obj_at_def orthr + dest!: vs_lookup_table_pt_at ) + apply (fastforce simp: opt_map_def vs_lookup_table'[symmetric]) + done + +end + + +context retype_region_proofs' begin interpretation Arch . + +lemma pas_refined: + "\ invs s; pas_refined aag s \ \ pas_refined aag s'" + apply (erule pas_refined_state_objs_to_policy_subset) + apply (simp add: state_objs_to_policy_def refs_eq mdb_and_revokable) + apply (subst state_vrefs_eq; fastforce?) + apply (rule subsetI, rename_tac x, case_tac x, simp) + apply (erule state_bits_to_policy.cases) + apply (solves \auto intro!: sbta_caps intro: caps_retype split: cap.split\) + apply (solves \auto intro!: sbta_untyped intro: caps_retype split: cap.split\) + apply (blast intro: state_bits_to_policy.intros) + apply (blast intro: state_bits_to_policy.intros) + apply (force intro!: sbta_cdt + dest: caps_of_state_pres invs_mdb_cte'[THEN mdb_cte_atD[rotated]]) + apply (force intro!: sbta_cdt_transferable + dest: caps_of_state_pres invs_mdb_cte'[THEN mdb_cte_atD[rotated]]) + apply (blast intro: state_bits_to_policy.intros) + apply (subst state_vrefs_eq; fastforce?) + apply (force elim!: state_asids_to_policy_aux.cases + intro: state_asids_to_policy_aux.intros caps_retype + split: cap.split + dest: sata_asid[OF caps_retype, rotated]) + apply clarsimp + apply (erule state_irqs_to_policy_aux.cases) + apply (solves\auto intro!: sita_controlled intro: caps_retype split: cap.split\) + apply (rule domains_of_state) + apply simp + done + +end + + +context Arch begin global_naming RISCV64 + +named_theorems Retype_AC_assms + +declare retype_region_proofs'.pas_refined[Retype_AC_assms] + +lemma aobjs_of_detype[simp]: + "(aobjs_of (detype S s) p = Some aobj) = (p \ S \ aobjs_of s p = Some aobj)" + by (simp add: in_omonad detype_def) + +lemma pts_of_detype[simp]: + "(pts_of (detype S s) p = Some pt) = (p \ S \ pts_of s p = Some pt)" + by (simp add: in_omonad detype_def) + +lemma ptes_of_detype_Some[simp]: + "(ptes_of (detype S s) p = Some pte) = (table_base p \ S \ ptes_of s p = Some pte)" + by (simp add: in_omonad ptes_of_def detype_def) + +lemma asid_pools_of_detype: + "asid_pools_of (detype S s) = (\p. if p\S then None else asid_pools_of s p)" + by (rule ext) (simp add: detype_def opt_map_def) + +lemma asid_pools_of_detype_Some[simp]: + "(asid_pools_of (detype S s) p = Some ap) = (p \ S \ asid_pools_of s p = Some ap)" + by (simp add: in_omonad detype_def) + +lemma pool_for_asid_detype_Some[simp]: + "(pool_for_asid asid (detype S s) = Some p) = (pool_for_asid asid s = Some p)" + by (simp add: pool_for_asid_def) + +lemma vspace_for_pool_detype_Some[simp]: + "(vspace_for_pool ap asid (\p. if p \ S then None else pools p) = Some p) = + (ap \ S \ vspace_for_pool ap asid pools = Some p)" + by (simp add: vspace_for_pool_def obind_def split: option.splits) + +lemma vspace_for_asid_detype_Some[simp]: + "(vspace_for_asid asid (detype S s) = Some p) = + ((\ap. pool_for_asid asid s = Some ap \ ap \ S) \ vspace_for_asid asid s = Some p)" + apply (simp add: vspace_for_asid_def obind_def asid_pools_of_detype split: option.splits) + apply (auto simp: pool_for_asid_def) + done + +lemma pt_walk_detype: + "pt_walk level bot_level pt_ptr vref (ptes_of (detype S s)) = Some (bot_level, p) \ + pt_walk level bot_level pt_ptr vref (ptes_of s) = Some (bot_level, p)" + apply (induct level arbitrary: pt_ptr) + apply (subst pt_walk.simps, simp) + apply (subst pt_walk.simps) + apply (subst (asm) (3) pt_walk.simps) + apply (clarsimp simp: in_omonad split: if_split_asm) + apply (erule disjE; clarsimp) + apply (drule meta_spec, drule (1) meta_mp) + apply fastforce + done + +lemma vs_lookup_table: + "vs_lookup_table level asid vref (detype S s) = Some (level, p) \ + vs_lookup_table level asid vref s = Some (level, p)" + apply (clarsimp simp: vs_lookup_table_def in_omonad obind_def asid_pools_of_detype + split: if_split_asm option.split_asm) + apply (rule conjI) + apply clarsimp + apply (subst pt_walk_detype) + apply simp + apply simp + done + +lemma state_vrefs_detype[Retype_AC_assms, dest]: + "x \ state_vrefs (detype R s) p \ x \ state_vrefs s p" + apply (clarsimp simp: state_vrefs_def) + apply (frule vs_lookup_level) + apply (drule vs_lookup_table) + apply fastforce + done + +lemma sata_detype[Retype_AC_assms]: + "state_asids_to_policy aag (detype R s) \ state_asids_to_policy aag s" + apply (clarsimp) + apply (erule state_asids_to_policy_aux.induct) + apply (auto intro: state_asids_to_policy_aux.intros split: if_split_asm) + done + +lemma word_size_bits_untyped_min_bits[Retype_AC_assms]: "word_size_bits \ untyped_min_bits" + by (simp add: word_size_bits_def untyped_min_bits_def) + +lemma word_size_bits_resetChunkBits[Retype_AC_assms]: "word_size_bits \ resetChunkBits" + by (simp add: word_size_bits_def Kernel_Config.resetChunkBits_def) + +lemma clas_default_cap[Retype_AC_assms]: + "tp \ ArchObject ASIDPoolObj \ cap_links_asid_slot aag p (default_cap tp p' sz dev)" + unfolding cap_links_asid_slot_def + apply (cases tp, simp_all) + apply (rename_tac aobject_type) + apply (case_tac aobject_type, simp_all add: arch_default_cap_def) + done + +lemma cli_default_cap[Retype_AC_assms]: + "tp \ ArchObject ASIDPoolObj \ cap_links_irq aag p (default_cap tp p' sz dev)" + unfolding cap_links_irq_def + apply (cases tp, simp_all) + done + +lemma aobj_refs'_default'[Retype_AC_assms]: + "is_aligned oref (obj_bits_api (ArchObject tp) sz) + \ aobj_ref' (arch_default_cap tp oref sz dev) \ ptr_range oref (obj_bits_api (ArchObject tp) sz)" + by (cases tp; simp add: arch_default_cap_def ptr_range_memI obj_bits_api_def default_arch_object_def) + +crunch init_arch_objects + for inv[wp]: P + +lemma region_in_kernel_window_preserved: + assumes "\P. f \\s. P (arch_state s)\" + shows "\S. f \region_in_kernel_window S\" + apply (clarsimp simp: valid_def region_in_kernel_window_def) + apply (erule use_valid) + apply (rule assms) + apply fastforce + done + +(* proof clagged from Retype_AI.clearMemory_vms *) +lemma freeMemory_vms: + "valid_machine_state s \ + \x\fst (freeMemory ptr bits (machine_state s)). valid_machine_state (s\machine_state := snd x\)" + apply (clarsimp simp: valid_machine_state_def disj_commute[of "in_user_frame p s" for p s]) + apply (drule_tac x=p in spec, simp) + apply (drule_tac P4="\m'. underlying_memory m' p = 0" + in use_valid[where P=P and Q="\_. P" for P], simp_all) + apply (simp add: freeMemory_def machine_op_lift_def machine_rest_lift_def split_def) + apply (wp hoare_drop_imps | simp | wp mapM_x_wp_inv)+ + apply (simp add: storeWord_def | wp)+ + apply (simp add: word_rsplit_0 upto.simps word_bits_def) + apply simp + done + +lemma dmo_freeMemory_vms: + "do_machine_op (freeMemory ptr bits) \valid_machine_state\" + apply (unfold do_machine_op_def) + apply (wp modify_wp freeMemory_vms | simp add: split_def)+ + done + +lemma freeMemory_valid_irq_states: + "freeMemory ptr bits \\ms. valid_irq_states (s\machine_state := ms\)\" + unfolding freeMemory_def + by (wp mapM_x_wp[OF _ subset_refl] storeWord_valid_irq_states) + +crunch freeMemory + for pspace_respects_device_region[wp]: "\ms. P (device_state ms)" + (wp: crunch_wps) + +lemma dmo_freeMemory_invs[Retype_AC_assms]: + "do_machine_op (freeMemory ptr bits) \invs\" + apply (simp add: do_machine_op_def invs_def valid_state_def cur_tcb_def | wp | wpc)+ + apply (clarsimp) + apply (frule_tac P1="(=) (device_state (machine_state s))" + in use_valid[OF _ freeMemory_pspace_respects_device_region]) + apply simp + apply simp + apply (rule conjI) + apply (erule use_valid[OF _ freeMemory_valid_irq_states], simp) + apply (drule freeMemory_vms) + apply auto + done + +crunch delete_objects + for global_refs[wp]: "\s. P (global_refs s)" + (ignore: do_machine_op freeMemory) + +lemma init_arch_objects_pas_cur_domain[Retype_AC_assms, wp]: + "init_arch_objects tp dev ptr n us refs \pas_cur_domain aag\" + by wp + +lemma retype_region_pas_cur_domain[Retype_AC_assms, wp]: + "retype_region ptr n us tp dev \pas_cur_domain aag\" + by wp + +lemma reset_untyped_cap_pas_cur_domain[Retype_AC_assms, wp]: + "reset_untyped_cap src_slot \pas_cur_domain aag\" + by wp + +lemma arch_data_to_obj_type_not_ASIDPoolObj[Retype_AC_assms, simp]: + "arch_data_to_obj_type v \ Some ASIDPoolObj" + by (clarsimp simp: arch_data_to_obj_type_def) + +lemma data_to_nat_of_nat[Retype_AC_assms, simp]: + "of_nat (data_to_nat x) = x" + by simp + +lemma nonzero_data_to_nat_simp[Retype_AC_assms]: + "0 < data_to_nat x \ 0 < x" + by (auto dest: word_of_nat_less) + +lemma storeWord_integrity_autarch: + "\\ms. integrity aag X st (s\machine_state := ms\) \ + (is_aligned p word_size_bits \ (\p' \ ptr_range p word_size_bits. is_subject aag p'))\ + storeWord p v + \\_ ms. integrity aag X st (s\machine_state := ms\)\" + unfolding storeWord_def + apply wp + by (auto simp: upto.simps integrity_def is_aligned_mask [symmetric] word_size_bits_def word_bits_def + intro!: trm_lrefl ptr_range_memI ptr_range_add_memI) + +(* TODO: proof has mainly been copied from dmo_clearMemory_respects *) +lemma dmo_freeMemory_respects[Retype_AC_assms]: + "\integrity aag X st and K (is_aligned ptr bits \ bits < word_bits \ word_size_bits \ bits \ + (\p \ ptr_range ptr bits. is_subject aag p))\ + do_machine_op (freeMemory ptr bits) + \\_. integrity aag X st\" + unfolding do_machine_op_def freeMemory_def + apply (simp add: split_def) + apply wp + apply clarsimp + apply (erule use_valid) + apply (wpsimp wp: mol_respects mapM_x_wp' storeWord_integrity_autarch) + apply (clarsimp simp: word_size_def word_size_bits_def word_bits_def + upto_enum_step_shift_red[where us=3, simplified]) + apply (erule bspec) + apply (erule set_mp [rotated]) + apply (rule ptr_range_subset) + apply simp + apply (simp add: is_aligned_mult_triv2 [where n = 3, simplified]) + apply assumption + apply (erule word_less_power_trans_ofnat [where k = 3, simplified]) + apply assumption + apply simp + apply simp + done + +lemma storeWord_respects: + "\\ms. integrity aag X st (s\machine_state := ms\) \ + (\p' \ ptr_range p word_size_bits. aag_has_auth_to aag Write p')\ + storeWord p v + \\_ ms. integrity aag X st (s\machine_state := ms\)\" + unfolding storeWord_def word_size_bits_def + apply wp + by (auto simp: upto.simps integrity_def is_aligned_mask [symmetric] word_bits_def + intro!: trm_write ptr_range_memI ptr_range_add_memI) + +lemma dmo_clearMemory_respects'[Retype_AC_assms]: + "\integrity aag X st and + K (is_aligned ptr bits \ bits < word_bits \ word_size_bits \ bits \ + (\p \ ptr_range ptr bits. aag_has_auth_to aag Write p))\ + do_machine_op (clearMemory ptr (2 ^ bits)) + \\_. integrity aag X st\" + unfolding do_machine_op_def clearMemory_def + apply (simp add: split_def ) + apply wp + apply clarsimp + apply (erule use_valid) + apply (wp mol_respects mapM_x_wp' storeWord_respects)+ + apply (simp add: word_size_bits_def) + apply (clarsimp simp: word_size_def word_bits_def upto_enum_step_shift_red[where us=3, simplified]) + apply (erule bspec) + apply (erule set_mp [rotated]) + apply (rule ptr_range_subset) + apply simp + apply (simp add: is_aligned_mult_triv2 [where n = 3, simplified]) + apply assumption + apply (erule word_less_power_trans_ofnat [where k = 3, simplified]) + apply assumption + apply simp + apply simp + done + +lemma integrity_asids_detype[Retype_AC_assms]: + assumes refs: "\r\refs. pasObjectAbs aag r \ subjects" + shows + "integrity_asids aag subjects x a (detype refs s) s' = + integrity_asids aag subjects x a s s'" + "integrity_asids aag subjects x a s (detype refs s') = + integrity_asids aag subjects x a s s'" + by (auto simp: detype_def refs opt_map_def) + +lemma retype_region_integrity_asids[Retype_AC_assms]: + "\ range_cover ptr sz (obj_bits_api typ o_bits) n; typ \ Untyped; + \x\up_aligned_area ptr sz. is_subject aag x; integrity_asids aag {pasSubject aag} x a s st \ + \ integrity_asids aag {pasSubject aag} x a s + (st\kheap := \a. if a \ (\x. ptr_add ptr (x * 2 ^ obj_bits_api typ o_bits)) ` {0 ..< n} + then Some (default_object typ dev o_bits) + else kheap s a\)" + apply (clarsimp simp: opt_map_def) + apply (case_tac "x \ up_aligned_area ptr sz"; clarsimp) + apply (fastforce intro: tro_lrefl tre_lrefl + dest: retype_addrs_subset_ptr_bits[simplified retype_addrs_def] + simp: image_def p_assoc_help power_sub) + done + +end + + +global_interpretation Retype_AC_1?: Retype_AC_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Retype_AC_assms | wpsimp wp: init_arch_objects_inv)?) +qed + +requalify_facts RISCV64.storeWord_respects + +end diff --git a/proof/access-control/AARCH64/ArchSyscall_AC.thy b/proof/access-control/AARCH64/ArchSyscall_AC.thy new file mode 100644 index 0000000000..e9c7f0ee17 --- /dev/null +++ b/proof/access-control/AARCH64/ArchSyscall_AC.thy @@ -0,0 +1,174 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchSyscall_AC +imports Syscall_AC +begin + +context Arch begin global_naming RISCV64 + +named_theorems Syscall_AC_assms + +crunch set_original + for idle_thread[wp]: "\s. P (idle_thread s)" + and cur_thread[wp]: "\s. P (cur_thread s)" + +crunch prepare_thread_delete + for idle_thread[Syscall_AC_assms, wp]: "\s. P (idle_thread s)" + +lemma cap_move_idle_thread[Syscall_AC_assms, wp]: + "cap_move new_cap src_slot dest_slot \\s. P (idle_thread s)\" + unfolding cap_move_def + by (wpsimp wp: dxo_wp_weak) + +lemma cancel_badged_sends_idle_thread[Syscall_AC_assms, wp]: + "cancel_badged_sends epptr badge \\s. P (idle_thread s)\" + unfolding cancel_badged_sends_def + by (wpsimp wp: dxo_wp_weak mapM_wp_inv get_simple_ko_wp simp: filterM_mapM) + +declare arch_finalise_cap_idle_thread[Syscall_AC_assms] + +lemma invs_irq_state_update[Syscall_AC_assms, simp]: + "invs (s\machine_state := irq_state_update f sa\) = invs (s\machine_state := sa\)" + apply (rule iffI) + apply (subst invs_irq_state_independent[symmetric]) + apply (subst RISCV64.fold_congs(2); fastforce) + apply (subst (asm) invs_irq_state_independent[symmetric]) + apply (subst RISCV64.fold_congs(2); fastforce) + done + +crunch prepare_thread_delete, arch_finalise_cap + for cur_thread[Syscall_AC_assms, wp]: "\s. P (cur_thread s)" + (wp: crunch_wps simp: crunch_simps) + +lemma cap_move_cur_thread[Syscall_AC_assms, wp]: + "cap_move new_cap src_slot dest_slot \\s. P (cur_thread s)\" + unfolding cap_move_def + by (wpsimp wp: dxo_wp_weak) + +lemma cancel_badged_sends_cur_thread[Syscall_AC_assms, wp]: + "cancel_badged_sends epptr badge \\s. P (cur_thread s)\" + unfolding cancel_badged_sends_def + by (wpsimp wp: dxo_wp_weak filterM_preserved crunch_wps) + +crunch arch_mask_irq_signal, handle_reserved_irq + for pas_refined[Syscall_AC_assms, wp]: "pas_refined aag" + +crunch handle_hypervisor_fault + for pas_refined[Syscall_AC_assms, wp]: "pas_refined aag" + and cur_thread[Syscall_AC_assms, wp]: "\s. P (cur_thread s)" + and integrity[Syscall_AC_assms, wp]: "integrity aag X st" + +crunch handle_vm_fault + for pas_refined[Syscall_AC_assms, wp]: "pas_refined aag" + and cur_thread[Syscall_AC_assms, wp]: "\s. P (cur_thread s)" + and state_refs_of[Syscall_AC_assms, wp]: "\s. P (state_refs_of s)" + +lemma handle_vm_fault_integrity[Syscall_AC_assms]: + "\integrity aag X st and K (is_subject aag thread)\ + handle_vm_fault thread vmfault_type + \\rv. integrity aag X st\" + unfolding handle_vm_fault_def + by (cases vmfault_type; wpsimp wp: as_user_integrity_autarch dmo_wp) + +crunch ackInterrupt, resetTimer + for underlying_memory_inv[Syscall_AC_assms, wp]: "\s. P (underlying_memory s)" + (simp: maskInterrupt_def) + +crunch arch_mask_irq_signal, handle_reserved_irq + for integrity[Syscall_AC_assms, wp]: "integrity aag X st" + (wp: dmo_no_mem_respects) + +lemma set_thread_state_restart_to_running_respects[Syscall_AC_assms]: + "\integrity aag X st and st_tcb_at ((=) Restart) thread and K (pasMayActivate aag)\ + do pc \ as_user thread getRestartPC; + as_user thread $ setNextPC pc; + set_thread_state thread Structures_A.thread_state.Running + od + \\_. integrity aag X st\" + apply (simp add: set_thread_state_def as_user_def split_def setNextPC_def + getRestartPC_def setRegister_def bind_assoc getRegister_def) + apply (wpsimp wp: set_object_wp) + apply (clarsimp simp: in_monad fun_upd_def[symmetric] cong: if_cong) + apply (cases "is_subject aag thread") + apply (cut_tac aag=aag in integrity_update_autarch, simp+) + apply (erule integrity_trans) + apply (clarsimp simp: integrity_def obj_at_def st_tcb_at_def integrity_asids_kh_upds opt_map_def) + apply (clarsimp dest!: get_tcb_SomeD) + apply (rule_tac tro_tcb_activate[OF refl refl]) + apply (simp add: tcb_bound_notification_reset_integrity_def ctxt_IP_update_def + split: user_context.splits)+ + done + +lemma getActiveIRQ_inv[Syscall_AC_assms]: + "\f s. P s \ P (irq_state_update f s) + \ \P\ getActiveIRQ irq \\rv. P\" + by (wpsimp simp: irq_state_independent_def) + +lemma getActiveIRQ_rv_None[Syscall_AC_assms]: + "\\\ getActiveIRQ True \\rv ms. (rv \ None \ the rv \ non_kernel_IRQs)\" + by (wpsimp simp: getActiveIRQ_def) + +lemma arch_activate_idle_thread_respects[Syscall_AC_assms, wp]: + "arch_activate_idle_thread t \integrity aag X st\" + unfolding arch_activate_idle_thread_def by wpsimp + +lemma arch_activate_idle_thread_pas_refined[Syscall_AC_assms, wp]: + "arch_activate_idle_thread t \pas_refined aag\" + unfolding arch_activate_idle_thread_def by wpsimp + +lemma arch_switch_to_thread_respects[Syscall_AC_assms, wp]: + "arch_switch_to_thread t \integrity aag X st\" + unfolding arch_switch_to_thread_def by wpsimp + +lemma arch_switch_to_thread_pas_refined[Syscall_AC_assms, wp]: + "arch_switch_to_thread t \pas_refined aag\" + unfolding arch_switch_to_thread_def by wpsimp + +lemma arch_switch_to_idle_thread_respects[Syscall_AC_assms, wp]: + "arch_switch_to_idle_thread \integrity aag X st\" + unfolding arch_switch_to_idle_thread_def by wpsimp + +lemma arch_switch_to_idle_thread_pas_refined[Syscall_AC_assms, wp]: + "arch_switch_to_idle_thread \pas_refined aag\" + unfolding arch_switch_to_idle_thread_def by wpsimp + +lemma arch_mask_irq_signal_arch_state[Syscall_AC_assms, wp]: + "arch_mask_irq_signal irq \\s :: det_ext state. P (arch_state s)\" + by wpsimp + +lemma handle_reserved_irq_arch_state[Syscall_AC_assms, wp]: + "handle_reserved_irq irq \\s :: det_ext state. P (arch_state s)\" + unfolding handle_reserved_irq_def by wpsimp + +crunch arch_post_cap_deletion + for ct_active[Syscall_AC_assms, wp]: "ct_active" + (wp: crunch_wps filterM_preserved unless_wp simp: crunch_simps ignore: do_extended_op) + +crunch + arch_post_modify_registers, arch_invoke_irq_control, + arch_invoke_irq_handler, arch_perform_invocation, arch_mask_irq_signal, + handle_reserved_irq, handle_vm_fault, handle_hypervisor_fault, handle_arch_fault_reply + for cur_thread[Syscall_AC_assms, wp]: "\s. P (cur_thread s)" + and idle_thread[Syscall_AC_assms, wp]: "\s. P (idle_thread s)" + and cur_domain[Syscall_AC_assms, wp]: "\s. P (cur_domain s)" + (wp: crunch_wps simp: crunch_simps) + +\ \These aren't proved in the previous crunch, and hence need to be declared\ +declare handle_arch_fault_reply_cur_thread[Syscall_AC_assms] +declare handle_arch_fault_reply_it[Syscall_AC_assms] + +end + + +global_interpretation Syscall_AC_1?: Syscall_AC_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Syscall_AC_assms | wp init_arch_objects_inv)) +qed + +end diff --git a/proof/access-control/AARCH64/ArchTcb_AC.thy b/proof/access-control/AARCH64/ArchTcb_AC.thy new file mode 100644 index 0000000000..800f889a7e --- /dev/null +++ b/proof/access-control/AARCH64/ArchTcb_AC.thy @@ -0,0 +1,110 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchTcb_AC +imports Tcb_AC +begin + +context Arch begin global_naming RISCV64 + +named_theorems Tcb_AC_assms + +declare arch_get_sanitise_register_info_inv[Tcb_AC_assms] + +crunch arch_post_modify_registers + for pas_refined[Tcb_AC_assms, wp]: "pas_refined aag" + +lemma arch_post_modify_registers_respects[Tcb_AC_assms]: + "\integrity aag X st and K (is_subject aag t)\ + arch_post_modify_registers cur t + \\_ s. integrity aag X st s\" + by wpsimp + +lemma invoke_tcb_tc_respects_aag[Tcb_AC_assms]: + "\integrity aag X st and pas_refined aag and einvs and simple_sched_action + and tcb_inv_wf (ThreadControl t sl ep mcp priority croot vroot buf) + and K (authorised_tcb_inv aag (ThreadControl t sl ep mcp priority croot vroot buf))\ + invoke_tcb (ThreadControl t sl ep mcp priority croot vroot buf) + \\_. integrity aag X st and pas_refined aag\" + apply (rule hoare_gen_asm)+ + apply (subst invoke_tcb.simps) + apply (subst option_update_thread_def) + apply (subst set_priority_extended.dxo_eq) + apply (rule hoare_weaken_pre) + apply (rule_tac P="case ep of Some v \ length v = word_bits | _ \ True" + in hoare_gen_asm) + apply (simp only: split_def) + apply (((simp add: conj_comms, + strengthen imp_consequent[where Q="x = None" for x], simp cong: conj_cong) + | strengthen invs_psp_aligned invs_vspace_objs invs_arch_state + | 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 restart_integrity_autarch set_mcpriority_integrity_autarch + as_user_integrity_autarch thread_set_integrity_autarch + option_update_thread_integrity_autarch + opt_update_thread_valid_sched hoare_weak_lift_imp + cap_insert_integrity_autarch checked_insert_pas_refined + cap_delete_respects' cap_delete_pas_refined' + check_cap_inv2[where Q="\_. integrity aag X st"] + as_user_pas_refined restart_pas_refined + thread_set_pas_refined + 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] + check_cap_inv[where P="simple_sched_action"] + check_cap_inv[where P="valid_list"] + check_cap_inv[where P="valid_sched"] + check_cap_inv[where P="valid_arch_state"] + check_cap_inv[where P="valid_vspace_objs"] + check_cap_inv[where P="pspace_aligned"] + thread_set_not_state_valid_sched + thread_set_cte_at + thread_set_cte_wp_at_trivial[where Q="\x. x", OF ball_tcb_cap_casesI] + thread_set_no_cap_to_trivial[OF ball_tcb_cap_casesI] + checked_insert_no_cap_to + out_no_cap_to_trivial[OF ball_tcb_cap_casesI] + thread_set_ipc_tcb_cap_valid + cap_delete_pas_refined'[THEN valid_validE_E] thread_set_cte_wp_at_trivial + | simp add: ran_tcb_cap_cases dom_tcb_cap_cases[simplified] + emptyable_def a_type_def partial_inv_def + | wpc + | strengthen invs_mdb use_no_cap_to_obj_asid_strg + tcb_cap_always_valid_strg[where p="tcb_cnode_index 0"] + tcb_cap_always_valid_strg[where p="tcb_cnode_index (Suc 0)"]))+ + apply (clarsimp simp: authorised_tcb_inv_def) + apply (clarsimp simp: tcb_at_cte_at_0 tcb_at_cte_at_1[simplified] + is_cap_simps is_valid_vtable_root_def + 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 + emptyable_def + | rule conjI | erule pas_refined_refl)+ + apply (thin_tac "case_option _ _ _")+ + apply (fastforce split: cap.split_asm option.split_asm) + apply (thin_tac "case_option _ _ _")+ + apply (fastforce split: cap.split_asm option.split_asm) + done + +end + + +global_interpretation Tcb_AC_1?: Tcb_AC_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; fact Tcb_AC_assms) +qed + +end diff --git a/proof/access-control/AARCH64/ArchTypes.thy b/proof/access-control/AARCH64/ArchTypes.thy new file mode 100644 index 0000000000..3c988dc77a --- /dev/null +++ b/proof/access-control/AARCH64/ArchTypes.thy @@ -0,0 +1,17 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchTypes +imports Deterministic_AC +begin + +section \Policy and policy refinement\ + +subsection \Arch-specific definitions\ + +datatype arch_auth = ASIDPoolMapsASID + +end diff --git a/proof/access-control/AARCH64/ExampleSystem.thy b/proof/access-control/AARCH64/ExampleSystem.thy new file mode 100644 index 0000000000..2f1980177f --- /dev/null +++ b/proof/access-control/AARCH64/ExampleSystem.thy @@ -0,0 +1,1103 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ExampleSystem +imports ArchAccess_AC +begin + +context begin interpretation Arch . (*FIXME: arch-split*) + +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)" + apply (clarsimp simp: nat_to_bl_def to_bl_def) + apply (auto simp: le_def word_size) + done + + +(*---------------------------------------------------------*) + +subsection \Purpose\ + +text \ + +This file defines some example systems using the access control +definitions. The aim is a sanity check of the AC definitions, to +ensure they enable to reason about reasonable systems. + +In particular, we want to make sure that + + . the function state_objs_to_policy does not connect everything to + everything (Example 1) + . we can talk about components sharing cnodes + . we can talk about components sharing frames + . we can have more than 1 untrusted component + . we can have an EP between two untrusted components + +\ + +(*---------------------------------------------------------*) + +subsection \Generic functions / lemmas\ + + +text \Defining the authority between labels. + +In addition to the intuitive authority we want, we need to add all the +authority required to have a wellformed graph. So we define +complete_AgentAuthGraph to add these 'extra' authorities (at least all +the ones not depending on the current label). These are: + + . self-authority (each label needs all the authorities to itself). + . if Control edge is present between 2 labels then we add all + authorities between them. + . Control authority is transitive: we add an Control edge + between 2 labels if we can connect them via Control + edges. Actually we add all authorities because of the second + clause. + +\ + + +definition + complete_AuthGraph :: "'a auth_graph \ 'a set \ 'a auth_graph" +where + "complete_AuthGraph g ls \ + g \ {(l,a,l) | a l. l \ ls}" + +text \converting a nat to a bool list of size 10 - for the cnodes\ + +definition + the_nat_to_bl :: "nat \ nat \ bool list" +where + "the_nat_to_bl sz n \ the (nat_to_bl sz n)" + +definition + the_nat_to_bl_10 :: "nat \ bool list" +where + "the_nat_to_bl_10 n \ the_nat_to_bl 10 n" + +lemma tcb_cnode_index_nat_to_bl: + "n<10 \ the_nat_to_bl_10 n \ tcb_cnode_index n" + by (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def + tcb_cnode_index_def + nat_to_bl_def to_bl_def bin_to_bl_aux_def) + + +(*---------------------------------------------------------*) +subsection \Example 1\ + +text \ + +This example aims at checking that we can extract a reasonable policy +from the state, i.e. that the function state_objs_to_policy does not connect +everything to everything. + +This example is a system Sys1 made of 2 main components UT1 and T1, +connected through and endpoint EP1. EP1 is made of one single kernel +object: obj1_0x9, the endpoint. Both UT1 and T1 contains: + + . one TCB (obj1_0xC07 and obj1_0xC08 resp.) + . one vspace made up of one top-level page table (obj1_BF7 and obj1_0xBF9 resp.) + . each top-level pt contains a single page table (obj1_0xC00000 and obj1_0xC05000 resp.) + . one cspace made up of one cnode (obj1_0x6 and obj1_0x7 resp.) + . each cspace contains 4 caps: + one to the tcb + one to the cnode itself + one to the vspace + one to the ep + +UT1 can send to the ep while T1 can receive from it. + +Attempt to ASCII art: + + + -------- ---- ---- -------- + | | | | | | | | + V | | V S R | V | V +obj1_0xC07(tcb)-->obj1_0x6(cnode)--->obj1_0x9(ep)<---obj1_0x7(cnode)<--obj1_0xC08(tcb) + | | | | + V | | V +obj1_0xBF7(pt)<----- -------> obj1_0xBF9(pt) + | | + V V +obj1_0xC00000(pt) obj1_0xC05000(pt) + + +(the references are derived from the dump of the SAC system) + + +The aim is to be able to prove + + pas_refined Sys1PAS s1 + +where Sys1PAS is the label graph defining the AC policy for Sys1 and +s1 is the state of Sys1 described above. + +This shows that the aag extracted from s1 (by state_objs_to_policy) is +included in the policy graph Sys1PAS. + +\ + + +subsubsection \Defining the State\ + +text \We need to define the asids of each pt to ensure that +the object is included in the right ASID-label\ + +text \UT1's ASID\ + +definition + asid1_0xBF7 :: asid +where + "asid1_0xBF7 \ 1<T1's ASID\ + +definition + asid1_0xBF9 :: asid +where + "asid1_0xBF9 \ 2< asid_high_bits_of asid1_0xBF7" +by (simp add: asid1_0xBF7_def asid_high_bits_of_def asid1_0xBF9_def asid_low_bits_def) + + +text \UT1's CSpace\ +definition + caps1_0x6 :: cnode_contents +where + "caps1_0x6 \ + (empty_cnode 10) + ( (the_nat_to_bl_10 1) + \ ThreadCap 0xC07, + (the_nat_to_bl_10 2) + \ CNodeCap 6 undefined undefined, + (the_nat_to_bl_10 3) + \ ArchObjectCap (PageTableCap 0xBF7 (Some (asid1_0xBF7,0))), + (the_nat_to_bl_10 318) + \ EndpointCap 9 0 {AllowSend} )" + + +definition + obj1_0x6 :: kernel_object +where + "obj1_0x6 \ CNode 10 caps1_0x6" + +text \T1's Cspace\ + +definition + caps1_0x7 :: cnode_contents +where + "caps1_0x7 \ + (empty_cnode 10) + ( (the_nat_to_bl_10 1) + \ ThreadCap 0xC08, + (the_nat_to_bl_10 2) + \ CNodeCap 7 undefined undefined, + (the_nat_to_bl_10 3) + \ ArchObjectCap (PageTableCap 0xBF9 (Some (asid1_0xBF9,0))), + (the_nat_to_bl_10 318) + \ EndpointCap 9 0 {AllowRecv}) " + +definition + obj1_0x7 :: kernel_object +where + "obj1_0x7 \ CNode 10 caps1_0x7" + + +text \endpoint between UT1 and T1\ + +definition + obj1_0x9 :: kernel_object +where + "obj1_0x9 \ Endpoint IdleEP" + + +text \UT1's VSpace\ + +definition + pt1_0xC00000 :: pt +where + "pt1_0xC00000 \ (\_. InvalidPTE)" + +definition + obj1_0xC00000 :: kernel_object +where + "obj1_0xC00000 \ ArchObj (PageTable pt1_0xC00000)" + +definition + pt1_0xBF7 :: pt +where + "pt1_0xBF7 \ + (\_. InvalidPTE) + (0 := PageTablePTE + (ucast (addrFromPPtr 0xC00000 >> pageBits)) + undefined )" + +(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check +if it's right *) + +definition + obj1_0xBF7 :: kernel_object +where + "obj1_0xBF7 \ ArchObj (PageTable pt1_0xBF7)" + + +text \T1's VSpace\ + + +definition + pt1_0xC05000 :: pt +where + "pt1_0xC05000 \ + (\_. InvalidPTE)" + + +definition + obj1_0xC05000 :: kernel_object +where + "obj1_0xC05000 \ ArchObj (PageTable pt1_0xC05000)" + + +definition + pt1_0xBF9 :: pt +where + "pt1_0xBF9 \ + (\_. InvalidPTE) + (0 := PageTablePTE + (ucast (addrFromPPtr 0xC05000 >> pageBits)) + undefined )" + +(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check +if it's right *) + +definition + obj1_0xBF9 :: kernel_object +where + "obj1_0xBF9 \ ArchObj (PageTable pt1_0xBF9)" + + +text \UT1's tcb\ + +definition + obj1_0xC07 :: kernel_object +where + "obj1_0xC07 \ + TCB \ + tcb_ctable = CNodeCap 6 undefined undefined, + tcb_vtable = ArchObjectCap (PageTableCap 0xBF7 (Some (asid1_0xBF7, 0))), + tcb_reply = ReplyCap 0xC07 True {AllowGrant,AllowWrite}, \ \master reply cap to itself\ + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = Running, + tcb_fault_handler = undefined, + tcb_ipc_buffer = undefined, + tcb_fault = undefined, + tcb_bound_notification = None, + tcb_mcpriority = undefined, + tcb_arch = \tcb_context = undefined\ \" + + +text \T1's tcb\ + +definition + obj1_0xC08 :: kernel_object +where + "obj1_0xC08 \ + TCB \ + tcb_ctable = CNodeCap 7 undefined undefined, + tcb_vtable = ArchObjectCap (PageTableCap 0xBF9 (Some (asid1_0xBF9, 0))), + tcb_reply = ReplyCap 0xC08 True {AllowGrant,AllowWrite}, \ \master reply cap to itself\ + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = BlockedOnReceive 9 \ receiver_can_grant = False \, + tcb_fault_handler = undefined, + tcb_ipc_buffer = undefined, + tcb_fault = undefined, + tcb_bound_notification = None, + tcb_mcpriority = undefined, + tcb_arch = \tcb_context = undefined\\" + +definition + "obj1_10 \ CNode 10 (Map.empty([] \ cap.NullCap))" + + +(* the boolean in BlockedOnReceive is True if the object can receive but not send. +but Tom says it only matters if the sender can grant - which is not the case of the UT1 - I think *) + +definition + kh1 :: kheap +where + "kh1 \ [0x6 \ obj1_0x6, + 0x7 \ obj1_0x7, + 0x9 \ obj1_0x9, + 0xA \ obj1_10, + 0xBF7 \ obj1_0xBF7, + 0xBF9 \ obj1_0xBF9, + 0xC07 \ obj1_0xC07, + 0xC08 \ obj1_0xC08, + 0xC00000 \ obj1_0xC00000, + 0xC05000 \ obj1_0xC05000]" + +lemmas kh1_obj_def = + obj1_0x6_def obj1_0x7_def obj1_0x9_def obj1_10_def obj1_0xBF7_def obj1_0xBF9_def + obj1_0xC00000_def obj1_0xC05000_def obj1_0xC07_def obj1_0xC08_def + +definition exst1 :: "det_ext" where + "exst1 \ \work_units_completed_internal = undefined, + scheduler_action_internal = undefined, + ekheap_internal = \x. None, + domain_list_internal = undefined, + domain_index_internal = undefined, + cur_domain_internal = undefined, + domain_time_internal = undefined, + ready_queues_internal = undefined, + cdt_list_internal = undefined\" + +definition + s1 :: "det_ext state" +where + "s1 \ \ + kheap = kh1, + cdt = Map.empty, + is_original_cap = undefined, + cur_thread = undefined, + idle_thread = undefined, + machine_state = undefined, + interrupt_irq_node = (\_. 10), + interrupt_states = undefined, + arch_state = \ + riscv_asid_table = (\_. None), + riscv_global_pts = undefined, + riscv_kernel_vspace = undefined + \, + exst = exst1 + \" + + +subsubsection \Defining the policy graph\ + + +datatype Sys1Labels = + UT1 | T1 | EP1 | IRQ1 + +definition + Sys1AgentMap :: "Sys1Labels agent_map" +where + "Sys1AgentMap \ + (\_. undefined) + (0x6 := UT1, + 0x7 := T1, + 0x9 := EP1, + 0xA := IRQ1, + 0xBF7 := UT1, + 0xBF9 := T1, + 0xC00000 := UT1, + 0xC05000 := T1, + 0xC07 := UT1, + 0xC08 := T1 )" + +lemma Sys1AgentMap_simps: + "Sys1AgentMap 0x6 = UT1" + "Sys1AgentMap 0x7 = T1" + "Sys1AgentMap 0x9 = EP1" + "Sys1AgentMap 0xA = IRQ1" + "Sys1AgentMap 0xBF7 = UT1" + "Sys1AgentMap 0xBF9 = T1" + "Sys1AgentMap 0xC00000 = UT1" + "Sys1AgentMap 0xC05000 = T1" + "Sys1AgentMap 0xC07 = UT1" + "Sys1AgentMap 0xC08 = T1" + unfolding Sys1AgentMap_def by simp_all + +definition + Sys1AuthGraph_aux :: "Sys1Labels auth_graph" +where + "Sys1AuthGraph_aux \ + { (UT1, auth.SyncSend, EP1), + (UT1, auth.Reset, EP1), + (T1, auth.Receive, EP1), + (T1, auth.Reset, EP1) }" + +definition + Sys1AuthGraph:: "Sys1Labels auth_graph" +where + "Sys1AuthGraph \ complete_AuthGraph Sys1AuthGraph_aux {T1, UT1}" + + +definition + Sys1ASIDMap :: "Sys1Labels agent_asid_map" +where + "Sys1ASIDMap \ + (\x. if (asid_high_bits_of x = asid_high_bits_of asid1_0xBF7) + then UT1 + else if (asid_high_bits_of x = asid_high_bits_of asid1_0xBF9) + then T1 else undefined)" + +definition Sys1PAS :: "Sys1Labels PAS" where + "Sys1PAS \ \ pasObjectAbs = Sys1AgentMap, pasASIDAbs = Sys1ASIDMap, pasIRQAbs = (\_. IRQ1), + pasPolicy = Sys1AuthGraph, pasSubject = UT1, pasMayActivate = True, + pasMayEditReadyQueues = True, pasMaySendIrqs = True, pasDomainAbs = undefined \" + +subsubsection \Proof of pas_refined for Sys1\ + +lemma caps1_0x7_well_formed: "well_formed_cnode_n 10 caps1_0x7" + apply (clarsimp simp: caps1_0x7_def well_formed_cnode_n_def) + apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def) + apply (clarsimp simp: empty_cnode_def dom_def) + apply (rule set_eqI, clarsimp) + apply (rule iffI) + apply (elim disjE, insert len_bin_to_bl, simp_all)[1] + apply clarsimp + done + +lemma caps1_0x6_well_formed: "well_formed_cnode_n 10 caps1_0x6" + apply (clarsimp simp: caps1_0x6_def well_formed_cnode_n_def) + apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def) + apply (clarsimp simp: empty_cnode_def dom_def) + apply (rule set_eqI, clarsimp) + apply (rule iffI) + apply (elim disjE, insert len_bin_to_bl, simp_all)[1] + apply clarsimp + done + +(* clagged from KernelInit_R *) +lemma empty_cnode_apply[simp]: + "(empty_cnode n xs = Some cap) = (length xs = n \ cap = NullCap)" + by (auto simp add: empty_cnode_def) + + +lemma s1_caps_of_state : + "caps_of_state s1 p = Some cap \ + cap = NullCap \ + (p,cap) \ + { ((6::obj_ref,(the_nat_to_bl_10 1)), ThreadCap 0xC07), + ((6::obj_ref,(the_nat_to_bl_10 2)), CNodeCap 6 undefined undefined), + ((6::obj_ref,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap 0xBF7 (Some (asid1_0xBF7, 0)))), + ((6::obj_ref,(the_nat_to_bl_10 318)),EndpointCap 9 0 {AllowSend}), + ((7::obj_ref,(the_nat_to_bl_10 1)), ThreadCap 0xC08), + ((7::obj_ref,(the_nat_to_bl_10 2)), CNodeCap 7 undefined undefined), + ((7::obj_ref,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap 0xBF9 (Some (asid1_0xBF9, 0)))), + ((7::obj_ref,(the_nat_to_bl_10 318)),EndpointCap 9 0 {AllowRecv}) , + ((0xC07::obj_ref, (tcb_cnode_index 0)), CNodeCap 6 undefined undefined ), + ((0xC07::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageTableCap 0xBF7 (Some (asid1_0xBF7, 0)))), + ((0xC07::obj_ref, (tcb_cnode_index 2)), ReplyCap 0xC07 True {AllowGrant,AllowWrite}), + ((0xC07::obj_ref, (tcb_cnode_index 3)), NullCap), + ((0xC07::obj_ref, (tcb_cnode_index 4)), NullCap), + ((0xC08::obj_ref, (tcb_cnode_index 0)), CNodeCap 7 undefined undefined ), + ((0xC08::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageTableCap 0xBF9 (Some (asid1_0xBF9, 0)))), + ((0xC08::obj_ref, (tcb_cnode_index 2)), ReplyCap 0xC08 True {AllowGrant,AllowWrite}), + ((0xC08::obj_ref, (tcb_cnode_index 3)), NullCap), + ((0xC08::obj_ref, (tcb_cnode_index 4)), NullCap)} " + apply (insert caps1_0x7_well_formed) + apply (insert caps1_0x6_well_formed) + apply (simp add: caps_of_state_cte_wp_at cte_wp_at_cases s1_def kh1_def kh1_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: caps1_0x7_def split: if_splits) + apply (clarsimp simp: caps1_0x6_def cte_wp_at_cases split: if_splits) + done + + +lemma Sys1_wellformed: "pas_wellformed Sys1PAS" + apply (clarsimp simp: Sys1PAS_def + policy_wellformed_def + Sys1AuthGraph_def + Sys1AuthGraph_aux_def + complete_AuthGraph_def) + apply blast + done + +lemma tcb_states_of_state_1: + "tcb_states_of_state s1 = [0xC08 \ thread_state.BlockedOnReceive 9 \ receiver_can_grant = False \, 0xC07 \ thread_state.Running ]" + unfolding s1_def tcb_states_of_state_def + apply (rule ext) + apply (simp add: get_tcb_def) + apply (simp add: kh1_def kh1_obj_def ) + done + +lemma thread_bound_ntfns_1: + "thread_bound_ntfns s1 = Map.empty" + unfolding s1_def thread_bound_ntfns_def + apply (rule ext) + apply (simp add: get_tcb_def) + apply (simp add: kh1_def kh1_obj_def ) + done + +declare AllowSend_def[simp] AllowRecv_def[simp] + +lemma domains_of_state_s1[simp]: + "domains_of_state s1 = {}" + apply (rule equalityI) + apply (rule subsetI) + apply clarsimp + apply (erule domains_of_state_aux.induct) + apply (simp add: s1_def exst1_def) + apply simp + done + +lemma vs_refs_aux_empty_pt[simp]: + "vs_refs_aux lvl (PageTable empty_pt) = {}" + by (clarsimp simp: vs_refs_aux_def graph_of_def pte_ref2_def) + +lemma is_aligned_0xC00000[simp]: + "ptrFromPAddr (addr_from_ppn (UCAST(64 \ 52) (addrFromPPtr 0xC00000 >> pageBits))) = 0xC00000" + by (subst ptrFromPAddr_addr_from_ppn; fastforce simp: bit_simps is_aligned_mask mask_def) + +lemma is_aligned_0xC05000[simp]: + "ptrFromPAddr (addr_from_ppn (UCAST(64 \ 52) (addrFromPPtr 0xC05000 >> pageBits))) = 0xC05000" + by (subst ptrFromPAddr_addr_from_ppn; fastforce simp: bit_simps is_aligned_mask mask_def) + +lemma "pas_refined Sys1PAS s1" + apply (clarsimp simp: pas_refined_def) + apply (intro conjI) + subgoal by (simp add: Sys1_wellformed) + subgoal by (simp add: irq_map_wellformed_aux_def s1_def Sys1AgentMap_simps Sys1PAS_def) + subgoal by (simp add: tcb_domain_map_wellformed_aux_def) + apply (clarsimp simp: auth_graph_map_def Sys1PAS_def state_objs_to_policy_def)+ + apply (erule state_bits_to_policy.cases, simp_all, clarsimp) + apply (drule s1_caps_of_state, clarsimp) + apply (simp add: Sys1AuthGraph_def complete_AuthGraph_def Sys1AuthGraph_aux_def) + apply (elim disjE conjE; solves\clarsimp simp: Sys1AgentMap_simps cap_auth_conferred_def cap_rights_to_auth_def\) + apply (drule s1_caps_of_state, clarsimp) + apply (elim disjE; solves \simp add: thread_bound_ntfns_def\) + apply (clarsimp simp: state_refs_of_def thread_st_auth_def tcb_states_of_state_1 + Sys1AuthGraph_def Sys1AgentMap_simps + complete_AuthGraph_def + Sys1AuthGraph_aux_def + split: if_splits) + apply (simp add: thread_bound_ntfns_1) + apply (simp add: s1_def) (* this is OK because cdt is empty..*) + apply (simp add: s1_def) (* this is OK because cdt is empty..*) + apply (fastforce simp: state_vrefs_def vs_refs_aux_def s1_def kh1_def kh1_obj_def + pt1_0xC00000_def pt1_0xC05000_def pt1_0xBF9_def pt1_0xBF7_def + Sys1AuthGraph_def Sys1AuthGraph_aux_def Sys1AgentMap_simps + complete_AuthGraph_def ptr_range_def pte_ref2_def opt_map_def + dest!: graph_ofD split: if_splits) + apply (rule subsetI, clarsimp) + apply (erule state_asids_to_policy_aux.cases) + apply (drule s1_caps_of_state, clarsimp) + apply (fastforce simp: Sys1AgentMap_simps Sys1PAS_def Sys1ASIDMap_def Sys1AuthGraph_def + Sys1AuthGraph_aux_def complete_AuthGraph_def cap_auth_conferred_def + asid1_0xBF9_def asid1_0xBF7_def asid_low_bits_def asid_high_bits_of_def) + apply (fastforce simp: state_vrefs_def vs_refs_aux_def s1_def kh1_def kh1_obj_def + pt1_0xC00000_def pt1_0xC05000_def pt1_0xBF9_def pt1_0xBF7_def + Sys1AuthGraph_def Sys1AuthGraph_aux_def Sys1AgentMap_simps + complete_AuthGraph_def ptr_range_def pte_ref2_def opt_map_def + dest!: graph_ofD split: if_splits) + apply (clarsimp simp: s1_def) + apply (rule subsetI, clarsimp) + apply (erule state_irqs_to_policy_aux.cases) + apply (simp add: Sys1AuthGraph_def complete_AuthGraph_def Sys1AuthGraph_aux_def Sys1PAS_def Sys1ASIDMap_def) + apply (drule s1_caps_of_state) + apply (fastforce simp: Sys1AgentMap_simps Sys1PAS_def Sys1ASIDMap_def Sys1AuthGraph_def + Sys1AuthGraph_aux_def complete_AuthGraph_def cap_auth_conferred_def + asid1_0xBF9_def asid1_0xBF7_def asid_low_bits_def asid_high_bits_of_def) + done + + +(*---------------------------------------------------------*) +subsection \Example 2\ + +text \ + +This example systems Sys2 aims at checking that we can have 2 +components, one untrusted UT2 and one truted T1, sharing a cnode obj2_5. + +Both UT2 and T2 contains: + + . one TCB (obj2_0xC07 and obj2_0xC08 resp.) + . one vspace made up of one top-level page table (obj2_0xBF7 and obj2_0xBF9 resp.) + . each top-level pt contains a single page table (obj2_0xC00000 and obj2_0xC05000 resp.) + . one cspace made up of one cnode (obj2_0x6 and obj2_0x7 resp.) + . each cspace contains 4 caps: + one to the tcb + one to the cnode itself + one to the vspace + one to obj2_5 + + +Attempt to ASCII art: + + + -------- ---- ---- -------- + | | | | | | | | + V | | V S R | V | V +obj2_0xC07(tcb)-->obj2_0x6(cnode)--->obj2_5(cnode)<---obj2_0x7(cnode)<--obj2_0xC08(tcb) + | | | | + V | | V +obj2_0xBF7(pt)<----- -------> obj2_0xBF9(pt) + | | + V V +obj2_0xC00000(pt) obj2_0xC05000(pt) + + +(the references are derived from the dump of the SAC system) + + +The aim is to be able to prove + + pas_refined Sys2PAS s2 + +where Sys2PAS is the label graph defining the AC policy for Sys2 and +s2 is the state of Sys2 described above. + +This shows that the aag extracted from s2 (by state_objs_to_policy) is +included in the policy graph Sys2PAS. + +\ + + +subsubsection \Defining the State\ + + + +text \We need to define the asids of each pt to ensure that +the object is included in the right ASID-label\ + +text \UT2's ASID\ + +definition + asid2_0xBF7 :: asid +where + "asid2_0xBF7 \ 1<T2's ASID\ + +definition + asid2_0xBF9 :: asid +where + "asid2_0xBF9 \ 2< asid_high_bits_of asid2_0xBF7" +by (simp add: asid2_0xBF7_def asid_high_bits_of_def asid2_0xBF9_def asid_low_bits_def) + + + +text \the intermediaite CSpace\ + +definition + caps2_5 :: cnode_contents +where + "caps2_5 \ + (empty_cnode 10)" + +definition + obj2_5 :: kernel_object +where + "obj2_5 \ CNode 10 caps2_5" + + + +text \UT2's CSpace\ + +definition + caps2_0x6 :: cnode_contents +where + "caps2_0x6 \ + (empty_cnode 10) + ( (the_nat_to_bl_10 1) + \ ThreadCap 0xC07, + (the_nat_to_bl_10 2) + \ CNodeCap 6 undefined undefined, + (the_nat_to_bl_10 3) + \ ArchObjectCap (PageTableCap 0xBF7 + (Some (asid2_0xBF7, 0))), + (the_nat_to_bl_10 4) + \ CNodeCap 5 undefined undefined )" + + +definition + obj2_0x6 :: kernel_object +where + "obj2_0x6 \ CNode 10 caps2_0x6" + +text \T2's Cspace\ + +definition + caps2_0x7 :: cnode_contents +where + "caps2_0x7 \ + (empty_cnode 10) + ( (the_nat_to_bl_10 1) + \ ThreadCap 0xC08, + (the_nat_to_bl_10 2) + \ CNodeCap 7 undefined undefined, + (the_nat_to_bl_10 3) + \ ArchObjectCap (PageTableCap 0xBF9 + (Some (asid2_0xBF9, 0))), + (the_nat_to_bl_10 4) + \ CNodeCap 5 undefined undefined) " + +definition + obj2_0x7 :: kernel_object +where + "obj2_0x7 \ CNode 10 caps2_0x7" + + +text \endpoint between UT2 and T2\ + +definition + obj2_0x9 :: kernel_object +where + "obj2_0x9 \ Endpoint IdleEP" + + +text \UT2's VSpace\ + +definition + pt2_0xC00000 :: pt +where + "pt2_0xC00000 \ (\_. InvalidPTE)" + +definition + obj2_0xC00000 :: kernel_object +where + "obj2_0xC00000 \ ArchObj (PageTable pt2_0xC00000)" + + +definition + pt2_0xBF7 :: pt +where + "pt2_0xBF7 \ + (\_. InvalidPTE) + (0 := PageTablePTE + (ucast (addrFromPPtr 0xC00000 >> pageBits)) + undefined )" + +(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check +if it's right *) + +definition + obj2_0xBF7 :: kernel_object +where + "obj2_0xBF7 \ ArchObj (PageTable pt2_0xBF7)" + + +text \T1's VSpace\ + + +definition + pt2_0xC05000 :: pt +where + "pt2_0xC05000 \ + (\_. InvalidPTE)" + +definition + obj2_0xC05000 :: kernel_object +where + "obj2_0xC05000 \ ArchObj (PageTable pt2_0xC05000)" + + +definition + pt2_0xBF9 :: pt +where + "pt2_0xBF9 \ + (\_. InvalidPTE) + (0 := PageTablePTE + (ucast (addrFromPPtr 0xC05000 >> pageBits)) + undefined )" + +(* used addrFromPPtr because proof gives me ptrFromAddr.. TODO: check +if it's right *) + +definition + obj2_0xBF9 :: kernel_object +where + "obj2_0xBF9 \ ArchObj (PageTable pt2_0xBF9)" + + +text \UT1's tcb\ + +definition + obj2_0xC07 :: kernel_object +where + "obj2_0xC07 \ + TCB \ + tcb_ctable = CNodeCap 6 undefined undefined , + tcb_vtable = ArchObjectCap (PageTableCap 0xBF7 (Some (asid2_0xBF7, 0))), + tcb_reply = ReplyCap 0xC07 True {AllowGrant,AllowWrite}, \ \master reply cap to itself\ + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = Running, + tcb_fault_handler = undefined, + tcb_ipc_buffer = undefined, + tcb_fault = undefined, + tcb_bound_notification = None, + tcb_mcpriority = undefined, + tcb_arch = \tcb_context = undefined\\" + + +text \T1's tcb\ + +definition + obj2_0xC08 :: kernel_object +where + "obj2_0xC08 \ + TCB \ + tcb_ctable = CNodeCap 7 undefined undefined , + tcb_vtable = ArchObjectCap (PageTableCap 0xBF9 (Some (asid2_0xBF9,0))), + tcb_reply = ReplyCap 0xC08 True {AllowGrant,AllowWrite}, \ \master reply cap to itself\ + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = BlockedOnReceive 9 \ receiver_can_grant = False \, + tcb_fault_handler = undefined, + tcb_ipc_buffer = undefined, + tcb_fault = undefined, + tcb_bound_notification = None, + tcb_mcpriority = undefined, + tcb_arch = \tcb_context = undefined\\" + +(* the boolean in BlockedOnReceive is True if the object can receive but not send. +but Tom says it only matters if the sender can grant - which is not the case of the UT1 - I think *) + +definition + kh2 :: kheap +where + "kh2 \ [0x6 \ obj2_0x6, + 0x7 \ obj2_0x7, + 0x9 \ obj2_0x9, + 0xBF7 \ obj2_0xBF7, + 0xBF9 \ obj2_0xBF9, + 0xC00000 \ obj2_0xC00000, + 0xC05000 \ obj2_0xC05000, + 0xC07 \ obj2_0xC07, + 0xC08 \ obj2_0xC08 ]" + +lemmas kh2_obj_def = + obj2_0x6_def obj2_0x7_def obj2_0x9_def obj2_0xBF7_def obj2_0xBF9_def + obj2_0xC00000_def obj2_0xC05000_def obj2_0xC07_def obj2_0xC08_def + + +definition + s2 :: "det_ext state" +where + "s2 \ \ + kheap = kh2, + cdt = Map.empty, + is_original_cap = undefined, + cur_thread = undefined, + idle_thread = undefined, + machine_state = undefined, + interrupt_irq_node = (\_. 9001), + interrupt_states = undefined, + arch_state = \ + riscv_asid_table = (\_. None), + riscv_global_pts = undefined, + riscv_kernel_vspace = undefined + \, + exst = exst1 + \" + + +subsubsection \Defining the policy graph\ + + +datatype Sys2Labels = + UT2 | T2 | IRQ2 + +definition + Sys2AgentMap :: "Sys2Labels agent_map" +where + "Sys2AgentMap \ + (\_. undefined) + (0x5 := UT2, + 0x6 := UT2, + 0x7 := T2, + 0x9 := T2, + 0xBF7 := UT2, + 0xBF9 := T2, + 0xC00000 := UT2, + 0xC05000 := T2, + 0xC07 := UT2, + 0xC08 := T2, + 9001 := IRQ2 )" + + +definition + Sys2AuthGraph_aux :: "Sys2Labels auth_graph" +where + "Sys2AuthGraph_aux \ + { (T2, Control, UT2) }" + +definition + Sys2AuthGraph:: "Sys2Labels auth_graph" +where + "Sys2AuthGraph \ complete_AuthGraph Sys2AuthGraph_aux {T2, UT2}" + + +definition + Sys2ASIDMap :: "Sys2Labels agent_asid_map" +where + "Sys2ASIDMap \ + (\_. undefined) + (asid2_0xBF7 := UT2, + asid2_0xBF9 := T2 )" + +definition Sys2PAS :: "Sys2Labels PAS" where + "Sys2PAS \ \ pasObjectAbs = Sys2AgentMap, pasASIDAbs = Sys2ASIDMap, + pasIRQAbs = (\_. IRQ2), + pasPolicy = Sys2AuthGraph, pasSubject = UT2, pasMayActivate = True, pasMayEditReadyQueues = True, pasMaySendIrqs = True, pasDomainAbs = undefined \" + + + +subsubsection \Proof of pas_refined for Sys2\ + +lemma caps2_0x7_well_formed: "well_formed_cnode_n 10 caps2_0x7" + apply (clarsimp simp: caps2_0x7_def well_formed_cnode_n_def) + apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def) + apply (clarsimp simp: empty_cnode_def dom_def) + apply (rule set_eqI, clarsimp) + apply (rule iffI) + apply (elim disjE, insert len_bin_to_bl, simp_all)[1] + apply clarsimp + done + +lemma caps2_0x6_well_formed: "well_formed_cnode_n 10 caps2_0x6" + apply (clarsimp simp: caps2_0x6_def well_formed_cnode_n_def) + apply (clarsimp simp: the_nat_to_bl_10_def the_nat_to_bl_def nat_to_bl_def) + apply (clarsimp simp: empty_cnode_def dom_def) + apply (rule set_eqI, clarsimp) + apply (rule iffI) + apply (elim disjE, insert len_bin_to_bl, simp_all)[1] + apply clarsimp + done + +lemma s2_caps_of_state : + "caps_of_state s2 p = Some cap \ + cap = NullCap \ + (p,cap) \ + { ((6::obj_ref,(the_nat_to_bl_10 1)), ThreadCap 0xC07), + ((6::obj_ref,(the_nat_to_bl_10 2)), CNodeCap 6 undefined undefined), + ((6::obj_ref,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap 0xBF7 (Some (asid2_0xBF7, 0)))), + ((6::obj_ref,(the_nat_to_bl_10 4)), CNodeCap 5 undefined undefined), + ((7::obj_ref,(the_nat_to_bl_10 1)), ThreadCap 0xC08), + ((7::obj_ref,(the_nat_to_bl_10 2)), CNodeCap 7 undefined undefined), + ((7::obj_ref,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap 0xBF9 (Some (asid2_0xBF9, 0)))), + ((7::obj_ref,(the_nat_to_bl_10 4)), CNodeCap 5 undefined undefined), + ((0xC07::obj_ref, (tcb_cnode_index 0)), CNodeCap 6 undefined undefined ), + ((0xC07::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageTableCap 0xBF7 (Some (asid2_0xBF7, 0)))), + ((0xC07::obj_ref, (tcb_cnode_index 2)), ReplyCap 0xC07 True {AllowGrant,AllowWrite}), + ((0xC07::obj_ref, (tcb_cnode_index 3)), NullCap), + ((0xC07::obj_ref, (tcb_cnode_index 4)), NullCap), + ((0xC08::obj_ref, (tcb_cnode_index 0)), CNodeCap 7 undefined undefined ), + ((0xC08::obj_ref, (tcb_cnode_index 1)), ArchObjectCap (PageTableCap 0xBF9 (Some (asid2_0xBF9, 0)))), + ((0xC08::obj_ref, (tcb_cnode_index 2)), ReplyCap 0xC08 True {AllowGrant,AllowWrite}), + ((0xC08::obj_ref, (tcb_cnode_index 3)), NullCap), + ((0xC08::obj_ref, (tcb_cnode_index 4)), NullCap)} " + apply (insert caps2_0x7_well_formed) + apply (insert caps2_0x6_well_formed) + apply (simp add: caps_of_state_cte_wp_at cte_wp_at_cases s2_def kh2_def kh2_obj_def) + apply (case_tac p, clarsimp) + apply (clarsimp simp: cte_wp_at_cases split: if_splits) + apply (clarsimp simp: tcb_cap_cases_def split: if_splits)+ + apply (clarsimp simp: caps2_0x7_def split: if_splits) + apply (clarsimp simp: caps2_0x6_def cte_wp_at_cases split: if_splits) + done + +lemma Sys2_wellformed: "pas_wellformed Sys2PAS" + apply (clarsimp simp: Sys2PAS_def policy_wellformed_def) + apply (intro conjI) + apply (simp_all add: Sys2AuthGraph_def complete_AuthGraph_def + Sys2AuthGraph_aux_def) + done + +lemma Sys2AgentMap_simps: + "Sys2AgentMap 5 = UT2" + "Sys2AgentMap 6 = UT2" + "Sys2AgentMap 7 = T2" + "Sys2AgentMap 9 = T2" + "Sys2AgentMap 0xBF7 = UT2" + "Sys2AgentMap 0xBF9 = T2" + "Sys2AgentMap 0xC00000 = UT2" + "Sys2AgentMap 0xC05000 = T2" + "Sys2AgentMap 0xC07 = UT2" + "Sys2AgentMap 0xC08 = T2" + "Sys2AgentMap 9001 = IRQ2" + by (simp_all add: Sys2AgentMap_def) + +lemma domains_of_state_s2[simp]: + "domains_of_state s2 = {}" + apply (rule equalityI) + apply (rule subsetI) + apply clarsimp + apply (erule domains_of_state_aux.induct) + apply (simp add: s2_def exst1_def) + apply simp + done + +lemma thread_bound_ntfns_2[simp]: + "thread_bound_ntfns s2 = Map.empty" + unfolding s2_def thread_bound_ntfns_def + apply (rule ext) + apply (simp add: get_tcb_def) + apply (simp add: kh2_def kh2_obj_def) + done + +lemma "pas_refined Sys2PAS s2" + apply (clarsimp simp: pas_refined_def) + apply (intro conjI) + apply (simp add: Sys2_wellformed) + apply (simp add: Sys2PAS_def s2_def Sys2AgentMap_def + irq_map_wellformed_aux_def) + apply (clarsimp simp: auth_graph_map_def + Sys2PAS_def + state_objs_to_policy_def + state_bits_to_policy_def tcb_domain_map_wellformed_aux_def)+ + apply (erule state_bits_to_policyp.cases, simp_all) + apply (drule s2_caps_of_state, clarsimp) + apply (elim disjE, simp_all add: cap_auth_conferred_def + Sys2AgentMap_simps + Sys2AuthGraph_def Sys2AuthGraph_aux_def + complete_AuthGraph_def + split: if_split_asm)[1] + apply (drule s2_caps_of_state, clarsimp) + apply (elim disjE, simp_all)[1] + apply (clarsimp simp: state_refs_of_def s2_def kh2_def kh2_obj_def + split: if_splits) + apply (clarsimp split:if_splits option.splits + simp: thread_st_auth_def tcb_states_of_state_def + Sys2AgentMap_simps Sys2AuthGraph_def + complete_AuthGraph_def Sys2AuthGraph_aux_def + dest!: get_tcb_SomeD) + apply (simp add: s2_def) (* this is OK because cdt is empty..*) + apply (simp add: s2_def) (* this is OK because cdt is empty..*) + apply (fastforce simp: state_vrefs_def vs_refs_aux_def s2_def kh2_def kh2_obj_def pt2_0xBF9_def + pt2_0xBF7_def pt2_0xC05000_def pt2_0xC00000_def Sys2AgentMap_simps + Sys2AuthGraph_def Sys2AuthGraph_aux_def complete_AuthGraph_def + pte_ref2_def graph_of_def opt_map_def ptr_range_def + split: if_splits) + apply clarsimp + apply (erule state_asids_to_policy_aux.cases) + apply clarsimp + apply (fastforce simp: Sys2PAS_def Sys2AuthGraph_def Sys2AuthGraph_aux_def + complete_AuthGraph_def Sys2AgentMap_simps asid_low_bits_def + Sys2ASIDMap_def asid2_0xBF7_def asid2_0xBF9_def + dest!: s2_caps_of_state) + apply (clarsimp simp: state_vrefs_def vs_refs_aux_def s2_def kh2_def kh2_obj_def + split: if_splits) + apply (clarsimp simp: s2_def) + apply (clarsimp) + apply (erule state_irqs_to_policy_aux.cases) + apply (fastforce simp: Sys2PAS_def Sys2AuthGraph_def Sys2AuthGraph_aux_def + complete_AuthGraph_def Sys2AgentMap_simps + Sys2ASIDMap_def asid2_0xBF7_def asid2_0xBF9_def + dest!: s2_caps_of_state) + done + +end + +end From 2048660d39ab412b0da46794a06b31457b2e340d Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Thu, 12 Dec 2024 13:06:24 +1100 Subject: [PATCH 3/4] aarch64 aspec+ainvs+access: access control modulo sorries Signed-off-by: Ryan Barry --- proof/access-control/AARCH64/ArchADT_AC.thy | 67 +- proof/access-control/AARCH64/ArchAccess.thy | 135 +- .../access-control/AARCH64/ArchAccess_AC.thy | 94 +- proof/access-control/AARCH64/ArchArch_AC.thy | 1674 +++++++++++------ proof/access-control/AARCH64/ArchCNode_AC.thy | 45 +- .../AARCH64/ArchDomainSepInv.thy | 87 +- .../AARCH64/ArchFinalise_AC.thy | 373 ++-- .../AARCH64/ArchInterrupt_AC.thy | 13 +- proof/access-control/AARCH64/ArchIpc_AC.thy | 11 +- .../access-control/AARCH64/ArchRetype_AC.thy | 22 +- .../access-control/AARCH64/ArchSyscall_AC.thy | 250 ++- proof/access-control/AARCH64/ArchTcb_AC.thy | 6 +- .../AARCH64/ArchSchedule_AI.thy | 7 +- .../AARCH64/ArchVCPU_AI.thy | 6 +- .../AARCH64/ArchVSpace_AI.thy | 3 +- spec/abstract/AARCH64/VCPUAcc_A.thy | 12 +- 16 files changed, 1923 insertions(+), 882 deletions(-) diff --git a/proof/access-control/AARCH64/ArchADT_AC.thy b/proof/access-control/AARCH64/ArchADT_AC.thy index d49d34b5b4..ca23b3c3e4 100644 --- a/proof/access-control/AARCH64/ArchADT_AC.thy +++ b/proof/access-control/AARCH64/ArchADT_AC.thy @@ -8,40 +8,37 @@ theory ArchADT_AC imports ADT_AC begin -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems ADT_AC_assms -lemma mask_ptTranslationBits_ucast_ucast: - "(asid && mask ptTranslationBits) = ucast (ucast asid :: 9 word)" - by (word_eqI_solve simp: ptTranslationBits_def) - lemma ptr_offset_in_ptr_range: - "\ invs s; x \ kernel_mappings; - get_vspace_of_thread (kheap s) (arch_state s) tcb \ global_pt s; + "\ invs s; get_vspace_of_thread (kheap s) (arch_state s) tcb \ global_pt s; get_page_info (aobjs_of s) - (get_vspace_of_thread (kheap s) (arch_state s) tcb) x = Some (base, sz, attr, r) \ + (get_vspace_of_thread (kheap s) (arch_state s) tcb) x = Some (base, sz, attr, r) \ \ ptrFromPAddr base + (x && mask sz) \ ptr_range (ptrFromPAddr base) sz" apply (simp add: ptr_range_def mask_def) apply (rule conjI) apply (rule_tac b="2 ^ sz - 1" in word_plus_mono_right2) apply (frule some_get_page_info_umapsD) - apply (fastforce dest: get_vspace_of_thread_reachable - simp: canonical_not_kernel_is_user get_page_info_def)+ + apply (fastforce dest: get_vspace_of_thread_reachable + simp: get_page_info_def)+ apply clarsimp apply (drule is_aligned_ptrFromPAddr_n) - apply (simp add: pageBitsForSize_def pageBits_def canonical_bit_def ptTranslationBits_def + apply (simp add: pageBitsForSize_def pageBits_def canonical_bit_def + ptTranslationBits_def pptrBaseOffset_alignment_def split: vmpage_size.splits) apply (clarsimp simp: is_aligned_no_overflow' word_and_le1)+ apply (subst p_assoc_help) apply (rule word_plus_mono_right) apply (rule word_and_le1) apply (frule some_get_page_info_umapsD) - apply (fastforce dest: get_vspace_of_thread_reachable - simp: canonical_not_kernel_is_user get_page_info_def)+ + apply (fastforce dest: get_vspace_of_thread_reachable + simp: get_page_info_def)+ apply clarsimp apply (drule is_aligned_ptrFromPAddr_n) - apply (simp add: pageBitsForSize_def pageBits_def canonical_bit_def ptTranslationBits_def + apply (simp add: pageBitsForSize_def pageBits_def canonical_bit_def + ptTranslationBits_def pptrBaseOffset_alignment_def split: vmpage_size.splits) apply (clarsimp simp: is_aligned_no_overflow') done @@ -50,24 +47,19 @@ lemma user_op_access[ADT_AC_assms]: "\ invs s; pas_refined aag s; is_subject aag tcb; ptable_lift tcb s x = Some ptr; auth \ vspace_cap_rights_to_auth (ptable_rights tcb s x) \ \ abs_has_auth_to aag auth tcb (ptrFromPAddr ptr)" - apply (case_tac "x \ kernel_mappings") - using get_vspace_of_thread_asid_or_global_pt - apply (fastforce simp: ptable_rights_def vspace_cap_rights_to_auth_def invs_def - valid_state_def valid_arch_state_def kernel_mappings_canonical - dest: some_get_page_info_kmapsD split: option.splits) apply (clarsimp simp: ptable_lift_def split: option.splits) apply (insert get_vspace_of_thread_asid_or_global_pt) apply (erule_tac x=s in meta_allE) apply (erule_tac x=tcb in meta_allE) apply (cases "get_vspace_of_thread (kheap s) (arch_state s) tcb = global_pt s"; clarsimp) - apply (frule get_page_info_gpd_kmaps[rotated 2]; fastforce simp: get_page_info_def) - apply (frule (3) ptr_offset_in_ptr_range) + apply (frule get_page_info_gpd_kmaps[rotated 3]; fastforce simp: get_page_info_def) + apply (frule (2) ptr_offset_in_ptr_range) apply (frule get_vspace_of_thread_reachable; clarsimp) apply (frule vs_lookup_table_vspace) apply fastforce+ + apply (clarsimp simp: vspace_for_asid_def entry_for_asid_def pool_for_asid_def entry_for_pool_def) apply (clarsimp simp: get_vspace_of_thread_def get_page_info_def ptable_rights_def pt_lookup_slot_def - split: if_splits option.splits kernel_object.splits cap.splits arch_cap.splits) - apply (frule (1) canonical_not_kernel_is_user) + split: if_splits option.splits kernel_object.splits cap.splits arch_cap.splits pt_type.splits) apply (frule pt_lookup_slot_from_level_is_subject) apply (fastforce elim: vs_lookup_table_vref_independent)+ apply (rule aag_Control_into_owns) @@ -86,24 +78,21 @@ lemma user_op_access[ADT_AC_assms]: apply (drule (1) vs_lookup_table_extend, rule order_refl) apply (rename_tac level vref) apply (case_tac "level = asid_pool_level", simp add: pt_walk_top) - apply (frule vs_lookup_table_is_aligned; clarsimp simp: canonical_not_kernel_is_user) + apply (frule vs_lookup_table_is_aligned; clarsimp) apply (clarsimp simp: pas_refined_def pte_info_def split: pte.splits) apply (erule subsetD) - apply (clarsimp simp: auth_graph_map_def state_objs_to_policy_def) - apply (intro exI conjI sbta_vref | erule sym | rule refl)+ - apply (clarsimp simp: state_vrefs_def ptes_of_Some pts_of_Some) - apply (intro exI conjI) - apply (simp add: canonical_not_kernel_is_user)+ - apply (clarsimp simp: vs_refs_aux_def) - apply (rule conjI; clarsimp) - apply (clarsimp simp: graph_of_def pte_ref2_def Bex_def ptes_of_Some pts_of_Some aobjs_of_Some) - apply (rule_tac x="table_index (pt_slot_offset max_pt_level vref x)" in exI) - apply (fastforce simp: table_index_max_level_slots canonical_not_kernel_is_user - image_iff ptrFromPAddr_def mult_is_add.mult_ac) - apply (clarsimp simp: graph_of_def pte_ref2_def ptes_of_Some pts_of_Some aobjs_of_Some) - apply (rule_tac x="table_index (pt_slot_offset level vref x)" in exI) - apply (fastforce simp: image_iff table_index_offset_pt_bits_left - ptrFromPAddr_def mult_is_add.mult_ac) + apply (clarsimp simp: auth_graph_map_def state_objs_to_policy_def vspace_for_asid_def) + apply (drule_tac s="pasObjectAbs aag vref" in sym) + apply (clarsimp simp: ptes_of_Some pts_of_Some) + apply (clarsimp simp: pt_apply_def split: pt.splits) + apply (intro exI conjI sbta_vref | simp add: state_vrefs_def vspace_objs_of_Some)+ + apply (clarsimp simp: vs_refs_aux_def graph_of_def pte_ref2_def) + apply (rule_tac x="UCAST(64 \ vs_index_len) (pt_index max_pt_level x)" in exI) + apply (fastforce simp: image_iff ptrFromPAddr_def mult_is_add.mult_ac split: pte.splits) + apply (intro exI conjI sbta_vref | simp add: state_vrefs_def vspace_objs_of_Some)+ + apply (clarsimp simp: vs_refs_aux_def graph_of_def pte_ref2_def) + apply (rule_tac x="UCAST(64 \ 9) (pt_index level x)" in exI) + apply (fastforce simp: image_iff ptrFromPAddr_def mult_is_add.mult_ac split: pte.splits) done lemma write_in_vspace_cap_rights[ADT_AC_assms]: diff --git a/proof/access-control/AARCH64/ArchAccess.thy b/proof/access-control/AARCH64/ArchAccess.thy index 8c48f69eb3..0aff83ea09 100644 --- a/proof/access-control/AARCH64/ArchAccess.thy +++ b/proof/access-control/AARCH64/ArchAccess.thy @@ -8,7 +8,7 @@ theory ArchAccess imports Types begin -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 subsection \Arch-specific transformation of caps into authorities\ @@ -25,37 +25,39 @@ subsection \Generating a policy from the current ASID distribution\ definition pte_ref2 where "pte_ref2 level pte \ case pte of - PagePTE ppn atts rights - \ Some (ptrFromPAddr (addr_from_ppn ppn), - pageBitsForSize (vmpage_size_of_level level), + PagePTE paddr _ _ rights + \ Some (ptrFromPAddr paddr, + pt_bits_left level, vspace_cap_rights_to_auth rights) - | PageTablePTE ppn atts - \ Some (ptrFromPAddr (addr_from_ppn ppn), 0, {Control}) + | PageTablePTE ppn + \ Some (ptrFromPAddr (paddr_from_ppn ppn), 0, {Control}) | _ \ None" definition vs_refs_aux :: "vm_level \ arch_kernel_obj \ (obj_ref \ obj_ref \ aa_type \ auth) set" where "vs_refs_aux level \ \ko. case ko of - ASIDPool pool \ (\(r,p). (p, ucast r, AASIDPool, Control)) ` graph_of pool - | PageTable pt \ - \(r,(p, sz, auth)) \ graph_of (pte_ref2 level o pt) - {(x,y). x \ kernel_mapping_slots \ level = max_pt_level}. - (\(p, a). (p, ucast r, APageTable, a)) ` (ptr_range p sz \ auth) + ASIDPool pool \ (\(r,p). (p, ucast r, AASIDPool, Control)) ` graph_of (option_map ap_vspace o pool) + | PageTable pt \ (case pt of + VSRootPT pt \ \(r,(p, sz, auth)) \ graph_of (pte_ref2 level o pt). + (\(p, a). (p, ucast r, APageTable VSRootPT_T, a)) ` (ptr_range p sz \ auth) + | NormalPT pt \ \(r,(p, sz, auth)) \ graph_of (pte_ref2 level o pt). + (\(p, a). (p, ucast r, APageTable NormalPT_T, a)) ` (ptr_range p sz \ auth)) | _ \ {}" definition state_vrefs where "state_vrefs s \ \p. \{vs_refs_aux lvl ao | lvl ao bot asid vref. vs_lookup_table bot asid vref s = Some (lvl, p) - \ aobjs_of s p = Some ao \ vref \ user_region}" + \ vspace_objs_of s p = Some ao \ vref \ user_region}" lemma state_vrefsD: "\ vs_lookup_table level asid vref s = Some (lvl, p); - aobjs_of s p = Some ao; vref \ user_region; x \ vs_refs_aux lvl ao \ + vspace_objs_of s p = Some ao; vref \ user_region; x \ vs_refs_aux lvl ao \ \ x \ state_vrefs s p" unfolding state_vrefs_def by fastforce end -context Arch_p_arch_update_eq begin global_naming RISCV64 +context Arch_p_arch_update_eq begin global_naming AARCH64 interpretation Arch . @@ -64,7 +66,7 @@ lemma state_vrefs[iff]: "state_vrefs (f s) = state_vrefs s" end -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemmas state_vrefs_upd = cur_thread_update.state_vrefs @@ -80,17 +82,18 @@ end context Arch begin primrec aobj_ref' where - "aobj_ref' (ASIDPoolCap p as) = {p}" + "aobj_ref' (ASIDPoolCap ref _) = {ref}" | "aobj_ref' ASIDControlCap = {}" -| "aobj_ref' (FrameCap ref cR sz dev as) = ptr_range ref (pageBitsForSize sz)" -| "aobj_ref' (PageTableCap x as3) = {x}" +| "aobj_ref' (FrameCap ref _ sz _ _) = ptr_range ref (pageBitsForSize sz)" +| "aobj_ref' (PageTableCap ref _ _) = {ref}" +| "aobj_ref' (VCPUCap ref) = {ref}" fun acap_asid' :: "arch_cap \ asid set" where "acap_asid' (FrameCap _ _ _ _ mapping) = fst ` set_option mapping" -| "acap_asid' (PageTableCap _ mapping) = fst ` set_option mapping" -| "acap_asid' (ASIDPoolCap _ asid) - = {x. asid_high_bits_of x = asid_high_bits_of asid \ x \ 0}" +| "acap_asid' (PageTableCap _ _ mapping) = fst ` set_option mapping" +| "acap_asid' (ASIDPoolCap _ asid) = {x. asid_high_bits_of x = asid_high_bits_of asid \ x \ 0}" | "acap_asid' ASIDControlCap = UNIV" +| "acap_asid' (VCPUCap _) = {}" inductive_set state_asids_to_policy_aux for aag caps asid_tab vrefs where sata_asid: @@ -109,7 +112,7 @@ inductive_set state_asids_to_policy_aux for aag caps asid_tab vrefs where definition "state_asids_to_policy_arch aag caps astate vrefs \ - state_asids_to_policy_aux aag caps (riscv_asid_table astate) + state_asids_to_policy_aux aag caps (arm_asid_table astate) (vrefs :: 64 word \ (64 word \ 64 word \ aa_type \ auth) set)" declare state_asids_to_policy_arch_def[simp] @@ -201,21 +204,21 @@ lemma integrity_asids_kh_update: subsection \Misc definitions\ fun ctxt_IP_update where - "ctxt_IP_update (UserContext ctxt) = UserContext (ctxt(NextIP := ctxt FaultIP))" + "ctxt_IP_update (UserContext fpu ctxt) = UserContext fpu (ctxt(NextIP := ctxt FaultIP))" lemma ctxt_IP_update_def: "ctxt_IP_update ctxt = - (case ctxt of (UserContext ctxt') \ UserContext (ctxt'(NextIP := ctxt' FaultIP)))" + (case ctxt of (UserContext fpu ctxt') \ UserContext fpu (ctxt'(NextIP := ctxt' FaultIP)))" by (cases ctxt; clarsimp) abbreviation arch_IP_update where "arch_IP_update arch \ arch_tcb_context_set (ctxt_IP_update (arch_tcb_context_get arch)) arch" definition asid_pool_integrity :: - "'a set \ 'a PAS \ (asid_low_index \ obj_ref) \ (asid_low_index \ obj_ref) \ bool" where + "'a set \ 'a PAS \ (asid_low_index \ asid_pool_entry) \ (asid_low_index \ asid_pool_entry) \ bool" where "asid_pool_integrity subjects aag pool pool' \ \x. pool' x \ pool x - \ pool' x = None \ aag_subjects_have_auth_to subjects aag Control (the (pool x))" + \ pool' x = None \ aag_subjects_have_auth_to subjects aag Control (ap_vspace (the (pool x)))" inductive arch_integrity_obj_atomic :: "'a PAS \ 'a set \ 'a \ arch_kernel_obj \ arch_kernel_obj \ bool" @@ -275,4 +278,86 @@ end declare state_vrefs_upd[simp] declare integrity_asids_updates[simp] + +context Arch begin global_naming AARCH64 + +(* FIXME AARCH64: update the access control spec + -Parameterise arch object updates with machine state and arch state + -Model virtualised machine state more explicitly + -Specify when virtualised machine state can change (i.e. restoring from current VCPU) + -Specify when arm_current_vcpu can change (i.e. once current VCPU has been saved) + -Specify integrity constraints for FPUs +*) + +\ \Anyone can save virtualised registers to the current VCPU\ +lemma arch_troa_vcpu_save_reg: + "\ aobjs_of s vptr = Some (VCPU vcpu); ao' = VCPU vcpu'; + option_map fst (arm_current_vcpu (arch_state s)) = Some vptr; + vcpu' = vcpu\vcpu_regs := (vcpu_regs vcpu)(reg := vcpuHardwareReg_val reg (machine_state s))\ \ + \ arch_integrity_obj_atomic aag subjects l ao ao'" + sorry + +(* FIXME AARCH64: assert a connection to the current (or soon-to-be-switched-to) thread? *) +\ \Anyone can update the virtual count offset in the current VCPU\ +lemma arch_troa_vcpu_restore_vtimer: + "\ aobjs_of s vptr = Some (VCPU vcpu); ao' = VCPU vcpu'; + option_map fst (arm_current_vcpu (arch_state s)) = Some vptr; + vcpu' = vcpu\vcpu_regs := (vcpu_regs vcpu) + (VCPURegCNTVOFF := vcpu_regs vcpu VCPURegCNTVOFF + + (read_cntpct_val (machine_state s) + - vtimerLastPCount (vcpu_vtimer vcpu)))\ \ + \ arch_integrity_obj_atomic aag subjects l ao ao'" + sorry + +\ \Anyone can save the physical count register to the current VCPU\ +lemma arch_troa_vcpu_save_virt_timer: + "\ aobjs_of s vptr = Some (VCPU vcpu); ao' = VCPU vcpu'; + option_map fst (arm_current_vcpu (arch_state s)) = Some vptr; + vcpu' = vcpu\vcpu_vtimer := VirtTimer (read_cntpct_val (machine_state s))\ \ + \ arch_integrity_obj_atomic aag subjects l ao ao'" + sorry + +\ \Anyone can save virtualised GIC registers to the current VCPU\ +lemma arch_troa_vcpu_save_vgic: + "\ aobjs_of s vptr = Some (VCPU vcpu); ao' = VCPU vcpu'; + option_map fst (arm_current_vcpu (arch_state s)) = Some vptr; + vcpu' = vcpu \vcpu_vgic := vgic\; + vgic = vcpu_vgic vcpu\vgic_hcr := gic_vcpu_ctrl_hcr_val (machine_state s)\ \ + vgic = vcpu_vgic vcpu\vgic_vmcr := gic_vcpu_ctrl_vmcr_val (machine_state s)\ \ + vgic = vcpu_vgic vcpu\vgic_apr := gic_vcpu_ctrl_apr_val (machine_state s)\ \ + vgic = vcpu_vgic vcpu\vgic_lr := (vgic_lr (vcpu_vgic vcpu)) + (vreg := gic_vcpu_ctrl_lr_val (of_nat vreg) (machine_state s))\ \ + \ arch_integrity_obj_atomic aag subjects l ao ao'" + sorry + +\ \Update the vmid of a pool\ +lemma + arch_troa_asidpool_vmid: + "\ ao = ASIDPool pool; ao' = ASIDPool pool'; + \x. (pool x = None) = (pool' x = None); + \x e e'. pool x = Some e \ pool' x = Some e' + \ (ap_vspace e = ap_vspace e' \ + (ap_vmid e = ap_vmid e' \ ap_vmid e = None \ ap_vmid e' = None)) \ + \ arch_integrity_obj_atomic aag subjects l ao ao'" + sorry + +\ \If a VCPU belongs to the current agent, then so does its associated TCB\ +lemma associated_tcb_is_subject: + "\ vcpus_of s v = Some vcpu; vcpu_tcb vcpu = Some t; is_subject aag v \ + \ is_subject aag t" + sorry + +\ \If a TCB belongs to the current agent, then so does its associated VCPU\ +lemma associated_vcpu_is_subject: + "\ get_tcb t s = Some tcb; tcb_vcpu (tcb_arch tcb) = Some v; is_subject aag t \ + \ is_subject aag v" + sorry + +(* FIXME AARCH64: clarify when we can assume this *) +lemma invs_valid_cur_vcpu: + "invs s \ valid_cur_vcpu s" + sorry + +end + end diff --git a/proof/access-control/AARCH64/ArchAccess_AC.thy b/proof/access-control/AARCH64/ArchAccess_AC.thy index 0d5405dbed..4e3376a928 100644 --- a/proof/access-control/AARCH64/ArchAccess_AC.thy +++ b/proof/access-control/AARCH64/ArchAccess_AC.thy @@ -10,7 +10,7 @@ begin section\Arch-specific AC proofs\ -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems Access_AC_assms @@ -59,7 +59,7 @@ proof goal_cases qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemma auth_ipc_buffers_tro[Access_AC_assms]: "\ integrity_obj_state aag activate subjects s s'; @@ -96,7 +96,7 @@ proof goal_cases qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemma ipcframe_subset_page: "\ valid_objs s; get_tcb p s = Some tcb; @@ -163,13 +163,99 @@ proof goal_cases qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemma pas_refined_irq_state_independent[intro!, simp]: "pas_refined x (s\machine_state := machine_state s\irq_state := f (irq_state (machine_state s))\\) = pas_refined x s" by (simp add: pas_refined_def) +(* FIXME AARCH64: try to use in_opt_map_eq where possible *) +lemma vspace_objs_of_Some: + "(vspace_objs_of s p = Some ao) = (aobjs_of s p = Some ao \ \is_VCPU ao)" + by (clarsimp simp: in_opt_map_eq vspace_obj_of_Some) + +lemma state_irqs_to_policy_eq_caps: + "\ x \ state_irqs_to_policy_aux aag caps; caps = caps' \ + \ x \ state_irqs_to_policy_aux aag caps'" + by (erule subst) + +lemma vs_lookup_table_eqI': + "\ asid_table s' (asid_high_bits_of asid) = asid_table s (asid_high_bits_of asid); + \pool_ptr. asid_table s' (asid_high_bits_of asid) = Some pool_ptr + \ bot_level \ max_pt_level + \ vspace_for_pool pool_ptr asid (asid_pools_of s') = + vspace_for_pool pool_ptr asid (asid_pools_of s); + bot_level < max_pt_level \ pts_of s' = pts_of s \ + \ vs_lookup_table bot_level asid vref s' = vs_lookup_table bot_level asid vref s" + by (auto simp: obind_def vs_lookup_table_def asid_pool_level_eq[symmetric] + pool_for_asid_def entry_for_pool_def vspace_for_pool_def + split: option.splits) + +lemma vs_refs_aux_eqI: + assumes "pts_of s' = pts_of s" + and "\p sz. data_at sz p s' = data_at sz p s" + and "\pool_ptr asid. (asid_pools_of s' |> oapply asid |> ogets ap_vspace) pool_ptr + = (asid_pools_of s |> oapply asid |> ogets ap_vspace) pool_ptr" + and "aobjs_of s p = Some ao" + and "aobjs_of s' p = Some ao'" + shows "vs_refs_aux level ao = vs_refs_aux level ao'" + apply (insert assms) + apply (clarsimp simp: fun_eq_iff) + apply (erule_tac x=p in allE)+ + apply (fastforce simp: vs_refs_aux_def graph_of_def image_iff opt_map_def ogets_def + split: option.splits arch_kernel_obj.splits) + done + +lemma state_vrefs_eqI': + assumes "asid_table s' = asid_table s" + and "pts_of s' = pts_of s" + and "\p sz. data_at sz p s' = data_at sz p s" + and "\pool_ptr asid. (asid_pools_of s' |> oapply asid |> ogets ap_vspace) pool_ptr + = (asid_pools_of s |> oapply asid |> ogets ap_vspace) pool_ptr" + shows "state_vrefs s' = state_vrefs s" + apply (insert assms) + apply (prop_tac "\level asid vref. vs_lookup_table level asid vref s' = vs_lookup_table level asid vref s") + apply (rule vs_lookup_table_eqI') + apply (auto simp: fun_eq_iff vspace_for_pool_def entry_for_pool_def obind_def ogets_def opt_map_def)[3] + apply (rule ext)+ + apply (intro equalityI subsetI; subst (asm) state_vrefs_def; clarsimp) + + apply (clarsimp simp: vspace_objs_of_Some) + apply (case_tac "vspace_objs_of s x"; clarsimp?) + apply (clarsimp simp: fun_eq_iff) + apply (erule_tac x=x in allE)+ + apply (fastforce simp: vspace_obj_of_def vs_refs_aux_def graph_of_def + image_iff opt_map_def ogets_def is_VCPU_def + split: option.splits arch_kernel_obj.splits if_splits )[1] + apply (prop_tac "\level. vs_refs_aux level ao = vs_refs_aux level ac") + apply (intro allI vs_refs_aux_eqI; fastforce simp: vspace_objs_of_Some) + apply (fastforce intro: state_vrefsD) + + apply (clarsimp simp: vspace_objs_of_Some) + apply (case_tac "vspace_objs_of s' x"; clarsimp?) + apply (clarsimp simp: fun_eq_iff) + apply (erule_tac x=x in allE)+ + apply (fastforce simp: vspace_obj_of_def vs_refs_aux_def graph_of_def + image_iff opt_map_def ogets_def is_VCPU_def + split: option.splits arch_kernel_obj.splits if_splits )[1] + apply (prop_tac "\level. vs_refs_aux level ac = vs_refs_aux level ao") + apply (intro allI vs_refs_aux_eqI; fastforce simp: vspace_objs_of_Some) + apply (fastforce intro!: state_vrefsD) + done + +lemma state_vrefs_eqI: + assumes "asid_table s' = asid_table s" + and "vspace_objs_of s' = vspace_objs_of s" + shows "state_vrefs s' = state_vrefs s" + apply (prop_tac "\level asid vref. vs_lookup_table level asid vref s = vs_lookup_table level asid vref s'") + apply (intro allI vs_lookup_table_eqI') + using assms apply (fastforce simp: obj_at_def) + using vspace_objs_of_aps_eq assms apply fastforce + using vspace_objs_of_pts_eq assms apply fastforce + using assms apply (fastforce simp: state_vrefs_def) + done + end end diff --git a/proof/access-control/AARCH64/ArchArch_AC.thy b/proof/access-control/AARCH64/ArchArch_AC.thy index 4519236a7b..f2954fd9dc 100644 --- a/proof/access-control/AARCH64/ArchArch_AC.thy +++ b/proof/access-control/AARCH64/ArchArch_AC.thy @@ -14,25 +14,20 @@ Arch-specific access control. \ -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems Arch_AC_assms lemma set_mrs_state_vrefs[Arch_AC_assms, wp]: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ + "\(\s. P (state_vrefs s))\ set_mrs thread buf msgs \\_ s. P (state_vrefs s)\" apply (simp add: set_mrs_def split_def set_object_def get_object_def split del: if_split) apply (wpsimp wp: gets_the_wp get_wp put_wp mapM_x_wp' simp: zipWithM_x_mapM_x split_def store_word_offs_def split_del: if_split) - apply (subst state_vrefs_eqI) - prefer 7 - apply assumption - apply (clarsimp simp: opt_map_def) - apply (fastforce simp: opt_map_def aobj_of_def) - apply clarsimp - apply (auto simp: valid_arch_state_def) + apply (subst (asm) state_vrefs_tcb_upd[symmetric]) + apply (auto simp: fun_upd_def get_tcb_def tcb_at_def) done lemma mul_add_word_size_lt_msg_align_bits_ofnat[Arch_AC_assms]: @@ -59,7 +54,7 @@ proof goal_cases qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 definition level_of_table :: "obj_ref \ 'z :: state_ext state \ vm_level" where @@ -68,7 +63,7 @@ definition level_of_table :: "obj_ref \ 'z :: state_ext state \ vs_lookup_table level asid vref s = Some (level, p); - ptes_of s p = Some pte; level \ max_pt_level; vref \ user_region; invs s \ + ptes_of s pt_t p = Some pte; level \ max_pt_level; vref \ user_region; invs s \ \ level_of_table p s = level" apply (subst level_of_table_def) apply (rule Greatest_equality, fastforce) @@ -79,7 +74,7 @@ lemma level_of_table_vs_lookup_table: lemma vs_lookup_slot_level_of_slot: "\ vs_lookup_slot level asid vref s = Some (level, p); - ptes_of s p = Some pte; level \ max_pt_level; vref \ user_region; invs s \ + ptes_of s pt_t p = Some pte; level \ max_pt_level; vref \ user_region; invs s \ \ level_of_slot asid vref p s = level" apply (subst level_of_slot_def) apply (rule Greatest_equality) @@ -101,18 +96,15 @@ lemma vs_lookup_table_vref_independent: lemma state_vrefs_store_NonPageTablePTE: "\ invs s; is_aligned p pte_bits; vs_lookup_slot level asid vref s = Some (level, p); - vref \ user_region; \ is_PageTablePTE pte; - kheap s (table_base p) = Some (ArchObj (PageTable pt)) \ - \ state_vrefs (s\kheap := \a. if a = table_base p - then Some (ArchObj (PageTable (\a. if a = table_index p - then pte - else pt a))) - else kheap s a\) = + vref \ user_region; \ is_PageTablePTE pte; pts_of s (table_base (pt_type pt) p) = Some pt \ + \ state_vrefs (s\kheap := (kheap s)(table_base (pt_type pt) p \ + ArchObj (PageTable (pt_upd pt (table_index (pt_type pt) p) pte)) + )\) = (\x. if \level' vref'. vref_for_level vref' (level + 1) = vref_for_level vref (level + 1) \ - vref' \ user_region \ p = pt_slot_offset level (table_base p) vref' \ - pt_walk level level' (table_base p) vref' (ptes_of s) = Some (level',x) - then (if x = table_base p - then vs_refs_aux level (PageTable (\a. if a = table_index p then pte else pt a)) + vref' \ user_region \ p = pt_slot_offset level (table_base (pt_type pt) p) vref' \ + pt_walk level level' (table_base (pt_type pt) p) vref' (ptes_of s) = Some (level',x) + then (if x = table_base (pt_type pt) p + then vs_refs_aux level (PageTable (pt_upd pt (table_index (pt_type pt) p) pte)) else {}) else state_vrefs s x)" apply (rule all_ext) @@ -120,20 +112,26 @@ lemma state_vrefs_store_NonPageTablePTE: apply (fastforce simp: vs_lookup_slot_def vs_lookup_table_def ptes_of_Some pts_of_Some aobjs_of_Some dest: pool_for_asid_no_pte) - apply (prop_tac "ptes_of s p \ None") - apply (drule valid_vspace_objs_strong_slotD; clarsimp split del: if_split) + apply (frule vs_lookup_slot_level_type) + apply (fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some)+ + apply (prop_tac "ptes_of s (pt_type pt) p \ None") + apply (drule valid_vspace_objs_strong_slotD; clarsimp simp: ptes_of_Some pts_of_Some aobjs_of_Some) apply (frule vs_lookup_slot_table_base; clarsimp split del: if_split) + apply (subst (asm) ptes_of_Some) apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp split del: if_split) apply safe - apply (subst (asm) state_vrefs_def opt_map_def)+ + apply (subst (asm) state_vrefs_def)+ apply (clarsimp split: option.splits split del: if_split) apply (subst (asm) vs_lookup_non_PageTablePTE[where s=s and s'="kheap_update _ s" and p=p]) - apply (fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some - opt_map_def pte_of_def obind_def - dest: pte_ptr_eq)+ - apply (case_tac "x = table_base p"; clarsimp) + apply ((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def split: option.splits)+; fail)+ + + apply (frule pts_of_ptes_of; clarsimp) + apply (case_tac "x = table_base (pt_type pt) p"; clarsimp) apply (case_tac "lvl = asid_pool_level") - apply (fastforce dest: vs_lookup_table_no_asid[OF vs_lookup_level] + apply (fastforce dest: vs_lookup_table_no_asid[OF vs_lookup_level, where pt_t="pt_type pt"] simp: ptes_of_Some pts_of_Some aobjs_of_Some split: if_splits) apply (fastforce dest: vs_lookup_table_unique_level[OF vs_lookup_level] elim: allE[where x=level] split: if_splits) @@ -143,7 +141,10 @@ lemma state_vrefs_store_NonPageTablePTE: apply (frule vs_lookup_slot_level_of_slot) apply (fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some split: option.splits) apply fastforce+ - apply (subst (asm) vs_lookup_slot_table_unfold; fastforce) + apply (subst (asm) vs_lookup_slot_table_unfold) + apply fastforce+ + apply clarsimp + apply (metis (no_types, lifting) vs_lookup_slot_table_unfold vs_lookup_slot_unique_level) apply (rule conjI; clarsimp) apply (case_tac "level' < level") apply (subst (asm) vs_lookup_vref_for_level_eq1, rule sym, assumption) @@ -154,7 +155,7 @@ lemma state_vrefs_store_NonPageTablePTE: apply (frule_tac level=lvl in vs_lookup_level) apply (drule (1) vs_lookup_table_unique_level, rule refl) apply fastforce+ - apply (frule bit0.plus_one_leq) + apply (frule bit1.plus_one_leq) apply (erule_tac x=level in allE) apply (subst (asm) vs_lookup_slot_vref_for_level[symmetric], assumption) apply (frule_tac bot_level=bot in vs_lookup_min_level) @@ -162,31 +163,36 @@ lemma state_vrefs_store_NonPageTablePTE: apply (subst (asm) pt_walk.simps, clarsimp) apply (fastforce simp: state_vrefs_def opt_map_def) apply (prop_tac "level_of_slot asid vref p s = level") - apply (fastforce simp: vs_lookup_slot_table_unfold vs_lookup_slot_level_of_slot) + apply (fastforce simp: vs_lookup_slot_table_unfold ptes_of_Some intro: vs_lookup_slot_level_of_slot) apply (clarsimp split: if_splits) apply (rule state_vrefsD) apply (subst vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte]) - apply (fastforce dest: pte_ptr_eq - simp: ptes_of_Some pts_of_Some aobjs_of_Some - opt_map_def pte_of_def obind_def)+ - apply (case_tac "x = table_base p") + apply ((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def split: option.splits)+; fail)+ + apply (case_tac "x = table_base (pt_type pt) p") apply (fastforce elim: allE[where x=level]) apply (subst (asm) state_vrefs_def, clarsimp) apply (rule_tac level=lvl and asid=asida and vref=vrefa in state_vrefsD) apply (subst vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte]) - apply (fastforce dest: pte_ptr_eq - simp: ptes_of_Some pts_of_Some aobjs_of_Some - opt_map_def pte_of_def obind_def)+ + apply ((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def split: option.splits)+; fail)+ apply (clarsimp split: if_splits) apply (intro conjI; clarsimp) apply (case_tac "level' = asid_pool_level") apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some) - apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) apply (case_tac "lvl < level") apply (drule_tac bot_level=bot in vs_lookup_level) apply (subst (asm) vs_lookup_split_Some, erule dual_order.strict_implies_order) apply fastforce + apply (frule vs_lookup_slot_level_type) + apply (fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some)+ + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) apply (drule (1) vs_lookup_table_unique_level; fastforce) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) apply (metis vs_lookup_slot_table vs_lookup_slot_unique_level) apply (fastforce dest: vs_lookup_level) apply (fastforce simp: aobjs_of_Some opt_map_def) @@ -194,100 +200,102 @@ lemma state_vrefs_store_NonPageTablePTE: apply clarsimp done + lemma state_vrefs_store_NonPageTablePTE': "\ invs s; is_aligned p pte_bits; \ is_PageTablePTE pte; - kheap s (table_base p) = Some (ArchObj (PageTable pt)); + pts_of s (table_base (pt_type pt) p) = Some pt; \level asid vref. vref \ user_region \ vs_lookup_slot level asid vref s \ Some (level, p) \ - \ state_vrefs (s\kheap := \a. if a = table_base p - then Some (ArchObj (PageTable (\a. if a = table_index p - then pte - else pt a))) - else kheap s a\) = - (\x. if x = table_base p \ (\level. \\ (level, table_base p) s) - then vs_refs_aux (level_of_table (table_base p) s) (PageTable (\a. if a = table_index p - then pte - else pt a)) + \ state_vrefs (s\kheap := (kheap s)(table_base (pt_type pt) p \ + ArchObj (PageTable (pt_upd pt (table_index (pt_type pt) p) pte)) + )\) = + (\x. if x = table_base (pt_type pt) p \ (\level. \\ (level, table_base (pt_type pt) p) s) + then vs_refs_aux (level_of_table (table_base (pt_type pt) p) s) + (PageTable (pt_upd pt (table_index (pt_type pt) p) pte)) else state_vrefs s x)" apply (rule all_ext) + apply safe - apply (subst (asm) state_vrefs_def opt_map_def)+ + apply (frule pts_of_ptes_of; clarsimp) + apply (subst (asm) state_vrefs_def)+ apply (clarsimp split: option.splits split del: if_split) apply (clarsimp split: if_split_asm option.splits split del: if_split) apply (subst (asm) vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte]) - apply (fastforce dest: pte_ptr_eq - simp: ptes_of_Some pts_of_Some aobjs_of_Some - opt_map_def pte_of_def obind_def)+ + apply ((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def split: option.splits)+; fail)+ apply (clarsimp split: if_splits) apply (drule vs_lookup_level) apply (rule conjI; clarsimp) apply (case_tac "level = asid_pool_level") - apply (fastforce dest: vs_lookup_table_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some) + apply (clarsimp simp: ptes_of_Some pts_of_Some) + apply (fastforce dest: vs_lookup_table_pt_at vs_lookup_asid_pool + simp: asid_pools_of_ko_at obj_at_def opt_map_def) apply (case_tac "lvl = asid_pool_level") - apply (fastforce dest: vs_lookup_table_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some) - apply (subst level_of_table_vs_lookup_table; fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some) + apply (fastforce dest: vs_lookup_table_pt_at vs_lookup_asid_pool + simp: asid_pools_of_ko_at obj_at_def) + apply (subst level_of_table_vs_lookup_table[where pt_t="pt_type pt"]; fastforce) apply (subst (asm) vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte]) - apply (fastforce dest: pte_ptr_eq - simp: ptes_of_Some pts_of_Some aobjs_of_Some - opt_map_def pte_of_def obind_def)+ + apply ((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def split: option.splits)+; fail)+ apply (fastforce simp: state_vrefs_def aobjs_of_Some) apply (clarsimp split: if_splits) apply (case_tac "level = asid_pool_level") - apply (fastforce dest: vs_lookup_table_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some) - apply (subst (asm) level_of_table_vs_lookup_table) + apply (clarsimp simp: ptes_of_Some pts_of_Some) + apply (fastforce dest: vs_lookup_table_pt_at vs_lookup_asid_pool + simp: asid_pools_of_ko_at obj_at_def opt_map_def) + apply (subst (asm) level_of_table_vs_lookup_table[where pt_t="pt_type pt"]) apply (fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some)+ apply (rule state_vrefsD) apply (subst vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte ]) - apply ((fastforce dest: pte_ptr_eq - simp: ptes_of_Some pts_of_Some aobjs_of_Some - opt_map_def pte_of_def obind_def)+)[7] - apply auto[1] - apply (fastforce simp: aobjs_of_Some opt_map_def) - apply clarsimp - apply clarsimp - apply (case_tac "x = table_base p") + apply ((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def split: option.splits)+; fail)+ + apply (case_tac "x = table_base (pt_type pt) p") apply (fastforce dest: vs_lookup_level simp: state_vrefs_def) apply (subst (asm) state_vrefs_def, clarsimp) apply (rule state_vrefsD) apply (subst vs_lookup_non_PageTablePTE[where s=s and p=p and pte=pte ]) - apply ((fastforce dest: pte_ptr_eq - simp: ptes_of_Some pts_of_Some aobjs_of_Some - opt_map_def pte_of_def obind_def)+)[7] - apply auto[1] - apply (fastforce simp: aobjs_of_Some opt_map_def split: option.splits) - apply clarsimp - apply clarsimp + apply ((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def split: option.splits)+; fail)+ done (* FIXME AC: make this less ugly *) lemma state_vrefs_store_NonPageTablePTE_wp: "\\s. invs s \ \ is_PageTablePTE pte \ - (\pt. ako_at (PageTable pt) (table_base p) s \ is_aligned p pte_bits \ + (\pt. pts_of s (table_base pt_t p) = Some pt \ pt_t = pt_type pt \ is_aligned p pte_bits \ (if \level asid vref. vs_lookup_slot level asid vref s = Some (level, p) \ vref \ user_region then (\level asid vref. vs_lookup_slot level asid vref s = Some (level, p) \ vref \ user_region \ P (\x. (if \level' vref'. vref_for_level vref' (level + 1) = vref_for_level vref (level + 1) \ - vref' \ user_region \ p = pt_slot_offset level (table_base p) vref' \ - pt_walk level level' (table_base p) vref' (ptes_of s) = Some (level', x) - then (if x = table_base p - then vs_refs_aux level (PageTable (\a. if a = table_index p then pte else pt a)) + vref' \ user_region \ p = pt_slot_offset level (table_base pt_t p) vref' \ + pt_walk level level' (table_base pt_t p) vref' (ptes_of s) = Some (level', x) + then (if x = table_base pt_t p + then vs_refs_aux level (PageTable (pt_upd pt (table_index pt_t p) pte)) else {}) else state_vrefs s x))) - else P (\x. (if x = table_base p \ (\level. \\ (level, table_base p) s) - then vs_refs_aux (level_of_table (table_base p) s) (PageTable (\a. if a = table_index p then pte else pt a)) + else P (\x. (if x = table_base pt_t p \ (\level. \\ (level, table_base pt_t p) s) + then vs_refs_aux (level_of_table (table_base pt_t p) s) (PageTable (pt_upd pt (table_index pt_t p) pte)) else state_vrefs s x))))\ - store_pte p pte + store_pte pt_t p pte \\_ s. P (state_vrefs s)\" unfolding store_pte_def set_pt_def apply (wpsimp wp: set_object_wp) apply (case_tac "\level asid vref. vs_lookup_slot level asid vref s = Some (level, p) \ vref \ user_region") + apply clarsimp apply (erule_tac x=pt in allE) - apply (clarsimp simp: fun_upd_def) apply (subst state_vrefs_store_NonPageTablePTE) apply fastforce+ - apply (clarsimp simp: obj_at_def) + apply (clarsimp simp: obj_at_def pts_of_Some aobjs_of_Some) apply (case_tac "level = asid_pool_level") apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (clarsimp simp: pts_of_Some aobjs_of_Some obj_at_def) apply (case_tac "levela = asid_pool_level") apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) @@ -298,12 +306,11 @@ lemma state_vrefs_store_NonPageTablePTE_wp: apply (fastforce intro: vm_level_less_le_1) apply clarsimp apply (erule_tac x=pt in allE) - apply (clarsimp simp: fun_upd_def) - apply (subst state_vrefs_store_NonPageTablePTE'; fastforce simp: obj_at_def) + apply (subst state_vrefs_store_NonPageTablePTE'; fastforce simp: obj_at_def aobjs_of_Some pts_of_Some) done lemma store_pte_thread_st_auth[wp]: - "store_pte p pte \\s. P (thread_st_auth s)\" + "store_pte pt_t p pte \\s. P (thread_st_auth s)\" unfolding store_pte_def set_pt_def apply (wpsimp wp: set_object_wp) apply (clarsimp simp: get_tcb_def thread_st_auth_def tcb_states_of_state_def obj_at_def @@ -311,7 +318,7 @@ lemma store_pte_thread_st_auth[wp]: done lemma store_pte_thread_bound_ntfns[wp]: - "store_pte p pte \\s. P (thread_bound_ntfns s)\" + "store_pte pt_t p pte \\s. P (thread_bound_ntfns s)\" unfolding store_pte_def set_pt_def apply (wpsimp wp: set_object_wp) apply (clarsimp simp: get_tcb_def thread_bound_ntfns_def obj_at_def @@ -319,11 +326,11 @@ lemma store_pte_thread_bound_ntfns[wp]: done lemma store_pte_domains_of_state[wp]: - "store_pte p pte \\s. P (domains_of_state s)\" + "store_pte pt_t p pte \\s. P (domains_of_state s)\" unfolding store_pte_def set_pt_def by (wpsimp wp: set_object_wp) lemma mapM_x_store_pte_caps_of_state[wp]: - "mapM_x (swp store_pte InvalidPTE) slots \\s. P (asid_table s)\" + "mapM_x (swp (store_pte pt_t) InvalidPTE) slots \\s. P (asid_table s)\" by (wpsimp wp: mapM_x_wp') lemma state_bits_to_policy_vrefs_subseteq: @@ -342,15 +349,88 @@ lemma state_asids_to_policy_vrefs_subseteq: apply (erule state_asids_to_policy_aux.cases; fastforce intro: state_asids_to_policy_aux.intros) done +lemma vs_lookup_table_subseteq: + "\ vs_lookup_table bot_level asid vref s' = Some (lvl,ptr); + \pptr. pool_for_asid asid s' = Some pptr \ pool_for_asid asid s = Some pptr; + \pptr vref. vspace_for_pool pptr asid (asid_pools_of s') = Some vref + \ vspace_for_pool pptr asid (asid_pools_of s) = Some vref; + ptes_of s' = ptes_of s \ + \ vs_lookup_table bot_level asid vref s = Some (lvl,ptr)" + by (auto simp: vs_lookup_table_def in_obind_eq split: if_splits) + +lemma vs_refs_aux_subseteq: + assumes "\asid vref. vspace_for_pool 0 asid (K (asid_pool_of ao')) = Some vref + \ vspace_for_pool 0 asid (K (asid_pool_of ao)) = Some vref" + and "\idx vref. option_map (swp pt_apply idx) (pt_of ao') = Some vref + \ option_map (swp pt_apply idx) (pt_of ao) = Some vref" + and "aa_type ao' = aa_type ao" + shows "vs_refs_aux lvl ao' \ vs_refs_aux lvl ao" + apply (insert assms) + apply (case_tac ao'; case_tac ao; + clarsimp simp: vs_refs_aux_def graph_of_def image_iff pt_type_def + split: pt.splits if_splits) + apply (erule_tac x="ucast ac" in allE) + apply (fastforce simp: asid_low_bits_of_def vspace_for_pool_def + entry_for_pool_def in_obind_eq ucast_ucast_id) + apply (erule_tac x="ucast ac" in allE) + apply (intro exI conjI; fastforce simp: ucast_ucast_id vs_index_bits_def) + apply (erule_tac x="ucast ac" in allE) + apply (intro exI conjI; fastforce simp: ucast_ucast_id vs_index_bits_def) + done + +lemma state_vrefs_subseteq: + assumes "typs_of s' x = typs_of s x" + and "pts_of s' = pts_of s" + and "\pptr asid. pool_for_asid asid s' = Some pptr \ pool_for_asid asid s = Some pptr" + and "\pptr asid vref. vspace_for_pool pptr asid (asid_pools_of s') = Some vref + \ vspace_for_pool pptr asid (asid_pools_of s) = Some vref" + shows "state_vrefs s' x \ state_vrefs s x" + apply (subst state_vrefs_def) + using assms(1) apply clarsimp + apply (case_tac "vspace_objs_of s x") + apply (fastforce simp: opt_map_def a_type_def + split: option.splits arch_kernel_obj.splits kernel_object.splits if_splits)[1] + apply (prop_tac "vs_refs_aux lvl ao \ vs_refs_aux lvl ac") + apply (rule vs_refs_aux_subseteq) + using assms(4) + apply (fastforce simp: opt_map_def aa_type_def vspace_for_pool_def entry_for_pool_def obind_def + split: option.splits arch_kernel_obj.splits) + using assms(2) + apply (clarsimp simp: in_opt_map_eq fun_eq_iff) + apply (erule_tac x=x in allE) + apply (fastforce simp: opt_map_def aa_type_def split: if_splits arch_kernel_obj.splits) + apply (fastforce simp: opt_map_def aa_type_def + split: option.splits arch_kernel_obj.splits) + apply (rule_tac state_vrefsD) + apply (erule vs_lookup_table_subseteq) + using assms by fastforce+ + +lemma pas_refined_subseteq: + "\ pas_refined aag s; caps_of_state s' = caps_of_state s; + \x y. asid_table s' x = Some y \ asid_table s x = Some y; + \x. state_vrefs s' x \ state_vrefs s x; interrupt_irq_node s' = interrupt_irq_node s; + domains_of_state s' = domains_of_state s; thread_st_auth s' = thread_st_auth s; + thread_bound_ntfns s' = thread_bound_ntfns s; cdt s' = cdt s \ + \ pas_refined aag s'" + apply (auto simp: pas_refined_def) + apply (clarsimp simp: state_objs_to_policy_def) + apply (erule subsetD) + apply (clarsimp simp: auth_graph_map_def) + apply (rule exI, rule conjI, rule refl)+ + apply (erule state_bits_to_policy_vrefs_subseteq; clarsimp) + apply (erule subsetD, rule state_asids_to_policy_vrefs_subseteq, auto) + done + lemma store_InvalidPTE_state_objs_in_policy: - "\\s. state_objs_in_policy aag s \ invs s \ table_base p \ global_refs s \ - ((\a. vspace_for_asid a s = Some (table_base p)) \ table_index p \ kernel_mapping_slots)\ - store_pte p InvalidPTE + "\\s. state_objs_in_policy aag s \ invs s\ + store_pte pt_t p InvalidPTE \\_ s. state_objs_in_policy aag s\" apply (rule hoare_weaken_pre) apply (clarsimp simp: state_objs_to_policy_def pred_conj_def) apply wps apply (rule state_vrefs_store_NonPageTablePTE_wp) + apply (intro conjI; fastforce?) + apply (intro allI impI) apply clarsimp apply (rule conjI; clarsimp) apply (intro exI conjI) @@ -364,32 +444,35 @@ lemma store_InvalidPTE_state_objs_in_policy: apply (case_tac "level = asid_pool_level") apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (frule vs_lookup_slot_level_type) + apply (fastforce simp: ptes_of_Some)+ apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) apply (erule state_vrefsD) - apply (fastforce simp: aobjs_of_Some obj_at_def) + apply (fastforce simp: pts_of_Some vspace_objs_of_Some obj_at_def) apply clarsimp - apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits) + apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits pt.splits) apply (clarsimp simp: state_objs_to_policy_def) apply (erule subsetD) apply (clarsimp simp: auth_graph_map_def) apply (rule exI, rule conjI, rule refl)+ apply (erule state_bits_to_policy_vrefs_subseteq; clarsimp) apply (case_tac "level = asid_pool_level") - apply (fastforce dest: vs_lookup_table_no_asid + apply (fastforce dest: vs_lookup_table_no_asid[where pt_t=pt_t] simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) - apply (frule level_of_table_vs_lookup_table) - apply (fastforce dest: vs_lookup_slot_no_asid + apply (frule level_of_table_vs_lookup_table[where pt_t=pt_t]) + apply (fastforce dest: vs_lookup_slot_no_asid[where pt_t=pt_t] simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def)+ apply (erule state_vrefsD) - apply (fastforce simp: aobjs_of_Some obj_at_def) + apply (fastforce simp: pts_of_Some vspace_objs_of_Some obj_at_def) apply clarsimp - apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits) + apply (auto simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits pt.splits) + apply fastforce + apply fastforce done lemma store_InvalidPTE_state_asids_to_policy: - "\\s. state_asids_to_policy aag s \ pasPolicy aag \ invs s \ table_base p \ global_refs s \ - ((\a. vspace_for_asid a s = Some (table_base p)) \ table_index p \ kernel_mapping_slots)\ - store_pte p InvalidPTE + "\\s. state_asids_to_policy aag s \ pasPolicy aag \ invs s\ + store_pte pt_t p InvalidPTE \\_ s. state_asids_to_policy aag s \ pasPolicy aag\" apply (rule hoare_weaken_pre) apply (clarsimp simp: state_objs_to_policy_def pred_conj_def) @@ -406,30 +489,34 @@ lemma store_InvalidPTE_state_asids_to_policy: apply (case_tac "level = asid_pool_level") apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (frule vs_lookup_slot_level_type) + apply (fastforce simp: ptes_of_Some)+ apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) apply (erule state_vrefsD) - apply (fastforce simp: aobjs_of_Some obj_at_def) + apply (fastforce simp: pts_of_Some vspace_objs_of_Some obj_at_def) apply clarsimp - apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits) + apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits pt.splits) apply (erule subsetD) apply (erule state_asids_to_policy_vrefs_subseteq; clarsimp) apply (case_tac "level = asid_pool_level") - apply (fastforce dest: vs_lookup_table_no_asid + apply (fastforce dest: vs_lookup_table_no_asid[where pt_t=pt_t] simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) - apply (frule level_of_table_vs_lookup_table) + apply (frule level_of_table_vs_lookup_table[where pt_t=pt_t]) apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def)+ apply (erule state_vrefsD) - apply (fastforce simp: aobjs_of_Some obj_at_def) + apply (fastforce simp: pts_of_Some vspace_objs_of_Some obj_at_def) apply clarsimp - apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits) + apply (auto simp: vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits pt.splits) + apply fastforce + apply fastforce done lemma mapM_x_swp_store_InvalidPTE_pas_refined: "\pas_refined aag and invs and - (\s. \x \ set slots. table_base x \ global_refs s \ - (\asid. vspace_for_asid asid s \ Some (table_base x)))\ - mapM_x (swp store_pte InvalidPTE) slots + (\s. \x \ set slots. table_base pt_t x \ global_refs s \ + (\asid. vspace_for_asid asid s \ Some (table_base pt_t x)))\ + mapM_x (swp (store_pte pt_t) InvalidPTE) slots \\_ s. pas_refined aag s\" supply state_asids_to_policy_arch_def[simp del] apply (rule hoare_strengthen_post) @@ -441,23 +528,25 @@ lemma mapM_x_swp_store_InvalidPTE_pas_refined: done lemma mapM_swp_store_pte_invs_unmap: - "\\s. invs s \ pte = InvalidPTE \ table_base p \ global_refs s - \ (\asid. vspace_for_asid asid s \ Some (table_base p))\ - store_pte p pte + "\\s. invs s \ pte = InvalidPTE \ table_base pt_t p \ global_refs s + \ (\asid. vspace_for_asid asid s \ Some (table_base pt_t p))\ + store_pte pt_t p pte \\_. invs\" by (wpsimp wp: store_pte_invs simp: wellformed_pte_def) lemma store_pte_pas_refined: - "\\s. pas_refined aag s \ invs s \ table_base p \ global_refs s \ - (\slot ref. caps_of_state s slot = Some (ArchObjectCap (PageTableCap (table_base p) ref))) \ - ((\asid. vspace_for_asid asid s = Some (table_base p)) \ table_index p \ kernel_mapping_slots)\ - store_pte p InvalidPTE + "\\s. pas_refined aag s \ invs s \ table_base pt_t p \ global_refs s \ + (\slot pt_t ref. caps_of_state s slot = Some (ArchObjectCap (PageTableCap (table_base pt_t p) pt_t ref)))\ + store_pte pt_t p InvalidPTE \\_. pas_refined aag\" supply state_asids_to_policy_arch_def[simp del] apply (clarsimp simp: pas_refined_def) apply (wpsimp wp: store_InvalidPTE_state_objs_in_policy store_InvalidPTE_state_asids_to_policy) done +crunch invalidate_tlb_by_asid + for pas_refined[wp]: "pas_refined aag" + lemma unmap_page_table_pas_refined: "\pas_refined aag and invs and K (vaddr \ user_region)\ unmap_page_table asid vaddr pt @@ -477,7 +566,6 @@ lemma unmap_page_table_pas_refined: apply (drule vs_lookup_table_valid_cap; clarsimp?) apply (fastforce simp: valid_cap_def valid_arch_cap_def valid_arch_cap_ref_def obj_at_def dest: caps_of_state_valid split: cap.splits arch_cap.splits) - apply (metis vs_lookup_table_vspace user_region_slots is_aligned_neg_mask2 pt_slot_offset_offset) done crunch unmap_page_table @@ -485,16 +573,16 @@ crunch unmap_page_table definition authorised_page_table_inv :: "'a PAS \ page_table_invocation \ bool" where "authorised_page_table_inv aag pti \ - case pti of PageTableMap cap cslot_ptr pde obj_ref \ - is_subject aag (fst cslot_ptr) \ is_subject aag (obj_ref && ~~ mask pt_bits) \ + case pti of PageTableMap cap cslot pte slot level \ + is_subject aag (fst cslot) \ is_subject aag (table_base (level_type level) slot) \ pas_cap_cur_auth aag (ArchObjectCap cap) - | PageTableUnmap cap cslot_ptr \ - is_subject aag (fst cslot_ptr) \ + | PageTableUnmap cap cslot \ + is_subject aag (fst cslot) \ aag_cap_auth aag (pasSubject aag) (ArchObjectCap cap) \ - (\p asid vspace_ref. cap = PageTableCap p (Some (asid, vspace_ref)) + (\p pt_t asid vspace_ref. cap = PageTableCap p pt_t (Some (asid, vspace_ref)) \ is_subject_asid aag asid \ - (\x \ set [p, p + 2 ^ pte_bits .e. p + 2 ^ pt_bits - 1]. - is_subject aag (x && ~~ mask pt_bits)))" + (\x \ set [p, p + 2 ^ pte_bits .e. p + 2 ^ (pt_bits pt_t) - 1]. + is_subject aag (table_base pt_t x)))" lemma perform_pt_inv_unmap_pas_refined: "\pas_refined aag and invs and valid_pti (PageTableUnmap cap ct_slot) @@ -503,11 +591,10 @@ lemma perform_pt_inv_unmap_pas_refined: \\_. pas_refined aag\" unfolding perform_pt_inv_unmap_def apply (wpsimp wp: set_cap_pas_refined get_cap_wp) - apply (strengthen invs_psp_aligned invs_vspace_objs invs_arch_state) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift) apply wps apply (rule hoare_vcg_all_lift[OF hoare_vcg_imp_lift'[OF mapM_x_wp_inv]], wpsimp wp: mapM_x_wp_inv) apply (rule hoare_vcg_conj_lift[OF hoare_strengthen_post[OF mapM_x_swp_store_InvalidPTE_pas_refined]], assumption) - apply (rule hoare_vcg_conj_lift[OF hoare_strengthen_post[OF mapM_x_swp_store_pte_invs_unmap]], assumption) apply (wpsimp wp: pt_lookup_from_level_wrp store_pte_invs_unmap store_pte_pas_refined mapM_x_wp_inv unmap_page_table_pas_refined hoare_vcg_imp_lift' hoare_vcg_ball_lift hoare_vcg_all_lift)+ @@ -518,13 +605,13 @@ lemma perform_pt_inv_unmap_pas_refined: valid_pti_def cte_wp_at_caps_of_state update_map_data_def aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def wellformed_mapdata_def cap_links_asid_slot_def cap_links_irq_def is_transferable.simps) - apply (prop_tac "table_base x = acap_obj cap") + apply (prop_tac "table_base NormalPT_T x = acap_obj cap") apply (drule (1) caps_of_state_aligned_page_table) 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 neg_mask_mono_le[where n="pt_bits NormalPT_T"]) + apply (drule neg_mask_mono_le[where n="pt_bits NormalPT_T"]) apply (fastforce dest: plus_mask_AND_NOT_mask_eq) apply (rule conjI; clarsimp) apply (fastforce simp: cte_wp_at_caps_of_state cap_range_def @@ -532,21 +619,27 @@ lemma perform_pt_inv_unmap_pas_refined: apply (frule vspace_for_asid_target) apply (drule valid_vs_lookupD; clarsimp) apply (drule (1) unique_table_refsD[rotated]; clarsimp) - apply (drule (1) cap_to_pt_is_pt_cap) - apply (clarsimp simp: in_omonad obj_at_def) + apply (clarsimp simp: obj_at_def) + apply (drule (1) cap_to_pt_is_pt_cap_and_type) + apply (fastforce simp: in_omonad obj_at_def) apply (fastforce intro: valid_objs_caps) apply (clarsimp simp: is_cap_simps) done +(* FIXME AARCH64: move *) +lemma fun_upd2_apply: + "(f (x, y := z)) a b = (if a = x \ b = y then z else f a b)" + by (clarsimp simp: fun_upd2_def) + lemma vs_lookup_PageTablePTE: "\ vs_lookup_table level asid vref s' = Some (lvl', pt); pspace_aligned s; valid_vspace_objs s; valid_asid_table s; - invalid_pte_at p s; ptes_of s' = (ptes_of s)(p \ pte); is_PageTablePTE pte; + invalid_pte_at pt_t p s; ptes_of s' = (ptes_of s)(pt_t,p \ pte); is_PageTablePTE pte; asid_pools_of s' = asid_pools_of s; asid_table s' = asid_table s; vref \ user_region; - pts_of s (the (pte_ref pte)) = Some empty_pt; pt \ pptr_from_pte pte \ + pts_of s (the (pte_ref pte)) = Some (empty_pt NormalPT_T); pt \ pptr_from_pte pte \ \ \level' \ level. vs_lookup_table level' asid vref s = Some (lvl', pt)" - apply (induct level arbitrary: lvl' pt rule: bit0.from_top_full_induct[where y=max_pt_level]) + apply (induct level arbitrary: lvl' pt rule: bit1.from_top_full_induct[where y=max_pt_level]) apply (fastforce simp: geq_max_pt_level vs_lookup_table_def pool_for_asid_def obind_def) apply (rule_tac x=lvl' in exI) apply (frule vs_lookup_min_level, clarsimp) @@ -558,9 +651,18 @@ lemma vs_lookup_PageTablePTE: apply (fastforce elim: le_less_trans dest: vm_level_less_plus_1_mono) apply (erule_tac x="lvl'+1" in allE) apply clarsimp - apply (frule subst[where s="ptes_of s'" and P="\ptes. ptes _ = _"]) - apply assumption - apply (drule mp, fastforce simp: pte_ref_def2 ptes_of_Some split: if_splits) + apply (frule (1) subst[where P="\ptes. _ ptes = (_ :: pte option)"]) + apply (clarsimp simp: fun_upd2_apply split: if_splits) + apply (cases pte; clarsimp) + apply (drule mp) + apply clarsimp + apply (case_tac "(lvl' + 1) + 1 \ max_pt_level") + apply (fastforce simp: add_ac ptes_of_Some dest!: pptr_from_pte_aligned_pt_bits[where pte=pte]) + apply (prop_tac "is_aligned (pptr_from_pte pte) (pt_bits (level_type (lvl' + 1)))") + apply (fastforce simp: geq_max_pt_level plus_one_eq_asid_pool max_pt_level_plus_one[symmetric] + vs_lookup_max_pt_level_eq[where s=s and s'=s'] less_imp_neq not_le add_ac + dest: vs_lookup_table_is_aligned[where pt_ptr="pptr_from_pte (PageTablePTE _)"]) + apply (clarsimp simp: ptes_of_Some) apply (cases pte; clarsimp) apply (drule_tac bot_level=level' in vs_lookup_level) apply (subst vs_lookup_split_Some) @@ -574,7 +676,7 @@ lemma vs_lookup_PageTablePTE: apply (subst (asm) pt_walk.simps) apply (clarsimp simp: obind_def) apply (subst pt_walk.simps) - apply (clarsimp split: if_splits simp: obind_def) + apply (clarsimp split: if_splits option.splits simp: obind_def) apply (fastforce dest: vm_level_less_le_1) apply (fastforce dest: vm_level_less_max_pt_level vm_level_less_plus_1_mono) apply (case_tac "lvl' = asid_pool_level") @@ -584,10 +686,10 @@ lemma vs_lookup_PageTablePTE: lemma vs_lookup_PageTablePTE': "\ vs_lookup_table level asid vref s = Some (lvl', pt); pspace_aligned s; valid_vspace_objs s; valid_asid_table s; - invalid_pte_at p s; ptes_of s' = (ptes_of s)(p \ pte); is_PageTablePTE pte; + invalid_pte_at pt_t p s; ptes_of s' = (ptes_of s)(pt_t, p \ pte); is_PageTablePTE pte; asid_pools_of s' = asid_pools_of s; asid_table s' = asid_table s; vref \ user_region \ \ \level' \ level. vs_lookup_table level' asid vref s' = Some (lvl', pt)" - apply (induct level arbitrary: lvl' pt rule: bit0.from_top_full_induct[where y=max_pt_level]) + apply (induct level arbitrary: lvl' pt rule: bit1.from_top_full_induct[where y=max_pt_level]) apply (fastforce simp: geq_max_pt_level vs_lookup_table_def pool_for_asid_def obind_def) apply (rule_tac x=lvl' in exI) apply (frule vs_lookup_min_level, clarsimp) @@ -615,6 +717,11 @@ lemma vs_lookup_PageTablePTE': apply (cases pte; clarsimp) apply (frule is_aligned_pt[rotated]) apply (erule vs_lookup_table_pt_at; fastforce) + apply (clarsimp split: option.splits) + apply (rule context_conjI) + apply (clarsimp simp: fun_upd2_def) + apply clarsimp + apply (clarsimp simp: fun_upd2_def split: if_splits) apply (clarsimp simp: invalid_pte_at_def ptes_of_Some pts_of_Some aobjs_of_Some) apply (fastforce dest: vm_level_less_le_1) apply (fastforce dest: vm_level_less_max_pt_level vm_level_less_plus_1_mono) @@ -628,17 +735,14 @@ lemma state_vrefs_store_PageTablePTE: and "vs_lookup_slot level asid vref s = Some (level, p)" and "vref \ user_region" and "is_PageTablePTE pte" - and "invalid_pte_at p s" - and "pts_of s (the (pte_ref pte)) = Some empty_pt" - and "the (pte_ref pte) \ table_base p" - and "kheap s (table_base p) = Some (ArchObj (PageTable pt))" - shows "state_vrefs (s\kheap := \a. if a = table_base p - then Some (ArchObj (PageTable (\a. if a = table_index p - then pte - else pt a))) - else kheap s a\) = - (\x. if x = table_base p - then vs_refs_aux level (PageTable (\a. if a = table_index p then pte else pt a)) + and "invalid_pte_at (pt_type pt) p s" + and "pts_of s (the (pte_ref pte)) = Some (empty_pt NormalPT_T)" + and "the (pte_ref pte) \ table_base (pt_type pt) p" + and "(kheap s)(table_base (pt_type pt) p) = Some (ArchObj (PageTable pt))" + shows "state_vrefs (s\kheap := (kheap s)(table_base (pt_type pt) p \ + ArchObj (PageTable (pt_upd pt (table_index (pt_type pt) p) pte)))\) = + (\x. if x = table_base (pt_type pt) p + then vs_refs_aux level (PageTable (pt_upd pt (table_index (pt_type pt) p) pte)) else state_vrefs s x)" (is "state_vrefs ?s' = _") using assms @@ -652,47 +756,100 @@ lemma state_vrefs_store_PageTablePTE: apply (clarsimp simp: state_vrefs_def opt_map_def split: option.splits) apply (case_tac "x = pptr_from_pte pte") apply (clarsimp simp: pte_ref_def2 split: if_splits) - apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def) + apply (fastforce simp: empty_pt_def vs_refs_aux_def graph_of_def pte_ref2_def split: if_splits pt.splits) apply (drule_tac s=s and pte=pte and p=p in vs_lookup_PageTablePTE) - apply (fastforce simp: pts_of_Some aobjs_of_Some opt_map_def pte_of_def obind_def - dest: pte_ptr_eq)+ + apply ((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def split: option.splits)+; fail)+ apply clarsimp apply (drule vs_lookup_level) apply (case_tac "lvl = asid_pool_level") - apply (fastforce dest: vs_lookup_asid_pool simp: asid_pools_of_ko_at obj_at_def) + apply (fastforce dest: vs_lookup_asid_pool simp: asid_pools_of_ko_at obj_at_def) + apply (frule vs_lookup_slot_level_type) + apply (fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some)+ apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) apply (fastforce dest: vs_lookup_table_unique_level split: if_splits) apply (clarsimp simp: state_vrefs_def opt_map_def) + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_asid_pool simp: asid_pools_of_ko_at obj_at_def) + apply (frule vs_lookup_slot_level_type) + apply ((fastforce simp: ptes_of_Some pts_of_Some aobjs_of_Some)+)[7] apply (frule vs_lookup_slot_table_base) apply clarsimp+ - apply (case_tac "x = table_base p"; clarsimp) - apply (drule_tac pte=pte and s'="?s'" in vs_lookup_PageTablePTE'; - fastforce dest: pte_ptr_eq simp: pts_of_Some aobjs_of_Some opt_map_def pte_of_def obind_def) - apply (drule_tac level=bot and pte=pte and s'="?s'" in vs_lookup_PageTablePTE'; - fastforce dest: pte_ptr_eq simp: pts_of_Some aobjs_of_Some opt_map_def pte_of_def obind_def) + apply (case_tac "x = table_base (pt_type pt) p"; clarsimp) + apply (drule_tac pte=pte and s'="?s'" in vs_lookup_PageTablePTE') + apply (((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def fun_upd2_def split: if_splits option.splits)+; fail)+)[10] + apply (drule_tac level=bot and pte=pte and s'="?s'" in vs_lookup_PageTablePTE') + apply (((fastforce simp: ptes_of_pts_of_upd ptes_of_Some pts_of_Some aobjs_of_Some + intro: ptes_of_pts_of_upd + dest: pte_ptr_eq split: if_splits + | clarsimp simp: opt_map_def fun_upd_def fun_upd2_def split: if_splits option.splits)+; fail)+)[10] done lemma state_vrefs_store_PageTablePTE_wp: - "\\s. invs s \ is_PageTablePTE pte \ invalid_pte_at p s \ - pts_of s (the (pte_ref pte)) = Some empty_pt \ the (pte_ref pte) \ table_base p \ + "\\s. invs s \ is_PageTablePTE pte \ invalid_pte_at pt_t p s \ + pts_of s (the (pte_ref pte)) = Some (empty_pt NormalPT_T) \ the (pte_ref pte) \ table_base pt_t p \ (\level asid vref. vs_lookup_slot level asid vref s = Some (level, p) \ vref \ user_region \ - (\pt. ako_at (PageTable pt) (table_base p) s \ - P (\x. if x = table_base p - then vs_refs_aux level (PageTable (\a. if a = table_index p - then pte - else pt a)) + (\pt. pts_of s (table_base pt_t p) = Some pt \ pt_t = pt_type pt \ is_aligned p pte_bits \ + P (\x. if x = table_base (pt_type pt) p + then vs_refs_aux level (PageTable (pt_upd pt (table_index (pt_type pt) p) pte)) else state_vrefs s x)))\ - store_pte p pte + store_pte pt_t p pte \\_ s. P (state_vrefs s)\" unfolding store_pte_def set_pt_def apply (wpsimp wp: set_object_wp) - apply (fastforce simp: fun_upd_def obj_at_def state_vrefs_store_PageTablePTE) + apply (subst state_vrefs_store_PageTablePTE; simp?) + apply (fastforce simp: fun_upd_def fun_upd2_def obj_at_def state_vrefs_store_PageTablePTE split: if_splits) + apply (clarsimp simp: pts_of_Some aobjs_of_Some obj_at_def) + done + +lemma pt_apply_def2: + "pt_apply pt = (\idx. case pt of NormalPT npt \ npt (ucast idx) | VSRootPT vs \ vs (ucast idx))" + by (fastforce simp: pt_apply_def) + +lemma pt_apply_upd_eq': + "pt_apply (pt_upd pt idx pte) idx' = + (if idx && mask (ptTranslationBits (pt_type pt)) = idx' && mask (ptTranslationBits (pt_type pt)) + then pte else pt_apply pt idx')" + by (fastforce simp: pt_apply_def pt_upd_def ucast_ucast_mask vs_index_bits_def ptTranslationBits_def + dest: arg_cong[where f="UCAST(vs_index_len \ 64)"] arg_cong[where f="UCAST(9 \ 64)"] + intro: ucast_up_inj[where 'b=64] + split: pt.splits) + +(* FIXME AARCH64: replace vs_refs_aux with this definition *) +lemma vs_refs_aux_def2: + "vs_refs_aux level = (\ko. case ko of + ASIDPool pool \ (\(r,p). (p, ucast r, AASIDPool, Control)) ` graph_of (option_map ap_vspace o pool) + | PageTable pt \ \(r,(p, sz, auth)) \ graph_of (pte_ref2 level o pt_apply pt). + (\(p, a). (p, r && mask (ptTranslationBits (pt_type pt)), APageTable (pt_type pt), a)) + ` (ptr_range p sz \ auth) + | _ \ {})" + apply (rule ext)+ + apply (rule equalityI) + apply (clarsimp simp: vs_refs_aux_def ) + apply (case_tac ko; clarsimp) + apply (case_tac x2; clarsimp simp: pt_apply_def2) + apply (clarsimp simp: graph_of_def image_iff) + apply (rule_tac x="UCAST(vs_index_len \ 64) ac" in exI) + apply (fastforce simp: ucast_and_mask_drop ucast_ucast_id vs_index_bits_def ptTranslationBits_def) + apply (clarsimp simp: graph_of_def image_iff) + apply (rule_tac x="UCAST(9 \ 64) ac" in exI) + apply (fastforce simp: ucast_and_mask_drop ucast_ucast_id vs_index_bits_def ptTranslationBits_def) + apply (clarsimp simp: vs_refs_aux_def) + apply (case_tac ko; clarsimp) + apply (case_tac x2; clarsimp simp: pt_apply_def2) + apply (fastforce simp: graph_of_def image_iff ucast_ucast_mask vs_index_bits_def ptTranslationBits_def) + apply (fastforce simp: graph_of_def image_iff ucast_ucast_mask vs_index_bits_def ptTranslationBits_def) done lemma perform_pt_inv_map_pas_refined[wp]: - "\pas_refined aag and invs and valid_pti (PageTableMap acap (a, b) pte p) - and K (authorised_page_table_inv aag (PageTableMap acap (a, b) pte p))\ - perform_pt_inv_map acap (a,b) pte p + "\pas_refined aag and invs and valid_pti (PageTableMap acap (a, b) pte p level) + and K (authorised_page_table_inv aag (PageTableMap acap (a, b) pte p level))\ + perform_pt_inv_map acap (a,b) pte p level \\_. pas_refined aag\" unfolding perform_pt_inv_map_def apply (rule hoare_gen_asm) @@ -717,7 +874,7 @@ lemma perform_pt_inv_map_pas_refined[wp]: apply (frule (2) vs_lookup_table_is_aligned; clarsimp) apply (drule (1) vs_lookup_table_target) apply (drule valid_vs_lookupD, erule vref_for_level_user_region; clarsimp) - apply (frule (1) cap_to_pt_is_pt_cap, simp, fastforce intro: valid_objs_caps) + apply (frule (1) cap_to_pt_is_pt_cap_and_type, simp, fastforce intro: valid_objs_caps) apply (clarsimp simp: cte_wp_at_caps_of_state) apply (clarsimp simp: is_cap_simps is_arch_update_def cap_master_cap_def split: cap.splits arch_cap.splits) @@ -733,17 +890,19 @@ lemma perform_pt_inv_map_pas_refined[wp]: apply (fastforce dest: sbta_ts simp: state_objs_to_policy_def) apply (fastforce dest: sbta_bounds simp: state_objs_to_policy_def) apply (clarsimp simp: state_objs_to_policy_def is_arch_update_def cap_master_cap_def) - apply (drule_tac caps="caps_of_state s" in sbta_cdt; fastforce elim: is_transferable.cases - split: if_splits) + apply (drule_tac caps="caps_of_state s" in sbta_cdt; + fastforce elim: is_transferable.cases split: if_splits) apply (fastforce dest: sbta_cdt_transferable simp: state_objs_to_policy_def) apply (clarsimp split: if_splits) - apply (clarsimp simp: authorised_page_table_inv_def vs_refs_aux_def split: arch_kernel_obj.splits) - apply (erule swap) - apply (clarsimp simp: graph_of_def pte_ref2_def split: if_split_asm) - apply (cases pte; clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (clarsimp simp: authorised_page_table_inv_def split: arch_kernel_obj.splits) + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (cases pte; clarsimp) + apply (clarsimp simp: vs_refs_aux_def2 graph_of_def) + apply (clarsimp simp: pt_apply_upd_eq' split: if_splits) + apply (clarsimp simp: pte_ref2_def pptr_from_pte_def) apply (erule subsetD) apply (clarsimp simp: auth_graph_map_def state_objs_to_policy_def) - apply (rule_tac x="table_base p" in exI, rule conjI, erule sym) + apply (rule_tac x="table_base (pt_type pt) p" in exI, rule conjI, erule sym) apply (rule exI, rule conjI, rule refl) apply (rule sbta_vref) apply (case_tac "level = asid_pool_level") @@ -751,9 +910,10 @@ lemma perform_pt_inv_map_pas_refined[wp]: simp: vs_lookup_slot_def vs_lookup_table_def invalid_pte_at_def) apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) apply (erule state_vrefsD) - apply (fastforce simp: aobjs_of_Some obj_at_def) + apply (fastforce simp: pts_of_Some vspace_objs_of_Some obj_at_def) apply clarsimp - apply (fastforce simp: vs_refs_aux_def graph_of_def pte_ref2_def) + apply (fastforce simp: vs_refs_aux_def2 graph_of_def) + (* slow ~60s *) apply (clarsimp simp: is_arch_update_def cap_master_cap_def split: cap.splits arch_cap.splits option.splits) apply (fastforce dest: sbta_vref simp: pas_refined_def auth_graph_map_def state_objs_to_policy_def) @@ -765,7 +925,7 @@ lemma perform_pt_inv_map_pas_refined[wp]: cap_links_asid_slot_def label_owns_asid_slot_def) apply (fastforce dest: sata_asid) apply (clarsimp split: if_splits) - apply (fastforce dest!: state_asids_to_policy_aux.intros simp: vs_refs_aux_def) + apply (fastforce dest!: state_asids_to_policy_aux.intros simp: vs_refs_aux_def split: pt.splits) apply (fastforce dest!: sata_asid_lookup) apply (fastforce dest!: sata_asidpool) apply (clarsimp simp: pas_refined_def) @@ -786,7 +946,7 @@ lemma perform_page_table_invocation_pas_refined: (* FIXME move to AInvs *) lemma store_pte_ekheap[wp]: - "store_pte p pte \\s. P (ekheap s)\" + "store_pte pt_t p pte \\s. P (ekheap s)\" apply (simp add: store_pte_def set_pt_def) apply (wp get_object_wp) apply simp @@ -810,20 +970,13 @@ lemma set_asid_pool_thread_bound_ntfns[wp]: split: kernel_object.split_asm option.split) done -(* FIXME move to AInvs *) -lemma set_asid_pool_ekheap[wp]: - "set_asid_pool p pool \\s. P (ekheap s)\" - apply (simp add: set_asid_pool_def) - apply (wp get_object_wp | simp)+ - done - crunch set_asid_pool for integrity_autarch: "integrity aag X st" (wp: crunch_wps) lemma store_pte_respects: - "\integrity aag X st and K (is_subject aag (table_base p))\ - store_pte p pte + "\integrity aag X st and K (is_subject aag (table_base pt_t p))\ + store_pte pt_t p pte \\_. integrity aag X st\" apply (simp add: store_pte_def set_pt_def) apply (wp get_object_wp set_object_integrity_autarch) @@ -831,17 +984,12 @@ lemma store_pte_respects: done lemma integrity_arch_state[iff]: - "riscv_asid_table v = riscv_asid_table (arch_state s) + "arm_asid_table v = arm_asid_table (arch_state s) \ integrity aag X st (s\arch_state := v\) = integrity aag X st s" unfolding integrity_def by simp -lemma integrity_riscv_global_pts[iff]: - "integrity aag X st (s\arch_state := ((arch_state s)\riscv_global_pts := v\)\) = - integrity aag X st s" - unfolding integrity_def by simp - lemma integrity_riscv_kernel_vspace[iff]: - "integrity aag X st (s\arch_state := ((arch_state s)\riscv_kernel_vspace := v\)\) = + "integrity aag X st (s\arch_state := ((arch_state s)\arm_kernel_vspace := v\)\) = integrity aag X st s" unfolding integrity_def by simp @@ -864,7 +1012,8 @@ lemma pt_walk_is_subject: level \ max_pt_level; vptr \ user_region; is_subject aag pt_ptr \ \ is_subject aag pt" apply (induct level arbitrary: pt_ptr; clarsimp) - apply (erule_tac x="pptr_from_pte (the (ptes_of s (pt_slot_offset level pt_ptr vptr)))" in meta_allE) + apply (erule_tac x="pptr_from_pte (the (ptes_of s (level_type level) (pt_slot_offset level pt_ptr vptr)))" + in meta_allE) apply (subst (asm) pt_walk.simps) apply (clarsimp simp: obind_def split: if_splits option.splits) apply (drule meta_mp) @@ -872,22 +1021,18 @@ lemma pt_walk_is_subject: apply (subst pt_walk.simps, clarsimp simp: obind_def) apply clarsimp apply (erule meta_mp) - apply (frule vs_lookup_table_pt_at; clarsimp simp: pt_at_eq) + apply (subst (asm) ptes_of_Some) + apply (frule vs_lookup_table_is_aligned; clarsimp) apply (erule (1) is_subject_trans) apply (clarsimp simp: pas_refined_def auth_graph_map_def) apply (erule subsetD, clarsimp) apply (rule exI conjI refl sta_vref)+ apply (erule state_vrefsD) - apply (fastforce simp: pts_of_Some) + apply (fastforce simp: vspace_objs_of_Some pts_of_Some) apply clarsimp - apply (frule_tac pt_ptr=pt_ptr in pspace_aligned_pts_ofD, simp) - apply (clarsimp simp: ptes_of_def obind_def is_PageTablePTE_def vs_refs_aux_def split: option.splits) - apply (drule_tac g=y and f="pte_ref2 level" in graph_of_comp) - apply (fastforce simp: pte_ref2_def) - apply (fastforce simp: aobjs_of_Some pts_of_Some pptr_from_pte_def - dest: table_index_max_level_slots - elim: rev_bexI bexI_minus[rotated] - intro!: pts_of_Some_alignedD) + apply (clarsimp simp: vs_refs_aux_def2 graph_of_def) + apply (rule_tac x="pt_index level vptr" in exI) + apply (fastforce simp: pptr_from_pte_def pte_ref2_def split: pte.splits) done lemma pt_lookup_slot_from_level_is_subject: @@ -895,16 +1040,19 @@ lemma pt_lookup_slot_from_level_is_subject: pt_lookup_slot_from_level level bot_level pt_ptr vptr (ptes_of s) = Some (level', pt); (\asid. vs_lookup_table level asid vptr s = Some (level, pt_ptr)); level \ max_pt_level; vptr \ user_region; is_subject aag pt_ptr \ - \ is_subject aag (table_base pt)" - by (fastforce dest: pt_walk_is_aligned vs_lookup_table_is_aligned pt_walk_is_subject - simp: pt_lookup_slot_from_level_def obind_def split: option.splits) + \ is_subject aag (table_base (level_type level') pt)" + apply (clarsimp simp: pt_lookup_slot_from_level_def) + apply (frule vs_lookup_table_is_aligned, fastforce+) + apply (frule pt_walk_is_aligned, fastforce+) + apply (frule pt_walk_is_subject, fastforce+) + done lemma pt_lookup_from_level_is_subject: "\\s. pas_refined aag s \ pspace_aligned s \ valid_vspace_objs s \ valid_asid_table s \ is_subject aag pt_ptr \ level \ max_pt_level \ vref \ user_region \ (\asid. vs_lookup_table level asid vref s = Some (level, pt_ptr))\ pt_lookup_from_level level pt_ptr vref pt - \\rv _. is_subject aag (table_base rv)\, -" + \\(rv,lvl) _. is_subject aag (table_base (level_type lvl) rv)\, -" apply (wpsimp wp: pt_lookup_from_level_wp) apply (erule_tac level=level and bot_level=levela and pt_ptr=pt_ptr and vptr=vref in pt_lookup_slot_from_level_is_subject) @@ -915,23 +1063,24 @@ lemma unmap_page_table_respects: and K (is_subject_asid aag asid \ vaddr \ user_region)\ unmap_page_table asid vaddr pt \\_. integrity aag X st\" - apply (simp add: unmap_page_table_def sfence_def) - apply (wpsimp wp: pt_lookup_from_level_is_subject dmo_mol_respects hoare_vcg_conj_liftE_weaker - store_pte_respects pt_lookup_from_level_wrp[where Q="\_. integrity aag X st"] - | wp (once) hoare_drop_imps hoare_vcg_conj_elimE)+ - apply (intro conjI; clarsimp) - apply fastforce + unfolding unmap_page_table_def invalidate_tlb_by_asid_def + apply (wpsimp wp: dmo_no_mem_respects store_pte_respects Nondet_VCG.hoare_vcg_all_liftE + simp: imp_conjR + | rule hoare_strengthen_postE_R[OF pt_lookup_from_level_is_subject], fastforce + | rule hoare_vcg_conj_elimE hoare_vcg_conj_liftE_R hoare_drop_imps)+ + apply (intro conjI; clarsimp?) apply (rule aag_Control_into_owns[rotated], assumption) apply (drule sym) - apply (clarsimp simp: vspace_for_asid_def obj_at_def pas_refined_def) + apply (clarsimp simp: vspace_for_asid_def entry_for_asid_def obj_at_def pas_refined_def) apply (erule_tac A="state_asids_to_policy_aux _ _ _ _" in subsetD) apply (rule sata_asid_lookup) - apply (simp add: vspace_for_pool_def pool_for_asid_def) - apply (clarsimp simp: vspace_for_pool_def) + apply (simp add: vspace_for_pool_def pool_for_asid_def) + apply (clarsimp simp: entry_for_pool_def vspace_for_pool_def) apply (drule pool_for_asid_vs_lookupD) apply (erule state_vrefsD) - apply (fastforce simp: aobjs_of_Some asid_pools_of_ko_at obj_at_def) + apply (fastforce simp: vspace_objs_of_Some aobjs_of_Some asid_pools_of_ko_at obj_at_def) apply assumption + apply (clarsimp simp: vs_refs_aux_def) apply (fastforce simp: vs_refs_aux_def graph_of_def asid_low_bits_of_mask_eq[symmetric] word_size ucast_ucast_b is_up_def source_size_def target_size_def) apply (fastforce dest: vs_lookup_table_vref_independent[OF vspace_for_asid_vs_lookup]) @@ -948,15 +1097,16 @@ lemma perform_page_table_invocation_respects: cap.case_cong arch_cap.case_cong) apply (cases page_table_invocation; clarsimp) apply (wpsimp wp: set_cap_integrity_autarch store_pte_respects - simp: authorised_page_table_inv_def sfence_def) + simp: authorised_page_table_inv_def cleanByVA_PoU_def) apply (rename_tac cap fst_cslot_ptr snd_cslot_ptr) - apply (wpsimp wp: set_cap_integrity_autarch) + apply (wpsimp wp: set_cap_integrity_autarch simp:cleanCacheRange_PoU_def) apply (rule_tac I="\s. integrity aag X st s \ is_subject aag fst_cslot_ptr \ is_PageTableCap cap" in mapM_x_inv_wp; clarsimp) apply (rule_tac P="\s. integrity aag X st s \ is_PageTableCap cap" in hoare_vcg_conj_lift) apply (wpsimp wp: store_pte_respects) apply (clarsimp simp: authorised_page_table_inv_def) apply (case_tac cap; clarsimp) + apply (metis add_mask_fold) apply (wpsimp wp: unmap_page_table_respects)+ apply (clarsimp simp: authorised_page_table_inv_def valid_pti_def valid_arch_cap_def wellformed_acap_def wellformed_mapdata_def @@ -968,13 +1118,21 @@ lemma perform_pg_inv_get_addr_pas_refined [wp]: perform_pg_inv_get_addr ptr \\_. pas_refined aag\" unfolding perform_pg_inv_get_addr_def - by wpsimp + by wp auto + +lemma store_pte_vmid_for_asid[wp]: + " store_pte pt_t p pte + \\s. P (vmid_for_asid s asid)\" + apply (simp add: store_pte_def set_pt_def) + apply (wp get_object_wp set_object_wp) + by (auto simp: obj_at_def opt_map_def vmid_for_asid_def obind_def entry_for_pool_def + split: if_splits option.splits) lemma unmap_page_pas_refined: "\pas_refined aag and invs and K (vptr \ user_region)\ unmap_page pgsz asid vptr pptr \\_. pas_refined aag\" - unfolding unmap_page_def + unfolding unmap_page_def invalidate_tlb_by_asid_va_def cleanByVA_PoU_def apply (clarsimp simp: conj_ac | wpsimp wp: set_cap_pas_refined_not_transferable hoare_vcg_all_lift hoare_vcg_imp_lift' get_cap_wp store_pte_pas_refined store_pte_valid_arch_state_unreachable)+ @@ -989,25 +1147,24 @@ lemma unmap_page_pas_refined: apply (drule vs_lookup_table_valid_cap; clarsimp?) apply (fastforce simp: valid_cap_def valid_arch_cap_def valid_arch_cap_ref_def obj_at_def dest: caps_of_state_valid split: cap.splits arch_cap.splits) - apply (metis vs_lookup_table_vspace user_region_slots is_aligned_neg_mask2 pt_slot_offset_offset) done -definition authorised_slots :: "'a PAS \ pte \ obj_ref \ 's :: state_ext state \ bool" where - "authorised_slots aag m s \ case m of (pte, slot) \ +definition authorised_slots :: "'a PAS \ pte \ obj_ref \ vm_level \ 's :: state_ext state \ bool" where + "authorised_slots aag m s \ case m of (pte, slot, lvl) \ (\level asid vref x. vs_lookup_slot level asid vref s = Some (level, slot) \ vref \ user_region \ level \ max_pt_level \ pte_ref2 level pte = Some x \ (\a \ snd (snd x). \p \ ptr_range (fst x) (fst (snd x)). aag_has_auth_to aag a p)) \ - is_subject aag (table_base slot)" + is_subject aag (table_base (level_type lvl) slot)" definition authorised_page_inv :: "'a PAS \ page_invocation \ 's :: state_ext state \ bool" where "authorised_page_inv aag pgi s \ case pgi of PageMap cap ptr slots \ pas_cap_cur_auth aag (ArchObjectCap cap) \ is_subject aag (fst ptr) \ authorised_slots aag slots s | PageUnmap cap ptr \ pas_cap_cur_auth aag (ArchObjectCap cap) \ is_subject aag (fst ptr) - | PageGetAddr ptr \ True" + | _ \ True" lemma perform_pg_inv_unmap_pas_refined: "\pas_refined aag and invs and valid_page_inv (PageUnmap cap ct_slot) @@ -1059,65 +1216,86 @@ lemma set_cap_same_ref[wp]: done lemma perform_pg_inv_map_pas_refined: - "\pas_refined aag and invs and valid_page_inv (PageMap cap ct_slot (pte,slot)) - and authorised_page_inv aag (PageMap cap ct_slot (pte,slot))\ - perform_pg_inv_map cap ct_slot pte slot + "\pas_refined aag and invs and valid_page_inv (PageMap cap ct_slot (pte,slot,level)) + and authorised_page_inv aag (PageMap cap ct_slot (pte,slot,level))\ + perform_pg_inv_map cap ct_slot pte slot level \\_. pas_refined aag\" - unfolding perform_pg_inv_map_def - apply (wpsimp simp: simp: pas_refined_def state_objs_to_policy_def) - apply (subst conj_commute, subst conj_commute) - apply clarsimp - apply (rule hoare_vcg_conj_lift, wpsimp) - apply wps - apply (rule state_vrefs_store_NonPageTablePTE_wp) - apply (rule_tac Q'="\_. invs and pas_refined aag and K (\ is_PageTablePTE pte) - and authorised_page_inv aag (PageMap cap ct_slot (pte,slot)) - and same_ref (pte,slot) (ArchObjectCap cap)" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pas_refined_def) - apply (rule conjI) - apply clarsimp - apply (intro exI, rule conjI, assumption) - apply clarsimp + unfolding perform_pg_inv_map_def invalidate_tlb_by_asid_va_def cleanCacheRange_PoU_def cleanByVA_PoU_def + apply wp + apply wpsimp + apply wp + apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_imp_lift) + apply (rule_tac Q'="\_. pas_refined aag" in hoare_strengthen_post) + apply (simp add: pas_refined_def state_objs_to_policy_def) + apply wp + apply wps + apply (rule state_vrefs_store_NonPageTablePTE_wp) + apply (clarsimp simp: pas_refined_def) + apply (rule_tac Q'="\_. invs and pas_refined aag and K (\ is_PageTablePTE pte) + and authorised_page_inv aag (PageMap cap ct_slot (pte,slot,level)) + and same_ref (pte,slot,level) (ArchObjectCap cap)" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: pas_refined_def) apply (rule conjI) apply clarsimp - apply (erule_tac A="state_asids_to_policy_aux _ _ _ _" in subsetD) - apply (erule state_asids_to_policy_aux.cases) - apply (fastforce dest: sata_asid) - apply (clarsimp simp: cte_wp_at_caps_of_state) - apply (clarsimp simp only: split: if_splits) - apply (clarsimp simp: vs_refs_aux_def) - apply (erule sata_asid_lookup) - apply assumption - apply (fastforce dest: sata_asidpool) - apply (clarsimp simp: auth_graph_map_def authorised_page_inv_def) - apply (erule state_bits_to_policy.cases) - apply (fastforce dest: sbta_caps simp: state_objs_to_policy_def) - apply (fastforce dest: sbta_untyped simp: state_objs_to_policy_def) - apply (fastforce dest: sbta_ts simp: state_objs_to_policy_def) - apply (fastforce dest: sbta_bounds simp: state_objs_to_policy_def) - apply (fastforce dest: sbta_cdt simp: state_objs_to_policy_def) - apply (fastforce dest: sbta_cdt_transferable simp: state_objs_to_policy_def) - apply (clarsimp split: if_split_asm) - apply (clarsimp simp: vs_refs_aux_def graph_of_def) - apply (erule_tac P="_ \ _" in swap) - apply (case_tac "level = asid_pool_level") - apply (fastforce dest!: vs_lookup_slot_no_asid - simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (intro exI, rule conjI, assumption) + apply clarsimp + apply (rule conjI) + prefer 2 + apply clarsimp + apply (erule_tac A="state_asids_to_policy_aux _ _ _ _" in subsetD) + apply (erule state_asids_to_policy_aux.cases) + apply (fastforce dest: sata_asid) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (clarsimp simp only: split: if_splits) + apply (clarsimp simp: vs_refs_aux_def split: pt.splits) + apply (erule sata_asid_lookup) + apply assumption + apply (fastforce dest: sata_asidpool) + apply (clarsimp simp: auth_graph_map_def authorised_page_inv_def) + apply (erule state_bits_to_policy.cases) + apply (fastforce dest: sbta_caps simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_untyped simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_ts simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_bounds simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_cdt simp: state_objs_to_policy_def) + apply (fastforce dest: sbta_cdt_transferable simp: state_objs_to_policy_def) apply (clarsimp split: if_split_asm) - apply (case_tac pte; clarsimp simp: authorised_slots_def) - apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) - apply (erule subsetD) - apply (clarsimp simp: state_objs_to_policy_def) - apply (rule exI, rule conjI, rule refl)+ - apply (rule sbta_vref) - apply (erule state_vrefsD) - apply (fastforce simp: aobjs_of_Some obj_at_def) - apply fastforce - apply (fastforce simp: vs_refs_aux_def graph_of_def) - apply (fastforce dest: sbta_vref simp: state_objs_to_policy_def) - apply (clarsimp simp: same_ref_def) - apply (wpsimp wp: arch_update_cap_invs_map set_cap_pas_refined_not_transferable) + apply (clarsimp simp: vs_refs_aux_def) + apply (case_tac "levela = asid_pool_level") + apply (fastforce dest!: vs_lookup_slot_no_asid + simp: ptes_of_Some pts_of_Some aobjs_of_Some obj_at_def) + apply (clarsimp simp: pt_upd_def split: pt.splits) + apply (clarsimp simp: graph_of_def split: if_split_asm) + apply (case_tac pte; clarsimp simp: authorised_slots_def) + apply (clarsimp simp: same_ref_def) + apply (drule (1) vs_lookup_slot_unique_level; clarsimp) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (erule subsetD) + apply (clarsimp simp: state_objs_to_policy_def) + apply (rule exI, rule conjI, rule refl)+ + apply (rule sbta_vref) + apply (erule state_vrefsD) + apply (fastforce simp: ptes_of_Some pts_of_Some vspace_objs_of_Some obj_at_def) + apply fastforce + apply (fastforce simp: vs_refs_aux_def graph_of_def) + apply (clarsimp simp: graph_of_def split: if_split_asm) + apply (case_tac pte; clarsimp simp: authorised_slots_def level_type_def) + apply (clarsimp simp: same_ref_def) + apply (drule (1) vs_lookup_slot_unique_level; clarsimp) + apply (subst (asm) vs_lookup_slot_table_unfold; clarsimp) + apply (erule subsetD) + apply (clarsimp simp: state_objs_to_policy_def level_type_def) + apply (rule exI, rule conjI, rule refl)+ + apply (rule sbta_vref) + apply (erule state_vrefsD) + apply (fastforce simp: ptes_of_Some pts_of_Some vspace_objs_of_Some obj_at_def) + apply fastforce + apply (fastforce simp: vs_refs_aux_def graph_of_def) + apply (fastforce dest: sbta_vref simp: state_objs_to_policy_def) + apply (clarsimp simp: same_ref_def) + apply (wpsimp wp: arch_update_cap_invs_map set_cap_pas_refined_not_transferable) + apply wp apply (clarsimp simp: valid_page_inv_def authorised_page_inv_def cte_wp_at_caps_of_state is_frame_cap_def is_arch_update_def cap_master_cap_def split: arch_cap.splits) @@ -1131,7 +1309,7 @@ lemma perform_page_invocation_pas_refined: "\pas_refined aag and invs and authorised_page_inv aag pgi and valid_page_inv pgi\ perform_page_invocation pgi \\_. pas_refined aag\" - apply (simp add: perform_page_invocation_def) + unfolding perform_page_invocation_def perform_flush_def apply (wpsimp wp: perform_pg_inv_map_pas_refined perform_pg_inv_unmap_pas_refined) apply auto done @@ -1147,18 +1325,16 @@ lemma unmap_page_respects: apply (rule hoare_pre) apply (wpsimp wp: store_pte_respects hoare_drop_imps[where Q="\rv. integrity aag X st"] - simp: sfence_def is_aligned_mask[symmetric] + simp: is_aligned_mask[symmetric] cleanByVA_PoU_def + invalidate_tlb_by_asid_va_def invalidateTranslationSingle_def | wp (once) hoare_drop_imps - mapM_set''[where f="(\a. store_pte a InvalidPTE)" - and I="\x s. is_subject aag (x && ~~ mask pt_bits)" - and Q="integrity aag X st"] | wp (once) hoare_drop_imps[where Q'="\rv s. rv"])+ apply (clarsimp simp: pt_lookup_slot_def) apply (frule pt_lookup_slot_from_level_is_subject) apply (fastforce simp: valid_arch_state_asid_table dest: vs_lookup_table_vref_independent[OF vspace_for_asid_vs_lookup])+ apply (erule (1) is_subject_asid_trans) - apply (clarsimp simp: pas_refined_def vspace_for_asid_def vspace_for_pool_def) + apply (clarsimp simp: pas_refined_def entry_for_asid_def entry_for_pool_def vspace_for_asid_def) apply (erule subsetD[where A="state_asids_to_policy_aux _ _ _ _"]) apply (rule sata_asid_lookup) apply (fastforce simp: pool_for_asid_def) @@ -1171,6 +1347,14 @@ lemma unmap_page_respects: apply simp done +lemma set_cap_vmid_for_asid[wp]: + "set_cap cap cslot + \\s. P (vmid_for_asid s asid)\" + apply (simp add: set_cap_def) + apply (wpsimp wp: get_object_wp set_object_wp) + by (auto simp: obj_at_def opt_map_def vmid_for_asid_def obind_def entry_for_pool_def + split: if_splits option.splits) + lemma perform_page_invocation_respects: "\integrity aag X st and pas_refined aag and authorised_page_inv aag pgi and valid_page_inv pgi and valid_vspace_objs @@ -1184,44 +1368,39 @@ proof - apply (unfold authorised_page_inv_def) apply (simp add: perform_page_invocation_def mapM_discarded swp_def valid_page_inv_def valid_unmap_def authorised_page_inv_def authorised_slots_def - perform_pg_inv_map_def perform_pg_inv_unmap_def sfence_def + perform_pg_inv_map_def perform_pg_inv_unmap_def + invalidate_tlb_by_asid_va_def invalidateTranslationSingle_def + cleanByVA_PoU_def perform_flush_def do_flush_def split: page_invocation.split sum.split arch_cap.split option.split, safe) - apply ((wp set_cap_integrity_autarch unmap_page_respects - mapM_x_and_const_wp[OF store_pte_respects] store_pte_respects - | elim conjE - | clarsimp dest!: set_tl_subset_mp - | wpc)+) - apply (rule conjI) - apply (case_tac m; clarsimp) - apply (clarsimp simp: aag_cap_auth_def cte_wp_at_caps_of_state) - apply (prop_tac "a \ acap_asid' (FrameCap r R sz dev (Some (a,b)))", clarsimp) - apply (drule (1) sata_asid[where aag=aag]) - apply (clarsimp simp: pas_refined_def) - apply (drule (1) subsetD) - apply (fastforce dest: aag_wellformed_Control) - apply (fastforce simp: valid_arch_cap_def wellformed_mapdata_def split: if_splits) - apply (wpsimp wp: set_mrs_integrity_autarch set_message_info_integrity_autarch - simp: ipc_buffer_has_auth_def perform_pg_inv_get_addr_def) + apply ((wp set_cap_integrity_autarch unmap_page_respects + mapM_x_and_const_wp[OF store_pte_respects] store_pte_respects + hoare_vcg_if_lift hoare_vcg_imp_lift hoare_vcg_ex_lift hoare_vcg_disj_lift + | elim conjE + | clarsimp dest!: set_tl_subset_mp split del: if_split + | wpc)+) + apply (rule conjI) + apply (case_tac m; clarsimp) + apply (clarsimp simp: aag_cap_auth_def cte_wp_at_caps_of_state) + apply (prop_tac "a \ acap_asid' (FrameCap r R sz dev (Some (a,b)))", clarsimp) + apply (drule (1) sata_asid[where aag=aag]) + apply (clarsimp simp: pas_refined_def) + apply (drule (1) subsetD) + apply (fastforce dest: aag_wellformed_Control) + apply (fastforce simp: valid_arch_cap_def wellformed_mapdata_def split: if_splits) + apply (wpsimp wp: set_mrs_integrity_autarch set_message_info_integrity_autarch dmo_no_mem_respects + simp: ipc_buffer_has_auth_def perform_pg_inv_get_addr_def)+ done qed -lemma integrity_asid_table_entry_update': - "\ integrity aag X st s; atable = riscv_asid_table (arch_state s); is_subject aag v; - (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of asid \ is_subject_asid aag asid') \ - \ integrity aag X st (s\arch_state := - arch_state s\riscv_asid_table := \a. if a = asid_high_bits_of asid - then (Some v) - else atable a\\)" - by (clarsimp simp: integrity_def) - lemma asid_table_entry_update_integrity: - "\integrity aag X st and (\s. atable = riscv_asid_table (arch_state s)) and K (is_subject aag v) - and K (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of asid - \ is_subject_asid aag asid')\ - modify (\s. s\arch_state := arch_state s\riscv_asid_table := atable(asid_high_bits_of asid := Some v)\\) + "\\s. integrity aag X st s \ atable = arm_asid_table (arch_state s) + \ (\v. vopt = Some v \ is_subject aag v) + \ (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of asid + \ is_subject_asid aag asid')\ + modify (\s. s\arch_state := arch_state s\arm_asid_table := atable(asid_high_bits_of asid := vopt)\\) \\_. integrity aag X st\" - by wpsimp (blast intro: integrity_asid_table_entry_update') + by (wpsimp simp: integrity_def) definition authorised_asid_control_inv :: "'a PAS \ asid_control_invocation \ bool" where "authorised_asid_control_inv aag aci \ @@ -1236,9 +1415,9 @@ lemma perform_asid_control_invocation_respects: \\_. integrity aag X st\" apply (simp add: perform_asid_control_invocation_def) apply (wpc, simp) - apply (wpsimp wp: set_cap_integrity_autarch cap_insert_integrity_autarch - asid_table_entry_update_integrity retype_region_integrity[where sz=12] - hoare_weak_lift_imp delete_objects_valid_vspace_objs delete_objects_valid_arch_state) + apply (wpsimp wp: hoare_weak_lift_imp set_cap_integrity_autarch asid_table_entry_update_integrity + cap_insert_integrity_autarch retype_region_integrity[where sz=12] + delete_objects_valid_vspace_objs delete_objects_valid_arch_state) apply (clarsimp simp: authorised_asid_control_inv_def ptr_range_def add.commute range_cover_def obj_bits_api_def default_arch_object_def pageBits_def word_bits_def) apply (subst is_aligned_neg_mask_eq[THEN sym], assumption) @@ -1249,7 +1428,7 @@ lemma perform_asid_control_invocation_respects: lemma state_vrefs_asid_pool_map: "\ ako_at (ASIDPool Map.empty) frame s; asid_table s (asid_high_bits_of base) = None \ - \ state_vrefs (s\arch_state := arch_state s\riscv_asid_table := \a. if a = asid_high_bits_of base + \ state_vrefs (s\arch_state := arch_state s\arm_asid_table := \a. if a = asid_high_bits_of base then Some frame else asid_table s a\\) = state_vrefs s" @@ -1258,8 +1437,8 @@ lemma state_vrefs_asid_pool_map: apply safe apply (subst (asm) state_vrefs_def, clarsimp) apply (case_tac "asid_high_bits_of asid = asid_high_bits_of base") - apply (clarsimp simp: vs_lookup_table_def pool_for_asid_def vspace_for_pool_def graph_of_def - asid_pools_of_ko_at obj_at_def vs_refs_aux_def aobjs_of_Some + apply (clarsimp simp: vs_lookup_table_def pool_for_asid_def vspace_for_pool_def entry_for_pool_def + graph_of_def obj_at_def vs_refs_aux_def aobjs_of_Some vspace_objs_of_Some split: if_splits) apply (subst (asm) asid_update.vs_lookup_table[simplified fun_upd_def]) apply (clarsimp simp: asid_update_def asid_pools_of_ko_at) @@ -1281,9 +1460,9 @@ lemma pas_refined_asid_control_helper: "authorised_asid_control_inv aag (MakePool frame slot parent base) \ \\s. pas_refined aag s \ ko_at (ArchObj (ASIDPool Map.empty)) frame s \ asid_table s (asid_high_bits_of base) = None\ - do asid_table <- gets (riscv_asid_table \ arch_state); + do asid_table <- gets asid_table; asid_table' <- return (asid_table(asid_high_bits_of base \ frame)); - modify (\s. s\arch_state := arch_state s\riscv_asid_table := asid_table'\\) + modify (\s. s\arch_state := arch_state s\arm_asid_table := asid_table'\\) od \\_. pas_refined aag\" unfolding pas_refined_def @@ -1303,7 +1482,7 @@ lemma pas_refined_asid_control_helper: apply (fastforce dest: sata_asid) apply (subst (asm) state_vrefs_asid_pool_map; clarsimp) apply (case_tac "asid_high_bits_of asid = asid_high_bits_of base") - apply (clarsimp simp: state_vrefs_def aobjs_of_Some obj_at_def vs_refs_aux_def graph_of_def) + apply (clarsimp simp: state_vrefs_def aobjs_of_Some vspace_objs_of_Some obj_at_def vs_refs_aux_def graph_of_def) apply (drule sata_asid_lookup[rotated]; fastforce) apply (clarsimp split: if_splits) apply (fastforce simp: authorised_asid_control_inv_def is_aligned_no_overflow aag_wellformed_refl) @@ -1348,12 +1527,11 @@ lemma perform_asid_control_invocation_pas_refined: pas_cap_cur_auth aag (ArchObjectCap (ASIDPoolCap frame base)) \ (\x. asid_high_bits_of x = asid_high_bits_of base \ is_subject_asid aag x)" in hoare_strengthen_post) - apply (simp add: page_bits_def) apply (wp add: delete_objects_pspace_no_overlap hoare_vcg_ex_lift delete_objects_descendants_range_in delete_objects_invs_ex delete_objects_pas_refined del: Untyped_AI.delete_objects_pspace_no_overlap - | simp add: page_bits_def)+ + | simp add: )+ apply clarsimp apply (rename_tac s idx) apply (frule untyped_cap_aligned, simp add: invs_valid_objs) @@ -1379,11 +1557,11 @@ lemma perform_asid_control_invocation_pas_refined: apply simp apply simp apply (rule subset_refl) - apply (simp add: page_bits_def) + apply simp apply (frule_tac x=x in bspec) apply (simp add: is_aligned_no_overflow) apply (clarsimp simp: ptr_range_def invs_psp_aligned invs_valid_objs aag_cap_auth_def - descendants_range_def2 empty_descendants_range_in page_bits_def + descendants_range_def2 empty_descendants_range_in pas_refined_refl cap_links_asid_slot_def label_owns_asid_slot_def cap_links_irq_def range_cover_def obj_bits_api_def pageBits_def default_arch_object_def and_mask_eq_iff_shiftr_0 mask_zero) @@ -1391,23 +1569,6 @@ lemma perform_asid_control_invocation_pas_refined: apply (intro conjI; fastforce intro: empty_descendants_range_in) done -lemma copy_global_mappings_integrity: - "\integrity aag X st and K (is_aligned x pt_bits \ is_subject aag x)\ - copy_global_mappings x - \\_. integrity aag X st\" - apply (rule hoare_gen_asm) - apply (simp add: copy_global_mappings_def) - apply (wp mapM_x_wp[OF _ subset_refl] store_pte_respects) - apply (simp only: pt_index_def) - apply (subst table_base_offset_id) - apply simp - 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+ - done - definition authorised_asid_pool_inv :: "'a PAS \ asid_pool_invocation \ bool" where "authorised_asid_pool_inv aag api \ case api of Assign asid pool_ptr ct_slot \ @@ -1419,22 +1580,15 @@ lemma perform_asid_pool_invocation_respects: perform_asid_pool_invocation api \\_. integrity aag X st\" apply (unfold perform_asid_pool_invocation_def store_asid_pool_entry_def) - apply (wpsimp wp: set_asid_pool_integrity_autarch get_cap_wp set_cap_integrity_autarch - copy_global_mappings_integrity hoare_drop_imps) - apply (clarsimp simp: authorised_asid_pool_inv_def valid_apinv_def cte_wp_at_caps_of_state is_cap_simps) - apply (rule conjI) - apply (rule is_aligned_pt; fastforce simp: valid_cap_def dest: caps_of_state_valid) - apply (frule_tac ptr="(a,b)" in sbta_caps) - apply simp - apply (simp add: cap_auth_conferred_def arch_cap_auth_conferred_def) - apply (erule_tac x=a in is_subject_trans, assumption) - apply (fastforce simp: pas_refined_def auth_graph_map_def state_objs_to_policy_def) + apply (wpsimp wp: set_asid_pool_integrity_autarch get_cap_wp + set_cap_integrity_autarch hoare_drop_imps) + apply (clarsimp simp: authorised_asid_pool_inv_def) done lemma store_pte_state_vrefs_unreachable: "\\s. P (state_vrefs s) \ pspace_aligned s \ valid_vspace_objs s \ - valid_asid_table s \ (\level. \ \\ (level, table_base p) s)\ - store_pte p pte + valid_asid_table s \ (\level. \ \\ (level, table_base pt_t p) s)\ + store_pte pt_t p pte \\_ s. P (state_vrefs s)\" supply fun_upd_apply[simp del] apply (wpsimp simp: store_pte_def set_pt_def wp: set_object_wp) @@ -1446,87 +1600,41 @@ lemma store_pte_state_vrefs_unreachable: apply (rule state_vrefsD) apply (subst vs_lookup_table_unreachable_upd_idem; fastforce) apply (drule vs_lookup_level) - apply (prop_tac "x \ table_base p", clarsimp) + apply (prop_tac "x \ table_base pt_t p", clarsimp) apply (fastforce simp: fun_upd_def aobjs_of_Some opt_map_def) apply clarsimp apply fastforce apply (subst (asm) state_vrefs_def, clarsimp) apply (rule state_vrefsD) apply (subst (asm) vs_lookup_table_unreachable_upd_idem; fastforce) - apply (prop_tac "x \ table_base p") + apply (prop_tac "x \ table_base pt_t p") apply (subst (asm) vs_lookup_table_unreachable_upd_idem; fastforce dest: vs_lookup_level) apply (fastforce simp: fun_upd_def aobjs_of_Some) apply clarsimp apply clarsimp done -lemma copy_global_mappings_state_vrefs: - "\\s. P (state_vrefs s) \ invs s \ is_aligned pt_ptr pt_bits \ (\level. \ \\ (level, pt_ptr) s)\ - copy_global_mappings pt_ptr - \\_ s. P (state_vrefs s)\" - unfolding copy_global_mappings_def - apply clarsimp - apply wp - apply (rule_tac Q'="\_ s. P (state_vrefs s) \ pspace_aligned s \ valid_vspace_objs s \ - valid_asid_table s \ unique_table_refs s \ valid_vs_lookup s \ - valid_objs s \ is_aligned pt_ptr pt_bits \ is_aligned global_pt pt_bits \ - (\level. \ \\ (level, table_base (pt_ptr)) s) \ - (\level. \ \\ (level, table_base (global_pt)) s)" - in hoare_strengthen_post[rotated], clarsimp) - apply (wpsimp wp: store_pte_state_vrefs_unreachable store_pte_valid_vs_lookup_unreachable - store_pte_vs_lookup_table_unreachable store_pte_valid_vspace_objs - hoare_vcg_all_lift hoare_vcg_imp_lift' mapM_x_wp') - apply (prop_tac "table_base (pt_ptr + (x << pte_bits)) = pt_ptr \ - table_base (global_pt + (x << pte_bits)) = global_pt") - apply (metis mask_2pm1 table_base_plus) - apply (fastforce simp: valid_objs_caps ptes_of_wellformed_pte) - apply wpsimp+ - apply (simp add: invs_valid_global_vspace_mappings) - apply (intro conjI; clarsimp) - apply (frule invs_valid_global_arch_objs) - apply (frule valid_global_arch_objs_pt_at) - using not_in_global_refs_vs_lookup apply fastforce - done - -crunch copy_global_mappings - for tcb_domain_map_wellformed[wp]: "\s. P (tcb_domain_map_wellformed aag s)" - and asid_table[wp]: "\s. P (asid_table s)" - and cdt[wp]: "\s. P (cdt s)" - and thread_st_auth[wp]: "\s. P (thread_st_auth s)" - and thread_bound_ntfns[wp]: "\s. P (thread_bound_ntfns s)" - (wp: crunch_wps) - -lemma copy_global_mappings_pas_refined: - "\\s. pas_refined aag s \ invs s \ is_aligned pt_ptr pt_bits \ (\level. \ \\ (level, pt_ptr) s)\ - copy_global_mappings pt_ptr - \\_. pas_refined aag\" - apply (clarsimp simp: pas_refined_def state_objs_to_policy_def) - apply (rule hoare_pre) - apply (wps) - apply (wpsimp wp: copy_global_mappings_state_vrefs)+ - done - lemma store_asid_pool_entry_state_vrefs: "\\s. P (\x. if x = pool_ptr then vs_refs_aux asid_pool_level (ASIDPool (\a. if a = asid_low_bits_of asid - then Some pt_base + then Some (ASIDPoolVSpace None pt_base) else the (asid_pools_of s pool_ptr) a)) else if x = pt_base - then vs_refs_aux max_pt_level (the (aobjs_of s x)) + then vs_refs_aux max_pt_level (the (vspace_objs_of s x)) else state_vrefs s x) \ pspace_aligned s \ valid_vspace_objs s \ valid_asid_table s \ pool_for_asid asid s = Some pool_ptr \ (\pool. ako_at (ASIDPool pool) pool_ptr s \ pool (asid_low_bits_of asid) = None) \ (\level. \\\ (level, pt_base) s) \ - (\pt. pts_of s pt_base = Some pt \ kernel_mappings_only pt s)\ - store_asid_pool_entry pool_ptr asid (Some pt_base) + (\pt. pts_of s pt_base = Some (empty_pt VSRootPT_T))\ + store_asid_pool_entry pool_ptr asid (Some (ASIDPoolVSpace None pt_base)) \\_ s. P (state_vrefs s)\" unfolding store_asid_pool_entry_def set_asid_pool_def apply (wpsimp wp: set_object_wp get_cap_wp) apply (erule rsubst[where P=P]) apply (rule all_ext) apply (clarsimp split del: if_split) - apply (prop_tac "is_aligned pt_base pt_bits") + apply (prop_tac "is_aligned pt_base (pt_bits (pt_type (empty_pt VSRootPT_T)))") apply (fastforce elim: pspace_aligned_pts_ofD dest: invs_psp_aligned) apply safe apply (clarsimp split: if_splits) @@ -1535,7 +1643,7 @@ lemma store_asid_pool_entry_state_vrefs: apply (simp only: fun_upd_def) apply (subst asid_pool_map.vs_lookup_table[simplified fun_upd_def]) apply (fastforce simp: asid_pool_map_def asid_pools_of_ko_at - valid_apinv_def asid_low_bits_of_def aobjs_of_Some) + valid_apinv_def asid_low_bits_of_def ) apply fastforce apply fastforce apply fastforce @@ -1548,9 +1656,9 @@ lemma store_asid_pool_entry_state_vrefs: valid_apinv_def asid_low_bits_of_def aobjs_of_Some) apply clarsimp apply fastforce - apply (fastforce simp: pts_of_Some) + apply (fastforce simp: vspace_objs_of_Some pts_of_Some) apply (fastforce simp: pts_of_Some) - apply (fastforce simp: pts_of_Some) + apply (clarsimp simp: vspace_obj_of_def opt_map_def split: option.splits) apply (clarsimp simp: obj_at_def) apply (subst (asm) state_vrefs_def, clarsimp) apply (rename_tac asida vref) @@ -1561,7 +1669,8 @@ lemma store_asid_pool_entry_state_vrefs: valid_apinv_def asid_low_bits_of_def aobjs_of_Some) apply fastforce apply (prop_tac "asid \ asida") - apply (fastforce simp: vs_lookup_table_def vspace_for_pool_def asid_pools_of_ko_at obj_at_def + apply (fastforce simp: vs_lookup_table_def entry_for_pool_def vspace_for_pool_def + asid_pools_of_ko_at obj_at_def split: if_splits) apply fastforce apply fastforce @@ -1574,13 +1683,15 @@ lemma store_asid_pool_entry_state_vrefs: valid_apinv_def asid_low_bits_of_def aobjs_of_Some) apply clarsimp apply (case_tac "x = pool_ptr") - apply (prop_tac "asid_pools_of s pool_ptr = Some pool") + apply (prop_tac "asid_pools_of s pool_ptr = Some rv") apply (clarsimp simp: asid_pools_of_ko_at obj_at_def) apply (clarsimp simp: vs_refs_aux_def) apply (case_tac "asida = asid \ bot \ max_pt_level"; clarsimp) + apply (clarsimp simp: vspace_obj_of_def opt_map_def split: option.splits) apply (case_tac "x = pt_base") apply (fastforce dest: vs_lookup_level) - apply (fastforce simp: state_vrefs_def) + apply clarsimp + apply (fastforce simp: state_vrefs_def vspace_obj_of_def opt_map_def split: option.splits) done crunch store_asid_pool_entry @@ -1599,8 +1710,8 @@ lemma store_asid_pool_entry_pas_refined: is_subject aag pt_base \ is_subject_asid aag asid \ (\level. \\\ (level, pt_base) s) \ (\pool. ako_at (ASIDPool pool) pool_ptr s \ pool (asid_low_bits_of asid) = None) \ - (\pt. pts_of s pt_base = Some pt \ kernel_mappings_only pt s)\ - store_asid_pool_entry pool_ptr asid (Some pt_base) + (\pt. pts_of s pt_base = Some (empty_pt VSRootPT_T))\ + store_asid_pool_entry pool_ptr asid (Some (ASIDPoolVSpace None pt_base)) \\_ s. pas_refined aag s\" apply (clarsimp simp: pas_refined_def state_objs_to_policy_def) apply (rule hoare_pre) @@ -1626,12 +1737,12 @@ lemma store_asid_pool_entry_pas_refined: apply (rule sbta_vref) apply (drule pool_for_asid_vs_lookupD) apply (erule_tac vref=0 in state_vrefsD) - apply (simp add: asid_pools_of_ko_at aobjs_of_ako_at_Some) + apply (fastforce simp: asid_pools_of_ko_at aobjs_of_ako_at_Some vspace_objs_of_Some) apply clarsimp apply (fastforce simp: vs_refs_aux_def graph_of_def) - apply (fastforce simp: vs_refs_aux_def kernel_mappings_only_def + apply (fastforce simp: vs_refs_aux_def empty_pt_def vspace_obj_of_def opt_map_def graph_of_def pts_of_Some pte_ref2_def - dest: sbta_vref split: if_splits) + dest: sbta_vref split: if_splits option.splits) apply (erule state_asids_to_policy_aux.cases) apply (erule subsetD[where A="state_asids_to_policy_aux _ _ _ _"]) apply (fastforce dest: sata_asid) @@ -1641,7 +1752,7 @@ lemma store_asid_pool_entry_pas_refined: apply (drule_tac x="asid_high_bits_of asid" in bspec, clarsimp) apply (drule_tac x="asid_high_bits_of asida" in bspec, clarsimp) apply clarsimp - apply (drule asid_high_low) + apply (drule asid_high_low_inj[rotated]) apply (simp add: asid_low_bits_of_mask_eq[symmetric]) apply (prop_tac "is_up UCAST(9 \ 16) \ is_up UCAST(9 \ 64)") apply (clarsimp simp: is_up_def source_size_def target_size_def word_size) @@ -1652,39 +1763,18 @@ lemma store_asid_pool_entry_pas_refined: apply (rule sata_asid_lookup, fastforce) apply (frule pool_for_asid_vs_lookupD) apply (erule_tac vref=0 in state_vrefsD) - apply (simp add: asid_pools_of_ko_at aobjs_of_ako_at_Some) + apply (fastforce simp: asid_pools_of_ko_at aobjs_of_ako_at_Some vspace_objs_of_Some) apply simp apply (fastforce simp: vs_refs_aux_def graph_of_def) apply (case_tac "poolptr = pt_base") - apply (clarsimp simp: vs_refs_aux_def pts_of_Some) + apply (fastforce simp: vs_refs_aux_def pts_of_Some empty_pt_def vspace_obj_of_def opt_map_def + split: option.splits) apply (erule subsetD[where A="state_asids_to_policy_aux _ _ _ _"]) apply (fastforce simp: sata_asid_lookup) apply (erule subsetD[where A="state_asids_to_policy_aux _ _ _ _"]) apply (fastforce simp: sata_asidpool) done - -lemma copy_global_mappings_vs_lookup_table_noteq: - "\\s. vs_lookup_table level asid vref s \ Some (level, pt_ptr) \ invs s \ - is_aligned pt_ptr pt_bits \ vref \ user_region \ (\level. \ \\ (level, pt_ptr) s)\ - copy_global_mappings pt_ptr - \\_ s. vs_lookup_table level asid vref s \ Some (level, pt_ptr)\" - unfolding copy_global_mappings_def - apply clarsimp - apply wp - apply (rule_tac Q'="\_. pspace_aligned and valid_vspace_objs and valid_asid_table and - unique_table_refs and valid_vs_lookup and valid_objs and - (\s. vs_lookup_table level asid vref s \ Some (level, pt_ptr) \ - vref \ user_region \ is_aligned pt_ptr pt_bits \ - (\level. \ \\ (level, table_base pt_ptr) s))" - in hoare_strengthen_post[rotated], clarsimp) - apply (wpsimp wp: mapM_x_wp' store_pte_valid_vspace_objs store_pte_vs_lookup_table_unreachable - store_pte_valid_vs_lookup_unreachable hoare_vcg_all_lift hoare_vcg_imp_lift') - apply (metis valid_objs_caps ptes_of_wellformed_pte mask_2pm1 table_base_plus) - apply wpsimp - apply fastforce - done - lemma perform_asid_pool_invocation_pas_refined [wp]: "\pas_refined aag and invs and valid_apinv api and K (authorised_asid_pool_inv aag api)\ perform_asid_pool_invocation api @@ -1692,55 +1782,476 @@ lemma perform_asid_pool_invocation_pas_refined [wp]: apply (simp add: perform_asid_pool_invocation_def) apply (strengthen invs_psp_aligned invs_vspace_objs valid_arch_state_asid_table invs_arch_state | wpsimp simp: ako_asid_pools_of - wp: copy_global_mappings_invs copy_global_mappings_pas_refined - copy_global_mappings_copies copy_global_mappings_vs_lookup_table_noteq - store_asid_pool_entry_pas_refined set_cap_pas_refined get_cap_wp + wp: store_asid_pool_entry_pas_refined set_cap_pas_refined get_cap_wp arch_update_cap_invs_map hoare_vcg_all_lift hoare_vcg_imp_lift')+ apply (clarsimp simp: cte_wp_at_caps_of_state valid_apinv_def cong: conj_cong) apply (clarsimp simp: is_PageTableCap_def is_ArchObjectCap_def) - apply (clarsimp split: option.splits) - apply (clarsimp simp: authorised_asid_pool_inv_def) - apply (prop_tac "(\x xa xb. vs_lookup_table x xa xb s = Some (x, x41) \ xb \ user_region)") + apply (clarsimp simp: authorised_asid_pool_inv_def is_arch_update_def update_map_data_def + is_cap_simps cap_master_cap_def asid_bits_of_defs + split: option.splits) + apply (intro conjI) + apply (fastforce dest: cap_cur_auth_caps_of_state pas_refined_refl + simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + cap_links_asid_slot_def label_owns_asid_slot_def cap_links_irq_def) + apply (fastforce dest: caps_of_state_valid + simp: update_map_data_def valid_cap_def cap_aligned_def wellformed_mapdata_def) + apply (fastforce dest: cap_cur_auth_caps_of_state pas_refined_Control + simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def) apply (frule (1) caps_of_state_valid) apply (clarsimp simp: valid_cap_def) apply (clarsimp simp: obj_at_def) apply (rename_tac asid' pool_ptr a b acap_obj level asid vref pt) apply (drule (1) vs_lookup_table_valid_cap; clarsimp) - apply (frule (1) cap_to_pt_is_pt_cap, simp add: pts_of_Some aobjs_of_Some, fastforce intro: valid_objs_caps) - apply (drule (1) unique_table_refsD[rotated]; clarsimp) - apply (clarsimp simp: is_cap_simps) - apply (clarsimp simp: is_arch_update_def update_map_data_def is_cap_simps cap_master_cap_def asid_bits_of_defs) - apply (intro conjI) - apply (fastforce dest: cap_cur_auth_caps_of_state pas_refined_refl - simp: update_map_data_def aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def - cap_links_asid_slot_def label_owns_asid_slot_def cap_links_irq_def) - apply (fastforce dest: caps_of_state_valid - simp: update_map_data_def valid_cap_def cap_aligned_def wellformed_mapdata_def) - apply (fastforce dest: caps_of_state_aligned_page_table) - apply (fastforce dest: unique_table_capsD[rotated]) - apply (fastforce dest: cap_not_in_valid_global_refs) - apply (fastforce dest: cap_cur_auth_caps_of_state pas_refined_Control - simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def) - apply fastforce - apply (fastforce dest: invs_valid_table_caps simp: valid_table_caps_def) + apply (frule (1) cap_to_pt_is_pt_cap_and_type) + apply (simp add: pts_of_Some aobjs_of_Some) + apply (fastforce intro: valid_objs_caps) + apply (drule (1) unique_table_refsD[rotated]; clarsimp simp: is_cap_simps) + apply (fastforce dest: invs_valid_table_caps simp: valid_table_caps_def is_vsroot_cap_def ) + done + +lemma perform_vspace_invocation_respects[wp]: + "perform_vspace_invocation iv \integrity aag X st\" + unfolding perform_vspace_invocation_def perform_flush_def + by (wpsimp wp: dmo_no_mem_respects) + +crunch perform_vspace_invocation + for pas_refined[wp]: "pas_refined aag" + +(* FIXME AARCH64: move these *) +lemma tcb_states_of_state_fun_upd: + "map_option tcb_state (get_tcb p s) = (case val of TCB tcb \ Some (tcb_state tcb) | _ \ None) + \ tcb_states_of_state (s\kheap := (kheap s)(p \ val)\) = tcb_states_of_state s" + by (fastforce simp: tcb_states_of_state_def get_tcb_def split: kernel_object.splits) + +lemma thread_st_auth_fun_upd: + "map_option tcb_state (get_tcb p s) = (case val of TCB tcb \ Some (tcb_state tcb) | _ \ None) + \ thread_st_auth (s\kheap := (kheap s)(p \ val)\) = thread_st_auth s" + by (auto simp: tcb_states_of_state_fun_upd thread_st_auth_def) + +lemma thread_bound_ntfns_fun_upd: + "map_option tcb_bound_notification (get_tcb p s) = + (case val of TCB tcb \ Some (tcb_bound_notification tcb) | _ \ None) + \ thread_bound_ntfns (s\kheap := (kheap s)(p \ val)\) = thread_bound_ntfns s" + by (fastforce simp: thread_bound_ntfns_def get_tcb_def split: kernel_object.splits) + +lemma vcpu_save_reg_respects: + "\\s. integrity aag X st s \ option_map fst (arm_current_vcpu (arch_state s)) = Some vr\ + vcpu_save_reg vr reg + \\_. integrity aag X st\" + unfolding vcpu_save_reg_def vcpu_update_def + apply (wpsimp wp: set_vcpu_wp get_vcpu_wp hoare_vcg_all_lift hoare_vcg_imp_lift dmo_wp + simp: readVCPUHardwareReg_def) + apply (clarsimp simp: integrity_def) + apply (subst tcb_states_of_state_fun_upd, fastforce simp: get_tcb_def obj_at_def)+ + apply (rule conjI) + apply (erule_tac x=vr in allE)+ + apply (auto elim!: tro_trans_spec simp: in_opt_map_eq + intro!: tro_arch arch_troa_vcpu_save_reg)[1] + apply (rule ccontr) + apply (auto simp: in_opt_map_eq) + done + +lemma save_virt_timer_respects: + "\\s. integrity aag X st s \ option_map fst (arm_current_vcpu (arch_state s)) = Some vr\ + save_virt_timer vr + \\_. integrity aag X st\" + (is "valid ?P _ _") + unfolding save_virt_timer_def vcpu_update_def + apply (wpsimp wp: set_vcpu_wp get_vcpu_wp hoare_vcg_all_lift hoare_vcg_imp_lift + simp: readVCPUHardwareReg_def read_cntpct_def)+ + apply (wp dmo_wp) + apply (rule_tac Q'="K ?P" in hoare_strengthen_post[rotated]) + apply (clarsimp simp: integrity_def simp del: fun_upd_apply) + apply (subst tcb_states_of_state_fun_upd; clarsimp simp: get_tcb_def obj_at_def)+ + apply (rule conjI) + apply (erule_tac x=vr in allE)+ + apply (auto elim!: tro_trans_spec simp: in_opt_map_eq + intro!: tro_arch arch_troa_vcpu_save_virt_timer)[1] + apply (rule ccontr) + apply (auto simp: in_opt_map_eq)[1] + by (wpsimp wp: dmo_no_mem_respects vcpu_save_reg_respects)+ + +lemma vgic_update_respects: + "\\s. integrity aag X st s \ option_map fst (arm_current_vcpu (arch_state s)) = Some vr + \ v = getf (machine_state s) + \ (setf = vgic_hcr_update \ getf = gic_vcpu_ctrl_hcr_val \ + setf = vgic_vmcr_update \ getf = gic_vcpu_ctrl_vmcr_val \ + setf = vgic_apr_update \ getf = gic_vcpu_ctrl_apr_val)\ + vgic_update vr (setf (\_. v)) + \\_. integrity aag X st\" + unfolding vgic_update_def vcpu_update_def + apply (wpsimp wp: set_vcpu_wp get_vcpu_wp dmo_wp) + apply (clarsimp simp: integrity_def) + apply (subst tcb_states_of_state_fun_upd, fastforce simp: get_tcb_def obj_at_def)+ + apply (rule conjI) + apply (erule_tac x=vr in allE)+ + apply (auto elim!: tro_trans_spec simp: in_opt_map_eq + intro!: tro_arch arch_troa_vcpu_save_vgic)[1] + apply (rule ccontr) + apply (auto simp: in_opt_map_eq) + done + +lemmas vgic_updates_respect = + vgic_update_respects[where setf=vgic_hcr_update and getf=gic_vcpu_ctrl_hcr_val, simplified] + vgic_update_respects[where setf=vgic_vmcr_update and getf=gic_vcpu_ctrl_vmcr_val, simplified] + vgic_update_respects[where setf=vgic_apr_update and getf=gic_vcpu_ctrl_apr_val, simplified] + +lemma get_gic_vcpu_ctrl_rvs: + "\\_. True\ do_machine_op get_gic_vcpu_ctrl_hcr \\rv s. rv = gic_vcpu_ctrl_hcr_val (machine_state s)\" + "\\_. True\ do_machine_op get_gic_vcpu_ctrl_vmcr \\rv s. rv = gic_vcpu_ctrl_vmcr_val (machine_state s)\" + "\\_. True\ do_machine_op get_gic_vcpu_ctrl_apr \\rv s. rv = gic_vcpu_ctrl_apr_val (machine_state s)\" + unfolding get_gic_vcpu_ctrl_hcr_def get_gic_vcpu_ctrl_vmcr_def get_gic_vcpu_ctrl_apr_def + by (wpsimp wp: dmo_wp)+ + +lemma vcpu_disable_None_respects[wp]: + "vcpu_disable None \integrity aag X st\" + unfolding vcpu_disable_def + by (wpsimp wp: dmo_no_mem_respects) + +lemma vcpu_disable_Some_respects: + "\\s. integrity aag X st s \ option_map fst (arm_current_vcpu (arch_state s)) = Some vcpu\ + vcpu_disable (Some vcpu) + \\_. integrity aag X st\" + unfolding vcpu_disable_def + by (wpsimp wp: dmo_no_mem_respects vcpu_save_reg_respects + save_virt_timer_respects vgic_updates_respect get_gic_vcpu_ctrl_rvs) + +lemma vgic_update_lr_respects: + "\\s. integrity aag X st s \ option_map fst (arm_current_vcpu (arch_state s)) = Some vr + \ lr = gic_vcpu_ctrl_lr_val (word_of_nat vreg) (machine_state s)\ + vgic_update_lr vr vreg lr + \\_. integrity aag X st\" + unfolding vgic_update_lr_def vgic_update_def vcpu_update_def + apply (wpsimp wp: set_vcpu_wp get_vcpu_wp dmo_wp hoare_vcg_all_lift hoare_vcg_imp_lift)+ + apply (clarsimp simp: integrity_def) + apply (subst tcb_states_of_state_fun_upd, fastforce simp: get_tcb_def obj_at_def)+ + apply (rule conjI) + apply (erule_tac x=vr in allE)+ + apply (auto elim!: tro_trans_spec simp: in_opt_map_eq + intro!: tro_arch arch_troa_vcpu_save_vgic)[1] + apply (rule ccontr) + apply (auto simp: in_opt_map_eq) + done + +lemma vcpu_save_reg_range_respects: + "\\s. integrity aag X st s \ map_option fst (arm_current_vcpu (arch_state s)) = Some vr\ + vcpu_save_reg_range vr from to + \\_. integrity aag X st\" + unfolding vcpu_save_reg_range_def + apply (rule_tac Q'="\_. P" and P=P for P in hoare_strengthen_post) + by (wpsimp wp: mapM_x_wp' vcpu_save_reg_respects)+ + +lemma vcpu_save_respects: + "\\s. integrity aag X st s \ arm_current_vcpu (arch_state s) = vb\ + vcpu_save vb + \\_. integrity aag X st\" + by (wpsimp wp: vcpu_save_reg_range_respects mapM_wp' vgic_update_lr_respects + vgic_updates_respect dmo_no_mem_respects get_gic_vcpu_ctrl_rvs + save_virt_timer_respects vcpu_save_reg_respects + simp: vcpu_save_def get_gic_vcpu_ctrl_lr_def + | wp dmo_wp)+ + +crunch vcpu_enable, vcpu_restore + for integrity_autarch: "integrity aag X st" + (wp: dmo_no_mem_respects mapM_wp' mapM_x_wp') + +lemma vcpu_switch_integrity: + "\\s. integrity aag X st s \ (\v. vcpu = Some v \ is_subject aag v)\ + vcpu_switch vcpu + \\_. integrity aag X st\" + unfolding vcpu_switch_def + by (wpsimp wp: vcpu_restore_integrity_autarch vcpu_save_respects vcpu_enable_integrity_autarch + vcpu_disable_Some_respects dmo_no_mem_respects)+ + +lemma vcpu_restore_reg_respects: + "\\s. integrity aag X st s \ (\v a. arm_current_vcpu (arch_state s) = Some (v,a) \ v = vcpu)\ + vcpu_restore_reg vcpu reg + \\_. integrity aag X st\" + unfolding vcpu_restore_reg_def + by (wpsimp wp: dmo_no_mem_respects) + +lemma restore_virt_timer_respects: + "\\s. integrity aag X st s \ option_map fst (arm_current_vcpu (arch_state s)) = Some vr\ + restore_virt_timer vr + \\_. integrity aag X st\" + (is "valid ?P _ _") + unfolding restore_virt_timer_def vcpu_write_reg_def vcpu_update_def vcpu_read_reg_def read_cntpct_def + apply (wpsimp wp: vcpu_restore_reg_respects set_vcpu_wp get_vcpu_wp + dmo_no_mem_respects dmo_wp hoare_vcg_imp_lift + simp_del: fun_upd_apply) + apply (rule_tac Q'="K ?P" in hoare_strengthen_post[rotated]) + apply (clarsimp simp: integrity_def) + apply (subst tcb_states_of_state_fun_upd, fastforce simp: get_tcb_def obj_at_def)+ + apply (rule conjI) + apply (erule_tac x=vr in allE)+ + apply (auto elim!: tro_trans_spec simp: in_opt_map_eq + intro!: tro_arch arch_troa_vcpu_restore_vtimer)[1] + apply (rule ccontr) + apply (auto simp: in_opt_map_eq)[1] + apply (wpsimp wp: vcpu_restore_reg_respects)+ + done + +lemma vcpu_enable_respects: + "\\s. integrity aag X st s \ option_map fst (arm_current_vcpu (arch_state s)) = Some vr\ + vcpu_enable vr + \\_. integrity aag X st\" + unfolding vcpu_enable_def + by (wpsimp wp: restore_virt_timer_respects vcpu_restore_reg_respects dmo_no_mem_respects) + +lemma vcpu_restore_respects: + "\\s. integrity aag X st s \ option_map fst (arm_current_vcpu (arch_state s)) = Some vr\ + vcpu_restore vr + \\_. integrity aag X st\" + unfolding vcpu_restore_def vcpu_restore_reg_range_def + by (wpsimp wp: vcpu_enable_respects vcpu_restore_reg_respects dmo_no_mem_respects mapM_x_wp' mapM_wp') + +lemma vcpu_switch_respects: + "vcpu_switch vcpu \integrity aag X st\" + unfolding vcpu_switch_def + by (wpsimp wp: vcpu_restore_respects vcpu_disable_Some_respects + vcpu_save_respects vcpu_enable_respects dmo_no_mem_respects) + +lemma arch_thread_set_integrity_autarch: + "\integrity aag X st and K (is_subject aag ptr)\ + arch_thread_set f ptr + \\_. integrity aag X st\" + unfolding arch_thread_set_def + by (wpsimp wp: set_object_integrity_autarch) + +lemma vcpu_invalidate_active_respects[wp]: + "vcpu_invalidate_active + \integrity aag X st\" + unfolding vcpu_invalidate_active_def + by wpsimp + +lemma dissociate_vcpu_tcb_respects: + "\integrity aag X st and K (is_subject aag vcpu \ is_subject aag tcb)\ + dissociate_vcpu_tcb vcpu tcb + \\_. integrity aag X st\" + unfolding dissociate_vcpu_tcb_def set_vcpu_def get_vcpu_def arch_thread_get_def + by (wpsimp wp: as_user_integrity_autarch set_object_integrity_autarch + arch_thread_set_integrity_autarch) + +crunch vcpu_invalidate_active + for vcpus_of[wp]: "\s. P (vcpus_of s)" + (simp: vcpu_invalidate_active_def vcpu_disable_def) + +lemma thread_set_vcpus_of[wp]: + "thread_set f tptr \\s. P (vcpus_of s)\" + unfolding thread_set_def + apply (wpsimp wp: set_object_wp) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: get_tcb_def opt_map_def split: option.splits kernel_object.splits) + done + +lemma dissociate_vcpu_tcb_vcpus_of: + "\\s. P ((vcpus_of s)(v := Some ((the (vcpus_of s v))\vcpu_tcb := None\)))\ + dissociate_vcpu_tcb v tcb + \\_ s. P (vcpus_of s)\" + unfolding dissociate_vcpu_tcb_def + by (wpsimp wp: as_user_wp_thread_set_helper hoare_drop_imps get_vcpu_wp simp: fun_upd_def) + +lemma associate_vcpu_tcb_respects: + "\integrity aag X st and K (is_subject aag vcpu) and K (is_subject aag tcb)\ + associate_vcpu_tcb vcpu tcb + \\_. integrity aag X st\" + unfolding associate_vcpu_tcb_def + apply (wpsimp wp: vcpu_switch_integrity set_vcpu_integrity_autarch hoare_drop_imps + arch_thread_set_integrity_autarch dissociate_vcpu_tcb_respects get_vcpu_wp) + apply (rule_tac Q'="\a b. integrity aag X st b \ is_subject aag vcpu \ is_subject aag tcb \ + (\v x. vcpus_of b vcpu = Some v \ vcpu_tcb v = Some x \ is_subject aag x)" + in hoare_strengthen_post) + apply (wpsimp wp: dissociate_vcpu_tcb_respects dissociate_vcpu_tcb_vcpus_of arch_thread_get_wp)+ + apply (fastforce intro: associated_vcpu_is_subject associated_tcb_is_subject + simp: get_tcb_def obj_at_def opt_map_def + split: option.splits) + done + +lemma invoke_vcpu_inject_irq_respects: + "\integrity aag X st and K (is_subject aag vcpu)\ + invoke_vcpu_inject_irq vcpu index vir + \\_. integrity aag X st\" + unfolding invoke_vcpu_inject_irq_def set_gic_vcpu_ctrl_lr_def vgic_update_lr_def vgic_update_def + by (wpsimp wp: vcpu_update_integrity_autarch) + +lemma invoke_vcpu_read_register_respects: + "invoke_vcpu_read_register vcpu reg \integrity aag X st\" + unfolding invoke_vcpu_read_register_def read_vcpu_register_def readVCPUHardwareReg_def + by wpsimp + +lemma invoke_vcpu_write_register_respects: + "\integrity aag X st and K (is_subject aag vcpu)\ + invoke_vcpu_write_register vcpu reg val + \\_. integrity aag X st\" + unfolding invoke_vcpu_write_register_def write_vcpu_register_def + vcpu_write_reg_def writeVCPUHardwareReg_def + by (wpsimp wp: vcpu_update_integrity_autarch) + +lemma invoke_vcpu_ack_vppi_respects: + "\integrity aag X st and K (is_subject aag vcpu)\ + invoke_vcpu_ack_vppi vcpu vppi + \\_. integrity aag X st\" + unfolding invoke_vcpu_ack_vppi_def + by (wpsimp wp: vcpu_update_integrity_autarch) + + +definition authorised_vcpu_inv where + "authorised_vcpu_inv aag iv \ + case iv of VCPUSetTCB vcpu tcb \ is_subject aag vcpu \ is_subject aag tcb + | VCPUInjectIRQ vcpu index vir \ is_subject aag vcpu + | VCPUReadRegister vcpu reg \ is_subject aag vcpu + | VCPUWriteRegister vcpu reg val \ is_subject aag vcpu + | VCPUAckVPPI vcpu vppi \ is_subject aag vcpu" + +lemma perform_vcpu_invocation_respects[wp]: + "\integrity aag X st and K (authorised_vcpu_inv aag iv) and pas_refined aag + and invs and valid_vcpu_invocation iv and is_subject aag \ cur_thread\ + perform_vcpu_invocation iv + \\_. integrity aag X st\" + unfolding perform_vcpu_invocation_def + apply (wpsimp wp: associate_vcpu_tcb_respects invoke_vcpu_ack_vppi_respects invoke_vcpu_inject_irq_respects + invoke_vcpu_read_register_respects invoke_vcpu_write_register_respects) + apply (auto simp: authorised_vcpu_inv_def) + done + +lemma set_vcpu_thread_bound_ntfns[wp]: + "set_vcpu ptr vcpu \\s. P (thread_bound_ntfns s)\" + apply (wpsimp wp: set_vcpu_wp) + apply (erule_tac P=P in rsubst) + apply (rule ext) + apply (clarsimp simp: thread_bound_ntfns_def get_tcb_def obj_at_def) + done + +lemma arch_thread_set_thread_bound_ntfns[wp]: + "arch_thread_set f tptr \\s. P (thread_bound_ntfns s)\" + apply (wpsimp wp: arch_thread_set_wp) + apply (erule_tac P=P in rsubst) + apply (rule ext) + apply (clarsimp simp: thread_bound_ntfns_def get_tcb_def obj_at_def) + done + +lemma set_vcpu_thread_st_auth[wp]: + "set_vcpu ptr vcpu \\s. P (thread_st_auth s)\" + apply (wpsimp wp: set_vcpu_wp) + apply (erule_tac P=P in rsubst) + apply (rule ext) + apply (clarsimp simp: thread_st_auth_def tcb_states_of_state_def get_tcb_def obj_at_def) + done + +lemma arch_thread_thread_st_auth[wp]: + "arch_thread_set f tptr \\s. P (thread_st_auth s)\" + apply (wpsimp wp: arch_thread_set_wp) + apply (erule_tac P=P in rsubst) + apply (rule ext) + apply (clarsimp simp: thread_st_auth_def tcb_states_of_state_def get_tcb_def obj_at_def) + done + +crunch perform_vcpu_invocation + for irq_map_wellformed[wp]: "irq_map_wellformed aag" + and state_irqs_to_policy[wp]: "\s. P (state_irqs_to_policy aag s)" + and caps_of_state[wp]: "\s. P (caps_of_state s)" + and interrupt_irq_node[wp]: "\s. P (interrupt_irq_node s)" + and domains_of_state[wp]: "\s. P (domains_of_state s)" + and asid_table[wp]: "\s. P (asid_table s)" + and cdt[wp]: "\s. P (cdt s)" + and tcb_bound_notification[wp]: "\s. P (thread_bound_ntfns s)" + and thread_st_auth[wp]: "\s. P (thread_st_auth s)" + (wp: crunch_wps simp: crunch_simps) + +lemma set_vcpu_valid_asid_table[wp]: + "set_vcpu p v \valid_asid_table\" + apply (wpsimp wp: set_vcpu_wp) + apply (clarsimp simp: obj_at_def opt_map_def) done +lemma arch_thread_set_valid_asid_table[wp]: + "arch_thread_set f t \valid_asid_table\" + apply (wpsimp wp: arch_thread_set_wp) + apply (clarsimp simp: get_tcb_def obj_at_def opt_map_def + split: option.splits kernel_object.splits) + done + +lemma as_user_asid_pools_of[wp]: + "as_user t f \\s. P (asid_pools_of s)\" + unfolding as_user_def + apply (wpsimp wp: set_object_wp) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: get_tcb_def opt_map_def split: option.splits) + done + +lemma as_user_valid_asid_table[wp]: + "as_user t f \valid_asid_table\" + apply (rule hoare_lift_Pf[where f=asid_table]) + apply (rule hoare_lift_Pf[where f=asid_pools_of]) + apply wpsimp+ + done + +lemma set_vcpu_vspace_objs_of[wp]: + "set_vcpu p vcpu \\s. P (vspace_objs_of s)\" + apply (wpsimp wp: set_vcpu_wp) + apply (clarsimp simp: opt_map_def typ_at_eq_kheap_obj) + done + +lemma thread_set_vspace_objs_of[wp]: + "thread_set f tptr \\s. P (vspace_objs_of s)\" + unfolding thread_set_def + apply (wpsimp wp: set_object_wp) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: get_tcb_def opt_map_def split: option.splits kernel_object.splits) + done + +lemma arch_thread_set_vspace_objs_of[wp]: + "arch_thread_set f tptr \\s. P (vspace_objs_of s)\" + apply (wpsimp wp: arch_thread_set_wp) + apply (fastforce simp: get_tcb_def opt_map_def split: option.splits kernel_object.splits) + done + +(* FIXME AARCH64: weaken in ArchKHeap_AI *) +lemma vs_lookup_vspace_objs_lift: + assumes "\P. f \\s. P (vspace_objs_of s)\" + assumes "\P. f \\s. P (asid_table s)\" + shows "f \\s. P (vs_lookup s)\" + by (intro vs_lookup_lift vspace_objs_of_pts_lift vspace_objs_of_aps_lift assms) + +crunch dissociate_vcpu_tcb + for valid_asid_table[wp]: "valid_asid_table" + (wp: crunch_wps) + +crunch perform_vcpu_invocation + for vspace_objs_of[wp]: "\s. P (vspace_objs_of s)" + (wp: crunch_wps as_user_wp_thread_set_helper) + +lemma perform_vcpu_invocation_state_vrefs[wp]: + "perform_vcpu_invocation iv \\s. P (state_vrefs s)\" + unfolding state_vrefs_def + apply (rule hoare_lift_Pf[where f=vspace_objs_of] ) + apply (rule vs_lookup_vspace_objs_lift) + apply wpsimp+ + done + +crunch perform_vcpu_invocation + for pas_refined[wp]: "pas_refined aag" + (simp: pas_refined_def state_objs_to_policy_def ignore: perform_vcpu_invocation) + definition authorised_arch_inv :: "'a PAS \ arch_invocation \ 's :: state_ext state \ bool" where "authorised_arch_inv aag ai s \ case ai of InvokePageTable pti \ authorised_page_table_inv aag pti | InvokePage pgi \ authorised_page_inv aag pgi s | InvokeASIDControl aci \ authorised_asid_control_inv aag aci - | InvokeASIDPool api \ authorised_asid_pool_inv aag api" + | InvokeASIDPool api \ authorised_asid_pool_inv aag api + | InvokeVCPU vi \ authorised_vcpu_inv aag vi + | InvokeVSpace vi \ True" lemma invoke_arch_respects: - "\integrity aag X st and authorised_arch_inv aag ai and - pas_refined aag and invs and valid_arch_inv ai and is_subject aag \ cur_thread\ + "\integrity aag X st and authorised_arch_inv aag ai and pas_refined aag and invs + and valid_arch_inv ai and is_subject aag \ cur_thread\ arch_perform_invocation ai \\_. integrity aag X st\" apply (simp add: arch_perform_invocation_def) apply (wpsimp wp: perform_page_table_invocation_respects perform_page_invocation_respects - perform_asid_control_invocation_respects perform_asid_pool_invocation_respects) + perform_asid_control_invocation_respects perform_asid_pool_invocation_respects + perform_vspace_invocation_respects) apply (auto simp: authorised_arch_inv_def valid_arch_inv_def) done @@ -1759,15 +2270,16 @@ lemma vspace_for_asid_is_subject: "\ vspace_for_asid a s = Some xaa; pas_refined aag s; valid_asid_table s; is_subject_asid aag a \ \ is_subject aag xaa" apply (frule vspace_for_asid_vs_lookup) - apply (clarsimp simp: vspace_for_asid_def) + apply (clarsimp simp: vspace_for_asid_def entry_for_asid_def) apply (frule pool_for_asid_vs_lookupD) - apply (frule (1) pool_for_asid_validD) - apply (clarsimp simp: vspace_for_pool_def pool_for_asid_def asid_pools_of_ko_at obj_at_def) - apply (frule_tac vrefs="state_vrefs s" in sata_asid_lookup) - apply (rule_tac level=asid_pool_level and asid=a and vref=0 in state_vrefsD) - by (fastforce simp: aobjs_of_Some vs_refs_aux_def graph_of_def asid_low_bits_of_mask_eq[symmetric] - ucast_ucast_b is_up_def source_size_def target_size_def word_size pas_refined_def - dest: aag_wellformed_Control)+ + apply (clarsimp simp: vspace_for_pool_def entry_for_pool_def pool_for_asid_def asid_pools_of_ko_at ) + apply (frule_tac pdptr = "(ap_vspace v'a)" and vrefs="state_vrefs s" and a=Control in sata_asid_lookup) + apply (fastforce simp: vs_refs_aux_def graph_of_def asid_low_bits_of_mask_eq[symmetric] + ucast_ucast_b is_up_def opt_map_def source_size_def target_size_def + word_size pas_refined_def obj_at_def + dest: aag_wellformed_Control + intro!: state_vrefsD)+ + done lemma decode_page_table_invocation_authorised: "\invs and pas_refined aag and cte_wp_at ((=) (ArchObjectCap cap)) slot @@ -1784,12 +2296,13 @@ lemma decode_page_table_invocation_authorised: apply (unfold decode_page_table_invocation_def decode_pt_inv_map_def authorised_arch_inv_def) apply (wpsimp simp: Let_def is_final_cap_def if_fun_split) apply (clarsimp simp: cte_wp_at_caps_of_state) - apply (prop_tac "\y \ set [x, x + 2 ^ pte_bits .e. x + 2 ^ pt_bits - 1]. table_base y = x") + apply (rename_tac x t m s) + apply (prop_tac "\y \ set [x, x + 2 ^ pte_bits .e. x + 2 ^ pt_bits t - 1]. table_base t y = x") apply (drule (1) caps_of_state_aligned_page_table) apply (clarsimp simp only: is_aligned_neg_mask_eq' 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 t" in neg_mask_mono_le) + apply (drule_tac n="pt_bits t" in neg_mask_mono_le) apply (fastforce dest: plus_mask_AND_NOT_mask_eq) apply (intro conjI; clarsimp) apply (clarsimp simp: authorised_page_table_inv_def) @@ -1801,7 +2314,7 @@ lemma decode_page_table_invocation_authorised: dest: caps_of_state_aligned_page_table pt_walk_is_aligned) apply (frule vs_lookup_table_vref_independent[OF vspace_for_asid_vs_lookup, simplified]) apply (erule pt_walk_is_subject[rotated 4]; fastforce intro: vspace_for_asid_is_subject - simp: user_vtop_canonical_user + simp: user_vtop_leq_canonical_user user_region_def) apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def cap_links_asid_slot_def label_owns_asid_slot_def cap_links_irq_def) @@ -1809,42 +2322,17 @@ lemma decode_page_table_invocation_authorised: cap_auth_conferred_def arch_cap_auth_conferred_def) done -lemma decode_frame_invocation_authorised: +lemma decode_fr_inv_flush_authorised: "\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 K (is_FrameCap cap \ (\(cap, slot) \ {(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 msg slot cap excaps + decode_fr_inv_flush label msg slot cap excaps \\rv. authorised_arch_inv aag rv\,-" - unfolding decode_frame_invocation_def authorised_arch_inv_def decode_fr_inv_map_def - apply (wpsimp wp: check_vp_wpR simp: Let_def authorised_page_inv_def) - apply (rule conj_imp_strg) - apply (cases excaps; clarsimp) - apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def - cap_links_asid_slot_def cap_links_irq_def authorised_slots_def) - apply (prop_tac "msg ! 0 \ user_region") - apply (fastforce dest: not_le_imp_less user_vtop_canonical_user - elim: dual_order.trans is_aligned_no_overflow_mask - simp: user_region_def vmsz_aligned_def) - apply (rule conjI) - apply (frule (1) pt_lookup_slot_vs_lookup_slotI, clarsimp) - apply (drule (1) vs_lookup_slot_unique_level; clarsimp) - apply (clarsimp simp: cte_wp_at_caps_of_state make_user_pte_def pte_ref2_def split: if_splits) - apply (subst (asm) ptrFromPAddr_addr_from_ppn[OF is_aligned_pageBitsForSize_table_size]) - apply (fastforce dest: caps_of_state_valid - simp: valid_cap_def cap_aligned_def pageBitsForSize_pt_bits_left) - apply (fastforce simp: vspace_cap_rights_to_auth_def mask_vm_rights_def validate_vm_rights_def - vm_kernel_only_def vm_read_only_def - split: if_splits) - apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) - apply (subst table_base_pt_slot_offset) - apply (fastforce simp: cte_wp_at_caps_of_state - dest: caps_of_state_aligned_page_table pt_walk_is_aligned) - apply (frule vs_lookup_table_vref_independent[OF vspace_for_asid_vs_lookup, simplified]) - apply (erule pt_walk_is_subject[rotated 4]; fastforce intro: vspace_for_asid_is_subject) - done + unfolding authorised_arch_inv_def authorised_page_inv_def decode_fr_inv_flush_def Let_def + by wpsimp lemma decode_asid_control_invocation_authorised: "\invs and pas_refined aag and cte_wp_at ((=) (ArchObjectCap cap)) slot @@ -1857,13 +2345,9 @@ lemma decode_asid_control_invocation_authorised: \authorised_arch_inv aag\, -" unfolding decode_asid_control_invocation_def authorised_arch_inv_def authorised_asid_control_inv_def apply wpsimp - apply (cases excaps; clarsimp) - apply (rename_tac excaps_tail) - apply (case_tac excaps_tail; clarsimp) - apply (clarsimp simp: aag_cap_auth_def cte_wp_at_caps_of_state) - apply (drule (1) caps_of_state_valid[where cap="UntypedCap _ _ _ _"]) - apply (fastforce simp: valid_cap_def cap_aligned_def is_cap_simps cap_auth_conferred_def - dest: pas_refined_Control) + apply (cases excaps; cases "tl excaps"; clarsimp simp: aag_cap_auth_def cte_wp_at_caps_of_state) + apply (fastforce dest: caps_of_state_valid[where cap="UntypedCap _ _ _ _"] pas_refined_Control + simp: valid_cap_def cap_aligned_def is_cap_simps cap_auth_conferred_def) done lemma decode_asid_pool_invocation_authorised: @@ -1879,9 +2363,9 @@ lemma decode_asid_pool_invocation_authorised: apply wpsimp apply (erule swap[where P="authorised_asid_pool_inv _ _"]) apply (cases excaps; clarsimp) - apply (clarsimp simp: authorised_asid_pool_inv_def is_ASIDPoolCap_def) + apply (clarsimp simp: authorised_asid_pool_inv_def is_ASIDPoolCap_def + pas_refined_def state_objs_to_policy_def auth_graph_map_def) apply (rule conjI) - apply (clarsimp simp: pas_refined_def state_objs_to_policy_def auth_graph_map_def) apply (drule subsetD) apply (fastforce dest!: sbta_caps simp: obj_refs_def cte_wp_at_caps_of_state @@ -1892,6 +2376,90 @@ lemma decode_asid_pool_invocation_authorised: simp: cte_wp_at_caps_of_state valid_cap_def) done +lemma decode_fr_inv_map_authorised: + "\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 K (is_FrameCap cap \ (\(cap, slot) \ {(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_fr_inv_map label msg slot cap excaps + \\rv. authorised_arch_inv aag rv\,-" + unfolding decode_fr_inv_map_def Let_def fun_app_def + apply (wpsimp wp: check_vp_wpR whenE_throwError_wp)+ + apply (subst imp_conjL[symmetric]) + apply (subst imp_disjL[symmetric]) + apply (rule impI) + apply clarsimp + apply (prop_tac "msg ! 0 \ user_region") + apply (prop_tac "\ user_vtop < msg ! 0 + mask (pageBitsForSize xb) \ msg!0 \ user_region") + apply (fastforce intro: dual_order.trans user_vtop_leq_canonical_user is_aligned_no_overflow_mask + simp: user_region_def vmsz_aligned_def not_less) + apply (fastforce dest: cte_wp_valid_cap simp: valid_cap_def wellformed_mapdata_def) + apply (cases excaps, clarsimp) + apply (drule_tac x="excaps ! 0" in bspec, clarsimp)+ + apply (clarsimp simp: authorised_arch_inv_def authorised_page_inv_def authorised_slots_def + aag_cap_auth_def cap_links_asid_slot_def cap_links_irq_def pte_ref2_def + make_user_pte_def cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (rule conjI) + apply (frule (1) pt_lookup_slot_vs_lookup_slotI, clarsimp) + apply (drule (1) vs_lookup_slot_unique_level; clarsimp) + apply (fastforce simp: cte_wp_at_caps_of_state make_user_pte_def pte_ref2_def + vspace_cap_rights_to_auth_def validate_vm_rights_def + mask_vm_rights_def vm_read_only_def vm_kernel_only_def + split: if_splits) + apply (fastforce elim: pt_lookup_slot_from_level_is_subject[rotated 4] + intro: vs_lookup_table_vref_independent[OF vspace_for_asid_vs_lookup] + pas_refined_Control[symmetric] + simp: pt_lookup_slot_def) + done + +lemma decode_frame_invocation_authorised: + "\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 K (is_FrameCap cap \ (\(cap, slot) \ {(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 msg slot cap excaps + \\rv. authorised_arch_inv aag rv\,-" + unfolding decode_frame_invocation_def + by (wpsimp wp: decode_fr_inv_flush_authorised decode_fr_inv_map_authorised + simp: authorised_arch_inv_def authorised_page_inv_def) + +lemma decode_vspace_invocation_authorised: + "\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 K (is_PageTableCap cap \ (\(cap, slot) \ {(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_vspace_invocation label msg slot cap excaps + \\rv. authorised_arch_inv aag rv\, -" + unfolding decode_vspace_invocation_def decode_vs_inv_flush_def authorised_arch_inv_def Let_def + by wpsimp + +lemma decode_vcpu_invocation_authorised: + "\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 K (is_VCPUCap cap \ (\(cap, slot) \ {(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 msg cap excaps + \\rv. authorised_arch_inv aag rv\, -" + 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 authorised_arch_inv_def + apply (rule hoare_gen_asmE) + apply (rule_tac Q'="\rv s. \x. rv = InvokeVCPU x \ authorised_vcpu_inv aag x" + in hoare_strengthen_postE_R[rotated], clarsimp) + apply wpsimp + apply (fastforce elim: caps_of_state_pasObjectAbs_eq + simp: authorised_vcpu_inv_def cte_wp_at_caps_of_state + cap_auth_conferred_def arch_cap_auth_conferred_def) + done + lemma decode_arch_invocation_authorised: "\invs and pas_refined aag and cte_wp_at ((=) (ArchObjectCap cap)) slot and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) @@ -1903,7 +2471,8 @@ lemma decode_arch_invocation_authorised: \authorised_arch_inv aag\, -" unfolding arch_decode_invocation_def apply (wpsimp wp: decode_page_table_invocation_authorised decode_asid_pool_invocation_authorised - decode_asid_control_invocation_authorised decode_frame_invocation_authorised) + decode_asid_control_invocation_authorised decode_frame_invocation_authorised + decode_vcpu_invocation_authorised decode_vspace_invocation_authorised) apply auto done @@ -1920,15 +2489,16 @@ lemma set_thread_state_authorised_arch_inv[wp]: apply (clarsimp simp: authorised_arch_inv_def authorised_page_inv_def authorised_slots_def split: arch_invocation.splits page_invocation.splits) apply (wpsimp wp: set_object_wp)+ - apply (clarsimp simp: authorised_arch_inv_def authorised_page_inv_def - authorised_slots_def vs_lookup_slot_def obind_def - split: arch_invocation.splits page_invocation.splits if_splits option.splits) - apply (clarsimp simp: vs_lookup_table_def obind_def vspace_for_pool_def - split: option.splits if_splits) - apply (subgoal_tac "(\p. pte_of p ((pts_of s)(ref := None))) = ptes_of s") - apply fastforce - apply (fastforce simp: pte_of_def obind_def pts_of_Some aobjs_of_Some get_tcb_def - split: option.splits) + apply (clarsimp simp: authorised_arch_inv_def) + apply (case_tac i; clarsimp) + apply (clarsimp simp: authorised_page_inv_def authorised_slots_def split: page_invocation.splits) + apply (erule_tac x=level in allE) + apply (erule_tac x=asid in allE) + apply (erule_tac x=vref in allE) + apply (drule mp) + apply (fastforce elim: subst[OF vs_lookup_table_eq_lift, rotated -1] + simp: vs_lookup_slot_table get_tcb_def opt_map_def + split: option.splits kernel_object.splits if_splits)+ done end diff --git a/proof/access-control/AARCH64/ArchCNode_AC.thy b/proof/access-control/AARCH64/ArchCNode_AC.thy index 39053ab651..3bab3f2231 100644 --- a/proof/access-control/AARCH64/ArchCNode_AC.thy +++ b/proof/access-control/AARCH64/ArchCNode_AC.thy @@ -10,7 +10,7 @@ begin section\Arch-specific CNode AC.\ -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 declare arch_post_modify_registers_def[simp] declare arch_post_cap_deletion_def[simp] @@ -56,29 +56,8 @@ lemma sata_update2[CNode_AC_assms]: simp: cap_links_asid_slot_def label_owns_asid_slot_def split: if_split_asm) -lemma state_vrefs_eqI: - "\ \bot_level asid vref level p. - bot_level < level \ vs_lookup_table level asid vref s = Some (level, p) - \ (if level \ max_pt_level - then pts_of s' p = pts_of s p - else asid_pools_of s' p = asid_pools_of s p); - aobjs_of s' = aobjs_of s; asid_table s' = asid_table s; - pspace_aligned s; valid_vspace_objs s; valid_asid_table s \ - \ state_vrefs (s' :: 'a :: state_ext state) = state_vrefs (s :: 'a :: state_ext state)" - apply (rule ext) - apply safe - apply (subst (asm) state_vrefs_def, clarsimp) - apply (fastforce intro: state_vrefsD elim: subst[OF vs_lookup_table_eqI,rotated -1]) - apply (subst (asm) state_vrefs_def, clarsimp) - apply (rule state_vrefsD) - apply (subst vs_lookup_table_eqI; fastforce) - apply fastforce+ - done - lemma set_cap_state_vrefs[CNode_AC_assms, wp]: - "\pspace_aligned and valid_vspace_objs and valid_arch_state and (\s. P (state_vrefs s))\ - set_cap cap slot - \\_ s :: det_ext state. P (state_vrefs s)\" + "set_cap cap slot \\s :: det_ext state. P (state_vrefs s)\" apply (simp add: set_cap_def set_object_def) apply (wpsimp wp: get_object_wp) apply safe @@ -86,10 +65,8 @@ lemma set_cap_state_vrefs[CNode_AC_assms, wp]: by (fastforce simp: valid_arch_state_def obj_at_def opt_map_def split: option.splits kernel_object.splits)+ -crunch maskInterrupt - for underlying_memory[CNode_AC_assms, wp]: "\s. P (underlying_memory s)" - and device_state[CNode_AC_assms, wp]: "\s. P (device_state s)" - (simp: maskInterrupt_def) +declare maskInterrupt_underlying_memory_inv[CNode_AC_assms, wp] + maskInterrupt_device_state_inv[CNode_AC_assms, wp] crunch set_cdt for state_vrefs[CNode_AC_assms, wp]: "\s. P (state_vrefs s)" @@ -100,14 +77,12 @@ crunch prepare_thread_delete, arch_finalise_cap (wp: crunch_wps hoare_vcg_if_lift2 simp: unless_def) lemma state_vrefs_tcb_upd[CNode_AC_assms]: - "\ pspace_aligned s; valid_vspace_objs s; valid_arch_state s; tcb_at t s \ - \ state_vrefs (s\kheap := (kheap s)(t \ TCB tcb)\) = state_vrefs s" + "tcb_at t s \ state_vrefs (s\kheap := (kheap s)(t \ TCB tcb)\) = state_vrefs s" apply (rule state_vrefs_eqI) by (fastforce simp: opt_map_def obj_at_def is_obj_defs valid_arch_state_def)+ lemma state_vrefs_simple_type_upd[CNode_AC_assms]: - "\ pspace_aligned s; valid_vspace_objs s; valid_arch_state s; - ko_at ko ptr s; is_simple_type ko; a_type ko = a_type (f val) \ + "\ ko_at ko ptr s; is_simple_type ko; a_type ko = a_type (f val) \ \ state_vrefs (s\kheap := (kheap s)(ptr \ f val)\) = state_vrefs s" apply (case_tac ko; case_tac "f val"; clarsimp) by (fastforce intro!: state_vrefs_eqI simp: opt_map_def obj_at_def is_obj_defs valid_arch_state_def)+ @@ -158,7 +133,7 @@ proof goal_cases qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemma integrity_asids_set_cap_Nullcap[CNode_AC_assms]: "\(=) s\ set_cap NullCap slot \\_. integrity_asids aag subjects x a s\" @@ -185,7 +160,7 @@ proof goal_cases qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemma arch_post_cap_deletion_pas_refined[CNode_AC_assms, wp]: "arch_post_cap_deletion irqopt \pas_refined aag\" @@ -223,7 +198,7 @@ proof goal_cases qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemma arch_derive_cap_auth_derived[CNode_AC_assms]: "\\s. cte_wp_at (auth_derived (ArchObjectCap cap)) src_slot s\ @@ -327,7 +302,7 @@ global_interpretation CNode_AC_4?: CNode_AC_4 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact CNode_AC_assms)?) + by (unfold_locales; fact CNode_AC_assms) qed diff --git a/proof/access-control/AARCH64/ArchDomainSepInv.thy b/proof/access-control/AARCH64/ArchDomainSepInv.thy index 6d295b84e4..75be93b3ce 100644 --- a/proof/access-control/AARCH64/ArchDomainSepInv.thy +++ b/proof/access-control/AARCH64/ArchDomainSepInv.thy @@ -9,14 +9,26 @@ imports "DomainSepInv" begin -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems DomainSepInv_assms -crunch arch_post_cap_deletion, set_pt, set_asid_pool, prepare_thread_delete, init_arch_objects +crunch arch_post_cap_deletion, set_pt, set_asid_pool, init_arch_objects for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" (wp: domain_sep_inv_triv crunch_wps set_asid_pool_cte_wp_at set_pt_cte_wp_at) +crunch vcpu_update + for domain_sep_inv[wp]: "domain_sep_inv irqs st" + (wp: domain_sep_inv_triv crunch_wps set_asid_pool_cte_wp_at set_pt_cte_wp_at) + +crunch vcpu_save_reg, vcpu_invalidate_active, dissociate_vcpu_tcb, fpu_thread_delete + for interrupt_states[wp]: "\s. P (interrupt_states s)" + (wp: crunch_wps) + +crunch prepare_thread_delete + for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" + (wp: domain_sep_inv_triv crunch_wps) + crunch arch_finalise_cap for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" (wp: crunch_wps simp: crunch_simps) @@ -25,6 +37,22 @@ lemma arch_finalise_cap_rv[DomainSepInv_assms]: "\\_. P (NullCap,NullCap)\ arch_finalise_cap c x \\rv _. P rv\" unfolding arch_finalise_cap_def by wpsimp +lemma arch_derive_cap_domain_sep_inv[DomainSepInv_assms, wp]: + "\\\ arch_derive_cap acap \\rv _. domain_sep_inv_cap irqs rv\,-" + unfolding arch_derive_cap_def + by wpsimp + +lemma arch_post_modify_registers_domain_sep_inv[DomainSepInv_assms, wp]: + "arch_post_modify_registers cur t \domain_sep_inv irqs st\" + unfolding arch_post_modify_registers_def by wpsimp + +crunch handle_vm_fault, handle_vm_fault, perform_pg_inv_unmap, + perform_pg_inv_get_addr, perform_pt_inv_map, perform_pt_inv_unmap, + handle_arch_fault_reply, arch_mask_irq_signal, arch_switch_to_thread, + arch_switch_to_idle_thread, arch_activate_idle_thread, store_asid_pool_entry + for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" + (wp: crunch_wps) + end @@ -32,28 +60,22 @@ global_interpretation DomainSepInv_1?: DomainSepInv_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact DomainSepInv_assms | wp init_arch_objects_inv)) + by (unfold_locales; (fact DomainSepInv_assms)?) qed +context Arch begin global_naming AARCH64 -context Arch begin global_naming RISCV64 - -crunch - handle_reserved_irq, handle_vm_fault, perform_pg_inv_map, perform_pg_inv_unmap, - perform_pg_inv_get_addr, perform_pt_inv_map, perform_pt_inv_unmap, - handle_hypervisor_fault, handle_arch_fault_reply, arch_mask_irq_signal, - arch_switch_to_thread, arch_switch_to_idle_thread, arch_activate_idle_thread, - store_asid_pool_entry, copy_global_mappings - for domain_sep_inv[DomainSepInv_assms, wp]: "domain_sep_inv irqs st" - (wp: crunch_wps) +crunch perform_pg_inv_map, perform_flush + for domain_sep_inv[wp]: "domain_sep_inv irqs st" + (wp: crunch_wps simp: crunch_simps) lemma perform_page_invocation_domain_sep_inv: "\domain_sep_inv irqs st and valid_page_inv pgi\ perform_page_invocation pgi - \\_. domain_sep_inv irqs st\" + \\_ (s :: det_ext state). domain_sep_inv irqs st s\" apply (rule hoare_pre) apply (wp mapM_wp[OF _ subset_refl] set_cap_domain_sep_inv mapM_x_wp[OF _ subset_refl] - perform_page_invocation_domain_sep_inv_get_cap_helper hoare_weak_lift_imp + perform_page_invocation_domain_sep_inv_get_cap_helper | simp add: perform_page_invocation_def o_def | wpc)+ done @@ -73,7 +95,7 @@ lemma perform_asid_control_invocation_domain_sep_inv: unfolding perform_asid_control_invocation_def apply (rule hoare_pre) apply (wp modify_wp cap_insert_domain_sep_inv' set_cap_domain_sep_inv - get_cap_domain_sep_inv_cap[where st=st] hoare_weak_lift_imp + get_cap_domain_sep_inv_cap[where st=st] hoare_vcg_imp_lift | wpc | simp )+ done @@ -84,10 +106,27 @@ lemma perform_asid_pool_invocation_domain_sep_inv: apply (wp set_cap_domain_sep_inv get_cap_wp | wpc | simp)+ done +lemma perform_vspace_invocation_domain_sep_inv[wp]: + "perform_vspace_invocation iv \domain_sep_inv irqs st\" + by (wpsimp simp: perform_vspace_invocation_def) + +crunch invoke_vcpu_inject_irq, invoke_vcpu_read_register, invoke_vcpu_write_register, invoke_vcpu_ack_vppi + for domain_sep_inv[wp]: "domain_sep_inv irqs st" + +lemma associate_vcpu_tcb_domain_sep_inv[wp]: + "associate_vcpu_tcb a b \domain_sep_inv irqs st\" + unfolding associate_vcpu_tcb_def + by (wpsimp | wp domain_sep_inv_triv)+ + +lemma perform_vcpu_invocation_domain_sep_inv[wp]: + "perform_vcpu_invocation vcpu \domain_sep_inv irqs st\" + unfolding perform_vcpu_invocation_def + by wpsimp + lemma arch_perform_invocation_domain_sep_inv[DomainSepInv_assms]: "\domain_sep_inv irqs st and valid_arch_inv ai\ arch_perform_invocation ai - \\_. domain_sep_inv irqs st\" + \\_ (s :: det_ext state). domain_sep_inv irqs st s\" unfolding arch_perform_invocation_def apply (wpsimp wp: perform_page_table_invocation_domain_sep_inv perform_page_invocation_domain_sep_inv @@ -112,14 +151,14 @@ lemma arch_invoke_irq_control_domain_sep_inv[DomainSepInv_assms]: apply (wpsimp wp: do_machine_op_domain_sep_inv simp: arch_irq_control_inv_valid_def)+ done -lemma arch_derive_cap_domain_sep_inv[DomainSepInv_assms, wp]: - "\\\ arch_derive_cap acap \\rv _. domain_sep_inv_cap irqs rv\,-" - unfolding arch_derive_cap_def - by wpsimp +crunch handle_reserved_irq, handle_hypervisor_fault + for domain_sep_inv[wp]: + "\s :: det_ext state. domain_sep_inv irqs (st :: 's :: state_ext state) s" + (wp: crunch_wps simp: crunch_simps vcpu_update_def valid_vcpu_def valid_fault_def) -lemma arch_post_modify_registers_domain_sep_inv[DomainSepInv_assms, wp]: - "arch_post_modify_registers cur t \domain_sep_inv irqs st\" - unfolding arch_post_modify_registers_def by wpsimp +\ \Remove the parentheses\ +declare handle_reserved_irq_domain_sep_inv[simplified and_assoc, DomainSepInv_assms] +declare handle_hypervisor_fault_domain_sep_inv[simplified and_assoc, DomainSepInv_assms] end diff --git a/proof/access-control/AARCH64/ArchFinalise_AC.thy b/proof/access-control/AARCH64/ArchFinalise_AC.thy index c523ccf513..b852399327 100644 --- a/proof/access-control/AARCH64/ArchFinalise_AC.thy +++ b/proof/access-control/AARCH64/ArchFinalise_AC.thy @@ -8,12 +8,12 @@ theory ArchFinalise_AC imports Finalise_AC begin -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems Finalise_AC_assms lemma state_vrefs_clear_asid_table: - "state_vrefs (s\arch_state := arch_state s\riscv_asid_table := \a. if a = asid_high_bits_of base + "state_vrefs (s\arch_state := arch_state s\arm_asid_table := \a. if a = asid_high_bits_of base then None else asid_table s a\\) x \ state_vrefs s x" @@ -22,82 +22,160 @@ lemma state_vrefs_clear_asid_table: lemma state_vrefs_clear_asid_pool: assumes "asid_table s (asid_high_bits_of asid) = Some pool_ptr" and "ako_at (ASIDPool pool) pool_ptr s" - shows "state_vrefs (s\kheap := \a. if a = pool_ptr - then Some (ArchObj (ASIDPool (\a. if a = asid_low_bits_of asid - then None - else pool a))) - else kheap s a\) x - \ state_vrefs s x" + shows "state_vrefs (s\kheap := (kheap s)(pool_ptr \ ArchObj + (ASIDPool (\a. if a = asid_low_bits_of asid then None else pool a)))\) x + \ state_vrefs s x" + apply (rule state_vrefs_subseteq) + using assms + by (auto simp: vspace_for_pool_def entry_for_pool_def opt_map_def obind_def obj_at_def) + +lemma pas_refined_arm_next_vmid[simp]: + "pas_refined aag (s\arch_state := arch_state s\arm_next_vmid := v\\) = pas_refined aag s" + by (auto simp: pas_refined_def state_objs_to_policy_def state_vrefs_def) + +lemma pas_refined_arm_vmid_table[simp]: + "pas_refined aag (s\arch_state := arch_state s\arm_vmid_table := v\\) = pas_refined aag s" + by (auto simp: pas_refined_def state_objs_to_policy_def state_vrefs_def) + +crunch invalidate_vmid_entry + for pas_refined[wp]: "pas_refined aag" + +lemma set_vcpu_state_vrefs[wp]: + "set_vcpu ptr vcpu \\s. P (state_vrefs s)\" + apply (wpsimp wp: set_vcpu_wp) + apply (erule_tac P=P in rsubst) + apply (fastforce intro: state_vrefs_eqI simp: opt_map_def typ_at_eq_kheap_obj) + done + +lemma state_vrefs_set_asid_pool_vmid: + assumes "pool_for_asid asid s = Some pool_ptr" + and "asid_pools_of s pool_ptr = Some pool" + and "pool (asid_low_bits_of asid) = Some entry" + shows "state_vrefs + (s\kheap := (kheap s) + (pool_ptr \ + ArchObj + (ASIDPool + (\a. if a = asid_low_bits_of asid + then Some (ASIDPoolVSpace vmid (ap_vspace entry)) else pool a)))\) + x + \ state_vrefs s x" (is "state_vrefs ?s' _ \ state_vrefs _ _") + apply (rule state_vrefs_subseteq) using assms - apply - - apply (clarsimp simp: state_vrefs_def) - apply (rule exI, rule conjI) - apply (rule_tac x=lvl in exI) - apply (rule_tac x="if x = pool_ptr then ASIDPool pool else ao" in exI) - apply (rule conjI, rule refl) - apply (rule_tac x=bot in exI) - apply (rule_tac x=asida in exI) - apply (rule_tac x=vref in exI) - apply (prop_tac "ptes_of ?s' = ptes_of s") - apply (fastforce simp: obj_at_def all_ext ptes_of_def obind_def opt_map_def) - apply (fastforce simp: vs_lookup_table_def vspace_for_pool_def obj_at_def obind_def opt_map_def - split: option.split_asm if_split_asm) - apply (fastforce simp: vs_refs_aux_def graph_of_def opt_map_def split: if_splits) + by (auto simp: vspace_for_pool_def entry_for_pool_def opt_map_def obind_def obj_at_def + split: option.splits) + +lemma update_asid_pool_entry_vmid_pas_refined[wp]: + "update_asid_pool_entry (\entry. Some (ASIDPoolVSpace vmid (ap_vspace entry))) asid \pas_refined aag\" + unfolding update_asid_pool_entry_def set_asid_pool_def + apply (wpsimp wp: set_object_wp)+ + apply (erule pas_refined_subseteq; clarsimp?) + apply (rule caps_of_state_fun_upd) + apply (clarsimp simp: obj_at_def opt_map_def split: option.splits) + apply (erule rev_subsetD, rule state_vrefs_subseteq) + apply (auto simp: vspace_for_pool_def entry_for_pool_def opt_map_def obind_def + split: option.splits kernel_object.splits)[4] + apply (rule thread_st_auth_fun_upd) + apply (clarsimp simp: obj_at_def asid_pools_of_ko_at get_tcb_def) + apply (rule thread_bound_ntfns_fun_upd) + apply (clarsimp simp: asid_pools_of_ko_at get_tcb_def obj_at_def) + done + +lemma tcb_vcpu_update_pas_refined[wp]: + "arch_thread_set v t \pas_refined aag\" + apply (wpsimp wp: arch_thread_set_wp) + apply (erule pas_refined_subseteq; clarsimp?) + apply (rule caps_of_state_fun_upd) + apply (clarsimp simp: obj_at_def get_tcb_def tcb_cap_cases_def + split: option.splits kernel_object.splits) + apply (erule rev_subsetD, rule state_vrefs_subseteq) + apply (auto simp: vspace_for_pool_def entry_for_pool_def opt_map_def obind_def get_tcb_def + split: option.splits kernel_object.splits)[4] + apply (rule thread_st_auth_fun_upd) + apply (clarsimp simp: obj_at_def asid_pools_of_ko_at get_tcb_def) + apply (rule thread_bound_ntfns_fun_upd) + apply (clarsimp simp: obj_at_def asid_pools_of_ko_at get_tcb_def) done -crunch set_vm_root for pas_refined[wp]: "pas_refined aag" +lemma set_vcpu_pas_refined[wp]: + "set_vcpu ptr vcpu \\s. pas_refined aag s\" + apply (wpsimp wp: set_vcpu_wp) + apply (erule pas_refined_subseteq; clarsimp?) + apply (fastforce simp: caps_of_state_fun_upd obj_at_def) + apply (erule rev_subsetD, rule state_vrefs_subseteq) + apply (auto simp: vspace_for_pool_def entry_for_pool_def opt_map_def obind_def obj_at_def)[4] + apply (fastforce simp: thread_st_auth_fun_upd obj_at_def asid_pools_of_ko_at get_tcb_def) + apply (fastforce simp: thread_bound_ntfns_fun_upd obj_at_def asid_pools_of_ko_at get_tcb_def) + done + +lemma vcpu_update_pas_refined: + "vcpu_update vr f \\s. pas_refined aag s\" + unfolding vcpu_update_def + by (wpsimp wp: get_vcpu_wp) + +crunch set_vm_root, invalidate_asid_entry + for pas_refined[wp]: "pas_refined aag" + (wp: crunch_wps ignore: update_asid_pool_entry) lemma delete_asid_pool_pas_refined[wp]: "delete_asid_pool base ptr \pas_refined aag\" - unfolding delete_asid_pool_def - apply wpsimp - apply (clarsimp simp: pas_refined_def state_objs_to_policy_def) - apply (rule conjI; clarsimp) - apply (erule subsetD) - apply (clarsimp simp: auth_graph_map_def) - apply (rule exI, rule conjI, rule refl)+ - apply (erule state_bits_to_policy_vrefs_subseteq; fastforce?) - apply (clarsimp simp: allI state_vrefs_clear_asid_table) - apply (erule subsetD, erule state_asids_to_policy_vrefs_subseteq) - apply clarsimp - apply (clarsimp simp: allI state_vrefs_clear_asid_table) - apply clarsimp + apply (wpsimp simp: delete_asid_pool_def) + apply (rule_tac Q'="\_ s. pas_refined aag s \ asid_low_bits_of base = 0 \ + arm_asid_table (arch_state s) = asid_table \ asid_pool_at ptr s" + in hoare_strengthen_post[rotated], clarsimp) + apply (erule pas_refined_subseteq; clarsimp?) + apply (erule rev_subsetD, rule state_vrefs_subseteq) + apply (auto simp: pool_for_asid_def)[4] + apply (wpsimp wp: mapM_wp')+ + apply (clarsimp simp: asid_pools_at_eq) done lemma delete_asid_pas_refined[wp]: "delete_asid asid pt \pas_refined aag\" - unfolding delete_asid_def - apply (rule bind_wp) - apply (wpsimp simp: set_asid_pool_def wp: set_object_wp hoare_vcg_imp_lift' hoare_vcg_all_lift) - apply (rule_tac Q'="\_ s. riscv_asid_table (arch_state s) = asid_table \ - ako_at (ASIDPool pool) x2 s \ pas_refined aag s" - in hoare_strengthen_post[rotated]) - defer - apply wpsimp+ - apply (clarsimp simp: pas_refined_def) - apply (intro conjI) - apply (clarsimp simp: state_objs_to_policy_def) - apply (subst (asm) caps_of_state_fun_upd[simplified fun_upd_def]) - apply (clarsimp simp: obj_at_def) - apply (erule subsetD) - apply (clarsimp simp: auth_graph_map_def) - apply (rule exI, rule conjI, rule refl)+ - apply (erule state_bits_to_policy_vrefs_subseteq) - apply clarsimp - apply (clarsimp simp: all_ext thread_st_auth_def tcb_states_of_state_def get_tcb_def obj_at_def) - apply (clarsimp simp: all_ext thread_bound_ntfns_def get_tcb_def obj_at_def) - apply clarsimp - apply (rule allI[OF state_vrefs_clear_asid_pool]; simp) - apply clarsimp - apply (erule subsetD, erule state_asids_to_policy_vrefs_subseteq) - apply (fastforce simp: obj_at_def caps_of_state_fun_upd[simplified fun_upd_def]) - apply (rule allI[OF state_vrefs_clear_asid_pool]; fastforce) - apply fastforce - apply (fastforce simp: obj_at_def caps_of_state_fun_upd[simplified fun_upd_def]) + apply (wpsimp wp: set_object_wp simp: delete_asid_def set_asid_pool_def simp_del: fun_upd_apply) + apply (rule_tac Q'="\_ s. pas_refined aag s \ pool_for_asid asid s = Some x2 \ asid_pool_at x2 s" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: asid_pools_at_eq) + apply (erule pas_refined_subseteq; clarsimp?) + apply (rule caps_of_state_fun_upd) + apply (clarsimp simp: obj_at_def opt_map_def split: option.splits) + apply (erule rev_subsetD, rule state_vrefs_subseteq) + apply (auto simp: vspace_for_pool_def entry_for_pool_def opt_map_def obind_def + split: option.splits)[4] + apply (rule thread_st_auth_fun_upd) + apply (clarsimp simp: obj_at_def get_tcb_def opt_map_def split: option.splits) + apply (rule thread_bound_ntfns_fun_upd) + apply (clarsimp simp: obj_at_def get_tcb_def opt_map_def split: option.splits) + apply wpsimp+ + apply (clarsimp simp: asid_pools_at_eq) done -lemma arch_finalise_cap_pas_refined[wp]: +lemma state_vrefs_set_current_vcpu[simp]: + "state_vrefs (s\arch_state := arch_state s\arm_current_vcpu := vcpu\\) + = state_vrefs s" + by (fastforce simp: state_vrefs_def dest: vs_lookup_clear_asid_table[simplified fun_upd_def]) + +lemma pas_refined_arm_current_vcpu_upd[simp]: + "pas_refined aag (s\arch_state := arch_state s\arm_current_vcpu := v\\) + = pas_refined aag s" + by (fastforce elim: pas_refined_by_subsets simp: state_objs_to_policy_def) + +crunch vcpu_invalidate_active + for pas_refined[wp]: "pas_refined aag" + (wp: crunch_wps simp: crunch_simps) + +lemma dissociate_vcpu_tcb_pas_refined[wp]: + "dissociate_vcpu_tcb vr t \pas_refined aag\" + unfolding dissociate_vcpu_tcb_def + by (wpsimp wp: get_vcpu_wp arch_thread_get_wp) + +lemma vcpu_finalise_cap_pas_refined[wp]: + "vcpu_finalise vr \pas_refined aag\" + unfolding vcpu_finalise_def + by (wpsimp wp: get_vcpu_wp) + +lemma arch_finalise_cap_pas_refined[Finalise_AC_assms, wp]: "\pas_refined aag and invs and valid_arch_cap c\ arch_finalise_cap c x \\_. pas_refined aag\" unfolding arch_finalise_cap_def apply (wpsimp wp: unmap_page_pas_refined unmap_page_table_pas_refined) @@ -105,19 +183,22 @@ lemma arch_finalise_cap_pas_refined[wp]: done crunch prepare_thread_delete - for pas_refined[wp]: "pas_refined aag" + for pas_refined[Finalise_AC_assms, wp]: "pas_refined aag" -crunch prepare_thread_delete - for respects[Finalise_AC_assms, wp]: "integrity aag X st" +lemma prepare_thread_delete_integrity[Finalise_AC_assms, wp]: + "\integrity aag X st and K (is_subject aag t)\ prepare_thread_delete t \\_. integrity aag X st\" + unfolding prepare_thread_delete_def + apply (wpsimp wp: dissociate_vcpu_tcb_respects arch_thread_get_wp + dmo_no_mem_respects hoare_vcg_all_lift hoare_vcg_imp_lift + simp: fpu_thread_delete_def) + using associated_vcpu_is_subject get_tcb_Some_ko_at by blast lemma sbn_st_vrefs[Finalise_AC_assms]: - "\(\s. P (state_vrefs s)) and pspace_aligned and valid_vspace_objs and valid_arch_state\ - set_bound_notification t st - \\_ s. P (state_vrefs s)\" + "set_bound_notification t st \\s. P (state_vrefs s)\" apply (simp add: set_bound_notification_def) apply (wpsimp wp: set_object_wp dxo_wp_weak) apply (subst state_vrefs_tcb_upd) - apply (auto simp: tcb_at_def) + apply (auto simp: tcb_at_def valid_arch_state_def) done lemma arch_finalise_cap_auth'[Finalise_AC_assms]: @@ -141,10 +222,43 @@ lemma arch_cap_cleanup_wf[Finalise_AC_assms]: \ (\irq. arch_cap_cleanup_opt acap = IRQHandlerCap irq \ is_subject_irq aag irq)" by simp -lemma set_vm_root_integrity[wp]: - "set_vm_root param_a \integrity aag X st\ " - unfolding set_vm_root_def - by (wpsimp wp: dmo_wp mol_respects get_cap_wp simp: setVSpaceRoot_def) +lemma update_asid_pool_entry_vmid_integrity: + "\\s. integrity aag X st s \ (vmid = None \ vmid_for_asid s asid = None)\ + update_asid_pool_entry (\entry. Some (ASIDPoolVSpace vmid (ap_vspace entry))) asid + \\_. integrity aag X st\" + unfolding update_asid_pool_entry_def set_asid_pool_def + apply (wpsimp wp: set_object_wp simp_del: fun_upd_apply) + apply (clarsimp simp: integrity_def) + apply (subst tcb_states_of_state_fun_upd, fastforce simp: get_tcb_def asid_pools_of_ko_at obj_at_def)+ + apply (intro conjI; clarsimp?) + apply (erule_tac allE, erule tro_trans_spec) + apply (force intro!: tro_arch arch_troa_asidpool_vmid + simp: asid_pools_of_ko_at vmid_for_asid_def entry_for_pool_def pool_for_asid_def + obj_at_def obind_def opt_map_def + split: option.splits if_splits) + apply (erule_tac x=asid in allE, auto simp: pool_for_asid_def) + done + +lemma store_vmid_Some_integrity: + "\\s. integrity aag X st s \ vmid_for_asid s asid = None\ + store_vmid asid vmid + \\_. integrity aag X st\" + unfolding store_vmid_def + by (wpsimp wp: update_asid_pool_entry_vmid_integrity) + +crunch find_free_vmid + for respects[wp]: "integrity aag X st" + (wp: update_asid_pool_entry_vmid_integrity dmo_no_mem_respects ignore: update_asid_pool_entry) + +lemma get_vmid_respects[wp]: + "get_vmid asid \integrity aag X st\" + unfolding get_vmid_def + by (wpsimp wp: store_vmid_Some_integrity) + +crunch arm_context_switch, set_global_user_vspace, set_vm_root, + invalidate_vmid_entry, invalidate_asid_entry, invalidate_tlb_by_asid + for respects[wp]: "integrity aag X st" + (wp: dmo_no_mem_respects ignore: update_asid_pool_entry) lemma delete_asid_pool_respects[wp]: "\integrity aag X st and @@ -152,87 +266,88 @@ lemma delete_asid_pool_respects[wp]: \ is_subject_asid aag asid')\ delete_asid_pool x y \\_. integrity aag X st\" - unfolding delete_asid_pool_def - by (wpsimp wp: mapM_wp[OF _ subset_refl] simp: integrity_asid_table_entry_update' integrity_def) - -crunch set_vm_root - for integrity_obj[wp]: "integrity_obj_state aag activate subjects st" - and cdt[wp]: "\s. P (cdt s)" - and is_original_cap[wp]: "\s. P (is_original_cap s x)" - and interrupt_irq_node[wp]: "\s. P (interrupt_states s x)" - and underlying_memory[wp]: "\s. P (underlying_memory (machine_state s) x)" - and device_state[wp]: "\s. P (device_state (machine_state s) x)" - and tcb_states_of_state[wp]: "\s. P (tcb_states_of_state s)" - (wp: dmo_wp) + by (wpsimp simp: delete_asid_pool_def wp: asid_table_entry_update_integrity mapM_wp') crunch set_asid_pool for is_original_cap[wp]: "\s. P (is_original_cap s x)" - and cdt_list[wp]: "\s. P (cdt_list s x)" - and ready_queues[wp]: "\s. P (ready_queues s x y)" - and machine_state[wp]: "\s. P (machine_state s)" lemma set_asid_pool_tcb_states_of_state[wp]: "set_asid_pool p pool \\s. P (tcb_states_of_state s)\" - apply (wpsimp wp: set_object_wp_strong simp: obj_at_def set_asid_pool_def) - apply (prop_tac "\x. get_tcb x (s\kheap := (kheap s)(p \ ArchObj (ASIDPool pool))\) = get_tcb x s") - apply (auto simp: tcb_states_of_state_def get_tcb_def) - done - -lemma delete_asid_integrity_asids: - "\\s. pas_refined aag s \ invs s \ is_subject aag pt \ - (\x a. integrity_asids aag {pasSubject aag} x a st s)\ - delete_asid asid pt - \\_ s. integrity_asids aag {pasSubject aag} x a st s\" - unfolding integrity_def - apply (wpsimp wp: dmo_wp mol_respects set_object_wp hoare_vcg_all_lift hoare_vcg_imp_lift - simp: delete_asid_def hwASIDFlush_def set_asid_pool_def) - apply (intro conjI impI allI; clarsimp) - apply fastforce - apply (clarsimp simp: opt_map_def) - apply (erule_tac x=asid in allE, fastforce) + apply (wpsimp wp: set_object_wp_strong simp: obj_at_def set_asid_pool_def) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: tcb_states_of_state_def get_tcb_def split: kernel_object.splits) done -lemma set_asid_pool_respects_clear: +lemma set_asid_pool_integrity_objs: "\integrity_obj_state aag activate subjects st and (\s. \pool'. ako_at (ASIDPool pool') ptr s \ asid_pool_integrity subjects aag pool' pool)\ set_asid_pool ptr pool \\_. integrity_obj_state aag activate subjects st\" apply (wpsimp wp: set_object_wp_strong simp: obj_at_def set_asid_pool_def) - using arch_troa_asidpool_clear tro_arch tro_trans_spec by fastforce + by (fastforce elim: tro_trans_spec + intro: tro_arch arch_troa_asidpool_clear + simp: a_type_def aa_type_def + split: if_splits kernel_object.splits arch_kernel_obj.splits) + +lemma set_asid_pool_integrity_autarch: + "\\s. integrity aag X st s \ pas_refined aag s \ invs s \ + (\asid pool. pool_for_asid asid s = Some pool_ptr \ asid_pools_of s pool_ptr = Some pool \ + pool' = pool (asid_low_bits_of asid := None) \ + (\entry. pool (asid_low_bits_of asid) = Some entry + \ is_subject aag (ap_vspace entry)))\ + set_asid_pool pool_ptr pool' + \\_. integrity aag X st\" + unfolding integrity_def conj_assoc[symmetric] + apply (wp set_object_wp_strong set_asid_pool_integrity_objs dmo_wp hoare_vcg_all_lift + | wps | simp add: obj_at_def set_asid_pool_def)+ + apply (intro conjI impI; clarsimp) + apply (fastforce simp: opt_map_def asid_pool_integrity_def aag_has_Control_iff_owns) + apply (erule_tac x=pool_ptr in allE)+ + apply (erule_tac x=asid in allE)+ + apply (fastforce simp: asid_pools_of_ko_at obj_at_def pool_for_asid_def) + done lemma delete_asid_respects: - "\integrity aag X st and pas_refined aag and invs and K (is_subject aag pd)\ + "\integrity aag X st and pas_refined aag and invs and K (0 < asid \ is_subject aag pd)\ delete_asid asid pd \\_. integrity aag X st\" - unfolding integrity_def - supply integrity_asids_def[simp del] - apply (rule hoare_pre) - apply (simp only: conj_assoc[symmetric]) - apply (rule hoare_vcg_conj_lift) - apply (simp add: delete_asid_def) - apply (wp | wpc | wps)+ - apply (wpsimp wp: set_asid_pool_respects_clear dmo_wp - delete_asid_integrity_asids hoare_vcg_all_lift)+ - apply (clarsimp simp: pas_refined_refl obj_at_def asid_pool_integrity_def) + apply (simp add: delete_asid_def) + apply (wpsimp wp: set_asid_pool_integrity_autarch) + apply (rule_tac Q'="\_ s. integrity aag X st s \ pas_refined aag s \ invs s \ + is_subject aag pd \ pool_for_asid asid s = Some x2 \ + vspace_for_asid asid s = Some pd" in hoare_strengthen_post[rotated]) + apply (fastforce simp: vspace_for_asid_def obind_def entry_for_asid_def entry_for_pool_def + split: if_splits) + apply (wpsimp wp: set_asid_pool_integrity_autarch invalidate_tlb_by_asid_invs)+ + apply (clarsimp simp: vspace_for_asid_def entry_for_asid_def entry_for_pool_def in_obind_eq) done -lemma arch_finalise_cap_respects[wp]: +lemma vcpu_finalise_integrity_autarch: + "\integrity aag X st and K (is_subject aag vr)\ + vcpu_finalise vr + \\_. integrity aag X st\" + unfolding vcpu_finalise_def + apply (wpsimp wp: dissociate_vcpu_tcb_respects get_vcpu_wp) + apply (erule (2) associated_tcb_is_subject) + done + +lemma arch_finalise_cap_respects[Finalise_AC_assms, wp]: "\integrity aag X st and invs and pas_refined aag and valid_cap (ArchObjectCap cap) and K (pas_cap_cur_auth aag (ArchObjectCap cap))\ arch_finalise_cap cap final \\_. integrity aag X st\" apply (simp add: arch_finalise_cap_def) - apply (wpsimp wp: unmap_page_respects unmap_page_table_respects delete_asid_respects) + apply (wpsimp wp: unmap_page_respects unmap_page_table_respects + delete_asid_respects delete_asid_pool_respects vcpu_finalise_integrity_autarch) apply (auto simp: cap_auth_conferred_def arch_cap_auth_conferred_def wellformed_mapdata_def aag_cap_auth_def pas_refined_all_auth_is_owns valid_cap_simps cap_links_asid_slot_def label_owns_asid_slot_def intro: pas_refined_Control_into_is_subject_asid) done -crunch arch_post_cap_deletion - for pspace_aligned[Finalise_AC_assms, wp]: "\s :: det_ext state. pspace_aligned s" - and valid_vspace_objs[Finalise_AC_assms, wp]: "\s :: det_ext state. valid_vspace_objs s" - and valid_arch_state[Finalise_AC_assms, wp]: "\s :: det_ext state. valid_arch_state s" +declare prepare_thread_delete_st_tcb_at_halted[Finalise_AC_assms] +declare finalise_cap_valid_list[Finalise_AC_assms] +declare finalise_cap_replaceable[Finalise_AC_assms] end @@ -241,11 +356,11 @@ global_interpretation Finalise_AC_1?: Finalise_AC_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Finalise_AC_assms | wp finalise_cap_replaceable)) + by (unfold_locales; fact Finalise_AC_assms) qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemma cap_revoke_respects'[Finalise_AC_assms]: "s \ \(\s. trp \ integrity aag X st s) and K (is_subject aag (fst slot)) diff --git a/proof/access-control/AARCH64/ArchInterrupt_AC.thy b/proof/access-control/AARCH64/ArchInterrupt_AC.thy index 09ff7a783c..6adcccd797 100644 --- a/proof/access-control/AARCH64/ArchInterrupt_AC.thy +++ b/proof/access-control/AARCH64/ArchInterrupt_AC.thy @@ -9,20 +9,19 @@ imports Interrupt_AC begin -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems Interrupt_AC_assms definition arch_authorised_irq_ctl_inv :: "'a PAS \ Invocations_A.arch_irq_control_invocation \ bool" where "arch_authorised_irq_ctl_inv aag cinv \ - case cinv of (RISCVIRQControlInvocation irq x1 x2 trigger) \ + case cinv of (ARMIRQControlInvocation irq x1 x2 trigger) \ is_subject aag (fst x1) \ is_subject aag (fst x2) \ (pasSubject aag, Control, pasIRQAbs aag irq) \ pasPolicy aag" lemma arch_invoke_irq_control_pas_refined[Interrupt_AC_assms]: - "\pas_refined aag and pspace_aligned and valid_vspace_objs and valid_arch_state - and valid_mdb and arch_irq_control_inv_valid irq_ctl_inv + "\pas_refined aag and valid_mdb and arch_irq_control_inv_valid irq_ctl_inv and K (arch_authorised_irq_ctl_inv aag irq_ctl_inv)\ arch_invoke_irq_control irq_ctl_inv \\_. pas_refined aag\" @@ -75,11 +74,11 @@ global_interpretation Interrupt_AC_1?: Interrupt_AC_1 "arch_authorised_irq_ctl_i proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Interrupt_AC_assms)?) + by (unfold_locales; (fact Interrupt_AC_assms | wp)?) qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemma arch_decode_irq_control_invocation_authorised[Interrupt_AC_assms]: "\pas_refined aag and @@ -105,7 +104,7 @@ global_interpretation Interrupt_AC_2?: Interrupt_AC_2 "arch_authorised_irq_ctl_i proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Interrupt_AC_assms)?) + by (unfold_locales; fact Interrupt_AC_assms) qed diff --git a/proof/access-control/AARCH64/ArchIpc_AC.thy b/proof/access-control/AARCH64/ArchIpc_AC.thy index 7be518e246..575161da53 100644 --- a/proof/access-control/AARCH64/ArchIpc_AC.thy +++ b/proof/access-control/AARCH64/ArchIpc_AC.thy @@ -8,7 +8,7 @@ theory ArchIpc_AC imports Ipc_AC begin -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems Ipc_AC_assms @@ -77,7 +77,7 @@ proof goal_cases qed -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 lemma store_word_offs_respects_in_ipc[Ipc_AC_assms]: "\integrity_tcb_in_ipc aag X receiver epptr TRContext st and @@ -184,11 +184,6 @@ lemma auth_ipc_buffers_machine_state_update[Ipc_AC_assms, simp]: "auth_ipc_buffers (machine_state_update f s) = auth_ipc_buffers s" by (clarsimp simp: auth_ipc_buffers_def get_tcb_def) -crunch handle_arch_fault_reply - for pspace_aligned[Ipc_AC_assms, wp]: "\s :: det_ext state. pspace_aligned s" - and valid_vspace_objs[Ipc_AC_assms, wp]: "\s :: det_ext state. valid_vspace_objs s" - and valid_arch_state[Ipc_AC_assms, wp]: "\s :: det_ext state. valid_arch_state s" - lemma cap_insert_ext_integrity_asids_in_ipc[Ipc_AC_assms, wp]: "cap_insert_ext src_parent src_slot dest_slot src_p dest_p \\s. integrity_asids aag subjects x asid st @@ -232,7 +227,7 @@ global_interpretation Ipc_AC_2?: Ipc_AC_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Ipc_AC_assms)?) + by (unfold_locales; fact Ipc_AC_assms) qed end diff --git a/proof/access-control/AARCH64/ArchRetype_AC.thy b/proof/access-control/AARCH64/ArchRetype_AC.thy index 93b34a9022..c0845be336 100644 --- a/proof/access-control/AARCH64/ArchRetype_AC.thy +++ b/proof/access-control/AARCH64/ArchRetype_AC.thy @@ -82,7 +82,7 @@ lemma pas_refined: end -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems Retype_AC_assms @@ -97,7 +97,7 @@ lemma pts_of_detype[simp]: by (simp add: in_omonad detype_def) lemma ptes_of_detype_Some[simp]: - "(ptes_of (detype S s) p = Some pte) = (table_base p \ S \ ptes_of s p = Some pte)" + "(ptes_of (detype S s) pt_t p = Some pte) = (table_base pt_t p \ S \ ptes_of s pt_t p = Some pte)" by (simp add: in_omonad ptes_of_def detype_def) lemma asid_pools_of_detype: @@ -115,14 +115,14 @@ lemma pool_for_asid_detype_Some[simp]: lemma vspace_for_pool_detype_Some[simp]: "(vspace_for_pool ap asid (\p. if p \ S then None else pools p) = Some p) = (ap \ S \ vspace_for_pool ap asid pools = Some p)" - by (simp add: vspace_for_pool_def obind_def split: option.splits) + by (simp add: entry_for_pool_def vspace_for_pool_def obind_def split: option.splits) lemma vspace_for_asid_detype_Some[simp]: "(vspace_for_asid asid (detype S s) = Some p) = ((\ap. pool_for_asid asid s = Some ap \ ap \ S) \ vspace_for_asid asid s = Some p)" - apply (simp add: vspace_for_asid_def obind_def asid_pools_of_detype split: option.splits) - apply (auto simp: pool_for_asid_def) - done + by (auto simp: entry_for_asid_def entry_for_pool_def pool_for_asid_def + vspace_for_asid_def obind_def asid_pools_of_detype + split: option.splits) lemma pt_walk_detype: "pt_walk level bot_level pt_ptr vref (ptes_of (detype S s)) = Some (bot_level, p) \ @@ -154,7 +154,7 @@ lemma state_vrefs_detype[Retype_AC_assms, dest]: apply (clarsimp simp: state_vrefs_def) apply (frule vs_lookup_level) apply (drule vs_lookup_table) - apply fastforce + apply (fastforce simp: vspace_objs_of_Some) done lemma sata_detype[Retype_AC_assms]: @@ -190,7 +190,9 @@ lemma aobj_refs'_default'[Retype_AC_assms]: by (cases tp; simp add: arch_default_cap_def ptr_range_memI obj_bits_api_def default_arch_object_def) crunch init_arch_objects - for inv[wp]: P + for pas_refined[wp]: "pas_refined aag" + and integrity_autarch[wp]: "integrity aag X st" + (wp: crunch_wps dmo_no_mem_respects) lemma region_in_kernel_window_preserved: assumes "\P. f \\s. P (arch_state s)\" @@ -375,9 +377,9 @@ global_interpretation Retype_AC_1?: Retype_AC_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Retype_AC_assms | wpsimp wp: init_arch_objects_inv)?) + by (unfold_locales; (fact Retype_AC_assms | wpsimp)) qed -requalify_facts RISCV64.storeWord_respects +requalify_facts AARCH64.storeWord_respects end diff --git a/proof/access-control/AARCH64/ArchSyscall_AC.thy b/proof/access-control/AARCH64/ArchSyscall_AC.thy index e9c7f0ee17..92a64193db 100644 --- a/proof/access-control/AARCH64/ArchSyscall_AC.thy +++ b/proof/access-control/AARCH64/ArchSyscall_AC.thy @@ -8,7 +8,7 @@ theory ArchSyscall_AC imports Syscall_AC begin -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems Syscall_AC_assms @@ -18,6 +18,7 @@ crunch set_original crunch prepare_thread_delete for idle_thread[Syscall_AC_assms, wp]: "\s. P (idle_thread s)" + (wp: crunch_wps simp: crunch_simps) lemma cap_move_idle_thread[Syscall_AC_assms, wp]: "cap_move new_cap src_slot dest_slot \\s. P (idle_thread s)\" @@ -34,10 +35,13 @@ declare arch_finalise_cap_idle_thread[Syscall_AC_assms] lemma invs_irq_state_update[Syscall_AC_assms, simp]: "invs (s\machine_state := irq_state_update f sa\) = invs (s\machine_state := sa\)" apply (rule iffI) - apply (subst invs_irq_state_independent[symmetric]) - apply (subst RISCV64.fold_congs(2); fastforce) - apply (subst (asm) invs_irq_state_independent[symmetric]) - apply (subst RISCV64.fold_congs(2); fastforce) + apply (subst invs_irq_state_independent[where f=f, symmetric]) + apply (erule back_subst[where P=invs]) + apply clarsimp + apply (subst (asm) invs_irq_state_independent[where f=f, symmetric]) + apply clarsimp + apply (erule back_subst[where P=invs]) + apply clarsimp done crunch prepare_thread_delete, arch_finalise_cap @@ -54,13 +58,9 @@ lemma cancel_badged_sends_cur_thread[Syscall_AC_assms, wp]: unfolding cancel_badged_sends_def by (wpsimp wp: dxo_wp_weak filterM_preserved crunch_wps) -crunch arch_mask_irq_signal, handle_reserved_irq - for pas_refined[Syscall_AC_assms, wp]: "pas_refined aag" - -crunch handle_hypervisor_fault +crunch arch_mask_irq_signal for pas_refined[Syscall_AC_assms, wp]: "pas_refined aag" - and cur_thread[Syscall_AC_assms, wp]: "\s. P (cur_thread s)" - and integrity[Syscall_AC_assms, wp]: "integrity aag X st" + (wp: crunch_wps simp: crunch_simps) crunch handle_vm_fault for pas_refined[Syscall_AC_assms, wp]: "pas_refined aag" @@ -71,14 +71,14 @@ lemma handle_vm_fault_integrity[Syscall_AC_assms]: "\integrity aag X st and K (is_subject aag thread)\ handle_vm_fault thread vmfault_type \\rv. integrity aag X st\" - unfolding handle_vm_fault_def - by (cases vmfault_type; wpsimp wp: as_user_integrity_autarch dmo_wp) + unfolding handle_vm_fault_def addressTranslateS1_def + by (cases vmfault_type; wpsimp wp: dmo_no_mem_respects as_user_integrity_autarch ) crunch ackInterrupt, resetTimer for underlying_memory_inv[Syscall_AC_assms, wp]: "\s. P (underlying_memory s)" (simp: maskInterrupt_def) -crunch arch_mask_irq_signal, handle_reserved_irq +crunch arch_mask_irq_signal for integrity[Syscall_AC_assms, wp]: "integrity aag X st" (wp: dmo_no_mem_respects) @@ -120,25 +120,10 @@ lemma arch_activate_idle_thread_pas_refined[Syscall_AC_assms, wp]: "arch_activate_idle_thread t \pas_refined aag\" unfolding arch_activate_idle_thread_def by wpsimp -lemma arch_switch_to_thread_respects[Syscall_AC_assms, wp]: - "arch_switch_to_thread t \integrity aag X st\" - unfolding arch_switch_to_thread_def by wpsimp - -lemma arch_switch_to_thread_pas_refined[Syscall_AC_assms, wp]: - "arch_switch_to_thread t \pas_refined aag\" - unfolding arch_switch_to_thread_def by wpsimp - -lemma arch_switch_to_idle_thread_respects[Syscall_AC_assms, wp]: - "arch_switch_to_idle_thread \integrity aag X st\" - unfolding arch_switch_to_idle_thread_def by wpsimp - -lemma arch_switch_to_idle_thread_pas_refined[Syscall_AC_assms, wp]: - "arch_switch_to_idle_thread \pas_refined aag\" - unfolding arch_switch_to_idle_thread_def by wpsimp - -lemma arch_mask_irq_signal_arch_state[Syscall_AC_assms, wp]: - "arch_mask_irq_signal irq \\s :: det_ext state. P (arch_state s)\" - by wpsimp +crunch arch_switch_to_thread, arch_switch_to_idle_thread + for integrity[Syscall_AC_assms, wp]: "integrity aag X st" + and pas_refined[Syscall_AC_assms, wp]: "pas_refined aag" + (wp: crunch_wps vcpu_switch_respects simp: crunch_simps) lemma handle_reserved_irq_arch_state[Syscall_AC_assms, wp]: "handle_reserved_irq irq \\s :: det_ext state. P (arch_state s)\" @@ -151,15 +136,208 @@ crunch arch_post_cap_deletion crunch arch_post_modify_registers, arch_invoke_irq_control, arch_invoke_irq_handler, arch_perform_invocation, arch_mask_irq_signal, - handle_reserved_irq, handle_vm_fault, handle_hypervisor_fault, handle_arch_fault_reply + handle_vm_fault, handle_arch_fault_reply for cur_thread[Syscall_AC_assms, wp]: "\s. P (cur_thread s)" and idle_thread[Syscall_AC_assms, wp]: "\s. P (idle_thread s)" and cur_domain[Syscall_AC_assms, wp]: "\s. P (cur_domain s)" (wp: crunch_wps simp: crunch_simps) +crunch handle_hypervisor_fault + for idle_thread[Syscall_AC_assms, wp]: "\s :: det_ext state. P (idle_thread s)" + (wp: crunch_wps simp: crunch_simps) + +crunch handle_reserved_irq + for idle_thread[Syscall_AC_assms, wp]: "\s :: det_ext state. P (idle_thread s)" + (wp: crunch_wps simp: crunch_simps) + +crunch set_extra_badge + for cur_domain[Syscall_AC_assms, wp]: "\s :: det_ext state. P (cur_domain s)" + (wp: crunch_wps simp: crunch_simps) + +lemma transfer_caps_loop_cur_domain[wp]: + "transfer_caps_loop ep rcv_buffer n caps slots mi \\s :: det_ext state. P (cur_domain s)\" + supply if_split[split del] + apply (induct caps arbitrary: slots n mi) + apply (wpsimp | assumption)+ + done + +crunch handle_hypervisor_fault + for cur_domain[Syscall_AC_assms, wp]: "\s :: det_ext state. P (cur_domain s)" + (wp: crunch_wps simp: crunch_simps ignore_del: possible_switch_to) + +crunch handle_reserved_irq + for cur_domain[Syscall_AC_assms, wp]: "\s :: det_ext state. P (cur_domain s)" + (wp: crunch_wps simp: crunch_simps) + +crunch vgic_update_lr, vgic_update + for integrity_autarch[Syscall_AC_assms, wp]: "integrity aag X st" + +lemma vgic_maintenance_integrity_autarch: + "\\s. integrity aag X st s \ pas_refined aag s \ is_subject aag (cur_thread s) \ invs s\ + vgic_maintenance + \\rv. integrity aag X st\" + (is "\?P\ _ \_\") + unfolding vgic_maintenance_def vgic_update_lr_def get_gic_vcpu_ctrl_misr_def + get_gic_vcpu_ctrl_eisr0_def get_gic_vcpu_ctrl_eisr1_def + apply (wpsimp wp: handle_fault_integrity_autarch gts_wp dmo_no_mem_respects split_del: if_split + | wpsimp wp: hoare_vcg_all_lift hoare_drop_imps)+ + apply (frule invs_cur) + apply (frule invs_valid_cur_vcpu) + apply (clarsimp simp: valid_fault_def cur_tcb_def tcb_at_def) + apply (fastforce intro: associated_vcpu_is_subject + simp: valid_cur_vcpu_def pred_tcb_at_def obj_at_def active_cur_vcpu_of_def get_tcb_def) + done + +lemma vppi_event_integrity_autarch: + "\\s. integrity aag X st s \ pas_refined aag s \ (is_subject aag (cur_thread s)) \ invs s\ + vppi_event irq + \\_ s. integrity aag X st s\" + unfolding vppi_event_def + apply (wpsimp wp: handle_fault_integrity_autarch maskInterrupt_invs dmo_no_mem_respects + vcpu_update_integrity_autarch vcpu_update_pas_refined vcpu_update_trivial_invs + simp: if_fun_split + | wpsimp wp: hoare_vcg_all_lift hoare_drop_imps)+ + apply (frule invs_cur) + apply (frule invs_valid_cur_vcpu) + apply (clarsimp simp: valid_fault_def cur_tcb_def tcb_at_def) + apply (fastforce intro: associated_vcpu_is_subject + simp: valid_cur_vcpu_def pred_tcb_at_def obj_at_def active_cur_vcpu_of_def get_tcb_def) + done + +lemma handle_reserved_irq_integrity_autarch[Syscall_AC_assms]: + "\integrity aag X st and pas_refined aag and invs and (\s. is_subject aag (cur_thread s))\ + handle_reserved_irq irq + \\_. integrity aag X st\" + unfolding handle_reserved_irq_def + by (wpsimp wp: vppi_event_integrity_autarch vgic_maintenance_integrity_autarch) + +lemma vppi_event_pas_refined: + "\\s. pas_refined aag s \ (ct_active s \ is_subject aag (cur_thread s)) \ invs s\ + vppi_event irq + \\_ s. pas_refined aag s\" + unfolding vppi_event_def + apply (wpsimp wp: handle_fault_pas_refined gts_wp vcpu_update_pas_refined) + apply (rule hoare_lift_Pf2[where f="cur_thread", rotated]) + apply wpsimp + apply (wpsimp wp: vcpu_update_pas_refined vcpu_update_trivial_invs + hoare_vcg_all_lift hoare_vcg_imp_lift) + apply (rule_tac Q'="\rv s. pas_refined aag s \ (ct_active s \ is_subject aag (cur_thread s)) \ invs s" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: valid_fault_def ct_in_state_def pred_tcb_at_def obj_at_def runnable_eq) + apply (wpsimp wp: maskInterrupt_invs hoare_vcg_imp_lift)+ + done + +lemma vgic_maintenance_pas_refined: + "\\s. pas_refined aag s \ (ct_active s \ is_subject aag (cur_thread s)) \ invs s\ + vgic_maintenance + \\_ s. pas_refined aag s\" + unfolding vgic_maintenance_def vgic_update_lr_def vgic_update_def + get_gic_vcpu_ctrl_misr_def get_gic_vcpu_ctrl_eisr1_def get_gic_vcpu_ctrl_eisr0_def + apply (wpsimp wp: handle_fault_pas_refined gts_wp vcpu_update_pas_refined) + apply (rule hoare_lift_Pf2[where f="cur_thread", rotated]) + apply wpsimp + apply (wpsimp wp: vcpu_update_pas_refined vcpu_update_trivial_invs + hoare_vcg_all_lift hoare_vcg_imp_lift) + apply (rule_tac Q'="\rv s. pas_refined aag s \ (ct_active s \ is_subject aag (cur_thread s)) \ invs s" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: valid_fault_def ct_in_state_def pred_tcb_at_def obj_at_def runnable_eq) + apply ((wpsimp wp: hoare_vcg_imp_lift)+)[4] + apply (rule_tac Q'="\rv s. pas_refined aag s \ (ct_active s \ is_subject aag (cur_thread s)) \ invs s" + in hoare_strengthen_post[rotated]) + apply (auto simp: valid_fault_def ct_in_state_def pred_tcb_at_def obj_at_def runnable_eq)[1] + apply wpsimp+ + done + +lemma handle_reserved_irq_pas_refined[Syscall_AC_assms]: + "\\s. pas_refined aag s \ invs s \ (ct_active s \ is_subject aag (cur_thread s))\ + handle_reserved_irq irq + \\_ s. pas_refined aag s\" + unfolding handle_reserved_irq_def + by (wpsimp wp: vppi_event_pas_refined vgic_maintenance_pas_refined) + +lemma vgic_maintenance_idle: + "\integrity aag X st and invs and ct_idle\ + vgic_maintenance + \\_. integrity aag X st\" + unfolding vgic_maintenance_def + apply (rule bind_wp) + apply (rule_tac P'="\s. integrity aag X st s \ (\v. rv \ Some (v,True))" in hoare_weaken_pre) + apply (case_tac rv; clarsimp) + apply (case_tac b; clarsimp) + apply assumption + apply (wpsimp) + apply (prop_tac "only_idle s") + apply (clarsimp simp: invs_def valid_state_def) + apply (prop_tac "arch_tcb_at (\itcb. itcb_vcpu itcb = None) (idle_thread s) s") + apply (frule invs_valid_idle) + apply (clarsimp simp: valid_idle_def pred_tcb_at_def valid_arch_idle_def obj_at_def) + apply (frule invs_valid_cur_vcpu) + apply (clarsimp simp: valid_cur_vcpu_def only_idle_def pred_tcb_at_def + ct_in_state_def obj_at_def active_cur_vcpu_of_def) + done + +lemma vppi_event_idle: + "\integrity aag X st and invs and ct_idle\ + vppi_event irq + \\_. integrity aag X st\" + unfolding vppi_event_def + apply (rule bind_wp) + apply (rule_tac P'="\s. integrity aag X st s \ (\v. rv \ Some (v,True))" in hoare_weaken_pre) + apply (case_tac rv; clarsimp) + apply (case_tac b; clarsimp) + apply assumption + apply (wpsimp) + apply (prop_tac "only_idle s") + apply (clarsimp simp: invs_def valid_state_def) + apply (prop_tac "arch_tcb_at (\itcb. itcb_vcpu itcb = None) (idle_thread s) s") + apply (frule invs_valid_idle) + apply (clarsimp simp: valid_idle_def pred_tcb_at_def valid_arch_idle_def obj_at_def) + apply (frule invs_valid_cur_vcpu) + apply (clarsimp simp: valid_cur_vcpu_def only_idle_def pred_tcb_at_def + ct_in_state_def obj_at_def active_cur_vcpu_of_def) + done + +lemma handle_reserved_irq_idle[Syscall_AC_assms]: + "\integrity aag X st and invs and ct_idle\ + handle_reserved_irq irq + \\_. integrity aag X st\" + unfolding handle_reserved_irq_def + by (wpsimp wp: vppi_event_idle vgic_maintenance_idle) + +lemma handle_hypervisor_fault_pas_refined[Syscall_AC_assms, wp]: + "\\s. pas_refined aag s \ is_subject aag (cur_thread s) \ is_subject aag thread \ invs s\ + handle_hypervisor_fault thread fault + \\_ s. pas_refined aag s\" + apply (case_tac fault) + apply clarify + apply (subst handle_hypervisor_fault.simps) + apply (wpsimp wp: handle_fault_pas_refined simp: getESR_def isFpuEnable_def valid_fault_def) + done + +lemma handle_hypervisor_fault_integrity_autarch[Syscall_AC_assms, wp]: + "\\s. integrity aag X st s \ pas_refined aag s \ invs s \ is_subject aag thread + \ (ct_active s \ is_subject aag (cur_thread s))\ + handle_hypervisor_fault thread fault + \\_ s. integrity aag X st s\" + apply (case_tac fault) + apply clarify + apply (subst handle_hypervisor_fault.simps) + apply (wpsimp wp: handle_fault_integrity_autarch simp: getESR_def isFpuEnable_def valid_fault_def) + done + \ \These aren't proved in the previous crunch, and hence need to be declared\ -declare handle_arch_fault_reply_cur_thread[Syscall_AC_assms] declare handle_arch_fault_reply_it[Syscall_AC_assms] +declare handle_arch_fault_reply_cur_thread[Syscall_AC_assms] +declare arch_invoke_irq_control_cur_thread[Syscall_AC_assms] +declare arch_invoke_irq_handler_cur_thread[Syscall_AC_assms] +declare arch_mask_irq_signal_cur_thread[Syscall_AC_assms] +declare handle_reserved_irq_cur_thread[Syscall_AC_assms] +declare handle_hypervisor_fault_cur_thread[Syscall_AC_assms] +declare handle_vm_fault_cur_thread[Syscall_AC_assms] +declare ackInterrupt_underlying_memory_inv[Syscall_AC_assms] +declare resetTimer_underlying_memory_inv[Syscall_AC_assms] +declare arch_mask_irq_signal_arch_state[Syscall_AC_assms] +declare init_arch_objects_arch_state[Syscall_AC_assms] end @@ -168,7 +346,7 @@ global_interpretation Syscall_AC_1?: Syscall_AC_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Syscall_AC_assms | wp init_arch_objects_inv)) + by (unfold_locales; fact Syscall_AC_assms) qed end diff --git a/proof/access-control/AARCH64/ArchTcb_AC.thy b/proof/access-control/AARCH64/ArchTcb_AC.thy index 800f889a7e..39c1a4a2e8 100644 --- a/proof/access-control/AARCH64/ArchTcb_AC.thy +++ b/proof/access-control/AARCH64/ArchTcb_AC.thy @@ -8,7 +8,7 @@ theory ArchTcb_AC imports Tcb_AC begin -context Arch begin global_naming RISCV64 +context Arch begin global_naming AARCH64 named_theorems Tcb_AC_assms @@ -92,9 +92,9 @@ lemma invoke_tcb_tc_respects_aag[Tcb_AC_assms]: emptyable_def | rule conjI | erule pas_refined_refl)+ apply (thin_tac "case_option _ _ _")+ - apply (fastforce split: cap.split_asm option.split_asm) + apply (fastforce split: cap.split_asm option.split_asm pt_type.split_asm) apply (thin_tac "case_option _ _ _")+ - apply (fastforce split: cap.split_asm option.split_asm) + apply (fastforce split: cap.split_asm option.split_asm pt_type.split_asm) done end diff --git a/proof/invariant-abstract/AARCH64/ArchSchedule_AI.thy b/proof/invariant-abstract/AARCH64/ArchSchedule_AI.thy index 01d12ad001..ef1627b0d8 100644 --- a/proof/invariant-abstract/AARCH64/ArchSchedule_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchSchedule_AI.thy @@ -31,7 +31,12 @@ lemma dmo_mapM_storeWord_0_invs[wp,Schedule_AI_assms]: lemma arch_stt_invs [wp,Schedule_AI_assms]: "arch_switch_to_thread t' \invs\" apply (wpsimp simp: arch_switch_to_thread_def) - by (rule sym_refs_VCPU_hyp_live; fastforce) + apply (clarsimp simp: obj_at_vcpu_hyp_live_of_s[symmetric] obj_at_conj_distrib) + apply (rule conjI) + apply (fastforce dest!: valid_tcb_objs[OF invs_valid_objs] + simp: valid_tcb_def valid_arch_tcb_def obj_at_def is_vcpu_def) + apply (rule sym_refs_VCPU_hyp_live; fastforce) + done lemma arch_stt_tcb [wp,Schedule_AI_assms]: "arch_switch_to_thread t' \tcb_at t'\" diff --git a/proof/invariant-abstract/AARCH64/ArchVCPU_AI.thy b/proof/invariant-abstract/AARCH64/ArchVCPU_AI.thy index 35dc4a38bc..e8d2ec6c0c 100644 --- a/proof/invariant-abstract/AARCH64/ArchVCPU_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchVCPU_AI.thy @@ -120,8 +120,10 @@ lemma switch_vcpu_valid_cur_vcpu_cur_thread_update[wp]: vcpu_switch v \\_ s. valid_cur_vcpu (s\cur_thread := t\)\" unfolding vcpu_switch_def - apply (wpsimp simp: valid_cur_vcpu_def active_cur_vcpu_of_def) - by fastforce + apply (wpsimp simp: valid_cur_vcpu_def active_cur_vcpu_of_def + | rule hoare_lift_Pf[where f=arch_state])+ + apply fastforce + done lemma switch_vcpu_valid_cur_vcpu[wp]: "\\s. arch_tcb_at (\itcb. itcb_vcpu itcb = v) (cur_thread s) s\ diff --git a/proof/invariant-abstract/AARCH64/ArchVSpace_AI.thy b/proof/invariant-abstract/AARCH64/ArchVSpace_AI.thy index 48bb3f688a..77163ae0fa 100644 --- a/proof/invariant-abstract/AARCH64/ArchVSpace_AI.thy +++ b/proof/invariant-abstract/AARCH64/ArchVSpace_AI.thy @@ -3063,13 +3063,14 @@ crunch vcpu_disable, vcpu_restore, vcpu_save (wp: crunch_wps) lemma vcpu_switch_invs[wp]: - "\invs and (\s. v \ None \ obj_at hyp_live (the v) s)\ vcpu_switch v \ \_ . invs \" + "\invs and (\s. v \ None \ vcpu_hyp_live_of s (the v))\ vcpu_switch v \ \_ . invs \" unfolding vcpu_switch_def apply (cases v; clarsimp) apply (wpsimp simp: cur_vcpu_at_def | strengthen invs_current_vcpu_update')+ apply (clarsimp simp: invs_def valid_state_def valid_arch_state_def cur_vcpu_def in_omonad obj_at_def hyp_live_def arch_live_def) apply (wpsimp simp: cur_vcpu_at_def | strengthen invs_current_vcpu_update')+ + apply (clarsimp simp: in_omonad obj_at_def hyp_live_def arch_live_def) done crunch diff --git a/spec/abstract/AARCH64/VCPUAcc_A.thy b/spec/abstract/AARCH64/VCPUAcc_A.thy index 26b69800fa..7304ee1c94 100644 --- a/spec/abstract/AARCH64/VCPUAcc_A.thy +++ b/spec/abstract/AARCH64/VCPUAcc_A.thy @@ -244,21 +244,21 @@ definition vcpu_switch :: "obj_ref option \ (unit,'z::state_ext) s_m cur_v \ gets (arm_current_vcpu \ arch_state); (case cur_v of None \ do \ \switch to the new vcpu with no current one\ - vcpu_restore new; - modify (\s. s\ arch_state := (arch_state s)\ arm_current_vcpu := Some (new, True) \\) + modify (\s. s\ arch_state := (arch_state s)\ arm_current_vcpu := Some (new, True) \\); + vcpu_restore new od | Some (vr, active) \ \ \switch from an existing vcpu\ (if vr \ new then do \ \different vcpu\ vcpu_save cur_v; - vcpu_restore new; - modify (\s. s\ arch_state := (arch_state s)\ arm_current_vcpu := Some (new, True) \\) + modify (\s. s\ arch_state := (arch_state s)\ arm_current_vcpu := Some (new, True) \\); + vcpu_restore new od else \ \same vcpu\ when (\ active) $ do do_machine_op isb; - vcpu_enable new; - modify (\s. s\ arch_state := (arch_state s)\ arm_current_vcpu := Some (new, True) \\) + modify (\s. s\ arch_state := (arch_state s)\ arm_current_vcpu := Some (new, True) \\); + vcpu_enable new od)) od" From f42bba84a9e169d459b7d113918702dbaa2258be Mon Sep 17 00:00:00 2001 From: Ryan Barry Date: Fri, 13 Dec 2024 11:56:13 +1100 Subject: [PATCH 4/4] run_tests: enable Access for AARCH64 Signed-off-by: Ryan Barry --- proof/ROOT | 4 ++-- run_tests | 10 ++++++++-- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/proof/ROOT b/proof/ROOT index cb8a159bab..3f6712c7d5 100644 --- a/proof/ROOT +++ b/proof/ROOT @@ -147,9 +147,9 @@ session DPolicy in "dpolicy" = DRefine + session Access in "access-control" = AInvs + directories "$L4V_ARCH" - theories + theories [quick_and_dirty] (* for development only *) "ArchADT_AC" - "ExampleSystem" + (* "ExampleSystem" *) session InfoFlow in "infoflow" = Access + directories diff --git a/run_tests b/run_tests index a99ffbd0af..ce6460d6db 100755 --- a/run_tests +++ b/run_tests @@ -40,7 +40,10 @@ EXCLUDE["ARM_HYP"]=[ "RefineOrphanage", "SimplExportAndRefine"] -EXCLUDE["ARM"]=[] +EXCLUDE["ARM"]=[ + "DPolicy", + "InfoFlow" +] EXCLUDE["X64"]=[ "Access", @@ -57,6 +60,7 @@ EXCLUDE["RISCV64"]=[ "AutoCorresSEL4", "DSpec", "DBaseRefine", + "InfoFlow", "CamkesGlueProofs", "AsmRefine" ] @@ -64,7 +68,9 @@ EXCLUDE["RISCV64"]=[ EXCLUDE["AARCH64"]=[ # To be eliminated/refined as development progresses "ASepSpec", - "Access", + "DPolicy", + "InfoFlow", + "Refine", # Tools and unrelated content, removed for development "AutoCorres",