(* * Copyright 2023, Proofcraft Pty Ltd * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) * * SPDX-License-Identifier: GPL-2.0-only *) (* AARCH64 VSpace refinement *) theory VSpace_R imports TcbAcc_R begin lemma cteCaps_of_ctes_of_lift: "(\P. \\s. P (ctes_of s)\ f \\_ s. P (ctes_of s)\) \ \\s. P (cteCaps_of s) \ f \\_ s. P (cteCaps_of s)\" unfolding cteCaps_of_def . context begin interpretation Arch . (*FIXME: arch_split*) definition "vspace_at_asid' vs asid \ \s. \ap pool entry. armKSASIDTable (ksArchState s) (ucast (asid_high_bits_of (ucast asid))) = Some ap \ ko_at' (ASIDPool pool) ap s \ pool (ucast (asid_low_bits_of (ucast asid))) = Some entry \ apVSpace entry = vs \ (\pt_t. page_table_at' pt_t vs s)" (* FIXME AARCH64: checkPTAt currently used in both contexts (Normal and VSRoot) -- if we later (in CRefine) need more precision here (= VSRootPT_T), we'll need to split checkPTAt into separate functions *) lemma findVSpaceForASID_vs_at_wp: "\\s. \pm. asid \ 0 \ asid_wf asid \ vspace_at_asid' pm asid s \ P pm s\ findVSpaceForASID asid \P\,-" unfolding findVSpaceForASID_def apply (wpsimp wp: getASID_wp simp: checkPTAt_def getASIDPoolEntry_def getPoolPtr_def) apply (fastforce simp: asid_low_bits_of_def ucast_ucast_a is_down ucast_ucast_mask asid_low_bits_def asidRange_def mask_2pm1[symmetric] le_mask_asidBits_asid_wf vspace_at_asid'_def page_table_at'_def) done crunches findVSpaceForASID, haskell_fail for inv[wp]: "P" (simp: const_def crunch_simps wp: loadObject_default_inv crunch_wps ignore_del: getObject) lemma asidBits_asid_bits[simp]: "asidBits = asid_bits" by (simp add: bit_simps' asid_bits_def asidBits_def) (* FIXME AARCH64: Added to crunch_param_rules in Crunch_Instances_NonDet as trans[OF liftE_bindE return_bind]; move to monad equations instead and give it the name below *) lemma liftE_return_bindE: "liftE (return x) >>=E f = f x" by (rule Crunch.crunch_param_rules(8)) crunches getIRQState for inv[wp]: P lemma dmo_invs_no_cicd_lift': (* FIXME AARCH64: move up *) assumes "\P. f \\s. P (irq_masks s)\" assumes "\P p. f \\s. P (underlying_memory s p)\" shows "doMachineOp f \all_invs_but_ct_idle_or_in_cur_domain'\" apply (wp dmo_invs_no_cicd' assms) apply clarsimp apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" in use_valid, rule assms, rule refl) apply simp done lemma dmo_invs_lift': (* FIXME AARCH64: move up *) assumes "\P. f \\s. P (irq_masks s)\" assumes "\P p. f \\s. P (underlying_memory s p)\" shows "doMachineOp f \invs'\" apply (wp dmo_invs' assms) apply clarsimp apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" in use_valid, rule assms, rule refl) apply simp done lemma dmos_invs_no_cicd'[wp]: "doMachineOp isb \invs_no_cicd'\" "doMachineOp dsb \invs_no_cicd'\" "\w. doMachineOp (setSCTLR w) \invs_no_cicd'\" "\w. doMachineOp (set_gic_vcpu_ctrl_hcr w) \invs_no_cicd'\" "\w x. doMachineOp (set_gic_vcpu_ctrl_lr w x) \invs_no_cicd'\" "\w. doMachineOp (set_gic_vcpu_ctrl_apr w) \invs_no_cicd'\" "\w. doMachineOp (set_gic_vcpu_ctrl_vmcr w) \invs_no_cicd'\" "\w. doMachineOp (setHCR w) \invs_no_cicd'\" "doMachineOp get_gic_vcpu_ctrl_hcr \invs_no_cicd'\" "\w. doMachineOp (get_gic_vcpu_ctrl_lr w) \invs_no_cicd'\" "doMachineOp get_gic_vcpu_ctrl_apr \invs_no_cicd'\" "doMachineOp get_gic_vcpu_ctrl_vmcr \invs_no_cicd'\" "doMachineOp enableFpuEL01 \invs_no_cicd'\" "\r. doMachineOp (readVCPUHardwareReg r) \invs_no_cicd'\" "\r v. doMachineOp (writeVCPUHardwareReg r v) \invs_no_cicd'\" "doMachineOp check_export_arch_timer \invs_no_cicd'\" by (wp dmo_invs_no_cicd_lift')+ lemma dmos_invs'[wp]: "doMachineOp isb \invs'\" "doMachineOp dsb \invs'\" "\w. doMachineOp (setSCTLR w) \invs'\" "\w. doMachineOp (set_gic_vcpu_ctrl_hcr w) \invs'\" "\w x. doMachineOp (set_gic_vcpu_ctrl_lr w x) \invs'\" "\w. doMachineOp (set_gic_vcpu_ctrl_apr w) \invs'\" "\w. doMachineOp (set_gic_vcpu_ctrl_vmcr w) \invs'\" "\w. doMachineOp (setHCR w) \invs'\" "doMachineOp get_gic_vcpu_ctrl_hcr \invs'\" "\w. doMachineOp (get_gic_vcpu_ctrl_lr w) \invs'\" "doMachineOp get_gic_vcpu_ctrl_apr \invs'\" "doMachineOp get_gic_vcpu_ctrl_vmcr \invs'\" "doMachineOp enableFpuEL01 \invs'\" "\r. doMachineOp (readVCPUHardwareReg r) \invs'\" "\r v. doMachineOp (writeVCPUHardwareReg r v) \invs'\" "doMachineOp check_export_arch_timer \invs'\" by (wp dmo_invs_lift')+ lemma valid_irq_node_lift_asm: assumes x: "\P. \\s. P (irq_node' s)\ f \\rv s. P (irq_node' s)\" assumes y: "\p. \real_cte_at' p and Q\ f \\rv. real_cte_at' p\" shows "\\s. valid_irq_node' (irq_node' s) s \ Q s\ f \\rv s. valid_irq_node' (irq_node' s) s\" apply (simp add: valid_irq_node'_def) apply (rule hoare_pre) apply (rule hoare_use_eq_irq_node' [OF x]) apply (wp hoare_vcg_all_lift y) apply simp done lemma isIRQActive_corres: "corres (=) \ \ (is_irq_active irqVTimerEvent) (isIRQActive irqVTimerEvent)" apply (clarsimp simp: isIRQActive_def getIRQState_def is_irq_active_def get_irq_state_def) apply (clarsimp simp: is_irq_active_def isIRQActive_def get_irq_state_def irq_state_relation_def getIRQState_def getInterruptState_def state_relation_def interrupt_state_relation_def) apply (fastforce split: irq_state.splits irqstate.splits) done lemma getIRQState_wp: "\\s. P (intStateIRQTable (ksInterruptState s) irq) s \ getIRQState irq \\rv s. P rv s\" unfolding getIRQState_def getInterruptState_def by (wpsimp simp: comp_def) lemma maskInterrupt_irq_states': "\valid_irq_states' and (\s. \b \ intStateIRQTable (ksInterruptState s) irq \ irqstate.IRQInactive)\ doMachineOp (maskInterrupt b irq) \\rv. valid_irq_states'\" by (wpsimp wp: dmo_maskInterrupt) (auto simp add: valid_irq_states_def valid_irq_masks'_def) crunch ksIdleThread[wp]: storeWordUser "\s. P (ksIdleThread s)" crunch ksIdleThread[wp]: asUser "\s. P (ksIdleThread s)" (wp: crunch_wps simp: crunch_simps) crunch ksQ[wp]: asUser "\s. P (ksReadyQueues s)" (wp: crunch_wps simp: crunch_simps) lemma maskInterrupt_invs': "\invs' and (\s. \b \ intStateIRQTable (ksInterruptState s) irq \ irqstate.IRQInactive)\ doMachineOp (maskInterrupt b irq) \\rv. invs'\" by (wpsimp wp: maskInterrupt_irq_states' dmo_maskInterrupt simp: invs'_def valid_state'_def) (auto simp: valid_irq_states_def valid_irq_masks'_def valid_machine_state'_def ct_not_inQ_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) lemma dmo_machine_op_lift_invs'[wp]: "doMachineOp (machine_op_lift f) \invs'\" by (wpsimp wp: dmo_invs' simp: machine_op_lift_def in_monad machine_rest_lift_def select_f_def) lemma dmo'_gets_wp: "\\s. Q (f (ksMachineState s)) s\ doMachineOp (gets f) \Q\" unfolding doMachineOp_def by (wpsimp simp: in_monad) lemma maskInterrupt_invs_no_cicd': "\invs_no_cicd' and (\s. \b \ intStateIRQTable (ksInterruptState s) irq \ irqstate.IRQInactive)\ doMachineOp (maskInterrupt b irq) \\rv. invs_no_cicd'\" by (wpsimp wp: maskInterrupt_irq_states' dmo_maskInterrupt simp: invs_no_cicd'_def) (auto simp: valid_irq_states_def valid_irq_masks'_def valid_machine_state'_def ct_not_inQ_def) (* FIXME AARCH64: this is a big block of VCPU-related lemmas in an attempt to consolidate them; there may be an opportunity to factor most of these out into a separate theory *) (* setObject for VCPU invariant preservation *) lemma setObject_vcpu_cur_domain[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksCurDomain s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_ct[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksCurThread s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_it[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksIdleThread s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_sched[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksSchedulerAction s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_L1[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksReadyQueuesL1Bitmap s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_L2[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksReadyQueuesL2Bitmap s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_ksInt[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksInterruptState s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_ksArch[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksArchState s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_gs[wp]: "setObject ptr (vcpu::vcpu) \\s. P (gsMaxObjectSize s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_maschine_state[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksMachineState s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_ksDomSchedule[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksDomSchedule s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_ksDomScheduleIdx[wp]: "setObject ptr (vcpu::vcpu) \\s. P (ksDomScheduleIdx s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setObject_vcpu_gsUntypedZeroRanges[wp]: "setObject ptr (vcpu::vcpu) \\s. P (gsUntypedZeroRanges s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) crunches vcpuEnable, vcpuSave, vcpuDisable, vcpuRestore for pspace_aligned'[wp]: pspace_aligned' (simp: crunch_simps wp: crunch_wps getObject_inv_vcpu loadObject_default_inv) lemma vcpuSwitch_aligned'[wp]: "\pspace_aligned'\ vcpuSwitch param_a \\_. pspace_aligned'\" by (wpsimp simp: vcpuSwitch_def modifyArchState_def | assumption)+ crunches vcpuEnable, vcpuSave, vcpuDisable, vcpuRestore for pspace_distinct'[wp]: pspace_distinct' (simp: crunch_simps wp: crunch_wps getObject_inv_vcpu loadObject_default_inv) lemma vcpuSwitch_distinct'[wp]: "\pspace_distinct'\ vcpuSwitch param_a \\_. pspace_distinct'\" by (wpsimp simp: vcpuSwitch_def modifyArchState_def | assumption)+ lemma setObject_vcpu_ctes_of[wp]: "\ \s. P (ctes_of s)\ setObject p (t :: vcpu) \\_ s. P (ctes_of s)\" apply (rule ctes_of_from_cte_wp_at[where Q="\", simplified]) apply (wp setObject_cte_wp_at2'[where Q="\"]) apply (clarsimp simp: updateObject_default_def in_monad projectKO_opts_defs) apply (rule equals0I) apply (clarsimp simp: updateObject_default_def in_monad) apply simp done lemma setObject_vcpu_untyped_ranges_zero'[wp]: "setObject ptr (vcpu::vcpu) \untyped_ranges_zero'\" by (rule hoare_lift_Pf[where f=cteCaps_of]; wp cteCaps_of_ctes_of_lift) lemma setVCPU_if_live[wp]: "\\s. if_live_then_nonz_cap' s \ (live' (injectKO vcpu) \ ex_nonz_cap_to' v s)\ setObject v (vcpu::vcpu) \\_. if_live_then_nonz_cap'\" apply (wpsimp wp: setObject_iflive' [where P=\] | simp add: objBits_simps vcpuBits_def pageBits_def)+ apply (clarsimp simp: updateObject_default_def in_monad) apply (clarsimp simp: updateObject_default_def in_monad bind_def) apply simp done lemma setVCPU_if_unsafe[wp]: "setObject v (vcpu::vcpu) \if_unsafe_then_cap'\" apply (wp setObject_ifunsafe') apply (clarsimp simp: updateObject_default_def in_monad) apply (clarsimp simp: updateObject_default_def in_monad bind_def) apply wp apply simp done lemma projectKO_opt_no_vcpu[simp]: "projectKO_opt (KOArch (KOVCPU v)) = (None::'a::no_vcpu option)" by (rule ccontr) (simp add: project_koType not_vcpu[symmetric]) lemma setObject_vcpu_obj_at'_no_vcpu[wp]: "setObject ptr (v::vcpu) \\s. P (obj_at' (P'::'a::no_vcpu \ bool) t s)\" apply (wp setObject_ko_wp_at[where P'="\ko. \obj. projectKO_opt ko = Some obj \ P' (obj::'a::no_vcpu)" for P', folded obj_at'_real_def]) apply (clarsimp simp: updateObject_default_def in_monad not_vcpu[symmetric]) apply (simp add: objBits_simps) apply (simp add: vcpuBits_def pageBits_def) apply (clarsimp split del: if_split) apply (erule rsubst[where P=P]) apply normalise_obj_at' apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) done lemmas setVCPU_pred_tcb'[wp] = setObject_vcpu_obj_at'_no_vcpu [where P'="\ko. P (proj (tcb_to_itcb' ko))" for P proj, folded pred_tcb_at'_def] lemma setVCPU_valid_idle'[wp]: "setObject v (vcpu::vcpu) \valid_idle'\" unfolding valid_idle'_def by (rule hoare_lift_Pf[where f=ksIdleThread]; wp) lemma setVCPU_ksQ[wp]: "\\s. P (ksReadyQueues s)\ setObject p (v::vcpu) \\rv s. P (ksReadyQueues s)\" by (wp setObject_qs updateObject_default_inv | simp)+ lemma setVCPU_valid_queues'[wp]: "setObject v (vcpu::vcpu) \valid_queues'\" unfolding valid_queues'_def by (rule hoare_lift_Pf[where f=ksReadyQueues]; wp hoare_vcg_all_lift updateObject_default_inv) lemma setVCPU_ct_not_inQ[wp]: "setObject v (vcpu::vcpu) \ct_not_inQ\" apply (wp ct_not_inQ_lift) apply (rule hoare_lift_Pf[where f=ksCurThread]; wp) apply assumption done (* TODO: move *) lemma getObject_ko_at_vcpu [wp]: "\\\ getObject p \\rv::vcpu. ko_at' rv p\" by (rule getObject_ko_at | simp add: objBits_simps vcpuBits_def pageBits_def)+ lemma corres_gets_gicvcpu_numlistregs: "corres (=) \ \ (gets (arm_gicvcpu_numlistregs \ arch_state)) (gets (armKSGICVCPUNumListRegs \ ksArchState))" by (simp add: state_relation_def arch_state_relation_def) lemma corres_gets_current_vcpu[corres]: "corres (=) \ \ (gets (arm_current_vcpu \ arch_state)) (gets (armHSCurVCPU \ ksArchState))" by (simp add: state_relation_def arch_state_relation_def) lemma setObject_VCPU_corres: "vcpu_relation vcpuObj vcpuObj' \ corres dc (vcpu_at vcpu) (vcpu_at' vcpu) (set_vcpu vcpu vcpuObj) (setObject vcpu vcpuObj')" apply (simp add: set_vcpu_def) apply (rule corres_guard_imp) apply (rule setObject_other_corres [where P="\ko::vcpu. True"], simp) apply (clarsimp simp: obj_at'_def) apply (erule map_to_ctes_upd_other, simp, simp) apply (simp add: a_type_def is_other_obj_relation_type_def) apply (simp add: objBits_simps) apply simp apply (simp add: objBits_simps vcpuBits_def pageBits_def) apply (simp add: other_obj_relation_def asid_pool_relation_def) apply (clarsimp simp: typ_at_to_obj_at'[symmetric] obj_at_def exs_valid_def assert_def a_type_def return_def fail_def) apply (fastforce split: Structures_A.kernel_object.split_asm if_split_asm) apply (simp add: typ_at_to_obj_at_arches) done lemma setObject_vcpu_cte_wp_at'[wp]: "\\s. P (cte_wp_at' P' p s)\ setObject ptr (vcpu::vcpu) \\rv s. P (cte_wp_at' P' p s)\" apply (wp setObject_cte_wp_at2'[where Q="\"]) apply (clarsimp simp: updateObject_default_def in_monad projectKO_opts_defs) apply (rule equals0I) apply (clarsimp simp: updateObject_default_def in_monad projectKO_opts_defs) apply simp done crunches vcpuSave, vcpuRestore, vcpuDisable, vcpuEnable for ctes[wp]: "\s. P (ctes_of s)" (simp: crunch_simps wp: crunch_wps getObject_inv_vcpu loadObject_default_inv) lemma vcpuSwitch_ctes[wp]: "\\s. P (ctes_of s)\ vcpuSwitch vcpu \\_ s. P (ctes_of s)\" by (wpsimp simp: vcpuSwitch_def modifyArchState_def | assumption)+ crunches vgicUpdate, vgicUpdateLR, vcpuWriteReg, vcpuReadReg, vcpuRestoreRegRange, vcpuSaveRegRange, vcpuSave for typ_at'[wp]: "\s. P (typ_at' T p s)" and no_0_obj'[wp]: no_0_obj' (wp: crunch_wps ignore_del: setObject) crunches vcpuSave, vcpuRestore, vcpuDisable, vcpuEnable for cte_wp_at'[wp]: "\s. P (cte_wp_at' P' p s)" (simp: crunch_simps wp: crunch_wps getObject_inv_vcpu loadObject_default_inv) crunches vcpuDisable, vcpuEnable, vcpuSave, vcpuRestore for no_0_obj'[wp]: no_0_obj' (simp: crunch_simps wp: crunch_wps getObject_inv_vcpu loadObject_default_inv) lemma vcpuSwitch_no_0_obj'[wp]: "\no_0_obj'\ vcpuSwitch v \\_. no_0_obj'\" by (wpsimp simp: vcpuSwitch_def modifyArchState_def | assumption)+ lemma vcpuSwitch_cte_wp_at'[wp]: "\\s. P (cte_wp_at' P' p s)\ vcpuSwitch param_a \\_ s. P (cte_wp_at' P' p s)\ " by (wpsimp simp: vcpuSwitch_def modifyArchState_def | assumption)+ lemma vcpuUpdate_corres[corres]: "\v1 v2. vcpu_relation v1 v2 \ vcpu_relation (f v1) (f' v2) \ corres dc (vcpu_at v) (vcpu_at' v) (vcpu_update v f) (vcpuUpdate v f')" by (corresKsimp corres: getObject_vcpu_corres setObject_VCPU_corres simp: vcpu_update_def vcpuUpdate_def vcpu_relation_def) lemma vgicUpdate_corres[corres]: "\vgic vgic'. vgic_map vgic = vgic' \ vgic_map (f vgic) = (f' vgic') \ corres dc (vcpu_at v) (vcpu_at' v) (vgic_update v f) (vgicUpdate v f')" by (corresKsimp simp: vgic_update_def vgicUpdate_def vcpu_relation_def) lemma vgicUpdateLR_corres[corres]: "corres dc (vcpu_at v) (vcpu_at' v) (vgic_update_lr v idx val) (vgicUpdateLR v idx val)" by (corresKsimp simp: vgic_update_lr_def vgicUpdateLR_def vgic_map_def) lemma vcpuReadReg_corres[corres]: "corres (=) (vcpu_at v) (vcpu_at' v and no_0_obj') (vcpu_read_reg v r) (vcpuReadReg v r)" apply (simp add: vcpu_read_reg_def vcpuReadReg_def) apply (rule corres_guard_imp) apply (rule corres_assert_gen_asm2) apply (rule corres_underlying_split[OF getObject_vcpu_corres]) apply (wpsimp simp: vcpu_relation_def)+ done lemma vcpuWriteReg_corres[corres]: "corres dc (vcpu_at v) (vcpu_at' v and no_0_obj') (vcpu_write_reg v r val) (vcpuWriteReg v r val)" apply (simp add: vcpu_write_reg_def vcpuWriteReg_def) apply (rule corres_guard_imp) apply (rule corres_assert_gen_asm2) apply (rule vcpuUpdate_corres) apply (fastforce simp: vcpu_relation_def)+ done lemma vcpuSaveReg_corres[corres]: "corres dc (vcpu_at v) (vcpu_at' v and no_0_obj') (vcpu_save_reg v r) (vcpuSaveReg v r)" apply (clarsimp simp: vcpu_save_reg_def vcpuSaveReg_def) apply (rule corres_guard_imp) apply (rule corres_assert_gen_asm2) apply (rule corres_split[OF corres_machine_op[where r="(=)"]]) apply (rule corres_Id; simp) apply (rule vcpuUpdate_corres, fastforce simp: vcpu_relation_def vgic_map_def) apply wpsimp+ done lemma vcpuSaveRegRange_corres[corres]: "corres dc (vcpu_at v) (vcpu_at' v and no_0_obj') (vcpu_save_reg_range v rf rt) (vcpuSaveRegRange v rf rt)" apply (clarsimp simp: vcpu_save_reg_range_def vcpuSaveRegRange_def) apply (rule corres_mapM_x[OF _ _ _ _ subset_refl]) apply (wpsimp wp: vcpuSaveReg_corres)+ done lemma vcpuRestoreReg_corres[corres]: "corres dc (vcpu_at v) (vcpu_at' v and no_0_obj') (vcpu_restore_reg v r) (vcpuRestoreReg v r)" apply (clarsimp simp: vcpu_restore_reg_def vcpuRestoreReg_def) apply (rule corres_guard_imp) apply (rule corres_assert_gen_asm2) apply (rule corres_split[OF getObject_vcpu_corres]) apply (rule corres_machine_op) apply (rule corres_Id) apply (fastforce simp: vcpu_relation_def) apply (wpsimp wp: corres_Id simp: vcpu_relation_def vgic_map_def)+ done lemma vcpuRestoreRegRange_corres[corres]: "corres dc (vcpu_at v) (vcpu_at' v and no_0_obj') (vcpu_restore_reg_range v rf rt) (vcpuRestoreRegRange v rf rt)" apply (clarsimp simp: vcpu_restore_reg_range_def vcpuRestoreRegRange_def) apply (rule corres_mapM_x[OF _ _ _ _ subset_refl]) apply (wpsimp wp: vcpuRestoreReg_corres)+ done lemma saveVirtTimer_corres[corres]: "corres dc (vcpu_at vcpu_ptr) (vcpu_at' vcpu_ptr and no_0_obj') (save_virt_timer vcpu_ptr) (saveVirtTimer vcpu_ptr)" unfolding save_virt_timer_def saveVirtTimer_def apply (rule corres_guard_imp) apply (rule corres_split_dc[OF vcpuSaveReg_corres], simp) apply (rule corres_split_dc[OF corres_machine_op], (rule corres_Id; simp)) apply (rule corres_split_dc[OF vcpuSaveReg_corres], simp)+ apply (rule corres_split_eqr[OF corres_machine_op], (rule corres_Id; simp))+ apply (fold dc_def) apply (rule vcpuUpdate_corres) apply (simp add: vcpu_relation_def) apply wpsimp+ done lemma restoreVirtTimer_corres[corres]: "corres dc (vcpu_at vcpu_ptr) (vcpu_at' vcpu_ptr and no_0_obj') (restore_virt_timer vcpu_ptr) (restoreVirtTimer vcpu_ptr)" unfolding restore_virt_timer_def restoreVirtTimer_def IRQ_def apply (rule corres_guard_imp) apply (rule corres_split_dc[OF vcpuRestoreReg_corres], simp)+ apply (rule corres_split_eqr[OF corres_machine_op], (rule corres_Id; simp))+ apply (rule corres_split[OF getObject_vcpu_corres]) apply (rule corres_split_eqr[OF vcpuReadReg_corres]) apply (clarsimp simp: vcpu_relation_def) apply (rule corres_split_dc[OF vcpuWriteReg_corres])+ apply (rule corres_split_dc[OF vcpuRestoreReg_corres], simp)+ apply (rule corres_split_eqr[OF isIRQActive_corres]) apply (rule corres_split_dc[OF corres_when], simp) apply (simp add: irq_vppi_event_index_def irqVPPIEventIndex_def IRQ_def) apply (rule corres_machine_op, simp) apply (rule corres_Id; wpsimp) apply (fold dc_def) apply (rule vcpuRestoreReg_corres) apply (wpsimp simp: if_apply_def2 isIRQActive_def)+ done lemma vcpuSave_corres: "corres dc (vcpu_at (fst cvcpu)) (vcpu_at' (fst cvcpu) and no_0_obj') (vcpu_save (Some cvcpu)) (vcpuSave (Some cvcpu))" apply (clarsimp simp add: vcpu_save_def vcpuSave_def armvVCPUSave_def) apply (cases cvcpu, clarsimp, rename_tac v active) apply (rule corres_guard_imp) apply (rule corres_split_dc[OF corres_machine_op]) apply (rule corres_Id; wpsimp) apply (rule corres_split[where r'=dc]) apply (rule corres_when, simp) apply (rule corres_split[OF vcpuSaveReg_corres]) apply (rule corres_split_eqr[OF corres_machine_op]) apply (rule corres_Id; wpsimp) apply (rule corres_split[OF vgicUpdate_corres]) apply (clarsimp simp: vgic_map_def) apply (rule saveVirtTimer_corres) apply wpsimp+ apply (rule corres_split_eqr[OF corres_machine_op]) apply (rule corres_Id; wpsimp) apply (rule corres_split[OF vgicUpdate_corres]) apply (clarsimp simp: vgic_map_def) apply (rule corres_split_eqr[OF corres_machine_op]) apply (rule corres_Id; wpsimp) apply (rule corres_split[OF vgicUpdate_corres]) apply (clarsimp simp: vgic_map_def) apply (rule corres_split_eqr) apply (rule corres_trivial) apply (fastforce simp add: state_relation_def arch_state_relation_def) apply (simp add: mapM_discarded) apply (rule corres_split[OF corres_mapM_x[OF _ _ _ _ subset_refl]]) apply (rule corres_split_eqr[OF corres_machine_op]) apply (rule corres_Id; wpsimp) apply (clarsimp, fold dc_def) apply (rule vgicUpdateLR_corres) apply wpsimp+ apply (rule corres_split[OF vcpuSaveRegRange_corres]) apply (rule corres_machine_op) apply (rule corres_Id; wpsimp) apply (wpsimp wp: mapM_x_wp_inv hoare_vcg_imp_lift' simp: if_apply_def2)+ done lemma vcpuDisable_corres: "corres dc (\s. (\v. vcpuopt = Some v) \ vcpu_at (the vcpuopt) s) (\s. ((\v. vcpuopt = Some v) \ vcpu_at' (the vcpuopt) s) \ no_0_obj' s) (vcpu_disable vcpuopt) (vcpuDisable vcpuopt)" apply (cases vcpuopt; clarsimp simp: vcpu_disable_def vcpuDisable_def) (* no current VCPU *) subgoal apply (clarsimp simp: doMachineOp_bind do_machine_op_bind empty_fail_cond) apply (rule corres_guard_imp) apply (rule corres_split_dc[OF corres_machine_op] | rule corres_machine_op corres_Id | wpsimp)+ done (* have current VCPU *) apply (rename_tac vcpu) apply (clarsimp simp: doMachineOp_bind do_machine_op_bind bind_assoc IRQ_def) apply (rule corres_guard_imp) apply (rule corres_split_dc[OF corres_machine_op]) apply (rule corres_Id; wpsimp) apply (rule corres_split_eqr[OF corres_machine_op]) apply (rule corres_Id; wpsimp) apply (rule corres_split_dc[OF vgicUpdate_corres]) apply (clarsimp simp: vgic_map_def) apply (rule corres_split_dc[OF vcpuSaveReg_corres]) apply (rule corres_split_dc[OF vcpuSaveReg_corres]) apply (rule corres_split_dc[OF corres_machine_op] corres_split_dc[OF saveVirtTimer_corres] | rule corres_machine_op corres_Id | wpsimp)+ done lemma vcpuEnable_corres: "corres dc (vcpu_at vcpu) (vcpu_at' vcpu and no_0_obj') (vcpu_enable vcpu) (vcpuEnable vcpu)" apply (simp add: vcpu_enable_def vcpuEnable_def doMachineOp_bind do_machine_op_bind bind_assoc) apply (rule corres_guard_imp) apply (rule corres_split_dc[OF vcpuRestoreReg_corres])+ apply (rule corres_split[OF getObject_vcpu_corres], rename_tac vcpu') apply (case_tac vcpu') apply (rule corres_split_dc[OF corres_machine_op] | rule corres_split_dc[OF vcpuRestoreReg_corres] | rule corres_machine_op corres_Id restoreVirtTimer_corres | wpsimp simp: vcpu_relation_def vgic_map_def)+ done lemma vcpuRestore_corres: "corres dc (vcpu_at vcpu) (vcpu_at' vcpu and no_0_obj') (vcpu_restore vcpu) (vcpuRestore vcpu)" apply (simp add: vcpu_restore_def vcpuRestore_def gicVCPUMaxNumLR_def) apply (rule corres_guard_imp) apply (rule corres_split_dc[OF corres_machine_op] | (rule corres_machine_op corres_Id; wpsimp))+ apply (rule corres_split[OF getObject_vcpu_corres], rename_tac vcpu') apply (rule corres_split[OF corres_gets_gicvcpu_numlistregs]) apply (case_tac vcpu' , clarsimp simp: comp_def vcpu_relation_def vgic_map_def mapM_x_mapM uncurry_def split_def mapM_map_simp) apply (simp add: doMachineOp_bind do_machine_op_bind bind_assoc empty_fail_cond) apply (rule corres_split_dc[OF corres_machine_op]) apply (rule corres_Id; wpsimp) apply (rule corres_split_dc[OF corres_machine_op]) apply (rule corres_Id; wpsimp) apply (rule corres_split) apply (rule corres_machine_op, rule corres_Id; wpsimp wp: no_fail_mapM) apply (rule corres_split_dc[OF vcpuRestoreRegRange_corres]) apply (rule vcpuEnable_corres) apply wpsimp+ done lemma vcpuSwitch_corres: assumes "vcpu' = vcpu" shows "corres dc (\s. (vcpu \ None \ vcpu_at (the vcpu) s) \ ((arm_current_vcpu \ arch_state) s \ None \ vcpu_at ((fst \ the \ arm_current_vcpu \ arch_state) s) s)) (\s. (vcpu' \ None \ vcpu_at' (the vcpu') s) \ ((armHSCurVCPU \ ksArchState) s \ None \ vcpu_at' ((fst \ the \ armHSCurVCPU \ ksArchState) s) s) \ no_0_obj' s) (vcpu_switch vcpu) (vcpuSwitch vcpu')" proof - have modify_current_vcpu: "\a b. corres dc \ \ (modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (a, b)\\)) (modifyArchState (armHSCurVCPU_update (\_. Some (a, b))))" by (clarsimp simp add: modifyArchState_def state_relation_def arch_state_relation_def intro!: corres_modify) have get_current_vcpu: "corres (=) \ \ (gets (arm_current_vcpu \ arch_state)) (gets (armHSCurVCPU \ ksArchState))" apply clarsimp apply (rule_tac P = "(arm_current_vcpu (arch_state s)) = (armHSCurVCPU (ksArchState s'))" in TrueE; simp add: state_relation_def arch_state_relation_def) done show ?thesis apply (simp add: vcpu_switch_def vcpuSwitch_def assms) apply (cases vcpu) apply (all \simp, rule corres_underlying_split[OF _ _ gets_sp gets_sp], rule corres_guard_imp[OF get_current_vcpu TrueI TrueI], rename_tac rv rv', case_tac rv ; clarsimp simp add: when_def\) apply (rule corres_machine_op[OF corres_underlying_trivial[OF no_fail_isb]] TrueI TrueI vcpuDisable_corres modify_current_vcpu vcpuEnable_corres vcpuRestore_corres vcpuSave_corres hoare_post_taut conjI corres_underlying_split corres_guard_imp | clarsimp simp add: when_def | wpsimp | assumption)+ done qed lemma aligned_distinct_relation_vcpu_atI'[elim]: "\ vcpu_at p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned' s'; pspace_distinct' s' \ \ vcpu_at' p s'" apply (clarsimp simp add: obj_at_def a_type_def) apply (simp split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) apply (drule(1) pspace_relation_absD) apply (clarsimp simp: other_obj_relation_def) apply (case_tac z ; simp) apply (rename_tac vcpu) apply (case_tac vcpu; simp) apply (clarsimp simp: vcpu_relation_def obj_at'_def typ_at'_def ko_wp_at'_def) apply (fastforce simp add: pspace_aligned'_def pspace_distinct'_def dom_def) done lemma vcpuSwitch_corres': assumes "vcpu' = vcpu" shows "corres dc (\s. (vcpu \ None \ vcpu_at (the vcpu) s) \ ((arm_current_vcpu \ arch_state) s \ None \ vcpu_at ((fst \ the \ arm_current_vcpu \ arch_state) s) s)) (pspace_aligned' and pspace_distinct' and no_0_obj') (vcpu_switch vcpu) (vcpuSwitch vcpu')" apply (rule stronger_corres_guard_imp, rule vcpuSwitch_corres[OF assms]) apply simp apply (simp add: assms) apply (rule conjI) apply clarsimp apply (rule aligned_distinct_relation_vcpu_atI' ; clarsimp simp add: state_relation_def, assumption?) apply (clarsimp simp add: state_relation_def arch_state_relation_def) apply (rule aligned_distinct_relation_vcpu_atI'; assumption) done crunches vgicUpdateLR, vcpuWriteReg, vcpuReadReg, vcpuRestoreRegRange, vcpuSaveRegRange, vcpuSave, vcpuSwitch for nosch[wp]: "\s. P (ksSchedulerAction s)" and it'[wp]: "\s. P (ksIdleThread s)" (ignore: doMachineOp wp: crunch_wps) lemma modifyArchState_hyp[wp]: "modifyArchState x \ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: modifyArchState_def wp: | subst doMachineOp_bind)+ abbreviation "live_vcpu_at_tcb p s \ \x. ko_at' x p s \ (case atcbVCPUPtr (tcbArch x) of None \ \_. True | Some x \ ko_wp_at' (is_vcpu' and hyp_live') x) s" lemma valid_case_option_post_wp': "(\x. \P x\ f \\rv. Q x\) \ \case ep of Some x \ P x | _ \ \_. True\ f \\rv. case ep of Some x \ Q x | _ \ \_. True\" by (cases ep, simp_all add: hoare_vcg_prop) crunches vcpuDisable, vcpuRestore, vcpuEnable, vgicUpdateLR, vcpuWriteReg, vcpuReadReg, vcpuRestoreRegRange, vcpuSaveRegRange for ksQ[wp]: "\s. P (ksReadyQueues s)" (wp: crunch_wps) lemma vcpuSave_ksQ[wp]: "\\s. P (ksReadyQueues s)\ vcpuSave param_a \\_ s. P (ksReadyQueues s)\" supply option.case_cong_weak[cong] apply (wpsimp simp: vcpuSave_def modifyArchState_def armvVCPUSave_def | simp)+ apply (rule_tac S="set gicIndices" in mapM_x_wp) apply wpsimp+ done lemma vcpuSwitch_ksQ[wp]: "\\s. P (ksReadyQueues s)\ vcpuSwitch param_a \\_ s. P (ksReadyQueues s)\" by (wpsimp simp: vcpuSwitch_def modifyArchState_def | simp)+ lemma hyp_live'_vcpu_regs[simp]: "hyp_live' (KOArch (KOVCPU (vcpuRegs_update f vcpu))) = hyp_live' (KOArch (KOVCPU vcpu))" by (simp add: hyp_live'_def arch_live'_def) lemma hyp_live'_vcpu_vgic[simp]: "hyp_live' (KOArch (KOVCPU (vcpuVGIC_update f' vcpu))) = hyp_live' (KOArch (KOVCPU vcpu))" by (simp add: hyp_live'_def arch_live'_def) lemma hyp_live'_vcpu_VPPIMasked[simp]: "hyp_live' (KOArch (KOVCPU (vcpuVPPIMasked_update f' vcpu))) = hyp_live' (KOArch (KOVCPU vcpu))" by (simp add: hyp_live'_def arch_live'_def) lemma hyp_live'_vcpu_VTimer[simp]: "hyp_live' (KOArch (KOVCPU (vcpuVTimer_update f' vcpu))) = hyp_live' (KOArch (KOVCPU vcpu))" by (simp add: hyp_live'_def arch_live'_def) lemma live'_vcpu_regs[simp]: "live' (KOArch (KOVCPU (vcpuRegs_update f vcpu))) = live' (KOArch (KOVCPU vcpu))" by (simp add: live'_def) lemma live'_vcpu_vgic[simp]: "live' (KOArch (KOVCPU (vcpuVGIC_update f' vcpu))) = live' (KOArch (KOVCPU vcpu))" by (simp add: live'_def) lemma live'_vcpu_VPPIMasked[simp]: "live' (KOArch (KOVCPU (vcpuVPPIMasked_update f' vcpu))) = live' (KOArch (KOVCPU vcpu))" by (simp add: live'_def) lemma live'_vcpu_VTimer[simp]: "live' (KOArch (KOVCPU (vcpuVTimer_update f' vcpu))) = live' (KOArch (KOVCPU vcpu))" by (simp add: live'_def) lemma setVCPU_regs_vcpu_live: "\ko_wp_at' (is_vcpu' and hyp_live') p and ko_at' vcpu v\ setObject v (vcpuRegs_update f vcpu) \\_. ko_wp_at' (is_vcpu' and hyp_live') p\" apply (wp setObject_ko_wp_at, simp) apply (simp add: objBits_simps) apply (clarsimp simp: vcpuBits_def pageBits_def) apply (clarsimp simp: pred_conj_def is_vcpu'_def ko_wp_at'_def obj_at'_real_def) done lemma setVCPU_vgic_vcpu_live[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') p and ko_at' vcpu v\ setObject v (vcpuVGIC_update f vcpu) \\_. ko_wp_at' (is_vcpu' and hyp_live') p\" apply (wp setObject_ko_wp_at, simp) apply (simp add: objBits_simps) apply (clarsimp simp: vcpuBits_def pageBits_def) apply (clarsimp simp: pred_conj_def is_vcpu'_def ko_wp_at'_def obj_at'_real_def) done lemma setVCPU_VPPIMasked_vcpu_live[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') p and ko_at' vcpu v\ setObject v (vcpuVPPIMasked_update f vcpu) \\_. ko_wp_at' (is_vcpu' and hyp_live') p\" apply (wp setObject_ko_wp_at, simp) apply (simp add: objBits_simps) apply (clarsimp simp: vcpuBits_def pageBits_def) apply (clarsimp simp: pred_conj_def is_vcpu'_def ko_wp_at'_def obj_at'_real_def) done lemma setVCPU_VTimer_vcpu_live[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') p and ko_at' vcpu v\ setObject v (vcpuVTimer_update f vcpu) \\_. ko_wp_at' (is_vcpu' and hyp_live') p\" apply (wp setObject_ko_wp_at, simp) apply (simp add: objBits_simps) apply (clarsimp simp: vcpuBits_def pageBits_def) apply (clarsimp simp: pred_conj_def is_vcpu'_def ko_wp_at'_def obj_at'_real_def) done lemma vgicUpdate_vcpu_live[wp]: "vgicUpdate v f \ ko_wp_at' (is_vcpu' and hyp_live') p \" by (wpsimp simp: vgicUpdate_def vcpuUpdate_def wp: setVCPU_vgic_vcpu_live) lemma setVCPU_regs_vgic_vcpu_live: "\ko_wp_at' (is_vcpu' and hyp_live') p and ko_at' vcpu v\ setObject v (vcpuRegs_update f (vcpuVGIC_update f' vcpu)) \\_. ko_wp_at' (is_vcpu' and hyp_live') p\" apply (wp setObject_ko_wp_at, simp) apply (simp add: objBits_simps) apply (clarsimp simp: vcpuBits_def pageBits_def) apply (clarsimp simp: pred_conj_def is_vcpu'_def ko_wp_at'_def obj_at'_real_def) done (* FIXME: move *) lemma setVCPU_regs_vgic_valid_arch': "\valid_arch_state' and ko_at' vcpu v\ setObject v (vcpuRegs_update f (vcpuVGIC_update f' vcpu)) \\_. valid_arch_state'\" apply (simp add: valid_arch_state'_def valid_asid_table'_def option_case_all_conv) apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setVCPU_regs_vgic_vcpu_live | rule hoare_lift_Pf[where f=ksArchState])+ apply (clarsimp simp: pred_conj_def o_def) done lemma setVCPU_regs_valid_arch': "\valid_arch_state' and ko_at' vcpu v\ setObject v (vcpuRegs_update f vcpu) \\_. valid_arch_state'\" apply (simp add: valid_arch_state'_def valid_asid_table'_def option_case_all_conv) apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setVCPU_regs_vcpu_live | rule hoare_lift_Pf[where f=ksArchState]) apply (clarsimp simp: pred_conj_def o_def) done lemma setVCPU_vgic_valid_arch': "\valid_arch_state' and ko_at' vcpu v\ setObject v (vcpuVGIC_update f vcpu) \\_. valid_arch_state'\" apply (simp add: valid_arch_state'_def valid_asid_table'_def option_case_all_conv) apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setVCPU_vgic_vcpu_live | rule hoare_lift_Pf[where f=ksArchState]) apply (clarsimp simp: pred_conj_def o_def) done lemma setVCPU_VPPIMasked_valid_arch': "\valid_arch_state' and ko_at' vcpu v\ setObject v (vcpuVPPIMasked_update f vcpu) \\_. valid_arch_state'\" apply (simp add: valid_arch_state'_def valid_asid_table'_def option_case_all_conv) apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setVCPU_vgic_vcpu_live | rule hoare_lift_Pf[where f=ksArchState]) apply (clarsimp simp: pred_conj_def o_def) done lemma setVCPU_VTimer_valid_arch': "\valid_arch_state' and ko_at' vcpu v\ setObject v (vcpuVTimer_update f vcpu) \\_. valid_arch_state'\" apply (simp add: valid_arch_state'_def valid_asid_table'_def option_case_all_conv) apply (wp hoare_vcg_imp_lift hoare_vcg_all_lift setVCPU_vgic_vcpu_live | rule hoare_lift_Pf[where f=ksArchState]) apply (clarsimp simp: pred_conj_def o_def) done lemma state_refs_of'_vcpu_empty: "ko_at' (vcpu::vcpu) v s \ (state_refs_of' s)(v := {}) = state_refs_of' s" by (rule ext) (clarsimp simp: state_refs_of'_def obj_at'_def) lemma state_hyp_refs_of'_vcpu_absorb: "ko_at' vcpu v s \ (state_hyp_refs_of' s)(v := vcpu_tcb_refs' (vcpuTCBPtr vcpu)) = state_hyp_refs_of' s" by (rule ext) (clarsimp simp: state_hyp_refs_of'_def obj_at'_def) lemma setObject_vcpu_valid_objs': "\valid_objs'\ setObject v (vcpu::vcpu) \\_. valid_objs'\" apply (wp setObject_valid_objs') apply (clarsimp simp: in_monad updateObject_default_def valid_obj'_def) apply simp done lemma setVCPU_valid_arch': "\valid_arch_state' and (\s. \a. armHSCurVCPU (ksArchState s) = Some (v,a) \ hyp_live' (KOArch (KOVCPU vcpu))) \ setObject v (vcpu::vcpu) \\_. valid_arch_state'\" apply (simp add: valid_arch_state'_def valid_asid_table'_def option_case_all_conv pred_conj_def) apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' setObject_ko_wp_at | simp add: objBits_simps vcpuBits_def pageBits_def)+ apply (clarsimp simp: is_vcpu'_def ko_wp_at'_def) done lemma setVCPU_valid_queues [wp]: "\valid_queues\ setObject p (v::vcpu) \\_. valid_queues\" by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ crunches vcpuDisable, vcpuRestore, vcpuEnable, vcpuUpdate, vcpuSaveRegRange, vgicUpdateLR for valid_queues[wp]: valid_queues (ignore: doMachineOp wp: mapM_x_wp) lemma vcpuSave_valid_queues[wp]: "\Invariants_H.valid_queues\ vcpuSave param_a \\_. Invariants_H.valid_queues\" by (wpsimp simp: vcpuSave_def armvVCPUSave_def wp: mapM_x_wp cong: option.case_cong_weak | simp)+ lemma vcpuSwitch_valid_queues[wp]: "\Invariants_H.valid_queues\ vcpuSwitch param_a \\_. Invariants_H.valid_queues\" by (wpsimp simp: vcpuSwitch_def modifyArchState_def | simp)+ lemma setObject_vcpu_no_tcb_update: "\ vcpuTCBPtr (f vcpu) = vcpuTCBPtr vcpu \ \ \ valid_objs' and ko_at' (vcpu :: vcpu) p\ setObject p (f vcpu) \ \_. valid_objs' \" apply (rule_tac Q="valid_objs' and (ko_at' vcpu p and valid_obj' (KOArch (KOVCPU vcpu)))" in hoare_pre_imp) apply (clarsimp) apply (simp add: valid_obj'_def) apply (rule setObject_valid_objs') apply (clarsimp simp add: obj_at'_def) apply (frule updateObject_default_result) apply (clarsimp simp add: valid_obj'_def) done lemma vcpuUpdate_valid_objs'[wp]: "\vcpu. vcpuTCBPtr (f vcpu) = vcpuTCBPtr vcpu \ \valid_objs'\ vcpuUpdate vr f \\_. valid_objs'\" apply (wpsimp simp: vcpuUpdate_def) apply (rule_tac vcpu=vcpu in setObject_vcpu_no_tcb_update) apply wpsimp+ done crunches vgicUpdate, vcpuSaveReg, vgicUpdateLR, vcpuSaveRegRange, vcpuSave, vcpuDisable, vcpuEnable, vcpuRestore, vcpuSwitch for valid_objs'[wp]: valid_objs' and ksCurDomain[wp]: "\s. P (ksCurDomain s)" (wp: mapM_wp_inv simp: mapM_x_mapM) lemma setVCPU_regs_r_invs_cicd': "\invs_no_cicd' and ko_at' vcpu v\ setObject v (vcpuRegs_update (\_. (vcpuRegs vcpu)(r:=rval)) vcpu) \\_. invs_no_cicd'\" unfolding valid_state'_def valid_pspace'_def valid_mdb'_def invs_no_cicd'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. vcpuRegs_update (\_. (vcpuRegs vcpu)(r:=rval)) vcpu"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift setObject_typ_at' cur_tcb_lift setVCPU_regs_valid_arch' setVCPU_regs_vcpu_live simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def) done lemma setVCPU_vgic_invs_cicd': "\invs_no_cicd' and ko_at' vcpu v\ setObject v (vcpuVGIC_update f vcpu) \\_. invs_no_cicd'\" unfolding valid_state'_def valid_pspace'_def valid_mdb'_def invs_no_cicd'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. (vcpuVGIC_update f vcpu)"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift setObject_typ_at' cur_tcb_lift setVCPU_vgic_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def) done lemma setVCPU_VPPIMasked_invs_cicd': "\invs_no_cicd' and ko_at' vcpu v\ setObject v (vcpuVPPIMasked_update f vcpu) \\_. invs_no_cicd'\" unfolding valid_state'_def valid_pspace'_def valid_mdb'_def invs_no_cicd'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. (vcpuVPPIMasked_update f vcpu)"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift setObject_typ_at' cur_tcb_lift setVCPU_VPPIMasked_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def) done lemma setVCPU_VTimer_invs_cicd': "\invs_no_cicd' and ko_at' vcpu v\ setObject v (vcpuVTimer_update f vcpu) \\_. invs_no_cicd'\" unfolding valid_state'_def valid_pspace'_def valid_mdb'_def invs_no_cicd'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. (vcpuVTimer_update f vcpu)"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift setObject_typ_at' cur_tcb_lift setVCPU_VTimer_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def) done lemma vgicUpdate_invs_no_cicd'[wp]: "\invs_no_cicd'\ vgicUpdate f v \\_. invs_no_cicd'\" by (wpsimp simp: vgicUpdate_def vcpuUpdate_def wp: setVCPU_vgic_invs_cicd') lemma vcpuRestoreReg_invs_no_cicd'[wp]: "\invs_no_cicd'\ vcpuRestoreReg v r \\_. invs_no_cicd'\" by (wpsimp simp: vcpuRestoreReg_def | subst doMachineOp_bind | rule empty_fail_bind)+ lemma vcpuReadReg_invs_no_cicd'[wp]: "\invs_no_cicd'\ vcpuReadReg v r \\_. invs_no_cicd'\" by (wpsimp simp: vcpuReadReg_def | subst doMachineOp_bind | rule empty_fail_bind)+ lemma vcpuSaveReg_invs_no_cicd'[wp]: "\invs_no_cicd'\ vcpuSaveReg v r \\_. invs_no_cicd'\" by (wpsimp simp: vcpuSaveReg_def vcpuUpdate_def wp: setVCPU_regs_r_invs_cicd' | subst doMachineOp_bind | rule empty_fail_bind)+ lemma vcpuWriteReg_invs_no_cicd'[wp]: "\invs_no_cicd'\ vcpuWriteReg vcpu_ptr r v \\_. invs_no_cicd'\" by (wpsimp simp: vcpuWriteReg_def vcpuUpdate_def wp: setVCPU_regs_r_invs_cicd' | subst doMachineOp_bind | rule empty_fail_bind)+ crunches vcpuRestoreRegRange, vcpuSaveRegRange, vgicUpdateLR for invs_no_cicd'[wp]: invs_no_cicd' (wp: mapM_x_wp ignore: loadObject) lemma saveVirtTimer_invs_no_cicd'[wp]: "\invs_no_cicd'\ saveVirtTimer vcpu_ptr \\_. invs_no_cicd'\" by (wpsimp simp: saveVirtTimer_def vcpuUpdate_def read_cntpct_def wp: setVCPU_VTimer_invs_cicd' dmo'_gets_wp) lemma restoreVirtTimer_invs_no_cicd'[wp]: "\invs_no_cicd'\ restoreVirtTimer vcpu_ptr \\_. invs_no_cicd'\" by (wpsimp simp: restoreVirtTimer_def vcpuUpdate_def read_cntpct_def if_apply_def2 isIRQActive_def wp: setVCPU_VTimer_invs_cicd' maskInterrupt_invs_no_cicd' getIRQState_wp dmo'_gets_wp) lemma vcpuEnable_invs_no_cicd'[wp]: "\invs_no_cicd'\ vcpuEnable v \\_. invs_no_cicd'\" by (wpsimp simp: vcpuEnable_def | subst doMachineOp_bind | rule empty_fail_bind)+ lemma dmo_maskInterrupt_True_invs_no_cicd'[wp]: "doMachineOp (maskInterrupt True irq) \invs_no_cicd'\" apply (wp dmo_maskInterrupt) apply (clarsimp simp: invs_no_cicd'_def valid_state'_def) apply (simp add: valid_irq_masks'_def valid_machine_state'_def ct_not_inQ_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) done lemma vcpuDisable_invs_no_cicd'[wp]: "\invs_no_cicd'\ vcpuDisable v \\_. invs_no_cicd'\" unfolding vcpuDisable_def by (wpsimp wp: doMachineOp_typ_ats simp: vcpuDisable_def doMachineOp_typ_at' split: option.splits | subst doMachineOp_bind | rule empty_fail_bind conjI)+ lemma vcpuRestore_invs_no_cicd'[wp]: "\invs_no_cicd'\ vcpuRestore v \\_. invs_no_cicd'\" including no_pre apply (wpsimp simp: vcpuRestore_def uncurry_def split_def doMachineOp_mapM_x gets_wp | subst doMachineOp_bind | rule empty_fail_bind)+ apply (rule_tac S="(\i. (of_nat i, vgicLR (vcpuVGIC vcpu) i)) ` {0..invs_no_cicd'\ vcpuSave v \\_. invs_no_cicd'\" by (wpsimp simp: vcpuSave_def armvVCPUSave_def wp: mapM_x_wp cong: option.case_cong_weak | assumption)+ lemma valid_arch_state'_armHSCurVCPU_update[simp]: "ko_wp_at' (is_vcpu' and hyp_live') v s \ valid_arch_state' s \ valid_arch_state' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" by (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def irq_issued'_def irqs_masked'_def valid_machine_state'_def cur_tcb'_def) lemma dmo_vcpu_hyp: "\ko_wp_at' (is_vcpu' and hyp_live') v\ doMachineOp f \\_. ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: doMachineOp_def) lemma vcpuSaveReg_hyp[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') v \ vcpuSaveReg v' r \\_. ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: vcpuSaveReg_def vcpuUpdate_def wp: setVCPU_regs_vcpu_live dmo_vcpu_hyp) lemma vcpuWriteReg_hyp[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') v \ vcpuWriteReg v' r val \\_. ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: vcpuWriteReg_def vcpuUpdate_def wp: setVCPU_regs_vcpu_live dmo_vcpu_hyp) crunches vcpuRestoreRegRange, vcpuSaveRegRange, vgicUpdateLR, vcpuReadReg for hyp[wp]: "ko_wp_at' (is_vcpu' and hyp_live') v" (wp: crunch_wps setVCPU_regs_vcpu_live dmo_vcpu_hyp) lemma saveVirtTimer_hyp[wp]: "saveVirtTimer vcpu_ptr \ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: saveVirtTimer_def vcpuUpdate_def wp: dmo_vcpu_hyp vgicUpdate_vcpu_live) lemma restoreVirtTimer_hyp[wp]: "restoreVirtTimer vcpu_ptr \ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: restoreVirtTimer_def vcpuUpdate_def isIRQActive_def wp: dmo_vcpu_hyp vgicUpdate_vcpu_live) lemma vcpuDisable_hyp[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') v\ vcpuDisable (Some x) \\_. ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: vcpuDisable_def wp: dmo_vcpu_hyp vgicUpdate_vcpu_live | subst doMachineOp_bind | rule empty_fail_bind)+ lemma vcpuEnable_hyp[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') v\ vcpuEnable x \\_. ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: vcpuEnable_def wp: dmo_vcpu_hyp | subst doMachineOp_bind | rule empty_fail_bind)+ lemma vcpuRestore_hyp[wp]: "\ko_wp_at' (is_vcpu' and hyp_live') v\ vcpuRestore x \\_. ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: vcpuRestore_def wp: dmo_vcpu_hyp | subst doMachineOp_bind | rule empty_fail_bind)+ lemma armvVCPUSave_hyp[wp]: "armvVCPUSave x y \ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: armvVCPUSave_def wp: dmo_vcpu_hyp) lemma vcpuSave_hyp[wp]: "vcpuSave x \ko_wp_at' (is_vcpu' and hyp_live') v\" apply (wpsimp simp: vcpuSave_def wp: dmo_vcpu_hyp mapM_x_wp' | subst doMachineOp_bind | rule empty_fail_bind)+ apply (simp add: pred_conj_def) done lemma vcpuSwitch_hyp[wp]: "vcpuSwitch x \ko_wp_at' (is_vcpu' and hyp_live') v\" by (wpsimp simp: vcpuSwitch_def wp: dmo_vcpu_hyp) lemma getObject_vcpu_ko_at': "(vcpu::vcpu, s') \ fst (getObject p s) \ s' = s \ ko_at' vcpu p s" apply (rule context_conjI) apply (drule use_valid, rule getObject_inv[where P="(=) s"]; simp add: loadObject_default_inv) apply (drule use_valid, rule getObject_ko_at; clarsimp simp: obj_at_simps vcpuBits_def) done lemma vcpuUpdate_valid_arch_state'[wp]: "\vcpu. vcpuTCBPtr (f vcpu) = vcpuTCBPtr vcpu \ \valid_arch_state'\ vcpuUpdate vr f \\_. valid_arch_state'\" including no_pre apply (wpsimp simp: vcpuUpdate_def wp: setVCPU_valid_arch') by (clarsimp simp: valid_def in_monad hyp_live'_def arch_live'_def valid_arch_state'_def obj_at'_real_def ko_wp_at'_def is_vcpu'_def dest!: getObject_vcpu_ko_at')+ crunches vcpuRestoreReg for valid_arch_state'[wp]: valid_arch_state' crunches vgicUpdateLR, vcpuSave, vcpuDisable, vcpuEnable, vcpuRestore for valid_arch_state'[wp]: valid_arch_state' (wp: crunch_wps ignore: doMachineOp) lemma vcpuSwitch_valid_arch_state'[wp]: "\valid_arch_state' and (case v of None \ \ | Some x \ ko_wp_at' (is_vcpu' and hyp_live') x)\ vcpuSwitch v \\_. valid_arch_state'\" apply (wpsimp simp: vcpuSwitch_def modifyArchState_def wp: vcpuDisable_hyp[simplified pred_conj_def] vcpuSave_hyp[unfolded pred_conj_def] dmo_vcpu_hyp vcpuSave_valid_arch_state' | strengthen valid_arch_state'_armHSCurVCPU_update | simp)+ apply (auto simp: valid_arch_state'_def pred_conj_def) done lemma invs_no_cicd'_armHSCurVCPU_update[simp]: "ko_wp_at' (is_vcpu' and hyp_live') v s \ invs_no_cicd' s \ invs_no_cicd' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" by (clarsimp simp: invs_no_cicd'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def irq_issued'_def irqs_masked'_def valid_machine_state'_def cur_tcb'_def) lemma invs'_armHSCurVCPU_update[simp]: "ko_wp_at' (is_vcpu' and hyp_live') v s \ invs' s \ invs' (s\ksArchState := armHSCurVCPU_update (\_. Some (v, b)) (ksArchState s)\)" apply (clarsimp simp: invs'_def valid_state'_def valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs valid_global_refs'_def valid_arch_state'_def global_refs'_def valid_queues'_def valid_irq_node'_def valid_irq_handlers'_def irq_issued'_def irqs_masked'_def valid_machine_state'_def cur_tcb'_def) done lemma armHSCurVCPU_None_invs'[wp]: "modifyArchState (armHSCurVCPU_update Map.empty) \invs'\" apply (wpsimp simp: modifyArchState_def) by (clarsimp simp: invs'_def valid_state'_def valid_machine_state'_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def valid_arch_state'_def valid_global_refs'_def global_refs'_def) lemma setVCPU_vgic_invs': "\invs' and ko_at' vcpu v\ setObject v (vcpuVGIC_update f vcpu) \\_. invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. vcpuVGIC_update f vcpu"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift setObject_typ_at' cur_tcb_lift setVCPU_vgic_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def) done lemma setVCPU_regs_invs': "\invs' and ko_at' vcpu v\ setObject v (vcpuRegs_update f vcpu) \\_. invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. vcpuRegs_update f vcpu"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift setObject_typ_at' cur_tcb_lift setVCPU_regs_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def) done lemma setVCPU_VPPIMasked_invs': "\invs' and ko_at' vcpu v\ setObject v (vcpuVPPIMasked_update f vcpu) \\_. invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. vcpuVPPIMasked_update f vcpu"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift setObject_typ_at' cur_tcb_lift setVCPU_VPPIMasked_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def) done lemma setVCPU_VTimer_invs': "\invs' and ko_at' vcpu v\ setObject v (vcpuVTimer_update f vcpu) \\_. invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def supply fun_upd_apply[simp del] apply (wpsimp wp: setObject_vcpu_no_tcb_update [where f="\vcpu. vcpuVTimer_update f vcpu"] sch_act_wf_lift tcb_in_cur_domain'_lift valid_queues_lift setObject_state_refs_of' setObject_state_hyp_refs_of' valid_global_refs_lift' valid_irq_node_lift_asm [where Q=\] valid_irq_handlers_lift' cteCaps_of_ctes_of_lift irqs_masked_lift ct_idle_or_in_cur_domain'_lift valid_irq_states_lift' hoare_vcg_all_lift hoare_vcg_disj_lift setObject_typ_at' cur_tcb_lift setVCPU_VTimer_valid_arch' simp: objBits_simps archObjSize_def vcpuBits_def pageBits_def state_refs_of'_vcpu_empty state_hyp_refs_of'_vcpu_absorb) apply (clarsimp simp: if_live_then_nonz_cap'_def obj_at'_real_def) apply (fastforce simp: ko_wp_at'_def) done lemma vcpuWriteReg_invs'[wp]: "vcpuWriteReg vcpu_ptr r v \invs'\" by (wpsimp simp: vcpuWriteReg_def vcpuUpdate_def wp: setVCPU_regs_invs') lemma vcpuSaveReg_invs'[wp]: "vcpuSaveReg v r \invs'\" by (wpsimp simp: vcpuSaveReg_def vcpuUpdate_def wp: setVCPU_regs_invs') lemma saveVirtTimer_invs'[wp]: "saveVirtTimer vcpu_ptr \invs'\" unfolding saveVirtTimer_def by (wpsimp wp: dmo'_gets_wp setVCPU_vgic_invs' setVCPU_regs_invs' dmo_maskInterrupt_True setVCPU_VTimer_invs' simp: doMachineOp_bind vcpuUpdate_def read_cntpct_def check_export_arch_timer_def) lemma vcpuDisable_invs'[wp]: "vcpuDisable v \invs'\" unfolding vcpuDisable_def isb_def setHCR_def setSCTLR_def set_gic_vcpu_ctrl_hcr_def getSCTLR_def get_gic_vcpu_ctrl_hcr_def dsb_def vgicUpdate_def vcpuUpdate_def vcpuSaveReg_def enableFpuEL01_def by (wpsimp wp: dmo'_gets_wp setVCPU_vgic_invs' setVCPU_regs_invs' dmo_maskInterrupt_True simp: doMachineOp_bind empty_fail_cond) lemma vcpuInvalidateActive_invs'[wp]: "vcpuInvalidateActive \invs'\" unfolding vcpuInvalidateActive_def by wpsimp crunches vcpuRestoreReg, vcpuRestoreRegRange, vcpuSaveReg, vcpuSaveRegRange, vgicUpdateLR, vcpuReadReg for invs'[wp]: invs' (wp: crunch_wps setVCPU_regs_invs' setVCPU_vgic_invs' simp: vcpuUpdate_def ignore: doMachineOp vcpuUpdate) lemma restoreVirtTimer_invs'[wp]: "restoreVirtTimer vcpu_ptr \ invs'\" unfolding restoreVirtTimer_def by (wpsimp wp: maskInterrupt_invs' getIRQState_wp dmo'_gets_wp dmo_machine_op_lift_invs' simp: IRQ_def if_apply_def2 read_cntpct_def isIRQActive_def) lemma vcpuEnable_invs'[wp]: "vcpuEnable v \ invs'\" unfolding vcpuEnable_def by (wpsimp | subst doMachineOp_bind | rule empty_fail_bind)+ lemma vcpuRestore_invs'[wp]: "\invs'\ vcpuRestore v \\_. invs'\" unfolding vcpuRestore_def by (wpsimp simp: vcpuRestore_def uncurry_def split_def doMachineOp_mapM_x wp: mapM_x_wp[OF _ subset_refl] | subst doMachineOp_bind | rule empty_fail_bind)+ lemma vcpuSave_invs': "\invs'\ vcpuSave v \\_. invs'\" by (wpsimp simp: vcpuSave_def doMachineOp_mapM armvVCPUSave_def get_gic_vcpu_ctrl_apr_def get_gic_vcpu_ctrl_vmcr_def get_gic_vcpu_ctrl_hcr_def getSCTLR_def wp: dmo'_gets_wp vgicUpdate_invs' mapM_x_wp[OF _ subset_refl]) lemma vcpuSwitch_invs'[wp]: "\invs' and (case v of None \ \ | Some x \ ko_wp_at' (is_vcpu' and hyp_live') x)\ vcpuSwitch v \\_. invs'\" apply (wpsimp simp: vcpuSwitch_def modifyArchState_def wp: vcpuDisable_hyp[simplified pred_conj_def] vcpuSave_hyp[unfolded pred_conj_def] dmo_vcpu_hyp vcpuSave_invs' | strengthen invs'_armHSCurVCPU_update | simp)+ apply (auto simp: invs'_def valid_state'_def valid_arch_state'_def pred_conj_def) done lemma vcpuSwitch_invs_no_cicd'[wp]: "\invs_no_cicd' and (case v of None \ \ | Some x \ ko_wp_at' (is_vcpu' and hyp_live') x)\ vcpuSwitch v \\_. invs_no_cicd'\" apply (wpsimp simp: vcpuSwitch_def modifyArchState_def wp: vcpuDisable_hyp[simplified pred_conj_def] vcpuSave_hyp[unfolded pred_conj_def] gets_wp vcpuSave_invs_no_cicd' dmo_vcpu_hyp | strengthen invs_no_cicd'_armHSCurVCPU_update | simp)+ apply (auto simp: invs_no_cicd'_def valid_state'_def valid_arch_state'_def pred_conj_def) done crunches loadVMID for inv: P lemma updateASIDPoolEntry_valid_arch_state'[wp]: "updateASIDPoolEntry f asid \valid_arch_state'\" unfolding updateASIDPoolEntry_def by (wpsimp wp: getObject_inv simp: loadObject_default_def) crunches armContextSwitch, setGlobalUserVSpace for valid_arch_state'[wp]: valid_arch_state' (* FIXME AARCH64 consolidated VCPU block ends here *) lemma setVMRoot_valid_arch_state'[wp]: "\valid_arch_state' and live_vcpu_at_tcb p\ setVMRoot p \\rv. valid_arch_state'\" apply (simp add: setVMRoot_def getThreadVSpaceRoot_def) apply ((wpsimp wp: hoare_vcg_ex_lift hoare_drop_imps getObject_tcb_wp valid_case_option_post_wp' simp: if_apply_def2 | wp hoare_vcg_all_lift)+) done crunches setVMRoot for ksQ[wp]: "\s. P (ksReadyQueues s)" (simp: updateObject_default_def o_def loadObject_default_def if_apply_def2 wp: crunch_wps getObject_inv) lemma handleVMFault_corres: "corres (fr \ dc) (tcb_at thread and pspace_aligned and pspace_distinct) \ (handle_vm_fault thread fault) (handleVMFault thread fault)" supply if_split[split del] apply (rule corres_cross_over_guard[where Q="tcb_at' thread"]) apply (fastforce simp: tcb_at_cross state_relation_def) apply (simp add: AARCH64_H.handleVMFault_def handle_vm_fault_def) apply (cases fault) (* ARMDataAbort *) apply (simp add: curVCPUActive_def) apply (rule corres_guard_imp) apply (rule corres_splitEE, simp, rule corres_machine_op[where r="(=)"], rule corres_Id refl, rule refl, simp, simp)+ (* only do S1 translation if current VCPU active *) apply (simp add: bind_liftE_distrib bindE_assoc) apply (rule corres_splitEE[OF corres_liftE_lift[OF corres_gets_current_vcpu]]) apply (clarsimp simp: liftE_return_bindE bindE_assoc) apply (rule corres_split_eqrE[OF corres_if]) apply fastforce apply (rule corres_split_eqrE, simp) apply (rule corres_returnOkTT, simp) apply simp apply (rule corres_splitEE, simp, rule corres_machine_op[where r="(=)"], rule corres_Id refl, rule refl, simp, simp)+ apply (rule corres_returnOkTT, simp) apply wpsimp+ apply (rule corres_returnOkTT, simp) apply (rule corres_trivial) apply simp apply (wpsimp simp: if_apply_def2)+ (* ARMPrefetchAbort *) apply (simp add: curVCPUActive_def) apply (rule corres_guard_imp) apply (rule corres_splitEE,simp) apply (rule asUser_corres') apply (rule corres_no_failI [where R="(=)"]) apply (rule no_fail_getRestartPC) apply fastforce apply (rule corres_splitEE,simp, rule corres_machine_op [where r="(=)"], rule corres_Id refl, rule refl, simp, simp)+ (* only do S1 translation if current VCPU active *) apply (simp add: bind_liftE_distrib bindE_assoc) apply (rule corres_splitEE[OF corres_liftE_lift[OF corres_gets_current_vcpu]]) apply (clarsimp simp: liftE_return_bindE bindE_assoc) apply (rule corres_split_eqrE[OF corres_if]) apply fastforce apply (rule corres_split_eqrE, simp) apply (rule corres_returnOkTT, simp) apply simp apply (rule corres_splitEE, simp, rule corres_machine_op[where r="(=)"], rule corres_Id refl, rule refl, simp, simp)+ apply (rule corres_returnOkTT, simp) apply wpsimp+ apply (rule corres_returnOkTT, simp) apply (rule corres_trivial, simp) apply (wpsimp simp: if_apply_def2)+ done crunches findFreeVMID, loadVMID for no_0_obj'[wp]: no_0_obj' (wp: crunch_wps getObject_inv simp: o_def loadObject_default_def) lemma mask_is_asid_low_bits_of[simp]: "(ucast asid :: machine_word) && mask asid_low_bits = ucast (asid_low_bits_of asid)" by (word_eqI_solve simp: asid_low_bits_of_def asid_low_bits_def) declare corres_gets_asid[corres] (* FIXME AARCH64: declare at origin *) declare getPoolPtr_corres[corres] (* FIXME AARCH64: declare at origin *) declare getObject_ASIDPool_corres[corres] (* FIXME AARCH64: declare at origin *) lemma getASIDPoolEntry_corres'[corres]: "asid' = ucast asid \ corres (\r r'. r = map_option abs_asid_entry r') (\s. pspace_aligned s \ pspace_distinct s \ (\p. pool_for_asid asid s = Some p \ asid_pool_at p s) \ 0 < asid) \ (gets (entry_for_asid asid)) (getASIDPoolEntry asid')" unfolding entry_for_asid_def getASIDPoolEntry_def apply (clarsimp simp: gets_obind_bind_eq entry_for_pool_def obind_comp_dist cong: option.case_cong) apply (corres corres: getPoolPtr_corres | corres_cases_both)+ apply (rule monadic_rewrite_corres_l) apply (monadic_rewrite_l gets_oapply_liftM_rewrite) apply (rule monadic_rewrite_refl) apply (corres simp: liftM_def asid_pool_relation_def asid_pools_at_eq corres: corres_returnTT | corres_cases)+ done lemma getASIDPoolEntry_get_the_corres[corres]: "asid' = ucast asid \ corres (\r r'. map_option abs_asid_entry r' = Some r) (\s. pspace_aligned s \ pspace_distinct s \ entry_for_asid asid s \ None \ 0 < asid) \ (gets_the (entry_for_asid asid)) (getASIDPoolEntry asid')" apply (simp add: gets_the_def cong: corres_weak_cong) apply (rule corres_bind_return2) apply (corres simp: entry_for_asid_def entry_for_pool_def in_omonad obj_at_def) done lemma loadVMID_corres[corres]: "asid' = ucast asid \ corres (=) (pspace_aligned and pspace_distinct and (\s. vspace_for_asid asid s \ None)) \ (load_vmid asid) (loadVMID asid')" unfolding load_vmid_def loadVMID_def apply corres apply (corres_cases, rule corres_inst[where P=\ and P'=\], clarsimp) apply (corres_cases, rule corres_returnTT, clarsimp simp: abs_asid_entry_def) apply wpsimp+ apply (clarsimp simp: vspace_for_asid_def) apply clarsimp done lemma updateASIDPoolEntry_corres[corres]: assumes eq: "asid' = ucast asid" assumes abs: "\e. map_option abs_asid_entry (f' e) = f (abs_asid_entry e)" shows "corres dc ((\s. entry_for_asid asid s \ None \ 0 < asid) and pspace_aligned and pspace_distinct) \ (update_asid_pool_entry f asid) (updateASIDPoolEntry f' asid')" unfolding update_asid_pool_entry_def updateASIDPoolEntry_def apply (simp add: gets_the_def bind_assoc eq) apply (corres simp: liftM_def term_simp: asid_pool_relation_def asid_low_bits_of_def mask_asid_low_bits_ucast_ucast ucast_ucast_mask2 is_down ucast_and_mask) apply (rule ext) apply (clarsimp simp: asid_pool_relation_def asid_low_bits_of_def mask_asid_low_bits_ucast_ucast ucast_ucast_mask2 is_down ucast_and_mask abs) apply (erule notE) apply word_eqI_solve apply wpsimp+ apply (clarsimp simp: entry_for_asid_def entry_for_pool_def asid_pools_at_eq) apply simp done lemma gets_armKSVMIDTable_corres[corres]: "corres (\t t'. t' = map_option UCAST(16 \ 64) \ t) \ \ (gets (arm_vmid_table \ arch_state)) (gets (armKSVMIDTable \ ksArchState))" by (simp add: state_relation_def arch_state_relation_def) lemma storeVMID_corres[corres]: "\ asid' = ucast asid; vmid' = vmid \ \ corres dc (pspace_aligned and pspace_distinct and (\s. vspace_for_asid asid s \ None)) \ (store_vmid asid vmid) (storeVMID asid' vmid')" unfolding store_vmid_def storeVMID_def apply (corres simp: abs_asid_entry_def corres: corres_modify_tivial) apply (fastforce simp: state_relation_def arch_state_relation_def) apply wpsimp+ apply (clarsimp simp: vspace_for_asid_def) apply simp done lemma invalidateASID_corres[corres]: "asid' = ucast asid \ corres dc ((\s. entry_for_asid asid s \ None \ 0 < asid) and pspace_aligned and pspace_distinct) \ (invalidate_asid asid) (invalidateASID asid')" unfolding invalidate_asid_def invalidateASID_def by (corres simp: abs_asid_entry_def entry_for_asid_def) lemma gets_armKSNextVMID_corres[corres]: "corres (=) \ \ (gets (arm_next_vmid \ arch_state)) (gets (armKSNextVMID \ ksArchState))" by (simp add: state_relation_def arch_state_relation_def) lemma take_vmid_minBound_maxBound: "take (length [minBound .e. maxBound :: vmid]) ([next_vmid .e. maxBound] @ [minBound .e. next_vmid]) = [next_vmid .e. maxBound] @ init [minBound .e. next_vmid]" for next_vmid :: vmid using leq_maxBound[where x=next_vmid] by (simp add: word_le_nat_alt init_def upto_enum_word minBound_word) (* FIXME AARCH64: move to SubMonad *) lemmas corres_machine_op_Id = corres_machine_op[OF corres_Id] lemmas corres_machine_op_Id_eq[corres_term] = corres_machine_op_Id[where r="(=)"] lemmas corres_machine_op_Id_dc[corres_term] = corres_machine_op_Id[where r="dc::unit \ unit \ bool"] lemma invalidateVMIDEntry_corres[corres]: "vmid' = vmid \ corres dc \ \ (invalidate_vmid_entry vmid) (invalidateVMIDEntry vmid')" unfolding invalidate_vmid_entry_def invalidateVMIDEntry_def by (corres' \fastforce simp: state_relation_def arch_state_relation_def\ corres: corres_modify_tivial) lemma valid_vmid_tableD: "\ valid_vmid_table s; vmid_table s vmid = Some asid \ \ 0 < asid" apply (subgoal_tac "asid \ 0") apply (simp add: word_neq_0_conv) apply (fastforce simp: valid_vmid_table_def) done lemma findFreeVMID_corres[corres]: "corres (=) (vmid_inv and valid_vmid_table and pspace_aligned and pspace_distinct) \ find_free_vmid findFreeVMID" unfolding find_free_vmid_def findFreeVMID_def apply (simp only: take_vmid_minBound_maxBound) apply corres apply corres_cases_both (* case find .. of *) (* Only None case left over *) apply corres apply (clarsimp dest!: findNoneD) apply (drule bspec, rule UnI1, simp, rule order_refl) apply clarsimp apply (corres corres: corres_modify_tivial (* FIXME AARCH64: fix typo *) simp: state_relation_def arch_state_relation_def maxBound_word minBound_word) apply wpsimp+ apply (clarsimp dest!: findNoneD) apply (drule bspec, rule UnI1, simp, rule order_refl) apply (clarsimp simp: vmid_inv_def) apply (frule (1) valid_vmid_tableD) apply (drule (1) is_inv_SomeD) apply (clarsimp simp: entry_for_asid_def) apply (clarsimp simp: vmid_for_asid_2_def in_omonad entry_for_pool_def pool_for_asid_def if_option_eq) apply simp done lemma getVMID_corres[corres]: "asid' = ucast asid \ corres (=) (vmid_inv and valid_vmid_table and pspace_aligned and pspace_distinct and (\s. vspace_for_asid asid s \ None)) \ (get_vmid asid) (getVMID asid')" unfolding get_vmid_def getVMID_def by (corres wp: hoare_drop_imps simp: vspace_for_asid_def entry_for_asid_def | corres_cases_both)+ lemma armContextSwitch_corres[corres]: "asid' = ucast asid \ corres dc (vmid_inv and valid_vmid_table and pspace_aligned and pspace_distinct and (\s. vspace_for_asid asid s \ None)) \ (arm_context_switch pt asid) (armContextSwitch pt asid')" unfolding arm_context_switch_def armContextSwitch_def by corres lemma setVMRoot_corres [corres]: assumes "t' = t" shows "corres dc (tcb_at t and valid_vspace_objs and valid_asid_table and vmid_inv and valid_vmid_table and pspace_aligned and pspace_distinct and valid_objs and valid_global_arch_objs) (no_0_obj') (set_vm_root t) (setVMRoot t')" proof - have global: "(\s. P s \ valid_global_arch_objs s) \ corres dc P Q set_global_user_vspace setGlobalUserVSpace" for P Q unfolding set_global_user_vspace_def setGlobalUserVSpace_def o_def[where g=arch_state] by (corresKsimp corres: corres_gets_global_pt corres_machine_op) show ?thesis unfolding set_vm_root_def setVMRoot_def catchFailure_def withoutFailure_def throw_def apply (rule corres_cross_over_guard[where Q="no_0_obj' and pspace_distinct' and pspace_aligned'"]) apply (clarsimp simp add: pspace_distinct_cross pspace_aligned_cross state_relation_def) apply (rule corres_guard_imp) apply (rule corres_split[where r'="(=) \ cte_map" and P=\ and P'=\]) apply (simp add: getThreadVSpaceRoot_def locateSlotTCB_def locateSlotBasic_def tcbVTableSlot_def cte_map_def objBits_def cte_level_bits_def objBitsKO_def tcb_cnode_index_def to_bl_1 assms cteSizeBits_def) apply (rule_tac R="\thread_root. valid_vspace_objs and valid_asid_table and vmid_inv and valid_vmid_table and pspace_aligned and pspace_distinct and valid_objs and valid_global_arch_objs and cte_wp_at ((=) thread_root) thread_root_slot and tcb_at (fst thread_root_slot) and K (snd thread_root_slot = tcb_cnode_index 1)" and R'="\thread_root. no_0_obj'" in corres_split[OF getSlotCap_corres]) apply simp apply simp apply (rename_tac cap cap') apply (rule_tac Q="no_0_obj' and (\_. isValidVTableRoot cap' \ cap' = NullCap)" in corres_cross_over_guard) apply clarsimp apply (drule (1) tcb_cap_wp_at[where ref="tcb_cnode_index 1" and Q="\cap. is_valid_vtable_root cap \ cap=Structures_A.NullCap"]) apply (simp add: tcb_cap_cases_def) apply clarsimp apply (clarsimp simp: cte_wp_at_caps_of_state) apply (erule disjE; simp?) apply (clarsimp simp: is_valid_vtable_root_def split: cap.splits arch_cap.splits option.splits pt_type.splits) apply (simp add: isValidVTableRoot_def isVTableRoot_def) apply (rule corres_guard_imp) apply (rule_tac P="valid_vspace_objs and valid_asid_table and pspace_aligned and valid_vmid_table and vmid_inv and pspace_distinct and valid_objs and valid_global_arch_objs and cte_wp_at ((=) cap) thread_root_slot" in corres_assert_gen_asm2) prefer 3 apply assumption apply (case_tac cap; clarsimp simp: isCap_simps catch_throwError intro!: global) apply (rename_tac acap acap') apply (case_tac acap; clarsimp simp: isCap_simps catch_throwError intro!: global) apply (rename_tac pt_t m) apply (case_tac pt_t; clarsimp simp: isCap_simps catch_throwError intro!: global) apply (case_tac m; clarsimp simp: isCap_simps catch_throwError intro!: global) apply (rule corres_guard_imp) apply (rule corres_split_catch [where f=lfr and E'="\_. \"]) apply (rule corres_split_eqrE[OF findVSpaceForASID_corres[OF refl]]) apply (rule whenE_throwError_corres; simp add: lookup_failure_map_def) apply (rule armContextSwitch_corres) apply (wpsimp wp: find_vspace_for_asid_wp findVSpaceForASID_inv hoare_drop_imps)+ apply (rule global, assumption) apply wpsimp+ apply (frule (1) cte_wp_at_valid_objs_valid_cap) apply (clarsimp simp: valid_cap_def mask_def wellformed_mapdata_def) apply (wpsimp wp: get_cap_wp simp: getThreadVSpaceRoot_def)+ apply (auto dest!: tcb_at_cte_at_1) done qed lemma dMo_no_0_obj'[wp]: "doMachineOp f \no_0_obj'\" apply (simp add: doMachineOp_def split_def) apply wp by (simp add: no_0_obj'_def) lemma dMo_riscvKSASIDTable_inv[wp]: "doMachineOp f \\s. P (armKSASIDTable (ksArchState s))\" apply (simp add: doMachineOp_def split_def) apply wp by (clarsimp) lemma dMo_valid_arch_state'[wp]: "\\s. P (valid_arch_state' s)\ doMachineOp f \\_ s. P (valid_arch_state' s)\" apply (simp add: doMachineOp_def split_def) apply wp by (clarsimp) crunches vcpuDisable, vcpuEnable, vcpuSave, vcpuRestore, deleteASID for no_0_obj'[wp]: no_0_obj' (simp: crunch_simps wp: crunch_wps getObject_inv getObject_inv_vcpu loadObject_default_inv) lemma asid_high_bits_of_ucast_ucast[simp]: "asid_high_bits_of (ucast (ucast asid :: machine_word)) = asid_high_bits_of asid" by (simp add: ucast_down_ucast_id is_down) lemma invalidateTLBByASID_corres[corres]: "asid' = ucast asid \ corres dc (pspace_aligned and pspace_distinct and (\s. vspace_for_asid asid s \ None)) \ (invalidate_tlb_by_asid asid) (invalidateTLBByASID asid')" unfolding invalidate_tlb_by_asid_def invalidateTLBByASID_def apply corres (* when vs case .. of *) apply (corres_cases; (solves \rule corres_inst[where P=\ and P'=\], clarsimp\)?) (* when-True case *) apply (clarsimp, corres) apply wpsimp+ done lemma invalidate_vmid_entry_entry_for_asid[wp]: "invalidate_vmid_entry vmid \\s. P (entry_for_asid asid s)\" unfolding invalidate_vmid_entry_def by wpsimp lemma invalidateASIDEntry_corres[corres]: "asid' = ucast asid \ corres dc (pspace_aligned and pspace_distinct and (\s. vspace_for_asid asid s \ None)) \ (invalidate_asid_entry asid) (invalidateASIDEntry asid')" unfolding invalidate_asid_entry_def invalidateASIDEntry_def by (corres simp: vspace_for_asid_def) lemma deleteASID_corres [corres]: assumes "asid' = ucast asid" "pm' = pm" shows "corres dc (invs and K (asid \ 0)) no_0_obj' (delete_asid asid pm) (deleteASID asid' pm')" unfolding delete_asid_def deleteASID_def using assms apply simp apply (corres simp: liftM_def | corres_cases_both)+ apply (simp add: mask_asid_low_bits_ucast_ucast asid_low_bits_of_def ucast_ucast_a is_down asid_pool_relation_def abs_asid_entry_def split: option.splits) apply corres apply (rule ext) apply (clarsimp simp: mask_asid_low_bits_ucast_ucast asid_low_bits_of_def ucast_ucast_a is_down asid_pool_relation_def) apply (erule notE) apply word_eqI_solve apply (corres corres: getCurThread_corres) apply (wpsimp simp: cur_tcb_def[symmetric] wp: set_asid_pool_None_vmid_inv set_asid_pool_vspace_objs_unmap_single) apply (wp getASID_wp)+ apply (rename_tac p pool pool' a b) apply (rule_tac Q="\_ s. invs s \ (\high. asid_table s high = Some p \ vmid_for_asid s (asid_of high (asid_low_bits_of asid)) = None)" in hoare_strengthen_post) apply (wp hoare_vcg_ex_lift invalidate_asid_entry_vmid_for_asid) apply (fastforce simp: asid_pools_at_eq ako_asid_pools_of) apply (wp hoare_drop_imp hoare_vcg_all_lift) apply (wp invalidate_tlb_by_asid_invs hoare_vcg_ex_lift) apply wp apply (clarsimp, wp) apply (wp getASID_wp) apply wp apply (wp hoare_vcg_all_lift hoare_drop_imp) apply (fastforce simp: pool_for_asid_def vspace_for_asid_def entry_for_asid_def word_neq_0_conv entry_for_pool_def in_omonad intro!: pool_for_asid_ap_at) apply simp done lemma valid_arch_state_unmap_strg': "valid_arch_state' s \ valid_arch_state' (s\ksArchState := armKSASIDTable_update (\_. (armKSASIDTable (ksArchState s))(ptr := None)) (ksArchState s)\)" apply (simp add: valid_arch_state'_def valid_asid_table'_def) apply (auto simp: ran_def split: if_split_asm option.splits) done crunch armKSASIDTable_inv[wp]: invalidateASIDEntry "\s. P (armKSASIDTable (ksArchState s))" (wp: getObject_inv crunch_wps simp: loadObject_default_def) lemma is_aligned_asid_low_bits_of_zero: "is_aligned asid asid_low_bits \ asid_low_bits_of asid = 0" apply (simp add: is_aligned_mask word_eq_iff word_size asid_bits_defs asid_bits_of_defs nth_ucast) apply (intro iffI allI; drule_tac x=n in spec; fastforce) done lemma asid_high_bits_of_0[simp]: "asid_high_bits_of 0 = 0" by (simp add: asid_high_bits_of_def) lemma asid_low_bits_of_0[simp]: "asid_low_bits_of 0 = 0" by (simp add: asid_low_bits_of_def) lemma invalidate_asid_entry_asid_pool_doms[wp]: "invalidate_asid_entry asid \\s. P (asid_pools_of s ||> dom)\" unfolding invalidate_asid_entry_def invalidate_asid_def invalidate_vmid_entry_def apply wpsimp apply (fastforce simp: opt_map_def split: option.splits elim!: rsubst[where P=P]) done declare getCurThread_corres[corres] (* FIXME AARCH64: declare at origin *) lemma valid_asid_table_None_upd: "valid_asid_table_2 table pools \ valid_asid_table_2 (table(idx := None)) pools" unfolding valid_asid_table_2_def by (auto simp: ran_def inj_on_def) lemma asid_low_le_mask_asidBits[simp]: "UCAST(asid_low_len \ asid_len) asid_low \ mask asid_low_bits" by (rule ucast_leq_mask, simp add: asid_low_bits_def) lemma ucast_eq_from_zip_asid_low_bits: "\(x, y) \ set (zip [0 .e. mask asid_low_bits] [0 .e. mask asid_low_bits]); is_aligned asid asid_low_bits\ \ ucast asid + y = ucast (asid + x)" for asid :: AARCH64_A.asid apply (clarsimp simp: in_set_zip upto_enum_word_nth) apply (subst add.commute[where a=asid]) apply (drule nat_le_Suc_less_imp)+ apply (simp add: ucast_add_mask_aligned[where n=asid_low_bits] mask_def word_le_nat_alt asid_low_bits_def unat_of_nat_eq ucast_of_nat is_down ucast_of_nat_small) done lemma deleteASIDPool_corres: assumes "base' = ucast base" "ptr' = ptr" shows "corres dc (invs and K (is_aligned base asid_low_bits) and asid_pool_at ptr) (no_0_obj') (delete_asid_pool base ptr) (deleteASIDPool base' ptr)" using assms apply (simp add: delete_asid_pool_def deleteASIDPool_def) apply (corres simp: liftM_def mapM_discarded) apply corres_split (* deal with mapM_x manually *) apply (rule_tac P="\s. invs s \ pool_for_asid base s = Some ptr \ (asid_pools_of s ||> dom) ptr = Some (dom pool) \ is_aligned base asid_low_bits" and P'="no_0_obj'" in corres_mapM_x') (* mapM_x body *) apply corres (* "when" condition *) apply (clarsimp simp: asid_pool_relation_def in_set_zip upto_enum_word_nth) apply (simp add: ucast_of_nat is_down asid_low_bits_def ucast_of_nat_small) apply (rule corres_gen_asm[where F="is_aligned base asid_low_bits"]) apply (corres term_simp: ucast_eq_from_zip_asid_low_bits mask_def) apply clarsimp apply (rename_tac low low' s s' entry) apply (clarsimp simp: vspace_for_asid_def entry_for_asid_def pool_for_asid_def in_omonad asid_high_bits_of_add asid_low_bits_of_add mask_def entry_for_pool_def dest!: set_zip_leftD) apply (rule conjI, fastforce) apply (clarsimp simp flip: word_neq_0_conv mask_2pm1) apply (prop_tac "valid_asid_map s", fastforce) apply (prop_tac "base = 0 \ low = 0") apply (simp add: asid_low_bits_def) apply (subst (asm) word_plus_and_or_coroll, word_eqI, force) apply (fastforce simp: word_or_zero) apply (clarsimp simp: valid_asid_map_def entry_for_asid_def obind_None_eq pool_for_asid_def entry_for_pool_def in_omonad) apply blast apply fastforce apply (wpsimp wp: invalidate_tlb_by_asid_invs)+ apply (simp add: mask_def asid_low_bits_def) apply (corres' \fastforce simp: asid_high_bits_of_def asid_low_bits_def up_ucast_inj_eq state_relation_def arch_state_relation_def\ corres: corres_modify_tivial) (* mapM_x wp conditions *) apply (rename_tac table table' pool pool') apply (rule hoare_strengthen_post) apply (rule_tac I="\s. invs s \ is_aligned base asid_low_bits \ table = asid_table s \ pool_for_asid base s = Some ptr \ (asid_pools_of s ||> dom) ptr = Some (dom pool)" and V="\xs s. \asid_low \ set xs. vmid_for_asid s (asid_of (asid_high_bits_of base) (ucast asid_low)) = None" in mapM_x_inv_wp3) apply (wpsimp wp: invalidate_asid_entry_vmid_for_asid_add hoare_vcg_op_lift invalidate_tlb_by_asid_invs) apply (rule conjI; clarsimp) apply (drule arg_cong[where f=set], drule sym[where t="set xs" for xs]) apply fastforce apply (clarsimp simp: vmid_for_asid_def obind_None_eq) apply (rule ccontr) apply (clarsimp simp: entry_for_pool_def in_omonad pool_for_asid_def) apply (fastforce dest: dom_eq_All) (* mapM_x invariant implies post condition; some manual massaging to avoid massive duplication *) apply (simp (no_asm) del: fun_upd_apply) apply (strengthen invs_vmid_inv invs_valid_global_arch_objs invs_implies invs_valid_vmid_table valid_asid_table_None_upd) (* can't move these into previous strengthen, otherwise will be applied too early *) apply (strengthen invs_arm_asid_table_unmap invs_valid_asid_table) apply (clarsimp simp: o_def) apply (rename_tac asid_low) apply (erule_tac x="ucast asid_low" in allE) apply (fastforce simp: ucast_up_ucast_id is_up) apply (wpsimp wp: mapM_x_wp' getASID_wp)+ apply (fastforce simp: is_aligned_asid_low_bits_of_zero pool_for_asid_def in_omonad) apply (clarsimp simp: is_aligned_asid_low_bits_of_zero) done crunch typ_at' [wp]: setVMRoot "\s. P (typ_at' T p s)" (simp: crunch_simps loadObject_default_def wp: crunch_wps getObject_inv) lemmas setVMRoot_typ_ats [wp] = typ_at_lifts [OF setVMRoot_typ_at'] lemma getObject_PTE_corres'': assumes "p' = p" shows "corres pte_relation' (pte_at pt_t p and pspace_aligned and pspace_distinct) \ (get_pte pt_t p) (getObject p')" using assms getObject_PTE_corres by simp crunches unmapPageTable, unmapPage for aligned'[wp]: "pspace_aligned'" and distinct'[wp]: "pspace_distinct'" and ctes [wp]: "\s. P (ctes_of s)" and typ_at'[wp]: "\s. P (typ_at' T p s)" (simp: crunch_simps wp: crunch_wps getObject_inv loadObject_default_inv) crunches storePTE for no_0_obj'[wp]: no_0_obj' and valid_arch'[wp]: valid_arch_state' and cur_tcb'[wp]: cur_tcb' lemma unmapPageTable_corres: assumes "asid' = ucast asid" "vptr' = vptr" "pt' = pt" shows "corres dc (invs and (\s. vspace_for_asid asid s \ Some pt) and K (0 < asid \ vptr \ user_region)) no_0_obj' (unmap_page_table asid vptr pt) (unmapPageTable asid' vptr' pt')" apply (clarsimp simp: assms unmap_page_table_def unmapPageTable_def ignoreFailure_def const_def) apply (corres corres: findVSpaceForASID_corres lookupPTFromLevel_corres storePTE_corres' corres_returnTT wp: pt_lookup_from_level_wp | corres_cases_left)+ apply (fastforce simp: pte_at_def dest: vspace_for_asid_vs_lookup) apply simp done (* FIXME AARCH64: move (all arches) *) lemma corres_split_strengthen_ftE: "\ corres (ftr \ r') P P' f j; \rv rv'. r' rv rv' \ corres (ftr' \ r) (R rv) (R' rv') (g rv) (k rv'); \Q\ f \R\,-; \Q'\ j \R'\,- \ \ corres (dc \ r) (P and Q) (P' and Q') (f >>=E (\rv. g rv)) (j >>=E (\rv'. k rv'))" apply (rule_tac r'=r' in corres_splitEE) apply (erule corres_rel_imp) apply (case_tac x, auto)[1] apply (rule corres_rel_imp, assumption) apply (case_tac x, auto)[1] apply (simp add: validE_R_def)+ done lemma checkMappingPPtr_corres: "\ pte_relation' pte pte'; pptr' = pptr \ \ corres (lfr \ dc) \ \ (whenE (AARCH64_A.is_PagePTE pte \ pptr_from_pte pte \ pptr) (throwError ExceptionTypes_A.InvalidRoot)) (checkMappingPPtr pptr' pte')" apply (simp add: liftE_bindE checkMappingPPtr_def) apply (cases pte; simp add: pte_base_addr_def pptr_from_pte_def) apply (auto simp: whenE_def unlessE_def corres_returnOk lookup_failure_map_def) done crunch inv[wp]: checkMappingPPtr "P" (wp: crunch_wps loadObject_default_inv simp: crunch_simps) lemmas liftE_get_pte_corres = getObject_PTE_corres[THEN corres_liftE_rel_sum[THEN iffD2]] lemma invalidateTLBByASIDVA_corres[corres]: "\ asid' = ucast asid; vptr' = vptr \ \ corres dc (pspace_aligned and pspace_distinct and (\s. vspace_for_asid asid s \ None)) \ (invalidate_tlb_by_asid_va asid vptr) (invalidateTLBByASIDVA asid' vptr')" unfolding invalidate_tlb_by_asid_va_def invalidateTLBByASIDVA_def by (corres term_simp: wordBits_def word_bits_def word_size | corres_cases_left | rule corres_inst[where P=\ and P'=\], clarsimp)+ crunches lookupPTSlot for inv: "P" lemma unmapPage_corres[corres]: assumes "sz' = sz" "asid' = ucast asid" "vptr' = vptr" "pptr' = pptr" shows "corres dc (invs and K (valid_unmap sz (asid,vptr) \ vptr \ user_region)) (no_0_obj') (unmap_page sz asid vptr pptr) (unmapPage sz' asid' vptr' pptr')" apply (clarsimp simp: assms unmap_page_def unmapPage_def ignoreFailure_def const_def) apply (corres corres: findVSpaceForASID_corres lookupPTSlot_corres[@lift_corres_args] getObject_PTE_corres' checkMappingPPtr_corres corres_returnTT simp: lookup_failure_map_def wp: hoare_drop_imp lookupPTSlot_inv | corres_cases_both)+ apply (clarsimp simp: valid_unmap_def cong: conj_cong) apply (fastforce dest: vspace_for_asid_vs_lookup pt_lookup_slot_vs_lookup_slotI intro: vs_lookup_slot_pte_at) apply simp done definition "mapping_map \ \(pte, r, level) (pte', r'). pte_relation' pte pte' \ r' = r" definition "page_invocation_map pgi pgi' \ case pgi of AARCH64_A.PageMap c slot m \ \c' m'. pgi' = PageMap c' (cte_map slot) m' \ acap_relation c c' \ mapping_map m m' | AARCH64_A.PageUnmap c ptr \ \c'. pgi' = PageUnmap c' (cte_map ptr) \ acap_relation c c' | AARCH64_A.PageGetAddr ptr \ pgi' = PageGetAddr ptr | AARCH64_A.PageFlush type vstart vend pstart vs asid \ pgi' = PageFlush type vstart vend pstart vs (ucast asid)" definition "valid_page_inv' pgi \ case pgi of PageMap cap ptr m \ cte_wp_at' (is_arch_update' (ArchObjectCap cap)) ptr and valid_cap' (ArchObjectCap cap) | PageUnmap cap ptr \ K (isFrameCap cap) and cte_wp_at' (is_arch_update' (ArchObjectCap cap)) ptr and valid_cap' (ArchObjectCap cap) | PageGetAddr ptr \ \ | PageFlush ty start end pstart space asid \ \" lemma message_info_to_data_eqv: "wordFromMessageInfo (message_info_map mi) = message_info_to_data mi" apply (cases mi) apply (simp add: wordFromMessageInfo_def msgLengthBits_def msgExtraCapBits_def msgMaxExtraCaps_def shiftL_nat) done lemma message_info_from_data_eqv: "message_info_map (data_to_message_info rv) = messageInfoFromWord rv" using shiftr_mask_eq[where 'a=64 and n=12] by (auto simp: data_to_message_info_def messageInfoFromWord_def Let_def not_less msgLengthBits_def msgExtraCapBits_def msgMaxExtraCaps_def mask_def shiftL_nat msgMaxLength_def msgLabelBits_def) lemma setMessageInfo_corres: "mi' = message_info_map mi \ corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (set_message_info t mi) (setMessageInfo t mi')" apply (simp add: setMessageInfo_def set_message_info_def) apply (subgoal_tac "wordFromMessageInfo (message_info_map mi) = message_info_to_data mi") apply (simp add: asUser_setRegister_corres msg_info_register_def msgInfoRegister_def) apply (simp add: message_info_to_data_eqv) done lemma set_mi_invs'[wp]: "\invs' and tcb_at' t\ setMessageInfo t a \\x. invs'\" by (simp add: setMessageInfo_def) wp lemma set_mi_tcb' [wp]: "\ tcb_at' t \ setMessageInfo receiver msg \\rv. tcb_at' t\" by (simp add: setMessageInfo_def) wp lemma setMRs_typ_at': "\\s. P (typ_at' T p s)\ setMRs receiver recv_buf mrs \\rv s. P (typ_at' T p s)\" by (simp add: setMRs_def zipWithM_x_mapM split_def, wp crunch_wps) lemmas setMRs_typ_at_lifts[wp] = typ_at_lifts [OF setMRs_typ_at'] lemma set_mrs_invs'[wp]: "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" apply (simp add: setMRs_def) apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| simp add: zipWithM_x_mapM split_def)+ done crunches unmapPage for cte_at'[wp]: "cte_at' p" (wp: crunch_wps simp: crunch_simps) lemma vs_lookup_slot_vspace_for_asidD: "\ vs_lookup_slot level asid vref s = Some (level, slot); level \ max_pt_level; valid_asid_map s \ \ vspace_for_asid asid s \ None" by (fastforce simp: vs_lookup_slot_def vs_lookup_table_def vspace_for_asid_def in_omonad valid_asid_map_def entry_for_asid_def vspace_for_pool_def obind_None_eq simp flip: word_neq_0_conv split: if_split_asm) lemma performPageInvocation_corres: assumes "page_invocation_map pgi pgi'" shows "corres dc (invs and valid_page_inv pgi) (no_0_obj' and valid_page_inv' pgi') (perform_page_invocation pgi) (performPageInvocation pgi')" apply (rule corres_cross_over_guard [where Q="no_0_obj' and valid_page_inv' pgi' and pspace_aligned' and pspace_distinct'"]) apply (fastforce intro!: pspace_aligned_cross pspace_distinct_cross) using assms unfolding perform_page_invocation_def performPageInvocation_def page_invocation_map_def apply (cases pgi; clarsimp simp: valid_page_inv_def mapping_map_def) apply (rename_tac cap ct_slot_ref ct_slot_idx pte slot level cap' pte') apply (simp add: perform_pg_inv_map_def) apply (corres corres: updateCap_same_master | fastforce | corres_cases)+ apply (rule_tac F="arch_cap.is_FrameCap cap" in corres_gen_asm) apply ((corres corres: corres_assert_opt_l simp: arch_cap.is_FrameCap_def | corres_cases)+)[1] apply clarsimp apply (wp get_pte_wp hoare_drop_imp hoare_vcg_op_lift)+ apply (clarsimp simp: invs_valid_objs invs_distinct invs_psp_aligned) apply (clarsimp simp: cte_wp_at_caps_of_state is_arch_update_def is_cap_simps same_ref_def) apply (frule (3) vs_lookup_slot_pte_at) apply (clarsimp simp: cap_master_cap_def split: arch_cap.splits) apply (fastforce dest!: vs_lookup_slot_vspace_for_asidD) apply (clarsimp simp: valid_page_inv'_def cte_wp_at_ctes_of) apply (simp add: perform_pg_inv_unmap_def) apply (corres corres: corres_assert_gen_asm_l simp: liftM_def) apply (corres_cases_both; (solves \rule corres_trivial, clarsimp simp: arch_cap.is_FrameCap_def\)?) apply (corres corres: getSlotCap_corres) apply (rule_tac F="is_frame_cap old_cap" in corres_gen_asm) apply (corres corres: updateCap_same_master simp: is_frame_cap_def arch_cap.is_FrameCap_def update_map_data_def) apply (wp get_cap_wp)+ apply corres_cases_both apply (corres simp: arch_cap.is_FrameCap_def corres: getSlotCap_corres) apply (rule_tac F="is_frame_cap old_cap" in corres_gen_asm) apply (corres corres: updateCap_same_master simp: is_frame_cap_def arch_cap.is_FrameCap_def update_map_data_def) apply (wpsimp wp: get_cap_wp hoare_vcg_op_lift)+ apply (clarsimp simp: invs_valid_objs invs_psp_aligned invs_distinct) apply (clarsimp simp: cte_wp_at_caps_of_state wellformed_pte_def cap_master_cap_simps is_cap_simps update_map_data_def mdata_map_def wellformed_mapdata_def valid_arch_cap_def) apply (clarsimp simp: valid_page_inv'_def cte_wp_at_ctes_of) apply (clarsimp simp: perform_pg_inv_get_addr_def fromPAddr_def) apply (corres corres: setMRs_corres[@lift_corres_args] setMessageInfo_corres[@lift_corres_args] simp: invs_valid_objs invs_psp_aligned invs_distinct) apply (clarsimp simp: perform_flush_def) apply (rename_tac type vstart vend pstart vs asid) apply (case_tac type; simp add: do_flush_def doFlush_def; corres simp: doMachineOp_bind do_machine_op_bind empty_fail_bind) done definition "page_table_invocation_map pti pti' \ case pti of AARCH64_A.PageTableMap cap ptr pte pt_slot level \ \cap' pte'. pti' = PageTableMap cap' (cte_map ptr) pte' pt_slot \ cap_relation (Structures_A.ArchObjectCap cap) cap' \ pte_relation' pte pte' | AARCH64_A.PageTableUnmap cap ptr \ \cap'. pti' = PageTableUnmap cap' (cte_map ptr) \ acap_relation cap cap'" definition "valid_pti' pti \ case pti of PageTableMap cap slot pte pteSlot \ cte_wp_at' (is_arch_update' cap) slot and valid_cap' cap | PageTableUnmap cap slot \ cte_wp_at' (is_arch_update' (ArchObjectCap cap)) slot and valid_cap' (ArchObjectCap cap) and K (isPageTableCap cap)" (* extend with arch rules *) lemmas store_pte_typ_ats[wp] = store_pte_typ_ats abs_atyp_at_lifts[OF store_pte_typ_at] lemma pte_bits_leq_pt_bits[simp, intro!]: "pte_bits \ pt_bits pt_t" by (simp add: bit_simps) lemma pt_bits_le_word_len[simplified, simp, intro!]: "pt_bits pt_t < LENGTH(machine_word_len)" by (simp add: bit_simps) lemma clear_page_table_corres: "corres dc (pspace_aligned and pspace_distinct and pt_at pt_t p) \ (mapM_x (swp (store_pte pt_t) AARCH64_A.InvalidPTE) [p , p + 2^pte_bits .e. p + mask (pt_bits pt_t)]) (mapM_x (swp storePTE AARCH64_H.InvalidPTE) [p , p + 2^pte_bits .e. p + mask (pt_bits pt_t)])" apply (rule_tac F="is_aligned p (pt_bits pt_t)" in corres_req) apply (clarsimp simp: obj_at_def a_type_def) apply (clarsimp split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) apply (drule(1) pspace_alignedD) apply (simp add: table_size_def pt_bits_def) apply (simp add: mask_def flip: p_assoc_help) apply (simp add: upto_enum_step_subtract[where x=p and y="p + 2^pte_bits"] is_aligned_no_overflow upto_enum_step_red[where us=pte_bits, simplified] mapM_x_mapM liftM_def[symmetric]) apply (rule corres_guard_imp, rule_tac r'=dc and S="(=)" and Q="\xs s. \x \ set xs. pte_at pt_t x s \ pspace_aligned s \ pspace_distinct s" and Q'="\_. \" in corres_mapM_list_all2, simp_all) apply (rule corres_guard_imp, rule storePTE_corres) apply (simp add:pte_relation_def)+ apply (wp hoare_vcg_const_Ball_lift | simp)+ apply (simp add: list_all2_refl) apply (clarsimp simp: upto_enum_step_def pte_bits_def word_size_bits_def) apply (erule page_table_pte_atI[simplified shiftl_t2n mult.commute bit_simps, simplified]) apply (simp add: bit_simps word_less_nat_alt word_le_nat_alt unat_of_nat) apply simp done lemmas unmapPageTable_typ_ats[wp] = typ_at_lifts[OF unmapPageTable_typ_at'] lemma performPageTableInvocation_corres: "page_table_invocation_map pti pti' \ corres dc (invs and valid_pti pti) (no_0_obj' and valid_pti' pti') (perform_page_table_invocation pti) (performPageTableInvocation pti')" apply (rule corres_cross_over_guard [where Q="no_0_obj' and valid_pti' pti' and pspace_aligned' and pspace_distinct'"]) apply (fastforce intro!: pspace_aligned_cross pspace_distinct_cross) apply (simp add: perform_page_table_invocation_def performPageTableInvocation_def page_table_invocation_map_def) apply (cases pti) apply (rename_tac cap slot pte pte_slot) apply (clarsimp simp: perform_pt_inv_map_def) apply (rule corres_name_pre) apply (clarsimp simp: valid_pti_def valid_pti'_def split: arch_cap.splits capability.split_asm arch_capability.split_asm) apply (rule corres_guard_imp) apply (rule corres_split[OF updateCap_same_master]) apply simp apply (rule corres_split[OF storePTE_corres]) apply assumption apply (rule corres_machine_op, rule corres_Id; simp) apply wpsimp+ apply (clarsimp simp: cte_wp_at_caps_of_state is_arch_update_def invs_valid_objs invs_psp_aligned invs_distinct) apply (case_tac cap; simp add: is_cap_simps cap_master_cap_simps) apply (clarsimp simp: cte_wp_at_ctes_of valid_pti'_def) apply (clarsimp simp: perform_pt_inv_unmap_def) apply (rename_tac acap a b acap') apply (rule_tac F="AARCH64_A.is_PageTableCap acap" in corres_req; clarsimp) apply (clarsimp simp: valid_pti_def) apply (clarsimp simp: AARCH64_A.is_PageTableCap_def split_def cong: option.case_cong) apply (simp add: case_option_If2 split del: if_split) apply (rule corres_guard_imp) apply (rule corres_split_nor) apply (rule corres_if3) apply (fastforce simp: acap_map_data_def mdata_map_def is_PageTableCap_def) apply (rule corres_split[OF unmapPageTable_corres]) apply (clarsimp simp: mdata_map_def) apply (clarsimp simp: mdata_map_def) apply (rule refl) apply (simp (no_asm) add: p_assoc_help flip: mask_2pm1) apply (rule clear_page_table_corres) apply wp+ apply (rule corres_trivial, simp) apply (simp add: liftM_def) apply (rule corres_split[OF getSlotCap_corres[OF refl]]) apply (rule_tac F="is_pt_cap x" in corres_gen_asm) apply (rule updateCap_same_master) apply (clarsimp simp: is_cap_simps update_map_data_def) apply (wpsimp wp: get_cap_wp mapM_x_wp' hoare_vcg_all_lift hoare_vcg_imp_lift' simp: wellformed_pte_def)+ apply (clarsimp simp: valid_pti_def valid_arch_cap_def cte_wp_at_caps_of_state invs_valid_objs invs_psp_aligned invs_distinct cap_master_cap_simps is_cap_simps update_map_data_def wellformed_mapdata_def) apply (clarsimp simp: valid_pti'_def cte_wp_at_ctes_of) done definition "asid_pool_invocation_map ap \ case ap of asid_pool_invocation.Assign asid p slot \ Assign (ucast asid) p (cte_map slot)" definition "valid_apinv' ap \ case ap of Assign asid p slot \ cte_wp_at' (isArchCap isPageTableCap o cteCap) slot and K (0 < asid \ asid_wf asid)" definition "valid_vcpuinv' vi \ case vi of VCPUSetTCB v t \ vcpu_at' v and ex_nonz_cap_to' v and ex_nonz_cap_to' t | VCPUInjectIRQ v n q \ \ | VCPUReadRegister v rg \ \ | VCPUWriteRegister v _ _ \ \ | VCPUAckVPPI v _ \ \" lemma performASIDPoolInvocation_corres[corres]: "\ ap' = asid_pool_invocation_map ap \ \ corres dc (valid_objs and pspace_aligned and pspace_distinct and valid_arch_state and valid_apinv ap) (no_0_obj' and valid_apinv' ap') (perform_asid_pool_invocation ap) (performASIDPoolInvocation ap')" apply (clarsimp simp: perform_asid_pool_invocation_def performASIDPoolInvocation_def) apply (cases ap, simp add: asid_pool_invocation_map_def) apply (corres corres: getSlotCap_corres corres_assert_gen_asm_l updateCap_same_master simp: liftM_def store_asid_pool_entry_def term_simp: cap.is_ArchObjectCap_def arch_cap.is_PageTableCap_def update_map_data_def) apply (fastforce simp: asid_pool_relation_def abs_asid_entry_def cap.is_ArchObjectCap_def arch_cap.is_PageTableCap_def inv_def ucast_up_inj) apply (wpsimp wp: set_cap_typ_at hoare_drop_imp get_cap_wp)+ apply (clarsimp simp: valid_apinv_def cte_wp_at_caps_of_state cap_master_cap_simps is_cap_simps arch_cap.is_PageTableCap_def is_vsroot_cap_def update_map_data_def in_omonad) apply (drule (1) caps_of_state_valid_cap) apply (simp add: valid_cap_def obj_at_def) apply (clarsimp simp: valid_apinv'_def cte_wp_at_ctes_of) apply (fastforce intro!: pspace_aligned_cross pspace_distinct_cross) done crunches doMachineOp for arch[wp]: "\s. P (ksArchState s)" and irq_node'[wp]: "\s. P (irq_node' s)" and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" and ksInterruptState[wp]: "\s. P (ksInterruptState s)" and cur'[wp]: "\s. P (ksCurThread s)" and cteCaps_of[wp]: "\s. P (cteCaps_of s)" and dmo_global_refs'[wp]: "\s. P (global_refs' s)" and ksPSpace[wp]: "\s. P (ksPSpace s)" and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" crunches vcpuSave, vcpuDisable, vcpuEnable, vcpuRestore for obj_at'_no_vcpu[wp]: "\s. P (obj_at' (P' :: ('a :: no_vcpu) \ bool) t s)" (simp: crunch_simps wp: crunch_wps) lemma vcpuSwitch_obj_at'_no_vcpu[wp]: "vcpuSwitch param_a \\s. P (obj_at' (P' :: ('a :: no_vcpu) \ bool) t s)\" by (wpsimp simp: vcpuSwitch_def modifyArchState_def | assumption)+ lemma dmo_setVSpaceRoot_invs'[wp]: "doMachineOp (setVSpaceRoot r a) \invs'\" by (wp dmo_invs_lift') lemma dmo_setVSpaceRoot_irq_masks[wp]: "doMachineOp (setVSpaceRoot r a) \\s. P (irq_masks (ksMachineState s))\" unfolding doMachineOp_def apply wpsimp apply (drule use_valid, rule setVSpaceRoot_irq_masks; assumption) done lemma dmo_setVSpaceRoot_memory[wp]: "doMachineOp (setVSpaceRoot r a) \\s. P (underlying_memory (ksMachineState s))\" unfolding doMachineOp_def apply wpsimp apply (drule use_valid, rule setVSpaceRoot_underlying_memory_inv; assumption) done lemma dmo_setVSpaceRoot_invs_no_cicd'[wp]: "doMachineOp (setVSpaceRoot r a) \invs_no_cicd'\" by (wp dmo_invs_no_cicd_lift') lemma getObject_tcb_hyp_sym_refs: "\\s. sym_refs (state_hyp_refs_of' s)\ getObject p \\rv. case atcbVCPUPtr (tcbArch rv) of None \ \_. True | Some x \ ko_wp_at' (is_vcpu' and hyp_live') x\" apply (wpsimp wp: getObject_tcb_wp) apply (clarsimp simp: typ_at_tcb'[symmetric] typ_at'_def ko_wp_at'_def[of _ p] split: option.splits) apply (case_tac ko; simp) apply (rename_tac tcb) apply (rule_tac x=tcb in exI; rule conjI, clarsimp simp: obj_at'_def) apply (clarsimp, rule context_conjI, clarsimp simp: obj_at'_def) apply (drule ko_at_state_hyp_refs_ofD') apply (simp add: hyp_refs_of'_def sym_refs_def) apply (erule_tac x=p in allE, simp) apply (drule state_hyp_refs_of'_elemD) apply (clarsimp simp: hyp_refs_of_rev') apply (simp add: ko_wp_at'_def, erule exE, clarsimp simp: is_vcpu'_def hyp_live'_def arch_live'_def) done lemma setASIDPool_valid_objs[wp]: "setObject p (ap::asidpool) \valid_objs'\" apply (wp setObject_valid_objs'[where P=\]) apply (clarsimp simp: updateObject_default_def in_monad valid_obj'_def) apply simp done lemma setASIDPool_valid_mdb[wp]: "setObject p (ap::asidpool) \valid_mdb'\" by (simp add: valid_mdb'_def) wp lemma setASIDPool_nosch[wp]: "setObject p (ap::asidpool) \\s. P (ksSchedulerAction s)\" by (wp setObject_nosch updateObject_default_inv|simp)+ lemma setASIDPool_ksQ[wp]: "setObject p (ap::asidpool) \\s. P (ksReadyQueues s)\" by (wp setObject_qs updateObject_default_inv|simp)+ lemma setASIDPool_inQ[wp]: "setObject ptr (ap::asidpool) \\s. P (obj_at' (inQ d p) t s)\" apply (simp add: obj_at'_real_def) apply (wpsimp wp: setObject_ko_wp_at simp: objBits_simps) apply (simp add: pageBits_def) apply simp apply (clarsimp simp: obj_at'_def ko_wp_at'_def) done lemma setASIDPool_qsL1[wp]: "setObject p (ap::asidpool) \\s. P (ksReadyQueuesL1Bitmap s)\" by (wp setObject_qs updateObject_default_inv|simp)+ lemma setASIDPool_qsL2[wp]: "setObject p (ap::asidpool) \\s. P (ksReadyQueuesL2Bitmap s)\" by (wp setObject_qs updateObject_default_inv|simp)+ lemma setASIDPool_tcb_obj_at'[wp]: "\obj_at' (P::tcb \ bool) t\ setObject p (ap::asidpool) \\_. obj_at' P t\" apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma setASIDPool_valid_queues[wp]: "setObject p (ap::asidpool) \valid_queues\" by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ lemma setASIDPool_valid_queues'[wp]: "setObject p (ap::asidpool) \valid_queues'\" by (wp valid_queues_lift') lemma setASIDPool_state_refs'[wp]: "setObject p (ap::asidpool) \\s. P (state_refs_of' s)\" apply (clarsimp simp: setObject_def valid_def in_monad split_def updateObject_default_def objBits_simps in_magnitude_check state_refs_of'_def ps_clear_upd elim!: rsubst[where P=P] del: ext intro!: ext split del: if_split cong: option.case_cong if_cong) apply (simp split: option.split) done lemma setASIDPool_state_hyp_refs'[wp]: "setObject p (ap::asidpool) \\s. P (state_hyp_refs_of' s)\" apply (clarsimp simp: setObject_def valid_def in_monad split_def updateObject_default_def objBits_simps in_magnitude_check state_hyp_refs_of'_def ps_clear_upd elim!: rsubst[where P=P] del: ext intro!: ext split del: if_split cong: option.case_cong if_cong) apply (simp split: option.split) done lemma setASIDPool_iflive[wp]: "setObject p (ap::asidpool) \if_live_then_nonz_cap'\" apply (rule hoare_pre) apply (rule setObject_iflive' [where P=\], simp) apply (simp add: objBits_simps) apply (auto simp: updateObject_default_def in_monad bit_simps live'_def hyp_live'_def arch_live'_def) done lemma setASIDPool_ksInt[wp]: "setObject p (ap::asidpool) \\s. P (ksInterruptState s)\" by (wp setObject_ksInterrupt updateObject_default_inv|simp)+ lemma setASIDPool_ifunsafe[wp]: "setObject p (ap::asidpool) \if_unsafe_then_cap'\" apply (rule hoare_pre) apply (rule setObject_ifunsafe' [where P=\], simp) apply (auto simp: updateObject_default_def in_monad)[2] apply wp apply simp done lemma setASIDPool_it'[wp]: "setObject p (ap::asidpool) \\s. P (ksIdleThread s)\" by (wp setObject_it updateObject_default_inv|simp)+ lemma setASIDPool_pred_tcb_at'[wp]: "setObject p (ap::asidpool) \pred_tcb_at' proj P t\" apply (simp add: pred_tcb_at'_def) apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma setASIDPool_idle[wp]: "setObject p (ap::asidpool) \valid_idle'\" unfolding valid_idle'_def by (rule hoare_lift_Pf [where f="ksIdleThread"]; wp) lemma setASIDPool_irq_states'[wp]: "setObject p (ap::asidpool) \valid_irq_states'\" apply (rule hoare_pre) apply (rule hoare_use_eq [where f=ksInterruptState, OF setObject_ksInterrupt]) apply (simp, rule updateObject_default_inv) apply (rule hoare_use_eq [where f=ksMachineState, OF setObject_ksMachine]) apply (simp, rule updateObject_default_inv) apply wp apply assumption done lemma setASIDPool_vms'[wp]: "setObject p (ap::asidpool) \valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) apply (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv hoare_vcg_all_lift hoare_vcg_disj_lift | simp)+ done lemma setASIDPool_ct_not_inQ[wp]: "setObject p (ap::asidpool) \ct_not_inQ\" apply (rule ct_not_inQ_lift [OF setObject_nosch]) apply (simp add: updateObject_default_def | wp)+ apply (rule hoare_weaken_pre) apply (wps setObject_ASID_ct) apply (rule obj_at_setObject2) apply (clarsimp simp: updateObject_default_def in_monad)+ done lemma setObject_asidpool_cur_domain[wp]: "setObject p (ap::asidpool) \\s. P (ksCurDomain s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma setObject_asidpool_ksDomSchedule[wp]: "setObject p (ap::asidpool) \\s. P (ksDomSchedule s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma setObject_asidpool_tcb_in_cur_domain'[wp]: "setObject p (ap::asidpool) \tcb_in_cur_domain' t\" by (wp tcb_in_cur_domain'_lift) lemma setObject_asidpool_ct_idle_or_in_cur_domain'[wp]: "setObject p (ap::asidpool) \ct_idle_or_in_cur_domain'\" by (wp hoare_vcg_disj_lift ct_idle_or_in_cur_domain'_lift) lemma setObject_ap_ksDomScheduleIdx[wp]: "setObject p (ap::asidpool) \\s. P (ksDomScheduleIdx s)\" by (wpsimp wp: updateObject_default_inv simp: setObject_def) lemma setASIDPool_invs[wp]: "setObject p (ap::asidpool) \invs'\" apply (simp add: invs'_def valid_state'_def valid_pspace'_def) apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift updateObject_default_inv | simp add: cteCaps_of_def | rule setObject_ksPSpace_only)+ apply (clarsimp simp: o_def) done lemma doMachineOp_invalidateTranslationASID_invs'[wp]: "doMachineOp (invalidateTranslationASID vmid) \invs'\" unfolding invalidateTranslationASID_def by (wp dmo_machine_op_lift_invs') crunches getVMID, armContextSwitch, setGlobalUserVSpace for invs'[wp]: invs' (ignore: doMachineOp wp: getASID_wp crunch_wps) lemma setVMRoot_invs'[wp]: "setVMRoot p \invs'\" unfolding setVMRoot_def getThreadVSpaceRoot_def by (wpsimp wp: whenE_wp findVSpaceForASID_vs_at_wp hoare_drop_imps hoare_vcg_ex_lift hoare_vcg_all_lift) lemma setASIDPool_invs_no_cicd'[wp]: "setObject p (ap::asidpool) \invs_no_cicd'\" apply (simp add: invs_no_cicd'_def valid_state'_def valid_pspace'_def) apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift updateObject_default_inv | simp add: cteCaps_of_def | rule setObject_ksPSpace_only)+ apply (clarsimp simp: o_def) done lemma invalidateTranslationASID_invs_no_cicd'[wp]: "doMachineOp (invalidateTranslationASID asid) \invs_no_cicd'\" by (wp dmo_invs_no_cicd_lift') crunches getVMID, armContextSwitch, setGlobalUserVSpace for invs_no_cicd'[wp]: "invs_no_cicd'" (ignore: doMachineOp wp: getASID_wp crunch_wps) lemma setVMRoot_invs_no_cicd': "setVMRoot p \invs_no_cicd'\" unfolding setVMRoot_def getThreadVSpaceRoot_def by (wpsimp wp: whenE_wp findVSpaceForASID_vs_at_wp hoare_drop_imps hoare_vcg_ex_lift hoare_vcg_all_lift) crunch nosch [wp]: setVMRoot "\s. P (ksSchedulerAction s)" (wp: crunch_wps getObject_inv setObject_nosch simp: crunch_simps loadObject_default_def updateObject_default_def) crunch it' [wp]: deleteASIDPool "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def updateObject_default_def wp: getObject_inv mapM_wp' crunch_wps) crunch it' [wp]: storePTE "\s. P (ksIdleThread s)" (simp: crunch_simps updateObject_default_def wp: setObject_idle') crunch it' [wp]: deleteASID "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def updateObject_default_def wp: getObject_inv) crunch typ_at' [wp]: performPageTableInvocation "\s. P (typ_at' T p s)" (wp: crunch_wps) crunch typ_at' [wp]: performPageInvocation "\s. P (typ_at' T p s)" (wp: crunch_wps simp: crunch_simps) lemma performASIDPoolInvocation_typ_at' [wp]: "\\s. P (typ_at' T p s)\ performASIDPoolInvocation api \\_ s. P (typ_at' T p s)\" by (wpsimp simp: performASIDPoolInvocation_def wp: getASID_wp hoare_vcg_imp_lift[where P'=\, simplified]) lemmas performPageTableInvocation_typ_ats' [wp] = typ_at_lifts [OF performPageTableInvocation_typ_at'] lemmas performPageInvocation_typ_ats' [wp] = typ_at_lifts [OF performPageInvocation_typ_at'] lemmas performASIDPoolInvocation_typ_ats' [wp] = typ_at_lifts [OF performASIDPoolInvocation_typ_at'] lemma storePTE_pred_tcb_at' [wp]: "storePTE p pte \pred_tcb_at' proj P t\" apply (simp add: storePTE_def pred_tcb_at'_def) apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma storePTE_valid_mdb [wp]: "\valid_mdb'\ storePTE p pte \\rv. valid_mdb'\" by (simp add: valid_mdb'_def) wp crunch nosch [wp]: storePTE "\s. P (ksSchedulerAction s)" (simp: updateObject_default_def ignore_del: setObject) crunch ksQ [wp]: storePTE "\s. P (ksReadyQueues s)" (simp: updateObject_default_def) lemma storePTE_inQ[wp]: "\\s. P (obj_at' (inQ d p) t s)\ storePTE ptr pte \\rv s. P (obj_at' (inQ d p) t s)\" apply (simp add: obj_at'_real_def storePTE_def) apply (wp setObject_ko_wp_at | simp add: objBits_simps)+ apply (clarsimp simp: obj_at'_def ko_wp_at'_def) done crunch norqL1[wp]: storePTE "\s. P (ksReadyQueuesL1Bitmap s)" (simp: updateObject_default_def) crunch norqL2[wp]: storePTE "\s. P (ksReadyQueuesL2Bitmap s)" (simp: updateObject_default_def) lemma storePTE_valid_queues' [wp]: "\valid_queues'\ storePTE p pte \\_. valid_queues'\" by (wp valid_queues_lift') lemma storePTE_iflive [wp]: "\if_live_then_nonz_cap'\ storePTE p pte \\rv. if_live_then_nonz_cap'\" apply (simp add: storePTE_def) apply (rule hoare_pre) apply (rule setObject_iflive' [where P=\], simp) apply (simp add: objBits_simps) apply (auto simp: updateObject_default_def in_monad live'_def hyp_live'_def arch_live'_def) done lemma setObject_pte_ksInt [wp]: "\\s. P (ksInterruptState s)\ setObject p (pte::pte) \\_. \s. P (ksInterruptState s)\" by (wp setObject_ksInterrupt updateObject_default_inv|simp)+ crunch ksInterruptState [wp]: storePTE "\s. P (ksInterruptState s)" lemma storePTE_ifunsafe [wp]: "\if_unsafe_then_cap'\ storePTE p pte \\rv. if_unsafe_then_cap'\" apply (simp add: storePTE_def) apply (rule hoare_pre) apply (rule setObject_ifunsafe' [where P=\], simp) apply (auto simp: updateObject_default_def in_monad)[2] apply wp apply simp done method valid_idle'_setObject uses simp = simp add: valid_idle'_def, rule hoare_lift_Pf [where f="ksIdleThread"]; wpsimp?; (wpsimp wp: obj_at_setObject2[where P="idle_tcb'", simplified] hoare_drop_imp simp: simp | clarsimp dest!: updateObject_default_result)+ lemma storePTE_idle [wp]: "\valid_idle'\ storePTE p pte \\rv. valid_idle'\" by (valid_idle'_setObject simp: storePTE_def) crunch arch' [wp]: storePTE "\s. P (ksArchState s)" crunch cur' [wp]: storePTE "\s. P (ksCurThread s)" lemma storePTE_irq_states' [wp]: "\valid_irq_states'\ storePTE pte p \\_. valid_irq_states'\" apply (simp add: storePTE_def) apply (wpsimp wp: valid_irq_states_lift' dmo_lift' no_irq_storeWord setObject_ksMachine updateObject_default_inv) done lemma storePTE_vms'[wp]: "\valid_machine_state'\ storePTE p pte \\_. valid_machine_state'\" apply (simp add: storePTE_def valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) apply (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv hoare_vcg_all_lift hoare_vcg_disj_lift | simp)+ done crunch pspace_domain_valid[wp]: storePTE "pspace_domain_valid" lemma storePTE_ct_not_inQ[wp]: "\ct_not_inQ\ storePTE p pte \\_. ct_not_inQ\" apply (rule ct_not_inQ_lift [OF storePTE_nosch]) apply (simp add: storePTE_def) apply (wp_pre, wps) apply (rule obj_at_setObject2) apply (clarsimp simp: updateObject_default_def in_monad)+ done lemma setObject_pte_cur_domain[wp]: "\\s. P (ksCurDomain s)\ setObject t (v::pte) \\rv s. P (ksCurDomain s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma setObject_pte_ksDomSchedule[wp]: "\\s. P (ksDomSchedule s)\ setObject t (v::pte) \\rv s. P (ksDomSchedule s)\" apply (simp add: setObject_def split_def) apply (wp updateObject_default_inv | simp)+ done lemma storePTE_cur_domain[wp]: "\\s. P (ksCurDomain s)\ storePTE p pte \\rv s. P (ksCurDomain s)\" by (simp add: storePTE_def) wp lemma storePTE_ksDomSchedule[wp]: "\\s. P (ksDomSchedule s)\ storePTE p pte \\rv s. P (ksDomSchedule s)\" by (simp add: storePTE_def) wp lemma storePTE_tcb_obj_at'[wp]: "\obj_at' (P::tcb \ bool) t\ storePTE p pte \\_. obj_at' P t\" apply (simp add: storePTE_def) apply (rule obj_at_setObject2) apply (clarsimp simp add: updateObject_default_def in_monad) done lemma storePTE_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t\ storePTE p pte \\_. tcb_in_cur_domain' t\" by (wp tcb_in_cur_domain'_lift) lemma storePTE_ct_idle_or_in_cur_domain'[wp]: "\ct_idle_or_in_cur_domain'\ storePTE p pte \\_. ct_idle_or_in_cur_domain'\" by (wp ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift) lemma setObject_pte_ksDomScheduleIdx [wp]: "\\s. P (ksDomScheduleIdx s)\ setObject p (pte::pte) \\_. \s. P (ksDomScheduleIdx s)\" by (wp updateObject_default_inv|simp add:setObject_def | wpc)+ crunches storePTE for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" (wp: setObject_ksPSpace_only updateObject_default_inv) lemma storePTE_valid_objs[wp]: "storePTE p pte \valid_objs'\" apply (simp add: storePTE_def doMachineOp_def split_def) apply (rule hoare_pre, rule setObject_valid_objs'[where P=\]) apply (clarsimp simp: updateObject_default_def in_monad valid_obj'_def) apply simp done lemma storePTE_valid_queues [wp]: "\Invariants_H.valid_queues\ storePTE p pde \\_. Invariants_H.valid_queues\" by (wp valid_queues_lift | simp add: pred_tcb_at'_def)+ lemma storePTE_ko_wp_vcpu_at'[wp]: "storePTE p pde \\s. P (ko_wp_at' (is_vcpu' and hyp_live') p' s)\" apply (clarsimp simp: storePTE_def) apply (wpsimp wp: hoare_drop_imps setObject_ko_wp_at simp: objBits_simps archObjSize_def) apply (auto simp: bit_simps ko_wp_at'_def obj_at'_def is_vcpu'_def)+ done lemma storePTE_invs[wp]: "storePTE p pte \invs'\" unfolding invs'_def valid_state'_def valid_pspace'_def by (wpsimp wp: sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_irq_handlers_lift'' untyped_ranges_zero_lift simp: cteCaps_of_def o_def) crunch cte_wp_at'[wp]: unmapPageTable "\s. P (cte_wp_at' P' p s)" (wp: crunch_wps simp: crunch_simps) lemmas storePTE_Invalid_invs = storePTE_invs[where pte=InvalidPTE, simplified] crunches unmapPageTable, invalidateTLBByASIDVA for invs'[wp]: "invs'" (ignore: doMachineOp wp: storePTE_Invalid_invs mapM_wp' crunch_wps dmo_invs_lift' simp: crunch_simps if_apply_def2) lemma perform_pti_invs [wp]: "\invs' and valid_pti' pti\ performPageTableInvocation pti \\_. invs'\" apply (clarsimp simp: performPageTableInvocation_def getSlotCap_def valid_pti'_def split: page_table_invocation.splits) apply (intro conjI allI impI; wpsimp wp: arch_update_updateCap_invs getCTE_wp' mapM_x_wp' hoare_vcg_all_lift hoare_vcg_imp_lift' dmo_invs_lift') apply (auto simp: cte_wp_at_ctes_of is_arch_update'_def isCap_simps valid_cap'_def capAligned_def) done crunches unmapPage for cte_wp_at': "\s. P (cte_wp_at' P' p s)" (wp: crunch_wps lookupPTSlotFromLevel_inv simp: crunch_simps) lemmas unmapPage_typ_ats [wp] = typ_at_lifts [OF unmapPage_typ_at'] lemma unmapPage_invs' [wp]: "unmapPage sz asid vptr pptr \invs'\" unfolding unmapPage_def by (wpsimp wp: lookupPTSlot_inv hoare_drop_imp hoare_vcg_all_lift dmo_invs_lift') lemma dmo_doFlush_invs'[wp]: "doMachineOp (doFlush flushOp vstart vend pstart) \invs'\" unfolding doFlush_def cleanCacheRange_RAM_def invalidateCacheRange_RAM_def branchFlushRange_def cleanInvalidateCacheRange_RAM_def cleanCacheRange_PoU_def invalidateCacheRange_I_def by (cases flushOp; wpsimp wp: dmo_machine_op_lift_invs' simp: doMachineOp_bind empty_fail_bind) lemma perform_page_invs [wp]: "\invs' and valid_page_inv' pt\ performPageInvocation pt \\_. invs'\" supply if_split[split del] apply (simp add: performPageInvocation_def) apply (cases pt) (* FIXME AARCH64: clean up this proof, not clear why all, fwd_all or solve_emerging don't work *) apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_const_imp_lift arch_update_updateCap_invs unmapPage_cte_wp_at' getSlotCap_wp dmo_invs_lift' simp: valid_page_inv'_def is_arch_update'_def if_apply_def2) apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_const_imp_lift arch_update_updateCap_invs unmapPage_cte_wp_at' getSlotCap_wp dmo_invs_lift' simp: valid_page_inv'_def is_arch_update'_def if_apply_def2) prefer 2 apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_const_imp_lift arch_update_updateCap_invs unmapPage_cte_wp_at' getSlotCap_wp simp: valid_page_inv'_def is_arch_update'_def if_apply_def2) apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_const_imp_lift arch_update_updateCap_invs unmapPage_cte_wp_at' getSlotCap_wp dmo_invs_lift' simp: valid_page_inv'_def is_arch_update'_def if_apply_def2) apply (clarsimp simp: cte_wp_at_ctes_of valid_page_inv'_def is_arch_update'_def isCap_simps valid_cap'_def capAligned_def split: option.splits)+ done lemma setObject_cte_obj_at_ap': shows "\\s. P' (obj_at' (P :: asidpool \ bool) p s)\ setObject c (cte::cte) \\_ s. P' (obj_at' P p s)\" apply (clarsimp simp: setObject_def in_monad split_def valid_def lookupAround2_char1 obj_at'_def ps_clear_upd split del: if_split) apply (clarsimp elim!: rsubst[where P=P']) apply (clarsimp simp: updateObject_cte in_monad objBits_simps tcbCTableSlot_def tcbVTableSlot_def typeError_def split: if_split_asm Structures_H.kernel_object.split_asm) done lemma updateCap_ko_at_ap_inv'[wp]: "\\s. P (ko_at' (ko::asidpool) p s )\ updateCap a b \\rv s. P ( ko_at' ko p s)\" by (wpsimp simp: updateCap_def setCTE_def wp: setObject_cte_obj_at_ap') lemma storePTE_asid_pool_obj_at'[wp]: "storePTE p pte \\s. P (obj_at' (P'::asidpool \ bool) t s)\" apply (simp add: storePTE_def) apply (clarsimp simp: setObject_def in_monad split_def valid_def lookupAround2_char1 obj_at'_def ps_clear_upd split del: if_split) apply (clarsimp elim!: rsubst[where P=P]) apply (clarsimp simp: updateObject_default_def in_monad) done lemma perform_aci_invs [wp]: "\invs' and valid_apinv' api\ performASIDPoolInvocation api \\_. invs'\" apply (clarsimp simp: performASIDPoolInvocation_def split: asidpool_invocation.splits) apply (wpsimp wp: arch_update_updateCap_invs getASID_wp getSlotCap_wp hoare_vcg_all_lift hoare_vcg_imp_lift') apply (clarsimp simp: valid_apinv'_def cte_wp_at_ctes_of) apply (case_tac cte, clarsimp) apply (drule ctes_of_valid_cap', fastforce) apply (clarsimp simp: valid_cap'_def capAligned_def is_arch_update'_def isCap_simps wellformed_mapdata'_def) done end end