diff --git a/proof/ROOT b/proof/ROOT index 1fd4f30109..77576172f7 100644 --- a/proof/ROOT +++ b/proof/ROOT @@ -159,8 +159,7 @@ session InfoFlowC in "infoflow/refine" = InfoFlowCBase + directories "$L4V_ARCH" theories - "Noninterference_Refinement" - "Example_Valid_StateH" + "InfoFlowC_Image_Toplevel" (* * capDL diff --git a/proof/access-control/AARCH64/ArchAccess.thy b/proof/access-control/AARCH64/ArchAccess.thy index da7ad0d1a5..4fe9a78063 100644 --- a/proof/access-control/AARCH64/ArchAccess.thy +++ b/proof/access-control/AARCH64/ArchAccess.thy @@ -133,8 +133,8 @@ where | (Some vcpu, None) \ Some (vcpu_mask n vcpu) \ \No current VCPU\ | (Some vcpu, Some enabled) \ Some (vcpu_mask n (vcpu\vcpu_regs := \reg. if vcpuRegSavedWhenDisabled reg \ \enabled - then vcpu_regs vcpu reg \ \Register saved when VCPU disabled\ - else vcpu_regs vst reg, + then vcpu_regs vcpu reg \ \Register saved when VCPU disabled\ + else vcpu_regs vst reg, vcpu_vgic := (vcpu_vgic vcpu) \vgic_hcr := if \enabled then vgic_hcr (vcpu_vgic vcpu) \ \Saved when VCPU disabled\ @@ -143,8 +143,18 @@ where vgic_apr := vgic_apr (vcpu_vgic vst), vgic_lr := vgic_lr (vcpu_vgic vst)\\))" +(* A vcpu's vgic_lr field is a total function from nats to virqs, with the domain restricted only + in practice via the arm_gicvcpu_numlistregs parameter. To establish true equivalence between + vcpus in the InfoFlow proofs, we prove here that these out-of-bounds registers aren't touched. *) +definition vcpu_extra_lrs :: "nat \ vcpu option \ (nat \ virq)" where + "vcpu_extra_lrs n vopt \ + case vopt of + None \ None + | Some vcpu \ Some (\r. if r \ n then vgic_lr (vcpu_vgic vcpu) r else undefined)" + definition vcpu_integrity where "vcpu_integrity hv hv' cv cv' n n' vopt vopt' \ + vcpu_extra_lrs n vopt = vcpu_extra_lrs n' vopt' \ vcpu_of_state hv cv n vopt = vcpu_of_state hv' cv' n' vopt'" definition integrity_hyp_2 :: diff --git a/proof/access-control/AARCH64/ArchAccess_AC.thy b/proof/access-control/AARCH64/ArchAccess_AC.thy index 6ad2103366..8fd790ddc2 100644 --- a/proof/access-control/AARCH64/ArchAccess_AC.thy +++ b/proof/access-control/AARCH64/ArchAccess_AC.thy @@ -333,7 +333,7 @@ lemma integrity_hyp_ao_upd: "\ ao p = Some ako; vcpu_of ako = None; vcpu_of ako' = None; integrity_hyp_2 aag subjects x ms ms' as as' ao ao' \ \ integrity_hyp_2 aag subjects x ms ms' as as' ao (ao'(p \ ako')) " - unfolding integrity_hyp_def vcpu_integrity_def vcpu_of_state_def opt_map_def + unfolding integrity_hyp_def vcpu_integrity_def vcpu_extra_lrs_def vcpu_of_state_def opt_map_def by (case_tac "x = p"; clarsimp; auto split: option.splits)+ end diff --git a/proof/access-control/AARCH64/ArchArch_AC.thy b/proof/access-control/AARCH64/ArchArch_AC.thy index 83ce529dea..a03e5341c0 100644 --- a/proof/access-control/AARCH64/ArchArch_AC.thy +++ b/proof/access-control/AARCH64/ArchArch_AC.thy @@ -2164,13 +2164,57 @@ lemma vcpu_proj_arch_state_update[simp]: crunch vcpu_switch for arm_gicvcpu_numlistregs[wp]: "\s. P (arm_gicvcpu_numlistregs (arch_state s))" +lemma vcpu_update_extra_lrs[wp]: + "\\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x)) \ + (\v r. arm_gicvcpu_numlistregs (arch_state s) \ r + \ vgic_lr (vcpu_vgic (f v)) r = vgic_lr (vcpu_vgic v) r)\ + vcpu_update vr f + \\_ s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))\" + unfolding vcpu_update_def + apply (wpsimp wp: set_vcpu_wp get_vcpu_wp) + apply (erule_tac x=v in allE) + apply (erule_tac P=P in rsubst) + apply (auto intro!: ext simp: vcpu_extra_lrs_def) + done + +crunch vcpu_save_reg, vcpu_save_reg_range, save_virt_timer + for extra_lrs[wp]: "\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))" + (wp: mapM_x_wp) + +lemma vgic_update_extra_lrs[wp]: + "\\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x)) \ + (\v r. arm_gicvcpu_numlistregs (arch_state s) \ r \ vgic_lr (f v) r = vgic_lr v r)\ + vgic_update vr f + \\_ s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))\" + unfolding vgic_update_def by wpsimp + +lemma vgic_update_lr_extra_lrs[wp]: + "\\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x)) \ + r < arm_gicvcpu_numlistregs (arch_state s)\ + vgic_update_lr vr r irq + \\_ s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))\" + unfolding vgic_update_lr_def by wpsimp + +lemma vcpu_save_extra_lrs[wp]: + "vcpu_save vr \\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))\" + by (wpsimp simp: vcpu_save_def + | rule hoare_strengthen_post, + rule_tac P="\s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x)) \ + num_list_regs = arm_gicvcpu_numlistregs (arch_state s)" + and Q="\r s. r < num_list_regs" and xs="[0..s. P (vcpu_extra_lrs (arm_gicvcpu_numlistregs (arch_state s)) (vcpus_of s x))" + (wp: mapM_x_wp) + lemma vcpu_switch_integrity_hyp[wp]: "\integrity_hyp aag subjects x st and valid_arch_state\ vcpu_switch vr \\_. integrity_hyp aag subjects x st\" unfolding integrity_hyp_def vcpu_integrity_def vcpu_switch_def vcpu_proj_of_state supply if_split[split del] if_split[where P="\v. _ = v", simp] - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' | wp dmo_lift_vcpu_proj)+ + apply (wpsimp wp: dmo_lift_vcpu_proj hoare_vcg_all_lift hoare_vcg_imp_lift') apply (auto simp: insert_commute cur_vcpu_of_def split: if_splits) done @@ -2221,11 +2265,15 @@ lemma vcpu_flush_integrity_hyp[wp]: vcpu_flush \\_. integrity_hyp aag subjects x st\" unfolding integrity_hyp_def vcpu_integrity_def vcpu_flush_def vcpu_proj_of_state + apply (rule hoare_weaken_pre) + apply (rule hoare_vcg_conj_lift, solves wpsimp) + apply (rule hoare_vcg_imp_lift, solves wpsimp) + apply (rule hoare_vcg_conj_lift, solves wpsimp) supply if_split[split del] if_split[where P="\v. _ = v", simp] apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_pre_cont[where f=vcpu_invalidate_active and P="\_ s. cur_vcpu_of s x = Some _"] | strengthen None_Some_strg)+ - apply (fastforce simp: cur_vcpu_of_def split: if_splits) + apply (auto simp: insert_commute cur_vcpu_of_def split: if_splits) done crunch vcpu_flush diff --git a/proof/access-control/Access.thy b/proof/access-control/Access.thy index 081778de37..2561adb1b9 100644 --- a/proof/access-control/Access.thy +++ b/proof/access-control/Access.thy @@ -669,6 +669,8 @@ inductive integrity_obj_alt for aag activate subjects l' ko ko' where "\ tro_tag TCBGeneric; ko = Some (TCB tcb); ko' = Some (TCB tcb'); tcb' = tcb \tcb_arch := new_arch, tcb_bound_notification := ntfn', tcb_caller := cap', tcb_ctable := ccap'\; + tcb_ctable tcb = ccap' \ tcb_caller tcb = cap' \ tcb_bound_notification tcb = ntfn' + \ arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb); tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb); tcb_bound_notification_reset_integrity (tcb_bound_notification tcb) ntfn' subjects aag ; reply_cap_deletion_integrity subjects aag (tcb_caller tcb) cap'; diff --git a/proof/access-control/Access_AC.thy b/proof/access-control/Access_AC.thy index 8d1630ca95..6111dd34dd 100644 --- a/proof/access-control/Access_AC.thy +++ b/proof/access-control/Access_AC.thy @@ -603,6 +603,7 @@ lemma tro_alt_trans_spec: (* this takes a long time to process *) apply (find_goal \match premises in "tro_tag TCBGeneric" and "tro_tag' TCBRestart" \ -\) subgoal + apply (thin_tac "_ \ _") apply (erule integrity_obj_alt.intros[simplified tro_tag_to_prime]) apply (simp | rule tcb.equality | fastforce)+ done @@ -638,14 +639,33 @@ lemma tro_alt_trans_spec: (* this takes a long time to process *) simp: arch_tro_alt_trans_spec\\) (* TCB-TCB steps, somewhat slow *) + apply (all \fails \erule thin_rl[of "tro_tag TCBGeneric"], + erule thin_rl[of "tro_tag' TCBGeneric"]\ + | time_methods \solves \ + erule integrity_obj_alt.intros[simplified tro_tag_to_prime], + (assumption | rule refl + | ((erule exE)+)?, (rule exI)?, + force intro: tcb.equality + simp: reply_cap_deletion_integrity_def + tcb_bound_notification_reset_integrity_def)+\\\) + + apply (all \fails \erule thin_rl[of "tro_tag TCBGeneric"]\ + | time_methods \solves \ + (thin_tac \_ \ _\)?, + erule integrity_obj_alt.intros[simplified tro_tag_to_prime], + (assumption | rule refl + | ((erule exE)+)?, (rule exI)?, force intro: tcb.equality)+\\\) + apply (all \fails \erule thin_rl[of "tro_tag TCBGeneric"]\ | time_methods \solves \ + thin_tac \_ \ _\, erule integrity_obj_alt.intros[simplified tro_tag_to_prime], (assumption | rule refl | ((erule exE)+)?, (rule exI)?, force intro: tcb.equality)+\\\) apply (all \fails \erule thin_rl[of "tro_tag' TCBGeneric"]\ | time_methods \solves \ + (thin_tac \_ \ _\)?, erule integrity_obj_alt.intros, (assumption | rule refl | (elim exE)?, (intro exI)?, fastforce intro: tcb.equality @@ -777,6 +797,7 @@ lemma cdt_direct_change_allowed_backward: by (drule spec, erule integrity_objE, erule cdca_owned; (elim exE)?; + (thin_tac "_ \ _")?; simp; rule cdca_reply[rotated], assumption, assumption, fastforce elim:tcb_states_of_state_kheapI simp:direct_call_def) diff --git a/proof/access-control/DomainSepInv.thy b/proof/access-control/DomainSepInv.thy index fe1c304ff3..5c7ff47291 100644 --- a/proof/access-control/DomainSepInv.thy +++ b/proof/access-control/DomainSepInv.thy @@ -30,6 +30,7 @@ definition domain_sep_inv :: "bool \ 'a :: state_ext state \ \ cte_wp_at ((=) (IRQHandlerCap irq)) slot s \ interrupt_states s irq \ IRQSignal \ interrupt_states s irq \ IRQReserved + \ (irq \ non_kernel_IRQs \ interrupt_states s irq = IRQInactive) \ interrupt_states s = interrupt_states st))" definition domain_sep_inv_cap where @@ -59,6 +60,7 @@ lemma domain_sep_inv_def2: \ \ cte_wp_at ((=) (IRQHandlerCap irq)) slot s)) \ (irqs \ (\irq. interrupt_states s irq \ IRQSignal \ interrupt_states s irq \ IRQReserved + \ (irq \ non_kernel_IRQs \ interrupt_states s irq = IRQInactive) \ interrupt_states s = interrupt_states st)))" by (fastforce simp: domain_sep_inv_def) @@ -90,7 +92,9 @@ lemma domain_sep_inv_wp: apply (rule disjI2) apply simp apply (intro allI conjI) - apply (erule_tac P1="\x. x irq \ IRQSignal" in use_valid[OF _ irq_pres], assumption) + apply (erule_tac P1="\x. x irq \ IRQSignal" in use_valid[OF _ irq_pres], assumption) + apply blast + apply (erule use_valid[OF _ irq_pres], assumption) apply blast apply (erule use_valid[OF _ irq_pres], assumption) apply blast diff --git a/proof/infoflow/AARCH64/ArchADT_IF.thy b/proof/infoflow/AARCH64/ArchADT_IF.thy new file mode 100644 index 0000000000..9ba925bcb5 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchADT_IF.thy @@ -0,0 +1,464 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +text \ + This file sets up a kernel automaton, ADT_A_if, which is + slightly different from ADT_A. + It then setups a big step framework to transfrom this automaton in the + big step automaton on which the infoflow theorem will be proved +\ + +theory ArchADT_IF +imports ADT_IF +begin + +context Arch begin arch_global_naming + +named_theorems ADT_IF_assms + +lemmas [ADT_IF_assms] = + thread_set_no_etcb_change_cur_fpu_in_cur_domain + thread_set_no_etcb_change_cur_vcpu_in_cur_domain + handle_event_valid_cur_vcpu + cur_vcpu_in_cur_domain_updates + cur_fpu_in_cur_domain_updates + +lemma dmo_getActiveIRQ_wp'[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)) + and domain_sep_inv False st and valid_irq_states\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (fastforce simp: domain_sep_inv_def non_kernel_IRQs_def + valid_irq_states_def valid_irq_masks_def irq_at_def) + done + +lemma dmo_getActiveIRQ_wp[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\))\ + do_machine_op (getActiveIRQ False) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma thread_set_valid_cur_vcpu_unchanged_strong: + "\\tcb. tcb_vcpu (tcb_arch (f tcb)) = tcb_vcpu (tcb_arch tcb); \tcb. tcb_domain (f tcb) = tcb_domain tcb\ + \ thread_set f tptr \valid_cur_vcpu\" + apply (rule valid_cur_vcpu_lift_weak; (solves wpsimp)?) + apply (clarsimp simp: thread_set_def) + apply (wpsimp wp: set_object_wp) + apply (fastforce simp: pred_tcb_at_def obj_at_def get_tcb_def) + apply (clarsimp simp: in_cur_domain_def) + apply (wp_pre, wps, wpsimp wp: thread_set_no_change_etcb_at, clarsimp) + done + +lemma thread_set_tcb_context_valid_cur_vcpu[ADT_IF_assms,wp]: + "thread_set (tcb_arch_update (arch_tcb_context_set tc)) tcb \valid_cur_vcpu\" + by (wpsimp wp: thread_set_valid_cur_vcpu_unchanged_strong simp: arch_tcb_context_set_def) + +crunch do_user_op_if + for cur_vcpu_in_cur_domain[ADT_IF_assms,wp]: "cur_vcpu_in_cur_domain" + and cur_fpu_in_cur_domain[ADT_IF_assms,wp]: "cur_fpu_in_cur_domain" + and valid_cur_vcpu[ADT_IF_assms,wp]: "valid_cur_vcpu" + (simp: do_user_op_if_def) + +lemma deleted_irq_handler_valid_irq_states[ADT_IF_assms,wp]: + "deleted_irq_handler irq \valid_irq_states\" + unfolding deleted_irq_handler_def set_irq_state_def valid_irq_states_def valid_irq_masks_def maskInterrupt_def + by (wpsimp wp: dmo_wp) + +lemma dmo_getActiveIRQ_valid_irq_states[ADT_IF_assms,wp]: + "do_machine_op (getActiveIRQ in_kernel) \valid_irq_states\" + unfolding getActiveIRQ_def by wpsimp + +crunch prepare_thread_delete, arch_finalise_cap, arch_post_cap_deletion + for valid_irq_states[ADT_IF_assms,wp]: "\s :: det_state. valid_irq_states s" + (wp: crunch_wps mapM_x_wp hoare_drop_imps simp: crunch_simps) + +lemmas [ADT_IF_assms] = + maybe_handle_interrupt_cur_vcpu_in_cur_domain + maybe_handle_interrupt_cur_fpu_in_cur_domain + maybe_handle_interrupt_valid_cur_vcpu + handle_event_cur_vcpu_in_cur_domain + handle_event_cur_fpu_in_cur_domain + schedule_cur_vcpu_in_cur_domain + schedule_cur_fpu_in_cur_domain + schedule_valid_cur_vcpu + activate_thread_cur_vcpu_in_cur_domain + activate_thread_cur_fpu_in_cur_domain + activate_thread_valid_cur_vcpu + +end + + +global_interpretation ADT_IF_1?: ADT_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_assms[folded valid_cur_hyp_def cur_hyp_in_cur_domain_def])?) +qed + + +context Arch begin arch_global_naming + +(* FIXME: clagged from AInvs.do_user_op_invs *) +lemma do_user_op_if_invs[ADT_IF_assms]: + "\invs and ct_running\ + do_user_op_if f tc + \\_. invs and ct_running\" + apply (simp add: do_user_op_if_def split_def) + apply (wp do_machine_op_ct_in_state device_update_invs | wp (once) dmo_invs | simp)+ + apply (clarsimp simp: user_mem_def user_memory_update_def simpler_modify_def restrict_map_def + invs_def cur_tcb_def ptable_rights_s_def ptable_lift_s_def) + apply (frule ptable_rights_imp_frame) + apply fastforce + apply simp + apply (clarsimp simp: valid_state_def device_frame_in_device_region) + done + +crunch do_user_op_if + for domain_sep_inv[ADT_IF_assms, wp]: "domain_sep_inv irqs st" + (ignore: user_memory_update) + +crunch do_user_op_if + for valid_sched[ADT_IF_assms, wp]: "valid_sched" + (ignore: user_memory_update) + +crunch do_user_op_if + for irq_masks[ADT_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (ignore: user_memory_update wp: dmo_wp no_irq) + +crunch do_user_op_if + for valid_list[ADT_IF_assms, wp]: "valid_list" + (ignore: user_memory_update) + +lemma do_user_op_if_scheduler_action[ADT_IF_assms, wp]: + "do_user_op_if f tc \\s. P (scheduler_action s)\" + by (simp add: do_user_op_if_def | wp | wpc)+ + +lemma do_user_op_silc_inv[ADT_IF_assms, wp]: + "do_user_op_if f tc \silc_inv aag st\" + apply (simp add: do_user_op_if_def) + apply (wp | wpc | simp)+ + done + +lemma do_user_op_pas_refined[ADT_IF_assms, wp]: + "do_user_op_if f tc \pas_refined aag\" + apply (simp add: do_user_op_if_def) + apply (wp | wpc | simp)+ + done + +crunch do_user_op_if + for cur_thread[ADT_IF_assms, wp]: "\s. P (cur_thread s)" + and cur_domain[ADT_IF_assms, wp]: "\s. P (cur_domain s)" + and idle_thread[ADT_IF_assms, wp]: "\s. P (idle_thread s)" + and domain_fields[ADT_IF_assms, wp]: "domain_fields P" + (ignore: user_memory_update) + +lemma do_use_op_guarded_pas_domain[ADT_IF_assms, wp]: + "do_user_op_if f tc \guarded_pas_domain aag\" + by (rule guarded_pas_domain_lift; wp) + +lemma tcb_arch_ref_tcb_context_set[ADT_IF_assms, simp]: + "tcb_arch_ref (tcb_arch_update (arch_tcb_context_set tc) tcb) = tcb_arch_ref tcb" + by (simp add: tcb_arch_ref_def arch_tcb_context_set_def) + +crunch arch_activate_idle_thread, arch_switch_to_thread + for cur_thread[ADT_IF_assms, wp]: "\s. P (cur_thread s)" + +lemma arch_activate_idle_thread_scheduler_action[ADT_IF_assms, wp]: + "arch_activate_idle_thread t \\s :: det_state. P (scheduler_action s)\" + by (wpsimp simp: arch_activate_idle_thread_def) + +crunch handle_vm_fault, handle_hypervisor_fault + for domain_fields[ADT_IF_assms, wp]: "domain_fields P" + +lemma arch_perform_invocation_noErr[ADT_IF_assms, wp]: + "\\\ arch_perform_invocation a -, \Q\" + by (wpsimp simp: arch_perform_invocation_def) + +lemma arch_invoke_irq_control_noErr[ADT_IF_assms, wp]: + "\\\ arch_invoke_irq_control a -, \Q\" + by (cases a; wpsimp) + +lemma getActiveIRQ_None[ADT_IF_assms]: + "(None,s') \ fst (do_machine_op (getActiveIRQ False) s) \ + irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" + apply (erule use_valid) + apply (wp dmo_getActiveIRQ_wp) + by simp + +lemma getActiveIRQ_Some[ADT_IF_assms]: + "(Some i, s') \ fst (do_machine_op (getActiveIRQ False) s) + \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some i" + apply (erule use_valid) + apply (wp dmo_getActiveIRQ_wp) + by simp + +lemma idle_equiv_as_globals_equiv: + "arm_us_global_vspace (arch_state s) \ idle_thread s + \ idle_equiv st s = + globals_equiv (st\arch_state := arch_state s, machine_state := machine_state s, + kheap:= (kheap st)(arm_us_global_vspace (arch_state s) := + kheap s (arm_us_global_vspace (arch_state s))), + cur_thread := cur_thread s\) s" + by (clarsimp simp: idle_equiv_def globals_equiv_def tcb_at_def2) + +lemma idle_globals_lift: + assumes g: "\st. \globals_equiv st and P\ f \\_. globals_equiv st\" + assumes i: "\s. P s \ arm_us_global_vspace (arch_state s) \ idle_thread s" + shows "\idle_equiv st and P\ f \\_. idle_equiv st\" + apply (clarsimp simp: valid_def) + apply (subgoal_tac "arm_us_global_vspace (arch_state s) \ idle_thread s") + apply (subst (asm) idle_equiv_as_globals_equiv,simp+) + apply (frule use_valid[OF _ g]) + apply simp+ + apply (clarsimp simp: idle_equiv_def globals_equiv_def tcb_at_def2) + apply (erule i) + done + +lemma idle_equiv_as_globals_equiv_scheduler: + "arm_us_global_vspace (arch_state s) \ idle_thread s + \ idle_equiv st s = + globals_equiv_scheduler (st\arch_state := arch_state s, machine_state := machine_state s, + kheap:= (kheap st)(arm_us_global_vspace (arch_state s) := + kheap s (arm_us_global_vspace (arch_state s)))\) s" + by (clarsimp simp: idle_equiv_def tcb_at_def2 globals_equiv_scheduler_def + arch_globals_equiv_scheduler_def) + +lemma idle_globals_lift_scheduler: + assumes g: "\st. \globals_equiv_scheduler st and P\ f \\_. globals_equiv_scheduler st\" + assumes i: "\s. P s \ arm_us_global_vspace (arch_state s) \ idle_thread s" + shows "\idle_equiv st and P\ f \\_. idle_equiv st\" + apply (clarsimp simp: valid_def) + apply (subgoal_tac "arm_us_global_vspace (arch_state s) \ idle_thread s") + apply (subst (asm) idle_equiv_as_globals_equiv_scheduler,simp+) + apply (frule use_valid[OF _ g]) + apply simp+ + apply (clarsimp simp: idle_equiv_def globals_equiv_scheduler_def tcb_at_def2) + apply (erule i) + done + +lemma invs_pt_not_idle_thread[intro]: + "invs s \ arm_us_global_vspace (arch_state s) \ idle_thread s" + apply clarsimp + apply (frule invs_valid_idle) + apply (frule invs_valid_global_arch_objs) + by (fastforce dest: valid_global_arch_objs_pt_at + simp: obj_at_def valid_idle_def pred_tcb_at_def) + +lemma kernel_entry_if_idle_equiv[ADT_IF_assms]: + "\invs and (\s. e \ Interrupt \ ct_active s) and domain_sep_inv irqs st and idle_equiv st + and (\s. ct_idle s \ tc = idle_context s)\ + kernel_entry_if e tc + \\_. idle_equiv st\" + apply (rule hoare_pre) + apply (rule idle_globals_lift) + apply (wp kernel_entry_if_globals_equiv) + apply force + apply (fastforce intro!: invs_pt_not_idle_thread)+ + done + +lemmas handle_preemption_idle_equiv[ADT_IF_assms, wp] = + idle_globals_lift[OF handle_preemption_globals_equiv invs_pt_not_idle_thread, simplified] + +lemmas schedule_if_idle_equiv[ADT_IF_assms, wp] = + idle_globals_lift_scheduler[OF schedule_if_globals_equiv_scheduler invs_pt_not_idle_thread, simplified] + +lemma do_user_op_if_idle_equiv[ADT_IF_assms, wp]: + "\idle_equiv st and invs\ + do_user_op_if uop tc + \\_. idle_equiv st\" + unfolding do_user_op_if_def + by (wpsimp wp: dmo_user_memory_update_idle_equiv dmo_device_memory_update_idle_equiv) + +lemma kernel_entry_if_valid_vspace_objs_if[ADT_IF_assms, wp]: + "\valid_vspace_objs_if and invs and (\s. e \ Interrupt \ ct_active s)\ + kernel_entry_if e tc + \\_. valid_vspace_objs_if\" + by wpsimp + +lemma handle_preemption_if_valid_pdpt_objs[ADT_IF_assms, wp]: + "\valid_vspace_objs_if\ handle_preemption_if a \\rv s. valid_vspace_objs_if s\" + by wpsimp + +lemma schedule_if_valid_pdpt_objs[ADT_IF_assms, wp]: + "\valid_vspace_objs_if\ schedule_if a \\rv s. valid_vspace_objs_if s\" + by wpsimp + +lemma do_user_op_if_valid_pdpt_objs[ADT_IF_assms, wp]: + "\valid_vspace_objs_if\ do_user_op_if a b \\rv s. valid_vspace_objs_if s\" + by wpsimp + +lemma valid_vspace_objs_if_ms_update[ADT_IF_assms, simp]: + "valid_vspace_objs_if (machine_state_update f s) = valid_vspace_objs_if s" + by simp + +lemma do_user_op_if_irq_state_of_state[ADT_IF_assms]: + "do_user_op_if utf uc \\s. P (irq_state_of_state s)\" + apply (rule hoare_pre) + apply (simp add: do_user_op_if_def user_memory_update_def | wp dmo_wp | wpc)+ + done + +lemma do_user_op_if_irq_masks_of_state[ADT_IF_assms]: + "do_user_op_if utf uc \\s. P (irq_masks_of_state s)\" + apply (rule hoare_pre) + apply (simp add: do_user_op_if_def user_memory_update_def | wp dmo_wp | wpc)+ + done + +lemma do_user_op_if_irq_measure_if[ADT_IF_assms]: + "do_user_op_if utf uc \\s. P (irq_measure_if s)\" + apply (rule hoare_pre) + apply (simp add: do_user_op_if_def user_memory_update_def irq_measure_if_def + | wps |wp dmo_wp | wpc)+ + done + +crunch set_flags, arch_post_set_flags + for irq_states_of_state[wp]: "\s. P (irq_state_of_state s)" + +lemma checked_cap_insert_valid_irq_states[wp]: + "check_cap_at a b (check_cap_at c d (cap_insert a b e)) \valid_irq_states\" + by (wpsimp simp: check_cap_at_def)+ + +crunch set_mcpriority + for valid_irq_states[wp]: valid_irq_states + +lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: + "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) and valid_irq_states + and tcb_inv_wf tinv and K (irq_is_recurring irq st)\ + invoke_tcb tinv + \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" + apply (case_tac tinv) + apply ((wp hoare_vcg_if_lift mapM_x_wp[OF _ subset_refl] + | wpc + | simp split del: if_split add: check_cap_at_def + | clarsimp + | wp (once) irq_state_inv_triv)+)[3] + defer + apply ((wp irq_state_inv_triv | simp)+)[2] + apply (simp add: split_def cong: option.case_cong) + by (clarsimp split del: if_split cong: conj_cong + | wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R + checked_cap_insert_domain_sep_inv cap_delete_deletes + cap_delete_irq_state_inv[where st=st and sta=sta and irq=irq] + cap_delete_irq_state_next[where st=st and sta=sta and irq=irq] + cap_delete_valid_cap cap_delete_cte_at + | wpc + | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def + tcb_at_st_tcb_at option_update_thread_def + | strengthen use_no_cap_to_obj_asid_strg + | wp (once) irq_state_inv_triv hoare_drop_imps + | clarsimp split: option.splits | intro impI conjI allI)+ + +crunch freeMemory + for irq_masks[wp]: "\s. P (irq_masks s)" + (wp: mapM_x_wp) + +lemma valid_irq_states_kheap_update[simp]: + "valid_irq_states (kheap_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +crunch delete_objects + for valid_irq_states[wp]: valid_irq_states + (wp: dmo_machine_state_lift simp: crunch_simps detype_def) + +lemma reset_untyped_cap_irq_state_inv[ADT_IF_assms]: + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ + reset_untyped_cap slot + \\y. irq_state_inv st\, \\y. irq_state_next st\" + apply (cases "irq_is_recurring irq st", simp_all) + apply (simp add: reset_untyped_cap_def) + apply (rule hoare_pre) + by (wp no_irq_clearMemory hoare_vcg_const_imp_lift set_cap_domain_sep_inv + hoare_post_addE[where Q'="domain_sep_inv False sta and valid_irq_states", OF mapME_x_wp'] + get_cap_wp preemption_point_irq_state_inv'[where irq=irq] + | rule hoare_vcg_conj_lift + | rule irq_state_inv_triv + | simp add: unless_def + | wp (once) dmo_wp + | fastforce)+ + +lemma handle_vm_fault_irq_state_of_state[ADT_IF_assms]: + "handle_vm_fault thread fault \\s. P (irq_state_of_state s)\" + unfolding handle_vm_fault_def addressTranslateS1_def + by (wpsimp wp: dmo_wp) + +lemma handle_hypervisor_fault_irq_state_of_state[ADT_IF_assms]: + "handle_hypervisor_fault thread fault \\s. P (irq_state_of_state s)\" + by (cases fault, wpsimp wp: dmo_wp split_del: if_split) + + +text \Not true of invoke_untyped any more.\ +crunch create_cap + for irq_state_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (ignore: freeMemory + wp: dmo_wp modify_wp crunch_wps + simp: freeMemory_def storeWord_def clearMemory_def + machine_op_lift_def machine_rest_lift_def mapM_x_defsym) + +crunch arch_invoke_irq_control + for irq_state_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: dmo_wp crunch_wps simp: setIRQTrigger_def machine_op_lift_def machine_rest_lift_def) + +lemma handle_reserved_irq_non_kernel_IRQs[ADT_IF_assms]: + "\P and K (irq \ non_kernel_IRQs)\ handle_reserved_irq irq \\_. P\" + unfolding handle_reserved_irq_def + apply (rule hoare_gen_asm) + apply (wpsimp wp: when_wp[where P'="\"] simp: non_kernel_IRQs_def irq_vppi_event_index_def) + done + +lemma thread_set_context_state_hyp_refs_of: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \\s. P (state_hyp_refs_of s)\" + apply (wpsimp simp: thread_set_def wp: set_object_wp) + apply (erule_tac P=P in back_subst) + apply (rule ext) + apply (simp add: state_hyp_refs_of_def get_tcb_def arch_tcb_context_set_def + split: option.splits kernel_object.splits) + done + +lemma thread_set_context_pas_refined[ADT_IF_assms]: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \pas_refined aag\" + unfolding pas_refined_def state_objs_to_policy_def + apply (rule hoare_weaken_pre) + apply (wpsimp wp: tcb_domain_map_wellformed_lift_strong thread_set_edomains) + apply (wps thread_set_state_vrefs thread_set_context_state_hyp_refs_of) + apply (rule hoare_lift_Pf2[where f="caps_of_state"]) + apply (rule hoare_lift_Pf2[where f="thread_st_auth"]) + apply (rule hoare_lift_Pf2[where f="thread_bound_ntfns"]) + apply wp + apply (wpsimp wp: thread_set_thread_bound_ntfns_trivT) + apply (wpsimp wp: thread_set_thread_st_auth_trivT) + apply (wpsimp wp: thread_set_caps_of_state_trivial simp: ran_tcb_cap_cases) + apply simp + done + +crunch init_arch_objects + for irq_states_of_state[ADT_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: crunch_wps dmo_wp) + +end + + +global_interpretation ADT_IF_2?: ADT_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_assms)?) +qed + +sublocale valid_initial_state \ valid_initial_state?: ADT_valid_initial_state .. + +end diff --git a/proof/infoflow/AARCH64/ArchArch_IF.thy b/proof/infoflow/AARCH64/ArchArch_IF.thy new file mode 100644 index 0000000000..d57c2b58fd --- /dev/null +++ b/proof/infoflow/AARCH64/ArchArch_IF.thy @@ -0,0 +1,3519 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchArch_IF +imports Arch_IF +begin + +(* FIXME AARCH64 IF: consider modelling some of these *) +axiomatization dmo_reads_respects where + dmo_getESR_reads_respects: "reads_respects aag l \ (do_machine_op AARCH64.getESR)" and + dmo_getFAR_reads_respects: "reads_respects aag l \ (do_machine_op AARCH64.getFAR)" and + dmo_doSMC_mop_reads_respects: "reads_respects aag l \ (do_machine_op (AARCH64.doSMC_mop args))" and + dmo_addressTranslateS1_reads_respects: "reads_respects aag l \ (do_machine_op (AARCH64.addressTranslateS1 w))" + +(* Axioms cannot be defined inside the Arch locale. To circumvent this, we define Arch-specific + copies of the axioms, then hide the original axioms from the generic context. *) + +context Arch begin arch_global_naming + +(* Define new copies of the axioms that are only visible in the Arch locale *) +lemmas dmo_getESR_reads_respects = dmo_getESR_reads_respects +lemmas dmo_getFAR_reads_respects = dmo_getFAR_reads_respects +lemmas dmo_doSMC_mop_reads_respects = dmo_doSMC_mop_reads_respects +lemmas dmo_addressTranslateS1_reads_respects = dmo_addressTranslateS1_reads_respects + +end + +(* Hide the original axioms *) +hide_fact + dmo_getESR_reads_respects + dmo_getFAR_reads_respects + dmo_doSMC_mop_reads_respects + dmo_addressTranslateS1_reads_respects + + +context Arch begin arch_global_naming + +named_theorems Arch_IF_assms + +(* we need to know we're not doing an asid pool update, or else this could affect + what some other domain sees *) +lemma set_object_equiv_but_for_labels: + "\equiv_but_for_labels aag L st and (\ s. \ asid_pool_at ptr s) and + K ((\asid_pool. obj \ ArchObj (ASIDPool asid_pool)) \ pasObjectAbs aag ptr \ L)\ + set_object ptr obj + \\_. equiv_but_for_labels aag L st\" + apply (wpsimp wp: set_object_wp) + apply (clarsimp simp: equiv_but_for_labels_def) + apply (subst dummy_kheap_update[where st=st]) + apply (rule states_equiv_for_non_asid_pool_kheap_update) + apply assumption + apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forE) + apply (fastforce simp: non_asid_pool_kheap_update_def) + apply (clarsimp simp: non_asid_pool_kheap_update_def asid_pool_at_kheap) + done + +lemma get_tcb_not_asid_pool_at: + "get_tcb ref s = Some y \ \ asid_pool_at ref s" + by (fastforce simp: get_tcb_def asid_pool_at_kheap) + +lemma as_user_set_register_ev2: + assumes domains_distinct: "pas_domains_distinct aag" + shows "labels_are_invisible aag l (pasObjectAbs aag ` {thread,thread'}) + \ equiv_valid_2 (reads_equiv aag) (affects_equiv aag l) (affects_equiv aag l) (=) \ \ + (as_user thread (setRegister x y)) (as_user thread' (setRegister a b))" + apply (simp add: as_user_def) + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac L="{pasObjectAbs aag thread}" and L'="{pasObjectAbs aag thread'}" + and Q="\" and Q'="\" in ev2_invisible[OF domains_distinct]) + apply (simp add: labels_are_invisible_def)+ + apply ((rule modifies_at_mostI + | wp set_object_equiv_but_for_labels + | simp add: split_def + | fastforce dest: get_tcb_not_asid_pool_at)+)[2] + apply auto + done + +crunch arch_post_cap_deletion + for valid_global_refs[Arch_IF_assms, wp]: "valid_global_refs" + +crunch store_word_offs + for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: crunch_wps dmo_wp simp: storeWord_def) + +crunch set_irq_state, arch_post_cap_deletion, handle_arch_fault_reply + for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: crunch_wps dmo_wp simp: crunch_simps maskInterrupt_def) + +crunch readVCPUHardwareReg, check_export_arch_timer, writeVCPUHardwareReg, maskInterrupt, + enableFpuEL01, isb, dsb, setHCR, setSCTLR, sendSGI, set_gic_vcpu_ctrl_hcr, + set_gic_vcpu_ctrl_lr, set_gic_vcpu_ctrl_apr, set_gic_vcpu_ctrl_vmcr, get_gic_vcpu_ctrl_hcr, + get_gic_vcpu_ctrl_lr, get_gic_vcpu_ctrl_apr, get_gic_vcpu_ctrl_vmcr, do_flush, + invalidateTranslationASID, writeFpuState, disableFpu, enableFpu, deactivateInterrupt + for irq_state[wp]: "\ms. P (irq_state ms)" + +crunch arch_switch_to_idle_thread, arch_switch_to_thread + for irq_state_of_state[Arch_IF_assms, wp]: "\s :: det_state. P (irq_state_of_state s)" + (wp: dmo_wp modify_wp crunch_wps whenE_wp + simp: machine_op_lift_def setVSpaceRoot_def + machine_rest_lift_def crunch_simps storeWord_def) + +crunch arch_invoke_irq_handler + for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" + (wp: dmo_wp simp: maskInterrupt_def) + +crunch arch_perform_invocation + for irq_state_of_state[wp]: "\s. P (irq_state_of_state s)" + (wp: dmo_wp modify_wp simp: cache_machine_op_defs doSMC_mop_def + wp: crunch_wps simp: crunch_simps ignore: ignore_failure) + +crunch arch_finalise_cap, prepare_thread_delete + for irq_state_of_state[Arch_IF_assms, wp]: "\s :: det_state. P (irq_state_of_state s)" + (wp: modify_wp crunch_wps dmo_wp + simp: crunch_simps) + +lemma equiv_asid_machine_state_update[Arch_IF_assms, simp]: + "equiv_asid asid (machine_state_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (machine_state_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma as_user_set_register_reads_respects'[Arch_IF_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows "reads_respects aag l \ (as_user thread (setRegister x y))" + apply (case_tac "aag_can_read aag thread \ aag_can_affect aag l thread") + apply (simp add: as_user_def split_def) + apply (rule gen_asm_ev) + apply (wp set_object_reads_respects select_f_ev gets_the_ev) + apply (auto intro: reads_affects_equiv_get_tcb_eq det_setRegister)[1] + apply (simp add: equiv_valid_def2) + apply (rule as_user_set_register_ev2[OF domains_distinct]) + apply (simp add: labels_are_invisible_def) + done + +lemma store_word_offs_reads_respects[Arch_IF_assms]: + "reads_respects aag l \ (store_word_offs ptr offs v)" + apply (simp add: store_word_offs_def storeWord_def do_machine_op_bind) + apply (wpsimp wp: equiv_valid_get_assert do_machine_op_reads_respects assert_ev2 modify_ev + | fastforce intro: equiv_forI elim: equiv_forE simp: upto.simps comp_def)+ + done + +lemma set_simple_ko_globals_equiv[Arch_IF_assms]: + "\globals_equiv s and valid_arch_state\ + set_simple_ko f ptr ep + \\_. globals_equiv s\" + unfolding set_simple_ko_def + apply (wpsimp wp: set_object_globals_equiv[THEN hoare_set_object_weaken_pre] get_object_wp + simp: partial_inv_def)+ + apply (fastforce simp: obj_at_def valid_arch_state_def dest: valid_global_arch_objs_pt_at) + done + +crunch set_thread_state_act + for globals_equiv[wp]: "globals_equiv s" + +lemma set_thread_state_globals_equiv[Arch_IF_assms]: + "\globals_equiv s and valid_arch_state\ + set_thread_state ref ts + \\_. globals_equiv s\" + unfolding set_thread_state_def + apply (wp set_object_globals_equiv |simp)+ + apply (intro impI conjI allI) + apply (fastforce simp: valid_arch_state_def obj_at_def tcb_at_def2 get_tcb_def is_tcb_def + dest: get_tcb_SomeD valid_global_arch_objs_pt_at + split: option.splits kernel_object.splits)+ + done + +lemma set_cap_globals_equiv'[Arch_IF_assms]: + "\globals_equiv s and valid_global_arch_objs\ + set_cap cap p + \\_. globals_equiv s\" + unfolding set_cap_def + apply (simp only: split_def) + apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ + apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def + dest: valid_global_arch_objs_pt_at)+ + done + +lemma thread_set_non_idle_globals_equiv[Arch_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv st\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + by (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def + dest: valid_global_arch_objs_pt_at) + +crunch arch_prepare_set_domain, arch_prepare_next_domain + for irq_state_of_state[Arch_IF_assms, wp]: "\s. P (irq_state_of_state s)" + +lemma equiv_hyp_machine_state_rest_update[Arch_IF_assms]: + "equiv_hyp P st (s\machine_state := ms\machine_state_rest := r\\) = equiv_hyp P st (s\machine_state := ms\)" + by (simp add: equiv_hyp_def equiv_for_def) + +lemma equiv_fpu_machine_state_rest_update[Arch_IF_assms]: + "equiv_fpu P st (s\machine_state := ms\machine_state_rest := r\\) = equiv_fpu P st (s\machine_state := ms\)" + by (simp add: equiv_fpu_def equiv_for_def) + +end + + +(* FIXME AARCH64 IF: add to interface *) +arch_requalify_facts + set_simple_ko_globals_equiv + retype_region_irq_state_of_state + arch_perform_invocation_irq_state_of_state + +declare + retype_region_irq_state_of_state[wp] + arch_perform_invocation_irq_state_of_state[wp] + + +global_interpretation Arch_IF_1?: Arch_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Arch_IF_assms)?) +qed + + +lemmas invs_imps = + invs_sym_refs invs_psp_aligned invs_distinct invs_arch_state + invs_valid_global_objs invs_arch_state invs_valid_objs invs_valid_global_refs tcb_at_invs + invs_cur invs_kernel_mappings + + +context Arch begin arch_global_naming + +lemma get_asid_pool_revrv': + "reads_equiv_valid_rv_inv (affects_equiv aag l) aag + (\rv rv'. aag_can_read aag ptr \ rv = rv') \ (get_asid_pool ptr)" + unfolding gets_map_def + apply (subst gets_apply) + apply (subst gets_apply) + apply (rule_tac W="\rv rv'. aag_can_read aag ptr \ rv = rv'" in equiv_valid_rv_bind) + apply (fastforce elim: reads_equivE equiv_forE + simp: equiv_valid_2_def opt_map_def gets_apply_def get_def bind_def return_def) + apply (fastforce simp: equiv_valid_2_def return_def assert_opt_def fail_def split: option.splits) + apply wp + done + +lemma get_asid_pool_rev: + "reads_equiv_valid_inv A aag (K (is_subject aag ptr)) (get_asid_pool ptr)" + unfolding gets_map_def + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (fastforce elim: reads_equivE equiv_forE simp: opt_map_def) + done + +lemma get_asid_pool_revrv: + "reads_equiv_valid_rv_inv (affects_equiv aag l) aag + (\rv rv'. rv (asid_low_bits_of asid) = rv' (asid_low_bits_of asid)) + (\s. Some a = arm_asid_table (arch_state s) (asid_high_bits_of asid) \ + is_subject_asid aag asid \ asid \ 0) + (get_asid_pool a)" + unfolding gets_map_def assert_opt_def2 + apply (rule equiv_valid_rv_guard_imp) + apply (rule_tac R'="\rv rv'. \p p'. rv a = Some p \ rv' a = Some p' + \ p (asid_low_bits_of asid) = p' (asid_low_bits_of asid)" + and P="\s. Some a = arm_asid_table (arch_state s) (asid_high_bits_of asid) \ + is_subject_asid aag asid \ asid \ 0" + and P'="\s. Some a = arm_asid_table (arch_state s) (asid_high_bits_of asid) \ + is_subject_asid aag asid \ asid \ 0" + in equiv_valid_2_bind) + apply (clarsimp simp: equiv_valid_2_def assert_def bind_def return_def fail_def + split: if_split) + apply (clarsimp simp: equiv_valid_2_def gets_def get_def bind_def return_def fail_def + split: if_split) + apply (drule_tac s="Some a" in sym) + apply (fastforce elim: reads_equivE simp: equiv_asids_def equiv_asid_def) + apply (wp wp_post_taut | simp)+ + done + +lemma asid_high_bits_0_eq_1: + "asid_high_bits_of 0 = asid_high_bits_of 1" + by (auto simp: asid_high_bits_of_def asid_low_bits_def) + +lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq: + "\ is_subject_asid aag asid; reads_equiv aag s t; asid \ 0 \ + \ arm_asid_table (arch_state s) (asid_high_bits_of asid) = + arm_asid_table (arch_state t) (asid_high_bits_of asid)" + apply (erule reads_equivE) + apply (fastforce simp: equiv_asids_def equiv_asid_def intro: aag_can_read_own_asids) + done + +lemma find_vspace_for_asid_reads_respects: + "reads_respects aag l (K (aag_can_read_asid aag asid)) (find_vspace_for_asid asid)" + unfolding find_vspace_for_asid_def + apply wpsimp + apply (simp add: throw_opt_def) + apply wpsimp + apply wpsimp+ + apply (erule reads_equivE) + apply (clarsimp simp: equiv_asids_def) + apply (erule equiv_forE) + apply (erule_tac x=asid in allE) + apply clarsimp + apply (fastforce simp: vspace_for_asid_def entry_for_asid_def entry_for_pool_def + pool_for_asid_def vspace_for_pool_def + opt_map_def obind_def obj_at_def equiv_asid_def + split: option.splits) + done + +crunch invalidate_tlb_by_asid + for states_equiv_for[wp]: "states_equiv_for P Q R S st" + and scheduler_action[wp]: "\s. P (scheduler_action s)" + and work_units_completed[wp]: "\s. P (work_units_completed s)" + (wp: do_machine_op_mol_states_equiv_for ignore: do_machine_op simp: invalidateTranslationASID_def) + +lemma invalidate_tlb_by_asid_reads_respects: + "reads_respects aag l (\_. True) (invalidate_tlb_by_asid asid)" + by (wpsimp wp: reads_respects_unobservable_unit_return) + +lemma invalidate_tlb_by_asid_va_reads_respects: + "reads_respects aag l \ (invalidate_tlb_by_asid_va asid vaddr)" + unfolding invalidate_tlb_by_asid_va_def invalidateTranslationSingle_def + by (wpsimp wp: reads_respects_unobservable_unit_return do_machine_op_mol_states_equiv_for) + +lemma ptes_of_reads_equiv: + "\ is_subject aag (table_base pt_t ptr); reads_equiv aag s t \ + \ ptes_of s pt_t ptr = ptes_of t pt_t ptr" + by (fastforce elim: reads_equivE equiv_forE simp: ptes_of_def obind_def opt_map_def) + +(* FIXME AARCH64 IF: consolidate with ArchArchAcc_R *) +lemmas bit_pred = bit0.pred bit1.pred + +lemma pt_walk_reads_equiv: + "\ reads_equiv aag s t; pas_refined aag s; pspace_aligned s; valid_asid_table s; + valid_vspace_objs s; is_subject aag pt; vptr \ user_region; + level \ max_pt_level; vs_lookup_table level asid vptr s = Some (level, pt) \ + \ pt_walk level bot_level pt vptr (ptes_of s) = + pt_walk level bot_level pt vptr (ptes_of t)" + apply (induct level arbitrary: pt; clarsimp) + apply (simp (no_asm) add: pt_walk.simps) + apply (clarsimp simp: obind_def split: if_splits) + apply (subgoal_tac "ptes_of s (level_type level) (pt_slot_offset level pt vptr) = + ptes_of t (level_type level) (pt_slot_offset level pt vptr)") + apply (clarsimp split: option.splits) + apply (frule_tac bot_level="level-1" in vs_lookup_table_extend) + apply (fastforce simp: pt_walk.simps obind_def) + apply clarsimp + apply (erule_tac x="pptr_from_pte x2" in meta_allE) + apply (drule meta_mp) + apply (subst (asm) vs_lookup_split_Some[OF order_less_imp_le], rule bit_pred) + apply fastforce+ + apply (erule_tac pt_ptr=pt in pt_walk_is_subject; fastforce) + apply (erule (1) meta_mp) + apply (rule ptes_of_reads_equiv) + apply (subst table_base_pt_slot_offset) + apply (erule vs_lookup_table_is_aligned) + by fastforce+ + +lemma pt_lookup_from_level_reads_respects: + "reads_respects aag l + (\s. pas_refined aag s \ pspace_aligned s \ valid_vspace_objs s \ valid_asid_table s \ + is_subject aag pt \ level \ max_pt_level \ vref \ user_region \ + (\asid. vs_lookup_table level asid vref s = Some (level, pt))) + (pt_lookup_from_level level pt vref target_pt)" + apply (induct level arbitrary: pt) + apply (simp add: pt_lookup_from_level_simps) + apply wp + apply (simp (no_asm) add: pt_lookup_from_level_simps unlessE_def) + apply clarsimp + apply (rule equiv_valid_guard_imp) + apply (wpsimp wp: get_pte_rev | assumption)+ + apply (frule vs_lookup_table_is_aligned; clarsimp) + apply (prop_tac "pt_walk level (level - 1) pt vref (ptes_of s) = + Some (level - 1, pptr_from_pte rv)") + apply (fastforce simp: pt_walk.simps obind_def) + apply (rule conjI) + apply (erule_tac level=level and bot_level="level-1" and pt_ptr=pt in pt_walk_is_subject; fastforce) + apply (rule_tac x=asid in exI) + apply (erule (2) vs_lookup_table_extend) + done + +lemma unmap_page_table_reads_respects: + "reads_respects aag l + (pas_refined aag and pspace_aligned and valid_vspace_objs and valid_asid_table + and K (asid \ 0 \ is_subject_asid aag asid \ vaddr \ user_region)) + (unmap_page_table asid vaddr pt)" + unfolding unmap_page_table_def fun_app_def cleanByVA_PoU_def + apply (rule gen_asm_ev) + apply (rule equiv_valid_guard_imp) + apply (wp dmo_mol_reads_respects store_pte_reads_respects invalidate_tlb_by_asid_reads_respects + pt_lookup_from_level_reads_respects find_vspace_for_asid_reads_respects + | wpc | simp | fastforce intro: hoare_strengthen_postE_R[OF pt_lookup_from_level_is_subject])+ + apply clarsimp + apply (frule vspace_for_asid_is_subject) + apply (fastforce dest: vspace_for_asid_vs_lookup vs_lookup_table_vref_independent)+ + done + +lemma perform_page_table_invocation_reads_respects: + "reads_respects aag l (pas_refined aag and pspace_aligned and valid_objs and valid_vspace_objs + and valid_asid_table and valid_pti pti + and K (authorised_page_table_inv aag pti)) + (perform_page_table_invocation pti)" + unfolding perform_page_table_invocation_def perform_pt_inv_map_def perform_pt_inv_unmap_def + apply (rule equiv_valid_guard_imp) + apply (wp dmo_mol_reads_respects store_pte_reads_respects set_cap_reads_respects mapM_x_ev'' + unmap_page_table_reads_respects get_cap_rev + | wpc | simp add: cleanByVA_PoU_def cleanCacheRange_PoU_def)+ + apply (case_tac pti; clarsimp simp: authorised_page_table_inv_def) + apply (clarsimp simp: valid_pti_def) + apply (frule cte_wp_valid_cap) + apply fastforce + apply (clarsimp simp: is_PageTableCap_def valid_cap_def wellformed_mapdata_def add_mask_fold) + done + +lemma unmap_page_reads_respects: + "reads_respects aag l + (pas_refined aag and pspace_aligned and valid_vspace_objs and valid_asid_table + and K (asid \ 0 \ is_subject_asid aag asid \ vptr \ user_region)) + (unmap_page pgsz asid vptr pptr)" + unfolding unmap_page_def catch_def fun_app_def cleanByVA_PoU_def + apply (simp add: unmap_page_def unlessE_def gets_the_def cong: vmpage_size.case_cong) + apply (wp gets_ev' dmo_mol_reads_respects get_pte_rev throw_on_false_reads_respects + find_vspace_for_asid_reads_respects store_pte_reads_respects[simplified] + invalidate_tlb_by_asid_va_reads_respects + | wpc | simp add: is_aligned_mask[symmetric])+ + apply (clarsimp simp: pt_lookup_slot_def) + apply (frule (3) vspace_for_asid_is_subject) + apply safe + apply (frule vspace_for_asid_vs_lookup) + apply (frule (6) pt_walk_reads_equiv[where bot_level=0]) + apply (rule order_refl) + apply (erule vs_lookup_table_vref_independent[OF _ order_refl]) + apply (clarsimp simp: pt_lookup_slot_from_level_def obind_def split: option.splits) + apply (fastforce elim!: pt_lookup_slot_from_level_is_subject + dest: vspace_for_asid_vs_lookup vs_lookup_table_vref_independent)+ + done + +lemma perform_flush_reads_respects: + "reads_respects aag l \ (perform_flush type vstart vend pstart space asid)" + unfolding perform_flush_def do_flush_def isb_def dsb_def + cleanCacheRange_PoU_def invalidateCacheRange_I_def + cleanInvalidateCacheRange_RAM_def cleanCacheRange_RAM_def invalidateCacheRange_RAM_def + by (cases type; wpsimp wp: dmo_mol_reads_respects when_ev simp: dmo_distr) + +lemma perform_page_invocation_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag l (pas_refined aag and authorised_page_inv aag pgi and valid_page_inv pgi + and valid_vspace_objs and valid_asid_table + and pspace_aligned and is_subject aag \ cur_thread) + (perform_page_invocation pgi)" + unfolding perform_page_invocation_def fun_app_def when_def perform_pg_inv_map_def + perform_pg_inv_unmap_def perform_pg_inv_get_addr_def cleanByVA_PoU_def + apply (rule equiv_valid_guard_imp) + apply (wp dmo_mol_reads_respects mapM_x_ev'' store_pte_reads_respects set_cap_reads_respects + mapM_ev'' store_pte_reads_respects unmap_page_reads_respects + get_cap_rev set_mrs_reads_respects set_message_info_reads_respects + invalidate_tlb_by_asid_va_reads_respects get_pte_rev perform_flush_reads_respects + | simp add: dmo_distr + | wpc | wp (once) hoare_drop_imps[where Q'="\r s. r"])+ + apply (case_tac pgi; clarsimp simp: authorised_page_inv_def valid_page_inv_def) + apply (auto simp: cte_wp_at_caps_of_state authorised_slots_def cap_links_asid_slot_def + label_owns_asid_slot_def valid_arch_cap_def wellformed_mapdata_def + dest!: clas_caps_of_state pas_refined_Control) + done + +lemma equiv_asids_arm_asid_table_update: + "\ equiv_asids R s t; kheap s pool_ptr = kheap t pool_ptr \ + \ equiv_asids R + (s\arch_state := arch_state s\arm_asid_table := (asid_table s) + (asid_high_bits_of asid \ pool_ptr)\\) + (t\arch_state := arch_state t\arm_asid_table := (asid_table t) + (asid_high_bits_of asid \ pool_ptr)\\)" + by (clarsimp simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap opt_map_def) + +lemma arm_asid_table_update_reads_respects: + "reads_respects aag l (K (is_subject aag pool_ptr)) + (do r \ gets asid_table; + modify (\s. s\arch_state := + arch_state s\arm_asid_table := r(asid_high_bits_of asid \ pool_ptr)\\) + od)" + apply (simp add: equiv_valid_def2) + apply (rule_tac W="\\" + and Q="\rv s. is_subject aag pool_ptr \ rv = arm_asid_table (arch_state s)" + in equiv_valid_rv_bind) + apply (rule equiv_valid_rv_guard_imp[OF equiv_valid_rv_trivial]) + apply wpsimp+ + apply (rule modify_ev2) + apply clarsimp + apply (drule (1) is_subject_kheap_eq[rotated]) + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def + equiv_for_def equiv_hyp_def equiv_fpu_def) + apply (fastforce intro!: equiv_asids_arm_asid_table_update) + apply wpsimp + done + +lemma perform_asid_control_invocation_reads_respects: + notes K_bind_ev[wp del] + shows "reads_respects aag l (invs and ct_active and valid_aci aci and K (authorised_asid_control_inv aag aci)) + (perform_asid_control_invocation aci)" + unfolding perform_asid_control_invocation_def + apply (rule gen_asm_ev) + apply (rule equiv_valid_guard_imp) + (* we do some hacky rewriting here to separate out the bit that does interesting stuff from the rest *) + apply (subst (6) my_bind_rewrite_lemma) + apply (subst (1) bind_assoc[symmetric]) + apply (subst another_hacky_rewrite) + apply (subst another_hacky_rewrite) + apply (wpc) + apply (rule bind_ev) + apply (rule K_bind_ev) + apply (rule_tac bind_ev) + apply (rule K_bind_ev) + apply (rule bind_ev) + apply (rule bind_ev) + apply (rule return_ev) + apply (rule K_bind_ev) + apply simp + apply (rule arm_asid_table_update_reads_respects) + apply (wp cap_insert_reads_respects retype_region_reads_respects + set_cap_reads_respects delete_objects_reads_respects get_cap_rev + | simp add: authorised_asid_control_inv_def)+ + apply (auto dest!: is_aligned_no_overflow) + done + +lemma set_asid_pool_reads_respects: + "reads_respects aag l (K (is_subject aag ptr)) (set_asid_pool ptr pool)" + unfolding set_asid_pool_def + by (wpsimp wp: set_object_reads_respects get_asid_pool_rev) + +lemma set_asid_pool_globals_equiv: + "\globals_equiv s and valid_global_arch_objs\ + set_asid_pool ptr pool + \\_. globals_equiv s\" + unfolding set_asid_pool_def + apply (wpsimp wp: set_object_globals_equiv[THEN hoare_set_object_weaken_pre] simp: a_type_def) + apply (fastforce simp: obj_at_def dest: valid_global_arch_objs_pt_at) + done + +lemma perform_asid_pool_invocation_reads_respects_g: + "reads_respects_g aag l (pas_refined aag and invs and K (authorised_asid_pool_inv aag api)) + (perform_asid_pool_invocation api)" + unfolding perform_asid_pool_invocation_def store_asid_pool_entry_def + apply (rule equiv_valid_guard_imp) + apply (wpsimp wp: reads_respects_g[OF set_asid_pool_reads_respects] + reads_respects_g[OF get_asid_pool_rev] + set_asid_pool_globals_equiv set_cap_reads_respects + doesnt_touch_globalsI get_cap_auth_wp[where aag=aag] get_cap_rev + set_cap_reads_respects_g get_cap_reads_respects_g + | strengthen valid_arch_state_global_arch_objs + | wp (once) hoare_drop_imps)+ + apply (clarsimp simp: invs_arch_state invs_valid_global_objs invs_psp_aligned + invs_valid_global_vspace_mappings authorised_asid_pool_inv_def) + done + +lemma equiv_asids_arm_asid_table_delete: + "equiv_asids R s t + \ equiv_asids R + (s\arch_state := arch_state s\arm_asid_table := \a. if a = asid_high_bits_of asid then None + else arm_asid_table (arch_state s) a\\) + (t\arch_state := arch_state t\arm_asid_table := \a. if a = asid_high_bits_of asid then None + else arm_asid_table (arch_state t) a\\)" + by (clarsimp simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap) + +lemma arm_asid_table_delete_ev2: + "equiv_valid_2 (reads_equiv aag) (affects_equiv aag l) (affects_equiv aag l) \\ + (\s. rv = arm_asid_table (arch_state s)) (\s. rv' = arm_asid_table (arch_state s)) + (modify (\s. s\arch_state := arch_state s\arm_asid_table := \a. if a = asid_high_bits_of base + then None + else rv a\\)) + (modify (\s. s\arch_state := arch_state s\arm_asid_table := \a. if a = asid_high_bits_of base + then None + else rv' a\\))" + apply (rule modify_ev2) + (* slow 15s *) + by (auto simp: reads_equiv_def2 affects_equiv_def2 equiv_hyp_def + equiv_fpu_def equiv_for_def get_tcb_def cur_fpu_for_def + intro!: states_equiv_forI equiv_forI equiv_asids_arm_asid_table_delete + elim!: states_equiv_forE equiv_forE + elim: is_subject_kheap_eq[simplified reads_equiv_def2 states_equiv_for_def, rotated]) + +lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq': + "\ (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of base + \ is_subject_asid aag asid'); reads_equiv aag s t \ + \ arm_asid_table (arch_state s) (asid_high_bits_of base) = + arm_asid_table (arch_state t) (asid_high_bits_of base)" + apply (insert asid_high_bits_0_eq_1) + apply (case_tac "base = 0") + apply (subgoal_tac "is_subject_asid aag 1") + apply (simp del: asid_high_bits_of_0) + apply (rule requiv_arm_asid_table_asid_high_bits_of_asid_eq[where aag=aag]) + apply (erule_tac x=1 in allE) + apply simp+ + apply (rule requiv_arm_asid_table_asid_high_bits_of_asid_eq[where aag=aag]) + apply (erule_tac x=base in allE) + apply simp+ + done + +lemma states_equiv_for_asid_map_update[simp]: + "states_equiv_for P Q R S st (s\arch_state := arch_state s\arm_asid_map := asid_map'\\) = + states_equiv_for P Q R S st s" + by (auto simp: states_equiv_for_def equiv_for_def equiv_hyp_def equiv_fpu_def get_tcb_def cur_fpu_for_def + intro: equiv_asids_triv' split: if_splits) + +lemma states_equiv_for_vmid_table_update[simp]: + "states_equiv_for P Q R S st (s\arch_state := arch_state s\arm_vmid_table := table\\) = + states_equiv_for P Q R S st s" + by (auto simp: states_equiv_for_def equiv_for_def equiv_hyp_def equiv_fpu_def get_tcb_def cur_fpu_for_def + intro: equiv_asids_triv' split: if_splits) + +lemma states_equiv_for_next_vmid_update[simp]: + "states_equiv_for P Q R S st (s\arch_state := arch_state s\arm_next_vmid := vmid\\) = + states_equiv_for P Q R S st s" + by (auto simp: states_equiv_for_def equiv_for_def equiv_hyp_def equiv_fpu_def get_tcb_def cur_fpu_for_def + intro: equiv_asids_triv' split: if_splits) + +crunch get_vmid + for states_equiv_for[wp]: "states_equiv_for P Q R S st" + (wp: do_machine_op_mol_states_equiv_for ignore: do_machine_op simp: invalidateTranslationASID_def) + +lemma set_vm_root_states_equiv_for: + "set_vm_root thread \states_equiv_for P Q R S st\" + unfolding set_vm_root_def catch_def fun_app_def set_global_user_vspace_def arm_context_switch_def + by (wpsimp wp: do_machine_op_mol_states_equiv_for + hoare_vcg_all_lift whenE_wp hoare_drop_imps + simp: setVSpaceRoot_def dmo_bind_valid if_apply_def2)+ + +crunch invalidate_asid_entry + for states_equiv_for[wp]: "states_equiv_for P Q R S st" + +crunch invalidate_asid_entry + for sched_act[wp]: "\s. P (scheduler_action s)" + +crunch invalidate_asid_entry + for wuc[wp]: "\s. P (work_units_completed s)" + +lemma delete_asid_pool_reads_respects: + "reads_respects aag l (K (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of base + \ is_subject_asid aag asid')) + (delete_asid_pool base ptr)" + unfolding delete_asid_pool_def + apply (rule equiv_valid_guard_imp) + apply (rule bind_ev) + apply (simp) + apply (subst equiv_valid_def2) + apply (rule_tac W="\\" + and Q="\rv s. rv = arm_asid_table (arch_state s) \ + (\asid'. asid' \ 0 \ asid_high_bits_of asid' = asid_high_bits_of base + \ is_subject_asid aag asid')" + in equiv_valid_rv_bind) + apply (rule equiv_valid_rv_guard_imp[OF equiv_valid_rv_trivial]) + apply (wp, simp) + apply (simp add: when_def) + apply (clarsimp | rule conjI)+ + apply (rule equiv_valid_2_guard_imp) + apply (rule equiv_valid_2_bind) + apply (rule equiv_valid_2_bind) + apply (rule equiv_valid_2_bind) + apply (rule equiv_valid_2_unobservable) + apply (wp set_vm_root_states_equiv_for)+ + apply (rule arm_asid_table_delete_ev2) + apply (wp)+ + apply (rule equiv_valid_2_unobservable) + apply (wpsimp wp: mapM_wp_inv)+ + apply (rule equiv_valid_2_unobservable) + by (wp mapM_wp' return_ev2 + | rule conjI | drule (1) requiv_arm_asid_table_asid_high_bits_of_asid_eq' + | clarsimp | simp add: equiv_valid_2_def)+ + +lemma set_asid_pool_state_equal_except_kheap: + "((), s') \ fst (set_asid_pool ptr pool s) + \ states_equal_except_kheap_asid s s' \ + (\p. p \ ptr \ kheap s p = kheap s' p) \ + asid_pools_of s' ptr = Some pool \ + (\asid. asid \ 0 + \ arm_asid_table (arch_state s) (asid_high_bits_of asid) = + arm_asid_table (arch_state s') (asid_high_bits_of asid) \ + (\pool_ptr. arm_asid_table (arch_state s) (asid_high_bits_of asid) = + Some pool_ptr + \ asid_pool_at pool_ptr s = asid_pool_at pool_ptr s' \ + (\asid_pool asid_pool'. pool_ptr \ ptr + \ asid_pools_of s pool_ptr = + Some asid_pool \ + asid_pools_of s' pool_ptr = + Some asid_pool' + \ asid_pool (asid_low_bits_of asid) = + asid_pool' (asid_low_bits_of asid))))" + by (clarsimp simp: set_asid_pool_def put_def bind_def set_object_def get_object_def gets_map_def + gets_def get_def return_def assert_def assert_opt_def fail_def + states_equal_except_kheap_asid_def equiv_for_def obj_at_def + split: if_split_asm option.split_asm) + +lemma set_asid_pool_delete_ev2: + "equiv_valid_2 (reads_equiv aag) (affects_equiv aag l) (affects_equiv aag l) \\ + (\s. arm_asid_table (arch_state s) (asid_high_bits_of asid) = Some a \ + asid_pools_of s a = Some pool \ asid \ 0 \ is_subject_asid aag asid) + (\s. arm_asid_table (arch_state s) (asid_high_bits_of asid) = Some a \ + asid_pools_of s a = Some pool' \ asid \ 0 \ is_subject_asid aag asid) + (set_asid_pool a (pool(asid_low_bits_of asid := None))) + (set_asid_pool a (pool'(asid_low_bits_of asid := None)))" + apply (clarsimp simp: equiv_valid_2_def) + apply (erule use_valid) + apply (wpsimp simp: set_asid_pool_def wp: set_object_wp) + apply clarsimp + apply (erule use_valid) + apply (wpsimp simp: set_asid_pool_def wp: set_object_wp) + apply clarsimp + apply (prop_tac "aag_can_read aag a \ aag_can_affect aag l a \ pool = pool'") + apply (erule reads_equivE) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply clarsimp + apply (clarsimp simp: equiv_for_def) + apply (erule affects_equivE) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply clarsimp + apply (clarsimp simp: opt_map_def split: option.splits) + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def) + apply (clarsimp simp: equiv_asids_def equiv_asid_def obj_at_def opt_map_def | rule conjI)+ + done + +lemma delete_asid_reads_respects: + "reads_respects aag l (K (asid \ 0 \ is_subject_asid aag asid)) (delete_asid asid pt)" + unfolding delete_asid_def + supply fun_upd_apply[simp del] + apply (subst equiv_valid_def2) + apply (rule_tac W="\\" and Q="\rv s. rv = asid_table s (asid_high_bits_of asid) \ + is_subject_asid aag asid \ asid \ 0" in equiv_valid_rv_bind) + apply (rule equiv_valid_rv_guard_imp[OF equiv_valid_rv_trivial]) + apply (wp, simp) + apply (case_tac "rv = rv'") + apply (simp) + apply (case_tac "rv") + apply (simp) + apply (wp return_ev2, simp) + apply (simp) + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. rv (asid_low_bits_of asid) = rv' (asid_low_bits_of asid)" + in equiv_valid_2_bind) + apply (simp add: when_def) + apply (clarsimp | rule conjI)+ + apply (rule_tac R'="\\" in equiv_valid_2_bind) + apply (rule_tac R'="\\" in equiv_valid_2_bind) + apply (rule_tac R'="\\" in equiv_valid_2_bind) + apply (rule_tac R'="\\" in equiv_valid_2_bind) + apply (subst equiv_valid_def2[symmetric]) + apply (rule reads_respects_unobservable_unit_return) + apply (wp set_vm_root_states_equiv_for)+ + apply (rule set_asid_pool_delete_ev2) + apply (wp)+ + apply (rule equiv_valid_2_unobservable) + apply (wpsimp wp: do_machine_op_mol_states_equiv_for invalidate_tlb_by_asid_reads_respects)+ + apply (rule equiv_valid_2_unobservable) + apply wpsimp+ + apply (wpsimp wp: hoare_vcg_imp_lift')+ + apply (rule equiv_valid_2_unobservable) + apply (wpsimp wp: hoare_vcg_imp_lift')+ + apply (clarsimp | rule return_ev2)+ + apply (rule equiv_valid_2_guard_imp) + apply (wp get_asid_pool_revrv) + apply (simp)+ + apply (wp)+ + apply (clarsimp simp: obj_at_def)+ + apply (clarsimp simp: equiv_valid_2_def reads_equiv_def + equiv_asids_def equiv_asid_def states_equiv_for_def) + apply (erule_tac x="pasASIDAbs aag asid" in ballE) + apply (clarsimp) + apply (drule aag_can_read_own_asids) + apply wpsimp+ + apply (clarsimp simp: pool_for_asid_def) + done + +lemma globals_equiv_arm_asid_map_update[simp]: + "globals_equiv s (t\arch_state := arch_state t\arm_asid_map := x\\) = globals_equiv s t" + by (simp add: globals_equiv_def) + +lemma globals_equiv_arm_asid_table_update[simp]: + "globals_equiv s (t\arch_state := arch_state t\arm_asid_table := x\\) = globals_equiv s t" + by (simp add: globals_equiv_def) + +lemma globals_equiv_arm_vmid_table_update[simp]: + "globals_equiv s (t\arch_state := arch_state t\arm_vmid_table := x\\) = globals_equiv s t" + by (simp add: globals_equiv_def) + +lemma globals_equiv_arm_next_vmid_update[simp]: + "globals_equiv s (t\arch_state := arch_state t\arm_next_vmid := x\\) = globals_equiv s t" + by (simp add: globals_equiv_def) + +lemma valid_global_arch_objs_arm_asid_table_update[simp]: + "valid_global_arch_objs (s\arch_state := arch_state s\arm_asid_table := x\\) = valid_global_arch_objs s" + by (simp add: valid_global_arch_objs_def) + +lemma set_global_user_vspace_globals_equiv[wp]: + "set_global_user_vspace \globals_equiv s\" + unfolding set_global_user_vspace_def setVSpaceRoot_def + by wpsimp + +lemma update_asid_pool_entry_globals_equiv[wp]: + "\globals_equiv s and valid_global_arch_objs\ + update_asid_pool_entry f asid + \\_. globals_equiv s\" + unfolding update_asid_pool_entry_def + by (wpsimp wp: set_asid_pool_globals_equiv) + +crunch invalidate_vmid_entry, invalidate_asid + for globals_equiv[wp]: "globals_equiv st" + (wp: crunch_wps dmo_mol_reads_respects simp: crunch_simps) + +lemma find_free_vmid_globals_equiv[wp]: + "\globals_equiv s and valid_global_arch_objs\ + find_free_vmid + \\_. globals_equiv s\" + unfolding find_free_vmid_def invalidateTranslationASID_def + by wpsimp + +crunch get_vmid + for globals_equiv[wp]: "globals_equiv st" + (wp: crunch_wps dmo_mol_reads_respects simp: crunch_simps) + +lemma arm_context_switch_globals_equiv[wp]: + "\globals_equiv s and valid_global_arch_objs\ + arm_context_switch vspace asid + \\_. globals_equiv s\" + unfolding arm_context_switch_def setVSpaceRoot_def + by (wpsimp wp: dmo_mol_reads_respects) + +lemma set_vm_root_globals_equiv[wp]: + "\globals_equiv s and valid_global_arch_objs\ + set_vm_root tcb + \\_. globals_equiv s\" + by (wpsimp wp: dmo_mol_globals_equiv hoare_vcg_all_lift hoare_drop_imps + simp: set_vm_root_def setVSpaceRoot_def) + +crunch invalidate_asid_entry + for globals_equiv[wp]: "globals_equiv st" + (wp: crunch_wps dmo_mol_reads_respects simp: crunch_simps) + +lemma invalidate_tlb_by_asid_globals_equiv[wp]: + "invalidate_tlb_by_asid asid \globals_equiv s\" + unfolding invalidate_tlb_by_asid_def invalidateTranslationASID_def + by wpsimp + +lemma invalidate_tlb_by_asid_va_globals_equiv[wp]: + "invalidate_tlb_by_asid_va asid vaddr \globals_equiv s\" + unfolding invalidate_tlb_by_asid_va_def invalidateTranslationSingle_def + by wpsimp + +lemma delete_asid_pool_globals_equiv[wp]: + "\globals_equiv s and valid_global_arch_objs\ + delete_asid_pool base ptr + \\_. globals_equiv s\" + unfolding delete_asid_pool_def + by (wpsimp wp: set_vm_root_globals_equiv mapM_wp[OF _ subset_refl] modify_wp) + +lemma vs_lookup_slot_not_global: + "\ vs_lookup_slot level asid vref s = Some (level, pte); level \ max_pt_level; + pte_refs_of (level_type level) pte s = Some pt; vref \ user_region; invs s \ + \ pt \ global_refs s" + apply (prop_tac "vs_lookup_target level asid vref s = Some (level, pt)") + apply (clarsimp simp: vs_lookup_target_def obind_def split: if_splits) + apply (erule (2) vs_lookup_target_not_global) + done + +lemma unmap_page_table_globals_equiv: + "\invs and globals_equiv st and K (vaddr \ user_region)\ + unmap_page_table asid vaddr pt + \\rv. globals_equiv st\" + unfolding unmap_page_table_def cleanByVA_PoU_def + apply (wp store_pte_globals_equiv pt_lookup_from_level_wrp | wpc | simp)+ + apply clarsimp + apply (rule_tac x=asid in exI) + apply clarsimp + apply (case_tac "level = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) + apply (drule vs_lookup_slot_table_base; clarsimp) + apply (drule reachable_page_table_not_global, clarsimp+) + done + +lemma mapM_x_swp_store_pte_globals_equiv: + "\globals_equiv s and pspace_aligned and valid_arch_state and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base pt_t x \ global_refs s)\ + mapM_x (swp (store_pte pt_t) pte) slots + \\_. globals_equiv s\" + apply (rule_tac Q'="\_. pspace_aligned and globals_equiv s and valid_arch_state + and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base pt_t x \ global_refs s)" + in hoare_strengthen_post) + apply (wp mapM_x_wp' store_pte_valid_arch_state_unreachable + store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ + apply (auto simp: global_refs_def) + done + +lemma mapM_x_swp_store_pte_valid_ko_at_arch[wp]: + "\pspace_aligned and valid_arch_state and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base pt_t x \ global_refs s)\ + mapM_x (swp (store_pte pt_t) pte) slots + \\_. valid_arch_state\" + apply (rule_tac Q'="\_. pspace_aligned and valid_arch_state and valid_global_vspace_mappings + and (\s. \x \ set slots. table_base pt_t x \ global_refs s)" + in hoare_strengthen_post) + apply (wp mapM_x_wp' store_pte_valid_arch_state_unreachable + store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ + done + + +definition authorised_for_globals_page_table_inv :: + "page_table_invocation \ 's :: state_ext state \ bool" where + "authorised_for_globals_page_table_inv pti \ \s. + case pti of PageTableMap cap ptr pte p lvl \ table_base (level_type lvl) p \ arm_us_global_vspace (arch_state s) + | _ \ True" + +lemma perform_pt_inv_map_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. table_base (level_type lvl) p \ global_pt s)\ + perform_pt_inv_map cap sl pte p lvl + \\_. globals_equiv st\" + unfolding perform_pt_inv_map_def cleanByVA_PoU_def + by (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv) + +lemma perform_pt_inv_unmap_globals_equiv: + "\invs and globals_equiv st and cte_wp_at ((=) (ArchObjectCap cap)) ct_slot\ + perform_pt_inv_unmap cap ct_slot + \\_. globals_equiv st\" + unfolding perform_pt_inv_unmap_def cleanCacheRange_PoU_def + apply (wpsimp wp: set_cap_globals_equiv mapM_x_swp_store_pte_globals_equiv) + apply (strengthen invs_imps invs_valid_global_vspace_mappings) + apply (clarsimp cong: conj_cong) + apply (wpsimp wp: unmap_page_table_globals_equiv unmap_page_table_invs) + apply wpsimp+ + apply (intro conjI) + apply (drule cte_wp_valid_cap, fastforce) + apply (clarsimp simp: is_PageTableCap_def valid_cap_def valid_arch_cap_def wellformed_mapdata_def) + apply (frule cte_wp_valid_cap, fastforce) + apply (clarsimp simp: is_PageTableCap_def valid_cap_def valid_arch_cap_def wellformed_mapdata_def) + apply (prop_tac "table_base x42 x = acap_obj cap") + apply (prop_tac "is_aligned x41 (pt_bits x42)") + apply (fastforce dest: is_aligned_pt simp: valid_arch_cap_def) + apply (simp only: is_aligned_neg_mask_eq') + apply (clarsimp simp: add_mask_fold) + apply (drule subsetD[OF upto_enum_step_subset], clarsimp) + apply (drule_tac n="pt_bits x42" in neg_mask_mono_le) + apply (drule_tac n="pt_bits x42" in neg_mask_mono_le) + apply (fastforce dest: plus_mask_AND_NOT_mask_eq) + apply clarsimp + apply (frule invs_valid_global_refs) + apply (drule (2) valid_global_refsD[OF invs_valid_global_refs]) + apply (clarsimp simp: cap_range_def) + done + +lemma perform_page_table_invocation_globals_equiv: + "\invs and globals_equiv st and valid_pti pti and authorised_for_globals_page_table_inv pti\ + perform_page_table_invocation pti + \\_. globals_equiv st\" + unfolding perform_page_table_invocation_def + apply (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv + perform_pt_inv_map_globals_equiv + perform_pt_inv_unmap_globals_equiv) + apply (case_tac pti; clarsimp simp: authorised_for_globals_page_table_inv_def valid_pti_def) + done + +lemma mapM_swp_store_pte_globals_equiv: + "\globals_equiv s and (\s. \x \ set slots. table_base pt_t x \ global_refs s)\ + mapM (swp (store_pte pt_t) pte) slots + \\_. globals_equiv s\" + apply (rule_tac Q'="\_. globals_equiv s and (\s. \x \ set slots. table_base pt_t x \ global_refs s)" + in hoare_strengthen_post) + apply (wp mapM_wp' store_pte_valid_arch_state_unreachable + store_pte_valid_global_vspace_mappings store_pte_globals_equiv | simp)+ + apply (auto simp: global_refs_def) + done + +lemma unmap_page_globals_equiv: + "\globals_equiv st and invs and K (vptr \ user_region)\ + unmap_page pgsz asid vptr pptr + \\_. globals_equiv st\" + unfolding unmap_page_def cleanByVA_PoU_def including no_pre + apply (induct pgsz) + apply (wpsimp wp: store_pte_globals_equiv | simp)+ + apply (rule hoare_weaken_preE[OF find_vspace_for_asid_wp]) + apply clarsimp + apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) + apply (drule vs_lookup_slot_table_base; clarsimp?) + apply (drule reachable_page_table_not_global; clarsimp?) + apply fastforce + apply (rule hoare_pre) + apply (wpsimp wp: store_pte_globals_equiv mapM_swp_store_pte_globals_equiv hoare_drop_imps)+ + apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) + apply (drule vs_lookup_slot_level) + apply (case_tac "x = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) + apply (drule vs_lookup_slot_table_base; clarsimp?) + apply (drule reachable_page_table_not_global; clarsimp?) + apply fastforce + apply (wpsimp wp: store_pte_globals_equiv)+ + apply (rule hoare_weaken_preE[OF find_vspace_for_asid_wp]) + apply clarsimp + apply (frule (1) pt_lookup_slot_vs_lookup_slotI0) + apply (drule vs_lookup_slot_level) + apply (case_tac "x = asid_pool_level") + apply (fastforce dest: vs_lookup_slot_no_asid simp: ptes_of_Some valid_arch_state_asid_table) + apply (drule vs_lookup_slot_table_base; clarsimp?) + apply (drule reachable_page_table_not_global; clarsimp?) + apply fastforce + done + + +definition authorised_for_globals_page_inv :: + "page_invocation \ 'z :: state_ext state \ bool" where + "authorised_for_globals_page_inv pgi \ \s. + case pgi of PageMap cap ptr m \ (\slot. cte_wp_at (parent_for_refs m) slot s) | _ \ True" + +lemma length_msg_lt_msg_max: + "length msg_registers < msg_max_length" + by (simp add: msg_registers_def msgRegisters_def upto_enum_def + fromEnum_def enum_register msg_max_length_def) + +lemma set_mrs_globals_equiv: + "\globals_equiv s and valid_arch_state and (\sa. thread \ idle_thread sa)\ + set_mrs thread buf msgs + \\_. globals_equiv s\" + unfolding set_mrs_def + apply (wp | wpc)+ + apply (simp add: zipWithM_x_mapM_x) + apply (rule conjI) + apply (rule impI) + apply (rule_tac Q'="\_. globals_equiv s" in hoare_strengthen_post) + apply (wp mapM_x_wp') + apply (simp add: split_def) + apply (wp store_word_offs_globals_equiv) + apply (simp) + apply (clarsimp) + apply (insert length_msg_lt_msg_max) + apply (simp) + apply (wp set_object_globals_equiv hoare_weak_lift_imp) + apply (wp hoare_vcg_all_lift set_object_globals_equiv hoare_weak_lift_imp)+ + apply (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def + dest: valid_global_arch_objs_pt_at) + done + +lemma perform_pg_inv_get_addr_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. cur_thread s \ idle_thread s)\ + perform_pg_inv_get_addr ptr + \\_. globals_equiv st\" + unfolding perform_pg_inv_get_addr_def + by (wpsimp wp: set_message_info_globals_equiv set_mrs_globals_equiv) + +crunch unmap_page + for valid_global_arch_objs[wp]: "valid_global_arch_objs" + (wp: crunch_wps simp: crunch_simps) + +lemma perform_pg_inv_unmap_globals_equiv: + "\invs and globals_equiv st and cte_wp_at ((=) (ArchObjectCap cap)) ct_slot\ + perform_pg_inv_unmap cap ct_slot + \\_. globals_equiv st\" + unfolding perform_pg_inv_unmap_def + apply (rule hoare_weaken_pre) + apply (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv + set_cap_globals_equiv' unmap_page_globals_equiv store_pte_globals_equiv + store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv + perform_pg_inv_get_addr_globals_equiv + | wpc | simp add: do_machine_op_bind)+ + apply (clarsimp simp: acap_map_data_def) + apply (intro conjI; clarsimp) + apply (clarsimp split: arch_cap.splits) + apply (drule cte_wp_valid_cap, fastforce) + apply (clarsimp simp: valid_cap_def valid_arch_cap_def wellformed_mapdata_def) + done + +lemma perform_pg_inv_map_globals_equiv: + "\invs and globals_equiv st and (\s. table_base (level_type lvl) slot \ global_pt s)\ + perform_pg_inv_map cap ct_slot pte slot lvl + \\_. globals_equiv st\" + unfolding perform_pg_inv_map_def cleanByVA_PoU_def + apply (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv + set_cap_globals_equiv' unmap_page_globals_equiv store_pte_globals_equiv + store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv + perform_pg_inv_get_addr_globals_equiv + | wpc | simp add: do_machine_op_bind | rule conjI; rule impI, wp hoare_drop_imps)+ + apply fastforce + done + +lemma perform_flush_globals_equiv[wp]: + "perform_flush type vstart vend pstart space asid \globals_equiv st\" + unfolding perform_flush_def do_flush_def cleanCacheRange_RAM_def invalidateCacheRange_RAM_def + cleanInvalidateCacheRange_RAM_def cleanCacheRange_PoU_def invalidateCacheRange_I_def isb_def dsb_def + by (cases type; wpsimp wp: dmo_mol_reads_respects when_ev simp: dmo_distr) + +lemma perform_page_invocation_globals_equiv: + "\invs and authorised_for_globals_page_inv pgi and valid_page_inv pgi + and globals_equiv st and ct_active\ + perform_page_invocation pgi + \\_. globals_equiv st\" + unfolding perform_page_invocation_def + apply (wpsimp wp: perform_pg_inv_get_addr_globals_equiv + perform_pg_inv_unmap_globals_equiv perform_pg_inv_map_globals_equiv) + apply (intro conjI) + apply (clarsimp simp: valid_page_inv_def same_ref_def) + apply (drule vs_lookup_slot_table_base; clarsimp) + apply (drule reachable_page_table_not_global, clarsimp+) + apply (clarsimp simp: valid_page_inv_def) + apply clarsimp + apply (fastforce dest: invs_valid_idle + simp: valid_idle_def pred_tcb_at_def obj_at_def ct_in_state_def) + done + +lemma retype_region_ASIDPoolObj_globals_equiv: + "\globals_equiv s and (\sa. ptr \ global_pt s) and (\sa. ptr \ idle_thread sa)\ + retype_region ptr 1 0 (ArchObject ASIDPoolObj) dev + \\_. globals_equiv s\" + unfolding retype_region_def + apply (wpsimp wp: modify_wp dxo_wp_weak + simp: trans_state_update[symmetric] simp_del: trans_state_update) + apply (fastforce simp: globals_equiv_def idle_equiv_def tcb_at_def2) + done + +lemma perform_asid_control_invocation_globals_equiv: + notes delete_objects_invs[wp del] + notes blah[simp del] = atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + shows "\globals_equiv s and invs and ct_active and valid_aci aci\ + perform_asid_control_invocation aci + \\_. globals_equiv s\" + unfolding perform_asid_control_invocation_def + apply (rule hoare_pre) + apply wpc + apply (rename_tac word1 cslot_ptr1 cslot_ptr2 word2) + apply (wp modify_wp cap_insert_globals_equiv + retype_region_ASIDPoolObj_globals_equiv[simplified] + retype_region_invs_extras(5)[where sz=pageBits] + retype_region_invs_extras(6)[where sz=pageBits] + set_cap_globals_equiv + max_index_upd_invs_simple set_cap_no_overlap + set_cap_caps_no_overlap max_index_upd_caps_overlap_reserved + region_in_kernel_window_preserved + hoare_vcg_all_lift get_cap_wp hoare_weak_lift_imp + set_cap_idx_up_aligned_area[where dev = False,simplified] + | simp)+ + (* factor out the implication -- we know what the relevant components of the + cap referred to in the cte_wp_at are anyway from valid_aci, so just use + those directly to simplify the reasoning later on *) + apply (rule_tac Q'="\a b. globals_equiv s b \ invs b \ + word1 \ arm_us_global_vspace (arch_state b) \ word1 \ idle_thread b \ + (\idx. cte_wp_at ((=) (UntypedCap False word1 pageBits idx)) cslot_ptr2 b) \ + descendants_of cslot_ptr2 (cdt b) = {} \ + pspace_no_overlap_range_cover word1 pageBits b" + in hoare_strengthen_post) + prefer 2 + apply (clarsimp simp: globals_equiv_def invs_valid_global_objs) + apply (drule cte_wp_at_eqD2, assumption) + apply clarsimp + apply (clarsimp simp: empty_descendants_range_in) + apply (rule conjI, fastforce simp: cte_wp_at_def) + apply (clarsimp simp: obj_bits_api_def default_arch_object_def) + apply (frule untyped_cap_aligned, simp add: invs_valid_objs) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (strengthen refl caps_region_kernel_window_imp[mk_strg I E]) + apply (simp add: invs_valid_objs invs_cap_refs_in_kernel_window + atLeastatMost_subset_iff word_and_le2 + cong: conj_cong) + apply (rule conjI, rule descendants_range_caps_no_overlapI) + apply assumption + apply (simp add: cte_wp_at_caps_of_state) + apply (simp add: empty_descendants_range_in) + apply (clarsimp simp: range_cover_def) + apply (subst is_aligned_neg_mask_eq[THEN sym], assumption) + apply (simp add: word_bw_assocs pageBits_def mask_zero) + apply (wp add: delete_objects_invs_ex delete_objects_pspace_no_overlap[where dev=False] + delete_objects_globals_equiv hoare_vcg_ex_lift + del: Untyped_AI.delete_objects_pspace_no_overlap | simp)+ + apply (clarsimp simp: conj_comms + invs_psp_aligned invs_valid_objs valid_aci_def) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (frule_tac cap="UntypedCap False a b c" for a b c in caps_of_state_valid, assumption) + apply (clarsimp simp: valid_cap_def cap_aligned_def untyped_min_bits_def) + apply (frule_tac slot="(aa,ba)" + in untyped_caps_do_not_overlap_global_refs[rotated, OF invs_valid_global_refs]) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply ((rule conjI |rule refl | simp)+)[1] + apply (rule conjI) + apply (clarsimp simp: global_refs_def ptr_range_memI) + apply (rule conjI) + apply clarify + apply (drule_tac p="global_pt sa" in ptr_range_memI) + apply fastforce + apply (rule conjI, fastforce simp: global_refs_def) + apply (rule conjI) + apply clarify + apply fastforce + apply (rule conjI) + apply (drule untyped_slots_not_in_untyped_range) + apply (blast intro!: empty_descendants_range_in) + apply (simp add: cte_wp_at_caps_of_state) + apply simp + apply (rule refl) + apply (rule subset_refl) + apply (simp) + apply (rule conjI) + apply fastforce + apply (auto intro: empty_descendants_range_in simp: descendants_range_def2 cap_range_def) + done + +lemma store_asid_pool_entry_globals_equiv: + "\globals_equiv st and valid_arch_state\ + store_asid_pool_entry pool_ptr asid ptr + \\_. globals_equiv st\" + unfolding store_asid_pool_entry_def + by (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv get_cap_wp | wpc | fastforce)+ + +lemma perform_asid_pool_invocation_globals_equiv: + "\globals_equiv s and invs and valid_apinv api\ + perform_asid_pool_invocation api + \\_. globals_equiv s\" + unfolding perform_asid_pool_invocation_def + apply (rule hoare_weaken_pre) + apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv + store_asid_pool_entry_globals_equiv get_cap_wp + | wpc | simp)+ + apply (clarsimp simp: valid_apinv_def cong: conj_cong) + done + +crunch perform_vspace_invocation + for globals_equiv[wp]: "globals_equiv st" + (simp: sendSGI_def wp: dmo_mol_globals_equiv) + +lemma perform_sgi_invocation_globals_equiv[wp]: + "perform_sgi_invocation iv \globals_equiv s\" + unfolding perform_sgi_invocation_def sendSGI_def + by wpsimp + +lemma perform_vspace_invocation_reads_respects: + "reads_respects aag l \ (perform_vspace_invocation iv)" + unfolding perform_vspace_invocation_def + by (cases iv; wpsimp wp: perform_flush_reads_respects) + + +(* Helpful groupings *) + +definition vcpu_enable_2 where + "vcpu_enable_2 vr \ do + vcpu_enable vr; + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr, True)\\) + od" + +definition vcpu_restore_2 where + "vcpu_restore_2 vr \ do + vcpu_restore vr; + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr, True)\\) + od" + +definition vcpu_disable_2 where + "vcpu_disable_2 vr \ do + vcpu_disable (Some vr); + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr, False)\\) + od" + +definition vcpu_save_hcr where + "vcpu_save_hcr vr \ do + hcr <- do_machine_op get_gic_vcpu_ctrl_hcr; + vgic_update vr (vgic_hcr_update (\_. hcr)) + od" + +definition vcpu_save_vmcr where + "vcpu_save_vmcr vr \ do + vmcr <- do_machine_op get_gic_vcpu_ctrl_vmcr; + vgic_update vr (vgic_vmcr_update (\_. vmcr)) + od" + +definition vcpu_save_apr where + "vcpu_save_apr vr \ do + apr <- do_machine_op get_gic_vcpu_ctrl_apr; + vgic_update vr (vgic_apr_update (\_. apr)) + od" + +definition vcpu_save_lr where + "vcpu_save_lr vr reg \ do + lr <- do_machine_op (get_gic_vcpu_ctrl_lr (word_of_nat reg)); + vgic_update_lr vr reg lr + od" + +definition vcpu_save_lrs where + "vcpu_save_lrs vr \ do + lrs <- do num_list_regs <- gets (arm_gicvcpu_numlistregs \ arch_state); + return [0.. ('l \ bool) \ ('a \ 'b \ bool) \ (det_state \ bool) \ (det_state \ bool) \ + (det_state,'a) nondet_monad \ (det_state,'b) nondet_monad \ bool" + where + "states_equiv_valid_2 aag L \ equiv_valid_2 (\_ _. True) (states_equiv_for_labels aag L) + (states_equiv_for_labels aag L)" + +locale_abbrev states_equiv_valid :: + "'l PAS \ ('l \ bool) \ (det_state \ bool) \ (det_state,'a) nondet_monad \ bool" + where + "states_equiv_valid aag L \ equiv_valid_inv (\_ _. True) (states_equiv_for_labels aag L)" + +lemma states_equiv_valid_2_invisible: + "\ modifies_at_most aag {l. \L l} Q f; modifies_at_most aag {l. \L l} Q' g; + \P. f \\s. P (ready_queues s)\; \P. g \\s. P (ready_queues s)\; + \s t. P s \ P' t \ (\(rva,s') \ fst (f s). \(rvb,t') \ fst (g t). R rva rvb) \ + \ states_equiv_valid_2 aag L R (P and Q) (P' and Q') f g" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def modifies_at_most_def) + apply (rename_tac u s' v t') + apply (drule_tac x=s in spec) + apply (drule_tac x=t in spec) + apply (drule_tac x=s in spec) + apply (drule_tac x=t in spec) + apply clarsimp + apply (drule (1) bspec, clarsimp)+ + apply (prop_tac "states_equiv_for_labels aag L s s'") + apply (subgoal_tac "equiv_for (\x. \x\pasDomainAbs aag x. L x) ready_queues s s'") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def) + apply (clarsimp simp: equiv_for_def) + apply (erule use_valid, erule meta_allE, assumption) + apply simp + apply (prop_tac "states_equiv_for_labels aag L t t'") + apply (subgoal_tac "equiv_for (\x. \x\pasDomainAbs aag x. L x) ready_queues t t'") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def) + apply (clarsimp simp: equiv_for_def) + apply (erule use_valid, erule meta_allE, assumption) + apply (erule use_valid, erule meta_allE, assumption) + apply simp + by (drule (1) states_equiv_for_trans, + drule states_equiv_for_sym, + drule (1) states_equiv_for_trans, + drule states_equiv_for_sym, + solves simp) + +lemma states_equiv_valid_invisible: + "\ modifies_at_most aag {l. \L l} Q f; \P. f \\s. P (ready_queues s)\; + \s t. P s \ P t \ (\(rva,s') \ fst (f s). \(rvb,t') \ fst (f t). rva = rvb) \ + \ states_equiv_valid aag L (P and Q) f" + unfolding equiv_valid_def2 by (fastforce intro!: states_equiv_valid_2_invisible) + +lemma states_equiv_valid_unit_cases': + "\ states_equiv_valid aag L (P and K (L (pasObjectAbs aag ptr))) f; + modifies_at_most aag {pasObjectAbs aag ptr} Q f; \P. f \\s. P (ready_queues s)\ \ + \ states_equiv_valid aag L (if L (pasObjectAbs aag ptr) then P else Q) (f :: (det_state,unit) nondet_monad)" + apply (case_tac "L (pasObjectAbs aag ptr)") + apply (erule equiv_valid_guard_imp, clarsimp) + apply clarsimp + apply (rule states_equiv_valid_invisible[where P="\", simplified]) + apply (fastforce simp: modifies_at_most_def equiv_but_for_labels_def elim: states_equiv_for_guard_imp) + apply simp + apply simp + done + +lemmas states_equiv_valid_unit_cases = states_equiv_valid_unit_cases'[OF _ modifies_at_mostI] + +definition aag_can_affect_label_via where + "aag_can_affect_label_via aag l d \ aag_can_affect_label aag l \ d \ subjectReads (pasPolicy aag) l" + +locale_abbrev aag_can_read_or_affect_label where + "aag_can_read_or_affect_label aag l \ \d. + aag_can_read_label aag d \ aag_can_affect_label_via aag l d" + +(* The states_equiv_for parts of reads_respects *) +definition roa_equiv where + "roa_equiv aag l s s' \ states_equiv_for_labels aag (aag_can_read_or_affect_label aag l) s s'" + +(* The parts of reads_respects besides states_equiv_for *) +definition roa_inv where + "roa_inv s s' \ + cur_thread s = cur_thread s' \ + cur_domain s = cur_domain s' \ + scheduler_action s = scheduler_action s' \ + work_units_completed s = work_units_completed s' \ + equiv_irq_state (machine_state s) (machine_state s')" + +lemma reads_equiv_for_labels: + "reads_equiv aag s s' \ states_equiv_for_labels aag (aag_can_read_label aag) s s' \ roa_inv s s'" + by (auto simp: reads_equiv_def roa_inv_def states_equiv_for_def + equiv_for_def equiv_asids_def equiv_hyp_def equiv_fpu_def) + +lemma affects_equiv_for_labels: + "affects_equiv aag l s s' \ states_equiv_for_labels aag (aag_can_affect_label_via aag l) s s'" + by (auto intro: states_equiv_for_guard_imp[where P=\ and Q=\ and R=\ and S=\] + simp: affects_equiv_def aag_can_affect_label_via_def states_equiv_for_def + equiv_for_def equiv_asids_def equiv_hyp_False equiv_fpu_False) + +lemma roa_equiv_def2: + "roa_equiv aag l s s' \ states_equiv_for_labels aag (aag_can_read_label aag) s s' \ + states_equiv_for_labels aag (aag_can_affect_label_via aag l) s s'" + by (auto simp: roa_equiv_def states_equiv_for_def comp_def bex_disj_distrib + equiv_for_disj equiv_asids_def equiv_fpu_def equiv_hyp_def) + +lemma reads_respects_def2: + "reads_respects aag l P f \ equiv_valid_inv roa_inv (roa_equiv aag l) P f" + by (auto intro!: iff_allI + simp: equiv_valid_def2 equiv_valid_2_def roa_equiv_def2 + reads_equiv_for_labels affects_equiv_for_labels) + +lemma reads_respects_from_labels: + assumes ev: "\L. states_equiv_valid aag L P f" + assumes inv: + "\P. f \\s. P (cur_domain s)\" + "\P. f \\s. P (cur_thread s)\" + "\P. f \\s. P (scheduler_action s)\" + "\P. f \\s. P (work_units_completed s)\" + "\P. f \\s. P (irq_state_of_state s)\" + shows "reads_respects aag l P f" + unfolding reads_respects_def2 roa_inv_def roa_equiv_def + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + apply (rule hoare_weaken_pre) + apply (wps inv) + apply wp + apply auto[3] + apply (fastforce intro: ev) + done + +lemma equiv_valid_guard_necessary: + assumes hoare: "\not P'\ f \\\\" + and ev: "equiv_valid I A B (P and P') f" + shows "equiv_valid I A B P f" + using ev + apply (simp add: equiv_valid_def2 equiv_valid_2_def) + apply (erule all_forward)+ + apply (fastforce dest: use_valid[OF _ hoare]) + done + +lemma set_object_states_equiv_valid: + "states_equiv_valid aag L \ (set_object ptr obj)" + apply(clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def + bind_def' get_def gets_def put_def return_def fail_def assert_def) + apply (erule states_equiv_for_identical_kheap_updates) + apply (clarsimp simp: identical_kheap_updates_def) + done + +lemma set_vcpu_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (set_vcpu vr vcpu)" + unfolding set_vcpu_def + apply (rule_tac P'="vcpu_at vr" in equiv_valid_guard_necessary) + apply (rule wp_pre) + apply (rule hoare_set_object_weaken_pre) + apply wp + apply (clarsimp simp: obj_at_def) + apply (wpsimp wp: set_object_states_equiv_valid) + done + +lemma get_vcpu_states_equiv_valid[wp]: + "states_equiv_valid aag L (K (L (pasObjectAbs aag vr))) (get_vcpu vr)" + unfolding get_vcpu_def gets_map_def + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def opt_map_def) + done + +(* equiv_but_for_labels proofs *) + +lemma set_vcpu_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + set_vcpu vr vcpu + \\_. equiv_but_for_labels aag L st\" + unfolding set_vcpu_def + apply (rule wp_pre) + apply (rule hoare_set_object_weaken_pre) + apply (wp set_object_equiv_but_for_labels) + apply (clarsimp simp: opt_map_def obj_at_def) + done + +lemma vcpu_update_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vcpu_update vr f + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_update_def by wpsimp + +lemma vgic_update_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vgic_update vr f + \\_. equiv_but_for_labels aag L st\" + unfolding vgic_update_def by wpsimp + +lemma vgic_update_lr_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vgic_update_lr vr reg irq + \\_. equiv_but_for_labels aag L st\" + unfolding vgic_update_lr_def by wpsimp + +lemma dmo_mol_equiv_but_for_labels[wp]: + "do_machine_op (machine_op_lift f) \equiv_but_for_labels aag L st\" + unfolding equiv_but_for_labels_def + by (wpsimp wp: do_machine_op_mol_states_equiv_for) + +lemma dmo_equiv_but_for_labels_lift: + assumes "\P. f \\ms. P (underlying_memory ms)\" + assumes "\P. f \\ms. P (device_state ms)\" + assumes "\P. f \\ms. P (irq_state ms)\" + assumes "\P. f \\ms. P (vcpu_state ms)\" + assumes "\P. f \\ms. P (fpu_state ms)\" + shows "do_machine_op f \equiv_but_for_labels aag L st\" + unfolding equiv_but_for_labels_def states_equiv_for_def equiv_asids_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def + by (wpsimp wp: equiv_for_lift2 assms dmo_wp) + +lemma dmo_equiv_but_for_labels_vcpu: + assumes "\P. f \\ms. P (underlying_memory ms)\" + assumes "\P. f \\ms. P (device_state ms)\" + assumes "\P. f \\ms. P (irq_state ms)\" + assumes "\P. f \\ms. P (fpu_state ms)\" + shows "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op f + \\_. equiv_but_for_labels aag L st\" + unfolding equiv_but_for_labels_def states_equiv_for_def equiv_asids_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def + apply wp + apply clarsimp + apply (rule hoare_vcg_conj_lift, solves "wpsimp wp: equiv_for_lift2 assms dmo_wp")+ + apply (rule hoare_vcg_conj_lift) + apply (rule_tac Q'="\_ s. equiv_for (\x. pasObjectAbs aag x \ L) cur_vcpu_of st s \ + cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None" + in hoare_strengthen_post) + apply (wpsimp wp: equiv_for_lift2 assms dmo_wp) + defer + apply (wpsimp wp: equiv_for_lift2 assms dmo_wp) + apply clarsimp + apply (clarsimp simp: equiv_for_def cur_vcpu_for_def split: option.splits) + apply (clarsimp simp: cur_vcpu_of_def split: option.splits) + apply (clarsimp split: if_splits) + apply (erule_tac x=x in allE) + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + done + +lemma dmo_get_hcr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s\ + do_machine_op get_gic_vcpu_ctrl_hcr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_set_hcr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (set_gic_vcpu_ctrl_hcr val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_setSCTLR_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (setSCTLR val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_setHCR_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (setHCR val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_maskInterrupt_equiv_but_for_labels[wp]: + "do_machine_op (maskInterrupt b irq) \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_check_export_arch_timer_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op check_export_arch_timer + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_writeVCPUHardwareReg_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (writeVCPUHardwareReg reg val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_readVCPUHardwareReg_inv[wp]: + "do_machine_op (readVCPUHardwareReg reg) \P\" + by (wpsimp simp: readVCPUHardwareReg_def) + +lemma vcpu_save_reg_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vcpu_save_reg vr reg + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_save_reg_def + by wpsimp + +lemma save_virt_timer_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag vr \ L \ cur_vcpu_of s vr \ None\ + save_virt_timer vr + \\_. equiv_but_for_labels aag L st\" + unfolding save_virt_timer_def + apply wpsimp + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits if_splits) + done + +lemma dmo_enableFpuEL01_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op enableFpuEL01 + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_isb_equiv_but_for_labels[wp]: + "do_machine_op isb \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_dsb_equiv_but_for_labels[wp]: + "do_machine_op dsb \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma vcpu_disable_Some_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_of s vr \ None \ pasObjectAbs aag vr \ L\ + vcpu_disable (Some vr) \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_disable_def + apply (clarsimp simp: dmo_distr) + apply wpsimp + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits if_splits) + done + +lemma vcpu_save_reg_range_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag vr \ L)\ + vcpu_save_reg_range vr from to + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_save_reg_range_def + apply (rule hoare_gen_asm) + apply (wpsimp wp: mapM_x_wp_inv) + done + +lemma dmo_get_lr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (get_gic_vcpu_ctrl_lr reg) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_set_lr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (set_gic_vcpu_ctrl_lr reg val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_get_apr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s\ + do_machine_op get_gic_vcpu_ctrl_apr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_set_apr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (set_gic_vcpu_ctrl_apr val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma dmo_get_vmcr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s\ + do_machine_op get_gic_vcpu_ctrl_vmcr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_set_vmcr_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + do_machine_op (set_gic_vcpu_ctrl_vmcr val) + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_vcpu) + +lemma vcpu_save_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ current_vcpu s = vopt \ + (\vr b. vopt = Some (vr,b) \ pasObjectAbs aag vr \ L)\ + vcpu_save vopt \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_save_def + apply (case_tac vopt; clarsimp) + apply (wpsimp split_del: if_split simp: crunch_simps) + apply (rule_tac Q'="\_ s. equiv_but_for_labels aag L st s \ pasObjectAbs aag a \ L \ + cur_vcpu_of s a \ None" in hoare_strengthen_post) + apply (wpsimp wp: mapM_wp_inv) + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits if_splits) + apply clarsimp + apply (wpsimp simp: crunch_simps)+ + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits if_splits) + done + +lemma vcpu_restore_reg_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_restore_reg vr reg + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_restore_reg_def + by wp + +lemma vcpu_restore_reg_range_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_restore_reg_range vr from to + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_restore_reg_range_def + apply (rule hoare_strengthen_post, rule mapM_x_wp_inv) + apply (wpsimp wp: mapM_x_wp_inv)+ + done + +lemma restore_virt_timer_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + restore_virt_timer vr + \\_. equiv_but_for_labels aag L st\" + unfolding restore_virt_timer_def + by wpsimp + +lemma vcpu_enable_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_enable vr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp simp: vcpu_enable_def dmo_distr) + +crunch vcpu_restore_reg_range + for current_vcpu[wp]: "\s. P (current_vcpu s)" + (wp: crunch_wps) + +lemma vcpu_restore_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_restore vr + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: mapM_wp_inv simp: vcpu_restore_def dmo_distr dom_mapM) + +lemma modify_current_vcpu_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag vr \ L \ + (\ptr b. current_vcpu s = Some (ptr,b) \ pasObjectAbs aag ptr \ L)\ + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr,a)\\) + \\_ s. equiv_but_for_labels aag L st s\" + apply wp + apply simp + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (intro conjI) + apply (clarsimp simp: equiv_asids_def equiv_asid_def) + defer + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) + apply (clarsimp simp: equiv_hyp_def equiv_for_def) + apply (intro context_conjI; clarsimp) + apply (erule_tac x=x in allE)+ + apply clarsimp + apply (case_tac "\b. current_vcpu s = Some (x, b)") + apply clarsimp + apply (fastforce simp: cur_vcpu_of_def split: option.splits if_splits) + done + +lemma vcpu_enable_2_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag vr \ L \ + (\ptr b. current_vcpu s = Some (ptr,b) \ pasObjectAbs aag ptr \ L)\ + vcpu_enable_2 vr + \\_ s. equiv_but_for_labels aag L st s\" + unfolding vcpu_enable_2_def + apply (wp modify_current_vcpu_equiv_but_for_labels) + apply (fastforce simp: cur_vcpu_for_def split: option.splits) + done + +lemma vcpu_restore_2_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag vr \ L \ + (\ptr b. current_vcpu s = Some (ptr,b) \ pasObjectAbs aag ptr \ L)\ + vcpu_restore_2 vr + \\_ s. equiv_but_for_labels aag L st s\" + unfolding vcpu_restore_2_def + apply (wp modify_current_vcpu_equiv_but_for_labels) + apply (fastforce simp: cur_vcpu_for_def split: option.splits) + done + +lemma vcpu_disable_2_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ current_vcpu s = Some (vr, True) \ pasObjectAbs aag vr \ L\ + vcpu_disable_2 vr + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_disable_2_def + apply (wp modify_current_vcpu_equiv_but_for_labels) + apply (clarsimp simp: cur_vcpu_of_def) + done + + +lemma vcpu_update_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (vcpu_update vr f)" + unfolding vcpu_update_def + apply (rule wp_pre) + apply (rule_tac ptr=vr in states_equiv_valid_unit_cases) + apply wpsimp+ + done + +lemma cur_vcpu_for_eq_Some[simp]: + "(cur_vcpu_for_2 P cv = Some b) = (\ptr. cv = Some (ptr,b) \ P ptr)" + by (clarsimp simp: cur_vcpu_for_def split: option.splits) + +lemma cur_vcpu_for_equiv_l: + "\ equiv_for P cur_vcpu_of st s \ + \ cur_vcpu_for P st = cur_vcpu_for P s" + apply (case_tac "current_vcpu st"; case_tac "current_vcpu s") + by (auto simp: cur_vcpu_for_None cur_vcpu_for_Some equiv_for_def cur_vcpu_of_def split: if_splits) + +lemma numlistregs_for_equiv_l: + "\ equiv_for P (K \ numlistregs) st s \ + \ numlistregs_for P st = numlistregs_for P s" + by (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def + equiv_hyp_def equiv_for_def numlistregs_for_def) + +lemma do_machine_op_states_equiv_valid': + assumes equiv_dmo: + "\n cv cf. equiv_valid_inv (equiv_machine_state (L o pasObjectAbs aag) + and equiv_hyp_state n cv + and equiv_fpu_state cf) + (equiv_machine_state (L o pasObjectAbs aag)) (Q n cv cf) f" + assumes guard: + "\s. P s \ Q (numlistregs_for (L o pasObjectAbs aag) s) (cur_vcpu_for (L o pasObjectAbs aag) s) + (cur_fpu_for (L o pasObjectAbs aag) s) + (machine_state s)" + shows + "states_equiv_valid aag L P (do_machine_op f)" + apply (rule use_spec_ev) + apply (rule spec_equiv_valid_add_A[OF _ states_equiv_for_refl]) + apply (simp add: do_machine_op_def spec_equiv_valid_def) + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. equiv_machine_state (L o pasObjectAbs aag) rv rv' \ + equiv_hyp_state (numlistregs_for (L o pasObjectAbs aag) st) + (cur_vcpu_for (L o pasObjectAbs aag) st) rv rv' \ + equiv_fpu_state (cur_fpu_for (L o pasObjectAbs aag) st) rv rv'" + and Q="\r s. st = s \ Q (numlistregs_for (L o pasObjectAbs aag) st) + (cur_vcpu_for (L o pasObjectAbs aag) st) + (cur_fpu_for (L o pasObjectAbs aag) st) r" + and Q'="\r s. Q (numlistregs_for (L o pasObjectAbs aag) st) + (cur_vcpu_for (L o pasObjectAbs aag) st) + (cur_fpu_for (L o pasObjectAbs aag) st) r" + and P="(=) st" and P'="\" in equiv_valid_2_bind) + apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) + apply (rule gen_asm_ev2_r') + apply (rule_tac R'="\(r, ms') (r', ms''). r = r' \ + equiv_machine_state (L o pasObjectAbs aag) ms' ms'' \ + equiv_hyp_state (numlistregs_for (L o pasObjectAbs aag) st) + (cur_vcpu_for (L o pasObjectAbs aag) st) ms' ms'' \ + equiv_fpu_state (cur_fpu_for (L o pasObjectAbs aag) st) ms' ms''" + and Q="\r s. s = st" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) + apply (rule states_equiv_for_machine_state_update) + apply clarsimp + apply (clarsimp simp: equiv_for_def) + apply (rule equiv_hyp_state_identical_hyp_state_updates) + apply (clarsimp simp: equiv_hyp_state_def cur_vcpu_for_def numlistregs_for_def + split: option.splits if_splits) + apply (clarsimp simp: states_equiv_for_def) + apply (rule equiv_fpu_state_identical_fpu_state_updates) + apply (fastforce simp: equiv_fpu_state_def cur_fpu_for_def hw_fpu_def + split: option.splits if_splits) + apply (clarsimp simp: states_equiv_for_def) + apply (insert equiv_dmo)[1] + apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 split_def equiv_for_def) + apply (erule_tac x="numlistregs_for (L o pasObjectAbs aag) st" in meta_allE) + apply (erule_tac x="cur_vcpu_for (L o pasObjectAbs aag) st" in meta_allE) + apply (erule_tac x="cur_fpu_for (L o pasObjectAbs aag) st" in meta_allE) + apply (drule_tac x=rv in spec, drule_tac x=rv' in spec, fastforce) + apply wp + apply wp + apply clarsimp + apply clarsimp + apply (clarsimp simp: equiv_valid_2_def in_monad states_equiv_for_def equiv_hyp_def equiv_hyp_state_def comp_def) + apply (rule conjI) + apply (frule cur_vcpu_for_equiv_l) + apply (case_tac "cur_vcpu_for (L o pasObjectAbs aag) t"; clarsimp) + apply (clarsimp simp: cur_vcpu_for_def split: option.splits if_splits) + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=ptr in allE)+ + apply (fastforce simp: cur_vcpu_for_Some cur_vcpu_of_def hw_vcpu_def numlistregs_for_def + split: if_splits option.splits) + apply (fastforce simp: equiv_fpu_def equiv_fpu_state_def equiv_for_def hw_fpu_def cur_fpu_for_def + split: if_splits) + apply (wpsimp wp: guard)+ + apply (drule guard) + apply (clarsimp simp: states_equiv_for_def equiv_fpu_cur_fpu_for equiv_hyp_def + cur_vcpu_for_equiv_l numlistregs_for_equiv_l comp_def) + done + +lemma do_machine_op_states_equiv_valid: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (L o pasObjectAbs aag)) (equiv_machine_state (L o pasObjectAbs aag)) \ f" + assumes hyp_state_inv: + "\n cv ms. \equiv_hyp_state n cv ms\ f \\_. equiv_hyp_state n cv ms\" + assumes fpu_state_inv: + "\cf ms. \equiv_fpu_state cf ms\ f \\_. equiv_fpu_state cf ms\" + shows + "states_equiv_valid aag L \ (do_machine_op f)" + apply (rule do_machine_op_states_equiv_valid'[where Q="\_ _ _. \"]) + apply (insert equiv_dmo) + apply (clarsimp simp: equiv_valid_2_def equiv_valid_def2 equiv_for_or + simp: split_def split: prod.splits simp: equiv_for_def)[1] + apply (rename_tac rv st rv' st') + apply (drule_tac x=s in spec, drule_tac x=t in spec) + apply clarsimp + apply (drule (1) bspec)+ + apply clarsimp + apply (rule conjI) + apply (erule use_valid[OF _ hyp_state_inv]) + apply (rule equiv_hyp_state_sym) + apply (erule use_valid[OF _ hyp_state_inv]) + apply (erule equiv_hyp_state_sym) + apply (erule use_valid[OF _ fpu_state_inv]) + apply (rule equiv_fpu_state_sym) + apply (erule use_valid[OF _ fpu_state_inv]) + apply (erule equiv_fpu_state_sym) + apply simp + done + +lemma readVCPUHardwareReg_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. cur_vcpu_for (L o pasObjectAbs aag) s = Some b \ + (vcpuRegSavedWhenDisabled reg \ b)) + (do_machine_op (readVCPUHardwareReg reg))" + unfolding readVCPUHardwareReg_def + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some) + apply (case_tac b; clarsimp simp: hw_vcpu_def) + apply (drule_tac x=reg in fun_cong, clarsimp) + done + +lemma dmo_mol_states_equiv_valid: + "states_equiv_valid aag L \ (do_machine_op (machine_op_lift mop))" + apply (rule do_machine_op_states_equiv_valid) + apply (rule equiv_valid_guard_imp[OF machine_op_lift_ev]) + apply simp + apply wp+ + done + +lemma writeVCPUHardwareReg_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op (writeVCPUHardwareReg reg val))" + unfolding writeVCPUHardwareReg_def dmo_distr + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (wpsimp wp: do_machine_op_states_equiv_valid' modify_ev) + apply wpsimp + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def) + apply (case_tac "cur_vcpu_for (L \ pasObjectAbs aag) s"; clarsimp simp: cur_vcpu_for_Some) + apply (clarsimp simp: hw_vcpu_def split: if_splits) + apply (intro conjI ext; drule_tac x=r in fun_cong; clarsimp)+ + done + +lemma vcpu_save_reg_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. current_vcpu s = Some (vr,b) \ (vcpuRegSavedWhenDisabled reg \ b)) + (vcpu_save_reg vr reg)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_reg_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply wpsimp+ + done + +lemma vcpu_save_reg_range_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. current_vcpu s = Some (vr,b)) + (vcpu_save_reg_range vr VCPURegTTBR0 VCPURegSPSR_EL1)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_reg_range_def + apply (wpsimp wp: mapM_x_ev[where I="\s. \b. current_vcpu s = Some (vr,b)"]) + apply (auto simp: upto_enum_def fromEnum_def enum_vcpureg toEnum_def vcpuRegSavedWhenDisabled_def)[1] + apply wpsimp+ + done + +lemma get_gic_vcpu_ctrl_hcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op (get_gic_vcpu_ctrl_hcr))" + unfolding get_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some hw_vcpu_def) + done + +lemma get_gic_vcpu_ctrl_vmcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. cur_vcpu_for (L o pasObjectAbs aag) s = Some b) + (do_machine_op (get_gic_vcpu_ctrl_vmcr))" + unfolding get_gic_vcpu_ctrl_vmcr_def dmo_distr + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some hw_vcpu_def) + done + +lemma get_gic_vcpu_ctrl_apr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. cur_vcpu_for (L o pasObjectAbs aag) s = Some b) + (do_machine_op (get_gic_vcpu_ctrl_apr))" + unfolding get_gic_vcpu_ctrl_apr_def dmo_distr + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some hw_vcpu_def) + done + +lemma cur_fpu_for_lift: + assumes "\P. f \\s. P (arch_state s)\" + shows "f \\s. P (cur_fpu_for Q s)\" + unfolding cur_fpu_for_def + by (wp assms) + +lemma numlistregs_for_lift: + assumes "\P. f \\s. P (numlistregs s)\" + shows "f \\s. P (numlistregs_for Q s)\" + unfolding numlistregs_for_def + by (wp assms) + +lemma get_gic_vcpu_ctrl_lr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. (\b. cur_vcpu_for (L o pasObjectAbs aag) s = Some b) \ + unat reg < numlistregs s) + (do_machine_op (get_gic_vcpu_ctrl_lr reg))" + unfolding get_gic_vcpu_ctrl_lr_def dmo_distr + apply wp + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid') + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule hoare_lift_Pf[where f="numlistregs_for _"]) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift cur_fpu_for_lift) + apply (wpsimp wp: numlistregs_for_lift) + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some hw_vcpu_def) + apply (drule_tac x="unat reg" in fun_cong)+ + apply (clarsimp simp: numlistregs_for_def split: if_splits) + done + +lemma vgic_update_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (vgic_update vr f)" + unfolding vgic_update_def by wp + +lemma vgic_lr_update_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (vgic_update_lr vr reg irq)" + unfolding vgic_update_lr_def by wp + +lemma vcpu_save_hcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True)) + (vcpu_save_hcr vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_hcr_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply (wpsimp simp: get_gic_vcpu_ctrl_hcr_def)+ + done + +lemma vcpu_save_vmcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. current_vcpu s = Some (vr,b)) + (vcpu_save_vmcr vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_vmcr_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply (wpsimp simp: get_gic_vcpu_ctrl_vmcr_def)+ + done + +lemma vcpu_save_apr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \b. current_vcpu s = Some (vr,b)) + (vcpu_save_apr vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_apr_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply wpsimp+ + done + +lemma vcpu_save_lr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. (\b. current_vcpu s = Some (vr,b)) \ valid_numlistregs s \ reg < numlistregs s) + (vcpu_save_lr vr reg)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_lr_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply wpsimp + apply (clarsimp simp: valid_numlistregs_def) + apply (simp add: unat_of_nat64) + apply wpsimp + apply assumption + apply wpsimp + apply (clarsimp simp: cur_vcpu_for_def) + done + +crunch vcpu_save_hcr, vcpu_save_vmcr, vcpu_save_apr, vcpu_save_lr, vcpu_save_lrs + for arch_state[wp]: "\s. P (arch_state s)" + (wp: mapM_x_wp_inv) + +lemma vcpu_save_lrs_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. (\b. current_vcpu s = Some (vr,b)) \ valid_numlistregs s) + (vcpu_save_lrs vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding vcpu_save_lrs_def + apply (rule wp_pre) + apply (rule_tac P="?P" and ptr=vr in states_equiv_valid_unit_cases) + apply (wpsimp wp: mapM_x_ev) + apply (rule wp_pre) + apply wpsimp + apply (prop_tac "\x \ set rv. x < numlistregs s") + apply (erule conjunct1) + apply clarsimp + apply assumption + apply wpsimp+ + apply (fastforce simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (wpsimp wp: mapM_x_wp_inv simp: vcpu_save_lr_def get_gic_vcpu_ctrl_lr_def dmo_distr)+ + done + +lemma equiv_valid_cases'': + "\ \s t. \ A s t; I s t; R s; R t \ \ P s = P t; + equiv_valid I A B (R and P) f; equiv_valid I A B ((\s. \P s) and R) f \ + \ equiv_valid I A B R f" + by (fastforce simp: equiv_valid_def2 equiv_valid_2_def) + +lemma hw_vcpu_Some_True[simp]: + "hw_vcpu n (Some True) vst = Some (vcpu_mask n vst)" + apply (clarsimp simp: hw_vcpu_def) + apply (rule vcpu_state.equality; clarsimp) + apply (rule gic_vcpu_interface.equality; clarsimp) + apply (rule ext; clarsimp) + done + +lemma vcpu_mask_regs_update[simp]: + "vcpu_mask n (vcpu_regs_update f vst) = vcpu_regs_update f (vcpu_mask n vst)" + by (rule vcpu_state.equality; clarsimp) + +lemma check_export_arch_timer_states_equiv_valid'': + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s = None) + (do_machine_op check_export_arch_timer)" + (is "states_equiv_valid _ _ ?P _") + unfolding check_export_arch_timer_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma check_export_arch_timer_states_equiv_valid': + "states_equiv_valid aag L (\s. \vr. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op check_export_arch_timer)" + (is "states_equiv_valid _ _ ?P _") + unfolding check_export_arch_timer_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma cur_vcpu_for_None': + "(cur_vcpu_for P s = None) = (\vr. P vr \ cur_vcpu_of s vr = None)" + by (auto simp: cur_vcpu_for_def cur_vcpu_of_def split: option.splits) + +lemma check_export_arch_timer_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \vr. current_vcpu s = Some (vr,True)) + (do_machine_op check_export_arch_timer)" + (is "states_equiv_valid _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (L o pasObjectAbs aag) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: check_export_arch_timer_states_equiv_valid'') + apply (wpsimp wp: check_export_arch_timer_states_equiv_valid') + done + +lemma save_virt_timer_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True)) + (save_virt_timer vr)" + (is "states_equiv_valid _ _ ?P _") + unfolding save_virt_timer_def + apply (wpsimp wp: vcpu_save_reg_states_equiv_valid) + apply auto + done + +lemma dmo_dsb_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op dsb)" + unfolding dsb_def + by (wpsimp wp: dmo_mol_states_equiv_valid) + +lemma dmo_isb_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op isb)" + unfolding isb_def + by (wpsimp wp: dmo_mol_states_equiv_valid) + +lemma dmo_setHCR_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op (setHCR val))" + unfolding setHCR_def + by (wpsimp wp: dmo_mol_states_equiv_valid) + +(* FIXME AARCH64 IF: move *) +lemma mapM_K_bind_discarded: + "mapM f xs >>= K_bind g = mapM_x f xs >>= K_bind g" + by (simp add: mapM_x_mapM) + +lemma vcpu_save_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. current_vcpu s = cv \ valid_numlistregs s) (vcpu_save cv)" + apply (simp only: vcpu_save_def fun_app_def mapM_K_bind_discarded bind_assoc[symmetric] + vcpu_save_vgic_defs[symmetric]) + apply (wpsimp wp: when_ev mapM_ev mapM_wp_inv)+ + apply auto + done + +lemma dmo_maskInterrupt_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op (maskInterrupt m irq))" + unfolding maskInterrupt_def + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_states_equiv_valid' modify_ev) + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def) + done + +lemma enableFpuEL01_states_equiv_valid'': + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s = None) + (do_machine_op enableFpuEL01)" + (is "states_equiv_valid _ _ ?P _") + unfolding enableFpuEL01_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma enableFpuEL01_states_equiv_valid': + "states_equiv_valid aag L (\s. \vr. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op enableFpuEL01)" + (is "states_equiv_valid _ _ ?P _") + unfolding enableFpuEL01_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma enableFpuEL01_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op enableFpuEL01)" + (is "states_equiv_valid _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (L o pasObjectAbs aag) s t") + apply (auto simp: states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: enableFpuEL01_states_equiv_valid'') + apply (wpsimp wp: enableFpuEL01_states_equiv_valid') + done + +lemma setSCTLR_states_equiv_valid'': + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s = None) + (do_machine_op (setSCTLR val))" + (is "states_equiv_valid _ _ ?P _") + unfolding setSCTLR_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma setSCTLR_states_equiv_valid': + "states_equiv_valid aag L (\s. \vr. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op (setSCTLR val))" + (is "states_equiv_valid _ _ ?P _") + unfolding setSCTLR_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma setSCTLR_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op (setSCTLR val))" + (is "states_equiv_valid _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (L o pasObjectAbs aag) s t") + apply (auto simp: states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: setSCTLR_states_equiv_valid'') + apply (wpsimp wp: setSCTLR_states_equiv_valid') + done + +lemma set_gic_vcpu_ctrl_hcr_states_equiv_valid'': + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s = None) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "states_equiv_valid _ _ ?P _") + unfolding set_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma vcpu_mask_hcr_update[simp]: + "vcpu_mask n (vcpu_vgic_update (vgic_hcr_update f) vst) = vcpu_vgic_update (vgic_hcr_update f) (vcpu_mask n vst)" + by (rule vcpu_state.equality; clarsimp) + +lemma set_gic_vcpu_ctrl_hcr_states_equiv_valid': + "states_equiv_valid aag L (\s. \vr. cur_vcpu_for (L o pasObjectAbs aag) s = Some True) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "states_equiv_valid _ _ ?P _") + unfolding set_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_states_equiv_valid) + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_hcr_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "states_equiv_valid _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (L o pasObjectAbs aag) s t") + apply (auto simp: states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: set_gic_vcpu_ctrl_hcr_states_equiv_valid'') + apply (wpsimp wp: set_gic_vcpu_ctrl_hcr_states_equiv_valid') + done + +lemma vcpu_disable_Some_states_equiv_valid[wp]: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True)) (vcpu_disable (Some vr))" + apply (simp only: vcpu_disable_def fun_app_def bind_assoc[symmetric] vcpu_save_vgic_defs[symmetric]) + apply (clarsimp simp: dmo_distr) + apply (wpsimp wp: when_ev mapM_ev mapM_wp_inv)+ + apply auto + done + +definition states_equiv_for_non_hyp :: + "(obj_ref \ bool) \ (irq \ bool) \ (asid \ bool) \ + (domain \ bool) \ det_state \ det_state \ bool" + where + "states_equiv_for_non_hyp P Q R S s s' \ + equiv_for P kheap s s' \ + equiv_machine_state P (machine_state s) (machine_state s') \ + equiv_for (P \ fst) cdt s s' \ + equiv_for (P \ fst) cdt_list s s' \ + equiv_for (P \ fst) is_original_cap s s' \ + equiv_for Q interrupt_states s s' \ + equiv_for Q interrupt_irq_node s s' \ + equiv_for S ready_queues s s' \ + equiv_asids R s s' \ + equiv_fpu P s s'" + +lemma states_equiv_for_non_hyp_refl: + "states_equiv_for_non_hyp P Q R S s s" + by (auto simp: states_equiv_for_non_hyp_def intro: equiv_for_refl equiv_asids_refl equiv_hyp_refl equiv_fpu_refl) + +lemma states_equiv_for_non_hyp_sym: + "states_equiv_for_non_hyp P Q R S s t \ states_equiv_for_non_hyp P Q R S t s" + by (auto simp: states_equiv_for_non_hyp_def intro: equiv_for_sym equiv_asids_sym equiv_hyp_sym equiv_fpu_sym) + +lemma states_equiv_for_non_hyp_trans: + "\ states_equiv_for_non_hyp P Q R S s t; states_equiv_for_non_hyp P Q R S t u \ + \ states_equiv_for_non_hyp P Q R S s u" + by (auto simp: states_equiv_for_non_hyp_def + intro: equiv_for_trans equiv_asids_trans equiv_hyp_trans equiv_fpu_trans equiv_forI + elim: equiv_forE) + +lemma states_equiv_for_non_hyp_lift: + assumes "\st. f \\s. equiv_for P kheap st s\" + assumes "\ms. f \\s. equiv_machine_state P ms (machine_state s)\" + assumes "\st. f \\s. equiv_for (P \ fst) cdt st s\" + assumes "\st. f \\s. equiv_for (P \ fst) cdt_list st s\" + assumes "\st. f \\s. equiv_for (P \ fst) is_original_cap st s\" + assumes "\st. f \\s. equiv_for Q interrupt_states st s\" + assumes "\st. f \\s. equiv_for Q interrupt_irq_node st s\" + assumes "\st. f \\s. equiv_for S ready_queues st s\" + assumes "\st. f \\s. equiv_asids R st s\" + assumes "\st. f \\s. equiv_fpu P st s\" + shows "f \states_equiv_for_non_hyp P Q R S st\" + unfolding states_equiv_for_non_hyp_def + apply (rule hoare_weaken_pre) + apply (rule hoare_vcg_conj_lift, rule assms)+ + apply (rule assms) + apply simp + done + +crunch vcpu_switch + for is_original_cap[wp]: "\s. P (is_original_cap s)" + and interrupt_states[wp]: "\s. P (interrupt_states s)" + (wp: crunch_wps) + +lemma equiv_asids_lift: + assumes "\P. f \\s. P (asid_pools_of s)\" + assumes "\P. f \\s. P (asid_table s)\" + shows "f \\s. equiv_asids R st s\" + unfolding equiv_asids_def equiv_asid_def asid_pools_at_eq + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift assms) + apply auto + done + +crunch vcpu_switch + for asid_pools[wp]: "\s. P (asid_pools_of s)" + (wp: crunch_wps) + +lemma equiv_fpu_lift: + assumes "\P. f \\s. P (fpu_state (machine_state s))\" + assumes "\P. f \\s. P (current_fpu s)\" + shows "f \\s. equiv_fpu P st s\" + apply (clarsimp simp: valid_def equiv_fpu_def equiv_for_def) + apply (erule_tac x=x in allE, clarsimp) + apply (frule_tac P="\s'. fpu_state (machine_state s') = fpu_state (machine_state s)" in use_valid) + apply (rule assms(1)) + apply simp + apply (drule_tac P="\s'. current_fpu s' = current_fpu s" in use_valid) + apply (rule assms(2)) + apply simp + apply (clarsimp simp: equiv_fpu_def opt_map_def fpu_of_state_def cur_fpu_for_def get_tcb_def + split: option.splits kernel_object.splits if_splits) + done + +crunch vcpu_restore + for kheap[wp]: "\s. P (kheap s)" + and fpu_state[wp]: "\s. P (fpu_state (machine_state s))" + and underlying_memory[wp]: "\s. P (underlying_memory (machine_state s))" + and device_state[wp]: "\s. P (device_state (machine_state s))" + (wp: crunch_wps dmo_wp simp: crunch_simps) + +lemma equiv_machine_state_lift: + assumes "\P. f \\s. P (underlying_memory (machine_state s))\" + assumes "\P. f \\s. P (device_state (machine_state s))\" + shows "f \\s. equiv_machine_state P ms (machine_state s)\" + by (wpsimp wp: assms equiv_for_lift2) + +lemma vcpu_restore_states_equiv_for_non_hyp[wp]: + "vcpu_restore vopt \states_equiv_for_non_hyp P Q R S st\" + by (wpsimp wp: states_equiv_for_non_hyp_lift equiv_for_lift + equiv_asids_lift equiv_fpu_lift equiv_machine_state_lift) + +lemma equiv_valid_split: + assumes "equiv_valid I A B P f" + assumes "equiv_valid I' A' B' P' f" + shows "equiv_valid (\s s'. I s s' \ I' s s') (\s s'. A s s' \ A' s s') + (\s s'. B s s' \ B' s s') (\s. P s \ P' s) f" + using assms by (fastforce simp: equiv_valid_def2 equiv_valid_2_def) + +lemma vcpus_of_vcpu_proj: + "vcpus_of s vr = Some vcpu + \ vcpu_proj UNIV UNIV True True True vr s = Some (vcpu_mask (numlistregs s) vcpu)" + by (clarsimp simp: vcpu_proj_def cong: if_cong) + +lemma vcpu_mask_truncate_helper: + "vcpu_mask (numlistregs s) (vcpu_state.truncate vcpu) = + vcpu_state.truncate (vcpu_mask (numlistregs s) vcpu)" + by (clarsimp simp: vcpu_state.defs) + +lemma vcpu_restore_vcpu_proj': + "\\s. vopt = vcpu_proj UNIV UNIV True True True vr s \ valid_arch_state s\ + vcpu_restore vr + \\_ s. vopt = vcpu_proj {} {} False False False vr s\" + by (wpsimp wp: vcpu_restore_vcpu_proj) + +lemma vcpu_restore_helper: + "\\s. vcpus_of s vr = Some vcpu \ valid_arch_state s\ + vcpu_restore vr + \\_ s. vcpu_mask (numlistregs s) (vcpu_state.truncate vcpu) = vcpu_mask (numlistregs s) (vcpu_state (machine_state s))\" + apply (rule_tac P'="\s. vcpus_of s vr = Some vcpu \ valid_arch_state s \ + Some (vcpu_mask (numlistregs s) vcpu) = vcpu_proj UNIV UNIV True True True vr s " + and Q'="\_ s. vcpus_of s vr = Some vcpu \ + Some (vcpu_mask (numlistregs s) vcpu) = vcpu_proj {} {} False False False vr s" + in hoare_chain) + apply (rule hoare_weaken_pre) + apply (rule hoare_vcg_conj_lift) + apply wpsimp + apply wps + apply (wp vcpu_restore_vcpu_proj') + apply clarsimp + apply clarsimp + apply (drule vcpus_of_vcpu_proj) + apply simp + apply clarsimp + apply (clarsimp simp: vcpu_mask_truncate_helper) + apply (clarsimp simp: vcpu_proj_def vcpu_state.defs cong: if_cong) + done + +lemma vcpu_restore_2_helper: + "\\s. vcpus_of s vr = Some vcpu \ valid_arch_state s\ + vcpu_restore_2 vr + \\_ s. hw_vcpu_of s vr = Some (vcpu_mask (numlistregs s) (vcpu_state.truncate vcpu))\" + unfolding vcpu_restore_2_def + apply (rule_tac Q'="\_ s. vcpu_mask (numlistregs s) (vcpu_state.truncate vcpu) + = vcpu_mask (numlistregs s) (vcpu_state (machine_state s)) + \ current_vcpu s = Some (vr,True)" in hoare_strengthen_post) + apply wp + apply (rule hoare_vcg_conj_lift) + apply simp + apply (wp vcpu_restore_helper[simplified]) + apply simp + apply wpsimp+ + apply (clarsimp simp: cur_vcpu_of_def) + done + +lemma get_vcpu_vcpu_at: + "\\s. vcpu_at vr s \ P s\ get_vcpu vr \\_. P\" + unfolding get_vcpu_def gets_map_def + by (wpsimp simp: obj_at_def opt_map_def split: option.splits) + +crunch vcpu_restore_2 + for kheap[wp]: "\s. P (kheap s)" + and numlistregs[wp]: "\s. P (numlistregs s)" + +abbreviation states_equiv_for_labels_non_hyp :: + "'a PAS \ ('a \ bool) \ det_state \ det_state \ bool" + where + "states_equiv_for_labels_non_hyp aag P \ + states_equiv_for_non_hyp (\x. P (pasObjectAbs aag x)) (\x. P (pasIRQAbs aag x)) + (\x. P (pasASIDAbs aag x)) (\x. \l\pasDomainAbs aag x. P l)" + +abbreviation states_equiv_valid_non_hyp where + "states_equiv_valid_non_hyp aag L P f \ equiv_valid_inv \\ (states_equiv_for_labels_non_hyp aag L) P f" + +lemma states_equiv_for_non_hyp_symmetric: + "states_equiv_for_non_hyp P Q R S s t = states_equiv_for_non_hyp P Q R S t s" + by (auto simp: states_equiv_for_non_hyp_sym) + +lemma states_equiv_valid_non_hyp_unobservable: + assumes f: + "\P Q R S st. \states_equiv_for_non_hyp P Q R S st\ f \\_. states_equiv_for_non_hyp P Q R S st\" + shows + "states_equiv_valid_non_hyp aag l \ (f :: (det_state,unit) nondet_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (subst states_equiv_for_non_hyp_symmetric) + apply (erule use_valid) + apply (wp assms) + apply (subst states_equiv_for_non_hyp_symmetric) + apply (erule use_valid) + apply (wp assms) + apply simp + done + +lemma states_equiv_for_non_hyp_current_vcpu_update[simp]: + "states_equiv_for_non_hyp P Q R S st (s\arch_state := arch_state s\arm_current_vcpu := cv\\) = + states_equiv_for_non_hyp P Q R S st s" + by (clarsimp simp: states_equiv_for_non_hyp_def equiv_asids_def equiv_asid_def + equiv_for_def cur_fpu_for_def equiv_fpu_def get_tcb_def) + +lemma vcpu_restore_2_reads_respects_hyp_l: + "equiv_valid (\s s'. equiv_for P kheap s s' \ + equiv_for P (K \ numlistregs) s s') + \\ (\s s'. equiv_for P cur_vcpu_of s s' \ + equiv_for P hw_vcpu_of s s') (valid_arch_state) + (vcpu_restore_2 vr)" + apply (rule_tac P'="\s. vcpus_of s vr \ None" in equiv_valid_guard_necessary) + apply (unfold vcpu_restore_2_def vcpu_restore_def)[1] + apply (clarsimp simp: bind_assoc) + apply (wpsimp wp: get_vcpu_vcpu_at simp: obj_at_def opt_map_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (rule context_conjI) + apply (erule use_valid, rule equiv_for_lift, wp)+ + apply simp + apply (rename_tac s' t' vcpu vcpu') + apply (rule context_conjI, clarsimp simp: comp_def) + apply (erule use_valid, rule equiv_for_lift, wp)+ + apply simp + apply (prop_tac "current_vcpu s' = Some (vr,True)") + apply (erule use_valid, wpsimp simp: vcpu_restore_2_def, simp) + apply (prop_tac "current_vcpu t' = Some (vr,True)") + apply (erule use_valid, wpsimp simp: vcpu_restore_2_def, simp) + apply (rule conjI) + apply (clarsimp simp: equiv_for_def) + apply (case_tac "P vr") + apply (prop_tac "vcpu = vcpu'") + apply (clarsimp simp: equiv_for_def opt_map_def) + apply (drule use_valid[OF _ vcpu_restore_2_helper], simp)+ + apply (subgoal_tac " Some + (vcpu_vgic_update + (vgic_lr_update (\f r. if numlistregs s' \ r then undefined else f r)) + (vcpu_state.truncate vcpu)) = + Some + (vcpu_vgic_update + (vgic_lr_update (\f r. if numlistregs t' \ r then undefined else f r)) + (vcpu_state.truncate vcpu'))") + apply (clarsimp simp: equiv_for_def cur_vcpu_of_def) + apply (clarsimp simp: equiv_for_def) + apply (drule mp, fastforce)+ + apply clarsimp + apply (clarsimp simp: equiv_for_def cur_vcpu_of_def) + done + +lemma vcpu_restore_2_states_equiv_valid: + "states_equiv_valid aag L (valid_arch_state) (vcpu_restore_2 vr)" + apply (rule equiv_valid_conseq) + apply (rule equiv_valid_split) + apply (subst vcpu_restore_2_def)[1] + apply (rule states_equiv_valid_non_hyp_unobservable[of _ L aag]) + apply (wpsimp)+ + apply (rule vcpu_restore_2_reads_respects_hyp_l[of "L o pasObjectAbs aag"]) + apply (auto simp: states_equiv_for_def comp_def + states_equiv_for_non_hyp_def equiv_hyp_def) + done + +lemma vcpu_enable_2_vcpu_proj: + "\\s. vopt = vcpu_proj savedWhenDisabledRegs {} True False False vr s \ valid_arch_state s\ + vcpu_enable_2 vr + \\_ s. vopt = vcpu_proj {} {} False False False vr s\" + by (wpsimp wp: vcpu_enable_vcpu_proj simp: vcpu_enable_2_def) + +crunch vcpu_enable_2 + for kheap[wp]: "\s. P (kheap s)" + and numlistregs[wp]: "\s. P (numlistregs s)" + +lemma vcpu_enable_2_reads_respects_hyp_l: + "equiv_valid (\s s'. equiv_for P kheap s s' \ + equiv_for P (K \ numlistregs) s s') + (equiv_for P hw_vcpu_of) + (\s s'. equiv_for P cur_vcpu_of s s' \ + equiv_for P hw_vcpu_of s s') (\s. current_vcpu s = Some (vr,False) \ valid_arch_state s) + (vcpu_enable_2 vr)" + apply (rule_tac P'="\s. vcpus_of s vr \ None" in equiv_valid_guard_necessary) + apply (unfold vcpu_enable_2_def vcpu_enable_def)[1] + apply (clarsimp simp: bind_assoc) + apply (wpsimp wp: get_vcpu_vcpu_at simp: obj_at_def opt_map_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (rule context_conjI) + apply (erule use_valid, rule equiv_for_lift, wp)+ + apply simp + apply (rename_tac s' t' vcpu vcpu') + apply (rule context_conjI, clarsimp simp: comp_def) + apply (erule use_valid, rule equiv_for_lift, wp)+ + apply simp + apply (prop_tac "current_vcpu s' = Some (vr,True)") + apply (erule use_valid, wpsimp simp: vcpu_enable_2_def, simp) + apply (prop_tac "current_vcpu t' = Some (vr,True)") + apply (erule use_valid, wpsimp simp: vcpu_enable_2_def, simp) + apply (rule conjI) + apply (clarsimp simp: equiv_for_def) + apply (case_tac "P vr") + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=x in allE)+ + apply (drule mp, fastforce)+ + apply clarsimp + apply (clarsimp simp: cur_vcpu_of_def) + apply (prop_tac "vcpu' = vcpu") + apply (clarsimp simp: opt_map_def) + apply clarsimp + apply (prop_tac "vcpu_proj savedWhenDisabledRegs {} True False False vr s = + vcpu_proj savedWhenDisabledRegs {} True False False vr t") + apply (clarsimp simp: vcpu_proj_def hw_vcpu_def) + apply (case_tac vcpu; clarsimp) + apply (case_tac vcpu_vgic; clarsimp) + apply (intro conjI ext) + apply (drule_tac x=r in fun_cong, clarsimp) + apply (drule_tac x=reg in fun_cong, clarsimp simp: vcpuRegSavedWhenDisabled_def split: if_splits vcpureg.splits) + apply (prop_tac "vcpus_of s' vr = Some vcpu") + apply (erule use_valid, wpsimp, simp) + apply (prop_tac "vcpus_of t' vr = Some vcpu") + apply (erule use_valid, wpsimp, clarsimp simp: opt_map_def) + apply (drule use_valid, rule vcpu_enable_2_vcpu_proj, solves simp) + apply simp + apply (thin_tac "vcpu_proj _ _ _ _ _ _ _ = vcpu_proj _ _ _ _ _ _ _") + apply (drule use_valid, rule vcpu_enable_2_vcpu_proj, solves simp) + apply (thin_tac "vcpu_proj _ _ _ _ _ _ _ = vcpu_proj _ _ _ _ _ _ _") + apply (clarsimp simp: vcpu_proj_def) + apply (case_tac vcpu; clarsimp) + apply (case_tac vcpu_vgic; clarsimp cong: if_cong) + apply (clarsimp simp: equiv_for_def cur_vcpu_of_def) + done + +lemma vcpu_enable_states_equiv_for_non_hyp[wp]: + "vcpu_enable vopt \states_equiv_for_non_hyp P Q R S st\" + by (wpsimp wp: states_equiv_for_non_hyp_lift equiv_for_lift + equiv_asids_lift equiv_fpu_lift equiv_machine_state_lift) + +lemma vcpu_enable_2_states_equiv_valid: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,False) \ valid_arch_state s) (vcpu_enable_2 vr)" + apply (rule equiv_valid_conseq) + apply (rule equiv_valid_split) + apply (subst vcpu_enable_2_def)[1] + apply (rule states_equiv_valid_non_hyp_unobservable[of _ L aag]) + apply (wpsimp)+ + apply (rule vcpu_enable_2_reads_respects_hyp_l[of "L o pasObjectAbs aag"]) + apply (auto simp: states_equiv_for_def equiv_for_def + states_equiv_for_non_hyp_def equiv_hyp_def) + done + +lemma states_equiv_valid_modify_disable: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True) \ L (pasObjectAbs aag vr)) + (modify (\s. s\arch_state := arch_state s\arm_current_vcpu := Some (vr, False)\\))" + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI) + apply (clarsimp simp: equiv_asids_def equiv_asid_def) + apply (clarsimp simp: equiv_hyp_def equiv_for_def) + apply (erule_tac x=vr in allE)+ + apply clarsimp + apply (drule mp, fastforce) + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply (clarsimp simp: hw_vcpu_def) + apply (case_tac "vcpu_state (machine_state s)"; case_tac "vcpu_state (machine_state t)"; clarsimp) + apply (case_tac "vcpu_vgic"; case_tac "vcpu_vgica"; clarsimp) + apply (intro conjI ext) + apply (drule_tac x=r in fun_cong, clarsimp) + apply (clarsimp split: if_splits) + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) + done + +lemma vcpu_disable_2_states_equiv_valid: + "states_equiv_valid aag L (\s. current_vcpu s = Some (vr,True) \ valid_arch_state s) (vcpu_disable_2 vr)" + unfolding vcpu_disable_2_def + apply (rule equiv_valid_guard_imp) + apply (rule states_equiv_valid_unit_cases) + apply clarsimp + apply (wp vcpu_disable_Some_states_equiv_valid states_equiv_valid_modify_disable) + apply simp + apply (wp modify_current_vcpu_equiv_but_for_labels) + apply clarsimp + apply assumption + apply wpsimp + apply (auto simp: cur_vcpu_of_def) + done + +crunch vcpu_disable_2, vcpu_enable_2, vcpu_restore_2 + for ready_queues[wp]: "\s. P (ready_queues s)" + +lemma ev_evrv: + "equiv_valid I A B P f \ equiv_valid_rv I A B (=) P f" + by (unfold equiv_valid_def2) + +lemma ev2_case_option: + assumes "\x = None; y = None\ \ equiv_valid_2 I A B R P1 Q1 f g" + and "\b. \x = None; y = Some b\ \ equiv_valid_2 I A B R P2 (Q2 b) f (g' b)" + and "\a. \x = Some a; y = None\ \ equiv_valid_2 I A B R (P3 a) Q3 (f' a) g" + and "\a b. \x = Some a; y = Some b\ \ equiv_valid_2 I A B R (P4 a) (Q4 b) (f' a) (g' b)" + shows "equiv_valid_2 I A B R (case_option (P1 and P2) (P3 and P4) x) + (case_option (Q1 and Q3) (Q2 and Q4) y) + (case_option f f' x) (case_option g g' y)" + apply (case_tac x; case_tac y; clarsimp) + by (rule equiv_valid_2_guard_imp, rule assms; fastforce)+ + +lemma vcpu_switch_states_equiv_valid: + notes ev2l_bind = equiv_valid_2_bind_pre[where P=\ and P'=\ and R'="\\", rotated, simplified] + shows "states_equiv_valid aag L (\s. valid_arch_state s) (vcpu_switch vopt)" + apply (unfold vcpu_switch_def) + apply (fold vcpu_restore_2_def vcpu_enable_2_def vcpu_disable_2_def) + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s = None" in equiv_valid_cases'') + apply (simp add: cur_vcpu_for_None') + apply (clarsimp simp: states_equiv_for_def equiv_hyp_def equiv_for_def) + prefer 2 + apply (wpsimp wp: when_ev vcpu_disable_2_states_equiv_valid + vcpu_restore_2_states_equiv_valid vcpu_enable_2_states_equiv_valid gets_ev') + apply (subgoal_tac "\t. states_equiv_for_labels aag L s t \ current_vcpu s = current_vcpu t") + apply (clarsimp simp: valid_arch_state_def) + apply (clarsimp simp: states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (erule_tac x=ptr in allE)+ + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply (rule_tac P="\_. none_bot (L o pasObjectAbs aag) vopt" in equiv_valid_cases'') + apply simp + prefer 2 + apply (rule states_equiv_valid_invisible[where P="\", simplified]) + apply (rule modifies_at_mostI) + apply (wpsimp wp: vcpu_enable_2_equiv_but_for_labels + vcpu_disable_2_equiv_but_for_labels + vcpu_restore_2_equiv_but_for_labels) + apply (fastforce simp: cur_vcpu_for_def) + apply wpsimp + apply clarsimp + apply (case_tac vopt; clarsimp simp: equiv_valid_def2) + apply (clarsimp simp: equiv_valid_2_def) + apply (rule equiv_valid_2_bind_pre[OF _ gets_any_evrv]) + apply (rule_tac P="\b. rv \ Some (a,b)" in gen_asm_ev2_l) + apply (rule_tac P'="\b. rv' \ Some (a,b)" in gen_asm_ev2_r) + apply (clarsimp simp: split_def) + apply (rule ev2_case_option) + apply (rule ev_evrv) + apply (rule vcpu_restore_2_states_equiv_valid) + apply (subst if_P, clarsimp, blast) + apply (subst return_bind[where f="\_. vcpu_restore_2 _", symmetric], + rule_tac R'=dc in equiv_valid_2_bind_pre) + apply (simp only: K_bind_def) + apply (rule ev_evrv) + apply (rule vcpu_restore_2_states_equiv_valid) + apply (rule_tac P=\ and P'=\ + in states_equiv_valid_2_invisible[OF modifies_at_mostI modifies_at_mostI]) + apply (assumption | wpsimp simp: split_def split_del: if_split)+ + apply (subst if_P, clarsimp, blast) + apply (subst return_bind[where f="\_. vcpu_restore_2 _", symmetric], + rule_tac R'=dc in equiv_valid_2_bind_pre) + apply (simp only: K_bind_def) + apply (rule ev_evrv) + apply (rule vcpu_restore_2_states_equiv_valid) + apply (rule_tac P=\ and P'=\ + in states_equiv_valid_2_invisible[OF modifies_at_mostI modifies_at_mostI]) + apply (assumption | wpsimp simp: split_def split_del: if_split)+ + apply (subst if_P, clarsimp, blast)+ + apply (rule_tac R'=dc in equiv_valid_2_bind_pre) + apply (simp only: K_bind_def) + apply (rule ev_evrv) + apply (rule vcpu_restore_2_states_equiv_valid) + apply (rule_tac P=\ and P'=\ + in states_equiv_valid_2_invisible[OF modifies_at_mostI modifies_at_mostI]) + apply (assumption | wpsimp simp: split_def split_del: if_split)+ + apply (auto simp: cur_vcpu_for_def split: option.splits if_splits) + done + +lemma vcpu_switch_reads_respects: + "reads_respects aag l valid_arch_state (vcpu_switch vopt)" + by (wpsimp wp: reads_respects_from_labels[OF vcpu_switch_states_equiv_valid]) + +lemma set_vcpu_reads_respects[wp]: + "reads_respects aag l \ (set_vcpu vr vcpu)" + unfolding set_vcpu_def + apply (rule_tac P'="vcpu_at vr" in equiv_valid_guard_necessary) + apply (rule wp_pre) + apply (rule hoare_set_object_weaken_pre) + apply wp + apply (clarsimp simp: obj_at_def) + apply (wpsimp wp: set_object_reads_respects) + done + +lemma get_vcpu_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read aag vr \ aag_can_affect aag l vr)) (get_vcpu vr)" + unfolding get_vcpu_def gets_map_def + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def opt_map_def) + done + +lemma vcpu_update_reads_respects[wp]: + "reads_respects aag l \ (vcpu_update vr f)" + unfolding vcpu_update_def + apply (rule wp_pre) + apply (rule_tac ptr=vr in reads_respects_unit_cases) + apply wpsimp+ + done + +lemma vcpu_read_reg_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read aag v)) (vcpu_read_reg v reg)" + unfolding vcpu_read_reg_def + by wpsimp + +lemma vcpu_write_reg_reads_respects[wp]: + "reads_respects aag l \ (vcpu_write_reg v reg val)" + unfolding vcpu_write_reg_def + by wpsimp + +lemma gets_apply_evrv: + "equiv_valid_rv_inv I A R (K (\s t. I s t \ A s t \ R (f s x) (f t x))) (gets_apply f x)" + apply (simp add: gets_apply_def get_def bind_def return_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + done + +lemma gets_apply_evrv': + "\s t. I s t \ A s t \ P s \ P t \ R (f s x) (f t x) + \ equiv_valid_rv_inv I A R P (gets_apply f x)" + apply (simp add: gets_apply_def get_def bind_def return_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + done + +lemma readVCPUHardwareReg_reads_respects[wp]: + "reads_respects aag l (\s. \b. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some b \ (vcpuRegSavedWhenDisabled reg \ b)) + (do_machine_op (readVCPUHardwareReg reg))" + unfolding readVCPUHardwareReg_def + apply (rule do_machine_op_reads_respects'') + apply wp + apply clarsimp + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def cur_vcpu_for_Some) + apply (case_tac b; clarsimp simp: hw_vcpu_def) + apply (drule_tac x=reg in fun_cong, clarsimp) + done + +lemma writeVCPUHardwareReg_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op (writeVCPUHardwareReg reg val))" + unfolding writeVCPUHardwareReg_def dmo_distr + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_reads_respects'' modify_ev) + apply wpsimp + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def) + apply (case_tac "cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) s"; clarsimp simp: cur_vcpu_for_Some) + apply (clarsimp simp: hw_vcpu_def split: if_splits) + apply (intro conjI ext; drule_tac x=r in fun_cong; clarsimp)+ + done + +lemma invoke_vcpu_read_register_reads_respects: + "reads_respects aag l (K (aag_can_read aag v)) (invoke_vcpu_read_register v reg)" + unfolding invoke_vcpu_read_register_def read_vcpu_register_def gets_def + apply (subst bind_assoc) + apply (subst return_bind) + apply (subst bind_assoc[symmetric]) + apply (subst gets_apply_def[symmetric]) + apply simp + apply (rule gen_asm_ev) + apply (rule wp_pre) + apply (unfold equiv_valid_def2) + apply (clarsimp simp: bind_assoc) + apply (rule_tac A=A and B=A and P=\ and W="\x y. fst x = fst y \ (fst x \ x = y)" + and Q="\rv s. (fst rv \ Q rv s) \ (\fst rv \ Q' rv s)" + for A Q Q' in equiv_valid_rv_bind_general) + apply (wpsimp wp: gets_apply_evrv') + apply (prop_tac "equiv_for (aag_can_read aag) cur_vcpu_of s t") + apply (clarsimp simp: reads_equiv_def2 states_equiv_for_def equiv_hyp_def) + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=v in allE) + apply (auto simp: equiv_for_def cur_vcpu_of_def split: option.splits if_splits)[1] + apply (case_tac "fst rv"; clarsimp split del: if_split; wpfix) + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp + apply (rule equiv_valid_guard_imp) + apply wpsimp + apply clarsimp + apply wpsimp + apply wpsimp+ + apply (clarsimp split: option.splits) + apply simp + done + +lemma invoke_vcpu_write_register_reads_respects: + "reads_respects aag l (K (aag_can_read aag v)) (invoke_vcpu_write_register v reg val)" + unfolding invoke_vcpu_write_register_def write_vcpu_register_def gets_def + apply (subst bind_assoc) + apply (subst return_bind) + apply (subst bind_assoc[symmetric]) + apply (subst gets_apply_def[symmetric]) + apply simp + apply (rule gen_asm_ev) + apply (rule wp_pre) + apply (unfold equiv_valid_def2) + apply (clarsimp simp: bind_assoc) + apply (rule_tac A=A and B=A and P=\ and W="\x y. fst x = fst y \ (fst x \ x = y)" + and Q="\rv s. (fst rv \ Q rv s) \ (\fst rv \ Q' rv s)" + for A Q Q' in equiv_valid_rv_bind_general) + apply (wpsimp wp: gets_apply_evrv') + apply (prop_tac "equiv_for (aag_can_read aag) cur_vcpu_of s t") + apply (clarsimp simp: reads_equiv_def2 states_equiv_for_def equiv_hyp_def) + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=v in allE) + apply (auto simp: equiv_for_def cur_vcpu_of_def split: option.splits if_splits)[1] + apply (case_tac "fst rv"; clarsimp split del: if_split; wpfix) + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_lr_reads_respects'': + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None) + (do_machine_op (set_gic_vcpu_ctrl_lr reg val))" + (is "reads_respects _ _ ?P _") + unfolding set_gic_vcpu_ctrl_lr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma hw_vcpu_lr_update[simp]: + "hw_vcpu n cv (vcpu_vgic_update (vgic_lr_update (\f. f(reg := val))) vst) = + (if reg < n then map_option (vcpu_vgic_update (vgic_lr_update (\f. f(reg := val)))) (hw_vcpu n cv vst) + else hw_vcpu n cv vst)" + by (auto split: if_splits option.splits simp: hw_vcpu_def) + +lemma set_gic_vcpu_ctrl_lr_reads_respects': + "reads_respects aag l (\s. \vr b. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some b) + (do_machine_op (set_gic_vcpu_ctrl_lr reg val))" + (is "reads_respects _ _ ?P _") + unfolding set_gic_vcpu_ctrl_lr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_lr_reads_respects[wp]: + "reads_respects aag l \ + (do_machine_op (set_gic_vcpu_ctrl_lr reg val))" + (is "reads_respects _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (aag_can_read_or_affect aag l) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: set_gic_vcpu_ctrl_lr_reads_respects'') + apply (wpsimp wp: set_gic_vcpu_ctrl_lr_reads_respects') + done + +lemma vgic_update_reads_respects[wp]: + "reads_respects aag l \ (vgic_update vr f)" + unfolding vgic_update_def by wp + +lemma vgic_lr_update_reads_respects[wp]: + "reads_respects aag l \ (vgic_update_lr vr reg irq)" + unfolding vgic_update_lr_def by wp + +lemma invoke_vcpu_inject_irq_reads_respects: + "reads_respects aag l (\s. aag_can_read aag v) (invoke_vcpu_inject_irq v n irq)" + unfolding invoke_vcpu_inject_irq_def + apply (subst equiv_valid_def2) + apply (rule_tac W="\cv cv'. (cv \ None \ fst (the cv) = v) = (cv' \ None \ fst (the cv') = v)" in equiv_valid_rv_bind) + apply (wpsimp wp: gets_evrv'') + apply (prop_tac "equiv_for (aag_can_read aag) cur_vcpu_of s t") + apply (clarsimp simp: reads_equiv_def2 states_equiv_for_def equiv_hyp_def) + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=v in allE) + apply (auto simp: equiv_for_def cur_vcpu_of_def split: option.splits if_splits)[1] + apply (clarsimp split del: if_split) + apply (subst equiv_valid_def2[symmetric]) + apply wpsimp+ + done + +lemma invoke_vcpu_ack_vppi_reads_respects: + "reads_respects aag l (K (aag_can_read aag v)) (invoke_vcpu_ack_vppi v vppi)" + unfolding invoke_vcpu_ack_vppi_def + by wpsimp + +lemma as_user_getRegister_reads_respects: + assumes domains_distinct: "pas_domains_distinct aag" + shows "reads_respects aag l (K (aag_can_read aag thread \ aag_can_affect aag l thread)) (as_user thread (getRegister reg))" + apply (simp add: as_user_def split_def) + apply (rule gen_asm_ev) + apply (wp set_object_reads_respects select_f_ev gets_the_ev) + apply (auto intro: reads_affects_equiv_get_tcb_eq det_getRegister)[1] + done + +lemma arch_thread_set_vcpu_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) + (arch_thread_set (tcb_vcpu_update f) t)" + unfolding arch_thread_set_def + apply (wpsimp wp: set_object_reads_respects) + apply fastforce + done + +lemma gets_arm_current_vcpu_reads_respects: + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s \ None) + (gets (arm_current_vcpu \ arch_state))" + apply (wpsimp wp: gets_ev') + apply (erule disjE) + apply (prop_tac "equiv_hyp (aag_can_read aag) s t") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (fastforce simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + apply (prop_tac "equiv_hyp (aag_can_affect aag l) s t") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (fastforce simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + done + +lemma modify_current_vcpu_None_reads_respects[wp]: + "reads_respects aag l \ + (modify (\s. s\arch_state := arch_state s\arm_current_vcpu := None\\))" + apply (wpsimp wp: modify_ev) + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_def) + apply (intro conjI) + prefer 4 + apply (auto simp: equiv_asids_def equiv_asid_def)[2] + prefer 2 + prefer 4 + apply (auto simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def)[2] + apply (clarsimp simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: option.split) + apply (clarsimp simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: option.split) + done + +lemma dmo_dsb_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op dsb)" + unfolding dsb_def + by (wpsimp wp: dmo_mol_reads_respects) + +lemma dmo_isb_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op isb)" + unfolding isb_def + by (wpsimp wp: dmo_mol_reads_respects) + +lemma dmo_setHCR_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op (setHCR val))" + unfolding setHCR_def + by (wpsimp wp: dmo_mol_reads_respects) + +lemma dmo_maskInterrupt_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op (maskInterrupt m irq))" + unfolding maskInterrupt_def + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_reads_respects'' modify_ev) + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def) + done + +lemma enableFpuEL01_reads_respects'': + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None) + (do_machine_op enableFpuEL01)" + (is "reads_respects _ _ ?P _") + unfolding enableFpuEL01_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma enableFpuEL01_reads_respects': + "reads_respects aag l (\s. \vr. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some True) + (do_machine_op enableFpuEL01)" + (is "reads_respects _ _ ?P _") + unfolding enableFpuEL01_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma enableFpuEL01_reads_respects[wp]: + "reads_respects aag l (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op enableFpuEL01)" + (is "reads_respects _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (aag_can_read_or_affect aag l) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: enableFpuEL01_reads_respects'') + apply (wpsimp wp: enableFpuEL01_reads_respects') + done + +lemma setSCTLR_reads_respects'': + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None) + (do_machine_op (setSCTLR val))" + (is "reads_respects _ _ ?P _") + unfolding setSCTLR_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma setSCTLR_reads_respects': + "reads_respects aag l (\s. \vr. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some True) + (do_machine_op (setSCTLR val))" + (is "reads_respects _ _ ?P _") + unfolding setSCTLR_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma setSCTLR_reads_respects[wp]: + "reads_respects aag l (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op (setSCTLR val))" + (is "reads_respects _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (aag_can_read_or_affect aag l) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: setSCTLR_reads_respects'') + apply (wpsimp wp: setSCTLR_reads_respects') + done + +lemma set_gic_vcpu_ctrl_hcr_reads_respects'': + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "reads_respects _ _ ?P _") + unfolding set_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_def) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_hcr_reads_respects': + "reads_respects aag l (\s. \vr. cur_vcpu_for (aag_can_read_or_affect aag l) s = Some True) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "reads_respects _ _ ?P _") + unfolding set_gic_vcpu_ctrl_hcr_def dmo_distr + apply (rule_tac P'="?P" in bind_ev_pre) + apply (wpsimp wp: dmo_mol_reads_respects) + apply (rule do_machine_op_reads_respects'') + apply (wpsimp wp: modify_ev') + apply (clarsimp simp: equiv_for_def equiv_hyp_state_def equiv_fpu_state_def cur_vcpu_for_Some) + apply wpsimp+ + done + +lemma set_gic_vcpu_ctrl_hcr_reads_respects[wp]: + "reads_respects aag l (\s. \vr b. current_vcpu s = Some (vr,b) \ b) + (do_machine_op (set_gic_vcpu_ctrl_hcr val))" + (is "reads_respects _ _ ?P _") + apply (rule_tac P="\s. cur_vcpu_for (aag_can_read_or_affect aag l) s = None" in equiv_valid_cases'') + apply (prop_tac "equiv_hyp (aag_can_read_or_affect aag l) s t") + apply (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def)[1] + apply (auto simp: cur_vcpu_for_None' equiv_hyp_def equiv_for_def)[1] + apply (wpsimp wp: set_gic_vcpu_ctrl_hcr_reads_respects'') + apply (wpsimp wp: set_gic_vcpu_ctrl_hcr_reads_respects') + done + +lemma vcpu_disable_None_reads_respects[wp]: + "reads_respects aag l (\s. \vr. current_vcpu s = Some (vr,True)) (vcpu_disable None)" + apply (simp only: vcpu_disable_def fun_app_def bind_assoc[symmetric] vcpu_save_vgic_defs[symmetric]) + apply (clarsimp simp: dmo_distr) + apply wpsimp + done + +lemma vcpu_invalidate_active_reads_respects: + "reads_respects aag l (\s. cur_vcpu_for (aag_can_read_or_affect aag l) s \ None) vcpu_invalidate_active" + unfolding vcpu_invalidate_active_def + apply wp + apply wpsimp + apply wpsimp + apply (wp gets_arm_current_vcpu_reads_respects) + apply wpsimp + apply clarsimp + done + +lemma arch_thread_get_tcb_vcpu_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read aag t)) (arch_thread_get tcb_vcpu t)" + unfolding arch_thread_get_def + apply wpsimp + apply fastforce + done + +(* FIXME AARCH64 IF: move *) +lemma gets_comp: + "do x <- gets f; + m (g x) + od = + do x <- gets (g \ f); + m x + od" + by (simp add: gets_def) + +lemma dissociate_vcpu_tcb_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (K (aag_can_read aag t \ aag_can_read aag vr)) + (dissociate_vcpu_tcb vr t)" + apply (clarsimp simp: dissociate_vcpu_tcb_def as_user_bind) + apply (subst gets_comp) + apply (wpsimp wp: as_user_set_register_reads_respects' as_user_getRegister_reads_respects when_ev + vcpu_invalidate_active_reads_respects get_vcpu_wp arch_thread_get_wp) + apply (rule conjI; clarsimp) + apply (prop_tac "equiv_hyp (aag_can_read aag) sa ta") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (fastforce simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + done + +lemma dissociate_vcpu_tcb_helper: + "\\s. \vcpu'. vcpus_of s vr = Some vcpu' \ P (Some (if v = vr then vcpu'\vcpu_tcb := None\ else vcpu'))\ + dissociate_vcpu_tcb v t + \\_ s. P (vcpus_of s vr)\" + unfolding dissociate_vcpu_tcb_def + apply (wpsimp wp: get_vcpu_wp hoare_vcg_all_lift arch_thread_get_wp) + apply (auto elim!: rsubst[where P=P] intro!: ext split: if_splits) + done + +lemma associate_vcpu_tcb_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (pas_refined aag and valid_arch_state and K (is_subject aag vr \ is_subject aag t)) (associate_vcpu_tcb vr t)" + unfolding associate_vcpu_tcb_def + apply (rule_tac P'="\s. vcpus_of s vr \ None" in equiv_valid_guard_necessary) + apply (clarsimp simp: bind_assoc) + apply (wpsimp wp: get_vcpu_vcpu_at simp: obj_at_def opt_map_def) + apply (subst gets_comp) + apply (wpsimp wp: when_ev vcpu_switch_reads_respects dissociate_vcpu_tcb_reads_respects + arch_thread_get_wp get_vcpu_wp dissociate_vcpu_tcb_helper + hoare_vcg_imp_lift' hoare_vcg_all_lift) + apply (intro conjI impI allI; clarsimp?) + apply (fastforce simp: get_tcb_ko_at dest: associated_vcpu_is_subject) + apply (fastforce dest: associated_tcb_is_subject) + apply (clarsimp simp: reads_equiv_def) + apply (fastforce dest: associated_tcb_is_subject) + apply (clarsimp simp: reads_equiv_def) + done + +lemma perform_vcpu_invocation_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag l (pas_refined aag and valid_arch_state and valid_vcpu_invocation iv and K (authorised_vcpu_inv aag iv)) + (perform_vcpu_invocation iv)" + unfolding perform_vcpu_invocation_def authorised_vcpu_inv_def + by (cases iv; wpsimp wp: associate_vcpu_tcb_reads_respects + invoke_vcpu_inject_irq_reads_respects + invoke_vcpu_read_register_reads_respects + invoke_vcpu_write_register_reads_respects + invoke_vcpu_ack_vppi_reads_respects) + +lemma set_vcpu_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + set_vcpu ptr vcpu + \\_. globals_equiv s\" + unfolding set_vcpu_def + apply (wpsimp wp: set_object_globals_equiv[THEN hoare_set_object_weaken_pre] get_object_wp + simp: partial_inv_def)+ + apply (fastforce simp: obj_at_def valid_arch_state_def dest: valid_global_arch_objs_pt_at) + done + +lemma vcpu_update_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + vcpu_update vr f + \\_. globals_equiv s\" + unfolding vcpu_update_def + by wpsimp + +lemma thread_set_globals_equiv: + "(\tcb. arch_tcb_context_get (tcb_arch (f tcb)) = arch_tcb_context_get (tcb_arch tcb)) + \ \globals_equiv s and valid_arch_state\ thread_set f tptr \\_. globals_equiv s\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + apply simp + apply (intro impI conjI allI) + apply (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def dest: valid_global_arch_objs_pt_at)+ + done + +lemma arch_thread_set_vcpu_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + arch_thread_set (tcb_vcpu_update f) t + \\_. globals_equiv s\" + unfolding arch_thread_set_is_thread_set + by (wpsimp wp: thread_set_globals_equiv simp: arch_tcb_context_get_def) + +crunch vcpu_save_reg + for globals_equiv[wp]: "globals_equiv st" + (simp: readVCPUHardwareReg_def) + +crunch vgic_update_lr + for globals_equiv[wp]: "globals_equiv st" + +lemma vcpu_save_reg_range_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + vcpu_save_reg_range vr from to + \\_. globals_equiv s\" + unfolding vcpu_save_reg_range_def + apply (rule hoare_strengthen_post) + apply (rule mapM_x_wp_inv) + apply wpsimp+ + done + +lemma dmo_globals_equiv: + "\ \P. f \\ms. P (device_state ms)\ \ + \ do_machine_op f \globals_equiv st\" + apply (simp add: do_machine_op_def) + apply (wp modify_wp | simp add: split_def)+ + apply (clarsimp simp: globals_equiv_def idle_equiv_def) + apply (erule use_valid, fastforce+) + done + +crunch vcpu_save + for globals_equiv[wp]: "globals_equiv st" + (wp: mapM_wp_inv dmo_globals_equiv simp: crunch_simps) + +crunch vcpu_restore + for globals_equiv[wp]: "globals_equiv st" + (wp: mapM_x_wp_inv mapM_wp_inv dmo_globals_equiv simp: crunch_simps) + +crunch vcpu_disable + for globals_equiv[wp]: "globals_equiv st" + (wp: mapM_x_wp_inv mapM_wp_inv dmo_globals_equiv simp: crunch_simps) + +lemma globals_equiv_arm_current_vcpu_update[simp]: + "globals_equiv st (s\arch_state := arch_state s\arm_current_vcpu := vcpu'\\) = globals_equiv st s" + by (auto simp: globals_equiv_def idle_equiv_def) + +crunch vcpu_switch + for globals_equiv[wp]: "globals_equiv st" + (wp: mapM_x_wp_inv mapM_wp_inv dmo_globals_equiv simp: crunch_simps) + +lemma vcpu_invalidate_active_valid_arch_state[wp]: + "vcpu_invalidate_active \valid_arch_state\" + unfolding vcpu_invalidate_active_def + apply wp + apply (rule_tac Q'="\_. valid_arch_state" in hoare_strengthen_post[rotated]) + apply (clarsimp simp: valid_arch_state_def cur_vcpu_def valid_global_arch_objs_def) + apply wpsimp+ + done + +crunch vcpu_invalidate_active + for globals_equiv[wp]: "globals_equiv st" + +lemma dissociate_vcpu_tcb_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state and (\s. t \ idle_thread s)\ + dissociate_vcpu_tcb vr t + \\_. globals_equiv s\" + unfolding dissociate_vcpu_tcb_def + apply (wpsimp wp: as_user_globals_equiv simp: arch_tcb_context_get_def as_user_bind) + apply (rule_tac Q'="\_ s. arm_current_vcpu (arch_state s) = None" in hoare_post_add) + apply (clarsimp cong: conj_cong) + apply (wpsimp wp: get_vcpu_wp arch_thread_get_wp)+ + done + +lemma associate_vcpu_tcb_globals_equiv[wp]: + "\globals_equiv s and invs and ex_nonz_cap_to t\ + associate_vcpu_tcb vr t + \\_. globals_equiv s\" + unfolding associate_vcpu_tcb_def + apply (wpsimp) + apply (wp hoare_drop_imps) + apply clarsimp + apply wpsimp + apply clarsimp + apply wpsimp + apply (wp get_vcpu_wp) + apply (rule_tac Q'="\_. globals_equiv s and valid_arch_state" in hoare_post_add) + apply (clarsimp cong: conj_cong) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift dissociate_vcpu_tcb_vcpus_of) + apply (wp arch_thread_get_wp) + apply clarsimp + apply (case_tac "t = idle_thread sa", clarsimp) + using idle_no_ex_cap apply fastforce + apply clarsimp + apply (case_tac "vcpus_of sa vr"; clarsimp) + apply (case_tac "vcpu_tcb a"; clarsimp) + apply (case_tac "aa = idle_thread sa"; clarsimp) + apply (subgoal_tac "False", clarsimp) + apply (rename_tac s' tcb vcpu) + apply (prop_tac "(idle_thread s', HypTCBRef) \ state_hyp_refs_of s' vr") + apply (clarsimp simp: state_hyp_refs_of_def opt_map_def split: option.splits) + apply (drule sym_refsD) + apply (erule invs_hyp_sym_refs) + apply (clarsimp simp: obj_at_vcpu_hyp_live_of_s[symmetric] is_vcpu_def + state_hyp_refs_of_def obj_at_def hyp_live_def hyp_refs_of_def + tcb_vcpu_refs_def refs_of_ao_def arch_live_def vcpu_tcb_refs_def + split: option.splits kernel_object.splits arch_kernel_obj.splits) + apply (frule invs_valid_idle) + apply (clarsimp simp: valid_idle_def pred_tcb_at_def) + apply (frule invs_iflive) + apply (frule invs_valid_global_refs) + apply (frule invs_valid_objs) + apply (drule (1) idle_no_ex_cap) + apply (erule swap, erule if_live_then_nonz_capD) + apply simp + apply clarsimp + apply (clarsimp simp: live_def hyp_live_def) + done + +crunch invoke_vcpu_inject_irq, invoke_vcpu_read_register, invoke_vcpu_write_register, invoke_vcpu_ack_vppi, perform_smc_invocation + for globals_equiv[wp]: "globals_equiv s" + (wp: dmo_globals_equiv) + +lemma perform_vcpu_invocation_globals_equiv: + "\globals_equiv s and invs and valid_vcpu_invocation iv\ + perform_vcpu_invocation iv + \\_. globals_equiv s\" + unfolding perform_vcpu_invocation_def valid_vcpu_invocation_def + by (cases iv; wpsimp) + +lemma perform_sgi_invocation_reads_respects: + "reads_respects aag l \ (perform_sgi_invocation api)" + unfolding perform_sgi_invocation_def sendSGI_def + by (case_tac api; wpsimp wp: dmo_mol_reads_respects) + +lemma perform_smc_invocation_reads_respects: + "reads_respects aag l \ (perform_smc_invocation api)" + unfolding perform_smc_invocation_def + by (case_tac api; wpsimp wp: dmo_doSMC_mop_reads_respects) + + +definition authorised_for_globals_arch_inv :: + "arch_invocation \ ('z::state_ext) state \ bool" where + "authorised_for_globals_arch_inv ai \ + case ai of InvokePageTable oper \ authorised_for_globals_page_table_inv oper + | InvokePage oper \ authorised_for_globals_page_inv oper + | _ \ \" + +lemma arch_perform_invocation_reads_respects_g: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects_g aag l (ct_active and authorised_arch_inv aag ai and valid_arch_inv ai + and authorised_for_globals_arch_inv ai and invs + and pas_refined aag and is_subject aag \ cur_thread) + (arch_perform_invocation ai)" + unfolding arch_perform_invocation_def fun_app_def + apply (case_tac ai; clarsimp) + by (wpsimp wp: doesnt_touch_globalsI + reads_respects_g[OF perform_page_table_invocation_reads_respects] + reads_respects_g[OF perform_page_invocation_reads_respects] + reads_respects_g[OF perform_asid_control_invocation_reads_respects] + reads_respects_g[OF perform_vspace_invocation_reads_respects] + reads_respects_g[OF perform_vcpu_invocation_reads_respects] + reads_respects_g[OF perform_sgi_invocation_reads_respects] + reads_respects_g[OF perform_smc_invocation_reads_respects] + perform_asid_pool_invocation_reads_respects_g + perform_page_table_invocation_globals_equiv + perform_page_invocation_globals_equiv + perform_asid_control_invocation_globals_equiv + perform_asid_pool_invocation_globals_equiv + perform_vcpu_invocation_globals_equiv + perform_sgi_invocation_globals_equiv + simp: authorised_arch_inv_def valid_arch_inv_def authorised_for_globals_arch_inv_def + invs_psp_aligned invs_valid_objs invs_vspace_objs invs_valid_asid_table | simp)+ + +lemma arch_perform_invocation_globals_equiv: + "\globals_equiv s and invs and ct_active and valid_arch_inv ai + and authorised_for_globals_arch_inv ai\ + arch_perform_invocation ai + \\_. globals_equiv s\" + unfolding arch_perform_invocation_def + apply (wpsimp wp: perform_page_table_invocation_globals_equiv + perform_page_invocation_globals_equiv + perform_asid_control_invocation_globals_equiv + perform_asid_pool_invocation_globals_equiv + perform_vcpu_invocation_globals_equiv)+ + apply (auto simp: authorised_for_globals_arch_inv_def invs_def valid_state_def valid_arch_inv_def) + done + +crunch arch_post_cap_deletion + for valid_global_objs[wp]: "valid_global_objs" + +(* generalises auth_ipc_buffers_mem_Write *) +lemma auth_ipc_buffers_mem_Write': + "\ x \ auth_ipc_buffers s thread; pas_refined aag s; valid_objs s \ + \ (pasObjectAbs aag thread, Write, pasObjectAbs aag x) \ pasPolicy aag" + apply (clarsimp simp add: auth_ipc_buffers_member_def) + apply (drule (1) cap_auth_caps_of_state) + apply simp + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + vspace_cap_rights_to_auth_def vm_read_write_def + split: if_split_asm) + apply (auto dest: ipcframe_subset_page) + done + +end + +(* FIXME AARCH64 IF: add to interface *) + +arch_requalify_consts + authorised_for_globals_arch_inv + +arch_requalify_facts + arch_post_cap_deletion_valid_global_objs + auth_ipc_buffers_mem_Write' + thread_set_globals_equiv + arch_post_modify_registers_cur_domain + arch_post_modify_registers_cur_thread + length_msg_lt_msg_max + set_mrs_globals_equiv + arch_perform_invocation_globals_equiv + check_valid_ipc_buffer_inv + arch_perform_invocation_reads_respects_g + +declare + arch_post_cap_deletion_valid_global_objs[wp] + arch_post_modify_registers_cur_domain[wp] + arch_post_modify_registers_cur_thread[wp] + prepare_thread_delete_st_tcb_at_halted[wp] + +end diff --git a/proof/infoflow/AARCH64/ArchCNode_IF.thy b/proof/infoflow/AARCH64/ArchCNode_IF.thy new file mode 100644 index 0000000000..6e95437e4a --- /dev/null +++ b/proof/infoflow/AARCH64/ArchCNode_IF.thy @@ -0,0 +1,127 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchCNode_IF +imports CNode_IF +begin + +context Arch begin arch_global_naming + +named_theorems CNode_IF_assms + +lemma set_object_globals_equiv: + "\globals_equiv s and (\s. ptr \ arm_us_global_vspace (arch_state s)) and + (\t. ptr = idle_thread t + \ (\tcb. kheap t (idle_thread t) = Some (TCB tcb) + \ (\tcb'. obj = (TCB tcb') + \ arch_tcb_context_get (tcb_arch tcb) = arch_tcb_context_get (tcb_arch tcb'))) \ + (\tcb'. obj = (TCB tcb') \ tcb_at (idle_thread t) t))\ + set_object ptr obj + \\_. globals_equiv s\" + apply (wpsimp wp: set_object_wp) + apply (case_tac "ptr = idle_thread sa") + apply (clarsimp simp: globals_equiv_def idle_equiv_def tcb_at_def2) + apply (intro impI conjI allI notI iffI | clarsimp)+ + apply (clarsimp simp: globals_equiv_def idle_equiv_def tcb_at_def2) + done + +lemma set_cap_globals_equiv[CNode_IF_assms]: + "\globals_equiv s and valid_arch_state\ + set_cap cap p + \\_. globals_equiv s\" + unfolding set_cap_def + apply (simp only: split_def) + apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ + apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def + dest: valid_global_arch_objs_pt_at)+ + done + +definition irq_at :: "nat \ (irq \ bool) \ irq option" where + "irq_at pos masks \ let i = irq_oracle pos in (if masks i then None else Some i)" + +lemma arch_globals_equiv_irq_state_update[CNode_IF_assms, simp]: + "arch_globals_equiv ct it kh kh' as as' ms (irq_state_update f ms') = + arch_globals_equiv ct it kh kh' as as' ms ms'" + "arch_globals_equiv ct it kh kh' as as' (irq_state_update f ms) ms' = + arch_globals_equiv ct it kh kh' as as' ms ms'" + by auto + +end + + +arch_requalify_consts irq_at + +global_interpretation CNode_IF_1?: CNode_IF_1 _ irq_at +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact CNode_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma is_irq_at_triv[CNode_IF_assms]: + assumes a: "\P. \(\s. P (irq_masks (machine_state s))) and Q\ + f + \\rv s. P (irq_masks (machine_state s))\" + shows "\(\s. P (is_irq_at s)) and Q\ f \\rv s. P (is_irq_at s)\" + apply (clarsimp simp: valid_def is_irq_at_def irq_at_def Let_def) + apply (erule use_valid[OF _ a]) + apply simp + done + +lemma is_irq_at_not_masked[CNode_IF_assms]: + "is_irq_at s irq pos \ \ irq_masks (machine_state s) irq" + by (clarsimp simp: is_irq_at_def irq_at_def split: option.splits simp: Let_def split: if_splits) + +end + + +global_interpretation CNode_IF_2?: CNode_IF_2 irq_at +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact CNode_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: + notes gets_ev[wp del] + shows "reads_respects aag l (invs and only_timer_irq_inv irq st) + (do_machine_op (getActiveIRQ in_kernel))" + apply (rule do_machine_op_reads_respects') + apply (simp add: getActiveIRQ_def) + apply (wp irq_state_increment_reads_respects_memory irq_state_increment_reads_respects_device + gets_ev[where f="irq_oracle \ irq_state"] equiv_valid_inv_conj_lift + gets_irq_masks_equiv_valid modify_wp + | simp add: no_irq_def)+ + apply (rule only_timer_irq_inv_determines_irq_masks, blast+) + apply (wpsimp simp: irq_state_independent_def)+ + done + +lemma dmo_getActiveIRQ_globals_equiv[CNode_IF_assms]: + "do_machine_op (getActiveIRQ in_kernel) \globals_equiv st\" + unfolding globals_equiv_def arch_globals_equiv_def idle_equiv_def + apply (rule hoare_weaken_pre) + apply wps + apply wpsimp + apply clarsimp + done + +end + + +global_interpretation CNode_IF_3?: CNode_IF_3 irq_at +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact CNode_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchDecode_IF.thy b/proof/infoflow/AARCH64/ArchDecode_IF.thy new file mode 100644 index 0000000000..4046529cd8 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchDecode_IF.thy @@ -0,0 +1,421 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchDecode_IF +imports Decode_IF +begin + +context Arch begin arch_global_naming + +named_theorems Decode_IF_assms + +lemma data_to_obj_type_rev[Decode_IF_assms]: + "reads_equiv_valid_inv A aag \ (data_to_obj_type type)" + unfolding data_to_obj_type_def fun_app_def arch_data_to_obj_type_def + apply (wp | wpc)+ + apply simp + done + +lemma check_valid_ipc_buffer_rev[Decode_IF_assms]: + "reads_equiv_valid_inv A aag \ (check_valid_ipc_buffer vptr cap)" + unfolding check_valid_ipc_buffer_def fun_app_def + apply (rule equiv_valid_guard_imp) + apply (wpc | wp)+ + apply simp + done + +lemma arch_check_irq_rev[Decode_IF_assms, wp]: + "reads_equiv_valid_inv A aag \ (arch_check_irq irq)" + unfolding arch_check_irq_def + apply (rule equiv_valid_guard_imp) + apply wpsimp+ + done + +lemma vspace_cap_rights_to_auth_mono[Decode_IF_assms]: + "R \ S \ vspace_cap_rights_to_auth R \ vspace_cap_rights_to_auth S" + by (auto simp: vspace_cap_rights_to_auth_def) + +lemma arch_decode_irq_control_invocation_rev[Decode_IF_assms]: + "reads_equiv_valid_inv A aag + (pas_refined aag and + K (is_subject aag (fst slot) \ (\cap\set caps. pas_cap_cur_auth aag cap) \ + (args \ [] \ (pasSubject aag, Control, pasIRQAbs aag (ucast (args ! 0))) \ pasPolicy aag))) + (arch_decode_irq_control_invocation label args slot caps)" + unfolding arch_decode_irq_control_invocation_def arch_check_irq_def + apply (wp ensure_empty_rev lookup_slot_for_cnode_op_rev + is_irq_active_rev whenE_inv range_check_ev + | wp (once) hoare_drop_imps + | simp add: Let_def unlessE_def split del: if_split)+ + apply safe + apply simp+ + apply (blast intro: aag_Control_into_owns_irq) + apply (drule_tac x="caps ! 0" in bspec) + apply (fastforce intro: bang_0_in_set) + apply (drule (1) is_cnode_into_is_subject; blast dest: prop_of_obj_ref_of_cnode_cap) + apply (fastforce dest: is_cnode_into_is_subject intro: bang_0_in_set) + apply (drule_tac x="caps ! 0" in bspec) + apply (fastforce intro: bang_0_in_set) + apply (drule (1) is_cnode_into_is_subject; blast dest: prop_of_obj_ref_of_cnode_cap) + apply (fastforce dest: is_cnode_into_is_subject intro: bang_0_in_set) + done + +end + + +global_interpretation Decode_IF_1?: Decode_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Decode_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq'': + "\ \asid. is_subject_asid aag asid; reads_equiv aag s t; pas_refined aag x \ + \ arm_asid_table (arch_state s) (asid_high_bits_of base) = + arm_asid_table (arch_state t) (asid_high_bits_of base)" + supply asid_high_bits_of_0[simp del] + apply (subgoal_tac "asid_high_bits_of 0 = asid_high_bits_of 1") + apply (case_tac "base = 0") + apply (subgoal_tac "is_subject_asid aag 1") + apply ((auto intro: requiv_arm_asid_table_asid_high_bits_of_asid_eq) | + (auto simp: asid_high_bits_of_def asid_low_bits_def))+ + done + +lemma pas_cap_cur_auth_ASIDControlCap: + "\ pas_cap_cur_auth aag (ArchObjectCap ASIDControlCap); reads_equiv aag s t; pas_refined aag x \ + \ arm_asid_table (arch_state s) = arm_asid_table (arch_state t)" + apply (rule ext) + apply (subst asid_high_bits_of_shift[symmetric]) + apply (subst (3) asid_high_bits_of_shift[symmetric]) + apply (rule requiv_arm_asid_table_asid_high_bits_of_asid_eq'') + apply (clarsimp simp: aag_cap_auth_def cap_links_asid_slot_def label_owns_asid_slot_def) + apply (rule pas_refined_Control_into_is_subject_asid, blast+) + done + +lemma decode_asid_pool_invocation_reads_respects_f: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + notes whenE_wps[wp_split del] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and K (cap = ASIDPoolCap x xa) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_asid_pool_invocation label args slot cap excaps)" + unfolding decode_asid_pool_invocation_def + apply (rule equiv_valid_guard_imp) + apply (subst gets_applyE)+ + apply (wp check_vp_wpR + reads_respects_f_inv'[OF get_asid_pool_rev] + gets_apply_ev + select_ext_ev_bind_lift + | wpc + | simp add: Let_def unlessE_whenE + | wp (once) whenE_throwError_wp)+ + apply (intro impI allI conjI) + apply (rule requiv_arm_asid_table_asid_high_bits_of_asid_eq') + apply fastforce + apply (simp add: reads_equiv_f_def) + apply blast + apply (fastforce simp: aag_cap_auth_ASIDPoolCap) + done + +lemma decode_asid_control_invocation_reads_respects_f: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + notes whenE_wps[wp_split del] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and K (cap = ASIDControlCap) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_asid_control_invocation label args slot cap excaps)" + unfolding decode_asid_control_invocation_def + apply (rule equiv_valid_guard_imp) + apply (wp check_vp_wpR reads_respects_f_inv'[OF get_asid_pool_rev] + reads_respects_f_inv'[OF ensure_empty_rev] + reads_respects_f_inv'[OF lookup_slot_for_cnode_op_rev] + reads_respects_f_inv'[OF ensure_no_children_rev] + reads_respects_f_inv'[OF lookup_error_on_failure_rev] + gets_apply_ev + is_final_cap_reads_respects + select_ext_ev_bind_lift + select_ext_ev_bind_lift[simplified] + | wpc + | simp add: Let_def unlessE_whenE + | wp (once) whenE_throwError_wp)+ + apply clarsimp + apply (prop_tac "excaps ! Suc 0 \ set excaps", fastforce) + apply (drule_tac x="excaps ! Suc 0" in bspec, assumption) + apply (frule_tac x="excaps ! Suc 0" in bspec, assumption) + apply (drule_tac x="excaps ! 0" in bspec, fastforce intro!: bang_0_in_set) + apply (intro impI allI conjI) + apply (fastforce intro: pas_cap_cur_auth_ASIDControlCap[where aag=aag] simp: reads_equiv_f_def) + apply fastforce + apply (fastforce intro: owns_cnode_owns_obj_ref_of_child_cnodes[where slot="snd (excaps ! (Suc 0))"]) + apply clarify + apply (rule_tac cap="fst (excaps ! Suc 0)" and p="snd (excaps ! Suc 0)" in caps_of_state_pasObjectAbs_eq) + apply (rule cte_wp_at_caps_of_state') + apply fastforce + apply (erule cap_auth_conferred_cnode_cap) + apply fastforce + apply assumption + apply fastforce + done + +lemma reads_respects_f_check_vspace_root[wp]: + "reads_respects_f aag l \ (check_vspace_root cap arg)" + unfolding check_vspace_root_def by wpsimp + +lemma decode_frame_invocation_reads_respects_f: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + notes whenE_wps[wp_split del] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and valid_arch_cap cap and K (cap = FrameCap p R sz dev m) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_frame_invocation label args slot cap excaps)" + unfolding decode_frame_invocation_def decode_fr_inv_map_def decode_fr_inv_flush_def + check_vp_alignment_def gets_the_def + apply (rule gen_asm_ev)+ + apply (rule equiv_valid_guard_imp) + apply ((wp gets_ev' check_vp_wpR reads_respects_f_inv'[OF get_asid_pool_rev] + reads_respects_f_inv'[OF ensure_empty_rev] + reads_respects_f_inv'[OF get_pte_rev] + reads_respects_f_inv'[OF lookup_slot_for_cnode_op_rev] + reads_respects_f_inv'[OF ensure_no_children_rev] + reads_respects_f_inv'[OF lookup_error_on_failure_rev] + find_vspace_for_asid_reads_respects + is_final_cap_reads_respects + select_ext_ev_bind_lift + select_ext_ev_bind_lift[simplified] + | wpc + | simp add: Let_def unlessE_whenE + | wp (once) whenE_throwError_wp)+)[1] + apply (case_tac "invocation_type label = ArchInvocationLabel ARMPageMap"; clarsimp) + apply (drule_tac x="excaps ! 0" in bspec, fastforce intro: bang_0_in_set)+ + apply clarsimp + apply (case_tac "m = None \ \ user_vtop < args ! 0 + mask (pageBitsForSize sz) \ (m = Some (asid, args ! 0))") + prefer 2 + apply clarsimp + apply (prop_tac "\ user_vtop < args ! 0 + mask (pageBitsForSize sz) \ args ! 0 \ user_region") + apply (clarsimp simp: user_region_def not_le) + apply (rule user_vtop_leq_canonical_user) + apply (simp add: vmsz_aligned_def not_less) + apply (drule is_aligned_no_overflow_mask) + apply simp + apply (prop_tac "args ! 0 \ user_region") + apply (fastforce simp: valid_arch_cap_def wellformed_mapdata_def) + apply (subgoal_tac "(\t. reads_equiv_f aag s t \ affects_equiv aag l s t \ + pt_lookup_slot pt (args ! 0) (ptes_of s) = pt_lookup_slot pt (args ! 0) (ptes_of t))") + apply clarsimp + apply (clarsimp simp: reads_equiv_f_def) + apply (frule vspace_for_asid_vs_lookup) + apply (frule_tac pt=pt and level=max_pt_level and bot_level=0 in pt_walk_reads_equiv) + by (fastforce dest: aag_has_Control_iff_owns + elim: vs_lookup_table_vref_independent + simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + pt_lookup_slot_def pt_lookup_slot_from_level_def obind_def + split: option.splits)+ + +lemma decode_page_table_invocation_reads_respects_f: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and valid_arch_cap cap and K (cap = PageTableCap p pt_t m) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_page_table_invocation label args slot cap excaps)" + unfolding decode_page_table_invocation_def decode_pt_inv_map_def gets_the_def + apply (wp gets_ev' check_vp_wpR reads_respects_f_inv'[OF get_asid_pool_rev] + reads_respects_f_inv'[OF ensure_empty_rev] + reads_respects_f_inv'[OF get_pte_rev] + reads_respects_f_inv'[OF lookup_slot_for_cnode_op_rev] + reads_respects_f_inv'[OF ensure_no_children_rev] + reads_respects_f_inv'[OF lookup_error_on_failure_rev] + find_vspace_for_asid_reads_respects + is_final_cap_reads_respects + select_ext_ev_bind_lift + select_ext_ev_bind_lift[simplified] + | wpc + | simp add: Let_def unlessE_whenE if_fun_split + | wp (once) whenE_throwError_wp hoare_drop_imps)+ + apply clarsimp + apply (rule conjI; clarsimp) + apply (drule_tac x="excaps ! 0" in bspec, fastforce intro: bang_0_in_set)+ + apply (prop_tac "args ! 0 \ user_region") + apply (clarsimp simp: user_region_def not_le) + apply (rule user_vtop_leq_canonical_user) + apply (simp add: vmsz_aligned_def not_less) + apply (clarsimp cong: conj_cong imp_cong) + apply (rule context_conjI; clarsimp) + apply (clarsimp simp: reads_equiv_f_def) + apply (frule vspace_for_asid_vs_lookup) + apply (frule_tac pt=pt and level=max_pt_level and bot_level=0 in pt_walk_reads_equiv, + (fastforce dest: aag_has_Control_iff_owns + elim: vs_lookup_table_vref_independent + simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + pt_lookup_slot_def pt_lookup_slot_from_level_def obind_def + split: option.splits)+)[1] + apply (frule (3) pt_lookup_slot_pte_at) + apply (clarsimp simp: pte_at_def2) + apply (frule vspace_for_asid_is_subject, fastforce+) + apply (clarsimp simp: pt_lookup_slot_def) + apply (erule pt_lookup_slot_from_level_is_subject) + apply fastforce+ + apply (fastforce dest: vspace_for_asid_vs_lookup vs_lookup_table_vref_independent) + apply clarsimp+ + apply (intro conjI) + apply fastforce + apply fastforce + apply fastforce + apply (fastforce dest: silc_inv_not_subject) + done + +lemma reads_respects_gets_lookup_frame: + "reads_respects aag l + (pas_refined aag and pspace_aligned and valid_vspace_objs and valid_asid_table + and (\s. \asid. vspace_for_asid asid s = Some pt \ + is_subject_asid aag asid \ vptr \ user_region)) + (gets (lookup_frame pt vptr \ ptes_of))" + apply (wp gets_ev') + apply (clarsimp simp: lookup_frame_def pt_lookup_slot_def) + apply (frule (3) vspace_for_asid_is_subject) + apply (frule vspace_for_asid_vs_lookup) + apply (rule obind_eqI_full) + apply (frule (6) pt_walk_reads_equiv[where bot_level=0]) + apply (rule order_refl) + apply (erule vs_lookup_table_vref_independent[OF _ order_refl]) + apply (clarsimp simp: pt_lookup_slot_from_level_def obind_def split: option.splits) + apply clarsimp + apply (rule obind_eqI; clarsimp simp: obind_def) + apply (rule_tac aag=aag in ptes_of_reads_equiv) + by (fastforce elim: vs_lookup_table_vref_independent pt_lookup_slot_from_level_is_subject) + +lemma decode_vspace_invocation_reads_respects_f: + notes reads_respects_f_inv' = reads_respects_f_inv[where st=st] + shows + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and valid_arch_cap cap + and K (aag_cap_auth aag (pasObjectAbs aag (fst slot)) (ArchObjectCap cap) \ + is_subject aag (fst slot) \ + (\v \ cap_asid' (ArchObjectCap cap). is_subject_asid aag v))) + (decode_vspace_invocation label args slot cap excaps)" + unfolding decode_vspace_invocation_def decode_vs_inv_flush_def + apply (wpsimp wp: reads_respects_f_inv'[OF reads_respects_gets_lookup_frame] + reads_respects_f_inv'[OF lookup_error_on_failure_rev] + find_vspace_for_asid_reads_respects whenE_throwError_wp hoare_vcg_all_lift + simp: Let_def)+ + apply (fastforce intro: user_vtop_leq_canonical_user simp: user_region_def user_vtop_def) + done + +lemma aag_cap_auth_VCPUCap: + "\ pas_cap_cur_auth aag (ArchObjectCap (VCPUCap vcpu_ptr)); pas_refined aag s \ + \ is_subject aag vcpu_ptr" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma decode_vcpu_inject_irq_reads_respects_f: + "\ cap = VCPUCap vcpu_ptr; invocation_type label = ArchInvocationLabel ARMVCPUInjectIRQ\ + \ reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and valid_arch_cap cap + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_vcpu_inject_irq args (VCPUCap vcpu_ptr))" + unfolding decode_vcpu_inject_irq_def range_check_def unlessE_whenE + apply (wpsimp wp: reads_respects_f[OF get_vcpu_reads_respects, where st=st]) + apply (prop_tac "valid_numlistregs x") + apply (frule invs_arch_state) + apply (clarsimp simp: valid_arch_state_def) + apply (clarsimp simp: valid_numlistregs_def) + apply (auto simp: aag_cap_auth_VCPUCap reads_equiv_f_def reads_equiv_def2 + states_equiv_for_def equiv_hyp_def equiv_for_def + dest: aag_can_read_self) + done + +lemma decode_vcpu_invocation_reads_respects_f: + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and valid_arch_cap cap + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (decode_vcpu_invocation label args cap excaps)" + unfolding decode_vcpu_invocation_def + apply (cases cap; clarsimp; (solves wp)?) + apply (cases "invocation_type label"; clarsimp; (solves wp)?) + by (wpsimp wp: decode_vcpu_inject_irq_reads_respects_f + simp: decode_vcpu_read_register_def decode_vcpu_write_register_def + decode_vcpu_set_tcb_def decode_vcpu_ack_vppi_def arch_check_irq_def + | fastforce)+ + +lemma decode_sgi_signal_invocation_reads_respects_f[wp]: + "reads_respects_f aag l \ (decode_sgi_signal_invocation (SGISignalCap irq target))" + unfolding decode_sgi_signal_invocation_def + by wpsimp + +lemma decode_smc_invocation_reads_respects_f[wp]: + "reads_respects_f aag l \ (decode_smc_invocation label args cap)" + unfolding decode_smc_invocation_def + by (wpsimp simp: unlessE_whenE) + +lemma arch_decode_invocation_reads_respects_f[Decode_IF_assms]: + "reads_respects_f aag l + (silc_inv aag st and invs and pas_refined aag and cte_wp_at ((=) (cap.ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s) + and K (\(cap, slot) \ {(cap.ArchObjectCap cap, slot)} \ set excaps. + aag_cap_auth aag (pasObjectAbs aag (fst slot)) cap \ + is_subject aag (fst slot) \ + (\v \ cap_asid' cap. is_subject_asid aag v))) + (arch_decode_invocation label args cap_index slot cap excaps)" + unfolding arch_decode_invocation_def + apply (cases cap; clarsimp; rule equiv_valid_guard_imp) + by (wpsimp wp: decode_asid_pool_invocation_reads_respects_f + decode_asid_control_invocation_reads_respects_f + decode_frame_invocation_reads_respects_f + decode_vspace_invocation_reads_respects_f + decode_vcpu_invocation_reads_respects_f + decode_page_table_invocation_reads_respects_f + | fastforce dest: caps_of_state_valid cte_wp_at_caps_of_state' + simp: valid_cap_def valid_arch_cap_def)+ + +end + + +global_interpretation Decode_IF_2?: Decode_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Decode_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchFinalCaps.thy b/proof/infoflow/AARCH64/ArchFinalCaps.thy new file mode 100644 index 0000000000..272c8543c8 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchFinalCaps.thy @@ -0,0 +1,456 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchFinalCaps +imports FinalCaps +begin + +context Arch begin arch_global_naming + +named_theorems FinalCaps_assms + +lemma FIXME_arch_gen_refs[FinalCaps_assms]: + "arch_gen_refs cap = {}" + by (clarsimp simp: arch_cap_set_map_def arch_gen_obj_refs_def split: cap.splits) + +lemma aobj_ref_same_aobject[FinalCaps_assms]: + "same_aobject_as cp cp' \ aobj_ref cp = aobj_ref cp'" + by (cases cp; cases cp'; clarsimp) + +lemma set_pt_silc_inv[wp]: + "set_pt ptr pt \silc_inv aag st\" + unfolding set_pt_def + apply (rule silc_inv_pres) + apply (wpsimp wp: set_object_wp_strong simp: a_type_def split: kernel_object.splits) + apply (fastforce simp: silc_inv_def obj_at_def is_cap_table_def) + apply (wp set_object_wp get_object_wp | simp)+ + apply (case_tac "ptr = fst slot") + apply (clarsimp split: kernel_object.splits) + apply (fastforce elim: cte_wp_atE simp: obj_at_def) + apply (fastforce elim: cte_wp_atE intro: cte_wp_at_cteI cte_wp_at_tcbI) + done + +lemma set_asid_pool_silc_inv[wp]: + "set_asid_pool ptr pool \silc_inv aag st\" + unfolding set_asid_pool_def + apply (rule silc_inv_pres) + apply (wpsimp wp: set_object_wp_strong simp: a_type_def split: kernel_object.splits) + apply (fastforce simp: silc_inv_def obj_at_def is_cap_table_def) + apply (wp set_object_wp get_object_wp | simp)+ + apply (case_tac "ptr = fst slot") + apply (clarsimp split: kernel_object.splits) + apply (fastforce elim: cte_wp_atE simp: obj_at_def) + apply (fastforce elim: cte_wp_atE intro: cte_wp_at_cteI cte_wp_at_tcbI) + done + +lemma set_vcpu_silc_inv: + "\silc_inv aag st\ + set_vcpu ptr vcpu + \\_. silc_inv aag st\" + unfolding set_vcpu_def + apply (rule silc_inv_pres) + apply (wpsimp wp: set_object_wp_strong get_object_wp simp: obj_at_def) + apply (drule (1) silc_inv_cnode_only) + apply (fastforce simp: silc_inv_def obj_at_def is_cap_table_def split: kernel_object.splits) + apply (wpsimp wp: set_object_wp get_object_wp) + apply (wpsimp wp: set_object_wp_strong get_object_wp simp: obj_at_def) + apply (case_tac "ptr = fst (a,b)") + apply (fastforce elim: cte_wp_atE simp: obj_at_def) + apply (fastforce elim: cte_wp_atE intro: cte_wp_at_cteI cte_wp_at_tcbI) + done + +crunch vcpu_switch + for silc_inv[wp]: "silc_inv aag st" + (wp: mapM_x_wp_inv mapM_wp_inv) + +crunch associate_vcpu_tcb + for silc_inv[wp]: "silc_inv aag st" + (wp: crunch_wps simp: arch_thread_set_is_thread_set) + +crunch arch_finalise_cap, prepare_thread_delete + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + (wp: crunch_wps modify_wp simp: crunch_simps ignore: set_object) + +crunch init_arch_objects + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + (wp: crunch_wps modify_wp simp: crunch_simps ignore: set_object) + +crunch handle_vm_fault, handle_arch_fault_reply, arch_invoke_irq_handler, arch_mask_irq_signal, + arch_post_cap_deletion, arch_post_modify_registers, arch_activate_idle_thread, + arch_switch_to_idle_thread, arch_switch_to_thread + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + +lemma arch_derive_cap_silc[FinalCaps_assms]: + "\\s. cap = ArchObjectCap acap \ + (\ cap_points_to_label aag cap l \ R (slots_holding_overlapping_caps cap s))\ + arch_derive_cap acap + \\cap' s. \ cap_points_to_label aag cap' l \ R (slots_holding_overlapping_caps cap' s)\, -" + apply (simp add: arch_derive_cap_def) + apply wpsimp + apply (auto simp: cap_points_to_label_def slots_holding_overlapping_caps_def) + done + +declare init_arch_objects_cte_wp_at[FinalCaps_assms] +declare handle_vm_fault_cur_thread[FinalCaps_assms] +declare finalise_cap_makes_halted[FinalCaps_assms] + +end + + +global_interpretation FinalCaps_1?: FinalCaps_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma perform_page_table_invocation_silc_inv_get_cap_helper: + "\silc_inv aag st and cte_wp_at (is_pt_cap or is_frame_cap) xa\ + get_cap xa + \(\capa s. (\ cap_points_to_label aag (ArchObjectCap $ update_map_data capa None) + (pasObjectAbs aag (fst xa)) + \ (\lslot. lslot \ slots_holding_overlapping_caps + (ArchObjectCap $ update_map_data capa None) s \ + pasObjectAbs aag (fst lslot) = SilcLabel))) \ the_arch_cap\" + apply (wp get_cap_wp) + apply clarsimp + apply (drule cte_wp_at_norm) + apply (clarify) + apply (drule (1) cte_wp_at_eqD2) + apply (case_tac cap, simp_all add: is_frame_cap_def is_pt_cap_def) + apply (clarsimp simp: cap_points_to_label_def update_map_data_def split: arch_cap.splits) + apply (drule silc_invD) + apply assumption + apply (fastforce simp: intra_label_cap_def cap_points_to_label_def) + apply (fastforce simp: slots_holding_overlapping_caps_def2 ctes_wp_at_def) + apply (drule silc_invD) + apply assumption + apply (fastforce simp: intra_label_cap_def cap_points_to_label_def) + apply (fastforce simp: slots_holding_overlapping_caps_def2 ctes_wp_at_def) + done + +lemmas perform_page_table_invocation_silc_inv_get_cap_helper' = + perform_page_table_invocation_silc_inv_get_cap_helper[simplified o_def fun_app_def] + +lemma mapM_x_swp_store_pte_silc_inv[wp]: + "mapM_x (swp (store_pte pt_t) A) slots \silc_inv aag st\" + by (wp mapM_x_wp[OF _ subset_refl] | simp add: swp_def)+ + +lemma is_arch_eq_pt_is_pt_or_frame_cap: + "cte_wp_at ((=) (ArchObjectCap (PageTableCap pt_t xa xb))) slot s + \ cte_wp_at (\a. is_pt_cap a \ is_frame_cap a) slot s" + apply (erule cte_wp_at_weakenE) + by (clarsimp simp: is_frame_cap_def is_pt_cap_def) + +lemma is_arch_eq_pg_is_pt_or_pg_cap: + "cte_wp_at ((=) (ArchObjectCap (FrameCap xa xb xc xd xe))) slot s + \ cte_wp_at (\a. is_pt_cap a \ is_frame_cap a) slot s" + apply (erule cte_wp_at_weakenE) + by (clarsimp simp: is_frame_cap_def is_pt_cap_def) + +lemma perform_page_table_invocation_silc_inv: + "\silc_inv aag st and valid_pti blah and K (authorised_page_table_inv aag blah)\ + perform_page_table_invocation blah + \\_. silc_inv aag st\" + unfolding perform_page_table_invocation_def perform_pt_inv_map_def perform_pt_inv_unmap_def + apply (rule hoare_pre) + apply (wp set_cap_silc_inv mapM_x_wp[OF _ subset_refl] + perform_page_table_invocation_silc_inv_get_cap_helper'[where st=st] + | wpc | simp only: o_def fun_app_def K_def swp_def)+ + apply (clarsimp simp: valid_pti_def authorised_page_table_inv_def + split: page_table_invocation.splits) + apply (rule conjI) + apply (clarsimp) + defer + apply (fastforce simp: silc_inv_def) + apply (fastforce dest: is_arch_eq_pt_is_pt_or_frame_cap + simp: silc_inv_def is_PageTableCap_def pred_disj_def) + apply (drule_tac slot="(aa,ba)" in overlapping_slots_have_labelled_overlapping_caps[rotated]) + apply (fastforce) + apply (fastforce elim: is_arch_update_overlaps[rotated] cte_wp_at_weakenE) + apply fastforce + done + +crunch invalidate_tlb_by_asid_va, perform_flush + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + +lemma perform_page_invocation_silc_inv: + "\silc_inv aag st and valid_page_inv blah and authorised_page_inv aag blah\ + perform_page_invocation blah + \\_. silc_inv aag st\" + unfolding perform_page_invocation_def perform_pg_inv_map_def perform_pg_inv_unmap_def perform_pg_inv_get_addr_def + apply (rule hoare_pre) + apply (wp mapM_wp[OF _ subset_refl] set_cap_silc_inv + mapM_x_wp[OF _ subset_refl] + perform_page_table_invocation_silc_inv_get_cap_helper'[where st=st] + hoare_vcg_all_lift hoare_vcg_if_lift hoare_weak_lift_imp + | wpc + | simp only: swp_def o_def fun_app_def K_def + | wp (once) hoare_drop_imps)+ + apply (clarsimp simp: valid_page_inv_def authorised_page_inv_def + split: page_invocation.splits) + apply (intro allI impI conjI) + apply (drule_tac slot="(ac,bb)" in overlapping_slots_have_labelled_overlapping_caps[rotated]) + apply (fastforce)+ + apply (fastforce elim: is_arch_update_overlaps[rotated] cte_wp_at_weakenE) + apply fastforce+ + apply (fastforce simp: silc_inv_def) + apply (drule_tac slot="(ac,bb)" in overlapping_slots_have_labelled_overlapping_caps[rotated]) + apply (fastforce)+ + apply (fastforce elim: is_arch_update_overlaps[rotated] cte_wp_at_weakenE) + apply fastforce+ + apply (fastforce simp: silc_inv_def) + apply (fastforce dest: is_arch_eq_pg_is_pt_or_pg_cap simp: silc_inv_def pred_disj_def) + done + +lemma perform_asid_control_invocation_silc_inv: + notes blah[simp del] = atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + shows + "\silc_inv aag st and valid_aci blah and invs and K (authorised_asid_control_inv aag blah)\ + perform_asid_control_invocation blah + \\_. silc_inv aag st\" + apply (rule hoare_gen_asm) + unfolding perform_asid_control_invocation_def + apply (rule hoare_pre) + apply (wp modify_wp cap_insert_silc_inv' retype_region_silc_inv[where sz=pageBits] + set_cap_silc_inv get_cap_slots_holding_overlapping_caps[where st=st] + delete_objects_silc_inv hoare_weak_lift_imp + | wpc | simp)+ + apply (clarsimp simp: authorised_asid_control_inv_def silc_inv_def valid_aci_def ptr_range_def) + apply (rule conjI) + apply (clarsimp simp: range_cover_def obj_bits_api_def default_arch_object_def asid_bits_def pageBits_def) + apply (rule of_nat_inverse) + apply simp + apply (drule is_aligned_neg_mask_eq'[THEN iffD1, THEN sym]) + apply (erule_tac t=x in ssubst) + apply (simp add: mask_AND_NOT_mask) + apply simp + apply (simp add: p_assoc_help) + apply (clarsimp simp: cap_points_to_label_def) + apply (erule bspec) + apply (fastforce intro: is_aligned_no_wrap' simp: blah) + done + +crunch store_asid_pool_entry, handle_spurious_irq + for silc_inv[wp]: "silc_inv aag st" + +lemma perform_asid_pool_invocation_silc_inv: + "\silc_inv aag st and K (authorised_asid_pool_inv aag blah)\ + perform_asid_pool_invocation blah + \\_. silc_inv aag st\" + unfolding perform_asid_pool_invocation_def + apply (wpsimp wp: set_cap_silc_inv get_cap_wp)+ + apply (fastforce dest: silc_invD + simp: intra_label_cap_def cap_points_to_label_def silc_inv_def + slots_holding_overlapping_caps_def authorised_asid_pool_inv_def + is_ArchObjectCap_def is_PageTableCap_def update_map_data_def)+ + done + +crunch perform_vcpu_invocation, perform_vspace_invocation, perform_sgi_invocation, perform_smc_invocation + for silc_inv[wp]: "silc_inv aag st" + +declare handle_spurious_irq_silc_inv[wp, FinalCaps_assms] + +lemma arch_perform_invocation_silc_inv[FinalCaps_assms]: + "\silc_inv aag st and invs and valid_arch_inv ai and authorised_arch_inv aag ai\ + arch_perform_invocation ai + \\_. silc_inv aag st\" + unfolding arch_perform_invocation_def + apply (rule hoare_pre) + apply (wp perform_page_table_invocation_silc_inv + perform_page_invocation_silc_inv + perform_asid_control_invocation_silc_inv + perform_asid_pool_invocation_silc_inv + perform_vcpu_invocation_silc_inv + | wpc)+ + apply (clarsimp simp: authorised_arch_inv_def valid_arch_inv_def split: arch_invocation.splits) + done + +lemma new_irq_handler_caps_are_intra_label: + "\ cte_wp_at ((=) (IRQControlCap)) slot s; pas_refined aag s; is_subject aag (fst slot) \ + \ cap_points_to_label aag (IRQHandlerCap irq) (pasSubject aag)" + apply (clarsimp simp: cap_points_to_label_def) + apply (frule cap_cur_auth_caps_of_state[rotated]) + apply assumption + apply (simp add: cte_wp_at_caps_of_state) + apply (clarsimp simp: aag_cap_auth_def cap_links_irq_def) + apply (blast intro: aag_Control_into_owns_irq) + done + +lemma arch_invoke_irq_control_silc_inv[FinalCaps_assms]: + "\silc_inv aag st and pas_refined aag and arch_irq_control_inv_valid arch_irq_cinv + and K (arch_authorised_irq_ctl_inv aag arch_irq_cinv)\ + arch_invoke_irq_control arch_irq_cinv + \\_. silc_inv aag st\" + unfolding arch_authorised_irq_ctl_inv_def + apply (rule hoare_gen_asm) + apply (case_tac arch_irq_cinv) + apply (wp cap_insert_silc_inv'' hoare_vcg_ex_lift slots_holding_overlapping_caps_lift + | simp add: authorised_irq_ctl_inv_def arch_irq_control_inv_valid_def)+ + apply (fastforce dest: new_irq_handler_caps_are_intra_label) + apply (wpsimp wp: cap_insert_silc_inv'' simp: cap_points_to_label_def) + done + +crunch set_priority, set_flags + for silc_inv[wp]: "silc_inv aag st" + (simp: tcb_cap_cases_def) + +crunch arch_prepare_set_domain, arch_prepare_next_domain, arch_post_set_flags + for silc_inv[FinalCaps_assms, wp]: "silc_inv aag st" + (wp: crunch_wps) + +lemma tcb_cap_cases_tcb_fault: + "\(getF, a, b) \ ran tcb_cap_cases. getF (tcb_fault_update F tcb) = getF tcb" + by (rule ball_tcb_cap_casesI, simp+) + +(* FIXME AARCH64 IF: move to lib *) +lemma case_option_wp_returnOk: + assumes [wp]: "\x. \P x\ f x \\_. Q\" + shows "\Q and (\s. opt \ None \ P (the opt) s)\ + case opt of None \ returnOk rv | Some x \ f x + \\_. Q\" + by (cases opt; wpsimp) + +(* FIXME AARCH64 IF: move to lib *) +lemma case_option_wp_return: + assumes [wp]: "\x. \P x\ f x \\_. Q\" + shows "\Q and (\s. opt \ None \ P (the opt) s)\ + case opt of None \ return rv | Some x \ f x + \\_. Q\" + by (cases opt; wpsimp) + +lemma invoke_tcb_silc_inv[FinalCaps_assms]: + notes hoare_weak_lift_imp [wp] + hoare_weak_lift_imp_conj [wp] + shows "\silc_inv aag st and einvs and simple_sched_action and pas_refined aag and tcb_inv_wf tinv + and K (authorised_tcb_inv aag tinv)\ + invoke_tcb tinv + \\_. silc_inv aag st\" + apply (case_tac tinv) + apply ((wp restart_silc_inv hoare_vcg_if_lift suspend_silc_inv mapM_x_wp[OF _ subset_refl] + hoare_weak_lift_imp + | wpc + | simp split del: if_split add: authorised_tcb_inv_def check_cap_at_def + | clarsimp + | strengthen invs_mdb + | force intro: notE[rotated,OF idle_no_ex_cap,simplified])+)[3] + defer + apply ((wp suspend_silc_inv restart_silc_inv | simp add: authorised_tcb_inv_def | force)+)[2] + (* NotificationControl *) + apply (rename_tac option) + apply (case_tac option; (wp | simp)+) + (* SetTLSBase *) + apply (wpsimp split: option.splits) + (* SetFlags *) + apply (wpsimp split: option.splits) + (* just ThreadControl left *) + apply (simp add: split_def cong: option.case_cong) + (* slow, ~2 mins *) + apply (strengthen use_no_cap_to_obj_asid_strg + | clarsimp + | simp only: conj_ac cong: conj_cong imp_cong + | wp case_option_wp_returnOk case_option_wp_return + checked_insert_pas_refined checked_cap_insert_silc_inv hoare_vcg_all_liftE_R + hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R + cap_delete_silc_inv_not_transferable + cap_delete_pas_refined' cap_delete_deletes + cap_delete_valid_cap cap_delete_cte_at + check_cap_inv[where P="valid_cap c" for c] + check_cap_inv[where P="cte_at p0" for p0] + check_cap_inv[where P="\s. \ tcb_at t s" for t] + check_cap_inv2[where Q="\_. valid_list"] + check_cap_inv2[where Q="\_. valid_sched"] + check_cap_inv2[where Q="\_. simple_sched_action"] + checked_insert_no_cap_to + thread_set_tcb_fault_handler_update_invs + thread_set_pas_refined thread_set_emptyable thread_set_valid_cap + thread_set_not_state_valid_sched thread_set_cte_at + thread_set_no_cap_to_trivial + | wpc + | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def + st_tcb_at_triv option_update_thread_def + | strengthen use_no_cap_to_obj_asid_strg invs_mdb + invs_psp_aligned invs_vspace_objs invs_arch_state + | wp (once) hoare_drop_imps + | elim disjE; solves clarsimp)+ + (* also slow, ~30s *) + prefer 1 + apply (clarsimp simp: is_cap_simps) + apply (clarsimp split: option.split_asm) + apply (clarsimp simp: is_cap_simps is_cnode_or_valid_arch_def is_valid_vtable_root_def + authorised_tcb_inv_def emptyable_def + split: cap.splits option.splits pt_type.splits arch_cap.splits)+ + done + +end + + +global_interpretation FinalCaps_2?: FinalCaps_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma handle_hypervisor_fault_silc_inv[FinalCaps_assms]: + "\silc_inv aag st and invs and pas_refined aag and is_subject aag o cur_thread and K (is_subject aag t)\ + handle_hypervisor_fault t ex + \\_. silc_inv aag st\" + apply (case_tac ex; clarsimp split del: if_split) + apply (wpsimp wp: handle_fault_silc_inv simp: valid_fault_def) + done + +lemma vppi_event_silc_inv: + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + vppi_event irq + \\_. silc_inv aag st\" + unfolding vppi_event_def + apply (wpsimp wp: gts_wp hoare_vcg_all_lift vcpu_update_trivial_invs maskInterrupt_invs + hoare_vcg_imp_lift | wps | wp dmo_wp)+ + apply (clarsimp simp: valid_fault_def) + using ct_active_st_tcb_at_weaken runnable_eq by blast + +lemma vgic_maintenance_silc_inv: + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + vgic_maintenance + \\_. silc_inv aag st\" + unfolding vgic_maintenance_def + apply (wpsimp wp: gts_wp hoare_vcg_all_lift hoare_weak_lift_imp dmo_invs_lift + simp: crunch_simps valid_fault_def split_del: if_split + | wps | wp (once) hoare_drop_imps)+ + using ct_active_st_tcb_at_weaken runnable_eq by blast + +lemma handle_reserved_irq_silc_inv[FinalCaps_assms]: + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + handle_reserved_irq irq + \\_. silc_inv aag st\" + unfolding handle_reserved_irq_def + by (cases "irq = irqVGICMaintenance"; wpsimp wp: vgic_maintenance_silc_inv vppi_event_silc_inv) + +lemma handle_reserved_irq_non_kernel_IRQs[FinalCaps_assms]: + "\P and K (irq \ non_kernel_IRQs)\ handle_reserved_irq irq \\_. P\" + unfolding handle_reserved_irq_def + apply (rule hoare_gen_asm) + apply (wpsimp wp: when_wp[where P'="\"] simp: non_kernel_IRQs_def irq_vppi_event_index_def) + done + +end + + +global_interpretation FinalCaps_3?: FinalCaps_3 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchFinalise_IF.thy b/proof/infoflow/AARCH64/ArchFinalise_IF.thy new file mode 100644 index 0000000000..1dde409f58 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchFinalise_IF.thy @@ -0,0 +1,1232 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchFinalise_IF +imports Finalise_IF +begin + +context Arch begin arch_global_naming + +named_theorems Finalise_IF_assms + +crunch arch_post_cap_deletion + for globals_equiv[Finalise_IF_assms, wp]: "globals_equiv st" + and valid_arch_state[Finalise_IF_assms,wp]: valid_arch_state + +lemma dmo_maskInterrupt_reads_respects[Finalise_IF_assms]: + "reads_respects aag l \ (do_machine_op (maskInterrupt m irq))" + by wpsimp + +lemma arch_post_cap_deletion_read_respects[Finalise_IF_assms, wp]: + "reads_respects aag l \ (arch_post_cap_deletion acap)" + by wpsimp + +lemma equiv_asid_sa_update[Finalise_IF_assms, simp]: + "equiv_asid asid (scheduler_action_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (scheduler_action_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma equiv_asid_ready_queues_update[Finalise_IF_assms, simp]: + "equiv_asid asid (ready_queues_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (ready_queues_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma arch_finalise_cap_makes_halted[Finalise_IF_assms]: + "\invs and valid_cap (ArchObjectCap arch_cap) + and (\s. ex = is_final_cap' (ArchObjectCap arch_cap) s) + and cte_wp_at ((=) (ArchObjectCap arch_cap)) slot\ + arch_finalise_cap arch_cap ex + \\rv s. \t \ obj_refs_ac (fst rv). halted_if_tcb t s\" + by (wpsimp simp: arch_finalise_cap_def) + +(* FIXME: move *) +lemma set_object_modifies_at_most: + "modifies_at_most aag {pasObjectAbs aag ptr} + (\s. \ asid_pool_at ptr s \ (\asid_pool. obj \ ArchObj (ASIDPool asid_pool))) + (set_object ptr obj)" + apply (rule modifies_at_mostI) + apply (wp set_object_equiv_but_for_labels) + apply clarsimp + done + +lemma set_thread_state_reads_respects[Finalise_IF_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows "reads_respects aag l (\s. is_subject aag (cur_thread s)) (set_thread_state ref ts)" + unfolding set_thread_state_def fun_app_def + apply (simp add: bind_assoc[symmetric]) + apply (rule pre_ev) + apply (rule_tac P'=\ in bind_ev) + apply (rule set_thread_state_act_reads_respects) + apply (case_tac "aag_can_read aag ref \ aag_can_affect aag l ref") + apply (wp set_object_reads_respects gets_the_ev) + apply fastforce + apply (clarsimp simp: equiv_for_def get_tcb_def) + apply (simp add: equiv_valid_def2) + apply (rule equiv_valid_rv_bind) + apply (rule equiv_valid_rv_trivial) + apply (wp | simp)+ + apply (rule_tac P=\ and P'=\ and L="{pasObjectAbs aag ref}" and L'="{pasObjectAbs aag ref}" + in ev2_invisible[OF domains_distinct]) + apply (blast | simp add: labels_are_invisible_def)+ + apply (rule set_object_modifies_at_most) + apply (rule set_object_modifies_at_most) + apply (simp | wp)+ + apply (blast dest: get_tcb_not_asid_pool_at) + apply (subst thread_set_def[symmetric, simplified fun_app_def]) + apply (wp | simp)+ + done + +lemma set_thread_state_runnable_reads_respects[Finalise_IF_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows "runnable ts \ reads_respects aag l \ (set_thread_state ref ts)" + unfolding set_thread_state_def fun_app_def + apply (simp add: bind_assoc[symmetric]) + apply (rule pre_ev) + apply (rule_tac P'=\ in bind_ev) + apply (rule set_thread_state_act_runnable_reads_respects) + apply (case_tac "aag_can_read aag ref \ aag_can_affect aag l ref") + apply (wp set_object_reads_respects gets_the_ev) + apply fastforce + apply (clarsimp simp: equiv_for_def get_tcb_def) + apply (simp add: equiv_valid_def2) + apply (rule equiv_valid_rv_bind) + apply (rule equiv_valid_rv_trivial) + apply (wp | simp)+ + apply (rule_tac P=\ and P'=\ and L="{pasObjectAbs aag ref}" and L'="{pasObjectAbs aag ref}" + in ev2_invisible[OF domains_distinct]) + apply (blast | simp add: labels_are_invisible_def)+ + apply (rule set_object_modifies_at_most) + apply (rule set_object_modifies_at_most) + apply (simp | wp)+ + apply (blast dest: get_tcb_not_asid_pool_at) + apply (subst thread_set_def[symmetric, simplified fun_app_def]) + apply (wp thread_set_st_tcb_at | simp)+ + done + +lemma set_bound_notification_none_reads_respects[Finalise_IF_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows "reads_respects aag l \ (set_bound_notification ref None)" + unfolding set_bound_notification_def fun_app_def + apply (rule pre_ev(5)[where Q=\]) + apply (case_tac "aag_can_read aag ref \ aag_can_affect aag l ref") + apply (wp set_object_reads_respects gets_the_ev)[1] + apply fastforce + apply (clarsimp simp: equiv_for_def get_tcb_def) + apply (simp add: equiv_valid_def2) + apply (rule equiv_valid_rv_bind) + apply (rule equiv_valid_rv_trivial) + apply (wp | simp)+ + apply (rule_tac P=\ and P'=\ and L="{pasObjectAbs aag ref}" and L'="{pasObjectAbs aag ref}" + in ev2_invisible[OF domains_distinct]) + apply (blast | simp add: labels_are_invisible_def)+ + apply (rule set_object_modifies_at_most) + apply (rule set_object_modifies_at_most) + apply (simp | wp)+ + apply (blast dest: get_tcb_not_asid_pool_at) + apply simp + done + +lemma set_tcb_queue_reads_respects[Finalise_IF_assms, wp]: + "reads_respects aag l \ (set_tcb_queue d prio queue)" + unfolding equiv_valid_def2 equiv_valid_2_def + apply (clarsimp simp: set_tcb_queue_def bind_def modify_def put_def get_def) + apply (rule conjI) + apply (rule reads_equiv_ready_queues_update, assumption) + apply (fastforce simp: reads_equiv_def affects_equiv_def states_equiv_for_def equiv_for_def) + apply (rule affects_equiv_ready_queues_update, assumption) + apply (clarsimp simp: reads_equiv_def affects_equiv_def states_equiv_for_def equiv_for_def + equiv_asids_def equiv_asid_def) + apply (rule ext) + apply force + done + +lemma set_tcb_queue_modifies_at_most: + "modifies_at_most aag L (\s. pasDomainAbs aag d \ L \ {}) (set_tcb_queue d prio queue)" + apply (rule modifies_at_mostI) + apply (simp add: set_tcb_queue_def modify_def, wp) + apply (force simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def equiv_asids_def + equiv_hyp_def equiv_fpu_def cur_fpu_for_def get_tcb_def) + done + +lemma set_notification_equiv_but_for_labels[Finalise_IF_assms]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag ntfnptr \ L)\ + set_notification ntfnptr ntfn + \\_. equiv_but_for_labels aag L st\" + unfolding set_simple_ko_def + apply (wp set_object_equiv_but_for_labels get_object_wp) + apply (clarsimp simp: asid_pool_at_kheap partial_inv_def obj_at_def split: kernel_object.splits) + done + +lemma thread_set_reads_respects[Finalise_IF_assms]: + "reads_respects aag l \ (thread_set f thread)" + apply (rule equiv_valid_guard_imp) + apply (rule_tac ptr=thread in reads_respects_unit_cases) + unfolding thread_set_def + apply (rule gen_asm_ev) + apply (wpsimp wp: set_object_reads_respects) + apply (wpsimp wp: set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def) + apply wpsimp+ + apply auto + done + +lemma aag_cap_auth_ASIDPoolCap: + "pas_cap_cur_auth aag (ArchObjectCap (ASIDPoolCap r asid)) \ + pas_refined aag s \ is_subject aag r" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma aag_cap_auth_PageDirectory: + "pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t (Some a))) \ + pas_refined aag s \ is_subject aag word" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma aag_cap_auth_ASIDPoolCap_asid: + "\ pas_cap_cur_auth aag (ArchObjectCap (ASIDPoolCap r asid)); asid' \ 0; + asid_high_bits_of asid' = asid_high_bits_of asid; pas_refined aag s \ + \ is_subject_asid aag asid'" + apply (frule (1) aag_cap_auth_ASIDPoolCap) + apply (unfold aag_cap_auth_def) + apply (rule is_subject_into_is_subject_asid) + apply auto + done + +lemma aag_cap_auth_PageCap_asid: + "\ pas_cap_cur_auth aag (ArchObjectCap (FrameCap dev ref r sz (Some (a, b)))); pas_refined aag s \ + \ is_subject_asid aag a" + by (auto simp: aag_cap_auth_def cap_links_asid_slot_def label_owns_asid_slot_def + intro: pas_refined_Control_into_is_subject_asid) + +lemma aag_cap_auth_PageTableCap: + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t option)); pas_refined aag s \ + \ is_subject aag word" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma aag_cap_auth_PageTableCap_asid: + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t (Some (a, b)))); pas_refined aag s \ + \ is_subject_asid aag a" + by (auto simp: aag_cap_auth_def cap_links_asid_slot_def label_owns_asid_slot_def + intro: pas_refined_Control_into_is_subject_asid) + +lemma aag_cap_auth_PageDirectoryCap: + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t option)); pas_refined aag s \ + \ is_subject aag word" + unfolding aag_cap_auth_def + by (simp add: clas_no_asid cap_auth_conferred_def arch_cap_auth_conferred_def + cli_no_irqs pas_refined_all_auth_is_owns) + +lemma aag_cap_auth_PageDirectoryCap_asid: + "\ pas_cap_cur_auth aag (ArchObjectCap (PageTableCap word pt_t (Some (a,vref)))); pas_refined aag s \ + \ is_subject_asid aag a" + unfolding aag_cap_auth_def + by (auto simp: cap_links_asid_slot_def label_owns_asid_slot_def + intro: pas_refined_Control_into_is_subject_asid) + +lemmas aag_cap_auth_subject = aag_cap_auth_ASIDPoolCap_asid + aag_cap_auth_PageCap_asid + aag_cap_auth_PageTableCap_asid + +(* Helpful groupings *) + +definition fpu_save where + "fpu_save \ do + cur_fpu_owner \ gets (arm_current_fpu_owner \ arch_state); + do_machine_op enableFpu; + maybeM save_fpu_state cur_fpu_owner + od" + +definition fpu_restore where + "fpu_restore new_owner \ do + case new_owner of None \ do_machine_op disableFpu + | Some tcb_ptr \ load_fpu_state tcb_ptr; + set_arm_current_fpu_owner new_owner + od" + +lemma dmo_enableFpu_reads_respects[wp]: + "states_equiv_valid aag L \ (do_machine_op enableFpu)" + unfolding enableFpu_def dmo_distr + apply wpsimp + apply (wpsimp wp: do_machine_op_states_equiv_valid modify_ev) + apply (clarsimp simp: equiv_for_def) + apply (wpsimp wp: dmo_mol_states_equiv_valid)+ + done + +lemma dmo_disableFpu_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (do_machine_op disableFpu)" + unfolding disableFpu_def dmo_distr + apply wpsimp + apply (wpsimp wp: do_machine_op_states_equiv_valid modify_ev) + apply (clarsimp simp: equiv_for_def) + apply (wpsimp wp: dmo_mol_states_equiv_valid)+ + done + +lemma switch_local_fpu_owner_def2: + "switch_local_fpu_owner new_owner = do fpu_save; fpu_restore new_owner od" + unfolding switch_local_fpu_owner_def fpu_save_def fpu_restore_def + by (clarsimp simp: bind_assoc) + +lemma valid_cur_fpu_cur_fpu_for: + "valid_cur_fpu s \ cur_fpu_for P s = (\p. P p \ is_tcb_cur_fpu p s)" + apply (clarsimp simp: cur_fpu_for_def valid_cur_fpu_def) + apply (rule iffI; erule ex_forward) + apply (clarsimp simp: valid_cur_fpu_def is_tcb_cur_fpu_def obj_at_def get_tcb_def is_arch_cur_fpu_def + split: option.splits kernel_object.splits)+ + done + +lemma equiv_kheap_equiv_current_fpu: + "\ equiv_for P kheap s t; valid_cur_fpu s; valid_cur_fpu t; cur_fpu_for P s; cur_fpu_for P t\ + \ current_fpu s = current_fpu t" + apply (clarsimp simp: valid_cur_fpu_cur_fpu_for valid_cur_fpu_def + equiv_for_def is_tcb_cur_fpu_def obj_at_def) + apply (drule_tac x=p in spec)+ + apply auto + done + +(* FIXME AARCH64 IF: move *) +lemma maybeM_when: + "maybeM f opt = when (opt \ None) (f (the opt))" + by (clarsimp simp: maybeM_def when_def) + +lemma maybeM_ev: + "\ \v. opt = Some v \ equiv_valid_inv I A (P v) (f v) \ + \ equiv_valid_inv I A (\s. \v. opt = Some v \ P v s) (maybeM f opt)" + apply (subst maybeM_when) + apply (rule equiv_valid_guard_imp) + apply (rule_tac P="P (the opt)" in when_ev) + apply auto + done + +lemma as_user_states_equiv_valid_roa: + "states_equiv_valid aag L (K (det f \ (L (pasObjectAbs aag thread)))) (as_user thread f)" + apply (simp add: as_user_def split_def) + apply (rule gen_asm_ev) + apply (wp set_object_states_equiv_valid select_f_ev gets_the_ev) + apply (auto simp: equiv_for_def get_tcb_def arch_tcb_context_set_def states_equiv_for_def) + done + +lemma states_equiv_valid_unobservable_unit_return: + assumes f: + "\P Q R S st. \states_equiv_for P Q R S st\ f \\_. states_equiv_for P Q R S st\" + shows + "states_equiv_valid aag L \ (f::(unit,det_ext) s_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid[OF _ f]) + apply (rule states_equiv_for_sym) + apply (erule use_valid[OF _ f]) + apply (rule states_equiv_for_sym) + apply simp + done + +lemma dmo_readFpuState_states_equiv_valid: + "states_equiv_valid aag L (cur_fpu_for (L o pasObjectAbs aag)) (do_machine_op readFpuState)" + (is "states_equiv_valid _ _ ?P _") + unfolding readFpuState_def dmo_distr + apply (rule_tac Q="\_. ?P" in bind_ev_pre) + apply wpsimp + apply (rule do_machine_op_states_equiv_valid') + apply (wpsimp wp: gets_ev') + apply (clarsimp simp: pred_disj_def equiv_fpu_state_def hw_fpu_def) + apply (rule states_equiv_valid_unobservable_unit_return) + apply (wpsimp wp: dmo_wp)+ + done + +lemma det_setFPUStat[simp]: + "det (setFPUState fpu)" + by (wpsimp simp: setFPUState_def) + +lemma thread_set_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag ptr \ L)\ + thread_set f ptr + \\_. equiv_but_for_labels aag L st\" + unfolding thread_set_def + apply (wpsimp wp: set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def split: option.splits kernel_object.splits) + done + +lemma as_user_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag ptr \ L)\ + as_user ptr f + \\_. equiv_but_for_labels aag L st\" + by (wpsimp wp: as_user_wp_thread_set_helper) + +lemma dmo_readFpuState_inv[wp]: + "do_machine_op readFpuState \P\" + by (wpsimp simp: readFpuState_def wp: dmo_wp) + +lemma save_fpu_state_states_equiv_valid: + "states_equiv_valid aag L (\s. current_fpu s = Some ptr) (save_fpu_state ptr)" + (is "states_equiv_valid _ _ ?P _") + unfolding save_fpu_state_def + apply (rule equiv_valid_guard_imp) + apply (rule_tac P="?P" and ptr=ptr in states_equiv_valid_unit_cases) + apply (wpsimp wp: as_user_states_equiv_valid_roa dmo_readFpuState_states_equiv_valid) + apply (clarsimp simp: cur_fpu_for_def is_arch_cur_fpu_def) + apply wpsimp+ + done + +(* FIXME AARCH64 IF: move *) +locale_abbrev "cur_fpu_of s \ \x. arm_current_fpu_owner (arch_state s) = Some x" + +lemma equiv_fpu_def2: + "equiv_fpu P s s' \ (\x. P x \ + (current_fpu s = Some x \ current_fpu s' = Some x) \ + (current_fpu s = Some x \ machine_fpu s = machine_fpu s'))" + apply (rule eq_reflection) + apply (clarsimp simp: equiv_fpu_def equiv_for_def valid_cur_fpu_cur_fpu_for) + apply (clarsimp simp: hw_fpu_def is_arch_cur_fpu_def) + apply auto + done + +lemma dmo_disableFpu_machine_fpu[wp]: + "do_machine_op disableFpu \\s. P (machine_fpu s)\" + by (wpsimp wp: dmo_wp) + +lemma dmo_enableFpu_machine_fpu[wp]: + "do_machine_op enableFpu \\s. P (machine_fpu s)\" + by (wpsimp wp: dmo_wp) + +lemma tcb_at_typ_at': + "(\P T p. \\s. P (typ_at T p s)\ f \\rv s. P (typ_at T p s)\) + \ \\s. P (tcb_at c s)\ f \\rv s. P (tcb_at c s)\" + by (simp add: tcb_at_typ) + +lemma as_user_not_tcb_at[wp]: + "as_user t m \\s. \tcb_at t' s\" + by (wpsimp wp: tcb_at_typ_at'[OF as_user_typ_at]) + +crunch save_fpu_state + for not_tcb_at[wp]: "\s. \tcb_at t s" + +lemma fpu_of_Some_True[simp]: + "fpu_of (Some True) fopt fpu = Some fpu" + by (clarsimp simp: fpu_of_def) + +lemma fpu_of_Some_False[simp]: + "fpu_of (Some False) fopt fpu = fopt" + by (clarsimp simp: fpu_of_def) + +lemma fpu_of_None[simp]: + "fpu_of None fopt fpu = None" + by (clarsimp simp: fpu_of_def) + +lemma valid_cur_fpu_current_fpu_Some: + "\ valid_cur_fpu s; current_fpu s = Some t \ + \ tcb_cur_fpu_of s t = Some True" + apply (clarsimp simp: valid_cur_fpu_def) + apply (erule_tac x=t in allE) + apply (clarsimp simp: get_tcb_def is_tcb_cur_fpu_def obj_at_def) + done + +lemma save_fpu_state_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ pasObjectAbs aag ptr \ L\ + save_fpu_state ptr + \\_. equiv_but_for_labels aag L st\" + unfolding save_fpu_state_def + by wpsimp + +lemma dmo_enableFpu_equiv_but_for_labels[wp]: + "do_machine_op enableFpu \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma dmo_disableFpu_equiv_but_for_labels[wp]: + "do_machine_op disableFpu \equiv_but_for_labels aag L st\" + by (wpsimp wp: dmo_equiv_but_for_labels_lift) + +lemma fpu_save_states_equiv_valid: + "states_equiv_valid aag L valid_cur_fpu fpu_save" + unfolding fpu_save_def + apply (rule_tac P="cur_fpu_for (L o pasObjectAbs aag)" in equiv_valid_cases'') + apply (fastforce simp: states_equiv_for_def comp_def equiv_fpu_cur_fpu_for) + apply (wpsimp wp: maybeM_ev gets_ev'' save_fpu_state_states_equiv_valid + hoare_vcg_imp_lift' hoare_vcg_all_lift) + apply (rename_tac s t) + apply (prop_tac "valid_cur_fpu s \ cur_fpu_for (L o pasObjectAbs aag) s") + apply assumption + apply (prop_tac "valid_cur_fpu t \ cur_fpu_for (L o pasObjectAbs aag) t") + apply assumption + apply clarsimp + apply (prop_tac "equiv_for (L o pasObjectAbs aag) kheap s t") + apply (fastforce simp: states_equiv_for_def comp_def) + apply (clarsimp simp: equiv_kheap_equiv_current_fpu) + apply wpsimp + apply clarsimp + apply (rule wp_pre) + apply (simp add: equiv_valid_def2) + apply (rule_tac R'="\\" + and Q="\rv. (\s. current_fpu s = rv \ valid_cur_fpu s) + and K (\vr. rv = Some vr \ \ L (pasObjectAbs aag vr))" + and Q'="\rv. (\s. current_fpu s = rv \ valid_cur_fpu s) + and K (\vr. rv = Some vr \ \ L (pasObjectAbs aag vr))" + in equiv_valid_2_bind) + apply (rule EquivValid.gen_asm_ev2_l) + apply (rule EquivValid.gen_asm_ev2_r) + prefer 2 + apply (rule gets_any_evrv) + apply (rule equiv_valid_2_guard_imp) + apply (rule states_equiv_valid_2_invisible) + apply (rule modifies_at_mostI) + apply (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift) + apply (rule modifies_at_mostI) + apply (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift) + apply (wp | simp)+ + apply (auto simp: cur_fpu_for_def is_arch_cur_fpu_def) + done + +lemma equiv_valid_lift: + assumes "\P. f \\s. P (i s)\" + shows "equiv_valid (equiv_for P i) \\ \\ \ (f :: ('s state, unit) nondet_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid) + apply (wpsimp wp: assms equiv_for_lift) + apply (erule use_valid) + apply (wpsimp wp: assms equiv_for_lift) + apply clarsimp + done + +crunch getFPUState + for inv[wp]: P + +crunch load_fpu_state + for kheap[wp]: "\s. P (kheap s)" + (wp: as_user_inv) + +lemma set_object_equiv_kheap: + "equiv_valid_inv (equiv_for P kheap) \\ \ (set_object ptr obj)" + by (clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def + bind_def' get_def gets_def put_def return_def fail_def assert_def equiv_for_def) + +lemma thread_set_kheap_equiv: + "equiv_valid_inv (equiv_for P kheap) \\ \ (thread_set f thread)" + unfolding thread_set_def + apply (case_tac "P thread") + apply (wpsimp wp: set_object_equiv_kheap) + apply (clarsimp simp: get_tcb_def equiv_for_def) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def + gets_the_def assert_opt_def get_tcb_def bind_def' get_def gets_def + put_def return_def fail_def assert_def equiv_for_def + split: option.splits kernel_object.splits) + done + +lemma arch_thread_set_kheap_equiv: + "equiv_valid_inv (equiv_for P kheap) \\ \ (arch_thread_set f thread)" + by (wpsimp simp: arch_thread_set_is_thread_set wp: thread_set_kheap_equiv) + +lemma gets_current_fpu_owner_equiv_kheap: + "equiv_valid (equiv_for P kheap) (equiv_for P cur_fpu_of) (\_ _. True) + (valid_cur_fpu and cur_fpu_for P) + (gets (arm_current_fpu_owner \ arch_state))" + (is "equiv_valid_inv _ _ ?P _") + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def gets_def get_def return_def bind_def) + apply (clarsimp simp: equiv_for_def cur_fpu_for_def is_arch_cur_fpu_def) + done + +lemma equiv_valid_make_inv: + assumes "equiv_valid_inv I A P f" + shows "equiv_valid I A \\ P f" + using assms + by (fastforce simp: equiv_valid_def2 equiv_valid_2_def) + +lemma arch_thread_set_equiv_for_kheap: + "\equiv_for P kheap st and K (\P thread)\ + arch_thread_set f thread + \\_. equiv_for P kheap st\" + apply (wpsimp wp: arch_thread_set_wp) + apply (clarsimp simp: equiv_for_def) + done + +lemma set_arm_current_fpu_owner_ev: + "equiv_valid (equiv_for P kheap) (equiv_for P cur_fpu_of) \\ (valid_cur_fpu) + (do cur_fpu_owner <- gets (arm_current_fpu_owner \ arch_state); + maybeM (arch_thread_set (tcb_cur_fpu_update (\_. False))) cur_fpu_owner + od)" + apply (rule_tac P="cur_fpu_for P" in equiv_valid_cases'') + apply (fastforce simp: equiv_for_def cur_fpu_for_def is_arch_cur_fpu_def) + apply (rule wp_pre) + apply (rule bind_ev_general) + apply (wp maybeM_ev) + apply (wpsimp wp: maybeM_ev arch_thread_set_kheap_equiv) + apply (wp gets_current_fpu_owner_equiv_kheap) + apply wpsimp + apply clarsimp + apply (rule equiv_valid_make_inv) + apply (rule equiv_valid_inv_lift) + apply (wpsimp wp: arch_thread_set_equiv_for_kheap equiv_for_lift) + apply (clarsimp simp: equiv_for_def cur_fpu_for_def is_arch_cur_fpu_def) + apply (auto simp: equiv_for_sym) + done + +crunch load_fpu_state + for valid_cur_fpu[wp]: valid_cur_fpu + +lemma fpu_restore_equiv_kheap': + "equiv_valid (equiv_for P kheap) (equiv_for P cur_fpu_of) \\ valid_cur_fpu (fpu_restore new_owner)" + unfolding fpu_restore_def set_arm_current_fpu_owner_def + apply (rule equiv_valid_guard_imp) + apply (rule_tac A=B and B=B for B in bind_ev_general) + prefer 2 + apply (rule equiv_valid_inv_lift) + apply (wpsimp wp: equiv_for_lift)+ + apply (fastforce simp: equiv_for_def)+ + apply simp + apply (subst bind_assoc[symmetric]) + apply (rule bind_ev_general) + prefer 2 + apply (rule set_arm_current_fpu_owner_ev) + apply clarsimp + apply (rule bind_ev_general) + prefer 2 + apply (rule equiv_valid_lift) + apply wpsimp + apply (rule maybeM_ev) + apply (rule arch_thread_set_kheap_equiv) + apply wpsimp+ + done + +lemma fpu_restore_equiv_kheap: + "equiv_valid (equiv_for P kheap) (equiv_fpu P) \\ valid_cur_fpu (fpu_restore new_owner)" + apply (rule equiv_valid_conseq) + apply (rule_tac P=P in fpu_restore_equiv_kheap') + apply (clarsimp simp: equiv_fpu_def2 equiv_for_def) + apply clarsimp + done + +crunch fpu_save + for valid_cur_fpu[wp]: "valid_cur_fpu" + (wp: crunch_wps) + +lemma switch_local_fpu_owner_equiv_kheap: + "equiv_valid \\ (states_equiv_for_labels aag L) (equiv_for (L o pasObjectAbs aag) kheap) + valid_cur_fpu (switch_local_fpu_owner new_owner :: (det_state,unit) nondet_monad)" + unfolding switch_local_fpu_owner_def2 + apply (rule equiv_valid_guard_imp) + apply (rule_tac B="\s t. equiv_for (L \ pasObjectAbs aag) kheap s t \ + equiv_fpu (L \ pasObjectAbs aag) s t" + and P'=valid_cur_fpu in bind_ev_general) + by (wpsimp wp: fpu_restore_equiv_kheap[where P="L o pasObjectAbs aag"] + fpu_save_states_equiv_valid[where aag=aag and L=L] + simp: comp_def states_equiv_for_def equiv_for_disj equiv_fpu_def + | rule equiv_valid_conseq[where P=valid_cur_fpu] | fastforce)+ + +definition states_equiv_for_non_fpu :: + "(obj_ref \ bool) \ (irq \ bool) \ (asid \ bool) \ + (domain \ bool) \ det_state \ det_state \ bool" where + "states_equiv_for_non_fpu P Q R S s s' \ + equiv_machine_state P (machine_state s) (machine_state s') \ + equiv_for (P \ fst) cdt s s' \ + equiv_for (P \ fst) cdt_list s s' \ + equiv_for (P \ fst) is_original_cap s s' \ + equiv_for Q interrupt_states s s' \ + equiv_for Q interrupt_irq_node s s' \ + equiv_for S ready_queues s s' \ + equiv_asids R s s' \ + equiv_hyp P s s'" + +lemma states_equiv_for_non_fpu_refl: + "states_equiv_for_non_fpu P Q R S s s" + by (auto simp: states_equiv_for_non_fpu_def intro: equiv_for_refl equiv_asids_refl equiv_hyp_refl) + +lemma states_equiv_for_non_fpu_sym: + "states_equiv_for_non_fpu P Q R S s t \ states_equiv_for_non_fpu P Q R S t s" + by (auto simp: states_equiv_for_non_fpu_def intro: equiv_for_sym equiv_asids_sym equiv_fpu_sym equiv_hyp_sym) + +lemma states_equiv_for_non_fpu_trans: + "\ states_equiv_for_non_fpu P Q R S s t; states_equiv_for_non_fpu P Q R S t u \ + \ states_equiv_for_non_fpu P Q R S s u" + by (auto simp: states_equiv_for_non_fpu_def + intro: equiv_for_trans equiv_asids_trans equiv_fpu_trans equiv_hyp_trans equiv_forI + elim: equiv_forE) + +abbreviation states_equiv_for_labels_non_fpu :: + "'a PAS \ ('a \ bool) \ det_state \ det_state \ bool" where + "states_equiv_for_labels_non_fpu aag P \ + states_equiv_for_non_fpu (\x. P (pasObjectAbs aag x)) (\x. P (pasIRQAbs aag x)) + (\x. P (pasASIDAbs aag x)) (\x. \l\pasDomainAbs aag x. P l)" + +abbreviation states_equiv_valid_non_fpu where + "states_equiv_valid_non_fpu aag L P f \ equiv_valid_inv \\ (states_equiv_for_labels_non_fpu aag L) P f" + +lemma states_equiv_for_non_fpu_symmetric: + "states_equiv_for_non_fpu P Q R S s t \ states_equiv_for_non_fpu P Q R S t s" + by (auto simp: states_equiv_for_non_fpu_sym) + +lemma states_equiv_valid_non_fpu_unobservable: + assumes "\P Q R S st. f \states_equiv_for_non_fpu P Q R S st\" + assumes "\P. f \\s. P (cur_thread s)\" + assumes "\P. f \\s. P (cur_domain s)\" + assumes "\P. f \\s. P (scheduler_action s)\" + assumes "\P. f \\s. P (work_units_completed s)\" + assumes l: "\P. f \\s. P (irq_state (machine_state s))\" + shows "states_equiv_valid_non_fpu aag l \ (f :: (det_state,unit) nondet_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (rule states_equiv_for_non_fpu_symmetric) + apply (erule use_valid) + apply (wp assms) + apply (rule states_equiv_for_non_fpu_symmetric) + apply (erule use_valid) + apply (wp assms) + apply simp + done + +lemma equiv_hyp_lift: + assumes "\P. f \\s. P (vcpu_state (machine_state s))\" + assumes "\P. f \\s. P (current_vcpu s)\" + assumes "\P. f \\s. P (numlistregs s)\" + shows "f \\s. equiv_hyp P st s\" + unfolding equiv_hyp_def + apply (wpsimp wp: equiv_for_lift assms) + apply (rule hoare_weaken_pre) + apply (wps assms) + apply wpsimp+ + done + +lemma switch_local_fpu_owner_states_equiv_for_non_hyp[wp]: + "switch_local_fpu_owner vopt \states_equiv_for_non_fpu P Q R S st\" + unfolding states_equiv_for_non_fpu_def + by (wpsimp wp: equiv_machine_state_lift equiv_asids_lift equiv_hyp_lift equiv_for_lift dmo_wp) + +lemma valid_cur_fpu_hw_fpu_of: + "valid_cur_fpu s \ + hw_fpu_of s t = (if current_fpu s = Some t + then fpu_of (tcb_cur_fpu_of s t) (tcb_fpu_of s t) (machine_fpu s) + else None)" + supply if_split[split del] + apply (subst fpu_of_def) + apply (clarsimp simp: is_arch_cur_fpu_def hw_fpu_def) + apply (case_tac "current_fpu s = Some t"; clarsimp) + apply (frule (1) current_fpu_owner_Some_tcb_at) + apply (clarsimp simp: tcb_at_def get_tcb_def split: option.splits kernel_object.splits) + apply (clarsimp simp: valid_cur_fpu_def) + apply (erule_tac x=t in allE) + apply (clarsimp simp: is_tcb_cur_fpu_def obj_at_def) + done + +lemma set_arm_current_fpu_owner_current_fpu[wp]: + "\\s. P (new_owner)\ + set_arm_current_fpu_owner new_owner + \\_ s. P (current_fpu s)\" + unfolding set_arm_current_fpu_owner_def + apply wpsimp + apply auto + done + +crunch switch_local_fpu_owner + for valid_cur_fpu[wp]: valid_cur_fpu + (wp: hoare_drop_imps) + +lemma switch_local_fpu_owner_current_fpu[wp]: + "\\s. P (new_owner)\ + switch_local_fpu_owner new_owner + \\_ s. P (current_fpu s)\" + unfolding switch_local_fpu_owner_def + by wpsimp + +lemma switch_local_fpu_owner_hw_fpu_of: + "\\s. valid_cur_fpu s \ fopt = (if new_owner \ Some ptr then None + else if hw_fpu_of s ptr = None then tcb_fpu_of s ptr + else hw_fpu_of s ptr)\ + switch_local_fpu_owner new_owner + \\_ s. fopt = hw_fpu_of s ptr\" + apply (rule_tac Q'="\_ s. valid_cur_fpu s \ + (current_fpu s = Some ptr \ fopt = fpu_of (tcb_cur_fpu_of s ptr) + (tcb_fpu_of s ptr) (machine_fpu s)) \ + (current_fpu s \ Some ptr \ fopt = None)" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: valid_cur_fpu_hw_fpu_of) + apply (rule wp_pre) + apply (rule hoare_vcg_conj_lift) + apply wpsimp + apply (rule hoare_vcg_conj_lift) + apply (rule hoare_vcg_imp_lift') + apply wp + apply (wp switch_local_fpu_owner_fpu_of) + apply wp + apply (clarsimp simp: valid_cur_fpu_hw_fpu_of split: if_splits) + apply (simp add: valid_cur_fpu_current_fpu_Some) + apply (clarsimp simp: fpu_of_def get_tcb_def split: option.splits bool.splits kernel_object.splits) + by (simp add: valid_cur_fpu_defs(1,2,3)) + +lemma switch_local_fpu_owner_equiv_fpu: + "equiv_valid (equiv_fpu P) (equiv_for P kheap) \\ valid_cur_fpu (switch_local_fpu_owner new_owner)" + apply (clarsimp simp: equiv_fpu_def equiv_valid_def2 equiv_valid_2_def) + apply (rename_tac s' t') + apply (clarsimp simp: equiv_for_def) + apply (erule_tac x=x in allE)+ + apply clarsimp + apply (rule sym) + apply (erule use_valid) + apply (rule switch_local_fpu_owner_hw_fpu_of) + apply (rule conjI, simp) + apply (rule sym) + apply (erule use_valid) + apply (rule switch_local_fpu_owner_hw_fpu_of) + apply (rule conjI, simp) + apply (case_tac "new_owner \ Some x") + apply clarsimp + apply (case_tac "hw_fpu_of s x = None") + apply (clarsimp simp: get_tcb_def) + apply clarsimp + done + +lemma switch_local_fpu_owner_states_equiv_valid[wp]: + "states_equiv_valid aag L (valid_cur_fpu) (switch_local_fpu_owner new_owner)" + apply (rule equiv_valid_conseq) + apply (rule equiv_valid_split) + apply (rule states_equiv_valid_non_fpu_unobservable[of _ L aag]) + apply ((wpsimp simp: fpu_restore_def wp: dmo_wp)+)[6] + apply (rule equiv_valid_split) + apply (rule_tac aag=aag and L=L in switch_local_fpu_owner_equiv_kheap) + apply (rule_tac P="L o pasObjectAbs aag" in switch_local_fpu_owner_equiv_fpu) + apply (clarsimp simp: states_equiv_for_def states_equiv_for_non_fpu_def comp_def)+ + done + +lemma switch_local_fpu_owner_reads_respects[wp]: + "reads_respects aag l (valid_cur_fpu) (switch_local_fpu_owner new_owner)" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_from_labels) + apply (rule switch_local_fpu_owner_states_equiv_valid) + apply wpsimp+ + done + +lemma arch_thread_set_equiv_but_for_labels[wp]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag t \ L)\ + arch_thread_set f t + \\_. equiv_but_for_labels aag L st\" + unfolding arch_thread_set_def + apply (wpsimp wp: set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def split: option.splits kernel_object.splits) + done + +lemma modify_current_fpu_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ + (\t. current_fpu s = Some t \ pasObjectAbs aag t \ L) \ + (\t. new_owner = Some t \ pasObjectAbs aag t \ L)\ + modify (\s. s\arch_state := arch_state s\arm_current_fpu_owner := new_owner\\) + \\_. equiv_but_for_labels aag L st\" + apply wp + apply (subst equiv_but_for_labels_def) + apply (subst states_equiv_for_def) + apply (intro conjI; (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def; fail)?) + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (clarsimp simp: equiv_asids_def equiv_asid_def) + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (clarsimp simp: equiv_hyp_def equiv_for_def) + apply (prop_tac "equiv_fpu (\x. pasObjectAbs aag x \ L) st s") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (erule equiv_fpu_trans) + apply (clarsimp simp: equiv_fpu_def) + apply (clarsimp simp: equiv_for_def) + apply (clarsimp simp: is_arch_cur_fpu_def) + apply (clarsimp simp: hw_fpu_def) + apply auto + done + +lemma set_arm_current_fpu_owner_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ (\t. new_owner = Some t \ pasObjectAbs aag t \ L) \ + (\t. current_fpu s = Some t \ pasObjectAbs aag t \ L)\ + set_arm_current_fpu_owner new_owner + \\_. equiv_but_for_labels aag L st\" + unfolding set_arm_current_fpu_owner_def + by (wpsimp wp_del: modify_wp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift modify_current_fpu_equiv_but_for_labels) + +lemma dmo_equiv_but_for_labels_fpu: + assumes "\P. f \\ms. P (underlying_memory ms)\" + assumes "\P. f \\ms. P (device_state ms)\" + assumes "\P. f \\ms. P (irq_state ms)\" + assumes "\P. f \\ms. P (vcpu_state ms)\" + shows "\\s. equiv_but_for_labels aag L st s \ \cur_fpu_for (\x. pasObjectAbs aag x \ L) s\ + do_machine_op f + \\_. equiv_but_for_labels aag L st\" + unfolding equiv_but_for_labels_def states_equiv_for_def equiv_asids_def cur_fpu_for_def + apply wp + apply clarsimp + apply (rule hoare_vcg_conj_lift, solves "wpsimp wp: equiv_for_lift equiv_hyp_lift assms dmo_wp")+ + apply (rule hoare_vcg_conj_lift) + apply (clarsimp simp: equiv_fpu_def) + apply (rule_tac Q'="\_ s. (\x. pasObjectAbs aag x \ L \ hw_fpu_of st x = None) \ + \cur_fpu_for (\x. pasObjectAbs aag x \ L) s" + in hoare_strengthen_post) + apply (wpsimp wp: equiv_for_lift2 assms dmo_wp simp: cur_fpu_for_def) + apply (clarsimp simp: equiv_for_def hw_fpu_def) + apply (erule_tac x=x in allE) + apply (clarsimp split: if_splits) + apply (fastforce simp: cur_fpu_for_def) + apply (wpsimp wp: equiv_for_lift equiv_hyp_lift assms dmo_wp) + apply clarsimp + apply (clarsimp simp: equiv_fpu_def) + apply (fastforce simp: equiv_for_def cur_fpu_for_def hw_fpu_def split: if_splits) + done + +lemma as_user_cur_fpu_for[wp]: + "as_user t f \\s. P (cur_fpu_for R s)\" + apply (wpsimp wp: as_user_wp_thread_set_helper thread_set_wp) + apply (auto elim!: rsubst[where P=P] + simp: get_tcb_def cur_fpu_for_def arch_tcb_context_get_def arch_tcb_context_set_def) + done + +lemma dmo_cur_fpu_for[wp]: + "do_machine_op f \\s. P (cur_fpu_for R s)\" + by (wpsimp wp: dmo_wp simp: cur_fpu_for_def) + +crunch save_fpu_state + for cur_fpu_for[wp]: "\s. P (cur_fpu_for R s)" + +lemma load_fpu_state_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ \cur_fpu_for (\a. pasObjectAbs aag a \ L) s\ + load_fpu_state t + \\_. equiv_but_for_labels aag L st\" + unfolding load_fpu_state_def + by (wpsimp wp: dmo_equiv_but_for_labels_fpu as_user_inv) + +lemma switch_local_fpu_owner_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ (\t. cur_fpu_of s t \ pasObjectAbs aag t \ L) \ + (\t. new_owner = Some t \ pasObjectAbs aag t \ L)\ + switch_local_fpu_owner new_owner + \\_. equiv_but_for_labels aag L st\" + unfolding switch_local_fpu_owner_def + apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) + apply (prop_tac "equiv_fpu (\a. pasObjectAbs aag a \ L) st s") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_def) + apply (clarsimp simp: cur_fpu_for_def is_arch_cur_fpu_def) + done + +lemma fpu_release_reads_respects: + "reads_respects aag l valid_cur_fpu (fpu_release t)" + unfolding fpu_release_def + apply (rule equiv_valid_guard_imp) + apply (subst gets_comp) + apply (rule_tac P=valid_cur_fpu and ptr=t in reads_respects_unit_cases) + apply (rule equiv_valid_guard_imp) + apply wp + apply (wpsimp wp: when_ev) + prefer 2 + apply wpsimp + apply (wpsimp wp: gets_ev'') + apply (prop_tac "valid_cur_fpu x \ aag_can_read_or_affect aag l t") + apply assumption + apply (prop_tac "valid_cur_fpu xa \ aag_can_read_or_affect aag l t") + apply assumption + apply (prop_tac "equiv_fpu (aag_can_read_or_affect aag l) x xa \ + equiv_for (aag_can_read_or_affect aag l) kheap x xa ") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 + states_equiv_for_def equiv_for_disj equiv_fpu_def) + apply clarsimp + apply (clarsimp simp: valid_cur_fpu_def equiv_for_def is_tcb_cur_fpu_def obj_at_def) + apply fastforce + apply clarsimp + apply wpsimp+ + apply (wp switch_local_fpu_owner_equiv_but_for_labels) + apply (clarsimp split del: if_split cong: if_cong conj_cong) + apply wp + apply clarsimp + apply wpsimp+ + done + +lemma prepare_thread_delete_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (pas_refined aag and valid_arch_state and valid_cur_fpu and K (is_subject aag thread)) + (prepare_thread_delete thread)" + unfolding prepare_thread_delete_def + apply (wpsimp wp: fpu_release_reads_respects dissociate_vcpu_tcb_reads_respects hoare_vcg_imp_lift' + | rule arch_thread_get_wp)+ + apply (subgoal_tac "is_subject aag x") + apply fastforce + apply (erule associated_vcpu_is_subject) + apply (simp add: get_tcb_ko_at) + apply simp + apply simp + done + +lemma prepare_thread_delete_reads_respects_f[Finalise_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects_f aag l (silc_inv aag st and pas_refined aag and valid_arch_state + and valid_cur_fpu and K (is_subject aag thread)) + (prepare_thread_delete thread)" + apply (rule equiv_valid_guard_imp) + apply (wpsimp wp: reads_respects_f[OF prepare_thread_delete_reads_respects, where st=st])+ + done + +lemma vcpu_finalise_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (pas_refined aag and valid_arch_state and K (is_subject aag vr)) (vcpu_finalise vr)" + unfolding vcpu_finalise_def + apply (rule gen_asm_ev) + apply (wpsimp wp: dissociate_vcpu_tcb_reads_respects get_vcpu_wp) + apply (fastforce dest: associated_tcb_is_subject) + done + +lemma arch_finalise_cap_reads_respects[Finalise_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag l (pas_refined aag and invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and K (pas_cap_cur_auth aag (ArchObjectCap cap))) + (arch_finalise_cap cap final)" + unfolding arch_finalise_cap_def + apply (rule gen_asm_ev) + apply (case_tac cap) + apply simp + apply (simp split: bool.splits) + apply (intro impI conjI) + apply (wp delete_asid_pool_reads_respects unmap_page_reads_respects unmap_page_table_reads_respects + delete_asid_reads_respects find_vspace_for_asid_reads_respects vcpu_finalise_reads_respects + | simp add: invs_psp_aligned invs_vspace_objs invs_valid_objs valid_cap_def + valid_arch_state_asid_table invs_arch_state wellformed_mapdata_def + split: option.splits bool.splits pt_type.splits + | intro impI conjI allI + | elim conjE + | drule cte_wp_valid_cap + | fastforce dest: aag_can_read_own_asids aag_cap_auth_subject)+ + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def) + apply (drule (1) pas_refined_Control, clarsimp) + apply (wp delete_asid_pool_reads_respects unmap_page_reads_respects unmap_page_table_reads_respects + delete_asid_reads_respects find_vspace_for_asid_reads_respects vcpu_finalise_reads_respects + | simp add: invs_psp_aligned invs_vspace_objs invs_valid_objs valid_cap_def + valid_arch_state_asid_table invs_arch_state wellformed_mapdata_def + split: option.splits bool.splits pt_type.splits + | intro impI conjI allI + | elim conjE + | drule cte_wp_valid_cap + | fastforce dest: aag_can_read_own_asids aag_cap_auth_subject)+ + done + +(*NOTE: Required to dance around the issue of the base potentially + being zero and thus we can't conclude it is in the current subject.*) +lemma requiv_arm_asid_table_asid_high_bits_of_asid_eq': + "\ pas_cap_cur_auth aag (ArchObjectCap (ASIDPoolCap p b)); reads_equiv aag s t; pas_refined aag x \ + \ asid_table s (asid_high_bits_of b) = + asid_table t (asid_high_bits_of b)" + apply (subgoal_tac "asid_high_bits_of 0 = asid_high_bits_of 1") + apply (case_tac "b = 0") + apply (subgoal_tac "is_subject_asid aag 1") + apply ((fastforce intro: requiv_arm_asid_table_asid_high_bits_of_asid_eq + aag_cap_auth_ASIDPoolCap_asid + simp del: asid_high_bits_of_0)+)[2] + apply (auto intro: requiv_arm_asid_table_asid_high_bits_of_asid_eq + aag_cap_auth_ASIDPoolCap_asid)[1] + apply (simp add: asid_high_bits_of_def asid_low_bits_def) + done + +lemma pt_cap_aligned: + "\ caps_of_state s p = Some (ArchObjectCap (PageTableCap word pt_t x)); valid_caps (caps_of_state s) s \ + \ is_aligned word (pt_bits pt_t)" + by (auto simp: obj_ref_of_def pt_bits_def pageBits_def + dest!: cap_aligned_valid[OF valid_capsD, unfolded cap_aligned_def, THEN conjunct1]) + +lemma maskInterrupt_no_mem: + "maskInterrupt a b \\ms. P (underlying_memory ms)\" + by (wpsimp simp: maskInterrupt_def) + +lemma set_irq_state_valid_global_objs: + "set_irq_state state irq \valid_global_objs\" + apply (simp add: set_irq_state_def) + apply (wp modify_wp) + apply (fastforce simp: valid_global_objs_def) + done + +lemma set_irq_state_globals_equiv[Finalise_IF_assms]: + "set_irq_state state irq \globals_equiv st\" + apply (simp add: set_irq_state_def) + apply (wp dmo_no_mem_globals_equiv maskInterrupt_no_mem modify_wp) + apply (simp add: globals_equiv_interrupt_states_update) + done + +lemma set_notification_globals_equiv[Finalise_IF_assms]: + "\globals_equiv st and valid_arch_state\ + set_notification ptr ntfn + \\_. globals_equiv st\" + unfolding set_simple_ko_def + apply (wp set_object_globals_equiv get_object_wp) + apply (fastforce simp: obj_at_def valid_arch_state_def dest: valid_global_arch_objs_pt_at) + done + +lemma delete_asid_globals_equiv: + "\globals_equiv st and valid_arch_state\ + delete_asid asid pt + \\_. globals_equiv st\" + unfolding delete_asid_def + by (wpsimp wp: set_vm_root_globals_equiv set_asid_pool_globals_equiv hoare_drop_imps) + +lemma vcpu_finalise_globals_equiv[wp]: + "\globals_equiv s and invs\ + vcpu_finalise vr + \\_. globals_equiv s\" + unfolding vcpu_finalise_def + apply (wpsimp wp: dissociate_vcpu_tcb_globals_equiv get_vcpu_wp) + apply (rule conjI, fastforce) + (* FIXME AARCH64 IF: boilerplate *) + apply (rename_tac s' vcpu tcb) + apply clarsimp + apply (prop_tac "(idle_thread s', HypTCBRef) \ state_hyp_refs_of s' vr") + apply (clarsimp simp: state_hyp_refs_of_def opt_map_def split: option.splits) + apply (drule sym_refsD) + apply (erule invs_hyp_sym_refs) + apply (clarsimp simp: obj_at_vcpu_hyp_live_of_s[symmetric] is_vcpu_def + state_hyp_refs_of_def obj_at_def hyp_live_def hyp_refs_of_def + tcb_vcpu_refs_def refs_of_ao_def arch_live_def vcpu_tcb_refs_def + split: option.splits kernel_object.splits arch_kernel_obj.splits) + apply (frule invs_valid_idle) + apply (clarsimp simp: valid_idle_def pred_tcb_at_def) + apply (frule invs_iflive) + apply (frule invs_valid_global_refs) + apply (frule invs_valid_objs) + apply (drule (1) idle_no_ex_cap) + apply (erule swap, erule if_live_then_nonz_capD) + apply simp + apply clarsimp + apply (clarsimp simp: live_def hyp_live_def) + done + +lemma arch_finalise_cap_globals_equiv[Finalise_IF_assms]: + "\globals_equiv st and invs and valid_arch_cap cap\ + arch_finalise_cap cap b + \\_. globals_equiv st\" + apply (induct cap; simp add: arch_finalise_cap_def) + by (wp delete_asid_pool_globals_equiv case_option_wp unmap_page_globals_equiv + unmap_page_table_globals_equiv delete_asid_globals_equiv + | wpc | fastforce simp: valid_arch_cap_def wellformed_mapdata_def)+ + +lemma arch_thread_set_fpu_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state\ + arch_thread_set (tcb_cur_fpu_update f) t + \\_. globals_equiv s\" + unfolding arch_thread_set_is_thread_set + by (wpsimp wp: thread_set_globals_equiv simp: arch_tcb_context_get_def) + +lemma globals_equiv_fpu_owner_update[simp]: + "globals_equiv st (s\arch_state := arch_state s\arm_current_fpu_owner := cf\\) = globals_equiv st s" + by (auto simp: globals_equiv_def) + +lemma set_arm_current_fpu_owner_globals_equiv: + "\globals_equiv st and valid_arch_state\ + set_arm_current_fpu_owner new_owner + \\_. globals_equiv st\" + unfolding set_arm_current_fpu_owner_def + by (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift)+ + +lemma load_fpu_state_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. t \ idle_thread s)\ + load_fpu_state t + \\_. globals_equiv st\" + unfolding load_fpu_state_def + by (wpsimp wp: dmo_globals_equiv) + +lemma save_fpu_state_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. t \ idle_thread s)\ + save_fpu_state t + \\_. globals_equiv st\" + unfolding save_fpu_state_def + by (wpsimp wp: dmo_globals_equiv) + +crunch load_fpu_state, save_fpu_state + for valid_arch_state[wp]: valid_arch_state + +(* FIXME AARCH64 IF: move *) +lemma switch_local_fpu_owner_Some_globals_equiv: + "\globals_equiv st and invs and (\s. t \ idle_thread s)\ + switch_local_fpu_owner (Some t) + \\_. globals_equiv st\" + unfolding switch_local_fpu_owner_def + apply (wpsimp wp: set_arm_current_fpu_owner_globals_equiv dmo_globals_equiv + load_fpu_state_globals_equiv save_fpu_state_globals_equiv + hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_cur_fpu_def + is_tcb_cur_fpu_def live_def arch_tcb_live_def + dest: idle_no_ex_cap if_live_then_nonz_capD) + done + +lemma switch_local_fpu_owner_None_globals_equiv: + "\globals_equiv st and invs\ + switch_local_fpu_owner None + \\_. globals_equiv st\" + unfolding switch_local_fpu_owner_def + apply (wpsimp wp: set_arm_current_fpu_owner_globals_equiv dmo_globals_equiv + load_fpu_state_globals_equiv save_fpu_state_globals_equiv + hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_cur_fpu_def + is_tcb_cur_fpu_def live_def arch_tcb_live_def + dest: idle_no_ex_cap if_live_then_nonz_capD) + done + +declare dissociate_vcpu_tcb_globals_equiv[wp del] + +(* FIXME AARCH64 IF: consolidate *) +lemma dissociate_vcpu_tcb_globals_equiv[wp]: + "\globals_equiv s and invs\ + dissociate_vcpu_tcb vr t + \\_. globals_equiv s\" + unfolding dissociate_vcpu_tcb_def + apply (wpsimp wp: as_user_globals_equiv simp: arch_tcb_context_get_def as_user_bind) + apply (rule_tac Q'="\_ s. arm_current_vcpu (arch_state s) = None" in hoare_post_add) + apply (clarsimp cong: conj_cong) + apply (wpsimp wp: get_vcpu_wp arch_thread_get_wp)+ + apply (subgoal_tac "(\tcb. ko_at (TCB tcb) t sa \ + (\v. vcpus_of sa vr = Some v \ + tcb_vcpu (tcb_arch tcb) = Some vr \ vcpu_tcb v = Some t \ + t \ idle_thread sa))") + apply fastforce + apply clarsimp + (* FIXME AARCH64 IF: boilerplate *) + apply (rename_tac s' tcb vcpu) + apply (prop_tac "(idle_thread s', HypTCBRef) \ state_hyp_refs_of s' vr") + apply (clarsimp simp: state_hyp_refs_of_def opt_map_def split: option.splits) + apply (drule sym_refsD) + apply (erule invs_hyp_sym_refs) + apply (clarsimp simp: obj_at_vcpu_hyp_live_of_s[symmetric] is_vcpu_def + state_hyp_refs_of_def obj_at_def hyp_live_def hyp_refs_of_def + tcb_vcpu_refs_def refs_of_ao_def arch_live_def vcpu_tcb_refs_def + split: option.splits kernel_object.splits arch_kernel_obj.splits) + apply (frule invs_valid_idle) + apply (clarsimp simp: valid_idle_def pred_tcb_at_def) + apply (frule invs_iflive) + apply (frule invs_valid_global_refs) + apply (frule invs_valid_objs) + apply (drule (1) idle_no_ex_cap) + apply (erule swap, erule if_live_then_nonz_capD) + apply simp + apply clarsimp + apply (clarsimp simp: live_def hyp_live_def) + done + +lemma fpu_release_globals_equiv: + "\globals_equiv st and invs\ + fpu_release t + \\_. globals_equiv st\" + unfolding fpu_release_def + by (wpsimp wp: switch_local_fpu_owner_None_globals_equiv) + +lemma prepare_thread_delete_globals_equiv[Finalise_IF_assms, wp]: + "\globals_equiv s and invs\ prepare_thread_delete t \\_. globals_equiv s\" + unfolding prepare_thread_delete_def + by (wpsimp wp: fpu_release_globals_equiv hoare_drop_imps) + +declare arch_get_sanitise_register_info_def[simp] + +lemma set_bound_notification_globals_equiv[Finalise_IF_assms]: + "\globals_equiv s and valid_arch_state\ + set_bound_notification ref ts + \\_. globals_equiv s\" + unfolding set_bound_notification_def + apply (wp set_object_globals_equiv dxo_wp_weak |simp)+ + apply (intro impI conjI allI) + by (fastforce simp: valid_arch_state_def obj_at_def tcb_at_def2 get_tcb_def is_tcb_def + dest: get_tcb_SomeD valid_global_arch_objs_pt_at + split: option.splits kernel_object.splits)+ + +end + + +global_interpretation Finalise_IF_1?: Finalise_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Finalise_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy b/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy new file mode 100644 index 0000000000..4fea890212 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchIRQMasks_IF.thy @@ -0,0 +1,302 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchIRQMasks_IF +imports IRQMasks_IF +begin + +context Arch begin arch_global_naming + +named_theorems IRQMasks_IF_assms + +declare storeWord_irq_masks_inv[IRQMasks_IF_assms] + +lemma resetTimer_irq_masks[IRQMasks_IF_assms, wp]: + "resetTimer \\s. P (irq_masks s)\" + by (simp add: resetTimer_def | wp no_irq)+ + +lemma delete_objects_irq_masks[IRQMasks_IF_assms, wp]: + "delete_objects ptr bits \\s. P (irq_masks_of_state s)\" + apply (simp add: delete_objects_def) + apply (wp dmo_wp no_irq_mapM_x no_irq | simp add: freeMemory_def no_irq_storeWord)+ + done + +crunch invoke_untyped + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (ignore: delete_objects wp: crunch_wps dmo_wp + wp: mapME_x_inv_wp preemption_point_inv + simp: crunch_simps no_irq_clearMemory mapM_x_def_bak unless_def) + +lemma vcpu_invalidate_active_irq_masks[wp]: + "vcpu_invalidate_active \\s. P (irq_masks_of_state s)\" + unfolding vcpu_invalidate_active_def vcpu_disable_def + by (wpsimp wp: dmo_wp) + +crunch finalise_cap + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: crunch_wps dmo_wp simp: crunch_simps) + +crunch send_signal, timer_tick + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: crunch_wps ignore: do_machine_op wp: dmo_wp simp: crunch_simps) + +lemma handle_interrupt_irq_masks[IRQMasks_IF_assms]: + notes no_irq[wp del] + shows + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and K (irq \ maxIRQ)\ + handle_interrupt irq + \\rv s. P (irq_masks_of_state s)\" + apply (rule hoare_gen_asm) + apply (simp add: handle_interrupt_def split del: if_split) + apply (rule hoare_pre) + apply (rule hoare_if) + apply simp + apply (wp dmo_wp + | simp add: ackInterrupt_def maskInterrupt_def when_def split del: if_split + | wpc + | simp add: get_irq_state_def + | wp (once) hoare_drop_imp hoare_pre_cont)+ + apply (fastforce simp: domain_sep_inv_def) + done + +lemma arch_invoke_irq_control_irq_masks[IRQMasks_IF_assms]: + "\domain_sep_inv False st and arch_irq_control_inv_valid invok\ + arch_invoke_irq_control invok + \\_ s. P (irq_masks_of_state s)\" + by (cases invok) (auto simp: arch_irq_control_inv_valid_def domain_sep_inv_def valid_def) + +lemma dmo_getActiveIRQ_irq_masks[IRQMasks_IF_assms, wp]: + "do_machine_op (getActiveIRQ in_kernel) \\s. P (irq_masks_of_state s)\" + apply (rule hoare_pre, rule dmo_wp) + apply (simp add: getActiveIRQ_def | wp | simp add: no_irq_def | clarsimp)+ + done + +lemma dmo_getActiveIRQ_return_axiom[IRQMasks_IF_assms, wp]: + "\\\ do_machine_op (getActiveIRQ in_kernel) \\rv s. (\x. rv = Some x \ x \ maxIRQ)\" + apply (simp add: getActiveIRQ_def) + apply (rule hoare_pre, rule dmo_wp) + apply (insert irq_oracle_max_irq) + apply (wp dmo_getActiveIRQ_irq_masks) + apply (clarsimp simp: maxIRQ_def) + done + +crunch activate_thread, handle_spurious_irq, handle_vm_fault + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp no_irq) + +end + + +global_interpretation IRQMasks_IF_1?: IRQMasks_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact IRQMasks_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +crunch handle_vm_fault, handle_hypervisor_fault + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp no_irq) + +crunch do_reply_transfer, set_priority, set_flags, arch_post_set_flags + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: crunch_wps dmo_wp empty_slot_irq_masks simp: crunch_simps unless_def) + +lemma no_irq_do_flush[wp,simp]: + "no_irq (do_flush type vstart vend pstart)" + by (wpsimp simp: do_flush_def) + +crunch perform_vspace_invocation, perform_page_table_invocation, perform_asid_control_invocation, + perform_asid_pool_invocation, perform_sgi_invocation, perform_page_invocation + for irq_masks[IRQMasks_IF_assms, wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp crunch_wps no_irq simp: crunch_simps) + +(* FIXME: remove duplication in this proof -- requires getting the wp automation + to do the right thing with dropping imps in validE goals *) +lemma invoke_tcb_irq_masks[IRQMasks_IF_assms]: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and tcb_inv_wf tinv\ + invoke_tcb tinv + \\_ s. P (irq_masks_of_state s)\" + apply (case_tac tinv) + apply((wp restart_irq_masks hoare_vcg_if_lift mapM_x_wp[OF _ subset_refl] + | wpc + | simp split del: if_split add: check_cap_at_def + | clarsimp)+)[3] + defer + apply ((wp | simp)+)[2] + (* NotificationControl *) + apply (rename_tac option) + apply (case_tac option) + apply ((wp | simp)+)[2] + (* just ThreadControl left *) + apply (simp add: split_def cong: option.case_cong) + apply wpsimp+ + apply (rule hoare_strengthen_postE[OF cap_delete_irq_masks[where P=P]]) + apply blast + apply blast + apply (wpsimp wp: hoare_vcg_all_liftE_R hoare_vcg_const_imp_liftE_R hoare_vcg_all_lift hoare_drop_imps + checked_cap_insert_domain_sep_inv)+ + apply (rule_tac Q'="\ r s. domain_sep_inv False st s \ P (irq_masks_of_state s)" + and E'="\_ s. P (irq_masks_of_state s)" in hoare_strengthen_postE) + apply (wp hoare_vcg_conj_liftE1 cap_delete_irq_masks) + apply fastforce + apply blast + apply (wpsimp wp: hoare_weak_lift_imp hoare_vcg_all_lift checked_cap_insert_domain_sep_inv)+ + apply (rule_tac Q'="\ r s. domain_sep_inv False st s \ P (irq_masks_of_state s)" + and E'="\_ s. P (irq_masks_of_state s)" in hoare_strengthen_postE) + apply (wp hoare_vcg_conj_liftE1 cap_delete_irq_masks) + apply fastforce + apply blast + apply (simp add: option_update_thread_def | wp hoare_weak_lift_imp hoare_vcg_all_lift | wpc)+ + by fastforce+ + +crunch arch_prepare_set_domain, + invoke_vcpu_inject_irq, invoke_vcpu_read_register, + invoke_vcpu_write_register, invoke_vcpu_ack_vppi + for irq_masks[IRQMasks_IF_assms,wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp mapM_x_wp_inv mapM_wp_inv) + +lemma inactive_irqVTimerEvent: + "\domain_sep_inv False st and R False\ + is_irq_active irqVTimerEvent + \\rv. if rv then Q rv else R rv\" + unfolding is_irq_active_def get_irq_state_def + apply wpsimp + apply (fastforce simp: domain_sep_inv_def non_kernel_IRQs_def) + done + +crunch vcpu_restore_reg, vcpu_restore_reg_range + for irq_masks[wp]: "\s. P (irq_masks_of_state s)" + (wp: dmo_wp mapM_x_wp) + +lemma restore_virt_timer_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + restore_virt_timer vcpu_ptr + \\rv s. P (irq_masks_of_state s)\" + unfolding restore_virt_timer_def + by (wpsimp wp: inactive_irqVTimerEvent[where st=st] | wp hoare_pre_cont)+ + +lemma vcpu_enable_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + vcpu_enable vr + \\rv s. P (irq_masks_of_state s)\" + unfolding vcpu_enable_def + by (wpsimp wp: restore_virt_timer_irq_masks[where st=st] dmo_wp) + +lemma vcpu_restore_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + vcpu_restore vr + \\rv s. P (irq_masks_of_state s)\" + unfolding vcpu_restore_def + by (wpsimp wp: vcpu_enable_irq_masks[where st=st] mapM_wp_inv dmo_wp) + +lemma vcpu_switch_Some_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + vcpu_switch (Some vcpu) + \\rv s. P (irq_masks_of_state s)\" + unfolding vcpu_switch_def + by (wpsimp wp: vcpu_restore_irq_masks[where st=st] vcpu_enable_irq_masks[where st=st] dmo_wp) + +lemma associate_vcpu_tcb_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + associate_vcpu_tcb vcpu_ptr t + \\rv s. P (irq_masks_of_state s)\" + unfolding associate_vcpu_tcb_def + by (wpsimp wp: vcpu_switch_Some_irq_masks[where st=st] hoare_weak_lift_imp | wps)+ + +lemma perform_vcpu_invocation_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + perform_vcpu_invocation i + \\rv s. P (irq_masks_of_state s)\" + unfolding perform_vcpu_invocation_def + by (wpsimp wp: associate_vcpu_tcb_irq_masks[where st=st]) + +lemma perform_smc_invocation_irq_masks[wp]: + "\(\s. P (irq_masks_of_state s))\ + perform_smc_invocation i + \\rv s. P (irq_masks_of_state s)\" + unfolding perform_smc_invocation_def doSMC_mop_def + by (wpsimp simp: dmo_distr wp: hoare_drop_imps dmo_wp) + +lemma arch_perform_invocation_irq_masks[IRQMasks_IF_assms, wp]: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + arch_perform_invocation i + \\rv s. P (irq_masks_of_state s)\" + unfolding arch_perform_invocation_def fun_app_def + by (wpsimp wp: perform_vcpu_invocation_irq_masks[where st=st]) + +lemma maskVTimer_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + do_machine_op (maskInterrupt True irqVTimerEvent) + \\rv s. P (irq_masks_of_state s)\" + unfolding maskInterrupt_def + apply (wpsimp wp: dmo_machine_state_lift) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: domain_sep_inv_def non_kernel_IRQs_def valid_irq_states_def valid_irq_masks_def) + done + +lemma vcpu_disable_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + vcpu_disable vo + \\rv s. P (irq_masks_of_state s)\" + by (wpsimp wp: maskVTimer_irq_masks[where st=st] hoare_drop_imps dmo_machine_state_lift + simp: vcpu_disable_def dmo_distr) + +lemma vcpu_switch_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + vcpu_switch vo + \\rv s. P (irq_masks_of_state s)\" + unfolding vcpu_switch_def + by (wpsimp wp: vcpu_disable_irq_masks[where st=st] + vcpu_restore_irq_masks[where st=st] + vcpu_enable_irq_masks[where st=st] + dmo_machine_state_lift) + +lemma arch_switch_to_idle_thread_irq_masks[IRQMasks_IF_assms]: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + arch_switch_to_idle_thread + \\rv s. P (irq_masks_of_state s)\" + unfolding arch_switch_to_idle_thread_def + by (wpsimp wp: vcpu_switch_irq_masks[where st=st]) + +lemma arch_switch_to_thread_irq_masks[IRQMasks_IF_assms]: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + arch_switch_to_thread t + \\rv s. P (irq_masks_of_state s)\" + unfolding arch_switch_to_thread_def + by (wpsimp wp: vcpu_switch_irq_masks[where st=st]) + +crunch arch_prepare_next_domain + for irq_masks[IRQMasks_IF_assms,wp]: "\s. P (irq_masks_of_state s)" + and valid_irq_states[IRQMasks_IF_assms,wp]: "valid_irq_states" + (wp: crunch_wps) + +end + + +global_interpretation IRQMasks_IF_2?: IRQMasks_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact IRQMasks_IF_assms)?) +qed + + +(* FIXME AARCH64 IF: add to interface *) +arch_requalify_facts + init_arch_objects_irq_masks + arch_activate_idle_thread_irq_masks + retype_region_irq_masks + +declare + init_arch_objects_irq_masks[wp] + arch_activate_idle_thread_irq_masks[wp] + retype_region_irq_masks[wp] + +end diff --git a/proof/infoflow/AARCH64/ArchInfoFlow.thy b/proof/infoflow/AARCH64/ArchInfoFlow.thy new file mode 100644 index 0000000000..7a2bc30a41 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchInfoFlow.thy @@ -0,0 +1,134 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchInfoFlow +imports + "Access.ArchSyscall_AC" + "Lib.EquivValid" +begin + +(* Declare here and define in InfoFlow_IF *) +consts equiv_for :: "('a \ bool) \ ('b \ 'a \ 'c) \ 'b \ 'b \ bool" + +context Arch begin arch_global_naming + +section \Arch-specific equivalence properties\ + +subsection \ASID equivalence\ + +definition equiv_asid :: "asid \ det_ext state \ det_ext state \ bool" where + "equiv_asid asid s s' \ + ((arm_asid_table (arch_state s) (asid_high_bits_of asid)) = + (arm_asid_table (arch_state s') (asid_high_bits_of asid))) \ + (\pool_ptr. arm_asid_table (arch_state s) (asid_high_bits_of asid) = Some pool_ptr + \ asid_pool_at pool_ptr s = asid_pool_at pool_ptr s' \ + (\asid_pool asid_pool'. asid_pools_of s pool_ptr = Some asid_pool \ + asid_pools_of s' pool_ptr = Some asid_pool' + \ asid_pool (asid_low_bits_of asid) = + asid_pool' (asid_low_bits_of asid)))" + +definition equiv_asid' where + "equiv_asid' asid pool_ptr_opt pool_ptr_opt' kh kh' \ + (case pool_ptr_opt of None \ pool_ptr_opt' = None + | Some pool_ptr \ + (case pool_ptr_opt' of None \ False + | Some pool_ptr' \ + (pool_ptr' = pool_ptr \ + ((\asid_pool. kh pool_ptr = Some (ArchObj (ASIDPool asid_pool))) = + (\asid_pool'. kh' pool_ptr' = Some (ArchObj (ASIDPool asid_pool')))) \ + (\asid_pool asid_pool'. kh pool_ptr = Some (ArchObj (ASIDPool asid_pool)) \ + kh' pool_ptr' = Some (ArchObj (ASIDPool asid_pool')) + \ asid_pool (asid_low_bits_of asid) = + asid_pool' (asid_low_bits_of asid)))))" + +definition non_asid_pool_kheap_update where + "non_asid_pool_kheap_update s kh \ + \x. (\asid_pool. kheap s x = Some (ArchObj (ASIDPool asid_pool)) \ + kh x = Some (ArchObj (ASIDPool asid_pool))) + \ kheap s x = kh x" + + +subsection \VCPU equivalence\ + +(* FIXME AARCH64 IF: move *) +locale_abbrev numlistregs :: "'s state \ nat" where + "numlistregs s \ arm_gicvcpu_numlistregs (arch_state s)" + +(* FIXME AARCH64 IF: move *) +locale_abbrev current_vcpu :: "'s state \ obj_ref \ bool" where + "current_vcpu s \ arm_current_vcpu (arch_state s)" + +definition hw_vcpu :: "nat \ bool option \ vcpu_state \ vcpu_state" where + "hw_vcpu n cv vcpu \ case cv of + None \ None + | Some enabled \ Some + \vcpu_vgic = \vgic_hcr = if \enabled then undefined else vgic_hcr (vcpu_vgic vcpu), + vgic_vmcr = vgic_vmcr (vcpu_vgic vcpu), + vgic_apr = vgic_apr (vcpu_vgic vcpu), + vgic_lr = \r. if r < n then vgic_lr (vcpu_vgic vcpu) r else undefined\, + vcpu_regs = \r. if \enabled \ vcpuRegSavedWhenDisabled r + then undefined + else vcpu_regs vcpu r\" + +locale_abbrev hw_vcpu_of :: "'s state \ obj_ref \ vcpu_state" where + "hw_vcpu_of s p \ hw_vcpu (numlistregs s) (cur_vcpu_of s p) (vcpu_state (machine_state s))" + +lemmas hw_vcpu_of_def = hw_vcpu_def + +definition equiv_hyp :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_hyp P s s' \ equiv_for P (K \ numlistregs) s s' \ + equiv_for P cur_vcpu_of s s' \ + equiv_for P hw_vcpu_of s s'" + + +subsection \FPU equivalence\ + +(* FIXME AARCH64 IF: move *) +locale_abbrev current_fpu :: "'s state \ obj_ref" where + "current_fpu s \ arm_current_fpu_owner (arch_state s)" + +definition is_arch_cur_fpu_2 :: "obj_ref \ obj_ref option \ bool" where + "is_arch_cur_fpu_2 ptr fopt \ fopt = Some ptr" + +locale_abbrev is_arch_cur_fpu :: "obj_ref \ 's state \ bool" where + "is_arch_cur_fpu ptr s \ is_arch_cur_fpu_2 ptr (arm_current_fpu_owner (arch_state s))" + +lemmas is_arch_cur_fpu_def = is_arch_cur_fpu_2_def + +definition hw_fpu :: "bool \ fpu_state \ fpu_state option" where + "hw_fpu cf fpu \ if cf then Some fpu else None" + +locale_abbrev hw_fpu_of :: "'s state \ 64 word \ fpu_state" where + "hw_fpu_of s t \ hw_fpu (is_arch_cur_fpu t s) (fpu_state (machine_state s))" + +definition equiv_fpu :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_fpu P s s' \ equiv_for P hw_fpu_of s s'" + + +subsection \Global (Kernel) VSpace equivalence\ +(* globals_equiv should be maintained by everything except the scheduler, since + nothing else touches the globals frame *) + +definition arch_globals_equiv :: + "obj_ref \ obj_ref \ kheap \ kheap \ arch_state \ + arch_state \ machine_state \ machine_state \ bool" + where + "arch_globals_equiv ct it kh kh' as as' ms ms' \ + arm_us_global_vspace as = arm_us_global_vspace as' \ + kh (arm_us_global_vspace as) = kh' (arm_us_global_vspace as)" + +declare arch_globals_equiv_def[simp] + +end + +(* FIXME AARCH64 IF: requalify elsewhere *) +arch_requalify_consts + equiv_asid + equiv_asid' + arch_globals_equiv + non_asid_pool_kheap_update + +end diff --git a/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy b/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy new file mode 100644 index 0000000000..e9640f8e59 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchInfoFlow_IF.thy @@ -0,0 +1,558 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchInfoFlow_IF +imports InfoFlow_IF +begin + +context Arch begin arch_global_naming + +named_theorems InfoFlow_IF_assms + +definition identical_hyp_state_updates :: + "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_hyp_state_updates P s s' ms ms' \ + identical_updates_for P (hw_vcpu_of s) (hw_vcpu_of s') + (hw_vcpu_of (s\machine_state := ms\)) + (hw_vcpu_of (s'\machine_state := ms'\))" + +definition identical_fpu_state_updates :: + "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_fpu_state_updates P s s' ms ms' \ + identical_updates_for P (hw_fpu_of s) (hw_fpu_of s') + (hw_fpu_of (s\machine_state := ms\)) + (hw_fpu_of (s'\machine_state := ms'\))" + +lemma asid_pool_at_kheap: + "asid_pool_at ptr s = (\asid_pool. kheap s ptr = Some (ArchObj (ASIDPool asid_pool)))" + by (simp add: atyp_at_eq_kheap_obj) + +lemma equiv_asid: + "equiv_asid asid s s' = equiv_asid' asid (arm_asid_table (arch_state s) (asid_high_bits_of asid)) + (arm_asid_table (arch_state s') (asid_high_bits_of asid)) + (kheap s) (kheap s')" + by (auto simp: equiv_asid_def equiv_asid'_def asid_pool_at_kheap opt_map_def split: option.splits) + +lemma equiv_asids_refl[InfoFlow_IF_assms]: + "equiv_asids R s s" + by (auto simp: equiv_asids_def equiv_asid_def) + +lemma equiv_asids_sym[InfoFlow_IF_assms]: + "equiv_asids R s t \ equiv_asids R t s" + by (auto simp: equiv_asids_def equiv_asid_def) + +lemma equiv_asids_trans[InfoFlow_IF_assms]: + "\ equiv_asids R s t; equiv_asids R t u \ \ equiv_asids R s u" + by (fastforce simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap asid_pools_of_ko_at obj_at_def) + +lemma equiv_asids_guard_imp[InfoFlow_IF_assms]: + "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" + by (auto simp: equiv_asids_def) + +lemma equiv_asids_non_asid_pool_kheap_update[InfoFlow_IF_assms]: + "\ equiv_asids R s s'; non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh' \ + \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" + apply (clarsimp simp: equiv_asids_def equiv_asid non_asid_pool_kheap_update_def) + apply (fastforce simp: equiv_asid'_def split: option.splits) + done + +lemma equiv_asids_identical_kheap_updates[InfoFlow_IF_assms]: + "\ equiv_asids R s s'; identical_kheap_updates s s' kh kh' \ + \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" + apply (clarsimp simp: equiv_asids_def equiv_asid_def opt_map_def + asid_pool_at_kheap identical_kheap_updates_def) + apply (case_tac "kh pool_ptr = kh' pool_ptr"; fastforce) + done + +lemma equiv_asids_triv': + "\ equiv_asids R s s'; kheap t = kheap s; kheap t' = kheap s'; + arm_asid_table (arch_state t) = arm_asid_table (arch_state s); + arm_asid_table (arch_state t') = arm_asid_table (arch_state s') \ + \ equiv_asids R t t'" + by (fastforce simp: equiv_asids_def equiv_asid equiv_asid'_def) + +lemma equiv_asids_triv[InfoFlow_IF_assms]: + "\ equiv_asids R s s'; kheap t = kheap s; kheap t' = kheap s'; + arch_state t = arch_state s; arch_state t' = arch_state s' \ + \ equiv_asids R t t'" + by (fastforce simp: equiv_asids_triv') + +lemma equiv_hyp_refl[InfoFlow_IF_assms]: + "equiv_hyp P s s" + by (auto simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_sym[InfoFlow_IF_assms]: + "equiv_hyp P s t \ equiv_hyp P t s" + by (auto simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_trans[InfoFlow_IF_assms]: + "\ equiv_hyp P s t; equiv_hyp P t u \ \ equiv_hyp P s u" + by (fastforce simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_guard_imp[InfoFlow_IF_assms]: + "\ equiv_hyp P s s'; \x. Q x \ P x \ \ equiv_hyp Q s s'" + by (fastforce simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_triv': + "\ equiv_hyp P s s'; + arm_current_vcpu (arch_state t) = arm_current_vcpu (arch_state s); + arm_current_vcpu (arch_state t') = arm_current_vcpu (arch_state s'); + vcpu_state (machine_state t) = vcpu_state (machine_state s); + vcpu_state (machine_state t') = vcpu_state (machine_state s'); + arm_gicvcpu_numlistregs (arch_state t) = arm_gicvcpu_numlistregs (arch_state s); + arm_gicvcpu_numlistregs (arch_state t') = arm_gicvcpu_numlistregs (arch_state s') \ + \ equiv_hyp P t t'" + by (fastforce simp: equiv_hyp_def equiv_for_def) + +lemma equiv_hyp_triv[InfoFlow_IF_assms]: + "\ equiv_hyp P s s'; arch_state t = arch_state s; arch_state t' = arch_state s'; + machine_state t = machine_state s; machine_state t' = machine_state s' \ + \ equiv_hyp P t t'" + by (fastforce simp: equiv_hyp_triv') + +lemma equiv_hyp_machine_state_update[InfoFlow_IF_assms]: + "\ equiv_hyp P s s'; identical_hyp_state_updates P s s' ms ms' \ + \ equiv_hyp P (s\machine_state := ms\) (s'\machine_state := ms'\)" + by (fastforce simp: equiv_hyp_def equiv_for_def identical_hyp_state_updates_def identical_updates_def) + +lemma equiv_fpu_refl[InfoFlow_IF_assms]: + "equiv_fpu P s s" + by (auto simp: equiv_fpu_def equiv_for_def) + +lemma equiv_fpu_sym[InfoFlow_IF_assms]: + "equiv_fpu P s t \ equiv_fpu P t s" + by (auto simp: equiv_fpu_def equiv_for_def) + +lemma equiv_fpu_trans[InfoFlow_IF_assms]: + "\ equiv_fpu P s t; equiv_fpu P t u \ \ equiv_fpu P s u" + by (fastforce simp: equiv_fpu_def equiv_for_def) + +lemma equiv_fpu_guard_imp[InfoFlow_IF_assms]: + "\ equiv_fpu P s s'; \x. Q x \ P x \ \ equiv_fpu Q s s'" + by (auto simp: equiv_fpu_def equiv_for_def) + +lemma equiv_fpu_triv': + "\ equiv_fpu P s s'; current_fpu t = current_fpu s; current_fpu t' = current_fpu s'; + fpu_state (machine_state t) = fpu_state (machine_state s); + fpu_state (machine_state t') = fpu_state (machine_state s') \ + \ equiv_fpu P t t'" + by (auto simp: equiv_fpu_def equiv_for_def get_tcb_def hw_fpu_def) + +lemma equiv_fpu_triv[InfoFlow_IF_assms]: + "\ equiv_fpu P s s'; arch_state t = arch_state s; arch_state t' = arch_state s'; + machine_state t = machine_state s; machine_state t' = machine_state s' \ + \ equiv_fpu P t t'" + by (fastforce simp: equiv_fpu_triv') + +lemma equiv_fpu_machine_state_update[InfoFlow_IF_assms]: + "\ equiv_fpu P s s'; identical_fpu_state_updates P s s' ms ms' \ + \ equiv_fpu P (s\machine_state := ms\) (s'\machine_state := ms'\)" + by (fastforce simp: equiv_fpu_def equiv_for_def hw_fpu_def + identical_fpu_state_updates_def identical_updates_def + split: if_splits) + +lemma globals_equiv_refl[InfoFlow_IF_assms]: + "globals_equiv s s" + by (simp add: globals_equiv_def idle_equiv_refl) + +lemma globals_equiv_sym[InfoFlow_IF_assms]: + "globals_equiv s t \ globals_equiv t s" + by (auto simp: globals_equiv_def idle_equiv_def) + +lemma globals_equiv_trans[InfoFlow_IF_assms]: + "\ globals_equiv s t; globals_equiv t u \ \ globals_equiv s u" + unfolding globals_equiv_def arch_globals_equiv_def + by clarsimp (metis idle_equiv_trans idle_equiv_def) + +lemma equiv_hypI[InfoFlow_IF_assms]: + assumes "\x. P x \ equiv_hyp ((=) x) s t" + shows "equiv_hyp P s t" + using assms by (fastforce simp: equiv_hyp_def equiv_for_def) + +lemma equiv_fpuI[InfoFlow_IF_assms]: + assumes "\x. P x \ equiv_fpu ((=) x) s t" + shows "equiv_fpu P s t" + using assms by (fastforce simp: equiv_fpu_def equiv_for_def) + +end + +arch_requalify_consts + identical_hyp_state_updates + identical_fpu_state_updates + + +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 identical_hyp_state_updates identical_fpu_state_updates +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact InfoFlow_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma dmo_loadWord_rev[InfoFlow_IF_assms]: + "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) + (do_machine_op (loadWord p))" + apply (rule gen_asm_ev) + apply (rule use_spec_ev) + apply (rule spec_equiv_valid_hoist_guard) + apply (rule do_machine_op_spec_rev) + apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) + apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" and Q="\\" and Q'="\\" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule_tac R'="(=)" and Q="\r s. p && mask 3 = 0" and Q'="\r s. p && mask 3 = 0" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule return_ev2) + apply (rule_tac f="word_rcat" in arg_cong) + apply (clarsimp simp: upto.simps) + apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right + simp: is_aligned_mask for_each_byte_of_word_def word_size_def) + apply (rule assert_ev2[OF refl]) + apply (rule assert_wp)+ + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad for_each_byte_of_word_def) + apply (erule equiv_forD) + apply fastforce + apply (wp wp_post_taut loadWord_inv | simp)+ + done + +definition cur_vcpu_for_2 :: "(obj_ref \ bool) \ (obj_ref \ bool) option \ bool" where + "cur_vcpu_for_2 P cv \ case cv of + None \ None + | Some (ptr,b) \ if P ptr then Some b else None" + +locale_abbrev cur_vcpu_for :: "(obj_ref \ bool) \ 's state \ bool" where + "cur_vcpu_for P s \ cur_vcpu_for_2 P (current_vcpu s)" + +lemmas cur_vcpu_for_def = cur_vcpu_for_2_def + +lemma hw_vcpu_None[simp]: + "hw_vcpu n None vst = None" + by (simp add: hw_vcpu_def) + +definition equiv_hyp_state :: "nat \ bool option \ machine_state \ machine_state \ bool" where + "equiv_hyp_state n cv ms ms' \ hw_vcpu n cv (vcpu_state ms) = hw_vcpu n cv (vcpu_state ms')" + +definition equiv_fpu_state :: "bool \ machine_state \ machine_state \ bool" where + "equiv_fpu_state cf ms ms' \ hw_fpu cf (fpu_state ms) = hw_fpu cf (fpu_state ms')" + +definition no_hyp :: "'a machine_monad \ bool" where + "no_hyp f \ \P. \\s. P (vcpu_state s)\ f \\_ s. P (vcpu_state s)\" + +definition no_fpu :: "'a machine_monad \ bool" where + "no_fpu f \ \P. \\s. P (fpu_state s)\ f \\_ s. P (fpu_state s)\" + +lemma equiv_hyp_state_identical_hyp_state_updates: + "\ equiv_hyp_state (numlistregs s) (cur_vcpu_for P s) ms ms'; equiv_hyp P s t \ + \ identical_hyp_state_updates P s t ms ms'" + apply (clarsimp simp: equiv_hyp_state_def equiv_for_def identical_hyp_state_updates_def equiv_hyp_def) + apply (erule_tac x=x in allE)+ + apply (drule mp, fastforce) + apply (clarsimp simp: cur_vcpu_for_def cur_vcpu_of_def identical_updates_rv_def + split: option.splits if_splits) + done + +lemma cur_vcpu_for_None: + "cur_vcpu_for_2 P None = None" + by (clarsimp simp: cur_vcpu_for_def) + +lemma cur_vcpu_for_Some: + "cur_vcpu_for_2 P (Some (a,b)) = (if P a then Some b else None)" + by (clarsimp simp: cur_vcpu_for_def) + +lemma cur_vcpu_for_equiv: + "\ reads_equiv aag st s; affects_equiv aag l st s \ + \ cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) st = cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) s" + apply (prop_tac "equiv_for (aag_can_read aag or aag_can_affect aag l) cur_vcpu_of st s") + apply (simp add: equiv_hyp_def equiv_for_or reads_equiv_def2 affects_equiv_def2 states_equiv_for_def) + apply (case_tac "current_vcpu st"; case_tac "current_vcpu s"; clarsimp) + apply (clarsimp simp: cur_vcpu_for_None) + apply (case_tac "(aag_can_read aag or aag_can_affect aag l) a") + prefer 2 + apply (clarsimp simp: cur_vcpu_for_Some) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def) + apply (clarsimp simp: cur_vcpu_for_None) + apply (case_tac "(aag_can_read aag or aag_can_affect aag l) a") + prefer 2 + apply (clarsimp simp: cur_vcpu_for_Some) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def) + apply (case_tac "(aag_can_read aag or aag_can_affect aag l) a"; case_tac "(aag_can_read aag or aag_can_affect aag l) aa") + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def split: if_splits) + apply (erule equiv_forE) + apply (erule_tac x=a in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def split: if_splits) + apply (erule equiv_forE) + apply (erule_tac x=aa in meta_allE) + apply (drule (1) meta_mp) + apply (clarsimp simp: cur_vcpu_of_def split: if_splits) + apply (clarsimp simp: cur_vcpu_for_Some) + done + +lemma aequiv_get_tcb_eq'[intro]: + "\ affects_equiv aag l s t; aag_can_affect aag l thread \ + \ get_tcb thread s = get_tcb thread t" + by (auto simp: affects_equiv_def2 get_tcb_def elim: states_equiv_forE_kheap) + +definition cur_fpu_for :: "(obj_ref \ bool) \ 's state \ bool" where + "cur_fpu_for P s \ \ptr. P ptr \ is_arch_cur_fpu ptr s" + +lemma equiv_fpu_cur_fpu_for: + "equiv_fpu P st s \ cur_fpu_for P st = cur_fpu_for P s" + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def) + apply (rule iffI; erule ex_forward; erule_tac x=ptr in allE; clarsimp simp: hw_fpu_def split: if_splits) + done + +lemma cur_fpu_for_equiv: + "\ reads_equiv aag st s; affects_equiv aag l st s \ + \ cur_fpu_for (aag_can_read aag or aag_can_affect aag l) st = + cur_fpu_for (aag_can_read aag or aag_can_affect aag l) s" + apply (prop_tac "equiv_fpu (aag_can_read aag or aag_can_affect aag l) st s") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_fpu_def equiv_for_def) + apply (simp add: equiv_fpu_cur_fpu_for) + done + +lemma equiv_fpu_state_identical_fpu_state_updates: + "\ equiv_fpu_state (cur_fpu_for P s) ms ms'; equiv_fpu P s t \ + \ identical_fpu_state_updates P s t ms ms'" + unfolding identical_fpu_state_updates_def + apply (clarsimp simp: identical_fpu_state_updates_def identical_updates_def) + apply (clarsimp simp: equiv_fpu_state_def equiv_for_def equiv_fpu_def) + apply (erule_tac x=x in allE, clarsimp) + apply (auto simp: cur_fpu_for_def hw_fpu_def get_tcb_def identical_updates_rv_def split: if_splits option.splits kernel_object.splits) + done + +definition numlistregs_for :: "(obj_ref \ bool) \ 's state \ nat" where + "numlistregs_for P s \ if \p. P p then numlistregs s else undefined" + +lemma numlistregs_for_equiv: + "\ reads_equiv aag st s; affects_equiv aag l st s \ + \ numlistregs_for (aag_can_read aag or aag_can_affect aag l) st = numlistregs_for (aag_can_read aag or aag_can_affect aag l) s" + by (auto simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def numlistregs_for_def) + +lemma equiv_hyp_state_sym: + "equiv_hyp_state n cv ms' ms \ equiv_hyp_state n cv ms ms'" + by (simp add: equiv_hyp_state_def) + +lemma equiv_fpu_state_sym: + "equiv_fpu_state cf ms' ms \ equiv_fpu_state cf ms ms'" + by (simp add: equiv_fpu_state_def) + +lemma spec_equiv_valid_add_inv: + assumes "spec_equiv_valid st I A B (P and I st) f" + and "\s. I s s" + shows "spec_equiv_valid st I A B P f" + using assms by (fastforce simp: spec_equiv_valid_def equiv_valid_2_def) + +lemma spec_equiv_valid_add_A: + assumes "spec_equiv_valid st I A B (P and A st) f" + and "\s. A s s" + shows "spec_equiv_valid st I A B P f" + using assms by (fastforce simp: spec_equiv_valid_def equiv_valid_2_def) + +lemma do_machine_op_reads_respects'': + assumes equiv_dmo: + "\n cv cf. equiv_valid_inv (equiv_irq_state and equiv_machine_state (aag_can_read aag) + and equiv_hyp_state n cv and equiv_fpu_state cf) + (equiv_machine_state (aag_can_affect aag l)) (Q n cv cf) f" + assumes guard: + "\s. P s \ Q (numlistregs_for (aag_can_read aag or aag_can_affect aag l) s) + (cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) s) + (cur_fpu_for (aag_can_read aag or aag_can_affect aag l) s) + (machine_state s)" + (is "\s. P s \ Q (?nlf s) (?cvf s) (?cff s) (machine_state s)") + shows + "reads_respects aag l P (do_machine_op f)" + apply (rule use_spec_ev) + apply (rule spec_equiv_valid_add_inv) + prefer 2 + apply (simp add: reads_equiv_refl) + apply (rule spec_equiv_valid_add_A) + prefer 2 + apply (simp add: affects_equiv_refl) + apply (unfold do_machine_op_def spec_equiv_valid_def) + supply equiv_for_disj[simp] + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. equiv_machine_state (aag_can_read_or_affect aag l) rv rv' \ + equiv_irq_state rv rv' \ + equiv_hyp_state (?nlf st) (?cvf st) rv rv' \ + equiv_fpu_state (?cff st) rv rv'" + and Q="\r s. st = s \ Q (?nlf st) (?cvf st) (?cff st) r" + and Q'="\r s. Q (?nlf st) (?cvf st) + (?cff st) r" + and P="(=) st" and P'="\" in equiv_valid_2_bind) + apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) + apply (rule gen_asm_ev2_r') + apply (rule_tac R'="\(r, ms') (r', ms''). r = r' + \ equiv_machine_state (aag_can_read_or_affect aag l) ms' ms'' + \ equiv_irq_state ms' ms'' + \ equiv_hyp_state (?nlf st) (?cvf st) ms' ms'' + \ equiv_fpu_state (?cff st) ms' ms''" + and Q="\r s. s = st" + and Q'="\\" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) + apply (rule conjI) + apply (rule reads_equiv_machine_state_update; clarsimp?) + apply (rule equiv_hyp_state_identical_hyp_state_updates) + apply (clarsimp simp: equiv_hyp_state_def cur_vcpu_for_def numlistregs_for_def + split: option.splits if_splits) + apply (erule reads_equivE, clarsimp simp: equiv_hyp_def) + apply (rule equiv_fpu_state_identical_fpu_state_updates) + apply (fastforce simp: equiv_fpu_state_def cur_fpu_for_def hw_fpu_def + split: option.splits if_splits) + apply (erule reads_equivE, clarsimp simp: equiv_fpu_def) + apply (rule affects_equiv_machine_state_update; clarsimp?) + apply (rule equiv_hyp_state_identical_hyp_state_updates) + apply (clarsimp simp: equiv_hyp_state_def cur_vcpu_for_def numlistregs_for_def + split: option.splits if_splits) + apply (erule affects_equivE, clarsimp simp: equiv_hyp_def) + apply (rule equiv_fpu_state_identical_fpu_state_updates) + apply (fastforce simp: equiv_fpu_state_def cur_fpu_for_def hw_fpu_def + split: option.splits if_splits) + apply (erule affects_equivE, clarsimp simp: equiv_fpu_def) + apply (insert equiv_dmo)[1] + apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or + simp: split_def split: prod.splits simp: equiv_for_def)[1] + apply (erule_tac x="?nlf st" in meta_allE) + apply (erule_tac x="?cvf st" in meta_allE) + apply (erule_tac x="?cff st" in meta_allE) + apply (drule_tac x=rv in spec, drule_tac x=rv' in spec) + apply clarsimp + apply (drule (1) bspec)+ + apply clarsimp + apply wp + apply wp + apply clarsimp + apply clarsimp + apply (clarsimp simp: equiv_valid_2_def in_monad) + apply (intro conjI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (frule (1) cur_vcpu_for_equiv) + apply (clarsimp simp: equiv_hyp_state_def) + apply (prop_tac "equiv_for (aag_can_read aag or aag_can_affect aag l) (K \ numlistregs) st t") + apply (simp add: equiv_hyp_def equiv_for_or reads_equiv_def2 affects_equiv_def2 states_equiv_for_def) + apply (prop_tac "equiv_for (aag_can_read aag or aag_can_affect aag l) hw_vcpu_of st t") + apply (simp add: equiv_hyp_def equiv_for_or reads_equiv_def2 affects_equiv_def2 states_equiv_for_def) + apply (case_tac "cur_vcpu_for (aag_can_read aag or aag_can_affect aag l) t"; clarsimp) + apply (clarsimp simp: cur_vcpu_for_def split: option.splits if_splits) + apply (erule equiv_forE)+ + apply (erule_tac x=aa in meta_allE, clarsimp)+ + apply (clarsimp simp: cur_vcpu_of_def hw_vcpu_def numlistregs_for_def split: if_splits) + apply (frule (1) cur_fpu_for_equiv) + apply (clarsimp simp: equiv_fpu_state_def) + apply (prop_tac "equiv_for ((aag_can_read aag or aag_can_affect aag l)) hw_fpu_of st t") + apply (simp add: equiv_fpu_def equiv_for_or reads_equiv_def2 affects_equiv_def2 states_equiv_for_def) + apply (fastforce simp: equiv_for_def hw_fpu_def cur_fpu_for_def split: if_splits) + apply (wp | simp add: guard)+ + using guard cur_fpu_for_equiv cur_vcpu_for_equiv numlistregs_for_equiv apply fastforce + done + +lemma do_machine_op_reads_respects'[InfoFlow_IF_assms]: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) + (equiv_machine_state (aag_can_affect aag l)) Q f" + assumes guard: "\s. P s \ Q (machine_state s)" + assumes no_hyp: "no_hyp f" + assumes no_fpu: "no_fpu f" + shows "reads_respects aag l P (do_machine_op f)" + apply (rule do_machine_op_reads_respects''[where Q="\_ _ _. Q"]) + apply (insert equiv_dmo no_hyp no_fpu) + apply (clarsimp simp: equiv_valid_2_def equiv_valid_def2 equiv_for_or no_hyp_def no_fpu_def + equiv_for_def split_def) + apply (rename_tac rv st rv' st') + apply (drule_tac x=s in spec, drule_tac x=t in spec) + apply clarsimp + apply (drule (1) bspec)+ + apply clarsimp + apply (rule conjI) + apply (clarsimp simp: equiv_hyp_state_def) + apply (erule use_valid, erule spec)+ + apply clarsimp + apply (clarsimp simp: equiv_fpu_state_def) + apply (erule use_valid, erule spec)+ + apply clarsimp + apply (simp add: guard) + done + +lemma equiv_hyp_state_upds[simp]: + "\f. equiv_hyp_state n cv ms (underlying_memory_update f ms') = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv (underlying_memory_update f ms) ms' = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv ms (device_state_update f ms') = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv (device_state_update f ms) ms' = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv ms (machine_state_rest_update f ms') = equiv_hyp_state n cv ms ms'" + "\f. equiv_hyp_state n cv (machine_state_rest_update f ms) ms' = equiv_hyp_state n cv ms ms'" + by (auto simp: equiv_hyp_state_def) + +lemma equiv_fpu_state_upds[simp]: + "\f. equiv_fpu_state cf ms (underlying_memory_update f ms') = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf (underlying_memory_update f ms) ms' = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf ms (device_state_update f ms') = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf (device_state_update f ms) ms' = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf ms (machine_state_rest_update f ms') = equiv_fpu_state cf ms ms'" + "\f. equiv_fpu_state cf (machine_state_rest_update f ms) ms' = equiv_fpu_state cf ms ms'" + by (auto simp: equiv_fpu_state_def) + +lemma no_hyp_bind: + "\ no_hyp f; \rv. no_hyp (g rv) \ \ no_hyp (f >>= g)" + unfolding no_hyp_def + by (wpsimp, blast+) + +lemma no_fpu_bind: + "\ no_fpu f; \rv. no_fpu (g rv) \ \ no_fpu (f >>= g)" + unfolding no_fpu_def + by (wpsimp, blast+) + +lemma equiv_hyp_state_lift[wp]: + assumes "\P. f \\s. P (vcpu_state s)\" + shows "f \equiv_hyp_state n cv st\" + unfolding equiv_hyp_state_def + by (wp assms) + +lemma equiv_fpu_state_lift[wp]: + assumes "\P. f \\s. P (fpu_state s)\" + shows "f \equiv_fpu_state cf st\" + unfolding equiv_fpu_state_def + by (wp assms) + +lemma no_hyp_lift[wp]: + assumes "\P. f \\s. P (vcpu_state s)\" + shows "no_hyp f" + using assms by (simp add: no_hyp_def) + +lemma no_fpu_lift[wp]: + assumes "\P. f \\s. P (fpu_state s)\" + shows "no_fpu f" + using assms by (simp add: no_fpu_def) + +end + +arch_requalify_consts + no_hyp no_fpu + + +global_interpretation InfoFlow_IF_2?: InfoFlow_IF_2 identical_hyp_state_updates identical_fpu_state_updates no_hyp no_fpu +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact InfoFlow_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchInterrupt_IF.thy b/proof/infoflow/AARCH64/ArchInterrupt_IF.thy new file mode 100644 index 0000000000..1862a1affd --- /dev/null +++ b/proof/infoflow/AARCH64/ArchInterrupt_IF.thy @@ -0,0 +1,62 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchInterrupt_IF +imports Interrupt_IF +begin + +context Arch begin arch_global_naming + +named_theorems Interrupt_IF_assms + +lemma arch_invoke_irq_handler_reads_respects[Interrupt_IF_assms, wp]: + "reads_respects_f aag l (silc_inv aag st) (arch_invoke_irq_handler irq)" + apply (cases irq) + apply (wpsimp simp: deactivateInterrupt_def maskInterrupt_def) + apply (rule reads_respects_f[where P=\ and Q=\, simplified]) + apply (rule do_machine_op_reads_respects) + apply (simp add: equiv_valid_def2) + apply (rule modify_ev2) + apply (fastforce simp: equiv_for_def) + apply wpsimp+ + done + +lemma arch_invoke_irq_control_reads_respects[Interrupt_IF_assms]: + "reads_respects aag (l :: 'a subject_label) (K (arch_authorised_irq_ctl_inv aag i)) + (arch_invoke_irq_control i)" + apply (cases i) + apply (simp add: setIRQTrigger_def) + apply (wp cap_insert_reads_respects set_irq_state_reads_respects dmo_mol_reads_respects | simp)+ + apply (clarsimp simp: arch_authorised_irq_ctl_inv_def) + apply (wpsimp wp: equiv_valid_guard_imp[OF cap_insert_reads_respects]) + apply (clarsimp simp: arch_authorised_irq_ctl_inv_def) + done + +lemma arch_invoke_irq_control_globals_equiv[Interrupt_IF_assms]: + "\globals_equiv st and valid_arch_state\ + arch_invoke_irq_control ai + \\_. globals_equiv st\" + apply (induct ai) + apply (simp add: setIRQTrigger_def) + apply (wpsimp wp: set_irq_state_globals_equiv set_irq_state_valid_global_objs + cap_insert_globals_equiv dmo_mol_globals_equiv)+ + done + +lemma arch_invoke_irq_handler_globals_equiv[Interrupt_IF_assms, wp]: + "arch_invoke_irq_handler irq \globals_equiv st\" + by (cases irq; wpsimp wp: dmo_no_mem_globals_equiv simp: deactivateInterrupt_def) + +end + + +global_interpretation Interrupt_IF_1?: Interrupt_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Interrupt_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchIpc_IF.thy b/proof/infoflow/AARCH64/ArchIpc_IF.thy new file mode 100644 index 0000000000..8da6ab896d --- /dev/null +++ b/proof/infoflow/AARCH64/ArchIpc_IF.thy @@ -0,0 +1,479 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchIpc_IF +imports Ipc_IF +begin + +context Arch begin arch_global_naming + +named_theorems Ipc_IF_assms + +lemma lookup_ipc_buffer_reads_respects[Ipc_IF_assms]: + "reads_respects aag l (K (aag_can_read aag thread \ aag_can_affect aag l thread)) + (lookup_ipc_buffer is_receiver thread)" + unfolding lookup_ipc_buffer_def + by (wp thread_get_reads_respects get_cap_reads_respects | wpc | simp)+ + +lemma as_user_equiv_but_for_labels[Ipc_IF_assms]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag thread \ L)\ + as_user thread f + \\_. equiv_but_for_labels aag L st\" + unfolding as_user_def + apply (wp set_object_equiv_but_for_labels | simp add: split_def)+ + apply (blast dest: get_tcb_not_asid_pool_at) + done + +lemma storeWord_equiv_but_for_labels[Ipc_IF_assms]: + "\\ms. equiv_but_for_labels aag L st (s\machine_state := ms\) \ + for_each_byte_of_word (\x. pasObjectAbs aag x \ L) p\ + storeWord p v + \\_ ms. equiv_but_for_labels aag L st (s\machine_state := ms\)\" + unfolding storeWord_def + apply (wp modify_wp) + apply (clarsimp simp: equiv_but_for_labels_def) + apply (rule states_equiv_forI) + apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD) + apply (simp add: states_equiv_for_def) + apply (rule conjI) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=underlying_memory in equiv_forD,fastforce) + apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right + simp: is_aligned_mask for_each_byte_of_word_def word_size_def upto.simps) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=device_state in equiv_forD,fastforce) + apply clarsimp + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) + apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply (fastforce simp: equiv_hyp_def equiv_for_def elim: states_equiv_forE) + apply (fastforce simp: equiv_fpu_def equiv_for_def cur_fpu_for_def elim: states_equiv_forE) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=ready_queues]) + done + +lemma set_thread_state_runnable_equiv_but_for_labels[Ipc_IF_assms]: + "runnable tst + \ \equiv_but_for_labels aag L st and K (pasObjectAbs aag thread \ L)\ + set_thread_state thread tst + \\_. equiv_but_for_labels aag L st\" + unfolding set_thread_state_def + apply (wpsimp wp: set_object_equiv_but_for_labels[THEN hoare_set_object_weaken_pre] + set_thread_state_act_runnable_equiv_but_for_labels) + apply (wpsimp wp: set_object_wp)+ + apply (fastforce dest: get_tcb_not_asid_pool_at simp: st_tcb_at_def obj_at_def) + done + +lemma set_endpoint_equiv_but_for_labels[Ipc_IF_assms]: + "\equiv_but_for_labels aag L st and K (pasObjectAbs aag epptr \ L)\ + set_endpoint epptr ep + \\_. equiv_but_for_labels aag L st\" + unfolding set_simple_ko_def + apply (wp set_object_equiv_but_for_labels get_object_wp) + apply (clarsimp simp: asid_pool_at_kheap partial_inv_def obj_at_def split: kernel_object.splits) + done + +(* FIXME move *) +lemma conj_imp: + "\ Q \ R; P \ Q; P' \ Q \ \ (P \ R) \ (P' \ R)" + by fastforce + +(* basically clagged directly from lookup_ipc_buffer_has_auth *) +lemma lookup_ipc_buffer_has_read_auth[Ipc_IF_assms]: + "\pas_refined aag and valid_objs\ + lookup_ipc_buffer is_receiver thread + \\rv s. ipc_buffer_has_read_auth aag (pasObjectAbs aag thread) rv\" + apply (rule hoare_pre) + apply (simp add: lookup_ipc_buffer_def) + apply (wp get_cap_wp thread_get_wp' | wpc)+ + apply (clarsimp simp: cte_wp_at_caps_of_state ipc_buffer_has_read_auth_def get_tcb_ko_at[symmetric]) + apply (frule caps_of_state_tcb_cap_cases [where idx = "tcb_cnode_index 4"]) + apply (simp add: dom_tcb_cap_cases) + apply (frule (1) caps_of_state_valid_cap) + apply (clarsimp simp: vm_read_only_def vm_read_write_def) + apply (rule_tac Q="AllowRead \ xb" in conj_imp) + apply (clarsimp simp: valid_cap_simps cap_aligned_def) + apply (rule conjI) + apply (erule aligned_add_aligned) + apply (rule is_aligned_andI1) + apply (drule (1) valid_tcb_objs) + apply (clarsimp simp: valid_obj_def valid_tcb_def valid_ipc_buffer_cap_def + split: if_splits) + apply (rule order_trans [OF _ pbfs_atleast_pageBits]) + apply (simp add: msg_align_bits pageBits_def) + apply (drule (1) cap_auth_caps_of_state) + apply (clarsimp simp: aag_cap_auth_def cap_auth_conferred_def arch_cap_auth_conferred_def + vspace_cap_rights_to_auth_def vm_read_only_def) + apply (drule bspec) + apply (erule (3) ipcframe_subset_page) + apply (simp_all) + done + +lemma cptrs_in_ipc_buffer[Ipc_IF_assms]: + "\ n \ set [buffer_cptr_index ..< buffer_cptr_index + unat (mi_extra_caps mi)]; + is_aligned (p :: obj_ref) msg_align_bits; + buffer_cptr_index + unat (mi_extra_caps mi) < 2 ^ (msg_align_bits - word_size_bits) \ + \ ptr_range (p + of_nat n * of_nat word_size) word_size_bits \ ptr_range p msg_align_bits" + apply (rule ptr_range_subset) + apply assumption + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits' word_size_bits_def word_bits_def) + apply (simp add: word_size_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits' word_bits_def word_size_bits_def)+ + done + +lemma msg_in_ipc_buffer[Ipc_IF_assms]: + "\ n = msg_max_length \ n < msg_max_length; is_aligned p msg_align_bits; + unat (mi_length mi) < 2 ^ (msg_align_bits - word_size_bits) \ + \ ptr_range (p + of_nat n * of_nat word_size) word_size_bits + \ ptr_range (p :: obj_ref) msg_align_bits" + apply (rule ptr_range_subset) + apply assumption + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits word_bits_def) + apply (simp add: word_size_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits word_bits_def)+ + apply (simp add: image_def) + apply (rule_tac x=n in bexI) + apply (rule refl) + apply (auto simp: msg_max_length_def) + done + +lemma arch_derive_cap_reads_respects[Ipc_IF_assms]: + "reads_respects aag l \ (arch_derive_cap cap)" + unfolding arch_derive_cap_def fun_app_def + apply (rule equiv_valid_guard_imp) + apply (wp | wpc)+ + apply (simp) + done + +lemma arch_derive_cap_rev[Ipc_IF_assms]: + "reads_equiv_valid_inv aag l \ (arch_derive_cap cap)" + unfolding arch_derive_cap_def fun_app_def + apply (rule equiv_valid_guard_imp) + apply (wp | wpc)+ + apply (simp) + done + +lemma captransfer_in_ipc_buffer[Ipc_IF_assms]: + "\ is_aligned (buf :: obj_ref) msg_align_bits; n \ {0..2} \ + \ ptr_range (buf + (2 + (of_nat msg_max_length + of_nat msg_max_extra_caps)) * word_size + + n * word_size) + word_size_bits + \ ptr_range buf msg_align_bits" + apply (rule ptr_range_subset) + apply assumption + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits word_bits_def) + apply (simp add: word_size_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits word_bits_def)+ + apply (simp add: image_def msg_max_length_def msg_max_extra_caps_def) + apply (rule_tac x="(125::nat) + unat n" in bexI) + apply simp+ + apply (fastforce intro: unat_less_helper word_leq_minus_one_le) + done + +lemma mrs_in_ipc_buffer[Ipc_IF_assms]: + "\ n \ set [length msg_registers + 1 ..< Suc n']; + is_aligned (buf :: obj_ref) msg_align_bits; n' < 2 ^ (msg_align_bits - word_size_bits) \ + \ ptr_range (buf + of_nat n * of_nat word_size) word_size_bits \ ptr_range buf msg_align_bits" + apply (rule ptr_range_subset) + apply assumption + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits word_bits_def) + apply (simp add: word_size_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits word_bits_def word_size_bits_def)+ + apply (simp add: image_def) + apply (rule_tac x=n in bexI) + apply (rule refl) + apply (fastforce split: if_split_asm) + done + +lemma dmo_loadWord_reads_respects[Ipc_IF_assms]: + "reads_respects aag l (K (for_each_byte_of_word (\ x. aag_can_read_or_affect aag l x) p)) + (do_machine_op (loadWord p))" + apply (rule gen_asm_ev) + apply (rule do_machine_op_reads_respects) + apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) + apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" + and Q="\\" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule_tac R'="(=)" and Q="\ r s. p && mask 3 = 0" and Q'="\ r s. p && mask 3 = 0" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule return_ev2) + apply (rule_tac f="word_rcat" in arg_cong) + apply (fastforce simp: upto.simps is_aligned_mask for_each_byte_of_word_def word_size_def + intro: is_aligned_no_wrap' word_plus_mono_right) + apply (rule assert_ev2[OF refl]) + apply (rule assert_wp)+ + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad for_each_byte_of_word_def) + apply (fastforce elim: equiv_forD orthD1 simp: ptr_range_def add.commute) + apply (wp wp_post_taut loadWord_inv | simp)+ + done + +lemma complete_signal_reads_respects[Ipc_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects aag l (K (aag_can_read aag ntfnptr \ aag_can_affect aag l ntfnptr)) + (complete_signal ntfnptr receiver)" + unfolding complete_signal_def + by (wp set_simple_ko_reads_respects get_simple_ko_reads_respects as_user_set_register_reads_respects' + | wpc | simp)+ + +lemma handle_arch_fault_reply_reads_respects[Ipc_IF_assms, wp]: + "reads_respects aag l (K (aag_can_read aag thread)) (handle_arch_fault_reply afault thread x y)" + by (simp add: handle_arch_fault_reply_def, wp) + +lemma arch_thread_get_reads_respects[wp]: + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (arch_thread_get f t)" + unfolding arch_thread_get_def + apply (wpsimp) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE simp: get_tcb_def split: option.splits) + done + +lemma arch_get_sanitise_register_info_reads_respects[Ipc_IF_assms, wp]: + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (arch_get_sanitise_register_info t)" + by wpsimp + +declare arch_get_sanitise_register_info_inv[Ipc_IF_assms] + +lemma lookup_ipc_buffer_ptr_range'[Ipc_IF_assms]: + "\valid_objs\ + lookup_ipc_buffer True thread + \\rv s. rv = Some buf' \ auth_ipc_buffers s thread = ptr_range buf' msg_align_bits\" + unfolding lookup_ipc_buffer_def + apply (rule hoare_pre) + apply (wp get_cap_wp thread_get_wp' | wpc)+ + apply (clarsimp simp: cte_wp_at_caps_of_state ipc_buffer_has_auth_def get_tcb_ko_at [symmetric]) + apply (frule caps_of_state_tcb_cap_cases [where idx = "tcb_cnode_index 4"]) + apply (simp add: dom_tcb_cap_cases) + apply (clarsimp simp: auth_ipc_buffers_def get_tcb_ko_at [symmetric]) + apply (drule(1) valid_tcb_objs) + apply (drule get_tcb_SomeD)+ + apply (simp add: vm_read_write_def valid_tcb_def valid_ipc_buffer_cap_def split: bool.splits) + done + +lemma lookup_ipc_buffer_aligned'[Ipc_IF_assms]: + "\valid_objs\ + lookup_ipc_buffer True thread + \\rv s. rv = Some buf' \ is_aligned buf' msg_align_bits\" + apply (insert lookup_ipc_buffer_aligned) + apply (fastforce simp: valid_def) + done + +lemma handle_arch_fault_reply_globals_equiv[Ipc_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. thread \ idle_thread s)\ + handle_arch_fault_reply vmf thread x y + \\_. globals_equiv st\" + by (wpsimp simp: handle_arch_fault_reply_def)+ + +crunch arch_get_sanitise_register_info, handle_arch_fault_reply + for valid_global_objs[Ipc_IF_assms, wp]: "valid_global_objs" + +crunch handle_arch_fault_reply + for valid_arch_state[Ipc_IF_assms,wp]: "\s :: det_state. valid_arch_state s" + +lemma transfer_caps_loop_valid_arch[Ipc_IF_assms]: + "transfer_caps_loop ep buffer n caps slots mi \valid_arch_state :: det_ext state \ _\" + by (wp valid_arch_state_lift_aobj_at_no_caps transfer_caps_loop_aobj_at) + +end + + +global_interpretation Ipc_IF_1?: Ipc_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Ipc_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma copy_mrs_reads_respects[Ipc_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag (l :: 'a subject_label) + (K (aag_can_read_or_affect aag l sender \ aag_can_read_or_affect_ipc_buffer aag l sbuf + \ unat n < 2 ^ (msg_align_bits - word_size_bits))) + (copy_mrs sender sbuf receiver rbuf n)" + unfolding copy_mrs_def fun_app_def + apply (rule gen_asm_ev) + apply (wp mapM_ev'' store_word_offs_reads_respects load_word_offs_reads_respects + as_user_set_register_reads_respects' as_user_reads_respects + | wpc + | simp add: det_setRegister det_getRegister split del: if_split)+ + apply clarsimp + apply (rename_tac n') + apply (subgoal_tac "ptr_range (x + of_nat n' * of_nat word_size) word_size_bits + \ ptr_range x msg_align_bits") + apply (simp add: for_each_byte_of_word_def2) + apply (simp add: aag_can_read_or_affect_ipc_buffer_def) + apply (erule conjE) + apply (rule ballI) + apply (erule bspec) + apply (erule (1) subsetD[rotated]) + apply (rule ptr_range_subset) + apply (simp add: aag_can_read_or_affect_ipc_buffer_def) + apply (simp add: msg_align_bits') + apply (simp add: msg_align_bits word_bits_def) + apply (simp add: word_size_def word_size_bits_def) + apply (subst upto_enum_step_shift_red[where us=3, simplified]) + apply (simp add: msg_align_bits word_bits_def aag_can_read_or_affect_ipc_buffer_def)+ + apply (fastforce simp: image_def) + done + +lemma get_message_info_reads_respects[Ipc_IF_assms]: + "reads_respects aag (l :: 'a subject_label) (K (aag_can_read_or_affect aag l ptr)) (get_message_info ptr)" + apply (simp add: get_message_info_def) + apply (wp as_user_reads_respects | clarsimp simp: getRegister_def)+ + done + +lemma do_normal_transfer_reads_respects[Ipc_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag (l :: 'a subject_label) + (pas_refined aag and valid_mdb and valid_objs + and K (aag_can_read_or_affect aag l sender \ + ipc_buffer_has_read_auth aag (pasObjectAbs aag sender) sbuf \ + ipc_buffer_has_read_auth aag (pasObjectAbs aag receiver) rbuf \ + (grant \ (is_subject aag sender \ is_subject aag receiver)))) + (do_normal_transfer sender sbuf endpoint badge grant receiver rbuf)" + apply (cases grant) + apply (rule gen_asm_ev) + apply (simp add: do_normal_transfer_def) + apply (wp copy_mrs_pas_refined get_message_info_rev lookup_extra_caps_rev + as_user_set_register_reads_respects' set_message_info_reads_respects + transfer_caps_reads_respects copy_mrs_reads_respects lookup_extra_caps_rev + lookup_extra_caps_authorised lookup_extra_caps_auth get_message_info_rev + get_mi_length' get_mi_length validE_E_wp_post_taut + copy_mrs_cte_wp_at hoare_vcg_ball_lift lec_valid_cap' + lookup_extra_caps_srcs[simplified ball_conj_distrib,THEN hoare_conjDR1] + lookup_extra_caps_srcs[simplified ball_conj_distrib,THEN hoare_conjDR2] + | wpc + | simp add: det_setRegister ball_conj_distrib)+ + apply (fastforce intro: aag_has_read_auth_can_read_or_affect_ipc_buffer) + apply (rule gen_asm_ev) + apply (simp add: do_normal_transfer_def transfer_caps_def) + apply (wp ev_irrelevant_bind[where f="get_receive_slots receiver rbuf"] + as_user_set_register_reads_respects' + set_message_info_reads_respects copy_mrs_reads_respects + get_message_info_reads_respects get_mi_length + | wpc + | simp)+ + apply (auto simp: ipc_buffer_has_read_auth_def aag_can_read_or_affect_ipc_buffer_def + dest: reads_read_thread_read_pages split: option.splits) + done + +lemma make_arch_fault_msg_reads_respects[Ipc_IF_assms]: + "reads_respects aag (l :: 'a subject_label) (\y. aag_can_read_or_affect aag l sender) + (make_arch_fault_msg x4 sender)" + apply (case_tac x4) + apply (wp as_user_reads_respects | simp add: det_getRegister det_getRestartPC)+ + done + +lemma set_mrs_equiv_but_for_labels[Ipc_IF_assms]: + "\equiv_but_for_labels (aag :: 'a subject_label PAS) L st and + K (pasObjectAbs aag thread \ L \ + (case buf of (Some buf') \ is_aligned buf' msg_align_bits \ + (\x \ ptr_range buf' msg_align_bits. pasObjectAbs aag x \ L) + | _ \ True))\ + set_mrs thread buf msgs + \\_. equiv_but_for_labels aag L st\" + unfolding set_mrs_def + apply (wp | wpc)+ + apply (subst zipWithM_x_mapM_x) + apply (rule_tac Q'="\_. equiv_but_for_labels aag L st and K (pasObjectAbs aag thread \ L \ + (case buf of (Some buf') \ is_aligned buf' msg_align_bits \ + (\x \ ptr_range buf' msg_align_bits. + pasObjectAbs aag x \ L) + | _ \ True))" in hoare_strengthen_post) + apply (wp mapM_x_wp' store_word_offs_equiv_but_for_labels | simp add: split_def)+ + apply (case_tac x, clarsimp split: if_split_asm elim!: in_set_zipE) + apply (clarsimp simp: for_each_byte_of_word_def) + apply (erule bspec) + apply (clarsimp simp: ptr_range_def) + apply (rule conjI) + apply (erule order_trans[rotated]) + apply (erule is_aligned_no_wrap') + apply (rule mul_word_size_lt_msg_align_bits_ofnat) + apply (fastforce simp: msg_max_length_def msg_align_bits') + apply (erule order_trans) + apply (subst p_assoc_help) + apply (simp add: add.assoc) + apply (rule word_plus_mono_right) + apply (rule word_less_sub_1) + apply (rule_tac y="of_nat msg_max_length * of_nat word_size + (word_size - 1)" + in le_less_trans) + apply (rule word_plus_mono_left) + apply (rule word_mult_le_mono1) + apply (erule disjE) + apply (rule word_of_nat_le) + apply (simp add: msg_max_length_def) + apply clarsimp + apply (rule word_of_nat_le) + apply (simp add: msg_max_length_def) + apply (simp add: word_size_def) + apply (simp add: msg_max_length_def word_size_def) + apply (simp add: msg_max_length_def word_size_def) + apply (rule mul_add_word_size_lt_msg_align_bits_ofnat) + apply (simp add: msg_max_length_def msg_align_bits') + apply (simp add: word_size_def) + apply (erule is_aligned_no_overflow') + apply simp + apply (wp set_object_equiv_but_for_labels hoare_vcg_all_lift hoare_weak_lift_imp | simp)+ + apply (fastforce dest: get_tcb_not_asid_pool_at)+ + done + +lemma set_mrs_reads_respects'[Ipc_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "reads_respects aag (l :: 'a subject_label) + (K (ipc_buffer_has_auth aag thread buf \ + (case buf of (Some buf') \ is_aligned buf' msg_align_bits | _ \ True))) + (set_mrs thread buf msgs)" + apply (case_tac "aag_can_read_or_affect aag l thread") + apply ((wp equiv_valid_guard_imp[OF set_mrs_reads_respects] | simp)+)[1] + apply (rule gen_asm_ev) + apply (simp add: equiv_valid_def2) + apply (rule equiv_valid_rv_guard_imp) + apply (case_tac buf) + apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in revrv_invisible[OF domains_distinct]) + apply (clarsimp simp: labels_are_invisible_def) + apply (rule modifies_at_mostI) + apply (simp add: set_mrs_def) + apply ((wp set_object_equiv_but_for_labels | simp | auto dest: get_tcb_not_asid_pool_at)+)[1] + apply (simp) + apply (rule set_mrs_ret_eq) + apply (rename_tac buf') + apply (rule_tac Q="\" and L="{pasObjectAbs aag thread} \ (pasObjectAbs aag) + ` (ptr_range buf' msg_align_bits)" + in revrv_invisible[OF domains_distinct]) + apply (auto simp: labels_are_invisible_def ipc_buffer_has_auth_def + dest: reads_read_page_read_thread simp: aag_can_affect_label_def)[1] + apply (rule modifies_at_mostI) + apply (wp set_mrs_equiv_but_for_labels | simp)+ + apply (rule set_mrs_ret_eq) + by simp + +end + + +global_interpretation Ipc_IF_2?: Ipc_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Ipc_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchNoninterference.thy b/proof/infoflow/AARCH64/ArchNoninterference.thy new file mode 100644 index 0000000000..4fd3011b5b --- /dev/null +++ b/proof/infoflow/AARCH64/ArchNoninterference.thy @@ -0,0 +1,816 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchNoninterference +imports Noninterference +begin + +context Arch begin arch_global_naming + +named_theorems Noninterference_assms + +(* clagged straight from ADT_AC.do_user_op_respects *) +lemma do_user_op_if_integrity[Noninterference_assms]: + "\invs and integrity aag X st and is_subject aag \ cur_thread and pas_refined aag\ + do_user_op_if uop tc + \\_. integrity aag X st\" + apply (simp add: do_user_op_if_def) + apply (wpsimp wp: dmo_user_memory_update_respects_Write dmo_device_update_respects_Write + hoare_vcg_all_lift hoare_vcg_imp_lift + wp_del: select_wp) + apply (rule hoare_pre_cont) + apply (wp | wpc | clarsimp)+ + apply (rule conjI) + apply clarsimp + apply (simp add: restrict_map_def ptable_lift_s_def ptable_rights_s_def split: if_splits) + apply (drule_tac auth=Write in user_op_access') + apply (simp add: vspace_cap_rights_to_auth_def)+ + apply clarsimp + apply (simp add: restrict_map_def ptable_lift_s_def ptable_rights_s_def split: if_splits) + apply (drule_tac auth=Write in user_op_access') + apply (simp add: vspace_cap_rights_to_auth_def)+ + done + +lemma do_user_op_if_globals_equiv_scheduler[Noninterference_assms]: + "\globals_equiv_scheduler st and invs\ + do_user_op_if tc uop + \\_. globals_equiv_scheduler st\" + apply (simp add: do_user_op_if_def) + apply (wpsimp wp: dmo_user_memory_update_globals_equiv_scheduler + dmo_device_memory_update_globals_equiv_scheduler)+ + apply (auto simp: ptable_lift_s_def ptable_rights_s_def) + done + +crunch do_user_op_if + for silc_dom_equiv[Noninterference_assms, wp]: "silc_dom_equiv aag st" + (ignore: do_machine_op user_memory_update wp: crunch_wps) + +lemma sameFor_scheduler_affects_equiv[Noninterference_assms]: + "\ (s,s') \ same_for aag PSched; (s,s') \ same_for aag (Partition l); + invs (internal_state_if s); invs (internal_state_if s') \ + \ scheduler_equiv aag (internal_state_if s) (internal_state_if s') \ + scheduler_affects_equiv aag (OrdinaryLabel l) (internal_state_if s) (internal_state_if s')" + apply (rule conjI) + apply (blast intro: sameFor_scheduler_equiv) + apply (clarsimp simp: scheduler_affects_equiv_def arch_scheduler_affects_equiv_def + sameFor_def silc_dom_equiv_def reads_scheduler_def sameFor_scheduler_def) + (* simplifying using sameFor_subject_def in assumptions causes simp to loop *) + apply (simp (no_asm_use) add: sameFor_subject_def disjoint_iff_not_equal Bex_def) + apply (blast intro: globals_equiv_to_scheduler_globals_frame_equiv globals_equiv_to_cur_thread_eq) + done + +lemma do_user_op_if_partitionIntegrity[Noninterference_assms]: + "\partitionIntegrity aag st and pas_refined aag and invs and is_subject aag \ cur_thread\ + do_user_op_if tc uop + \\_. partitionIntegrity aag st\" + apply (rule_tac Q'="\rv s. integrity (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + (scheduler_affects_globals_frame st) st s \ + domain_fields_equiv st s \ idle_thread s = idle_thread st \ + globals_equiv_scheduler st s \ silc_dom_equiv aag st s" + in hoare_strengthen_post) + apply (wpsimp wp: do_user_op_if_globals_equiv_scheduler + do_user_op_if_integrity domain_fields_equiv_lift) + apply (auto simp: partitionIntegrity_def) + done + +lemma arch_activate_idle_thread_reads_respects_g[Noninterference_assms, wp]: + "reads_respects_g aag l \ (arch_activate_idle_thread t)" + unfolding arch_activate_idle_thread_def by wpsimp + +crunch handle_spurious_irq + for domain[wp]: "\s. Q (domain_time s) (domain_index s) (domain_list s)" + and irq_state_of_state[wp]: "\s. P (irq_state_of_state s)" + +lemma handle_spurious_irq_reads_respect_scheduler[Noninterference_assms]: + "reads_respects_scheduler aag l \ handle_spurious_irq" + unfolding handle_spurious_irq_def + by wpsimp + +definition arch_globals_equiv_strengthener :: "machine_state \ machine_state \ bool" where + "arch_globals_equiv_strengthener ms ms' \ True" + +declare arch_globals_equiv_strengthener_def[simp] + +lemma arch_globals_equiv_strengthener_thread_independent[Noninterference_assms]: + "arch_globals_equiv_strengthener (machine_state s) (machine_state s') + \ \ct ct' it it'. arch_globals_equiv ct it (kheap s) (kheap s') + (arch_state s) (arch_state s') (machine_state s) (machine_state s') = + arch_globals_equiv ct' it' (kheap s) (kheap s') + (arch_state s) (arch_state s') (machine_state s) (machine_state s')" + by auto + +lemma integrity_asids_update_reference_state[Noninterference_assms]: + "is_subject aag t + \ integrity_asids aag {pasSubject aag} x a s (s\kheap := (kheap s)(t \ blah)\)" + by (clarsimp simp: integrity_asids_def opt_map_def) + +lemma partitionIntegrity_cur_vcpu_None: + "\ partitionIntegrity aag s s'; valid_objs s; valid_objs s'; + cur_vcpu_of s x = None; cur_vcpu_of s' x = None; vcpu_at x s \ + \ is_subject aag x \ kheap s x = kheap s' x" + apply (prop_tac "integrity_obj (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + False {pasSubject aag} (pasObjectAbs aag x) (kheap s x) (kheap s' x)") + apply (clarsimp simp: partitionIntegrity_def integrity_subjects_def) + apply (prop_tac "integrity_hyp (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} x s s'") + apply (clarsimp simp: partitionIntegrity_def integrity_subjects_def) + apply (rule disjCI2) + apply (drule tro_tro_alt) + apply (clarsimp simp: obj_at_def) + apply (erule integrity_obj_alt.cases; clarsimp) + apply (erule arch_integrity_obj_alt.cases; clarsimp) + apply (rename_tac vcpu vcpu') + apply (prop_tac "valid_vcpu vcpu s") + apply (erule valid_objsE, simp, fastforce simp: valid_obj_def) + apply (prop_tac "valid_vcpu vcpu' s'") + apply (erule valid_objsE, simp, fastforce simp: valid_obj_def) + apply (prop_tac "vcpus_of s x = Some vcpu") + apply (clarsimp simp: opt_map_def) + apply (prop_tac "vcpus_of s' x = Some vcpu'") + apply (clarsimp simp: opt_map_def) + apply (prop_tac "integrity_obj (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) False + {pasSubject aag} (pasObjectAbs aag x) (kheap s x) (kheap s' x)") + apply (thin_tac "kheap _ x = _")+ + apply (clarsimp simp: partitionIntegrity_def integrity_subjects_def) + apply (erule integrity_objE; fastforce?) + apply (erule arch_integrity_obj_alt.cases; fastforce?) + apply clarsimp + apply (clarsimp simp: integrity_hyp_def vcpu_integrity_def vcpu_extra_lrs_def vcpu_of_state_def) + apply (case_tac vcpu; case_tac vcpu'; clarsimp) + apply (case_tac vcpu_vgic; case_tac vcpu_vgica; clarsimp) + apply (rule ext) + apply (drule_tac x=xa in fun_cong)+ + apply (auto split: if_splits) + done + +lemma partitionIntegrity_cur_vcpu_Some: + "\ invs s; pas_refined aag s; pas_cur_domain aag s; pas_domains_distinct aag; + cur_vcpu_in_cur_domain s; current_vcpu s = Some (vr,b) \ + \ is_subject aag vr" + apply (clarsimp simp: cur_vcpu_in_cur_domain_def cur_vcpu_tcb_def split: option.splits) + defer + apply (rename_tac t) + apply (prop_tac "is_subject aag vr") + apply (prop_tac "\tcb. ko_at (TCB tcb) t s") + apply (prop_tac "valid_objs s") + apply fastforce + apply (clarsimp simp: opt_map_def split: option.splits) + apply (erule (1) valid_objsE) + apply (clarsimp simp: valid_obj_def valid_vcpu_def obj_at_def) + apply (prop_tac "is_subject aag t") + apply clarsimp + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply simp + apply (prop_tac "pasDomainAbs aag (cur_domain s) = {pasSubject aag}") + apply (clarsimp simp: pas_domains_distinct_def) + apply (metis singletonD) + apply blast + apply clarsimp + apply (clarsimp simp: opt_map_def split: option.splits) + apply (prop_tac "sym_refs (state_hyp_refs_of s)") + apply fastforce + apply (drule_tac x=vr in sym_refsD[rotated]) + apply (simp add: state_hyp_refs_of_def) + apply (clarsimp simp: state_hyp_refs_of_def hyp_refs_of_def obj_at_def tcb_vcpu_refs_def split: option.splits) + apply (erule associated_vcpu_is_subject) + apply (simp add: get_tcb_Some_ko_at obj_at_def) + apply simp+ + apply (prop_tac "cur_vcpu s") + apply (prop_tac "valid_arch_state s") + apply fastforce + apply (clarsimp simp: valid_arch_state_def) + apply (clarsimp simp: cur_vcpu_def opt_map_def opt_pred_def) + done + +lemma cur_vcpu_of_Some: + "cur_vcpu_of s vr = Some b \ current_vcpu s = Some (vr,b)" + by (auto simp: cur_vcpu_of_def split: option.splits) + +lemma partitionIntegrity_subjectAffects_vcpu: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (ArchObj (VCPU vcpu))" + and kh_neq: "kheap s x \ kheap s' x" + and "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_vcpu_in_cur_domain s" "cur_vcpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" + apply (rule ssubst[where s="pasSubject aag", OF _ affects_lrefl]) + apply (case_tac "cur_vcpu_of s x = None \ cur_vcpu_of s' x = None"; clarsimp) + apply (drule (1) partitionIntegrity_cur_vcpu_None[OF par_inte, rotated 2]) + apply (simp_all add: assms obj_at_def invs_valid_objs)[3] + apply (fastforce simp: kh_neq) + apply (elim disjE; clarsimp; rule partitionIntegrity_cur_vcpu_Some + ; simp add: assms cur_vcpu_of_Some pas_wellformed_noninterference_domains_distinct) + done + +lemma inte_obj_arch: + assumes inte_obj: "(integrity_obj_atomic aag activate subjects l)\<^sup>*\<^sup>* ko ko'" + assumes "ko = Some (ArchObj ao)" + assumes "ko \ ko'" + shows "integrity_obj_atomic aag activate subjects l ko ko'" +proof (cases "l \ subjects") + case True + then show ?thesis by (fastforce intro: integrity_obj_atomic.intros) +next + case False + note l = this + have "\ao'. ko = Some (ArchObj ao) \ + ko \ ko' \ + integrity_obj_atomic aag activate subjects l ko ko'" + using inte_obj + proof (induct rule: rtranclp_induct) + case base + then show ?case by clarsimp + next + case (step y z) + have "\ao'. ko' = Some (ArchObj ao')" + using False inte_obj assms + by (auto elim!: rtranclp_induct integrity_obj_atomic.cases) + then show ?case using step.hyps + by (fastforce intro: arch_integrity_obj_atomic.intros integrity_obj_atomic.intros + elim!: integrity_obj_atomic.cases arch_integrity_obj_atomic.cases) + qed + then show ?thesis + using assms by fastforce +qed + +lemma asid_pool_into_aag: + "\ pool_for_asid asid s = Some p; kheap s p = Some (ArchObj (ASIDPool pool)); + pool r = Some entry; ap_vspace entry = p'; pas_refined aag s \ + \ abs_has_auth_to aag Control p p'" + apply (rule pas_refined_mem [rotated], assumption) + apply (rule sta_vref) + apply (rule state_vrefsD) + apply (erule pool_for_asid_vs_lookupD) + apply (fastforce simp: opt_map_def) + apply fastforce + apply (fastforce simp: vs_refs_aux_def graph_of_def image_iff) + done + +lemma owns_mapping_owns_asidpool: + "\ pool_for_asid asid s = Some p; kheap s p = Some (ArchObj (ASIDPool pool)); + pool r = Some entry; ap_vspace entry = p'; pas_refined aag s; is_subject aag p'; + pas_wellformed (aag\pasSubject := (pasObjectAbs aag p)\) \ + \ is_subject aag p" + apply (frule asid_pool_into_aag) + apply assumption+ + apply (drule pas_wellformed_pasSubject_update_Control) + apply assumption + apply simp + done + +lemma partitionIntegrity_subjectAffects_asid_pool': + "\ pool_for_asid asid s = Some x; kheap s x = Some (ArchObj ao); ao \ ao'; + pas_refined aag s; silc_inv aag st s; pas_wellformed_noninterference aag; valid_arch_state s; + arch_integrity_obj_atomic (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} (pasObjectAbs aag x) ao ao' \ + \ subject_can_affect_label_directly aag (pasObjectAbs aag x)" + unfolding arch_integrity_obj_atomic.simps asid_pool_integrity_def + apply (elim disjE) + apply clarsimp + apply (rule ccontr) + apply (drule fun_noteqD) + apply (erule exE, rename_tac r) + apply (drule_tac x=r in spec) + apply (clarsimp dest!: not_sym[where t=None]) + apply (subgoal_tac "is_subject aag x", force intro: affects_lrefl) + apply (frule (1) aag_Control_into_owns) + apply (frule (2) asid_pool_into_aag) + apply simp + apply simp + apply (frule (1) pas_wellformed_noninterference_control_to_eq) + apply (fastforce elim!: silc_inv_cnode_onlyE obj_atE simp: is_cap_table_def) + apply clarsimp + apply clarsimp + apply (drule (1) pool_for_asid_ap_at) + apply (clarsimp simp: obj_at_def) + done + +lemma partitionIntegrity_subjectAffects_asid_pool: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (ArchObj (ASIDPool pool))" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_refined aag s" + "valid_arch_state s" + "pas_wellformed_noninterference aag" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" +proof (cases "pasObjectAbs aag x = pasSubject aag") + case True + then show ?thesis by (simp add: subjectAffects.intros(1)) +next + case False + obtain ao' where ao': "kheap s' x = Some (ArchObj ao')" + using assms False inte_obj_arch[OF inte_obj] + by (auto elim: integrity_obj_atomic.cases) + have arch_tro: + "arch_integrity_obj_atomic (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} (pasObjectAbs aag x) (ASIDPool pool) ao'" + using assms False ao' inte_obj_arch[OF inte_obj] + by (auto elim: integrity_obj_atomic.cases) + obtain asid where asid: "pool_for_asid asid s = Some x" + using assms False inte_obj_arch[OF inte_obj] + integrity_subjects_asids[OF partitionIntegrity_integrity[OF par_inte]] + by (fastforce elim!: integrity_obj_atomic.cases arch_integrity_obj_atomic.cases + simp: integrity_asids_def aobjs_of_Some opt_map_def pool_for_asid_def)+ + show ?thesis + using assms ao' asid arch_tro + by (fastforce dest: partitionIntegrity_subjectAffects_asid_pool') +qed + +lemma partitionIntegrity_subjectAffects_aobj: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (ArchObj ao)" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_vcpu_in_cur_domain s" "cur_vcpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" +proof (cases "pasObjectAbs aag x = pasSubject aag") + case True + then show ?thesis by (simp add: subjectAffects.intros(1)) +next + case False + obtain ao' where ao': "kheap s' x = Some (ArchObj ao')" + using assms False inte_obj_arch[OF inte_obj] + by (auto elim: integrity_obj_atomic.cases) + have arch_tro: + "arch_integrity_obj_atomic (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} (pasObjectAbs aag x) ao ao'" + using assms False ao' inte_obj_arch[OF inte_obj] + by (auto elim: integrity_obj_atomic.cases) + show ?thesis + apply (case_tac ao) + apply (insert partitionIntegrity_subjectAffects_asid_pool[of aag s s' x _ st]) + using assms apply (simp add: invs_arch_state) + using arch_tro apply (fastforce elim: arch_integrity_obj_atomic.cases) + using arch_tro apply (fastforce elim: arch_integrity_obj_atomic.cases) + apply (insert partitionIntegrity_subjectAffects_vcpu[of aag s s' x _ st]) + using assms apply (simp add: invs_arch_state) + done +qed + +declare cur_vcpu_for_None[simp] + +lemma cur_vcpu_of_None[simp]: + "cur_vcpu_of_2 None vst = None" + by (clarsimp simp: cur_vcpu_of_def) + +lemma partitionIntegrity_subjectAffects_numlistregs: + "partitionIntegrity aag s s' \ equiv_for (\x. pasObjectAbs aag x = da) (K \ numlistregs) s s'" + by (clarsimp simp: partitionIntegrity_def integrity_subjects_def integrity_hyp_def equiv_for_def) + +lemma partitionIntegrity_subjectAffects_cur_vcpu_of: + "\ invs s; invs s'; + cur_vcpu_in_cur_domain s; cur_vcpu_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_for (\x. pasObjectAbs aag x = a) cur_vcpu_of s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + apply (case_tac "\b. cur_vcpu_for (\x. pasObjectAbs aag x = a) s = Some b") + apply (clarsimp simp: affects_lrefl partitionIntegrity_cur_vcpu_Some cur_vcpu_for_def split: option.splits if_splits) + apply (case_tac "\b. cur_vcpu_for (\x. pasObjectAbs aag x = a) s' = Some b") + apply (clarsimp simp: affects_lrefl partitionIntegrity_cur_vcpu_Some cur_vcpu_for_def split: option.splits if_splits) + apply clarsimp + apply (erule swap) + apply (clarsimp simp: equiv_for_def cur_vcpu_of_def split: option.splits) + done + +lemma partitionIntegrity_subjectAffects_hw_vcpu: + "\ invs s; invs s'; + cur_vcpu_in_cur_domain s; cur_vcpu_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_for (\x. pasObjectAbs aag x = a) hw_vcpu_of s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + apply (case_tac "\b. cur_vcpu_for (\x. pasObjectAbs aag x = a) s = Some b") + apply (clarsimp simp: affects_lrefl partitionIntegrity_cur_vcpu_Some cur_vcpu_for_def split: option.splits if_splits) + apply (case_tac "\b. cur_vcpu_for (\x. pasObjectAbs aag x = a) s' = Some b") + apply (clarsimp simp: affects_lrefl partitionIntegrity_cur_vcpu_Some cur_vcpu_for_def split: option.splits if_splits) + apply clarsimp + apply (clarsimp simp: equiv_for_def) + apply (clarsimp simp: cur_vcpu_of_def cur_vcpu_for_def split: option.splits if_splits) + done + +lemma partitionIntegrity_subjectAffects_hyp: + "\ partitionIntegrity aag s s'; + invs s; invs s'; + cur_vcpu_in_cur_domain s; cur_vcpu_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_hyp (\x. pasObjectAbs aag x = a) s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + unfolding equiv_hyp_def + using partitionIntegrity_subjectAffects_numlistregs + partitionIntegrity_subjectAffects_cur_vcpu_of + partitionIntegrity_subjectAffects_hw_vcpu + by (metis (mono_tags)) + +lemma cur_fpu_is_subject: + "\ invs s; pas_refined aag s; pas_cur_domain aag s; pas_domains_distinct aag; + cur_fpu_in_cur_domain s; current_fpu s = Some t \ + \ is_subject aag t" + apply (clarsimp simp: cur_fpu_in_cur_domain_def split: option.splits) + apply (frule current_fpu_owner_Some_tcb_at, fastforce) + apply (drule tcb_at_ko_at, clarsimp) + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply simp + apply (prop_tac "pasDomainAbs aag (cur_domain s) = {pasSubject aag}") + apply (clarsimp simp: pas_domains_distinct_def) + apply (metis singletonD) + apply blast + done + +lemma partitionIntegrity_subjectAffects_fpu: + "\ partitionIntegrity aag s s'; + invs s; invs s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_fpu (\x. pasObjectAbs aag x = a) s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + unfolding equiv_fpu_def + apply (clarsimp simp: equiv_for_def) + apply (case_tac "is_arch_cur_fpu x s") + apply (frule (4) cur_fpu_is_subject[of s]) + apply (simp add: is_arch_cur_fpu_def) + apply (clarsimp simp: affects_lrefl) + apply (case_tac "is_arch_cur_fpu x s'") + apply (frule (4) cur_fpu_is_subject[of s']) + apply (simp add: is_arch_cur_fpu_def) + apply (clarsimp simp: affects_lrefl) + apply (clarsimp simp: hw_fpu_def) + done + +lemma partitionIntegrity_subjectAffects_tcb_fpu': + "\ partitionIntegrity aag s s'; valid_cur_fpu s; valid_cur_fpu s'; + kheap s x = Some (TCB tcb); kheap s' x = Some (TCB tcb'); + tcb' = tcb\tcb_arch := new_arch\; + arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb); + tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb); + current_fpu s \ Some x; current_fpu s' \ Some x \ + \ is_subject aag x \ kheap s x = kheap s' x" + apply clarsimp + apply (erule_tac P="tcb = tcb\tcb_arch := new_arch\" in swap) + apply (prop_tac "integrity_fpu (aag\pasMayActivate := False, pasMayEditReadyQueues := False\) + {pasSubject aag} x s s'") + apply (clarsimp simp: partitionIntegrity_def integrity_subjects_def) + apply (clarsimp simp: integrity_fpu_def) + apply (clarsimp simp: fpu_of_state_def) + apply (clarsimp simp: valid_cur_fpu_def) + apply (erule_tac x=x in allE)+ + apply (clarsimp simp: is_tcb_cur_fpu_def obj_at_def) + apply (subgoal_tac "tcb_arch tcb = new_arch") + apply (case_tac tcb; clarsimp) + apply (subgoal_tac "tcb_context (tcb_arch tcb) = tcb_context new_arch") + apply (case_tac "tcb_arch tcb"; case_tac new_arch; clarsimp simp: tcb_vcpu_refs_def split: option.splits) + apply (case_tac "tcb_context (tcb_arch tcb)"; case_tac "tcb_context new_arch"; clarsimp simp: arch_tcb_get_registers_def) + done + +lemma partitionIntegrity_subjectAffects_tcb_fpu: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (TCB tcb)" + "kheap s' x = Some (TCB tcb')" + "tcb' = tcb\tcb_arch := new_arch\" + "arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb)" + "tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb)" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_fpu_in_cur_domain s" "cur_fpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" + apply (rule ssubst[where s="pasSubject aag", OF _ affects_lrefl]) + apply (case_tac "current_fpu s \ Some x \ current_fpu s' \ Some x"; clarsimp) + using assms apply (fastforce dest!: partitionIntegrity_subjectAffects_tcb_fpu'[OF par_inte, rotated 7]) + apply (elim disjE; rule cur_fpu_is_subject; simp add: assms pas_wellformed_noninterference_domains_distinct) + done + +lemma partitionIntegrity_subjectAffects_asid[Noninterference_assms]: + "\ partitionIntegrity aag s s'; pas_refined aag s; valid_objs s; + valid_arch_state s; valid_arch_state s'; pas_wellformed_noninterference aag; + silc_inv aag st s'; invs s'; \ equiv_asids (\x. pasASIDAbs aag x = a) s s' \ + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + apply (clarsimp simp: equiv_asids_def equiv_asid_def asid_pool_at_kheap) + apply (case_tac "arm_asid_table (arch_state s) (asid_high_bits_of asid) = + arm_asid_table (arch_state s') (asid_high_bits_of asid)") + apply (clarsimp simp: valid_arch_state_def valid_asid_table_def) + apply (erule disjE) + apply (case_tac "kheap s' pool_ptr = None"; clarsimp) + apply (prop_tac "pool_ptr \ dom (asid_pools_of s')") + apply (fastforce simp: not_in_domIff asid_pools_of_ko_at obj_at_def) + apply blast + apply (case_tac "\asid_pool. y = ArchObj (ASIDPool asid_pool)"; clarsimp) + apply (prop_tac "pool_ptr \ dom (asid_pools_of s)") + apply (fastforce simp: not_in_domIff asid_pools_of_ko_at obj_at_def) + apply blast + apply (prop_tac "pool_ptr \ dom (asid_pools_of s')") + apply (fastforce simp: not_in_domIff asid_pools_of_ko_at obj_at_def) + apply blast + apply clarsimp + apply (rule affects_asidpool_map) + apply (rule pas_refined_asid_mem) + apply (drule partitionIntegrity_integrity) + apply (drule integrity_subjects_obj) + apply (drule_tac x="pool_ptr" in spec)+ + apply (clarsimp simp: asid_pools_of_ko_at obj_at_def) + apply (drule tro_tro_alt, erule integrity_obj_alt.cases; simp) + apply (drule_tac t="pasSubject aag" in sym) + apply simp + apply (rule sata_asidpool) + apply assumption + apply assumption + apply (clarsimp simp: arch_integrity_obj_alt.simps asid_pool_integrity_def) + apply (drule_tac x="asid_low_bits_of asid" in spec)+ + apply clarsimp + apply (drule owns_mapping_owns_asidpool[rotated]) + apply ((simp | blast intro: pas_refined_Control[THEN sym] + | fastforce simp: pool_for_asid_def + intro: pas_wellformed_pasSubject_update[simplified])+)[6] + apply (drule_tac t="pasSubject aag" in sym)+ + apply simp + apply (rule sata_asidpool) + apply assumption + apply assumption + apply assumption + apply clarsimp + apply (drule partitionIntegrity_integrity) + apply (clarsimp simp: integrity_def integrity_asids_def) + apply (drule_tac x=asid in spec)+ + apply (fastforce intro: affects_lrefl) + done + +(* clagged mostly from Scheduler_IF.dmo_storeWord_reads_respects_scheduler *) +lemma dmo_storeWord_reads_respects_g[Noninterference_assms, wp]: + "reads_respects_g aag l \ (do_machine_op (storeWord ptr w))" + apply (clarsimp simp: do_machine_op_def bind_def gets_def get_def return_def fail_def + select_f_def storeWord_def assert_def simpler_modify_def) + apply (fold simpler_modify_def) + apply (intro impI conjI) + apply (rule ev_modify) + apply (rule conjI) + apply (fastforce simp: reads_equiv_g_def globals_equiv_def reads_equiv_def2 states_equiv_for_def + equiv_for_def equiv_asids_def equiv_asid_def silc_dom_equiv_def + upto.simps equiv_hyp_def equiv_fpu_def cur_fpu_for_def) + apply (rule affects_equiv_machine_state_update, assumption) + apply (fastforce simp: equiv_for_def affects_equiv_def states_equiv_for_def upto.simps) + apply (clarsimp simp: identical_hyp_state_updates_def identical_updates_rv_def) + apply (clarsimp simp: identical_fpu_state_updates_def identical_updates_rv_def cur_fpu_for_def) + apply (simp add: equiv_valid_def2 equiv_valid_2_def) + done + +declare set_vm_root_states_equiv_for[wp] + +lemma set_vm_root_reads_respects: + "reads_respects aag l \ (set_vm_root tcb)" + by (rule reads_respects_unobservable_unit_return) wp+ + +lemmas set_vm_root_reads_respects_g[wp] = + reads_respects_g[OF set_vm_root_reads_respects, + OF doesnt_touch_globalsI[where P="valid_global_arch_objs"], + simplified, OF set_vm_root_globals_equiv] + +lemmas lazy_fpu_restore_reads_respects_g[wp] = + reads_respects_g[OF lazy_fpu_restore_reads_respects, + OF doesnt_touch_globalsI[where P=invs], + simplified, OF lazy_fpu_restore_globals_equiv] + +lemmas vcpu_switch_reads_respects_g[wp] = + reads_respects_g[OF vcpu_switch_reads_respects, + OF doesnt_touch_globalsI[where P=valid_arch_state], + simplified, OF vcpu_switch_globals_equiv] + +crunch vcpu_switch + for global_pt[wp]: "\s. P (global_pt s)" + (wp: valid_global_arch_objs_lift) + +crunch vcpu_switch + for valid_global_arch_objs[wp]: "valid_global_arch_objs" + (wp: valid_global_arch_objs_lift) + +lemma arch_switch_to_thread_reads_respects_g'[Noninterference_assms]: + "equiv_valid (reads_equiv_g aag) (affects_equiv aag l) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + (\s. invs s \ is_subject aag t) + (arch_switch_to_thread t)" + apply (simp add: arch_switch_to_thread_def) + apply (wp bind_ev_general thread_get_reads_respects_g) + apply (auto intro: sym_refs_VCPU_hyp_live simp: reads_equiv_g_def) + done + +(* consider rewriting the return-value assumption using equiv_valid_rv_inv *) +lemma ev2_invisible'[Noninterference_assms]: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "\ labels_are_invisible aag l L; labels_are_invisible aag l L'; + modifies_at_most aag L Q f; modifies_at_most aag L' Q' g; + doesnt_touch_globals Q f; doesnt_touch_globals Q' g; + \st :: det_state. f \\s. arch_globals_equiv_strengthener (machine_state st) (machine_state s)\; + \st :: det_state. g \\s. arch_globals_equiv_strengthener (machine_state st) (machine_state s)\; + \s t. P s \ P' t \ (\(rva,s') \ fst (f s). \(rvb,t') \ fst (g t). W rva rvb) \ + \ equiv_valid_2 (reads_equiv_g aag) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + W (P and Q) (P' and Q') f g" + apply (clarsimp simp: equiv_valid_2_def) + apply (rule conjI) + apply blast + apply (drule_tac s=s in modifies_at_mostD, assumption+) + apply (drule_tac s=t in modifies_at_mostD, assumption+) + apply (drule_tac s=s in globals_equivI, assumption+) + apply (drule_tac s=t in globals_equivI, assumption+) + apply (frule (1) equiv_but_for_reads_equiv[OF domains_distinct]) + apply (frule_tac s=t in equiv_but_for_reads_equiv[OF domains_distinct], assumption) + apply (drule (1) equiv_but_for_affects_equiv[OF domains_distinct]) + apply (drule_tac s=t in equiv_but_for_affects_equiv[OF domains_distinct], assumption) + apply (clarsimp simp: reads_equiv_g_def) + apply (blast intro: reads_equiv_trans reads_equiv_sym affects_equiv_trans + affects_equiv_sym globals_equiv_trans globals_equiv_sym) + done + +lemmas dmo_mol_reads_respects_g[wp] = + reads_respects_g[OF dmo_mol_reads_respects, + OF doesnt_touch_globalsI[where P="\"], + simplified, + OF dmo_mol_globals_equiv] + +lemma set_global_user_vspace_reads_respects_g[Noninterference_assms, wp]: + "reads_respects_g aag l \ (set_global_user_vspace)" + unfolding set_global_user_vspace_def setVSpaceRoot_def + apply wpsimp + apply (clarsimp simp: reads_equiv_g_def globals_equiv_def) + done + +lemma arch_switch_to_idle_thread_reads_respects_g[Noninterference_assms, wp]: + "reads_respects_g aag l valid_arch_state (arch_switch_to_idle_thread)" + apply (simp add: arch_switch_to_idle_thread_def) + apply wp + done + +lemma arch_globals_equiv_threads_eq[Noninterference_assms]: + "arch_globals_equiv t' t'' kh kh' as as' ms ms' + \ arch_globals_equiv t t kh kh' as as' ms ms'" + by clarsimp + +lemma arch_globals_equiv_globals_equiv_scheduler[Noninterference_assms, elim]: + "arch_globals_equiv (cur_thread t) (idle_thread s) (kheap s) (kheap t) + (arch_state s) (arch_state t) (machine_state s) (machine_state t) + \ arch_globals_equiv_scheduler (kheap s) (kheap t) (arch_state s) (arch_state t)" + by (auto simp: arch_globals_equiv_scheduler_def) + +lemma getActiveIRQ_ret_no_dmo[Noninterference_assms, wp]: + "\\\ getActiveIRQ in_kernel \\rv s. \x. rv = Some x \ x \ maxIRQ\" + apply (simp add: getActiveIRQ_def) + apply (rule hoare_pre) + apply (insert irq_oracle_max_irq) + apply (wp dmo_getActiveIRQ_irq_masks) + apply (clarsimp simp: maxIRQ_def) + done + +(*FIXME: Move to scheduler_if*) +lemma dmo_getActive_IRQ_reads_respect_scheduler[Noninterference_assms]: + "reads_respects_scheduler aag l (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ in_kernel))" + apply (simp add: getActiveIRQ_def) + apply (simp add: dmo_distr dmo_if_distr dmo_gets_distr dmo_modify_distr cong: if_cong) + apply wp + apply (rule ev_modify[where P=\]) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def + scheduler_affects_equiv_def arch_scheduler_affects_equiv_def + states_equiv_for_def equiv_for_def equiv_asids_def equiv_asid_def + scheduler_globals_frame_equiv_def silc_dom_equiv_def idle_equiv_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def) + apply wp + apply (rule_tac P="\s. irq_masks_of_state st = irq_masks_of_state s" in gets_ev') + apply wp + apply clarsimp + apply (simp add: scheduler_equiv_def) + done + +lemma integrity_hyp_update_reference_state[Noninterference_assms]: + "is_subject aag t + \ integrity_hyp aag {pasSubject aag} x s (s\kheap := (kheap s)(t \ blah)\)" + by (auto simp: integrity_hyp_def vcpu_integrity_def vcpu_of_state_def opt_map_def) + +lemma integrity_fpu_update_reference_state[Noninterference_assms]: + "is_subject aag t + \ integrity_fpu aag {pasSubject aag} x s (s\kheap := (kheap s)(t \ blah)\)" + by (auto simp: integrity_fpu_def fpu_of_state_def) + +definition irq_at' :: "bool \ nat \ (irq \ bool) \ irq option" where + "irq_at' in_kernel pos masks \ + let i = irq_oracle pos in (if masks i \ in_kernel \ i \ non_kernel_IRQs then None else Some i)" + +lemma dmo_getActiveIRQ_wp': + "\\s. P (irq_at' in_kernel (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at'_def split: if_splits) + done + +lemma getActiveIRQ_ev2[Noninterference_assms]: + "equiv_valid_2 (scheduler_equiv aag) + (scheduler_affects_equiv aag l) (scheduler_affects_equiv aag l) + (\irq irq'. irq = irq' \ irq = None \ irq' \ Some ` non_kernel_IRQs) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ True)) (do_machine_op (getActiveIRQ False))" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid, rule dmo_getActiveIRQ_wp')+ + apply (intro conjI) + apply (clarsimp simp: scheduler_equiv_def irq_at'_def Let_def) + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def + silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI impI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def equiv_asids_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + done + +crunch arch_prepare_next_domain + for work_units_completed[wp]: "\s. P (work_units_completed s)" + +lemma arch_prepare_next_domain_reads_respects: + "reads_respects aag l invs arch_prepare_next_domain" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_from_labels) + apply (rule arch_prepare_next_domain_states_equiv_valid) + apply wpsimp+ + done + +lemma arch_prepare_next_domain_reads_respects_g: + "reads_respects_g aag l invs arch_prepare_next_domain" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_g[OF arch_prepare_next_domain_reads_respects doesnt_touch_globalsI]) + apply wpsimp + apply assumption + apply clarsimp + done + +lemmas [Noninterference_assms] = + arch_prepare_next_domain_reads_respects_g + partitionIntegrity_subjectAffects_aobj[folded cur_hyp_in_cur_domain_def] + partitionIntegrity_subjectAffects_hyp[folded cur_hyp_in_cur_domain_def] + partitionIntegrity_subjectAffects_fpu + partitionIntegrity_subjectAffects_tcb_fpu + +end + + +arch_requalify_consts arch_globals_equiv_strengthener +arch_requalify_facts arch_globals_equiv_strengthener_thread_independent + + +global_interpretation Noninterference_1?: Noninterference_1 _ arch_globals_equiv_strengthener +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Noninterference_assms)?) +qed + + +sublocale valid_initial_state \ valid_initial_state?: + Noninterference_valid_initial_state arch_globals_equiv_strengthener .. + +end diff --git a/proof/infoflow/AARCH64/ArchPasUpdates.thy b/proof/infoflow/AARCH64/ArchPasUpdates.thy new file mode 100644 index 0000000000..cafef0519e --- /dev/null +++ b/proof/infoflow/AARCH64/ArchPasUpdates.thy @@ -0,0 +1,88 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchPasUpdates +imports PasUpdates +begin + +context Arch begin + +named_theorems PasUpdates_assms + +lemma state_asids_to_policy_aux_pasSubject_update: + "state_asids_to_policy_aux (aag\pasSubject := x\) caps asid vrefs = + state_asids_to_policy_aux aag caps asid vrefs" + apply (rule equalityI) + apply clarify + apply (erule state_asids_to_policy_aux.cases + | simp + | fastforce intro: state_asids_to_policy_aux.intros)+ + apply clarify + apply (erule state_asids_to_policy_aux.cases) + apply (simp, subst pasObjectAbs_pasSubject_update[symmetric] + , subst pasASIDAbs_pasSubject_update[symmetric] + , rule state_asids_to_policy_aux.intros + , assumption+)+ + done + +lemma state_asids_to_policy_pasSubject_update[PasUpdates_assms]: + "state_asids_to_policy (aag\pasSubject := x\) s = + state_asids_to_policy aag s" + by (simp add: state_asids_to_policy_aux_pasSubject_update) + +lemma state_asids_to_policy_aux_pasMayActivate_update: + "state_asids_to_policy_aux (aag\pasMayActivate := x\) caps asid_tab vrefs = + state_asids_to_policy_aux aag caps asid_tab vrefs" + apply (rule equalityI) + apply clarify + apply (erule state_asids_to_policy_aux.cases + | simp + | fastforce intro: state_asids_to_policy_aux.intros)+ + apply clarify + apply (erule state_asids_to_policy_aux.cases) + apply (simp, subst pasObjectAbs_pasMayActivate_update[symmetric] + , subst pasASIDAbs_pasMayActivate_update[symmetric] + , rule state_asids_to_policy_aux.intros + , assumption+)+ + done + +lemma state_asids_to_policy_pasMayActivate_update[PasUpdates_assms]: + "state_asids_to_policy (aag\pasMayActivate := x\) s = + state_asids_to_policy aag s" + by (simp add: state_asids_to_policy_aux_pasMayActivate_update) + +lemma state_asids_to_policy_aux_pasMayEditReadyQueues_update: + "state_asids_to_policy_aux (aag\pasMayEditReadyQueues := x\) caps asid_tab vrefs = + state_asids_to_policy_aux aag caps asid_tab vrefs" + apply (rule equalityI) + apply (clarify) + apply (erule state_asids_to_policy_aux.cases + | simp + | fastforce intro: state_asids_to_policy_aux.intros)+ + apply (clarify) + apply (erule state_asids_to_policy_aux.cases) + apply (simp, subst pasObjectAbs_pasMayEditReadyQueues_update[symmetric] + , subst pasASIDAbs_pasMayEditReadyQueues_update[symmetric] + , rule state_asids_to_policy_aux.intros + , assumption+)+ + done + +lemma state_asids_to_policy_pasMayEditReadyQueues_update[PasUpdates_assms]: + "state_asids_to_policy (aag\pasMayEditReadyQueues := x\) s = + state_asids_to_policy aag s" + by (simp add: state_asids_to_policy_aux_pasMayEditReadyQueues_update) + +end + + +global_interpretation PasUpdates_1?: PasUpdates_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact PasUpdates_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchRetype_IF.thy b/proof/infoflow/AARCH64/ArchRetype_IF.thy new file mode 100644 index 0000000000..0b9248747f --- /dev/null +++ b/proof/infoflow/AARCH64/ArchRetype_IF.thy @@ -0,0 +1,654 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchRetype_IF +imports Retype_IF +begin + +context Arch begin arch_global_naming + +named_theorems Retype_IF_assms + +crunch clearMemory, freeMemory + for vcpu_state[wp]: "\ms. P (vcpu_state ms)" + and fpu_state[wp]: "\ms. P (fpu_state ms)" + (wp: mapM_x_wp_inv ignore_del: storeWord clearMemory) + +lemma machine_op_lift_no_hyp[Retype_IF_assms]: + "no_hyp (machine_op_lift mop)" + by wp + +lemma machine_op_lift_no_fpu[Retype_IF_assms]: + "no_fpu (machine_op_lift mop)" + by wp + +lemma clearMemory_no_hyp[Retype_IF_assms]: + "no_hyp (clearMemory ptr bits)" + by wp + +lemma freeMemory_no_hyp[Retype_IF_assms]: + "no_hyp (freeMemory ptr bits)" + by wp + +lemma clearMemory_no_fpu[Retype_IF_assms]: + "no_fpu (clearMemory ptr bits)" + by wp + +lemma freeMemory_no_fpu[Retype_IF_assms]: + "no_fpu (freeMemory ptr bits)" + by wp + +lemma do_ipc_transfer_valid_arch_no_caps[wp]: + "do_ipc_transfer s ep bg grt r \valid_arch_state\" + by (wpsimp wp: valid_arch_state_lift_aobj_at_no_caps do_ipc_transfer_aobj_at) + +lemma create_cap_valid_arch_state_no_caps[wp]: + "create_cap tp sz p dev ref \valid_arch_state\" + by (wp valid_arch_state_lift_aobj_at_no_caps create_cap_aobj_at) + +lemma modify_underlying_memory_update_0_ev: + "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \ + (modify (underlying_memory_update (\m. m(x := word_rsplit 0 ! 7, + x + 1 := word_rsplit 0 ! 6, + x + 2 := word_rsplit 0 ! 5, + x + 3 := word_rsplit 0 ! 4, + x + 4 := word_rsplit 0 ! 3, + x + 5 := word_rsplit 0 ! 2, + x + 6 := word_rsplit 0 ! Suc 0, + x + 7 := word_rsplit 0 ! 0))))" + by (fastforce simp: equiv_valid_def2 equiv_valid_2_def in_monad + elim: equiv_forE + intro: equiv_forI) + +lemma storeWord_ev: + "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \ (storeWord x 0)" + unfolding storeWord_def + by (wp modify_underlying_memory_update_0_ev assert_inv | simp add: no_irq_def upto.simps comp_def)+ + +lemma clearMemory_ev[Retype_IF_assms]: + "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) (\_. True) (clearMemory ptr bits)" + unfolding clearMemory_def + apply (rule equiv_valid_guard_imp) + apply (rule mapM_x_ev[OF storeWord_ev]) + apply (rule wp_post_taut | simp)+ + done + +lemma freeMemory_ev[Retype_IF_assms]: + "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) (\_. True) (freeMemory ptr bits)" + unfolding freeMemory_def + apply (rule equiv_valid_guard_imp) + apply (rule mapM_x_ev[OF storeWord_ev]) + apply (rule wp_post_taut | simp)+ + done + +lemma set_pt_globals_equiv: + "\globals_equiv st and (\s. a \ global_pt s)\ + set_pt a b + \\_. globals_equiv st\" + apply (unfold set_pt_def gets_map_def) + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev set_object_globals_equiv) + apply (fastforce elim: reads_equivE equiv_forE simp: opt_map_def) + done + +lemma set_pt_reads_respects: + "reads_respects aag l (K (is_subject aag a)) (set_pt a b)" + apply (unfold set_pt_def gets_map_def) + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev set_object_reads_respects) + apply (fastforce elim: reads_equivE equiv_forE simp: opt_map_def) + done + +lemma set_pt_reads_respects_g: + "reads_respects_g aag l (\ s. is_subject aag ptr \ ptr \ global_pt s) (set_pt ptr pt)" + by (fastforce intro: equiv_valid_guard_imp[OF reads_respects_g] doesnt_touch_globalsI + set_pt_reads_respects set_pt_globals_equiv) + +crunch clearMemory + for irq_state[Retype_IF_assms, wp]: "\s. P (irq_state s)" + (wp: crunch_wps simp: crunch_simps storeWord_def ignore_del: clearMemory) + +crunch freeMemory + for irq_state[Retype_IF_assms, wp]: "\s. P (irq_state s)" + (wp: crunch_wps simp: crunch_simps storeWord_def) + +lemma get_pt_rev: + "reads_equiv_valid_inv A aag (K (is_subject aag ptr)) (get_pt ptr)" + apply (unfold gets_map_def) + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (fastforce elim: reads_equivE equiv_forE simp: opt_map_def) + done + +lemma get_pt_revg: + "reads_equiv_valid_g_inv A aag (\ s. ptr = arm_us_global_vspace (arch_state s)) (get_pt ptr)" + apply (unfold gets_map_def) + apply (subst gets_apply) + apply (wp gets_apply_ev') + defer + apply (wp hoare_drop_imps) + apply (rule conjI) + apply assumption + apply simp + apply (auto simp: reads_equiv_g_def globals_equiv_def opt_map_def) + done + +lemma store_pte_reads_respects: + "reads_respects aag l (K (is_subject aag (table_base pt_t ptr))) (store_pte pt_t ptr pte)" + unfolding store_pte_def fun_app_def + apply (wp set_pt_reads_respects get_pt_rev) + apply (clarsimp) + done + +lemma store_pte_globals_equiv: + "\globals_equiv s and (\ s. table_base pt_t ptr \ arm_us_global_vspace (arch_state s))\ + store_pte pt_t ptr pde + \\_. globals_equiv s\" + unfolding store_pte_def + apply (wp set_pt_globals_equiv) + apply simp + done + +lemma store_pte_reads_respects_g: + "reads_respects_g aag l (\s. is_subject aag (table_base pt_t ptr) \ + table_base pt_t ptr \ arm_us_global_vspace (arch_state s)) + (store_pte pt_t ptr pte)" + by (fastforce intro: equiv_valid_guard_imp[OF reads_respects_g] doesnt_touch_globalsI + store_pte_reads_respects store_pte_globals_equiv) + +lemma get_pte_rev: + "reads_equiv_valid_inv A aag (K (is_subject aag (table_base pt_t ptr))) (get_pte pt_t ptr)" + unfolding gets_map_def fun_app_def + apply (subst gets_apply) + apply (wpsimp wp: gets_apply_ev) + apply (fastforce elim: reads_equivE equiv_forE simp: ptes_of_def obind_def opt_map_def) + done + +lemma get_pte_revg: + "reads_equiv_valid_g_inv A aag (\s. (table_base pt_t ptr) = arm_us_global_vspace (arch_state s)) + (get_pte pt_t ptr)" + apply (unfold gets_map_def) + apply (subst gets_apply) + apply (wp gets_apply_ev') + defer + apply (wp hoare_drop_imps) + apply (rule conjI) + apply assumption + apply simp + apply (auto simp: reads_equiv_g_def globals_equiv_def opt_map_def ptes_of_def obind_def) + done + +lemma dmo_no_mem_globals_equiv: + "\ \P. f \\ms. P (underlying_memory ms)\; + \P. f \\ms. P (device_state ms)\; + \P. f \\ms. P (exclusive_state ms)\ \ + \ do_machine_op f \globals_equiv s\" + unfolding do_machine_op_def + apply (wp | simp add: split_def)+ + apply atomize + apply (erule_tac x="(=) (underlying_memory (machine_state sa))" in allE) + apply (erule_tac x="(=) (device_state (machine_state sa))" in allE) + apply (fastforce simp: valid_def globals_equiv_def idle_equiv_def) + done + +lemma dmo_mol_globals_equiv[wp]: + "do_machine_op (machine_op_lift f) \globals_equiv s\" + by (wpsimp wp: dmo_no_mem_globals_equiv simp: machine_op_lift_def machine_rest_lift_def) + +lemma mol_globals_equiv: + "machine_op_lift mop \\ms. globals_equiv st (s\machine_state := ms\)\" + unfolding machine_op_lift_def + apply (simp add: machine_rest_lift_def split_def) + apply wp + apply (clarsimp simp: globals_equiv_def idle_equiv_def) + done + +lemma storeWord_globals_equiv: + "storeWord p v \\ms. globals_equiv st (s\machine_state := ms\)\" + unfolding storeWord_def + apply (simp add: is_aligned_mask[symmetric]) + apply wp + apply (clarsimp simp: globals_equiv_def idle_equiv_def) + done + +lemma dmo_clearMemory_globals_equiv[Retype_IF_assms]: + "do_machine_op (clearMemory ptr (2 ^ bits)) \globals_equiv s\" + apply (simp add: do_machine_op_def clearMemory_def split_def) + apply wpsimp + apply (erule use_valid) + by (wpsimp wp: mapM_x_wp' storeWord_globals_equiv mol_globals_equiv)+ + +lemma dmo_freeMemory_globals_equiv[Retype_IF_assms]: + "do_machine_op (freeMemory ptr bits) \globals_equiv s\" + apply (rule hoare_pre) + apply (simp add: do_machine_op_def freeMemory_def split_def) + apply (wp) + apply clarsimp + apply (erule use_valid) + apply (wp mapM_x_wp' storeWord_globals_equiv mol_globals_equiv) + apply (simp_all) + done + +lemma init_arch_objects_reads_respects_g: + "reads_respects_g aag l \ (init_arch_objects new_type dev ptr num_objects obj_sz refs)" + unfolding init_arch_objects_def cleanCacheRange_RAM_def cleanCacheRange_PoU_def + by (wpsimp wp: reads_respects_g do_machine_op_reads_respects + equiv_valid_guard_imp[OF machine_op_lift_ev] + doesnt_touch_globalsI mapM_x_ev mapM_x_wp_inv) + +(* FIXME: cleanup this proof *) +lemma retype_region_globals_equiv[Retype_IF_assms]: + notes blah[simp del] = atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + shows + "\globals_equiv s and invs + and (\s. \i. cte_wp_at (\c. c = UntypedCap dev (p && ~~ mask sz) sz i) slot s \ + (i \ unat (p && mask sz) \ pspace_no_overlap_range_cover p sz s)) + and K (range_cover p sz (obj_bits_api type o_bits) num \ 0 < num)\ + retype_region p num o_bits type dev + \\_. globals_equiv s\" + apply (simp only: retype_region_def foldr_upd_app_if fun_app_def K_bind_def) + apply (wp |simp)+ + apply clarsimp + apply (simp only: globals_equiv_def) + apply (clarsimp split del: if_split) + apply (subgoal_tac "pspace_no_overlap_range_cover p sz sa") + apply (rule conjI) + apply (clarsimp simp: pspace_no_overlap_def) + apply (drule_tac x="arm_us_global_vspace (arch_state sa)" in spec) + apply (frule valid_global_arch_objs_pt_at[OF invs_valid_global_arch_objs]) + apply (clarsimp simp: invs_def valid_state_def valid_global_objs_def + valid_vso_at_def obj_at_def ptr_add_def) + apply (frule_tac p=x in range_cover_subset) + apply (simp add: blah) + apply simp + apply (frule range_cover_subset') + apply simp + apply (clarsimp simp: p_assoc_help) + apply (drule disjoint_subset_neg1[OF _ subset_thing], rule is_aligned_no_wrap') + apply (clarsimp simp: valid_pspace_def pspace_aligned_def) + apply (drule_tac x="arm_us_global_vspace (arch_state sa)" and A="dom (kheap sa)" in bspec) + apply (simp add: domI) + apply simp + apply (rule word_power_less_1) + apply (simp add: table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def) + apply simp + apply simp + apply simp + apply (drule (1) subset_trans) + apply (erule_tac P="a \ b" for a b in notE) + apply (erule_tac A="{p + c..d}" for c d in subsetD) + apply (simp add: blah) + apply (rule is_aligned_no_wrap') + apply (rule is_aligned_add[OF _ is_aligned_mult_triv2]) + apply (simp add: range_cover_def) + apply (rule word_power_less_1) + apply (simp add: range_cover_def) + apply (erule updates_not_idle) + apply (clarsimp simp: pspace_no_overlap_def) + apply (drule_tac x="idle_thread sa" in spec) + apply (clarsimp simp: invs_def valid_state_def valid_global_objs_def + obj_at_def ptr_add_def valid_idle_def pred_tcb_at_def) + apply (frule_tac p=a in range_cover_subset) + apply (simp add: blah) + apply simp + apply (frule range_cover_subset') + apply simp + apply (clarsimp simp: p_assoc_help) + apply (drule disjoint_subset_neg1[OF _ subset_thing], rule is_aligned_no_wrap') + apply (clarsimp simp: valid_pspace_def pspace_aligned_def) + apply (drule_tac x="idle_thread sa" and A="dom (kheap sa)" in bspec) + apply (simp add: domI) + apply simp + apply uint_arith + apply simp+ + apply (drule (1) subset_trans) + apply (erule_tac P="a \ b" for a b in notE) + apply (erule_tac A="{idle_thread_ptr..d}" for d in subsetD) + apply (simp add: blah) + apply (erule_tac t=idle_thread_ptr in subst) + apply (rule is_aligned_no_wrap') + apply (rule is_aligned_add[OF _ is_aligned_mult_triv2]) + apply (simp add: range_cover_def)+ + apply (auto intro!: cte_wp_at_pspace_no_overlapI simp: range_cover_def word_bits_def)[1] + done + +lemma no_irq_freeMemory[Retype_IF_assms]: + "no_irq (freeMemory ptr sz)" + apply (simp add: freeMemory_def) + apply (wp no_irq_mapM_x no_irq_storeWord) + done + +lemma equiv_asid_detype[Retype_IF_assms]: + "equiv_asid asid s s' \ equiv_asid asid (detype N s) (detype N s')" + by (auto simp: equiv_asid_def) + +end + + +global_interpretation Retype_IF_1?: Retype_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Retype_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma detype_globals_equiv: + "\globals_equiv st and ((\s. arm_us_global_vspace (arch_state s) \ S) and (\s. idle_thread s \ S))\ + modify (detype S) + \\_. globals_equiv st\" + apply (wp) + apply (clarsimp simp: globals_equiv_def detype_def idle_equiv_def tcb_at_def2) + done + +lemma detype_reads_respects_g: + "reads_respects_g aag l ((\s. arm_us_global_vspace (arch_state s) \ S) and (\s. idle_thread s \ S)) + (modify (detype S))" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_g) + apply (rule detype_reads_respects) + apply (rule doesnt_touch_globalsI[OF detype_globals_equiv]) + apply simp + done + +lemma delete_objects_reads_respects_g: + "reads_equiv_valid_g_inv (affects_equiv aag l) aag + (\s. arm_us_global_vspace (arch_state s) \ ptr_range p b \ + idle_thread s \ ptr_range p b \ + is_aligned p b \ 2 \ b \ b < word_bits) + (delete_objects p b)" + apply (simp add: delete_objects_def2) + apply (rule equiv_valid_guard_imp) + apply (wp dmo_freeMemory_reads_respects_g) + apply (rule detype_reads_respects_g) + apply wp + apply (unfold ptr_range_def) + apply simp + done + +lemma reset_untyped_cap_reads_respects_g: + "reads_equiv_valid_g_inv (affects_equiv aag (l :: 'a subject_label)) aag + (\s. cte_wp_at is_untyped_cap slot s \ invs s \ ct_active s \ only_timer_irq_inv irq st s \ + is_subject aag (fst slot) \ (descendants_of slot (cdt s) = {})) + (reset_untyped_cap slot)" + apply (simp add: reset_untyped_cap_def cong: if_cong) + apply (rule equiv_valid_guard_imp) + apply (wp set_cap_reads_respects_g dmo_clearMemory_reads_respects_g + | simp add: unless_def when_def split del: if_split)+ + apply (rule_tac I="invs and cte_wp_at (\cp. is_untyped_cap rv + \ (\idx. cp = free_index_update (\_. idx) rv) + \ free_index_of rv \ 2 ^ (bits_of rv) + \ is_subject aag (fst slot)) slot + and pspace_no_overlap (untyped_range rv) + and only_timer_irq_inv irq st + and (\s. descendants_of slot (cdt s) = {})" in mapME_x_ev) + apply (rule equiv_valid_guard_imp) + apply wp + apply (rule reads_respects_g_from_inv) + apply (rule preemption_point_reads_respects[where irq=irq and st=st]) + apply ((wp preemption_point_inv set_cap_reads_respects_g set_untyped_cap_invs_simple + only_timer_irq_inv_pres[where Q=\, OF _ set_cap_domain_sep_inv] + dmo_clearMemory_reads_respects_g + | simp)+) + apply (strengthen empty_descendants_range_in) + apply (wp only_timer_irq_inv_pres[where P=\ and Q=\] no_irq_clearMemory + | simp | wp (once) dmo_wp)+ + apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps bits_of_def) + apply (frule(1) caps_of_state_valid) + apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps + free_index_of_def invs_valid_global_objs) + apply (simp add: aligned_add_aligned is_aligned_shiftl) + apply (rule hoare_pre) + apply (wp preemption_point_inv' set_untyped_cap_invs_simple set_cap_cte_wp_at + set_cap_no_overlap only_timer_irq_inv_pres[where Q=\, OF _ set_cap_domain_sep_inv] + irq_state_independent_A_conjI + | simp)+ + apply (strengthen empty_descendants_range_in) + apply (wp only_timer_irq_inv_pres[where P=\ and Q=\] no_irq_clearMemory + | simp | wp (once) dmo_wp)+ + apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps bits_of_def) + apply (frule(1) caps_of_state_valid) + apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps free_index_of_def) + apply (wp | simp)+ + apply (wp delete_objects_reads_respects_g) + apply (simp add: if_apply_def2) + apply (strengthen invs_valid_global_objs) + apply (wp add: delete_objects_invs_ex hoare_vcg_const_imp_lift + delete_objects_pspace_no_overlap_again + only_timer_irq_inv_pres[where P=\ and Q=\] + delete_objects_valid_arch_state + del: Untyped_AI.delete_objects_pspace_no_overlap + | simp)+ + apply (rule get_cap_reads_respects_g) + apply (wp get_cap_wp) + apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps bits_of_def) + apply (frule(1) caps_of_state_valid) + apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps + free_index_of_def invs_valid_global_objs) + apply (frule valid_global_refsD2, clarsimp+) + apply (clarsimp simp: ptr_range_def[symmetric] global_refs_def descendants_range_def2) + apply (frule if_unsafe_then_capD[OF caps_of_state_cteD], clarsimp+) + apply (strengthen refl[where t=True] refl ex_tupleI[where t=slot] empty_descendants_range_in + | clarsimp)+ + apply (drule ex_cte_cap_protects[OF _ _ _ _ order_refl], erule caps_of_state_cteD) + apply (clarsimp simp: descendants_range_def2 empty_descendants_range_in) + apply clarsimp+ + apply (fastforce dest: invs_valid_global_arch_objs + simp: untyped_min_bits_def ptr_range_def) + done + +crunch init_arch_objects + for valid_global_objs[wp]: valid_global_objs + (wp: crunch_wps) + +lemma post_retype_invs_valid_global_objsI: + "post_retype_invs ty rv s \ valid_global_objs s" + by (clarsimp simp: post_retype_invs_def invs_def valid_state_def split: if_split_asm) + +lemma invoke_untyped_reads_respects_g_wcap[Retype_IF_assms]: + notes blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff + atLeastatMost_subset_iff atLeastLessThan_iff Int_atLeastAtMost + atLeastatMost_empty_iff split_paired_Ex + shows "reads_respects_g aag (l :: 'a subject_label) + (invs and valid_untyped_inv_wcap ui (Some (UntypedCap dev ptr sz idx)) + and only_timer_irq_inv irq st and ct_active and pas_refined aag + and K (authorised_untyped_inv aag ui)) + (invoke_untyped ui)" + apply (case_tac ui) + apply (rename_tac cslot_ptr reset ptr_base ptr' apiobject_type nat list dev') + apply (case_tac "\ (dev' = dev \ ptr = ptr' && ~~ mask sz)") + (* contradictory *) + apply (rule equiv_valid_guard_imp, rule_tac gen_asm_ev'[where P="\" and Q=False], simp) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (simp add: invoke_untyped_def mapM_x_def[symmetric]) + apply (wpsimp wp: mapM_x_ev'' create_cap_reads_respects_g + hoare_vcg_ball_lift init_arch_objects_reads_respects_g)+ + apply (wp retype_region_reads_respects_g[where sz=sz and slot="slot_of_untyped_inv ui"]) + apply (rule_tac Q'="\rvc s. (\x\set rvc. is_subject aag x) \ + (\x\set rvc. is_aligned x (obj_bits_api apiobject_type nat)) \ + ((0::obj_ref) < of_nat (length list)) \ + post_retype_invs apiobject_type rvc s \ + global_refs s \ set rvc = {} \ + (\x\set list. is_subject aag (fst x))" + for sz in hoare_strengthen_post) + apply (wp retype_region_ret_is_subject[where sz=sz, simplified] + retype_region_global_refs_disjoint[where sz=sz] + retype_region_aligned_for_init[where sz=sz] + retype_region_post_retype_invs_spec[where sz=sz]) + apply clarsimp + apply (fastforce simp: global_refs_def obj_bits_api_def + post_retype_invs_valid_arch_stateI + post_retype_invs_valid_global_objsI + pageBits_def default_arch_object_def + intro: post_retype_invs_pspace_alignedI + post_retype_invs_valid_arch_stateI + elim: in_set_zipE) + apply (rule set_cap_reads_respects_g) + apply simp + apply (wp hoare_vcg_ex_lift set_cap_cte_wp_at_cases + hoare_vcg_disj_lift set_cap_no_overlap + set_free_index_invs_UntypedCap + set_untyped_cap_caps_overlap_reserved + set_cap_caps_no_overlap + region_in_kernel_window_preserved) + apply (wp when_ev delete_objects_reads_respects_g hoare_vcg_disj_lift + delete_objects_pspace_no_overlap + delete_objects_descendants_range_in + delete_objects_caps_no_overlap + region_in_kernel_window_preserved + get_cap_reads_respects_g get_cap_wp + | simp split del: if_split)+ + apply (rule reset_untyped_cap_reads_respects_g[where irq=irq and st=st]) + apply (rule_tac P="authorised_untyped_inv aag ui \ + (\p \ ptr_range ptr sz. is_subject aag p)" in hoare_gen_asmE) + apply (rule validE_validE_R, + rule_tac E'="\\" + and Q'="\_. invs and valid_untyped_inv_wcap ui (Some (UntypedCap dev ptr sz (If reset 0 idx))) + and ct_active + and (\s. reset \ pspace_no_overlap {ptr .. ptr + 2 ^ sz - 1} s)" + in hoare_strengthen_postE) + apply (rule hoare_pre, wp whenE_wp) + apply (rule validE_validE_R, rule hoare_strengthen_postE, rule reset_untyped_cap_invs_etc) + apply (clarsimp simp only: if_True simp_thms, intro conjI, assumption+) + apply simp + apply assumption + apply clarify + apply (frule(2) invoke_untyped_proofs.intro) + apply (clarsimp simp: cte_wp_at_caps_of_state bits_of_def + free_index_of_def untyped_range_def + if_split[where P="\x. x \ unat v" for v] + split del: if_split) + apply (frule(1) valid_global_refsD2[OF _ invs_valid_global_refs]) + apply (strengthen refl) + apply (strengthen invs_valid_global_objs invs_arch_state) + apply (clarsimp simp: authorised_untyped_inv_def conj_comms invoke_untyped_proofs.simps) + apply (simp add: arg_cong[OF mask_out_sub_mask, where f="\y. x - y" for x] + field_simps invoke_untyped_proofs.idx_le_new_offs + invoke_untyped_proofs.idx_compare' untyped_range_def) + apply (strengthen caps_region_kernel_window_imp[mk_strg I E]) + apply (simp add: invoke_untyped_proofs.simps untyped_range_def invs_cap_refs_in_kernel_window + atLeastatMost_subset_iff[where b=x and d=x for x] + cong: conj_cong split del: if_split) + apply (intro conjI) + (* mostly clagged from Untyped_AI *) + apply (simp add: atLeastatMost_subset_iff word_and_le2) + apply (case_tac reset) + apply (clarsimp elim!: pspace_no_overlap_subset del: subsetI + simp: blah word_and_le2) + apply (drule invoke_untyped_proofs.ps_no_overlap) + apply (simp add: field_simps) + apply (simp add: Int_commute, erule disjoint_subset2[rotated]) + apply (simp add: atLeastatMost_subset_iff word_and_le2) + apply (clarsimp dest!: invoke_untyped_proofs.idx_le_new_offs) + apply (simp add: ptr_range_def) + apply (erule ball_subset, rule range_subsetI[OF _ order_refl]) + apply (simp add: word_and_le2) + apply (erule order_trans[OF invoke_untyped_proofs.subset_stuff]) + apply (simp add: atLeastatMost_subset_iff word_and_le2) + apply (drule invoke_untyped_proofs.usable_range_disjoint) + apply (clarsimp simp: field_simps mask_out_sub_mask shiftl_t2n) + apply blast + apply (clarsimp simp: cte_wp_at_caps_of_state authorised_untyped_inv_def) + apply (rule conjI; clarsimp) + apply (strengthen refl) + apply (frule(1) cap_auth_caps_of_state) + apply (simp add: aag_cap_auth_def untyped_range_def + aag_has_Control_iff_owns ptr_range_def[symmetric]) + apply (frule(1) cap_auth_caps_of_state) + apply (simp add: aag_cap_auth_def untyped_range_def + aag_has_Control_iff_owns ptr_range_def[symmetric]) + done + +lemma delete_objects_globals_equiv[wp]: + "\globals_equiv st and (\s. is_aligned p b \ 2 \ b \ b < word_bits \ + arm_us_global_vspace (arch_state s) \ ptr_range p b \ + idle_thread s \ ptr_range p b)\ + delete_objects p b + \\_. globals_equiv st\" + apply (simp add: delete_objects_def) + apply (wp detype_globals_equiv dmo_freeMemory_globals_equiv) + apply (clarsimp simp: ptr_range_def)+ + done + +lemma reset_untyped_cap_globals_equiv: + "\globals_equiv st and invs and cte_wp_at is_untyped_cap slot + and ct_active and (\s. descendants_of slot (cdt s) = {})\ + reset_untyped_cap slot + \\_. globals_equiv st\" + apply (simp add: reset_untyped_cap_def cong: if_cong) + apply (rule hoare_pre) + apply (wp set_cap_globals_equiv dmo_clearMemory_globals_equiv + preemption_point_inv | simp add: unless_def)+ + apply (rule valid_validE) + apply (rule_tac P="cap_aligned cap \ is_untyped_cap cap" in hoare_gen_asm) + apply (rule_tac Q'="\_ s. valid_global_objs s \ valid_arch_state s \ globals_equiv st s" + in hoare_strengthen_post) + apply (rule validE_valid, rule mapME_x_wp') + apply (rule hoare_pre) + apply (wp set_cap_globals_equiv dmo_clearMemory_globals_equiv + preemption_point_inv | simp add: if_apply_def2)+ + apply (clarsimp simp: is_cap_simps ptr_range_def[symmetric] + cap_aligned_def bits_of_def free_index_of_def) + apply (strengthen invs_valid_global_objs invs_arch_state) + apply (wp delete_objects_invs_ex hoare_vcg_const_imp_lift get_cap_wp)+ + apply (clarsimp simp: cte_wp_at_caps_of_state descendants_range_def2 is_cap_simps bits_of_def + split del: if_split) + apply (frule caps_of_state_valid_cap, clarsimp+) + apply (clarsimp simp: valid_cap_simps cap_aligned_def untyped_min_bits_def) + apply (frule valid_global_refsD2, clarsimp+) + apply (clarsimp simp: ptr_range_def[symmetric] global_refs_def) + apply (strengthen empty_descendants_range_in) + apply (cases slot, fastforce) + done + +lemma init_arch_objects_globals_equiv[wp]: + "init_arch_objects tp dev ptr n us refs \globals_equiv st\" + unfolding init_arch_objects_def cleanCacheRange_RAM_def cleanCacheRange_PoU_def + by (wpsimp wp: mapM_x_wp_inv) + +lemma invoke_untyped_globals_equiv: + notes blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff + atLeastatMost_subset_iff atLeastLessThan_iff Int_atLeastAtMost + atLeastatMost_empty_iff split_paired_Ex + shows "\globals_equiv st and invs and valid_untyped_inv ui and ct_active\ + invoke_untyped ui + \\_. globals_equiv st\" + apply (rule hoare_name_pre_state) + apply (rule hoare_pre, rule invoke_untyped_Q) + apply (wp create_cap_globals_equiv) + apply auto[1] + apply wpsimp + apply (rule hoare_pre, wp retype_region_globals_equiv[where slot="slot_of_untyped_inv ui"]) + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (strengthen refl) + apply simp + apply (wp set_cap_globals_equiv) + apply auto[1] + apply (wp reset_untyped_cap_globals_equiv) + apply (cases ui, clarsimp simp: cte_wp_at_caps_of_state) + done + +end + + +global_interpretation Retype_IF_2?: Retype_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Retype_IF_assms)?) +qed + + +arch_requalify_facts + reset_untyped_cap_reads_respects_g + reset_untyped_cap_globals_equiv + invoke_untyped_globals_equiv + storeWord_globals_equiv + +end diff --git a/proof/infoflow/AARCH64/ArchScheduler_IF.thy b/proof/infoflow/AARCH64/ArchScheduler_IF.thy new file mode 100644 index 0000000000..3a29f3a7ce --- /dev/null +++ b/proof/infoflow/AARCH64/ArchScheduler_IF.thy @@ -0,0 +1,1557 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchScheduler_IF +imports Scheduler_IF + +begin + +context Arch begin arch_global_naming + +named_theorems Scheduler_IF_assms + +definition arch_globals_equiv_scheduler :: "kheap \ kheap \ arch_state \ arch_state \ bool" where + "arch_globals_equiv_scheduler kh kh' as as' \ + arm_us_global_vspace as = arm_us_global_vspace as' \ kh (arm_us_global_vspace as) = kh' (arm_us_global_vspace as)" + +definition + "arch_scheduler_affects_equiv s s' \ True" + +lemma arch_globals_equiv_from_scheduler[Scheduler_IF_assms]: + "\ arch_globals_equiv_scheduler (kheap s) (kheap s') (arch_state s) (arch_state s'); + cur_thread s' \ idle_thread s \ arch_scheduler_affects_equiv s s' \ + \ arch_globals_equiv (cur_thread s') (idle_thread s) (kheap s) (kheap s') + (arch_state s) (arch_state s') (machine_state s) (machine_state s')" + by (clarsimp simp: arch_globals_equiv_scheduler_def arch_scheduler_affects_equiv_def) + +lemma arch_globals_equiv_scheduler_refl[Scheduler_IF_assms]: + "arch_globals_equiv_scheduler (kheap s) (kheap s) (arch_state s) (arch_state s)" + by (simp add: idle_equiv_refl arch_globals_equiv_scheduler_def) + +lemma arch_globals_equiv_scheduler_sym[Scheduler_IF_assms]: + "arch_globals_equiv_scheduler (kheap s) (kheap s') (arch_state s) (arch_state s') + \ arch_globals_equiv_scheduler (kheap s') (kheap s) (arch_state s') (arch_state s)" + by (auto simp: arch_globals_equiv_scheduler_def) + +lemma arch_globals_equiv_scheduler_trans[Scheduler_IF_assms]: + "\ arch_globals_equiv_scheduler (kheap s) (kheap s') (arch_state s) (arch_state s'); + arch_globals_equiv_scheduler (kheap s') (kheap s'') (arch_state s') (arch_state s'') \ + \ arch_globals_equiv_scheduler (kheap s) (kheap s'') (arch_state s) (arch_state s'')" + by (clarsimp simp: arch_globals_equiv_scheduler_def) + +lemma arch_scheduler_affects_equiv_trans[Scheduler_IF_assms, elim]: + "\ arch_scheduler_affects_equiv s s'; arch_scheduler_affects_equiv s' s'' \ + \ arch_scheduler_affects_equiv s s''" + by (simp add: arch_scheduler_affects_equiv_def) + +lemma arch_scheduler_affects_equiv_sym[Scheduler_IF_assms, elim]: + "arch_scheduler_affects_equiv s s' \ arch_scheduler_affects_equiv s' s" + by (simp add: arch_scheduler_affects_equiv_def) + +lemma arch_scheduler_affects_equiv_sa_update[Scheduler_IF_assms, simp]: + "arch_scheduler_affects_equiv (scheduler_action_update f s) s' = + arch_scheduler_affects_equiv s s'" + "arch_scheduler_affects_equiv s (scheduler_action_update f s') = + arch_scheduler_affects_equiv s s'" + by (auto simp: arch_scheduler_affects_equiv_def) + +lemma equiv_asid_cur_thread_update[Scheduler_IF_assms, simp]: + "equiv_asid asid (cur_thread_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (cur_thread_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma arch_scheduler_affects_equiv_ready_queues_update[Scheduler_IF_assms, simp]: + "arch_scheduler_affects_equiv (ready_queues_update f s) s' = arch_scheduler_affects_equiv s s'" + "arch_scheduler_affects_equiv s (ready_queues_update f s') = arch_scheduler_affects_equiv s s'" + by (auto simp: arch_scheduler_affects_equiv_def) + +crunch arch_switch_to_thread, arch_switch_to_idle_thread + for idle_thread[Scheduler_IF_assms, wp]: "\s :: det_state. P (idle_thread s)" + (wp: crunch_wps simp: crunch_simps) + +declare arch_prepare_next_domain_idle_thread[Scheduler_IF_assms] + +crunch arch_switch_to_thread, arch_switch_to_idle_thread + for cur_domain[Scheduler_IF_assms, wp]: "\s. P (cur_domain s)" + and domain_fields[Scheduler_IF_assms, wp]: "domain_fields P" + +lemma arch_switch_to_idle_thread_globals_equiv[Scheduler_IF_assms,wp]: + "\valid_arch_state and globals_equiv st\ arch_switch_to_idle_thread \\_. globals_equiv st\" + unfolding arch_switch_to_idle_thread_def + by wpsimp + +lemma arch_switch_to_idle_thread_work_units_completed[Scheduler_IF_assms,wp]: + "arch_switch_to_idle_thread \\s. P (work_units_completed s)\" + by wp + +crunch arch_activate_idle_thread + for cur_domain[Scheduler_IF_assms, wp]: "\s. P (cur_domain s)" + and idle_thread[Scheduler_IF_assms, wp]: "\s. P (idle_thread s)" + and irq_state_of_state[Scheduler_IF_assms, wp]: "\s. P (irq_state_of_state s)" + and domain_fields[Scheduler_IF_assms, wp]: "domain_fields P" + +lemma arch_scheduler_affects_equiv_cur_thread_update[Scheduler_IF_assms, simp]: + "arch_scheduler_affects_equiv (cur_thread_update f s) s' = arch_scheduler_affects_equiv s s'" + "arch_scheduler_affects_equiv s (cur_thread_update f s') = arch_scheduler_affects_equiv s s'" + by (auto simp: arch_scheduler_affects_equiv_def) + +lemma equiv_asid_domain_time_update[Scheduler_IF_assms, simp]: + "equiv_asid asid (domain_time_update f s) s' = equiv_asid asid s s'" + "equiv_asid asid s (domain_time_update f s') = equiv_asid asid s s'" + by (auto simp: equiv_asid_def) + +lemma arch_scheduler_affects_equiv_domain_time_update[Scheduler_IF_assms, simp]: + "arch_scheduler_affects_equiv (domain_time_update f s) s' = arch_scheduler_affects_equiv s s'" + "arch_scheduler_affects_equiv s (domain_time_update f s') = arch_scheduler_affects_equiv s s'" + by (auto simp: arch_scheduler_affects_equiv_def) + +crunch ackInterrupt + for irq_state[Scheduler_IF_assms, wp]: "\s. P (irq_state s)" + +lemma thread_set_context_globals_equiv[Scheduler_IF_assms]: + "\(\s. t = idle_thread s \ tc = idle_context s) and invs and globals_equiv st\ + thread_set (tcb_arch_update (arch_tcb_context_set tc)) t + \\rv. globals_equiv st\" + apply (clarsimp simp: thread_set_def) + apply (wpsimp wp: set_object_wp) + apply (subgoal_tac "t \ arm_us_global_vspace (arch_state s)") + apply (clarsimp simp: idle_equiv_def globals_equiv_def tcb_at_def2 get_tcb_def idle_context_def) + apply (clarsimp split: option.splits kernel_object.splits) + apply (fastforce simp: get_tcb_def obj_at_def valid_arch_state_def + dest: valid_global_arch_objs_pt_at invs_arch_state) + done + +lemma arch_scheduler_affects_equiv_update[Scheduler_IF_assms]: + "arch_scheduler_affects_equiv st s + \ arch_scheduler_affects_equiv st (s\kheap := (kheap s)(x \ TCB y')\)" + by (clarsimp simp: arch_scheduler_affects_equiv_def) + +lemma equiv_asid_equiv_update[Scheduler_IF_assms]: + "\ get_tcb x s = Some y; equiv_asid asid st s \ + \ equiv_asid asid st (s\kheap := (kheap s)(x \ TCB y')\)" + by (clarsimp simp: equiv_asid_def obj_at_def get_tcb_def) + +declare arch_activate_idle_thread_domain_fields_invs[Scheduler_IF_assms] + +end + + +arch_requalify_consts + arch_globals_equiv_scheduler + arch_scheduler_affects_equiv + +global_interpretation Scheduler_IF_1?: + Scheduler_IF_1 arch_globals_equiv_scheduler arch_scheduler_affects_equiv +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Scheduler_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +(* scheduler_affects_equiv - states_equiv_for_labels *) +definition scheduler_affects_inv where + "scheduler_affects_inv aag l st s \ + (reads_scheduler_cur_domain aag l st \ reads_scheduler_cur_domain aag l s \ + cur_thread st = cur_thread s \ + scheduler_action st = scheduler_action s \ + work_units_completed st = work_units_completed s \ + scheduler_globals_frame_equiv st s \ + idle_thread st = idle_thread s \ + (cur_thread st \ idle_thread s \ arch_scheduler_affects_equiv st s))" + +definition scheduler_inv where + "scheduler_inv aag l s s' \ + scheduler_equiv aag s s' \ scheduler_affects_inv aag l s s'" + +abbreviation (input) scheduler_can_read where + "scheduler_can_read aag l \ \l'. l' \ reads_scheduler aag l" + +lemma domains_distinct_states_equiv_for_labels: + "pas_domains_distinct aag + \ states_equiv_for_labels aag L s s' = states_equiv_but_for_labels aag (not L) s s'" + apply (rule iffI; erule states_equiv_for_guard_imp; clarsimp) + apply (fastforce simp: pas_domains_distinct_def) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x=x in allE, clarsimp) + done + +lemma scheduler_affects_equiv_def2: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "scheduler_affects_equiv aag l s s' \ + states_equiv_but_for_labels aag (not scheduler_can_read aag l) s s' \ scheduler_affects_inv aag l s s'" + apply (rule eq_reflection) + apply (simp only: domains_distinct_states_equiv_for_labels[OF domains_distinct,symmetric]) + apply (auto simp: scheduler_affects_equiv_def scheduler_affects_inv_def) + done + +lemma scheduler_inv_def2: + "scheduler_inv aag l s s' \ + domain_fields_equiv s s' \ idle_thread s = idle_thread s' \ + globals_equiv_scheduler s s' \ silc_dom_equiv aag s s' \ + irq_state_of_state s = irq_state_of_state s' \ + (reads_scheduler_cur_domain aag l s \ reads_scheduler_cur_domain aag l s' + \ (cur_thread s = cur_thread s' \ scheduler_action s = scheduler_action s' \ + work_units_completed s = work_units_completed s' \ + scheduler_globals_frame_equiv s s' \ + (cur_thread s \ idle_thread s' \ arch_scheduler_affects_equiv s s')))" + apply (rule eq_reflection) + apply (auto simp: scheduler_inv_def scheduler_equiv_def scheduler_affects_inv_def) + done + +lemma reads_respects_scheduler_def2: + "reads_respects_scheduler aag l P f \ + equiv_valid_inv (scheduler_inv aag l) (states_equiv_for_labels aag (scheduler_can_read aag l)) P f" + apply (rule eq_reflection) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (rule iff_allI)+ + apply (rule iffI; clarsimp) + apply (drule mp) + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def scheduler_inv_def2) + apply (drule (1) bspec, clarsimp)+ + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def scheduler_inv_def2) + apply (drule mp) + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def scheduler_inv_def2) + apply (drule (1) bspec, clarsimp)+ + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def scheduler_inv_def2) + done + +lemma domain_fields_equiv_sym: + "domain_fields_equiv st s = domain_fields_equiv s st" + by (auto simp: domain_fields_equiv_def) + +lemma reads_respects_scheduler_from_labels: + assumes ev: "\L. states_equiv_valid aag L P f" + and inv: "\P. \\s. P (cur_domain s) \ Q s\ f \\_ s. P (cur_domain s)\" + "\P. \\s. P (cur_thread s) \ Q s\ f \\_ s. P (cur_thread s)\" + "\P. \\s. P (idle_thread s) \ Q s\ f \\_ s. P (idle_thread s)\" + "\P. \\s. P (scheduler_action s) \ Q s\ f \\_ s. P (scheduler_action s)\" + "\P. \\s. P (work_units_completed s) \ Q s\ f \\_ s. P (work_units_completed s)\" + "\P. \\s. P (irq_state_of_state s) \ Q s\ f \\_ s. P (irq_state_of_state s)\" + "\P st. \\s. P (domain_fields_equiv st s) \ Q s\ f \\_ s. P (domain_fields_equiv st s)\" + "\P st. \\s. P (globals_equiv_scheduler st s) \ Q s\ f \\_ s. P (globals_equiv_scheduler st s)\" + "\P st. \\s. P (scheduler_globals_frame_equiv st s) \ Q s\ f \\_ s. P (scheduler_globals_frame_equiv st s)\" + "\P st. \\s. P (silc_dom_equiv aag st s) \ Q s\ f \\_ s. P (silc_dom_equiv aag st s)\" + shows "reads_respects_scheduler aag l (P and Q) f" + apply (simp add: reads_respects_scheduler_def2) + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + unfolding scheduler_inv_def2 + apply (rule hoare_weaken_pre) + apply clarsimp + apply (rule hoare_lift_Pf2_pre_conj[where f=cur_domain, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=cur_thread, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=idle_thread, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=idle_thread, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=scheduler_action, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=work_units_completed, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=irq_state_of_state, rotated], wp inv) + apply (rule hoare_lift_Pf2_pre_conj[where f=idle_thread, rotated], wp inv) + apply (rule_tac f="domain_fields_equiv st" in hoare_lift_Pf2_pre_conj[rotated], wp inv) + apply (rule_tac f="globals_equiv_scheduler st" in hoare_lift_Pf2_pre_conj[rotated], wp inv) + apply (rule_tac f="scheduler_globals_frame_equiv st" in hoare_lift_Pf2_pre_conj[rotated], wp inv) + apply (rule_tac f="silc_dom_equiv aag st" in hoare_lift_Pf2_pre_conj[rotated], wp inv) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + apply wp + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + apply (auto simp: domain_fields_equiv_sym globals_equiv_scheduler_sym silc_dom_equiv_sym + scheduler_globals_frame_equiv_sym arch_scheduler_affects_equiv_sym)[2] + apply (insert ev) + apply (fastforce elim: wp_pre) + done + +definition swap_things where + "swap_things s t \ + t\machine_state := underlying_memory_update + (\m a. if a \ scheduler_affects_globals_frame t + then underlying_memory (machine_state s) a + else m a) + (machine_state t)\ + \cur_thread := cur_thread s\" + +lemma globals_equiv_scheduler_inv'[Scheduler_IF_assms]: + "(\st. \P and globals_equiv st\ f \\_. globals_equiv st\) + \ \P and globals_equiv_scheduler s\ f \\_. globals_equiv_scheduler s\" + apply atomize + apply (rule use_spec) + apply (simp add: spec_valid_def) + apply (erule_tac x="(swap_things sa s)" in allE) + apply (rule_tac Q'="\r st. globals_equiv (swap_things sa s) st" in hoare_strengthen_post) + apply (rule hoare_pre) + apply assumption + apply (clarsimp simp: globals_equiv_def swap_things_def globals_equiv_scheduler_def + arch_globals_equiv_scheduler_def arch_scheduler_affects_equiv_def)+ + done + +crunch vcpu_switch + for global_pt[wp]: "\s. P (global_pt s)" + (wp: valid_global_arch_objs_lift) + +crunch vcpu_switch + for valid_global_arch_objs[wp]: "valid_global_arch_objs" + (wp: valid_global_arch_objs_lift) + +lemma arch_switch_to_thread_globals_equiv_scheduler[Scheduler_IF_assms]: + "\invs and globals_equiv_scheduler sta\ + arch_switch_to_thread thread + \\_. globals_equiv_scheduler sta\" + unfolding arch_switch_to_thread_def storeWord_def + apply (wpsimp wp: dmo_wp modify_wp thread_get_wp' lazy_fpu_restore_globals_equiv + globals_equiv_scheduler_inv'[where P="invs"]) + apply (auto intro: sym_refs_VCPU_hyp_live) + done + +crunch arch_activate_idle_thread + for silc_dom_equiv[Scheduler_IF_assms, wp]: "silc_dom_equiv aag st" + and scheduler_affects_equiv[Scheduler_IF_assms, wp]: "scheduler_affects_equiv aag l st" + +lemma set_vm_root_arch_scheduler_affects_equiv[wp]: + "set_vm_root tcb \arch_scheduler_affects_equiv st\" + unfolding arch_scheduler_affects_equiv_def by wpsimp + +lemmas set_vm_root_scheduler_affects_equiv[wp] = + scheduler_affects_equiv_unobservable[OF set_vm_root_states_equiv_for + set_vm_root_cur_domain _ _ _ set_vm_root_it + set_vm_root_arch_scheduler_affects_equiv] + +lemma set_vm_root_reads_respects_scheduler[wp]: + "reads_respects_scheduler aag l valid_global_arch_objs (set_vm_root thread)" + apply (rule reads_respects_scheduler_unobservable'[OF scheduler_equiv_lift' + [OF globals_equiv_scheduler_inv']]) + apply (wp silc_dom_equiv_states_equiv_lift set_vm_root_states_equiv_for | simp)+ + done + +lemma store_cur_thread_fragment_midstrength_reads_respects: + "equiv_valid (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (scheduler_affects_equiv aag l) \ + (do x \ modify (cur_thread_update (\_. t)); + set_scheduler_action resume_cur_thread + od)" + apply (rule equiv_valid_guard_imp) + apply (rule equiv_valid_weaken_pre) + apply (rule ev_asahi_ex_to_full_fragement) + apply (auto simp: midstrength_scheduler_affects_equiv_def asahi_scheduler_affects_equiv_def + asahi_ex_scheduler_affects_equiv_def states_equiv_for_def equiv_for_def + arch_scheduler_affects_equiv_def equiv_asids_def equiv_asid_def + scheduler_globals_frame_equiv_def + simp del: split_paired_All) + done + +lemma set_vm_root_globals_equiv_scheduler: + "\invs and globals_equiv_scheduler sta\ + set_vm_root t + \\_. globals_equiv_scheduler sta\" + by (rule globals_equiv_scheduler_inv', wpsimp) + +lemma equiv_valid_inv_A_conjI: + "\ equiv_valid_inv I A P f; equiv_valid_rv_inv I A' \\ P f \ + \ equiv_valid_inv I (\s s'. A s s' \ A' s s') P f" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule_tac x=s in allE, erule_tac x=s in allE) + apply (erule_tac x=t in allE, erule_tac x=t in allE) + apply fastforce + done + +lemma scheduler_globals_frame_equiv_triv[simp]: + "scheduler_globals_frame_equiv st s" + by (clarsimp simp: scheduler_globals_frame_equiv_def) + +lemma midstrength_reads_respects_scheduler_from_labels: + assumes ev: "\L. states_equiv_valid aag L P f" + assumes inv: "\P. \\s. P (idle_thread s) \ Q s\ f \\_ s. P (idle_thread s)\" + "\P. \\s. P (irq_state_of_state s) \ Q s\ f \\_ s. P (irq_state_of_state s)\" + "\P. \\s. P (work_units_completed s) \ Q s\ f \\_ s. P (work_units_completed s)\" + "\P. \\s. P (cur_domain s) \ Q s\ f \\_ s. P (cur_domain s)\" + "\st. \\s. domain_fields_equiv st s \ Q s\ f \\_ s. domain_fields_equiv st s\" + "\st. \\s. globals_equiv_scheduler st s \ Q s\ f \\_ s. globals_equiv_scheduler st s\" + "\st. \\s. silc_dom_equiv aag st s \ Q s\ f \\_ s. silc_dom_equiv aag st s\" + shows "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) (P and Q) f" + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + unfolding scheduler_equiv_def + apply (wpsimp wp: inv) + apply (auto simp: domain_fields_equiv_sym globals_equiv_scheduler_sym silc_dom_equiv_sym)[2] + unfolding midstrength_scheduler_affects_equiv_def + apply (rule equiv_valid_inv_A_conjI) + apply (rule_tac Q=P in equiv_valid_guard_imp) + apply (insert ev)[1] + apply fastforce + apply simp + apply (rule_tac Q=Q and Q'=Q in equiv_valid_2_guard_imp) + apply (rule equiv_valid_rv_inv_lift) + apply (wpsimp wp: inv hoare_vcg_imp_lift)+ + apply auto + done + +lemma weak_reads_respects_scheduler_from_labels: + assumes ev: "\L. states_equiv_valid aag L P f" + and inv: "\P. \\s. P (idle_thread s) \ Q s\ f \\_ s. P (idle_thread s)\" + "\P. \\s. P (irq_state_of_state s) \ Q s\ f \\_ s. P (irq_state_of_state s)\" + "\P. \\s. P (cur_domain s) \ Q s\ f \\_ s. P (cur_domain s)\" + "\st. \\s. domain_fields_equiv st s \ Q s\ f \\_ s. domain_fields_equiv st s\" + "\st. \\s. globals_equiv_scheduler st s \ Q s\ f \\_ s. globals_equiv_scheduler st s\" + "\st. \\s. silc_dom_equiv aag st s \ Q s\ f \\_ s. silc_dom_equiv aag st s\" + shows "equiv_valid_inv (scheduler_equiv aag) (weak_scheduler_affects_equiv aag l) (P and Q) f" + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + unfolding scheduler_equiv_def + apply (wpsimp wp: inv) + apply (auto simp: domain_fields_equiv_sym globals_equiv_scheduler_sym silc_dom_equiv_sym)[2] + unfolding weak_scheduler_affects_equiv_def + apply (rule_tac Q=P in equiv_valid_guard_imp) + apply (insert ev)[1] + apply fastforce + apply simp + done + +lemmas globals_equiv_scheduler_inv = globals_equiv_scheduler_inv'[where P="\",simplified] + +lemmas set_global_user_vspace_globals_equiv_scheduler[wp] = + globals_equiv_scheduler_inv[OF set_global_user_vspace_globals_equiv] + +lemma set_vcpu_silc_dom_equiv: + "\silc_dom_equiv aag st and valid_silc_label aag\ set_vcpu ptr vcpu \\_. silc_dom_equiv aag st\" + unfolding set_vcpu_def + by (wpsimp wp: set_object_silc_dom_equiv simp: is_cap_table_def) + +crunch vcpu_save_reg + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +lemma vcpu_save_reg_range_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ + vcpu_save_reg_range vr from to + \\_. silc_dom_equiv aag st\" + unfolding vcpu_save_reg_range_def + apply (rule hoare_strengthen_post) + apply (rule mapM_x_wp_inv) + apply (wpsimp wp: valid_silc_label_lift)+ + done + +crunch vcpu_save, vcpu_restore + for silc_dom_equiv: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +crunch vcpu_switch + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +crunch arch_switch_to_idle_thread + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +crunch arch_switch_to_thread + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +crunch arch_prepare_next_domain + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + and typ_at[wp]: "\s. P (typ_at T ptr s)" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + +lemma next_domain_snippet_cur_vcpu_in_cur_domain: + "\\\ do y <- arch_prepare_next_domain; + next_domain + od + \\_. cur_vcpu_in_cur_domain\" + unfolding arch_prepare_next_domain_def + by wpsimp + +lemma next_domain_snippet_cur_fpu_in_cur_domain: + "\\\ do y <- arch_prepare_next_domain; + next_domain + od + \\_. cur_fpu_in_cur_domain\" + unfolding arch_prepare_next_domain_def + by wpsimp + +lemmas [Scheduler_IF_assms] = + arch_switch_to_thread_silc_dom_equiv + arch_switch_to_idle_thread_silc_dom_equiv + set_scheduler_action_cur_vcpu_in_cur_domain + set_scheduler_action_cur_fpu_in_cur_domain + tcb_sched_action_cur_vcpu_in_cur_domain + tcb_sched_action_cur_fpu_in_cur_domain + next_domain_snippet_cur_vcpu_in_cur_domain + next_domain_snippet_cur_fpu_in_cur_domain + arch_prepare_next_domain_silc_dom_equiv + arch_prepare_next_domain_typ_at + +lemma vcpu_switch_globals_equiv_scheduler[wp]: + "\valid_arch_state and globals_equiv_scheduler s\ vcpu_switch vr \\_. globals_equiv_scheduler s\" + by (wp globals_equiv_scheduler_inv' vcpu_switch_globals_equiv | fastforce)+ + +lemma vcpu_switch_midstrength_reads_respects_scheduler: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) (vcpu_switch vopt)" + apply (rule equiv_valid_guard_imp) + apply (rule midstrength_reads_respects_scheduler_from_labels) + apply (rule vcpu_switch_states_equiv_valid) + apply (wpsimp wp: domain_fields_equiv_lift | erule conjunct1)+ + done + +lemma set_global_user_vspace_states_equiv_for[wp]: + "set_global_user_vspace \states_equiv_for P Q R S st\" + unfolding set_global_user_vspace_def setVSpaceRoot_def + by (wpsimp wp: do_machine_op_mol_states_equiv_for) + +lemma set_global_user_vspace_midstrength_reads_respects: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + \ set_global_user_vspace" + apply (rule equiv_valid_inv_unobservable) + apply (rule hoare_pre) + apply (rule scheduler_equiv_lift') + apply wpsimp+ + apply (wp midstrength_scheduler_affects_equiv_unobservable + | simp | wps)+ + apply (auto simp: scheduler_equiv_sym midstrength_scheduler_affects_equiv_sym) + done + +lemma arch_switch_to_idle_thread_midstrength_reads_respects[Scheduler_IF_assms]: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) arch_switch_to_idle_thread" + unfolding arch_switch_to_idle_thread_def + by (wp set_global_user_vspace_midstrength_reads_respects vcpu_switch_midstrength_reads_respects_scheduler) + +lemma arch_switch_to_idle_thread_globals_equiv_scheduler[Scheduler_IF_assms, wp]: + "\valid_arch_state and globals_equiv_scheduler sta\ + arch_switch_to_idle_thread + \\_. globals_equiv_scheduler sta\" + unfolding arch_switch_to_idle_thread_def storeWord_def + by (wp dmo_wp modify_wp thread_get_wp' set_vm_root_globals_equiv_scheduler) + +lemma states_equiv_but_for_labels_equiv_for_lift: + assumes "\st. \\s. equiv_but_for_labels aag {l. L l} st s \ Q s\ f \\_. equiv_but_for_labels aag {l. L l} st\" + shows "\\s. states_equiv_but_for_labels aag L st s \ Q s\ f \\_. states_equiv_but_for_labels aag L st\" + apply (clarsimp simp: valid_def) + apply (prop_tac "equiv_but_for_labels aag {l. L l} s s") + apply (clarsimp simp: equiv_but_for_labels_def states_equiv_for_refl) + apply (insert assms) + apply (erule_tac x=s in meta_allE) + apply (drule use_valid) + apply assumption + apply simp + apply (clarsimp simp: equiv_but_for_labels_def) + apply (erule (1) states_equiv_for_trans) + done + +lemma vcpu_switch_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ + (\vr. vopt = Some vr \ pasObjectAbs aag vr \ L) \ + (\vr b. current_vcpu s = Some (vr,b) \ pasObjectAbs aag vr \ L)\ + vcpu_switch vopt + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_switch_def + apply (wpc | wp modify_current_vcpu_equiv_but_for_labels)+ + apply clarsimp + apply (rule conjI) + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + apply clarsimp + apply (rule conjI) + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + apply clarsimp + apply (case_tac b) + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + apply clarsimp + apply (case_tac "a = x") + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + apply clarsimp + apply (clarsimp simp: cur_vcpu_for_Some) + done + +lemma vcpu_switch_None_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ + (\vr b. current_vcpu s = Some (vr,True) \ pasObjectAbs aag vr \ L)\ + vcpu_switch None + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_switch_def + apply (wpc | wp modify_current_vcpu_equiv_but_for_labels)+ + apply (auto simp: cur_vcpu_of_def cur_vcpu_for_def)[1] + done + +lemma tcb_invisible: + "\ \ reads_scheduler_cur_domain aag l s; pas_refined aag s; in_cur_domain t s; tcb_at t s \ + \ pasObjectAbs aag t \ reads_scheduler aag l" + apply (drule tcb_at_ko_at, clarsimp) + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply simp + by blast + +lemma vcpu_controls_associated_tcb: + "\ pas_refined aag s; vcpus_of s v = Some vcpu; vcpu_tcb vcpu = Some t \ + \ (v, Control, t) \ state_objs_to_policy s" + by (fastforce simp: sbta_href state_objs_to_policy_def state_hyp_refs_of_def opt_map_def + dest: pas_refined_mem is_subject_trans split: option.splits)+ + +(* FIXME AARCH64 IF: move *) +lemma invs_cur_vcpu: + "invs s \ cur_vcpu s" + by (auto simp: invs_def valid_state_def valid_arch_state_def) + +lemma vcpu_invisible: + assumes nrs: "\ reads_scheduler_cur_domain aag l s" + and pwn: "pas_wellformed_noninterference aag" + shows + "\ pas_refined aag s; valid_silc_label aag s; + invs s; current_vcpu s = Some (vr,b); cur_vcpu_in_cur_domain s \ + \ pasObjectAbs aag vr \ reads_scheduler aag l" + apply (prop_tac "cur_vcpu s") + apply (erule invs_cur_vcpu) + apply (clarsimp simp: cur_vcpu_def opt_pred_def split: option.splits) + apply (clarsimp simp: cur_vcpu_in_cur_domain_def cur_vcpu_tcb_def) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (rename_tac t vcpu) + apply (prop_tac "tcb_at t s") + apply (drule invs_valid_objs) + apply (erule (1) valid_objsE) + apply (clarsimp simp: valid_obj_def valid_vcpu_def obj_at_def) + apply (frule (2) tcb_invisible[OF nrs]) + apply (frule_tac vcpu=vcpu in vcpu_controls_associated_tcb) + apply (fastforce simp: opt_map_def split: option.splits) + apply simp + apply (prop_tac "pasObjectAbs aag vr \ SilcLabel") + apply (fastforce simp: valid_silc_label_def obj_at_def is_cap_table_def) + apply (drule (1) pas_refined_mem) + apply (drule aag_wellformed_Control) + using pwn apply (fastforce simp: pas_wellformed_noninterference_def) + apply simp + done + +lemma arch_switch_to_idle_thread_unobservable[Scheduler_IF_assms]: + assumes wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + arch_switch_to_idle_thread + \\_ s. scheduler_affects_equiv aag l st s\" + apply (simp add: arch_switch_to_idle_thread_def) + apply wp + apply (rule scheduler_affects_equiv_unobservable) + apply wpsimp+ + apply (unfold arch_scheduler_affects_equiv_def)[1] + apply wpsimp + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + apply (wp states_equiv_but_for_labels_equiv_for_lift) + apply (wp vcpu_switch_None_equiv_but_for_labels) + apply (simp add: scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply wps + apply wpsimp + using wellformed apply (clarsimp simp: vcpu_invisible) + done + +lemma lazy_fpu_restore_equiv_but_for_labels: + "\\s. equiv_but_for_labels aag L st s \ (\t. cur_fpu_of s t \ pasObjectAbs aag t \ L) \ + pasObjectAbs aag t \ L \ valid_cur_fpu s\ + lazy_fpu_restore t + \\_. equiv_but_for_labels aag L st\" + unfolding lazy_fpu_restore_def + apply wpsimp + apply (wp switch_local_fpu_owner_equiv_but_for_labels) + apply wpsimp+ + apply (wp thread_get_wp') + apply clarsimp + done + +lemma cur_fpu_invisible: + "\ pas_refined aag s; \ reads_scheduler_cur_domain aag l s; cur_fpu_in_cur_domain s; + valid_cur_fpu s; current_fpu s = Some t \ + \ pasObjectAbs aag t \ reads_scheduler aag l" + apply (clarsimp simp: cur_fpu_in_cur_domain_def) + apply (frule current_fpu_owner_Some_tcb_at, fastforce) + apply (drule tcb_at_ko_at, clarsimp) + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply simp + by blast + +lemma states_equiv_for_helper: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "states_equiv_for (\x. pasObjectAbs aag x \ reads_scheduler aag l) + (\x. pasIRQAbs aag x \ reads_scheduler aag l) + (\x. pasASIDAbs aag x \ reads_scheduler aag l) + (\x. \la\pasDomainAbs aag x. la \ reads_scheduler aag l) + st s = + states_equiv_but_for_labels aag (\l'. l' \ reads_scheduler aag l) st s" + apply clarsimp + apply (rule iffI; erule rsubst[where P="\x. states_equiv_for _ _ _ x _ _"]; rule ext) + using domains_distinct + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x=x in allE) + apply clarsimp + using domains_distinct + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x=x in allE) + apply clarsimp + done + +lemma lazy_fpu_restore_scheduler_affects_equiv: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "\\s. scheduler_affects_equiv aag l st s \ pas_refined aag s \ + \ reads_scheduler_cur_domain aag l s \ pasObjectAbs aag t \ reads_scheduler aag l \ + cur_fpu_in_cur_domain s \ valid_cur_fpu s\ + lazy_fpu_restore t + \\_. scheduler_affects_equiv aag l st\" + apply (rule wp_pre) + unfolding scheduler_affects_equiv_def + apply (rule hoare_vcg_conj_lift) + defer + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + apply (wpsimp wp: hoare_vcg_imp_lift' simp: scheduler_globals_frame_equiv_def) + apply (rule conjI) + prefer 2 + apply clarsimp + defer + apply (rule_tac Q'="\_. states_equiv_but_for_labels aag (\l'. l' \ reads_scheduler aag l) st" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp:) + apply (subst states_equiv_for_helper[OF domains_distinct]) + apply (clarsimp simp: equiv_but_for_labels_def) + apply (wp states_equiv_but_for_labels_equiv_for_lift) + apply (wp lazy_fpu_restore_equiv_but_for_labels) + apply (subst (asm) states_equiv_for_helper[OF domains_distinct]) + apply (clarsimp simp: equiv_but_for_labels_def) + apply (clarsimp simp: cur_fpu_invisible) + done + +lemma vcpu_switch_scheduler_affects_equiv: + assumes wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + K (\vr. vopt = Some vr \ pasObjectAbs aag vr \ reads_scheduler aag l) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + vcpu_switch vopt + \\_ s. scheduler_affects_equiv aag l st s\" + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + apply (wp states_equiv_but_for_labels_equiv_for_lift) + apply (wp vcpu_switch_equiv_but_for_labels) + apply (unfold scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply simp + apply wps + apply wpsimp + apply simp + using wellformed apply (clarsimp simp: vcpu_invisible) + done + +lemma tcb_controls_associated_vcpu: + "\ pas_refined aag s; get_tcb t s = Some tcb; tcb_vcpu (tcb_arch tcb) = Some v \ + \ (t, Control, v) \ state_objs_to_policy s" + by (fastforce simp: sbta_href state_objs_to_policy_def state_hyp_refs_of_def get_tcb_def + dest: pas_refined_mem is_subject_trans split: option.splits kernel_object.splits)+ + +lemma associated_vcpu_invisible: + "\ pas_wellformed_noninterference aag; pasObjectAbs aag t \ reads_scheduler aag l; + pas_refined aag s; valid_silc_label aag s; invs s; + get_tcb t s = Some tcb; tcb_vcpu (tcb_arch tcb) = Some vr \ + \ pasObjectAbs aag vr \ reads_scheduler aag l" + apply (frule (2) tcb_controls_associated_vcpu) + apply (prop_tac "pasObjectAbs aag t \ SilcLabel") + apply (fastforce simp: valid_silc_label_def obj_at_def is_cap_table_def get_tcb_Some) + apply (drule (1) pas_refined_mem) + apply (drule aag_wellformed_Control) + apply (fastforce simp: pas_wellformed_noninterference_def) + apply simp + done + +lemma arch_switch_to_thread_unobservable[Scheduler_IF_assms]: + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + (\s. pasObjectAbs aag t \ reads_scheduler aag l) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and cur_fpu_in_cur_domain and + valid_silc_label aag and pas_refined aag\ + arch_switch_to_thread t + \\_ s. scheduler_affects_equiv aag l st s\" + apply (simp add: arch_switch_to_thread_def) + apply (wp set_vm_root_scheduler_affects_equiv lazy_fpu_restore_scheduler_affects_equiv + vcpu_switch_scheduler_affects_equiv | simp)+ + apply clarsimp + apply (rule conjI) + prefer 2 + apply fastforce + using wellformed by (clarsimp simp: associated_vcpu_invisible) + +(* Can split, but probably more effort to generalise *) +lemma next_domain_midstrength_equiv_scheduler[Scheduler_IF_assms]: + "equiv_valid (scheduler_equiv aag) (weak_scheduler_affects_equiv aag l) + (midstrength_scheduler_affects_equiv aag l) \ next_domain" + apply (simp add: next_domain_def) + apply (subst is_extended.dxo_eq) + apply (clarsimp simp: is_extended_def is_extended'_def is_extended_axioms_def) + apply wpsimp + apply (clarsimp simp: modify_modify) + apply (rule ev_modify) + apply (clarsimp simp: equiv_for_def equiv_asid_def equiv_asids_def Let_def scheduler_equiv_def + globals_equiv_scheduler_def silc_dom_equiv_def domain_fields_equiv_def + weak_scheduler_affects_equiv_def midstrength_scheduler_affects_equiv_def + states_equiv_for_def idle_equiv_def equiv_hyp_def equiv_fpu_def cur_fpu_for_def get_tcb_def) + done + +lemma resetTimer_irq_state[wp]: + "resetTimer \\s. P (irq_state s)\" + apply (simp add: resetTimer_def machine_op_lift_def machine_rest_lift_def) + apply (wp | wpc| simp)+ + done + +lemma dmo_resetTimer_underlying_memory[wp]: + "do_machine_op resetTimer \\s. P (underlying_memory (machine_state s))\" + by (wpsimp wp: dmo_wp) + +lemma dmo_resetTimer_device_state[wp]: + "do_machine_op resetTimer \\s. P (device_state (machine_state s))\" + by (wpsimp wp: dmo_wp) + +lemma dmo_resetTimer_vcpu_state[wp]: + "do_machine_op resetTimer \\s. P (vcpu_state (machine_state s))\" + by (wpsimp wp: dmo_wp) + +lemma dmo_resetTimer_fpu_state[wp]: + "do_machine_op resetTimer \\s. P (fpu_state (machine_state s))\" + by (wpsimp wp: dmo_wp) + +lemma dmo_resetTimer_tcb_cur_fpu_of[wp]: + "do_machine_op resetTimer \\s. P (tcb_cur_fpu_of s)\" + by (wpsimp wp: dmo_wp simp: comp_def) + +lemma dmo_resetTimer_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l \ (do_machine_op resetTimer)" + apply (rule reads_respects_scheduler_unobservable) + apply (rule scheduler_equiv_lift) + apply (simp add: globals_equiv_scheduler_def[abs_def] idle_equiv_def) + apply (wpsimp wp: dmo_wp) + apply ((wp silc_dom_lift dmo_wp | simp)+)[5] + apply (rule scheduler_affects_equiv_unobservable) + unfolding states_equiv_for_def[abs_def] + apply (wp equiv_for_lift equiv_machine_state_lift equiv_asids_lift equiv_hyp_lift equiv_fpu_lift)+ + apply (wpsimp wp: dmo_wp simp: arch_scheduler_affects_equiv_def) + done + +lemma ackInterrupt_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l \ (do_machine_op (ackInterrupt irq))" + apply (rule reads_respects_scheduler_unobservable) + apply (rule scheduler_equiv_lift) + apply (simp add: globals_equiv_scheduler_def[abs_def] idle_equiv_def) + apply (rule hoare_pre) + apply wps + apply (wp dmo_wp ackInterrupt_irq_masks | simp add:no_irq_def)+ + apply clarsimp + apply ((wp silc_dom_lift dmo_wp | simp)+)[5] + apply (rule scheduler_affects_equiv_unobservable) + apply (simp add: states_equiv_for_def[abs_def] equiv_for_def equiv_asids_def equiv_asid_def) + apply (rule hoare_pre) + apply wps + apply (wp dmo_wp | simp add: arch_scheduler_affects_equiv_def ackInterrupt_def)+ + done + +lemma thread_set_scheduler_affects_equiv[Scheduler_IF_assms, wp]: + "\(\s. x \ idle_thread s \ pasObjectAbs aag x \ reads_scheduler aag l) and + (\s. x = idle_thread s \ tc = idle_context s) and scheduler_affects_equiv aag l st\ + thread_set (tcb_arch_update (arch_tcb_context_set tc)) x + \\_. scheduler_affects_equiv aag l st\" + apply (simp add: thread_set_def) + apply (wp set_object_wp) + apply (intro impI conjI) + apply (case_tac "x \ idle_thread s",simp_all) + apply (clarsimp simp: scheduler_affects_equiv_def get_tcb_def scheduler_globals_frame_equiv_def + split: option.splits kernel_object.splits) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + apply (elim states_equiv_forE equiv_forE) + apply (rule states_equiv_forI,simp_all add: equiv_for_def equiv_asids_def equiv_asid_def) + apply (clarsimp simp: obj_at_def) + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) + apply (clarsimp simp: idle_context_def get_tcb_def + split: option.splits kernel_object.splits) + apply (subst arch_tcb_update_aux) + apply simp + apply (subgoal_tac "s = (s\kheap := (kheap s)(idle_thread s \ TCB y)\)", simp) + apply (rule state.equality) + apply (rule ext) + apply simp+ + done + + +lemma thread_set_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l (valid_arch_state and K (valid_tcb_context_update f)) + (thread_set f t)" + apply (rule gen_asm_ev) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + unfolding thread_set_def gets_the_def gets_def get_def put_def return_def fail_def + set_object_def get_object_def assert_def assert_opt_def + apply (clarsimp simp: bind_def split: option.splits if_splits) + apply (clarsimp simp: get_tcb_ko_at obj_at_def) + unfolding valid_tcb_context_update_def + apply (rename_tac s' tcb tcb') + apply (erule_tac x=tcb in allE) + apply (erule_tac x=tcb' in allE) + apply (rule conjI) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def) + apply (intro conjI) + apply (clarsimp simp: valid_global_arch_objs_def arch_globals_equiv_scheduler_def) + apply (clarsimp simp: idle_equiv_def tcb_at_def get_tcb_def arch_tcb_context_get_def) + apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI; clarsimp?) + apply (clarsimp simp: equiv_asids_def equiv_asid_def obj_at_def) + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def arch_tcb_context_set_def arch_tcb_context_get_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def arch_scheduler_affects_equiv_def) + done + +lemma arch_activate_idle_thread_reads_respects_scheduler[Scheduler_IF_assms, wp]: + "reads_respects_scheduler aag l \ (arch_activate_idle_thread rv)" + unfolding arch_activate_idle_thread_def by wpsimp + +lemma tcb_visible: + "\ reads_scheduler_cur_domain aag l s; pas_refined aag s; + pas_domains_distinct aag; in_cur_domain t s; tcb_at t s \ + \ pasObjectAbs aag t \ reads_scheduler aag l" + apply (drule tcb_at_ko_at, clarsimp) + apply (drule ko_at_etcbD) + apply (frule (1) tcb_domain_wellformed) + apply (prop_tac "etcb_domain (etcb_of tcb) = cur_domain s") + apply (clarsimp simp: in_cur_domain_def) + apply (clarsimp simp: etcbs_of'_def etcb_at'_def split: option.splits kernel_object.splits) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE) + apply clarsimp + done + +lemma associated_vcpu_visible: + assumes nrs: "reads_scheduler_cur_domain aag l s" + and pwn: "pas_wellformed_noninterference aag" + shows + "\ pasObjectAbs aag t \ reads_scheduler aag l; + pas_refined aag s; valid_silc_label aag s; invs s; + get_tcb t s = Some tcb; tcb_vcpu (tcb_arch tcb) = Some vr \ + \ pasObjectAbs aag vr \ reads_scheduler aag l" + apply (frule (2) tcb_controls_associated_vcpu) + apply (prop_tac "pasObjectAbs aag t \ SilcLabel") + apply (fastforce simp: valid_silc_label_def obj_at_def is_cap_table_def get_tcb_Some) + apply (drule (1) pas_refined_mem) + apply (drule aag_wellformed_Control) + using pwn apply (fastforce simp: pas_wellformed_noninterference_def) + apply simp + done + +lemma vcpu_visible: + assumes rs: "reads_scheduler_cur_domain aag l s" + and wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\ pas_refined aag s; valid_silc_label aag s; + invs s; current_vcpu s = Some (vr,b); cur_vcpu_in_cur_domain s \ + \ pasObjectAbs aag vr \ reads_scheduler aag l" + apply (prop_tac "cur_vcpu s") + apply (erule invs_cur_vcpu) + apply (clarsimp simp: cur_vcpu_def opt_pred_def split: option.splits) + apply (clarsimp simp: cur_vcpu_in_cur_domain_def cur_vcpu_tcb_def) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (rename_tac t vcpu) + apply (prop_tac "tcb_at t s") + apply (drule invs_valid_objs) + apply (erule (1) valid_objsE) + apply (clarsimp simp: valid_obj_def valid_vcpu_def obj_at_def) + apply (frule (2) tcb_visible[OF rs _ domains_distinct]) + apply (frule_tac vcpu=vcpu in vcpu_controls_associated_tcb) + apply (fastforce simp: opt_map_def split: option.splits) + apply simp + apply (prop_tac "pasObjectAbs aag vr \ SilcLabel") + apply (fastforce simp: valid_silc_label_def obj_at_def is_cap_table_def) + apply (drule (1) pas_refined_mem) + apply (drule aag_wellformed_Control) + using wellformed apply (fastforce simp: pas_wellformed_noninterference_def) + apply simp + done + +lemma gets_current_vcpu_weak_reads_respects_scheduler: + assumes wellformed[simp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "weak_reads_respects_scheduler aag l + (reads_scheduler_cur_domain aag l and pas_refined aag and valid_silc_label aag + and invs and cur_vcpu_in_cur_domain) + (gets (arm_current_vcpu \ arch_state))" + apply (wp gets_ev'') + prefer 2 + apply assumption + apply clarsimp + apply (prop_tac "equiv_for (\vr. pasObjectAbs aag vr \ reads_scheduler aag l) cur_vcpu_of s t") + apply (clarsimp simp: weak_scheduler_affects_equiv_def states_equiv_for_def equiv_hyp_def) + apply (case_tac "\vr b. current_vcpu s = Some (vr,b)", clarsimp) + apply (subgoal_tac "pasObjectAbs aag vr \ reads_scheduler aag l") + apply (fastforce simp: equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + apply (erule vcpu_visible) + apply simp+ + apply (case_tac "\vr b. current_vcpu t = Some (vr,b)", clarsimp) + apply (subgoal_tac "pasObjectAbs aag vr \ reads_scheduler aag l") + apply (fastforce simp: equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + apply (erule_tac s=t in vcpu_visible) + apply simp+ + done + +lemma vcpu_disable_None_states_equiv_valid: + "states_equiv_valid aag L (\s. \vr. current_vcpu s = Some (vr,True)) (vcpu_disable None)" + apply (simp only: vcpu_disable_def fun_app_def bind_assoc[symmetric] vcpu_save_vgic_defs[symmetric]) + apply (clarsimp simp: dmo_distr) + apply wpsimp + done + +lemma vcpu_disable_globals_equiv_scheduler[wp]: + "\valid_arch_state and globals_equiv_scheduler s\ vcpu_disable vr \\_. globals_equiv_scheduler s\" + by (wp globals_equiv_scheduler_inv' | fastforce)+ + +lemma vcpu_disable_None_weak_reads_respects_scheduler: + "weak_reads_respects_scheduler aag l + (\s. valid_arch_state s \ valid_silc_label aag s \ (\vr. current_vcpu s = Some (vr,True))) + (vcpu_disable None)" + apply (rule equiv_valid_guard_imp) + apply (rule weak_reads_respects_scheduler_from_labels[where Q="valid_arch_state and valid_silc_label aag"]) + apply (rule vcpu_disable_None_states_equiv_valid) + apply (wpsimp wp: domain_fields_equiv_lift)+ + done + +lemma modify_current_vcpu_None_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (modify (\s. s\arch_state := arch_state s\arm_current_vcpu := None\\))" + apply (wpsimp wp: modify_ev) + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI) + apply (auto simp: equiv_asids_def equiv_asid_def)[1] + apply (clarsimp simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: option.split) + apply (auto simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) + done + +lemma disable_current_vcpu_weak_reads_respects_scheduler: + "weak_reads_respects_scheduler aag l \ (modify (\s. s\arch_state := arch_state s\arm_current_vcpu := None\\))" + apply (rule equiv_valid_guard_imp) + apply (rule weak_reads_respects_scheduler_from_labels) + by (wpsimp wp: domain_fields_equiv_lift simp: globals_equiv_scheduler_def arch_globals_equiv_scheduler_def)+ + +lemma vcpu_disable_None_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + vcpu_disable None \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_disable_def + apply (clarsimp simp: dmo_distr) + apply wpsimp + done + +lemma modify_current_vcpu_equiv_but_for_labels'': + "\\s. equiv_but_for_labels aag L st s \ cur_vcpu_for (\x. pasObjectAbs aag x \ L) s = None\ + modify (\s. s\arch_state := arch_state s\arm_current_vcpu := None\\) + \\_ s. equiv_but_for_labels aag L st s\" + apply wp + apply (clarsimp simp: cur_vcpu_for_def equiv_but_for_labels_def states_equiv_for_def equiv_for_def) + apply (intro conjI) + apply (clarsimp simp: equiv_asids_def equiv_asid_def) + defer + apply (clarsimp simp: equiv_fpu_def equiv_for_def cur_fpu_for_def get_tcb_def) + apply (clarsimp simp: equiv_hyp_def equiv_for_def) + apply (intro context_conjI; clarsimp) + apply (erule_tac x=x in allE)+ + apply clarsimp + apply (case_tac "\b. current_vcpu s = Some (x, b)") + apply clarsimp + apply (fastforce simp: cur_vcpu_of_def split: option.splits if_splits) + done + +lemma vcpu_invalidate_active_unobservable: + assumes wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + vcpu_invalidate_active + \\_ s. scheduler_affects_equiv aag l st s\" + apply (simp add: vcpu_invalidate_active_def) + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + supply modify_wp[wp del] + apply (wp states_equiv_but_for_labels_equiv_for_lift modify_current_vcpu_equiv_but_for_labels'' | wpc)+ + apply clarsimp + apply (clarsimp simp: cur_vcpu_for_def del: notI) + apply (prop_tac "cur_vcpu_for (\x. pasObjectAbs aag x \ reads_scheduler aag l) s = None") + apply assumption + apply (clarsimp simp: cur_vcpu_for_def) + prefer 2 + apply (rule conjI) + defer 2 + apply clarsimp + apply (case_tac "current_vcpu s") + apply (clarsimp simp: cur_vcpu_for_def split: option.splits) + apply (clarsimp simp: cur_vcpu_for_def del: notI) + apply (rule vcpu_invisible[OF _ wellformed]) + apply simp+ + apply (simp add: scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply (wpsimp wp: modify_wp hoare_vcg_imp_lift) + apply clarsimp + done + +lemma vcpu_invalidate_active_weak_scheduler_reads_respects: + assumes wellformed[wp,simp]: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "weak_reads_respects_scheduler aag l + (invs and ct_in_cur_domain and valid_cur_vcpu and pas_refined aag + and cur_vcpu_in_cur_domain and valid_silc_label aag) + vcpu_invalidate_active" + apply (rule equiv_valid_cases[where P="\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l \ {}"]) + prefer 3 + apply (simp add: scheduler_equiv_def domain_fields_equiv_def) + prefer 2 + defer + apply (unfold vcpu_invalidate_active_def)[1] + apply (rule equiv_valid_guard_imp) + apply (wpc | wp disable_current_vcpu_weak_reads_respects_scheduler + vcpu_disable_None_weak_reads_respects_scheduler + gets_current_vcpu_weak_reads_respects_scheduler)+ + apply clarsimp + apply (rule equiv_valid_guard_imp) + apply (rule_tac weak_cur_domain_unobservable) + apply (rule reads_respects_scheduler_unobservable'') + apply (rule wp_pre) + apply (rule scheduler_equiv_lift' [OF globals_equiv_scheduler_inv']) + apply (wpsimp | erule conjunct1)+ + apply (rule wp_pre) + apply (wp vcpu_invalidate_active_unobservable) + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def domain_fields_equiv_def) + apply assumption + apply clarsimp + apply assumption + apply clarsimp + apply auto + done + +lemma gets_arm_current_vcpu_states_equiv_valid: + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s \ None) + (gets (arm_current_vcpu \ arch_state))" + apply (wp gets_ev'') + prefer 2 + apply assumption + apply clarsimp + apply (clarsimp simp: states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (fastforce simp: equiv_hyp_def equiv_for_def cur_vcpu_of_def split: if_splits option.splits) + done + +lemma vcpu_save_weak_reads_respects_scheduler: + "weak_reads_respects_scheduler aag l + (\s. current_vcpu s = cv \ valid_arch_state s \ valid_silc_label aag s) (vcpu_save cv)" + apply (rule equiv_valid_guard_imp) + apply (rule weak_reads_respects_scheduler_from_labels) + apply (rule vcpu_save_states_equiv_valid) + apply (wpsimp wp: domain_fields_equiv_lift globals_equiv_scheduler_inv' vcpu_save_silc_dom_equiv | erule conjunct1)+ + apply (clarsimp simp: valid_arch_state_def) + done + +crunch vcpu_save + for pas_refined[wp]: "pas_refined aag" + (simp: pas_refined_def state_objs_to_policy_def ignore: vcpu_save) + +crunch vcpu_save + for cur_vcpu_in_cur_domain[wp]: cur_vcpu_in_cur_domain + (wp: cur_vcpu_in_cur_domain_lift) + +lemma vcpu_invalidate_active_unobservable': + assumes domains_distinct: "pas_domains_distinct aag" + shows + "\\s. \ reads_scheduler_cur_domain aag l s \ + scheduler_affects_equiv aag l st s \ + cur_domain st = cur_domain s \ + cur_vcpu_for (\x. pasObjectAbs aag x \ reads_scheduler aag l) s = None\ + vcpu_invalidate_active + \\_ s. scheduler_affects_equiv aag l st s\" + apply (simp add: vcpu_invalidate_active_def) + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + supply modify_wp[wp del] + apply (wp states_equiv_but_for_labels_equiv_for_lift modify_current_vcpu_equiv_but_for_labels'' | wpc)+ + apply clarsimp + apply (clarsimp simp: cur_vcpu_for_def del: notI) + apply (prop_tac "cur_vcpu_for (\x. pasObjectAbs aag x \ reads_scheduler aag l) s = None") + apply assumption + apply (clarsimp simp: cur_vcpu_for_def) + prefer 2 + apply (rule conjI) + defer 2 + apply clarsimp + apply (simp add: scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply (wpsimp wp: modify_wp hoare_vcg_imp_lift) + apply clarsimp + done + +lemma vcpu_save_unobservable: + assumes domains_distinct: "pas_domains_distinct aag" + shows + "\\s. \ reads_scheduler_cur_domain aag l s \ + scheduler_affects_equiv aag l st s \ + cur_domain st = cur_domain s \ + current_vcpu s = vopt \ + (\vr b. vopt = Some (vr,b) \ pasObjectAbs aag vr \ reads_scheduler aag l) + \ + vcpu_save vopt + \\_ s. scheduler_affects_equiv aag l st s\" + apply (unfold scheduler_affects_equiv_def2[OF domains_distinct]) + supply modify_wp[wp del] + apply (wp states_equiv_but_for_labels_equiv_for_lift modify_current_vcpu_equiv_but_for_labels'' | wpc)+ + apply (simp add: scheduler_affects_inv_def arch_scheduler_affects_equiv_def) + apply (wpsimp wp: modify_wp hoare_vcg_imp_lift) + apply clarsimp + done + +lemma vcpu_flush_unobservable: + assumes wellformed: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_vcpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + vcpu_flush + \\_. scheduler_affects_equiv aag l st\" + unfolding vcpu_flush_def + apply (wpsimp wp: vcpu_invalidate_active_unobservable' vcpu_save_unobservable) + apply (rule context_conjI) + prefer 2 + apply (clarsimp simp: cur_vcpu_for_Some) + using wellformed apply (clarsimp simp: vcpu_invisible) + done + +lemma vcpu_flush_weak_scheduler_reads_respects: + assumes wellformed[wp,simp]: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "weak_reads_respects_scheduler aag l + (pas_refined aag and valid_silc_label aag and invs and ct_in_cur_domain + and valid_cur_vcpu and cur_vcpu_in_cur_domain) + vcpu_flush" + apply (rule equiv_valid_cases[where P="\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l \ {}"]) + prefer 3 + apply (simp add: scheduler_equiv_def domain_fields_equiv_def) + apply (simp add: vcpu_flush_def) + apply wp + apply (wpsimp wp: ct_in_cur_domain_lift when_ev valid_silc_label_lift + vcpu_invalidate_active_weak_scheduler_reads_respects + vcpu_save_weak_reads_respects_scheduler + gets_current_vcpu_weak_reads_respects_scheduler) + apply (wp gets_current_vcpu_weak_reads_respects_scheduler) + apply wp + apply clarsimp + apply (rule equiv_valid_guard_imp) + apply (rule_tac weak_cur_domain_unobservable) + apply (rule reads_respects_scheduler_unobservable'') + apply (rule wp_pre) + apply (rule scheduler_equiv_lift' [OF globals_equiv_scheduler_inv']) + apply (wpsimp | erule conjunct1)+ + apply (rule wp_pre) + apply (wp vcpu_flush_unobservable) + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def scheduler_affects_equiv_def domain_fields_equiv_def) + apply assumption + apply clarsimp + apply assumption + apply clarsimp + apply auto + done + +lemma switch_local_fpu_owner_globals_equiv_scheduler[wp]: + "\invs and globals_equiv_scheduler s\ switch_local_fpu_owner vr \\_. globals_equiv_scheduler s\" + by (wp globals_equiv_scheduler_inv' switch_local_fpu_owner_globals_equiv | fastforce)+ + +lemma vcpu_flush_globals_equiv_scheduler[wp]: + "\valid_arch_state and globals_equiv_scheduler s\ vcpu_flush \\_. globals_equiv_scheduler s\" + by (wp globals_equiv_scheduler_inv' vcpu_flush_globals_equiv | fastforce)+ + +lemma arch_prepare_next_domain_globals_equiv_scheduler[Scheduler_IF_assms]: + "\invs and globals_equiv_scheduler st\ arch_prepare_next_domain \\_. globals_equiv_scheduler st\" + unfolding arch_prepare_next_domain_def + by wpsimp + +lemma vcpu_invalidate_active_states_equiv_valid: + "states_equiv_valid aag L (\s. cur_vcpu_for (L o pasObjectAbs aag) s \ None) vcpu_invalidate_active" + unfolding vcpu_invalidate_active_def + by (wpsimp wp: vcpu_disable_None_states_equiv_valid gets_arm_current_vcpu_states_equiv_valid) + +lemma vcpu_invalidate_active_equiv_but_for_labels[wp]: + "\\s. equiv_but_for_labels aag L st s \ (\vr b. current_vcpu s = Some (vr,b) \ pasObjectAbs aag vr \ L)\ + vcpu_invalidate_active + \\_. equiv_but_for_labels aag L st\" + unfolding vcpu_invalidate_active_def + by (wpsimp wp: modify_current_vcpu_equiv_but_for_labels'') + (auto simp: cur_vcpu_for_def) + +lemma vcpu_flush_states_equiv_valid[wp]: + "states_equiv_valid aag L (valid_numlistregs) vcpu_flush" + unfolding vcpu_flush_def + apply (rule_tac P="\s. cur_vcpu_for (L o pasObjectAbs aag) s \ None" in equiv_valid_cases) + prefer 3 + apply (prop_tac "equiv_for (L o pasObjectAbs aag) cur_vcpu_of s t") + apply (clarsimp simp: states_equiv_for_def equiv_for_def equiv_hyp_def) + apply (rule iffI; clarsimp simp: equiv_for_def) + apply (erule_tac x=ptr in allE, clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply (erule_tac x=ptr in allE, clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply wp + apply (wpsimp wp: when_ev vcpu_invalidate_active_states_equiv_valid) + apply (rule gets_arm_current_vcpu_states_equiv_valid) + apply wpsimp + apply clarsimp + apply (subst pred_conj_comm) + apply (rule states_equiv_valid_invisible[OF modifies_at_mostI]) + apply wpsimp + apply wpsimp + apply clarsimp + done + +lemma invs_valid_numlistregs [elim!]: + "invs s \ valid_numlistregs s" + by (drule invs_arch_state) + (simp add: valid_arch_state_def) + +lemma arch_prepare_next_domain_states_equiv_valid: + "states_equiv_valid aag L invs arch_prepare_next_domain" + unfolding arch_prepare_next_domain_def + by wpsimp fastforce + +crunch arch_prepare_next_domain + for domain_time[wp]: "\s. P (domain_time s)" + and domain_index[wp]: "\s. P (domain_index s)" + (simp : crunch_simps wp: crunch_wps) + +crunch arch_prepare_next_domain + for globals_equiv[wp]: "globals_equiv st" + (wp: valid_silc_label_lift) + +lemma arch_prepare_next_domain_weak_scheduler_reads_respects[Scheduler_IF_assms]: + "weak_reads_respects_scheduler aag l (invs and valid_silc_label aag) arch_prepare_next_domain" + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q="invs and valid_silc_label aag" in weak_reads_respects_scheduler_from_labels) + apply (rule arch_prepare_next_domain_states_equiv_valid) + apply (wpsimp wp: domain_fields_equiv_lift globals_equiv_scheduler_inv'[where P="invs"])+ + done + +lemma gets_cur_fpu_of_states_equiv_valid: + "states_equiv_valid aag L (valid_cur_fpu and K (L (pasObjectAbs aag t))) (gets (\s. cur_fpu_of s t))" + apply (wpsimp wp: gets_ev'') + prefer 2 + apply (rule conjI) + apply assumption+ + apply (prop_tac "equiv_fpu (\x. L (pasObjectAbs aag x)) x xa") + apply (clarsimp simp: states_equiv_for_def) + apply (clarsimp simp: equiv_fpu_def2) + done + +lemma thread_get_states_equiv_valid: + "states_equiv_valid aag L (K (L (pasObjectAbs aag thread))) (thread_get f thread)" + unfolding thread_get_def fun_app_def + apply (wp gets_the_ev) + apply (auto simp: states_equiv_for_def equiv_for_def get_tcb_def) + done + +lemma lazy_fpu_restore_states_equiv_valid[wp]: + "states_equiv_valid aag L (valid_cur_fpu and K (L (pasObjectAbs aag t))) (lazy_fpu_restore t)" + unfolding lazy_fpu_restore_def + apply (subst gets_comp) + apply (unfold comp_def) + apply (wpsimp wp: gets_cur_fpu_of_states_equiv_valid thread_get_states_equiv_valid thread_get_wp') + done + +lemma set_vm_root_states_equiv_valid[wp]: + "states_equiv_valid aag L \ (set_vm_root t)" + apply (rule states_equiv_valid_unobservable_unit_return) + apply (wp set_vm_root_states_equiv_for) + done + +lemma arch_switch_to_thread_states_equiv_valid: + "states_equiv_valid aag L (invs and K (L (pasObjectAbs aag t))) (arch_switch_to_thread t)" + unfolding arch_switch_to_thread_def + apply (wpsimp wp: vcpu_switch_states_equiv_valid) + apply (auto simp: states_equiv_for_def get_tcb_def equiv_for_def) + done + +lemma midstrength_reads_respects_scheduler_from_labels': + assumes ev: "\L. states_equiv_valid aag L (P (L o pasObjectAbs aag)) f" + and inv: "\P. \\s. P (idle_thread s) \ Q s\ f \\_ s. P (idle_thread s)\" + "\P. \\s. P (irq_state_of_state s) \ Q s\ f \\_ s. P (irq_state_of_state s)\" + "\P. \\s. P (work_units_completed s) \ Q s\ f \\_ s. P (work_units_completed s)\" + "\P. \\s. P (cur_domain s) \ Q s\ f \\_ s. P (cur_domain s)\" + "\st. \\s. domain_fields_equiv st s \ Q s\ f \\_ s. domain_fields_equiv st s\" + "\st. \\s. globals_equiv_scheduler st s \ Q s\ f \\_ s. globals_equiv_scheduler st s\" + "\st. \\s. silc_dom_equiv aag st s \ Q s\ f \\_ s. silc_dom_equiv aag st s\" + shows "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (P (\x. pasObjectAbs aag x \ reads_scheduler aag l) and Q) f" + apply (rule equiv_valid_inv_split_lr) + apply (rule equiv_valid_rv_inv_lift) + unfolding scheduler_equiv_def + apply (wpsimp wp: inv) + apply (auto simp: domain_fields_equiv_sym globals_equiv_scheduler_sym silc_dom_equiv_sym)[2] + unfolding midstrength_scheduler_affects_equiv_def + apply (rule equiv_valid_inv_A_conjI) + apply (rule_tac equiv_valid_guard_imp) + apply (insert ev)[1] + apply fastforce + apply (clarsimp simp: comp_def) + apply (rule_tac Q=Q and Q'=Q in equiv_valid_2_guard_imp) + apply (rule equiv_valid_rv_inv_lift) + apply (wpsimp wp: inv hoare_vcg_imp_lift)+ + apply auto + done + +lemma lazy_fpu_restore_unobservable: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + (\s. pasObjectAbs aag t \ reads_scheduler aag l) and + scheduler_equiv aag st and scheduler_affects_equiv aag l st and + invs and cur_fpu_in_cur_domain and valid_silc_label aag and pas_refined aag\ + lazy_fpu_restore t + \\_ s. scheduler_affects_equiv aag l st s\" + by (wpsimp wp: set_vm_root_scheduler_affects_equiv + lazy_fpu_restore_scheduler_affects_equiv + vcpu_switch_scheduler_affects_equiv) + +lemma midstrength_cur_domain_unobservable': + "reads_respects_scheduler aag l (P and (\s. \ reads_scheduler_cur_domain aag l s)) f + \ equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + ((\s. \ reads_scheduler_cur_domain aag l s) and P) f" + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def scheduler_affects_equiv_def + equiv_valid_def2 equiv_valid_2_def midstrength_scheduler_affects_equiv_def) + apply (drule_tac x=s in spec) + apply (drule_tac x=t in spec) + apply clarsimp + apply (drule_tac x="(a,b)" in bspec,clarsimp+) + apply (drule_tac x="(aa,ba)" in bspec,clarsimp+) + done + +lemma lazy_fpu_restore_midstrength_scheduler_reads_respects: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + ((\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s)) and invs and + pas_refined aag and valid_silc_label aag and cur_fpu_in_cur_domain) + (lazy_fpu_restore t)" + apply (rule_tac P="reads_scheduler_cur_domain aag l" in equiv_valid_cases) + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q="invs and valid_silc_label aag" in midstrength_reads_respects_scheduler_from_labels') + apply (rule equiv_valid_guard_imp) + apply (rule lazy_fpu_restore_states_equiv_valid) + apply (clarsimp simp: comp_def) + apply assumption + apply (wpsimp wp: domain_fields_equiv_lift lazy_fpu_restore_globals_equiv globals_equiv_scheduler_inv' | erule conjunct1)+ + apply (rule conjI) + apply clarsimp + apply (insert domains_distinct) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE, clarsimp) + apply (rule midstrength_cur_domain_unobservable') + apply (rule reads_respects_scheduler_unobservable'') + apply (wp_pre) + apply (rule_tac P="invs and valid_silc_label aag" in scheduler_equiv_lift') + apply (wpsimp wp: arch_switch_to_thread_globals_equiv_scheduler + lazy_fpu_restore_globals_equiv globals_equiv_scheduler_inv' + | erule conjunct1)+ + apply (wp lazy_fpu_restore_unobservable) + apply clarsimp + apply assumption + apply clarsimp + apply (rule conjI) + apply simp + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE, clarsimp) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) + done + +lemma arch_switch_to_thread_midstrength_reads_respects_scheduler': + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + ((\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s)) and invs and pas_refined aag and + valid_silc_label aag and cur_vcpu_in_cur_domain and cur_fpu_in_cur_domain) + (arch_switch_to_thread t)" + apply (rule_tac P="reads_scheduler_cur_domain aag l" in equiv_valid_cases) + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q="invs and valid_silc_label aag" in midstrength_reads_respects_scheduler_from_labels') + apply (rule equiv_valid_guard_imp) + apply (rule arch_switch_to_thread_states_equiv_valid) + apply (clarsimp simp: comp_def) + apply assumption + apply (wpsimp wp: domain_fields_equiv_lift arch_switch_to_thread_globals_equiv_scheduler)+ + apply (insert domains_distinct) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE, clarsimp) + prefer 2 + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) + apply (rule midstrength_cur_domain_unobservable') + apply (rule reads_respects_scheduler_unobservable'') + apply (wp_pre) + apply (rule_tac P="invs and valid_silc_label aag" in scheduler_equiv_lift') + apply (wpsimp wp: arch_switch_to_thread_globals_equiv_scheduler globals_equiv_scheduler_inv' + | erule conjunct1)+ + apply (wp arch_switch_to_thread_unobservable) + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) + apply assumption + apply clarsimp + apply (rule conjI, simp) + apply (clarsimp simp: pas_domains_distinct_def) + apply (erule_tac x="cur_domain s" in allE, clarsimp) + done + +lemma arch_switch_to_thread_midstrength_reads_respects_scheduler[Scheduler_IF_assms, wp]: + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "midstrength_reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag + and cur_vcpu_in_cur_domain and cur_fpu_in_cur_domain + and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) + (do _ <- arch_switch_to_thread t; + _ <- modify (cur_thread_update (\_. t)); + modify (scheduler_action_update (\_. resume_cur_thread)) + od)" + apply (rule equiv_valid_guard_imp) + apply (rule bind_ev_general) + apply (fold set_scheduler_action_def) + apply (rule store_cur_thread_fragment_midstrength_reads_respects) + apply (rule arch_switch_to_thread_midstrength_reads_respects_scheduler') + apply wpsimp+ + done + +definition cur_hyp_in_cur_domain where + "cur_hyp_in_cur_domain \ cur_vcpu_in_cur_domain" + +end + +arch_requalify_consts cur_hyp_in_cur_domain cur_fpu_in_cur_domain + + +global_interpretation Scheduler_IF_2?: + Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv _ cur_hyp_in_cur_domain cur_fpu_in_cur_domain +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Scheduler_IF_assms[folded cur_hyp_in_cur_domain_def])?) +qed + + +(* FIXME AARCH64 IF: add comment *) +hide_fact Scheduler_IF_2.globals_equiv_scheduler_inv' +arch_requalify_facts globals_equiv_scheduler_inv' + +end diff --git a/proof/infoflow/AARCH64/ArchSyscall_IF.thy b/proof/infoflow/AARCH64/ArchSyscall_IF.thy new file mode 100644 index 0000000000..098417e4d1 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchSyscall_IF.thy @@ -0,0 +1,378 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchSyscall_IF +imports Syscall_IF +begin + +context Arch begin arch_global_naming + +named_theorems Syscall_IF_assms + +lemma globals_equiv_irq_state_update[Syscall_IF_assms, simp]: + "globals_equiv st (s\machine_state := + machine_state s \irq_state := f (irq_state (machine_state s))\\) = + globals_equiv st s" + by (auto simp: globals_equiv_def idle_equiv_def) + +lemma thread_set_globals_equiv'[Syscall_IF_assms]: + "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv s\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + apply simp + apply (fastforce simp: obj_at_def get_tcb_def valid_arch_state_def + dest: valid_global_arch_objs_pt_at) + done + +lemma sts_authorised_for_globals_inv[Syscall_IF_assms]: + "set_thread_state d f \authorised_for_globals_inv oper\" + unfolding authorised_for_globals_inv_def authorised_for_globals_arch_inv_def + authorised_for_globals_page_table_inv_def authorised_for_globals_page_inv_def + apply (case_tac oper) + apply (wp | simp)+ + apply (rename_tac arch_invocation) + apply (case_tac arch_invocation) + apply simp + apply (rename_tac page_table_invocation) + apply (case_tac page_table_invocation) + apply wpsimp+ + apply (rename_tac page_invocation) + apply (case_tac page_invocation) + apply (simp | wp hoare_vcg_ex_lift)+ + done + +lemma dmo_maskInterrupt_globals_equiv[Syscall_IF_assms, wp]: + "do_machine_op (maskInterrupt b irq) \globals_equiv s\" + unfolding maskInterrupt_def + apply (rule dmo_no_mem_globals_equiv) + apply (wp modify_wp | simp)+ + done + +lemma dmo_ackInterrupt_globals_equiv[Syscall_IF_assms, wp]: + "do_machine_op (ackInterrupt irq) \globals_equiv s\" + unfolding ackInterrupt_def by wpsimp + +lemma dmo_resetTimer_globals_equiv[Syscall_IF_assms, wp]: + "do_machine_op resetTimer \globals_equiv s\" + unfolding resetTimer_def by (rule dmo_mol_globals_equiv) + +lemma arch_mask_irq_signal_globals_equiv[Syscall_IF_assms, wp]: + "arch_mask_irq_signal irq \globals_equiv st\" + by wpsimp + +lemma vppi_update_valid_objs[wp]: + "vcpu_update vr (\vcpu. vcpu\vcpu_vppi_masked := f vcpu\) \valid_objs\" + unfolding vcpu_update_def + by (wpsimp simp: valid_vcpu_def) + +lemma vppi_update_valid_arch_state[wp]: + "vcpu_update vr (\vcpu. vcpu\vcpu_vppi_masked := f vcpu\) \valid_arch_state\" + unfolding vcpu_update_def + apply (wpsimp wp: set_vcpu_valid_arch_eq_hyp get_vcpu_wp) + apply (auto simp: obj_at_def opt_map_def vcpu_tcb_refs_def split: option.splits) + done + +lemma vgic_update_valid_objs[wp]: + "vcpu_update vr (\vcpu. vcpu\vcpu_vgic := f vcpu\) \valid_objs\" + unfolding vcpu_update_def + by (wpsimp simp: valid_vcpu_def) + +lemma vgic_update_valid_arch_state[wp]: + "vcpu_update vr (\vcpu. vcpu\vcpu_vgic := f vcpu\) \valid_arch_state\" + unfolding vcpu_update_def + apply (wpsimp wp: set_vcpu_valid_arch_eq_hyp get_vcpu_wp) + apply (auto simp: obj_at_def opt_map_def vcpu_tcb_refs_def split: option.splits) + done + +crunch vcpu_update + for valid_global_objs[wp]: valid_global_objs + (wp: crunch_wps simp: crunch_simps) + +lemma vppi_event_globals_equiv[wp]: + "\globals_equiv st and invs\ vppi_event irq \\_. globals_equiv st\" + unfolding vppi_event_def + apply (wpsimp wp: handle_fault_globals_equiv gts_wp hoare_vcg_all_lift hoare_drop_imps + simp: crunch_simps split_del: if_split) + apply (auto simp: valid_fault_def) + done + +lemma vgic_maintenance_globals_equiv[wp]: + "\globals_equiv st and invs\ vgic_maintenance \\_. globals_equiv st\" + unfolding vgic_maintenance_def vgic_update_lr_def vgic_update_def + apply (wpsimp wp: handle_fault_globals_equiv gts_wp hoare_vcg_all_lift hoare_drop_imps dmo_globals_equiv + split_del: if_split simp: crunch_simps valid_fault_def) + apply auto + done + +lemma handle_reserved_irq_globals_equiv[Syscall_IF_assms, wp]: + "\globals_equiv st and invs\ handle_reserved_irq irq \\_. globals_equiv st\" + unfolding handle_reserved_irq_def + by wpsimp + +(* FIXME AARCH64 IF: move *) +lemma gets_compE: + "doE x <- liftE (gets f); + m (g x) + odE = + doE x <- liftE (gets (g \ f)); + m x + odE" + by (clarsimp simp: liftE_def bind_bindE_assoc gets_def return_bindE) + +definition is_subject_cur_vcpu_2 where + "is_subject_cur_vcpu_2 aag cf \ \ptr. cf = Some (ptr,True) \ is_subject aag ptr" + +locale_abbrev is_subject_cur_vcpu where + "is_subject_cur_vcpu aag \ \s. is_subject_cur_vcpu_2 aag (arm_current_vcpu (arch_state s))" + +lemmas is_subject_cur_vcpu_def = is_subject_cur_vcpu_2_def + +lemma active_vcpu_is_subject: + "\ pas_refined aag s; is_subject aag (cur_thread s); + valid_cur_vcpu s; schact_is_rct s; ct_in_cur_domain s \ + \ is_subject_cur_vcpu aag s" + apply (prop_tac "arch_tcb_at (\itcb. itcb_vcpu itcb = active_cur_vcpu_of s) (cur_thread s) s") + apply (clarsimp simp: valid_cur_vcpu_def schact_is_rct_def) + apply (case_tac "cur_thread s = idle_thread s") + apply (auto simp: ct_in_cur_domain_resume_cur_thread_not_idle)[2] + apply (clarsimp simp: pred_tcb_at_def obj_at_def is_subject_cur_vcpu_def) + apply (clarsimp simp: active_cur_vcpu_of_def split: option.splits) + apply (erule associated_vcpu_is_subject) + apply (fastforce simp: get_tcb_ko_at obj_at_def) + apply auto + done + +lemma gets_current_vcpu_reads_respects: + "reads_respects aag l (\s. pas_refined aag s \ valid_cur_vcpu s \ schact_is_rct s + \ ct_in_cur_domain s \ is_subject aag (cur_thread s)) + (gets ((\a. \v. a = Some (v, True)) \ (arm_current_vcpu \ arch_state)))" + (is "reads_respects aag l ?P _") + apply (wpsimp wp: gets_ev''[where P="?P"]) + apply (prop_tac "equiv_hyp (aag_can_read aag) s t") + apply (clarsimp simp: reads_equiv_def2 states_equiv_for_def equiv_hyp_def equiv_for_def) + apply (drule (4) active_vcpu_is_subject)+ + apply (clarsimp simp: equiv_hyp_def equiv_for_def is_subject_cur_vcpu_def) + apply (rule iffI; erule ex_forward) + apply (erule_tac x=v in allE)+ + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply (erule_tac x=v in allE)+ + apply (clarsimp simp: cur_vcpu_of_def split: option.splits if_splits) + apply simp + done + +lemma handle_vm_fault_reads_respects[Syscall_IF_assms]: + "reads_respects aag l (pas_refined aag and valid_cur_hyp and schact_is_rct and ct_in_cur_domain + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_vm_fault thread vmfault_type)" + unfolding handle_vm_fault_def fun_app_def valid_cur_hyp_def + apply (cases vmfault_type; clarsimp; subst gets_compE) + by (wpsimp wp: gets_current_vcpu_reads_respects as_user_reads_respects + dmo_getESR_reads_respects dmo_getFAR_reads_respects + dmo_addressTranslateS1_reads_respects + simp: det_getRestartPC)+ + +lemma handle_hypervisor_fault_reads_respects[Syscall_IF_assms]: + assumes pas_domains_distinct[wp]: "pas_domains_distinct (aag :: 'a subject_label PAS)" + shows "reads_respects aag l (invs and pas_refined aag and pas_cur_domain aag + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_hypervisor_fault thread hypfault_type)" + apply (cases hypfault_type) + apply (wpsimp wp: handle_fault_reads_respects dmo_getESR_reads_respects split_del: if_split) + apply (auto simp: valid_fault_def) + done + +lemma handle_vm_fault_globals_equiv[Syscall_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. thread \ idle_thread s)\ + handle_vm_fault thread vmfault_type + \\r. globals_equiv st\" + unfolding handle_vm_fault_def + by (cases vmfault_type; wpsimp wp: dmo_no_mem_globals_equiv) + +lemma handle_hypervisor_fault_globals_equiv[Syscall_IF_assms]: + "\globals_equiv st and invs\ handle_hypervisor_fault thread hypfault_type \\_. globals_equiv st\" + apply (cases hypfault_type) + apply (wpsimp wp: handle_fault_globals_equiv split_del: if_split)+ + apply (auto simp: valid_fault_def) + done + +crunch arch_activate_idle_thread, handle_spurious_irq + for globals_equiv[Syscall_IF_assms, wp]: "globals_equiv st" + +lemma select_f_setNextPC_reads_respects[Syscall_IF_assms, wp]: + "reads_respects aag l \ (select_f (setNextPC a b))" + unfolding setNextPC_def setRegister_def + by (wpsimp simp: select_f_returns) + +lemma select_f_getRestartPC_reads_respects[Syscall_IF_assms, wp]: + "reads_respects aag l \ (select_f (getRestartPC a))" + unfolding getRestartPC_def getRegister_def + by (wpsimp simp: select_f_returns) + +lemma arch_activate_idle_thread_reads_respects[Syscall_IF_assms, wp]: + "reads_respects aag l \ (arch_activate_idle_thread t)" + unfolding arch_activate_idle_thread_def by wpsimp + +lemma decode_asid_pool_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_asid_pool_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding authorised_for_globals_arch_inv_def decode_asid_pool_invocation_def Let_def + by wpsimp + +lemma decode_asid_control_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_asid_control_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding authorised_for_globals_arch_inv_def decode_asid_control_invocation_def Let_def + by wpsimp + +definition is_pt_cap_typ :: "cap \ pt_type \ bool" where + "is_pt_cap_typ cap pt_t \ + arch_cap_fun_lift (\acap. is_PageTableCap acap \ acap_pt_type acap = pt_t) False cap" + +(* FIXME AARCH64 IF: consolidate with pt_lookup_slot_cap_to *) +lemma pt_lookup_slot_cap_to_lvl: + "\ invs s; \\(max_pt_level, pt) s; is_aligned pt (pt_bits VSRootPT_T); vptr \ user_region; + pt_lookup_slot pt vptr (ptes_of s) = Some (level, slot) \ + \ \p cap. caps_of_state s p = Some cap \ is_pt_cap_typ cap (level_type level) \ + obj_refs cap = {table_base level slot} \ s \ cap \ cap_asid cap \ None" + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) + apply (frule pt_walk_max_level) + apply (rename_tac pt_ptr asid vref) + apply (subgoal_tac "vs_lookup_table level asid vptr s = Some (level, pt_ptr)") + prefer 2 + apply (drule pt_walk_level) + apply (clarsimp simp: vs_lookup_table_def in_omonad) + apply (frule_tac level=level in valid_vspace_objs_strongD[rotated]; clarsimp) + apply (drule vs_lookup_table_target[where level=level], simp) + apply (drule valid_vs_lookupD, erule vref_for_level_user_region; clarsimp) + apply (frule (1) cap_to_pt_is_pt_cap_and_type, simp) + apply (fastforce intro: valid_objs_caps) + apply (frule pts_of_Some_alignedD, fastforce) + apply (frule caps_of_state_valid, fastforce) + apply (fastforce simp: cap_asid_def is_cap_simps is_pt_cap_typ_def) + done + +lemma decode_frame_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_frame_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding authorised_for_globals_arch_inv_def authorised_for_globals_page_inv_def + decode_frame_invocation_def decode_fr_inv_map_def + apply (case_tac "invocation_type label = ArchInvocationLabel ARMPageMap \ is_FrameCap cap") + defer + apply (wpsimp simp: isPageFlushLabel_def Let_def decode_fr_inv_flush_def) + apply (simp add: is_FrameCap_def Let_def cong: arch_cap.case_cong if_cong) + apply (wpsimp wp: check_vp_wpR whenE_throwError_wp) + apply (prop_tac "\ user_vtop < msg ! 0 + mask (pageBitsForSize xb) \ msg ! 0 \ user_region") + apply (clarsimp simp: user_region_def not_le) + apply (rule user_vtop_leq_canonical_user) + apply (simp add: vmsz_aligned_def not_less) + apply (drule is_aligned_no_overflow_mask) + apply simp + apply (case_tac "msg ! 0 \ user_region") + prefer 2 + apply (fastforce dest: cte_wp_valid_cap simp: valid_cap_def wellformed_mapdata_def) + apply (clarsimp simp: parent_for_refs_def cte_wp_at_caps_of_state) + apply (frule vspace_for_asid_vs_lookup) + using pt_lookup_slot_cap_to_lvl[where vptr="msg ! 0"] + by (fastforce dest: vs_lookup_table_is_aligned + simp: is_pt_cap_typ_def is_PageTableCap_def + split: option.splits) + +lemma decode_page_table_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_page_table_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding decode_page_table_invocation_def decode_pt_inv_map_def + authorised_for_globals_arch_inv_def authorised_for_globals_page_table_inv_def + apply (simp add: split_def Let_def cong: arch_cap.case_cong if_cong split del: if_split) + apply (wpsimp cong: if_cong wp: hoare_vcg_if_lift2) + apply (clarsimp simp: pt_lookup_slot_from_level_def pt_lookup_slot_def) + apply (frule (1) pt_lookup_vs_lookupI, clarsimp) + apply (drule vs_lookup_level) + apply (frule pt_walk_max_level) + apply (subgoal_tac "msg ! 0 \ user_region") + apply (frule reachable_page_table_not_global; clarsimp?) + apply (frule vs_lookup_table_is_aligned; clarsimp?) + apply (fastforce intro: user_vtop_leq_canonical_user simp: user_region_def) + done + +lemma decode_sgi_signal_invocation_authorised_for_globals: + "\\\ decode_sgi_signal_invocation cap + \authorised_for_globals_arch_inv\, -" + unfolding decode_sgi_signal_invocation_def authorised_for_globals_arch_inv_def + by wpsimp + +lemma decode_smc_invocation_authorised_for_globals: + "\\\ decode_smc_invocation label args acap + \authorised_for_globals_arch_inv\, -" + unfolding decode_smc_invocation_def authorised_for_globals_arch_inv_def + by wpsimp + +lemma decode_vspace_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_vspace_invocation label msg slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding decode_vspace_invocation_def decode_vs_inv_flush_def + by (wpsimp simp: Let_def authorised_for_globals_arch_inv_def) + +lemma decode_vcpu_invocation_authorised_for_globals: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + decode_vcpu_invocation label msg cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding decode_vcpu_invocation_def decode_vcpu_set_tcb_def decode_vcpu_inject_irq_def + decode_vcpu_read_register_def decode_vcpu_write_register_def decode_vcpu_ack_vppi_def + range_check_def arch_check_irq_def authorised_for_globals_arch_inv_def + by (wpc | wpsimp wp: whenE_throwError_wp)+ + +lemma decode_arch_invocation_authorised_for_globals[Syscall_IF_assms]: + "\invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + and (\s. \(cap, slot) \ set excaps. cte_wp_at ((=) cap) slot s)\ + arch_decode_invocation label msg x_slot slot cap excaps + \authorised_for_globals_arch_inv\, -" + unfolding arch_decode_invocation_def + by (wpsimp wp: decode_sgi_signal_invocation_authorised_for_globals + decode_smc_invocation_authorised_for_globals + decode_vspace_invocation_authorised_for_globals + decode_vcpu_invocation_authorised_for_globals + decode_asid_pool_invocation_authorised_for_globals + decode_asid_control_invocation_authorised_for_globals + decode_frame_invocation_authorised_for_globals + decode_page_table_invocation_authorised_for_globals, fastforce) + +crunch vcpu_flush_if_current + for globals_equiv[wp]: "globals_equiv st" + (wp: crunch_wps simp: crunch_simps invs_arch_state) + +lemma arch_prepare_set_domain_globals_equiv[Syscall_IF_assms]: + "\globals_equiv st and invs\ arch_prepare_set_domain t new_dom \\_. globals_equiv st\" + unfolding arch_prepare_set_domain_def + by (wpsimp wp: fpu_release_globals_equiv) + +crunch arch_prepare_set_domain + for valid_arch_state[Syscall_IF_assms,wp]: valid_arch_state + (wp: hoare_drop_imps) + +end + + +global_interpretation Syscall_IF_1?: Syscall_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Syscall_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchTcb_IF.thy b/proof/infoflow/AARCH64/ArchTcb_IF.thy new file mode 100644 index 0000000000..dd39402e14 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchTcb_IF.thy @@ -0,0 +1,451 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchTcb_IF +imports Tcb_IF +begin + +context Arch begin arch_global_naming + +named_theorems Tcb_IF_assms + +crunch set_irq_state, suspend + for arm_us_global_vspace[wp]: "\s. P (arm_us_global_vspace (arch_state s))" + (wp: mapM_x_wp select_inv hoare_vcg_if_lift2 hoare_drop_imps dxo_wp_weak + simp: unless_def + ignore: empty_slot_ext reschedule_required) + +crunch as_user, restart + for arm_us_global_vspace[wp]: "\s. P (arm_us_global_vspace (arch_state s))" (wp: dxo_wp_weak) + +lemma cap_ne_global_pt: + "\ ex_nonz_cap_to word s; valid_global_refs s; valid_global_arch_objs s \ + \ word \ arm_us_global_vspace (arch_state s)" + unfolding ex_nonz_cap_to_def + apply (simp only: cte_wp_at_caps_of_state zobj_refs_to_obj_refs) + apply (elim exE conjE) + apply (drule valid_global_refsD2,simp) + apply (unfold global_refs_def) + apply clarsimp + apply (unfold cap_range_def) + apply blast + done + +lemma valid_arch_caps_vs_lookup[Tcb_IF_assms]: + "valid_arch_caps s \ valid_vs_lookup s" + by (simp add: valid_arch_caps_def) + +lemma no_cap_to_idle_thread'[Tcb_IF_assms]: + "valid_global_refs s \ \ ex_nonz_cap_to (idle_thread s) s" + apply (clarsimp simp add: ex_nonz_cap_to_def valid_global_refs_def valid_refs_def) + apply (drule_tac x=a in spec) + apply (drule_tac x=b in spec) + apply (clarsimp simp: cte_wp_at_def global_refs_def cap_range_def) + apply (case_tac cap,simp_all) + done + +lemma no_cap_to_idle_thread''[Tcb_IF_assms]: + "valid_global_refs s \ caps_of_state s ref \ Some (ThreadCap (idle_thread s))" + apply (clarsimp simp add: valid_global_refs_def valid_refs_def cte_wp_at_caps_of_state) + apply (drule_tac x="fst ref" in spec) + apply (drule_tac x="snd ref" in spec) + apply (simp add: cap_range_def global_refs_def) + done + +crunch arch_post_modify_registers + for globals_equiv[Tcb_IF_assms, wp]: "globals_equiv st" + and valid_arch_state[Tcb_IF_assms, wp]: valid_arch_state + +lemma arch_post_modify_registers_reads_respects_f[Tcb_IF_assms, wp]: + "reads_respects_f aag l \ (arch_post_modify_registers cur t)" + by wpsimp + +lemma reads_equiv_valid_inv_f: + assumes a: "reads_equiv_valid_inv A aag P f" + assumes b: "\P. \P\ f \\_. P\" + shows "equiv_valid_inv (reads_equiv_f aag) A P f" + supply equiv_valid_2_def[simp] equiv_valid_def2[simp] + apply (clarsimp simp: reads_equiv_f_def) + apply (insert a, clarsimp) + apply (drule_tac x=s in spec, drule_tac x=t in spec, clarsimp) + apply (drule (1) bspec, clarsimp) + apply (drule (1) bspec, clarsimp) + apply (drule state_unchanged[OF b])+ + by simp + +lemma arch_get_sanitise_register_info_reads_respects_f[Tcb_IF_assms, wp]: + "reads_respects_f aag l (K (aag_can_read_or_affect aag l rv)) (arch_get_sanitise_register_info rv)" + unfolding arch_get_sanitise_register_info_def + by (wpsimp wp: reads_equiv_valid_inv_f) + +end + + +global_interpretation Tcb_IF_1?: Tcb_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Tcb_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma valid_ipc_buffer_cap_is_nondevice_page_cap: + "\valid_ipc_buffer_cap cap ptr; cap \ NullCap\ \ is_nondevice_page_cap cap" + by (clarsimp simp: valid_ipc_buffer_cap_def split: cap.splits arch_cap.splits) + +lemma is_valid_vtable_root_def2: + "is_valid_vtable_root c = (\r a. c = ArchObjectCap (PageTableCap r VSRootPT_T (Some a)))" + by (auto simp: is_valid_vtable_root_def split: cap.splits arch_cap.splits option.splits pt_type.splits) + +(* FIXME: Pretty general. Probably belongs somewhere else *) +lemma invoke_tcb_thread_preservation[Tcb_IF_assms]: + notes is_nondevice_page_cap_simps[simp del] + assumes cap_delete_P: "\slot. \invs and P and emptyable slot\ cap_delete slot \\_. P\" + assumes cap_insert_P: "\new_cap src dest. \invs and P\ cap_insert new_cap src dest \\_. P\" + assumes thread_set_P: "\f ptr. \invs and P\ thread_set (tcb_ipc_buffer_update f) ptr \\_. P\" + assumes thread_set_P': "\f ptr. \invs and P\ thread_set (tcb_fault_handler_update f) ptr \\_. P\" + assumes set_mcpriority_P: "\mcp ptr. \invs and P\ set_mcpriority ptr mcp \\_.P\" + assumes set_priority_P: "\prio ptr. \invs and P\ set_priority ptr prio \\_.P\" + assumes reschedule_required_P: "reschedule_required \P\" + assumes P_trans[simp]: "\f s. P (trans_state f s) = P s" + shows + "\P and invs and tcb_inv_wf (tcb_invocation.ThreadControl t sl ep mcp prio croot vroot buf)\ + invoke_tcb (tcb_invocation.ThreadControl t sl ep mcp prio croot vroot buf) + \\rv s :: det_state. P s\" (is "\?pre\ _ \_\") + apply (simp add: split_def cong: option.case_cong) + apply (rule hoare_weaken_pre) + apply (rule_tac P="case ep of Some v \ length v = word_bits | _ \ True" + in hoare_gen_asm) + apply wp + apply (wpsimp wp: set_priority_P) + apply (rule_tac Q'="\_. invs and P" and E'="\_. P" in hoare_post_impE; clarsimp) + apply ((simp add: conj_comms(1, 2) + | rule wp_split_const_if wp_split_const_if_R hoare_vcg_all_liftE_R + hoare_vcg_conj_elimE hoare_vcg_const_imp_liftE_R hoare_vcg_conj_liftE_R + | (wp check_cap_inv2[where Q="\_ s. t \ idle_thread s"] + out_invs_trivial case_option_wpE cap_delete_deletes + cap_delete_valid_cap cap_insert_valid_cap out_cte_at + cap_insert_cte_at cap_delete_cte_at out_valid_cap out_tcb_valid + hoare_vcg_const_imp_liftE_R hoare_vcg_all_liftE_R + thread_set_tcb_ipc_buffer_cap_cleared_invs + thread_set_invs_trivial[OF ball_tcb_cap_casesI] + hoare_vcg_all_lift thread_set_valid_cap out_emptyable + check_cap_inv [where P="valid_cap c" for c] + check_cap_inv [where P="tcb_cap_valid c p" for c p] + check_cap_inv[where P="cte_at p0" for p0] + check_cap_inv[where P="tcb_at p0" for p0] + thread_set_cte_at thread_set_no_cap_to_trivial[OF ball_tcb_cap_casesI] + checked_insert_no_cap_to + thread_set_cte_wp_at_trivial[where Q="\x. x", OF ball_tcb_cap_casesI] + out_no_cap_to_trivial[OF ball_tcb_cap_casesI] thread_set_ipc_tcb_cap_valid + check_cap_inv2[where Q="\_. P"] cap_delete_P cap_insert_P + thread_set_P thread_set_P' set_mcpriority_P set_mcpriority_idle_thread + reschedule_required_P dxo_wp_weak hoare_weak_lift_imp) + | simp add: ran_tcb_cap_cases dom_tcb_cap_cases[simplified] emptyable_def + | wpc + | strengthen use_no_cap_to_obj_asid_strg[simplified conj_comms] + tcb_cap_always_valid_strg[where p="tcb_cnode_index 0"] + tcb_cap_always_valid_strg[where p="tcb_cnode_index (Suc 0)"])+) (*slow*) + apply (unfold option_update_thread_def) + apply (wp itr_wps thread_set_P thread_set_P' + | simp add: emptyable_def | wpc)+ (*also slow*) + apply clarsimp + by (clarsimp simp: tcb_at_cte_at_0 tcb_at_cte_at_1[simplified] + is_cap_simps is_valid_vtable_root_def2 + is_cnode_or_valid_arch_def tcb_cap_valid_def + tcb_at_st_tcb_at[symmetric] invs_valid_objs + cap_asid_def vs_cap_ref_def + clas_no_asid cli_no_irqs no_cap_to_idle_thread + valid_ipc_buffer_cap_is_nondevice_page_cap + split: option.split_asm) + +lemma tc_reads_respects_f[Tcb_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + and tc[simp]: "ti = ThreadControl x41 x42 x43 x44 x45 x46 x47 x48" + notes validE_valid[wp del] hoare_weak_lift_imp [wp] + shows + "reads_respects_f aag l + (silc_inv aag st and only_timer_irq_inv irq st' and einvs and simple_sched_action + and pas_refined aag and pas_cur_domain aag and tcb_inv_wf ti + and is_subject aag \ cur_thread + and K (authorised_tcb_inv aag ti \ authorised_tcb_inv_extra aag ti)) + (invoke_tcb ti)" + apply (simp add: split_def cong: option.case_cong) + apply (wpsimp wp: set_priority_reads_respects[THEN reads_respects_f[where st=st and Q=\]]) + apply (wpsimp wp: hoare_vcg_const_imp_liftE_R simp: when_def | wpc)+ + apply (rule conjI) + apply ((wpsimp wp: reschedule_required_reads_respects_f)+)[4] + apply ((wp reads_respects_f[OF cap_insert_reads_respects, where st=st] + reads_respects_f[OF thread_set_reads_respects, where st=st and Q="\"] + set_priority_reads_respects[THEN + reads_respects_f[where aag=aag and st=st and Q=\]] + set_mcpriority_reads_respects[THEN + reads_respects_f[where aag=aag and st=st and Q=\]] + check_cap_inv[OF check_cap_inv[OF cap_insert_valid_list]] + check_cap_inv[OF check_cap_inv[OF cap_insert_valid_sched]] + check_cap_inv[OF check_cap_inv[OF cap_insert_schedact]] + check_cap_inv[OF check_cap_inv[OF cap_insert_cur_domain]] + check_cap_inv[OF check_cap_inv[OF cap_insert_ct]] + get_thread_state_rev[THEN + reads_respects_f[where aag=aag and st=st and Q=\]] + hoare_vcg_all_liftE_R hoare_vcg_all_lift + cap_delete_reads_respects[where st=st] checked_insert_pas_refined + thread_set_pas_refined + reads_respects_f[OF checked_insert_reads_respects, where st=st] + checked_cap_insert_silc_inv[where st=st] + cap_delete_silc_inv_not_transferable[where st=st] + checked_cap_insert_only_timer_irq_inv[where st=st' and irq=irq] + cap_delete_only_timer_irq_inv[where st=st' and irq=irq] + set_priority_only_timer_irq_inv[where st=st' and irq=irq] + set_mcpriority_only_timer_irq_inv[where st=st' and irq=irq] + cap_delete_deletes cap_delete_valid_cap cap_delete_cte_at + cap_delete_pas_refined' itr_wps(12) itr_wps(14) cap_insert_cte_at + checked_insert_no_cap_to hoare_vcg_const_imp_liftE_R hoare_vcg_conj_lift + as_user_reads_respects_f thread_set_mdb cap_delete_invs + thread_set_valid_arch_state + | wpc + | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def + tcb_at_st_tcb_at when_def + | strengthen use_no_cap_to_obj_asid_strg invs_mdb + | solves auto)+)[7] + apply ((simp add: conj_comms, strengthen imp_consequent[where Q="x = None" for x] + , simp cong: conj_cong) + | wp reads_respects_f[OF cap_insert_reads_respects, where st=st] + reads_respects_f[OF thread_set_reads_respects, where st=st and Q="\"] + set_priority_reads_respects[THEN reads_respects_f[where st=st and Q=\]] + set_mcpriority_reads_respects[THEN reads_respects_f[where st=st and Q=\]] + check_cap_inv[OF check_cap_inv[OF cap_insert_valid_list]] + check_cap_inv[OF check_cap_inv[OF cap_insert_valid_sched]] + check_cap_inv[OF check_cap_inv[OF cap_insert_schedact]] + check_cap_inv[OF check_cap_inv[OF cap_insert_cur_domain]] + check_cap_inv[OF check_cap_inv[OF cap_insert_ct]] + get_thread_state_rev[THEN reads_respects_f[where st=st and Q=\]] + hoare_vcg_all_liftE_R hoare_vcg_all_lift + cap_delete_reads_respects[where st=st] checked_insert_pas_refined + thread_set_pas_refined reads_respects_f[OF checked_insert_reads_respects] + checked_cap_insert_silc_inv[where st=st] + cap_delete_silc_inv_not_transferable[where st=st] + checked_cap_insert_only_timer_irq_inv[where st=st' and irq=irq] + cap_delete_only_timer_irq_inv[where st=st' and irq=irq] + set_priority_only_timer_irq_inv[where st=st' and irq=irq] + set_mcpriority_only_timer_irq_inv[where st=st' and irq=irq] + cap_delete_deletes cap_delete_valid_cap cap_delete_cte_at + cap_delete_pas_refined' itr_wps(12) itr_wps(14) cap_insert_cte_at + checked_insert_no_cap_to hoare_vcg_const_imp_liftE_R + as_user_reads_respects_f cap_delete_invs + | wpc + | simp add: emptyable_def tcb_cap_cases_def tcb_cap_valid_def when_def st_tcb_at_triv + | strengthen use_no_cap_to_obj_asid_strg invs_mdb + | wp (once) hoare_drop_imp)+ + apply (simp add: option_update_thread_def tcb_cap_cases_def + | wp hoare_weak_lift_imp hoare_weak_lift_imp_conj thread_set_pas_refined + reads_respects_f[OF thread_set_reads_respects, where st=st and Q="\"] + thread_set_valid_arch_state + | wpc)+ + apply (wp hoare_vcg_all_lift thread_set_tcb_fault_handler_update_invs + thread_set_tcb_fault_handler_update_silc_inv + thread_set_not_state_valid_sched + thread_set_pas_refined thread_set_emptyable thread_set_valid_cap + thread_set_cte_at thread_set_no_cap_to_trivial + thread_set_tcb_fault_handler_update_only_timer_irq_inv + thread_set_valid_arch_state + | simp add: tcb_cap_cases_def | wpc | wp (once) hoare_drop_imp)+ + apply (clarsimp simp: authorised_tcb_inv_def authorised_tcb_inv_extra_def emptyable_def) + apply (clarsimp cong: conj_cong) + apply (intro conjI impI allI) + (* slow *) + by (clarsimp simp: is_cap_simps is_cnode_or_valid_arch_def is_valid_vtable_root_def + det_setRegister option.disc_eq_case[symmetric] + split: cap.splits arch_cap.splits option.split pt_type.splits)+ + +crunch lazy_fpu_restore + for cdt[wp]: "\s. P (cdt s)" + and is_original_cap[wp]: "\s. P (is_original_cap s)" + and interrupt_states[wp]: "\s. P (interrupt_states s)" + and interrupt_irq_node[wp]: "\s. P (interrupt_irq_node s)" + and ready_queues[wp]: "\s. P (ready_queues s)" + and asid_pools_of[wp]: "\s. P (asid_pools_of s)" + and asid_table[wp]: "\s. P (asid_table s)" + and numlistregs[wp]: "\s. P (numlistregs s)" + and vcpu_state[wp]: "\s. P (vcpu_state (machine_state s))" + and underlying_memory[wp]: "\s. P (underlying_memory (machine_state s))" + and device_state[wp]: "\s. P (device_state (machine_state s))" + (wp: dmo_wp crunch_wps ignore: arch_thread_set) + +lemma equiv_but_for_labels_guard_imp: + "\ equiv_but_for_labels aag L' st s; L' \ L \ + \ equiv_but_for_labels aag L st s" + by (auto simp: equiv_but_for_labels_def elim!: states_equiv_for_guard_imp) + +definition is_subject_cur_fpu_2 where + "is_subject_cur_fpu_2 aag cf \ \ptr. cf = Some ptr \ is_subject aag ptr" + +locale_abbrev is_subject_cur_fpu where + "is_subject_cur_fpu aag \ \s. is_subject_cur_fpu_2 aag (arm_current_fpu_owner (arch_state s))" + +lemmas is_subject_cur_fpu_def = is_subject_cur_fpu_2_def + +lemma dmo_enableFpu_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op enableFpu)" + unfolding enableFpu_def dmo_distr + apply wpsimp + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_reads_respects modify_ev) + apply (clarsimp simp: equiv_for_def) + apply (wpsimp wp: dmo_mol_reads_respects)+ + done + +lemma dmo_disableFpu_reads_respects[wp]: + "reads_respects aag l \ (do_machine_op disableFpu)" + unfolding disableFpu_def dmo_distr + apply wpsimp + apply (rule use_spec_ev) + apply (wpsimp wp: do_machine_op_reads_respects modify_ev) + apply (clarsimp simp: equiv_for_def) + apply (wpsimp wp: dmo_mol_reads_respects)+ + done + +(* FIXME AARCH64 IF: consolidate cur_fpu_of and is_arch_cur_fpu *) +lemma equiv_kheap_equiv_cur_fpu_of: + "\ equiv_for P kheap s s'; P t; valid_cur_fpu s; valid_cur_fpu s' \ + \ cur_fpu_of s t = cur_fpu_of s' t" + by (clarsimp simp: valid_cur_fpu_def equiv_for_def is_tcb_cur_fpu_def obj_at_def) + +lemma lazy_fpu_restore_reads_respects: + "reads_respects aag l (valid_cur_fpu and K (is_subject aag t)) (lazy_fpu_restore t)" + unfolding lazy_fpu_restore_def + apply (subst gets_comp) + apply (case_tac "aag_can_read_or_affect aag l t") + apply (wpsimp simp: lazy_fpu_restore_def wp: thread_get_reads_respects gets_ev'') + apply (rename_tac s s') + apply (prop_tac "valid_cur_fpu s") + apply assumption + apply (prop_tac "valid_cur_fpu s'") + apply assumption + apply clarsimp + apply (prop_tac "equiv_for (aag_can_read_or_affect aag l) kheap s s'") + apply (clarsimp simp: reads_equiv_def2 affects_equiv_def2 states_equiv_for_def equiv_for_disj) + apply (clarsimp simp: equiv_kheap_equiv_cur_fpu_of) + apply wpsimp + apply (wpsimp wp: thread_get_reads_respects) + apply (wpsimp wp: thread_get_wp') + apply clarsimp + apply (rule gen_asm_ev) + apply clarsimp + done + +lemma arch_post_set_flags_reads_respects_f[Tcb_IF_assms]: + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects_f aag l (silc_inv aag st and valid_cur_fpu and K (is_subject aag t)) (arch_post_set_flags t flags)" + unfolding arch_post_set_flags_def + apply (rule equiv_valid_guard_imp) + apply (wpsimp wp: when_ev reads_respects_f[OF fpu_release_reads_respects] + reads_respects_f[OF lazy_fpu_restore_reads_respects]) + apply fastforce + done + +lemma arch_tcb_context_get_cur_fpu_update[simp]: + "arch_tcb_context_get (tcb_arch tcb\tcb_cur_fpu := fpu\) = arch_tcb_context_get (tcb_arch tcb)" + by (simp add: arch_tcb_context_get_def) + +lemma globals_equiv_fpu_owner_update[simp]: + "globals_equiv st (s\arch_state := arch_state s\arm_current_fpu_owner := t\\) = + globals_equiv st s" + by (auto simp add: globals_equiv_def idle_equiv_def) + +lemma set_arm_current_fpu_owner_globals_equiv[wp]: + "\globals_equiv st and valid_arch_state\ + set_arm_current_fpu_owner t + \\_. globals_equiv st\" + unfolding set_arm_current_fpu_owner_def arch_thread_set_is_thread_set + by (wpsimp wp: thread_set_globals_equiv thread_set_valid_arch_state hoare_vcg_all_lift hoare_drop_imps + | fastforce simp: ran_tcb_cap_cases)+ + +lemma dmo_enableFpu_globals_equiv[wp]: + "do_machine_op enableFpu \globals_equiv st\" + by (wpsimp wp: bind_wp_skip + simp: globals_equiv_def idle_equiv_def enableFpu_def dmo_distr dmo_modify_distr) + +lemma dmo_disableFpu_globals_equiv[wp]: + "do_machine_op disableFpu \globals_equiv st\" + apply (clarsimp simp: disableFpu_def dmo_distr dmo_modify_distr) + apply (rule bind_wp_skip) + apply (unfold globals_equiv_def arch_globals_equiv_def idle_equiv_def enableFpu_def)[1] + apply wpsimp + apply wpsimp + done + +lemma dmo_state_assert_inv[wp]: + "do_machine_op (state_assert f) \P\" + unfolding state_assert_def + by (wpsimp wp: dmo_wp) + +lemma dmo_readFpuState_globals_equiv[wp]: + "do_machine_op readFpuState \globals_equiv st\" + by (wpsimp simp: readFpuState_def dmo_distr dmo_modify_distr) + +lemma dmo_writeFpuState_globals_equiv[wp]: + "do_machine_op (writeFpuState fpustate) \globals_equiv st\" + apply (clarsimp simp: writeFpuState_def dmo_distr dmo_modify_distr) + apply wpsimp + apply (clarsimp simp: globals_equiv_def idle_equiv_def) + done + +lemma as_user_getRestart_inv[wp]: + "as_user t getFPUState \P\" + unfolding getFPUState_def + by (wpsimp wp: as_user_inv) + +lemma load_fpu_state_globals_equiv[wp]: + "load_fpu_state t \globals_equiv st\" + unfolding load_fpu_state_def + by wpsimp + +lemma save_fpu_state_globals_equiv[wp]: + "\globals_equiv st and valid_arch_state and (\s. t \ idle_thread s)\ + save_fpu_state t + \\_. globals_equiv st\" + unfolding save_fpu_state_def + by wpsimp + +crunch load_fpu_state, save_fpu_state + for valid_arch_state[wp]: "valid_arch_state" + +lemma switch_local_fpu_owner_globals_equiv: + "\globals_equiv st and invs\ + switch_local_fpu_owner new_owner + \\_. globals_equiv st\" + unfolding switch_local_fpu_owner_def + apply (wpsimp wp: hoare_vcg_all_lift hoare_weak_lift_imp) + apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_cur_fpu_def + is_tcb_cur_fpu_def live_def arch_tcb_live_def + dest: idle_no_ex_cap if_live_then_nonz_capD) + done + +lemma lazy_fpu_restore_globals_equiv: + "\globals_equiv st and invs\ + lazy_fpu_restore t + \\_. globals_equiv st\" + unfolding lazy_fpu_restore_def + by (wpsimp wp: switch_local_fpu_owner_globals_equiv hoare_drop_imps) + +crunch arch_post_set_flags + for globals_equiv[Tcb_IF_assms]: "globals_equiv st" + (simp: crunch_simps) + +end + + +global_interpretation Tcb_IF_2?: Tcb_IF_2 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact Tcb_IF_assms)?) +qed + +end diff --git a/proof/infoflow/AARCH64/ArchUserOp_IF.thy b/proof/infoflow/AARCH64/ArchUserOp_IF.thy new file mode 100644 index 0000000000..f345f94fc1 --- /dev/null +++ b/proof/infoflow/AARCH64/ArchUserOp_IF.thy @@ -0,0 +1,832 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchUserOp_IF +imports UserOp_IF +begin + +context Arch begin arch_global_naming + +definition ptable_lift_s where + "ptable_lift_s s \ ptable_lift (cur_thread s) s" + +definition ptable_rights_s where + "ptable_rights_s s \ ptable_rights (cur_thread s) s" + +(* FIXME: move to ADT_AI.thy *) +definition ptable_attrs :: "obj_ref \ 's :: state_ext state \ obj_ref \ vm_attributes" where + "ptable_attrs tcb s \ + \addr. case_option {} (fst o snd o snd) + (get_page_info (aobjs_of s) (get_vspace_of_thread (kheap s) (arch_state s) tcb) addr)" + +definition ptable_attrs_s :: "'s :: state_ext state \ obj_ref \ vm_attributes" where + "ptable_attrs_s s \ ptable_attrs (cur_thread s) s" + +definition ptable_xn_s where + "ptable_xn_s s \ \addr. Execute \ ptable_attrs_s s addr" + + +type_synonym user_state_if = "user_context \ user_mem \ device_state" + +text \ + A user transition gives back a possible event that is the next + event the user wants to perform +\ +type_synonym user_transition_if = + "obj_ref \ vm_mapping \ mem_rights \ (obj_ref \ bool) \ + user_state_if \ (event option \ user_state_if) set" + + +definition do_user_op_if :: + "user_transition_if \ user_context \ (event option \ user_context,'z::state_ext) s_monad" where + "do_user_op_if uop tc = + do + \ \Get the page rights of each address (ReadOnly, ReadWrite, None, etc).\ + pr \ gets ptable_rights_s; + + \ \Fetch the execute bits of the current thread's page mappings.\ + pxn \ gets (\s x. pr x \ {} \ ptable_xn_s s x); + + \ \Get the mapping from virtual to physical addresses.\ + pl \ gets (\s. restrict_map (ptable_lift_s s) {x. pr x \ {}}); + + allow_read \ return {y. EX x. pl x = Some y \ AllowRead \ pr x}; + allow_write \ return {y. EX x. pl x = Some y \ AllowWrite \ pr x}; + + \ \Get the current thread.\ + t \ gets cur_thread; + + \ \Generate user memory by throwing away anything from global + memory that the user doesn't have access to. (The user must + have both (1) a mapping to the page; (2) that mapping has the + AllowRead right.\ + um \ gets (\s. (user_mem s) \ ptrFromPAddr); + dm \ gets (\s. (device_mem s) \ ptrFromPAddr); + ds \ gets (device_state \ machine_state); + + \ \Non-deterministically execute one of the user's operations.\ + u \ return (uop t pl pr pxn (tc, um|`allow_read, (ds \ ptrFromPAddr)|` allow_read)); + assert (u \ {}); + (e,(tc',um',ds')) \ select u; + + \ \Update the changes the user made to memory into our model. + We ignore changes that took place where they didn't have + write permissions. (uop shouldn't be doing that --- if it is, + uop isn't correctly modelling real hardware.)\ + do_machine_op (user_memory_update (((um' |` allow_write) \ addrFromPPtr) |` (-(dom ds)))); + + do_machine_op (device_memory_update (((ds' |` allow_write) \ addrFromPPtr) |` (dom ds))); + + return (e,tc') + od" + + +named_theorems UserOp_IF_assms + +lemma arch_globals_equiv_underlying_memory_update[UserOp_IF_assms, simp]: + "arch_globals_equiv ct it kh kh' as as' (underlying_memory_update f ms) ms' = + arch_globals_equiv ct it kh kh' as as' ms ms'" + "arch_globals_equiv ct it kh kh' as as' ms (underlying_memory_update f ms') = + arch_globals_equiv ct it kh kh' as as' ms ms'" + by auto + +lemma arch_globals_equiv_device_state_update[UserOp_IF_assms, simp]: + "arch_globals_equiv ct it kh kh' as as' (device_state_update f ms) ms' = + arch_globals_equiv ct it kh kh' as as' ms ms'" + "arch_globals_equiv ct it kh kh' as as' ms (device_state_update f ms') = + arch_globals_equiv ct it kh kh' as as' ms ms'" + by auto + +lemma no_hyp_modify[UserOp_IF_assms]: + "\f. no_hyp (modify (\ms. ms\underlying_memory := f ms\))" + "\f. no_hyp (modify (\ms. ms\device_state := f ms\))" + "\f. no_hyp (modify (\ms. ms\machine_state_rest := f ms\))" + by wpsimp+ + +lemma no_fpu_modify[UserOp_IF_assms]: + "\f. no_fpu (modify (\ms. ms\underlying_memory := f ms\))" + "\f. no_fpu (modify (\ms. ms\device_state := f ms\))" + "\f. no_fpu (modify (\ms. ms\machine_state_rest := f ms\))" + by wpsimp+ + +end + + +arch_requalify_types user_transition_if + +global_interpretation UserOp_IF_1?: UserOp_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact UserOp_IF_assms)?) +qed + + +context Arch begin arch_global_naming + +lemma requiv_get_pt_of_thread_eq: + "\ reads_equiv aag s s'; pas_refined aag s; is_subject aag (cur_thread s); + pt_ref \ arm_us_global_vspace (arch_state s); pt_ref' \ arm_us_global_vspace (arch_state s'); + get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = pt_ref; + get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = pt_ref' \ + \ pt_ref = pt_ref'" + apply (erule reads_equivE) + apply (erule equiv_forE) + apply (subgoal_tac "aag_can_read aag (cur_thread s)") + apply (clarsimp simp: get_vspace_of_thread_eq) + apply simp + done + +lemma requiv_get_pt_entry_eq: + "\ reads_equiv aag s t; invs s; pas_refined aag s; is_subject aag pt; vref \ user_region; + \asid vref. vs_lookup_table max_pt_level asid vref s = Some (max_pt_level, pt) \ + \ pt_lookup_slot pt vref (ptes_of s) = pt_lookup_slot pt vref (ptes_of t)" + apply (clarsimp simp: pt_lookup_slot_def) + apply (clarsimp simp: pt_lookup_slot_from_level_def) + apply (frule_tac pt=pt and vptr=vref in pt_walk_reads_equiv[where bot_level=0]) + apply clarsimp+ + apply (fastforce simp: reads_equiv_f_def) + apply (fastforce elim: vs_lookup_table_vref_independent) + apply (clarsimp simp: obind_def split: option.splits) + done + +lemma requiv_get_page_info_eq: + "\ reads_equiv aag s s'; pas_refined aag s; invs s; is_subject aag pt; + \asid. vs_lookup_table max_pt_level asid x s = Some (max_pt_level, pt) \ + \ get_page_info (aobjs_of s) pt x = get_page_info (aobjs_of s') pt x" + apply (clarsimp simp: get_page_info_def obind_def) + apply (subgoal_tac "pt_lookup_slot pt x (ptes_of s) = pt_lookup_slot pt x (ptes_of s')") + apply (clarsimp split: option.splits) + apply (case_tac "pt_lookup_slot pt x (ptes_of s') = Some (a, b)"; clarsimp) + apply (frule_tac ptr=b in ptes_of_reads_equiv[rotated]) + apply (clarsimp simp: pt_lookup_slot_def) + apply (rule_tac pt_lookup_slot_from_level_is_subject) + apply fastforce+ + apply (rule requiv_get_pt_entry_eq; fastforce) + done + +lemma requiv_vspace_of_thread_global_pt: + "\ reads_equiv aag s s'; is_subject aag (cur_thread s); invs s; pas_refined aag s; + get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = global_pt s \ + \ get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = global_pt s'" + apply (erule reads_equivE) + apply (erule equiv_forE) + apply (prop_tac "aag_can_read aag (cur_thread s)", simp) + apply (clarsimp simp: get_vspace_of_thread_def + split: option.split kernel_object.splits cap.splits arch_cap.splits pt_type.splits) + apply (rename_tac tcb pt asid vref) + apply (subgoal_tac "aag_can_read_asid aag asid") + apply (subgoal_tac "s \ ArchObjectCap (PageTableCap pt VSRootPT_T (Some (asid,vref)))") + apply (clarsimp simp: equiv_asids_def equiv_asid_def valid_cap_def obind_def + vspace_for_asid_def vspace_for_pool_def pool_for_asid_def) + apply (clarsimp simp: word_gt_0 typ_at_eq_kheap_obj) + apply (drule_tac x=asid in spec) + apply (case_tac "asid = 0"; clarsimp) + apply (clarsimp simp: asid_pools_of_ko_at obj_at_def) + apply (clarsimp simp: asid_low_bits_of_def opt_map_def + entry_for_asid_def entry_for_pool_def pool_for_asid_def obind_def + split: option.splits) + apply (drule invs_valid_global_refs) + apply (drule_tac ptr="((cur_thread s), tcb_cnode_index 1)" in valid_global_refsD2[rotated]) + apply (subst caps_of_state_tcb_cap_cases) + apply (simp add: get_tcb_def) + apply (simp add: dom_tcb_cap_cases[simplified]) + apply simp + apply (simp add: cap_range_def global_refs_def) + apply (cut_tac s=s and t="cur_thread s" and tcb=tcb in objs_valid_tcb_vtable) + apply (fastforce simp: invs_valid_objs get_tcb_def)+ + apply (subgoal_tac "(pasObjectAbs aag (cur_thread s), Control, pasASIDAbs aag asid) + \ state_asids_to_policy aag s") + apply (frule pas_refined_Control_into_is_subject_asid) + apply (fastforce simp: pas_refined_def) + apply simp + apply (cut_tac aag=aag and ptr="(cur_thread s, tcb_cnode_index 1)" in sata_asid) + prefer 3 + apply (simp add: caps_of_state_tcb_cap_cases get_tcb_def dom_tcb_cap_cases[simplified])+ + done + +lemma vspace_for_asid_get_vspace_of_thread: + "get_vspace_of_thread (kheap s) (arch_state s) ct \ global_pt s + \ \asid. vspace_for_asid asid s = Some (get_vspace_of_thread (kheap s) (arch_state s) ct)" + by (fastforce simp: get_vspace_of_thread_def + split: option.splits kernel_object.splits cap.splits arch_cap.splits pt_type.splits) + +lemma pt_of_thread_same_agent: + "\ pas_refined aag s; is_subject aag tcb_ptr; + get_vspace_of_thread (kheap s) (arch_state s) tcb_ptr = pt; pt \ global_pt s \ + \ pasObjectAbs aag tcb_ptr = pasObjectAbs aag pt" + apply (rule_tac aag="pasPolicy aag" in aag_wellformed_Control[rotated]) + apply (fastforce simp: pas_refined_def) + apply (rule pas_refined_mem[rotated], simp) + apply (clarsimp simp: get_vspace_of_thread_eq) + apply (cut_tac ptr="(tcb_ptr, tcb_cnode_index 1)" in sbta_caps) + prefer 4 + apply (simp add: state_objs_to_policy_def) + apply (subst caps_of_state_tcb_cap_cases) + apply (simp add: get_tcb_def) + apply (simp add: dom_tcb_cap_cases[simplified]) + apply simp + apply (simp add: obj_refs_def) + apply (simp add: cap_auth_conferred_def arch_cap_auth_conferred_def) + done + +lemma requiv_ptable_rights_eq: + "\ reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; + is_subject aag (cur_thread s); invs s; invs s' \ + \ ptable_rights_s s = ptable_rights_s s'" + apply (simp add: ptable_rights_s_def) + apply (rule ext) + apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = global_pt s") + apply (frule requiv_vspace_of_thread_global_pt) + apply (auto)[4] + apply (fastforce dest: get_page_info_gpd_kmaps[rotated 3] + simp: ptable_rights_def invs_valid_global_objs invs_arch_state + split: option.splits)+ + apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = global_pt s'") + apply (drule reads_equiv_sym) + apply (frule requiv_vspace_of_thread_global_pt; fastforce simp: reads_equiv_def) + apply (simp add: ptable_rights_def) + apply (frule requiv_get_pt_of_thread_eq) + apply (auto)[6] + apply (frule pt_of_thread_same_agent, simp+) + apply (subst requiv_get_page_info_eq, simp+) + apply (drule sym[where s="get_vspace_of_thread _ _ _"], clarsimp) + apply (fastforce dest: get_vspace_of_thread_reachable elim: vs_lookup_table_vref_independent)+ + done + +lemma requiv_ptable_attrs_eq: + "\ reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; + is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \ {} \ + \ ptable_attrs_s s x = ptable_attrs_s s' x" + apply (simp add: ptable_attrs_s_def ptable_rights_s_def) + apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = + arm_us_global_vspace (arch_state s)") + apply (frule requiv_vspace_of_thread_global_pt) + apply (fastforce+)[4] + apply (clarsimp simp: ptable_attrs_def split: option.splits) + apply (rule conjI) + apply clarsimp + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] + apply clarsimp + apply (rule conjI) + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] + apply clarsimp + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] + apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = + arm_us_global_vspace (arch_state s')") + apply (drule reads_equiv_sym) + apply (frule requiv_vspace_of_thread_global_pt) + apply ((fastforce simp: reads_equiv_def)+)[5] + apply (simp add: ptable_attrs_def) + apply (frule requiv_get_pt_of_thread_eq, simp+)[1] + apply (frule pt_of_thread_same_agent, simp+)[1] + apply (subst requiv_get_page_info_eq, simp+) + apply (drule sym[where s="get_vspace_of_thread _ _ _"], clarsimp) + apply (fastforce dest: get_vspace_of_thread_reachable elim: vs_lookup_table_vref_independent)+ + done + +lemma requiv_ptable_lift_eq: + "\ reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; invs s; + invs s'; is_subject aag (cur_thread s); ptable_rights_s s x \ {} \ + \ ptable_lift_s s x = ptable_lift_s s' x" + apply (simp add: ptable_lift_s_def ptable_rights_s_def) + apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) (cur_thread s) = + arm_us_global_vspace (arch_state s)") + apply (frule requiv_vspace_of_thread_global_pt) + apply (fastforce+)[4] + apply (clarsimp simp: ptable_lift_def split: option.splits) + apply (rule conjI) + apply clarsimp + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] + apply clarsimp + apply (rule conjI) + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] + apply clarsimp + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[4] + apply (case_tac "get_vspace_of_thread (kheap s') (arch_state s') (cur_thread s') = + arm_us_global_vspace (arch_state s')") + apply (drule reads_equiv_sym) + apply (frule requiv_vspace_of_thread_global_pt) + apply ((fastforce simp: reads_equiv_def)+)[5] + apply (simp add: ptable_lift_def) + apply (frule requiv_get_pt_of_thread_eq, simp+)[1] + apply (frule pt_of_thread_same_agent, simp+)[1] + apply (subst requiv_get_page_info_eq, simp+) + apply (drule sym[where s="get_vspace_of_thread _ _ _"], clarsimp) + apply (fastforce dest: get_vspace_of_thread_reachable elim: vs_lookup_table_vref_independent)+ + done + +lemma requiv_ptable_xn_eq: + "\ reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; + is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \ {} \ + \ ptable_xn_s s x = ptable_xn_s s' x" + by (simp add: ptable_xn_s_def requiv_ptable_attrs_eq) + +lemma data_at_obj_range: + "\ data_at sz ptr s; pspace_aligned s; valid_objs s \ + \ ptr + (offset && mask (pageBitsForSize sz)) \ obj_range ptr (ArchObj (DataPage dev sz))" + apply (clarsimp simp: data_at_def) + apply (elim disjE) + apply (clarsimp simp: obj_at_def) + apply (drule (2) ptr_in_obj_range) + apply (clarsimp simp: obj_bits_def obj_range_def) + apply fastforce + apply (clarsimp simp: obj_at_def) + apply (drule (2) ptr_in_obj_range) + apply (clarsimp simp: obj_bits_def obj_range_def) + apply fastforce + done + +lemma obj_range_data_for_cong: + "obj_range ptr (ArchObj (DataPage dev sz')) = obj_range ptr (ArchObj (DataPage False sz'))" + by (simp add: obj_range_def) + +lemma pspace_distinct_def': + "pspace_distinct \ + \s. \x y ko ko'. kheap s x = Some ko \ kheap s y = Some ko' \ x \ y + \ obj_range x ko \ obj_range y ko' = {}" + by (auto simp: pspace_distinct_def obj_range_def field_simps) + +lemma data_at_disjoint_equiv: + "\ ptr' \ ptr;data_at sz' ptr' s; data_at sz ptr s; valid_objs s; pspace_aligned s; + pspace_distinct s; ptr' \ obj_range ptr (ArchObj (DataPage dev sz)) \ + \ False" + apply (frule (2) data_at_obj_range[where offset = 0,simplified]) + apply (clarsimp simp: data_at_def obj_at_def) + apply (elim disjE) + by (clarsimp dest!: spec simp: obj_at_def pspace_distinct_def' + , erule impE, erule conjI2[OF conjI2], (fastforce+)[2] + , fastforce cong: obj_range_data_for_cong)+ + +lemma is_aligned_pptrBaseOffset: + "is_aligned pptrBaseOffset (pageBitsForSize sz)" + by (case_tac sz, simp_all add: pptrBaseOffset_def paddrBase_def pageBits_def canonical_bit_def + ptTranslationBits_def pptrBase_def is_aligned_def) + +lemma ptrFromPAddr_mask_simp: + "ptrFromPAddr z && ~~ mask (pageBitsForSize l) = + ptrFromPAddr (z && ~~ mask (pageBitsForSize l))" + apply (simp add: ptrFromPAddr_def field_simps) + apply (subst mask_out_add_aligned[OF is_aligned_pptrBaseOffset]) + apply simp + done + +lemma pageBitsForSize_le_canonical_bit: + "pageBitsForSize sz \ canonical_bit" + by (cases sz, simp_all add: pageBits_def ptTranslationBits_def canonical_bit_def) + +lemma data_at_same_size: + assumes dat_sz': + "data_at sz' (ptrFromPAddr base) s" + and dat_sz: + "data_at sz + (ptrFromPAddr (base + (x && mask (pageBitsForSize sz'))) && ~~ mask (pageBitsForSize sz)) s" + and vs: + "pspace_distinct s" "pspace_aligned s" "valid_objs s" + shows "sz' = sz" +proof - + from dat_sz' and dat_sz + have trivial: + "sz' \ sz + \ ptrFromPAddr (base + (x && mask (pageBitsForSize sz'))) && ~~ mask (pageBitsForSize sz) \ + ptrFromPAddr base" + by (auto simp: data_at_def obj_at_def) + have sz_equiv: "(pageBitsForSize sz = pageBitsForSize sz') = (sz' = sz)" + by (clarsimp simp: pageBitsForSize_def ptTranslationBits_def split: vmpage_size.splits) + show ?thesis + apply (rule sz_equiv[THEN iffD1]) + apply (rule ccontr) + apply (drule neq_iff[THEN iffD1]) + using dat_sz' dat_sz vs + apply (cut_tac trivial) prefer 2 + apply (fastforce simp: sz_equiv) + apply (frule(1) data_at_aligned) + apply (elim disjE) + apply (erule(5) data_at_disjoint_equiv) + apply (unfold obj_range_def) + apply (rule mask_in_range[THEN iffD1]) + apply (simp add: obj_bits_def)+ + apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp) + apply (rule arg_cong[where f = ptrFromPAddr]) + apply (subgoal_tac "is_aligned base (pageBitsForSize sz')") + apply (subst neg_mask_add_aligned[OF _ and_mask_less']) + apply simp + apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified]) + apply simp + apply (metis is_aligned_addD2 is_aligned_pptrBaseOffset ptrFromPAddr_def) + apply (drule not_sym) + apply (erule(5) data_at_disjoint_equiv) + apply (unfold obj_range_def) + apply (rule mask_in_range[THEN iffD1]) + apply (simp add: obj_bits_def is_aligned_neg_mask)+ + apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp) + apply (rule arg_cong[where f = ptrFromPAddr]) + apply (subgoal_tac "is_aligned base (pageBitsForSize sz')") + apply (rule sym) + apply (subst mask_lower_twice[symmetric]) + apply (erule less_imp_le_nat) + apply (rule arg_cong[where f = "\x. x && ~~ mask z" for z]) + apply (subst neg_mask_add_aligned[OF _ and_mask_less']) + apply simp + apply (fastforce simp: pbfs_less_wb'[unfolded word_bits_def,simplified]) + apply simp + apply (metis is_aligned_addD2 is_aligned_pptrBaseOffset ptrFromPAddr_def) + done +qed + +lemmas bit_minus_one_leq_less = bit0.minus_one_leq_less bit1.minus_one_leq_less +lemmas bit_zero_least = bit0.zero_least bit1.zero_least + +lemma level_le_2_cases: + "(level :: vm_level) \ 2 \ level = 0 \ level = 1 \ level = 2" + apply clarsimp + apply (erule_tac P="level=2" in swap) + apply (subst (asm) order.order_iff_strict) + apply (erule disjE_R) + apply (clarsimp simp: order.strict_implies_not_eq) + apply (induct level; clarsimp) + apply (drule meta_mp) + apply (erule order.strict_implies_not_eq) + apply (drule meta_mp) + apply (rule bit_minus_one_leq_less) + apply (erule order.strict_implies_order) + apply (erule bit_zero_least) + apply clarsimp + apply clarsimp + done + +lemma pt_walk_vref_for_levelD: + "\ pt_walk top_level bot_level pt vref ptes = Some (level,ptr); + level \ top_level; top_level \ max_pt_level \ + \ pt_walk top_level bot_level pt (vref_for_level vref level) ptes = Some (level,ptr)" + apply (induct top_level arbitrary: pt) + apply (simp add: pt_walk.simps Let_def oapply_def) + apply (case_tac "top_level=bot_level") + apply (simp add: pt_walk.simps) + apply (erule_tac x="pptr_from_pte (the (ptes (level_type top_level) (pt_slot_offset top_level pt vref)))" + in meta_allE) + apply (subst (asm) pt_walk.simps) + apply (subst pt_walk.simps) + apply (simp add: Let_def vm_level.leq_minus1_less) + apply (clarsimp simp: obind_def split: if_splits option.splits) + apply (meson pt_walk_max_level vm_level.leq_minus1_less vm_level.zero_least) + done + +lemma ptable_lift_data_consistant: + assumes vs: "valid_state s" + and pt_lift: "ptable_lift t s x = Some ptr" + and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s" + and misc: "get_vspace_of_thread (kheap s) (arch_state s) t \ arm_us_global_vspace (arch_state s)" + shows "ptable_lift t s (x && ~~ mask (pageBitsForSize sz)) = + Some (ptr && ~~ mask (pageBitsForSize sz))" +proof - + have vs': "valid_objs s \ valid_arch_state s \ valid_vspace_objs s + \ pspace_distinct s \ pspace_aligned s" + using vs by (simp add: valid_state_def valid_pspace_def) + thus ?thesis + using pt_lift dat vs' + apply (clarsimp simp: ptable_lift_def split: option.splits) + apply (clarsimp simp: get_page_info_def simp: obind_def split: option.splits) + apply (rule exE[OF vspace_for_asid_get_vspace_of_thread[OF misc(1)]]) + apply (rename_tac level pt pde asid) + apply (case_tac pde; clarsimp simp: pte_info_def) + apply (frule pt_lookup_slot_max_pt_level) + apply (frule vspace_for_asid_vs_lookup) + apply (clarsimp split: if_splits) + apply (frule_tac level=level in valid_vspace_objs_pte) + apply clarsimp + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) + apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned] + dest: valid_arch_state_asid_table dest!: pt_lookup_vs_lookupI + intro: vs_lookup_level) + apply (erule disjE[OF _ _ FalseE]) + prefer 2 + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad pt_walk.simps) + apply (clarsimp split: if_splits) + apply (fastforce dest: pt_walk_max_level simp: max_pt_level_def2) + apply clarsimp + apply (clarsimp simp: valid_pte_def) + apply (frule data_at_same_size[symmetric]; simp?) + apply (simp add: pageBitsForSize_pt_bits_left) + apply (fold vref_for_level_def) + apply (prop_tac "level_of_vmsize (vmsize_of_level level) = level") + apply (metis data_at_level pageBitsForSize_pt_bits_left) + apply clarsimp + apply (prop_tac "pt_lookup_slot (get_vspace_of_thread (kheap s) (arch_state s) t) + (vref_for_level x level) (ptes_of s) = Some (level, pt)") + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) + apply (fastforce dest: pt_walk_vref_for_levelD) + using vref_for_level_user_region + apply (fastforce simp: vref_for_level_def is_aligned_mask_out_add_eq mask_AND_NOT_mask + is_aligned_ptrFromPAddr_n_eq + dest: data_at_aligned) + done +qed + +(* FIXME AARCH64 IF: override in ArchRetype_AI *) +lemma valid_vspace_objs_pte: + "\ ptes_of s pt_t p = Some pte; valid_vspace_objs s; \\ (level, table_base pt_t p) s \ + \ valid_pte level pte s" + apply (clarsimp simp: ptes_of_def in_opt_map_eq) + apply (drule (2) valid_vspace_objsD) + apply (fastforce simp: in_opt_map_eq) + apply simp + done + +lemma ptable_rights_data_consistant: + assumes vs: "valid_state s" + and pt_lift: "ptable_lift t s x = Some ptr" + and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s" + and misc: "get_vspace_of_thread (kheap s) (arch_state s) t \ + arm_us_global_vspace (arch_state s)" + shows "ptable_rights t s (x && ~~ mask (pageBitsForSize sz)) = ptable_rights t s x" +proof - + have vs': "valid_objs s \ valid_arch_state s \ valid_vspace_objs s + \ pspace_distinct s \ pspace_aligned s" + using vs by (simp add: valid_state_def valid_pspace_def) + thus ?thesis + using pt_lift dat vs' + apply (clarsimp simp: ptable_rights_def ptable_lift_def split: option.splits) + apply (clarsimp simp: get_page_info_def simp: obind_def split: option.splits if_splits) + apply (rule exE[OF vspace_for_asid_get_vspace_of_thread[OF misc(1)]]) + apply (rename_tac level pt pde asid) + apply (case_tac pde; clarsimp simp: pte_info_def) + apply (frule pt_lookup_slot_max_pt_level) + apply (frule vspace_for_asid_vs_lookup) + apply (frule_tac level=level in valid_vspace_objs_pte) + apply clarsimp + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) + apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned] + dest: valid_arch_state_asid_table dest!: pt_lookup_vs_lookupI + intro: vs_lookup_level) + apply (clarsimp simp: valid_pte_def) + apply (frule data_at_same_size[symmetric]; simp?) + apply (simp add: pageBitsForSize_pt_bits_left) + apply (prop_tac "level_of_vmsize (vmsize_of_level level) = level") + apply (metis data_at_level pageBitsForSize_pt_bits_left) + apply clarsimp + apply (fold vref_for_level_def) + apply (prop_tac "pt_lookup_slot (get_vspace_of_thread (kheap s) (arch_state s) t) + (vref_for_level x level) (ptes_of s) = Some (level, pt)") + apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad) + apply (fastforce dest: pt_walk_vref_for_levelD) + apply (rule conjI) + apply (fastforce) + apply clarsimp + using vref_for_level_user_region by fastforce +qed + + +lemma user_op_access_data_at: + "\ invs s; pas_refined aag s; is_subject aag tcb; ptable_lift tcb s x = Some ptr; + data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s; + auth \ vspace_cap_rights_to_auth (ptable_rights tcb s x) \ + \ (pasObjectAbs aag tcb, auth, + pasObjectAbs aag (ptrFromPAddr (ptr && ~~ mask (pageBitsForSize sz)))) \ pasPolicy aag" + apply (case_tac "get_vspace_of_thread (kheap s) (arch_state s) tcb = arm_us_global_vspace (arch_state s)") + apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits) + apply (frule get_page_info_gpd_kmaps[rotated 3]) + apply (fastforce simp: invs_valid_global_objs invs_arch_state)+ + apply (frule (1) ptable_lift_data_consistant[rotated 2]) + apply fastforce + apply fastforce + apply (frule (1) ptable_rights_data_consistant[rotated 2]) + apply fastforce + apply fastforce + apply (erule (3) user_op_access) + apply simp + done + +lemma user_frame_at_equiv: + "\ typ_at (AArch (AUserData sz)) p s; equiv_for P kheap s s'; P p \ + \ typ_at (AArch (AUserData sz)) p s'" + by (clarsimp simp: equiv_for_def obj_at_def) + +lemma device_frame_at_equiv: + "\ typ_at (AArch (ADeviceData sz)) p s; equiv_for P kheap s s'; P p \ + \ typ_at (AArch (ADeviceData sz)) p s'" + by (clarsimp simp: equiv_for_def obj_at_def) + +lemma typ_at_user_data_at: + "typ_at (AArch (AUserData sz)) p s \ data_at sz p s" + by (simp add: data_at_def) + +lemma typ_at_device_data_at: + "typ_at (AArch (ADeviceData sz)) p s \ data_at sz p s" + by (simp add: data_at_def) + +lemma requiv_device_mem_eq: + "\ reads_equiv aag s s'; globals_equiv s s'; invs s; invs s'; + is_subject aag (cur_thread s); AllowRead \ ptable_rights_s s x; + ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \ + \ device_mem s (ptrFromPAddr y) = device_mem s' (ptrFromPAddr y)" + apply (simp add: device_mem_def) + apply (rule conjI) + apply (erule reads_equivE) + apply (clarsimp simp: in_device_frame_def) + apply (rule exI) + apply (rule device_frame_at_equiv) + apply assumption+ + apply (erule_tac f="underlying_memory" in equiv_forE) + apply (frule_tac auth=Read in user_op_access_data_at[where s=s]) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_device_data_at)+ + apply (rule reads_read) + apply (fastforce simp: ptrFromPAddr_mask_simp) + apply clarsimp + apply (frule requiv_ptable_rights_eq, fastforce+) + apply (frule requiv_ptable_lift_eq, fastforce+) + apply (clarsimp simp: globals_equiv_def) + apply (erule notE) + apply (erule reads_equivE) + apply (clarsimp simp: in_device_frame_def) + apply (rule exI) + apply (rule device_frame_at_equiv) + apply assumption+ + apply (erule_tac f="underlying_memory" in equiv_forE) + apply (erule equiv_symmetric[THEN iffD1]) + apply (frule_tac auth=Read in user_op_access_data_at[where s=s']) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_device_data_at)+ + apply (rule reads_read) + apply (fastforce simp: ptrFromPAddr_mask_simp) + done + +lemma requiv_user_mem_eq: + "\ reads_equiv aag s s'; globals_equiv s s'; invs s; invs s'; + is_subject aag (cur_thread s); AllowRead \ ptable_rights_s s x; + ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \ + \ user_mem s (ptrFromPAddr y) = user_mem s' (ptrFromPAddr y)" + apply (simp add: user_mem_def) + apply (rule conjI) + apply clarsimp + apply (rule context_conjI') + apply (erule reads_equivE) + apply (clarsimp simp: in_user_frame_def) + apply (rule exI) + apply (rule user_frame_at_equiv) + apply assumption+ + apply (erule_tac f="underlying_memory" in equiv_forE) + apply (frule_tac auth=Read in user_op_access_data_at[where s = s]) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_user_data_at)+ + apply (rule reads_read) + apply (fastforce simp: ptrFromPAddr_mask_simp) + apply clarsimp + apply (subgoal_tac "aag_can_read aag (ptrFromPAddr y)") + apply (erule reads_equivE) + apply clarsimp + apply (erule_tac f="underlying_memory" in equiv_forE) + apply simp + apply (frule_tac auth=Read in user_op_access) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def)+ + apply (rule reads_read) + apply simp + apply (frule requiv_ptable_rights_eq, fastforce+) + apply (frule requiv_ptable_lift_eq, fastforce+) + apply (clarsimp simp: globals_equiv_def) + apply (erule notE) + apply (erule reads_equivE) + apply (clarsimp simp: in_user_frame_def) + apply (rule exI) + apply (rule user_frame_at_equiv) + apply assumption+ + apply (erule_tac f="underlying_memory" in equiv_forE) + apply (erule equiv_symmetric[THEN iffD1]) + apply (frule_tac auth=Read in user_op_access_data_at[where s=s']) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_user_data_at)+ + apply (rule reads_read) + apply (fastforce simp: ptrFromPAddr_mask_simp) + done + +lemma ptable_rights_imp_frameD: + "\ ptable_lift t s x = Some y;valid_state s;ptable_rights t s x \ {} \ + \ \sz. data_at sz (ptrFromPAddr y && ~~ mask (pageBitsForSize sz)) s" + apply (subst (asm) addrFromPPtr_ptrFromPAddr_id[symmetric]) + apply (drule ptable_rights_imp_frame) + apply simp+ + apply (rule addrFromPPtr_ptrFromPAddr_id[symmetric]) + apply (auto simp: in_user_frame_def in_device_frame_def + dest!: spec typ_at_user_data_at typ_at_device_data_at) + done + +lemma requiv_user_device_eq: + "\ reads_equiv aag s s'; globals_equiv s s'; invs s; invs s'; + is_subject aag (cur_thread s); AllowRead \ ptable_rights_s s x; + ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s' \ + \ device_state (machine_state s) (ptrFromPAddr y) = + device_state (machine_state s') (ptrFromPAddr y)" + apply (simp add: ptable_lift_s_def) + apply (frule ptable_rights_imp_frameD) + apply fastforce + apply (fastforce simp: ptable_rights_s_def) + apply (erule reads_equivE) + apply clarsimp + apply (erule_tac f="device_state" in equiv_forD) + apply (frule_tac auth=Read in user_op_access_data_at[where s = s]) + apply ((fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def + | intro typ_at_user_data_at)+)[6] + apply (rule reads_read) + apply (frule_tac auth=Read in user_op_access) + apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def vspace_cap_rights_to_auth_def)+ + done + + +definition context_matches_state where + "context_matches_state pl pr pxn ms s \ case ms of (um, ds) \ + pl = ptable_lift_s s |` {x. pr x \ {}} \ + pr = ptable_rights_s s \ + pxn = (\x. pr x \ {} \ ptable_xn_s s x) \ + um = (user_mem s \ ptrFromPAddr) |` {y. \x. pl x = Some y \ AllowRead \ pr x} \ + ds = (device_state (machine_state s) \ ptrFromPAddr) |` + {y. \x. pl x = Some y \ AllowRead \ pr x}" + + +lemma do_user_op_reads_respects_g: + notes split_paired_All[simp del] + shows + "(\pl pr pxn tc ms s. P tc s \ context_matches_state pl pr pxn ms s + \ (\x. uop (cur_thread s) pl pr pxn (tc, ms) = {x})) + \ reads_respects_g aag l (pas_refined aag and invs and is_subject aag \ cur_thread + and (\s. cur_thread s \ idle_thread s) and P tc) + (do_user_op_if uop tc)" + apply (simp add: do_user_op_if_def) + apply (rule use_spec_ev) + apply (rule spec_equiv_valid_add_asm) + apply (rule spec_equiv_valid_add_rel[OF _ reads_equiv_g_refl]) + apply (rule spec_equiv_valid_add_rel'[OF _ affects_equiv_refl]) + apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified]) + apply (clarsimp simp: reads_equiv_g_def) + apply (rule requiv_ptable_rights_eq,simp+)[1] + apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified]) + apply (rule ext) + apply (clarsimp simp: reads_equiv_g_def) + apply (case_tac "ptable_rights_s st x = {}", simp) + apply simp + apply (rule requiv_ptable_xn_eq,simp+)[1] + apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified]) + apply (subst expand_restrict_map_eq,clarsimp) + apply (clarsimp simp: reads_equiv_g_def) + apply (rule requiv_ptable_lift_eq,simp+)[1] + apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified]) + apply (clarsimp simp: reads_equiv_g_def) + apply (rule requiv_cur_thread_eq,fastforce) + apply (rule spec_equiv_valid_inv_gets_more[where proj="\m. dom m \ cw" + and projsnd="\m. m |` cr" for cr and cw]) + apply (rule context_conjI') + apply (subst expand_restrict_map_eq) + apply (clarsimp simp: reads_equiv_g_def restrict_map_def) + apply (rule requiv_user_mem_eq) + apply simp+ + apply fastforce + apply (rule spec_equiv_valid_inv_gets[where proj = "\x. ()", simplified]) + apply (rule spec_equiv_valid_inv_gets_more[where proj = "\m. (m \ ptrFromPAddr) |` cr" for cr]) + apply (rule conjI) + apply (subst expand_restrict_map_eq) + apply (clarsimp simp: restrict_map_def reads_equiv_g_def) + apply (rule requiv_user_device_eq) + apply simp+ + apply (clarsimp simp: globals_equiv_def reads_equiv_g_def) + apply (rule spec_equiv_valid_guard_imp) + apply (wpsimp wp: dmo_user_memory_update_reads_respects_g dmo_device_state_update_reads_respects_g + dmo_device_state_update_reads_respects_g select_ev dmo_wp) + apply clarsimp + apply (rule conjI) + apply clarsimp + apply (drule spec)+ + apply (erule impE) + prefer 2 + apply assumption + apply (clarsimp simp: context_matches_state_def comp_def reads_equiv_g_def globals_equiv_def) + apply (clarsimp simp: reads_equiv_g_def globals_equiv_def) + done + +definition valid_vspace_objs_if where + "valid_vspace_objs_if \ \" + +declare valid_vspace_objs_if_def[simp] + +end + +arch_requalify_consts + do_user_op_if + valid_vspace_objs_if + context_matches_state + +(* FIXME AARCH64 IF: this is currently used in do_user_op_if_reads_respects_g + where aag contains a free type variable, so this can't be a locale assumption. + Investigate whether we can tweak the interface, or otherwise add a comment. *) +arch_requalify_facts + do_user_op_reads_respects_g + +end diff --git a/proof/infoflow/AARCH64/Example_Valid_State.thy b/proof/infoflow/AARCH64/Example_Valid_State.thy new file mode 100644 index 0000000000..69d6fa2b7b --- /dev/null +++ b/proof/infoflow/AARCH64/Example_Valid_State.thy @@ -0,0 +1,2024 @@ +(* + * Copyright 2023, Proofcraft Pty Ltd + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory Example_Valid_State +imports + "ArchNoninterference" + "Lib.Distinct_Cmd" + "AInvs.KernelInit_AI" +begin + +(* FIXME AARCH64 IF: major cleanup *) + +section \Example\ + +(* This example is a classic 'one way information flow' + example, where information is allowed to flow from Low to High, + but not the reverse. We consider a typical scenario where + shared memory and an notification for notifications are used to + implement a ring-buffer. We consider the NTFN to be in the domain of High, + and the shared memory to be in the domain of Low. *) + +(* basic machine-level declarations that need to happen outside the locale *) + +consts s0_context :: user_context + +(* define the irqs to come regularly every 10 *) + +definition timer_irq :: irq where + "timer_irq \ 0" + +abbreviation (input) "timer_int \ 10" + +axiomatization where + irq_oracle_def: "AARCH64.irq_oracle \ \pos. if pos mod timer_int = 0 then timer_irq else 0" + +context begin interpretation Arch . (*FIXME: arch-split*) + +subsection \We show that the authority graph does not let information flow from High to Low\ + +datatype auth_graph_label = High | Low | IRQ0 + +abbreviation partition_label where + "partition_label x \ OrdinaryLabel x" + +definition Sys1AuthGraph :: "(auth_graph_label subject_label) auth_graph" where + "Sys1AuthGraph \ + {(partition_label High, Read, partition_label Low), + (partition_label Low, Notify, partition_label High), + (partition_label Low, Reset, partition_label High), + (SilcLabel, Read, partition_label Low), + (SilcLabel, Notify, partition_label High), + (SilcLabel, Reset, partition_label High)} + \ {(x, a, y). x = y}" + +lemma subjectReads_Low: + "subjectReads Sys1AuthGraph (partition_label Low) = {partition_label Low}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectReads.induct, (fastforce simp: Sys1AuthGraph_def)+) + done + +lemma Low_in_subjectReads_High: + "partition_label Low \ subjectReads Sys1AuthGraph (partition_label High)" + by (simp add: Sys1AuthGraph_def reads_read) + +lemma subjectReads_High: + "subjectReads Sys1AuthGraph (partition_label High) = {partition_label High, partition_label Low}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectReads.induct, (fastforce simp: Sys1AuthGraph_def)+) + apply (auto intro: Low_in_subjectReads_High) + done + +lemma subjectReads_IRQ0: + "subjectReads Sys1AuthGraph (partition_label IRQ0) = {partition_label IRQ0}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectReads.induct, (fastforce simp: Sys1AuthGraph_def)+) + done + +lemma High_in_subjectAffects_Low: + "partition_label High \ subjectAffects Sys1AuthGraph (partition_label Low)" + apply (rule affects_ep) + apply (simp add: Sys1AuthGraph_def) + apply (rule disjI1, simp+) + done + +lemma subjectAffects_Low: + "subjectAffects Sys1AuthGraph (partition_label Low) = {partition_label Low, partition_label High}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectAffects.induct, (fastforce simp: Sys1AuthGraph_def)+) + apply (auto intro: affects_lrefl High_in_subjectAffects_Low) + done + +lemma subjectAffects_High: + "subjectAffects Sys1AuthGraph (partition_label High) = {partition_label High}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectAffects.induct, (fastforce simp: Sys1AuthGraph_def)+) + apply (auto intro: affects_lrefl) + done + +lemma subjectAffects_IRQ0: + "subjectAffects Sys1AuthGraph (partition_label IRQ0) = {partition_label IRQ0}" + apply (rule equalityI) + apply (rule subsetI) + apply (erule subjectAffects.induct, (fastforce simp: Sys1AuthGraph_def)+) + apply (auto intro: affects_lrefl) + done + +lemmas subjectReads = subjectReads_High subjectReads_Low subjectReads_IRQ0 + +lemma partsSubjectAffects_Low: + "partsSubjectAffects Sys1AuthGraph Low = {Partition Low, Partition High}" + by (auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def + subjectReads subjectAffects_Low | case_tac xa, rename_tac xa)+ + +lemma partsSubjectAffects_High: + "partsSubjectAffects Sys1AuthGraph High = {Partition High}" + by (auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def + subjectReads subjectAffects_High | rename_tac xa, case_tac xa)+ + +lemma partsSubjectAffects_IRQ0: + "partsSubjectAffects Sys1AuthGraph IRQ0 = {Partition IRQ0}" + by (auto simp: partsSubjectAffects_def image_def label_can_affect_partition_def + subjectReads subjectAffects_IRQ0 | rename_tac xa, case_tac xa)+ + +lemmas partsSubjectAffects = + partsSubjectAffects_High partsSubjectAffects_Low partsSubjectAffects_IRQ0 + +definition example_policy where + "example_policy \ + {(PSched, d) | d. True} \ {(d,e). d = e} \ {(Partition Low, Partition High)}" + +lemma "policyFlows Sys1AuthGraph = example_policy" + apply (rule equalityI) + apply (rule subsetI) + apply (clarsimp simp: example_policy_def) + apply (erule policyFlows.cases) + apply (case_tac l, auto simp: partsSubjectAffects)[1] + apply assumption + apply (rule subsetI) + apply (clarsimp simp: example_policy_def) + apply (elim disjE) + apply (fastforce simp: partsSubjectAffects intro: policy_affects) + apply (fastforce intro: policy_scheduler) + apply (fastforce intro: policyFlows_refl refl_onD) + done + + +subsection \We show there exists a valid initial state associated to the + above authority graph\ + +text \ + +This example (modified from ../access-control/ExampleSystem) is a system Sys1 made +of 2 main components Low and High, connected through an notification NTFN. +Both Low and High contains: + + . one TCB + . one vspace made up of one top-level page table + - one asid pool with a single entry for the corresponding vspace + . each top-level pt contains a single page table, with access to a shared page in memory + Low can read/write to this page, High can only read + . one cspace made up of one cnode + . each cspace contains 4 caps: + one to the tcb + one to the cnode itself + one to the top level page table + one to the asid pool + one to the shared page + one to the second level page table + one to the ntfn + +Low can send to the ntfn while High can receive from it. + +Attempt to ASCII art: + + -------- ---- ---- -------- + | | | | | | | | + V | | V S R | V | V +Low_tcb(3079)-->Low_cnode(6)--->ntfn(9)<---High_cnode(7)<--High_tcb(3080) + | | | | + V | | V +Low_pd(3063)<---------Low_pool High_pool------------> High_pd(3065) + | | + V R/W R V +Low_pt(3072)---------------->shared_page<-----------------High_pt(3077) + + +(the references are derived from the dump of the SAC system) + + +The aim is to be able to prove + + valid_initial_state s0_internal Sys1PAS timer_irq utf + +where Sys1PAS is the label graph defining the AC policy for Sys1 using +the authority graph defined above and s0 is the state of Sys1 described above. + +\ + +subsubsection \Defining the State\ + +definition "ntfn_ptr \ pptr_base + 0x20" + +definition "Low_tcb_ptr \ pptr_base + 0x800" +definition "idle_tcb_ptr = pptr_base + 0x1000" (* FIXME IF: change to idle_thread_ptr *) +definition "High_tcb_ptr = pptr_base + 0x1800" + +lemma "arm_global_pt_ptr = pptr_base + 0x2000" using arm_global_pt_ptr_def . + +definition "Low_pt_ptr = pptr_base + 0x4000" +definition "High_pt_ptr = pptr_base + 0x5000" + +definition "Low_pd_ptr = pptr_base + 0x6000" +definition "High_pd_ptr = pptr_base + 0x8000" + +definition "Low_pool_ptr = pptr_base + 0xA000" +definition "High_pool_ptr = pptr_base + 0xB000" + +definition "Low_cnode_ptr = pptr_base + 0x18000" +definition "High_cnode_ptr = pptr_base + 0x20000" +definition "Silc_cnode_ptr = pptr_base + 0x28000" +definition "irq_cnode_ptr = pptr_base + 0x30000" + +definition "shared_page_ptr_virt = pptr_base + 0x40000000" +definition "shared_page_ptr_phys = addrFromPPtr shared_page_ptr_virt" + +definition "Low_mcp \ 5 :: priority" +definition "Low_prio \ 5 :: priority" +definition "High_mcp \ 5 :: priority" +definition "High_prio \ 5 :: priority" +definition "Low_time_slice \ 0 :: nat" +definition "High_time_slice \ 5 :: nat" +definition "Low_domain \ 0 :: domain" +definition "High_domain \ 1 :: domain" + +lemmas s0_ptr_defs = + Low_pool_ptr_def High_pool_ptr_def Low_cnode_ptr_def High_cnode_ptr_def Silc_cnode_ptr_def + ntfn_ptr_def irq_cnode_ptr_def Low_pd_ptr_def High_pd_ptr_def Low_pt_ptr_def High_pt_ptr_def + Low_tcb_ptr_def High_tcb_ptr_def idle_tcb_ptr_def timer_irq_def Low_prio_def High_prio_def + Low_time_slice_def Low_domain_def High_domain_def init_irq_node_ptr_def arm_global_pt_ptr_def + pptr_base_def pptrBase_def canonical_bit_def shared_page_ptr_virt_def + +(* Distinctness proof of kernel pointers. *) + +distinct ptrs_distinct[simp]: + Low_tcb_ptr High_tcb_ptr idle_tcb_ptr ntfn_ptr + Low_pt_ptr High_pt_ptr shared_page_ptr_virt Low_pd_ptr High_pd_ptr + Low_cnode_ptr High_cnode_ptr Low_pool_ptr High_pool_ptr + Silc_cnode_ptr irq_cnode_ptr arm_global_pt_ptr + by (auto simp: s0_ptr_defs) + + +text \We need to define the asids of each pd and pt to ensure that +the object is included in the right ASID-label\ + +definition Low_asid :: asid where + "Low_asid \ 1 << asid_low_bits" + +definition High_asid :: asid where + "High_asid \ 2 << asid_low_bits" + +definition Silc_asid :: asid where + "Silc_asid \ 3 << asid_low_bits" + +distinct asid_high_bits_distinct[simp]: + "asid_high_bits_of Low_asid" + "asid_high_bits_of High_asid" + "asid_high_bits_of Silc_asid" + by (auto simp: asid_high_bits_of_def asid_low_bits_def Low_asid_def High_asid_def Silc_asid_def) + +distinct asids_distinct[simp]: + High_asid Low_asid Silc_asid + by (auto simp: Low_asid_def High_asid_def Silc_asid_def asid_low_bits_def) + + +text \converting a nat to a bool list of size 10 - for the cnodes\ + +definition nat_to_bl :: "nat \ nat \ bool list option" where + "nat_to_bl bits n \ + if n \ 2^bits then None + else Some $ bin_to_bl bits (of_nat n)" + +lemma nat_to_bl_id [simp]: "nat_to_bl (size (x :: (('a::len) word))) (unat x) = Some (to_bl x)" + by (clarsimp simp: nat_to_bl_def to_bl_def le_def word_size) + +definition the_nat_to_bl :: "nat \ nat \ bool list" where + "the_nat_to_bl sz n \ the (nat_to_bl sz (n mod 2^sz))" + +abbreviation (input) the_nat_to_bl_10 :: "nat \ bool list" where + "the_nat_to_bl_10 n \ the_nat_to_bl 10 n" + +lemma len_the_nat_to_bl[simp]: + "length (the_nat_to_bl x y) = x" + apply (clarsimp simp: the_nat_to_bl_def nat_to_bl_def) + apply safe + apply (metis le_def mod_less_divisor nat_zero_less_power_iff zero_less_numeral) + apply (clarsimp simp: size_bin_to_bl_aux not_le) + done + +lemma tcb_cnode_index_nat_to_bl [simp]: + "the_nat_to_bl_10 n \ tcb_cnode_index n" + by (clarsimp simp: tcb_cnode_index_def intro!: length_neq) + +lemma mod_less_self [simp]: + "a \ b mod a \ ((a :: nat) = 0)" + by (metis mod_less_divisor nat_neq_iff not_less not_less0) + +lemma split_div_mod: + "a = (b::nat) \ (a div k = b div k \ a mod k = b mod k)" + by (metis mult_div_mod_eq) + +lemma nat_to_bl_eq: + assumes "a < 2 ^ n \ b < 2 ^ n" + shows "nat_to_bl n a = nat_to_bl n b \ a = b" + using assms + apply - + apply (erule disjE_R) + apply (clarsimp simp: nat_to_bl_def) + apply (case_tac "a \ 2 ^ n") + apply (clarsimp simp: nat_to_bl_def) + apply (clarsimp simp: not_le) + apply (induct n arbitrary: a b) + apply (clarsimp simp: nat_to_bl_def) + apply atomize + apply (clarsimp simp: nat_to_bl_def) + apply (erule_tac x="a div 2" in allE) + apply (erule_tac x="b div 2" in allE) + apply (erule impE) + apply (metis power_commutes td_gal_lt zero_less_numeral) + apply (clarsimp simp: bin_last_def zdiv_int) + apply (rule iffI [rotated], clarsimp) + apply (subst (asm) (1 2 3 4) bin_to_bl_aux_alt) + apply (clarsimp simp: mod_eq_dvd_iff) + apply (subst split_div_mod [where k=2]) + apply clarsimp + apply presburger + done + +lemma nat_to_bl_mod_n_eq[simp]: + "nat_to_bl n a = nat_to_bl n b \ ((a = b \ a < 2 ^ n) \ (a \ 2 ^ n \ b \ 2 ^ n))" + apply (rule iffI) + apply (clarsimp simp: not_le) + apply (subst (asm) nat_to_bl_eq, simp) + apply clarsimp + apply (erule disjE) + apply clarsimp + apply (clarsimp simp: nat_to_bl_def) + done + +lemma the_the_eq: + "\ x \ None; y \ None \ \ (the x = the y) = (x = y)" + by auto + +lemma the_nat_to_bl_eq [simp]: + "(the_nat_to_bl n a = the_nat_to_bl m b) \ (n = m \ (a mod 2 ^ n = b mod 2 ^ n))" + apply (case_tac "n = m") + apply (clarsimp simp: the_nat_to_bl_def) + apply (subst the_the_eq) + apply (clarsimp simp: nat_to_bl_def) + apply (clarsimp simp: nat_to_bl_def) + apply simp + apply simp + apply (metis len_the_nat_to_bl) + done + +lemma empty_cnode_eq_Some[simp]: + "(empty_cnode n x = Some y) = (length x = n \ y = NullCap)" + by (clarsimp simp: empty_cnode_def, metis) + +lemma empty_cnode_eq_None[simp]: + "(empty_cnode n x = None) = (length x \ n)" + by (clarsimp simp: empty_cnode_def) + + +definition max_page_size where + "max_page_size \ if config_ARM_PA_SIZE_BITS_40 then ARMLargePage else ARMHugePage" + +lemma max_page_size_def2: + "max_page_size = vmsize_of_level (max_pt_level - 1)" + by (auto simp: max_page_size_def max_pt_level_def2 vmsize_of_level_def) + + +text \Low's CSpace\ + +definition Low_caps :: cnode_contents where + "Low_caps \ + (empty_cnode 10) + ((the_nat_to_bl_10 1) + \ ThreadCap Low_tcb_ptr, + (the_nat_to_bl_10 2) + \ CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2), + (the_nat_to_bl_10 3) + \ ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0))), + (the_nat_to_bl_10 4) + \ ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid), + (the_nat_to_bl_10 5) + \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write max_page_size False (Some (Low_asid,0))), + (the_nat_to_bl_10 6) + \ ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0))), + (the_nat_to_bl_10 318) + \ NotificationCap ntfn_ptr 0 {AllowSend})" + +definition Low_cnode :: kernel_object where + "Low_cnode \ CNode 10 Low_caps" + +lemma ran_empty_cnode[simp]: + "ran (empty_cnode C) = {NullCap}" + by (auto simp: empty_cnode_def ran_def Ex_list_of_length intro: set_eqI) + +lemma empty_cnode_app[simp]: + "length x = n \ empty_cnode n x = Some NullCap" + by (auto simp: empty_cnode_def) + +lemma in_ran_If[simp]: + "(x \ ran (\n. if P n then A n else B n)) \ + (\n. P n \ A n = Some x) \ (\n. \ P n \ B n = Some x)" + by (auto simp: ran_def) + +lemma Low_caps_ran: + "ran Low_caps = + {ThreadCap Low_tcb_ptr, + CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2), + ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0))), + ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0))), + ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid), + ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write max_page_size False (Some (Low_asid,0))), + NotificationCap ntfn_ptr 0 {AllowSend}, + NullCap}" + apply (rule equalityI) + apply (clarsimp simp: Low_caps_def fun_upd_def empty_cnode_def split: if_split_asm) + apply (clarsimp simp: Low_caps_def fun_upd_def empty_cnode_def split: if_split_asm cong: conj_cong) + apply (rule exI[where x="the_nat_to_bl_10 0"]) + apply simp + done + + +text \High's Cspace\ + +definition High_caps :: cnode_contents where + "High_caps \ + (empty_cnode 10) + ((the_nat_to_bl_10 1) + \ ThreadCap High_tcb_ptr, + (the_nat_to_bl_10 2) + \ CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2), + (the_nat_to_bl_10 3) + \ ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0))), + (the_nat_to_bl_10 4) + \ ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid), + (the_nat_to_bl_10 5) + \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (High_asid,0))), + (the_nat_to_bl_10 6) + \ ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0))), + (the_nat_to_bl_10 318) + \ NotificationCap ntfn_ptr 0 {AllowRecv}) " + +definition High_cnode :: kernel_object where + "High_cnode \ CNode 10 High_caps" + +lemma High_caps_ran: + "ran High_caps = + {ThreadCap High_tcb_ptr, + CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2), + ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0))), + ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0))), + ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid), + ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (High_asid,0))), + NotificationCap ntfn_ptr 0 {AllowRecv}, + NullCap}" + apply (rule equalityI) + apply (clarsimp simp: High_caps_def ran_def empty_cnode_def split: if_split_asm) + apply (clarsimp simp: High_caps_def ran_def empty_cnode_def split: if_split_asm cong: conj_cong) + apply (rule exI [where x="the_nat_to_bl_10 0"]) + apply simp + done + + +text \We need a copy of boundary crossing caps owned by SilcLabel\ + +definition Silc_caps :: cnode_contents where + "Silc_caps \ + (empty_cnode 10) + ((the_nat_to_bl_10 2) + \ CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2), + (the_nat_to_bl_10 5) + \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (Silc_asid,0))), + (the_nat_to_bl_10 318) + \ NotificationCap ntfn_ptr 0 {AllowSend})" + +definition Silc_cnode :: kernel_object where + "Silc_cnode \ CNode 10 Silc_caps" + +lemma Silc_caps_ran: + "ran Silc_caps = + {CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2), + ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (Silc_asid,0))), + NotificationCap ntfn_ptr 0 {AllowSend}, + NullCap}" + apply (rule equalityI) + apply (clarsimp simp: Silc_caps_def ran_def empty_cnode_def) + apply (clarsimp simp: ran_def Silc_caps_def empty_cnode_def cong: conj_cong) + apply (rule_tac x="the_nat_to_bl_10 0" in exI) + apply simp + done + + +text \notification between Low and High\ + +definition ntfn :: kernel_object where + "ntfn \ Notification \ntfn_obj = WaitingNtfn [High_tcb_ptr], ntfn_bound_tcb=None\" + +text \Low's VSpace (PageDirectory)\ + +abbreviation Low_pt' :: pt where + "Low_pt' \ + NormalPT ((\_. InvalidPTE) + (0 := PagePTE shared_page_ptr_phys False {} vm_read_write))" + +definition Low_pt :: kernel_object where + "Low_pt \ ArchObj (PageTable Low_pt')" + +abbreviation Low_pd' :: pt where + "Low_pd' \ + VSRootPT ((\_. InvalidPTE) + (0 := PageTablePTE (ppn_from_pptr Low_pt_ptr)))" + +definition Low_pd :: kernel_object where + "Low_pd \ ArchObj (PageTable Low_pd')" + + +text \High's VSpace (PageDirectory)\ + +abbreviation High_pt' :: pt where + "High_pt' \ + NormalPT ((\_. InvalidPTE) + (0 := PagePTE shared_page_ptr_phys False {} vm_read_only))" + +definition High_pt :: kernel_object where + "High_pt \ ArchObj (PageTable High_pt')" + +abbreviation High_pd' :: pt where + "High_pd' \ + VSRootPT ((\_. InvalidPTE) + (0 := PageTablePTE (ppn_from_pptr High_pt_ptr)))" + +definition High_pd :: kernel_object where + "High_pd \ ArchObj (PageTable High_pd')" + + +text \Low's tcb\ + +definition Low_tcb :: kernel_object where + "Low_tcb \ TCB \tcb_ctable = CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2), + tcb_vtable = ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0))), + tcb_reply = ReplyCap Low_tcb_ptr True {AllowGrant, AllowWrite}, + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = Running, + tcb_fault_handler = replicate word_bits False, + tcb_ipc_buffer = 0, + tcb_fault = None, + tcb_bound_notification = None, + tcb_mcpriority = Low_mcp, + tcb_priority = Low_prio, + tcb_time_slice = Low_time_slice, + tcb_domain = Low_domain, + tcb_flags = {}, + tcb_arch = \tcb_context = empty_context, tcb_vcpu = None, tcb_cur_fpu = False\\" + + +text \High's tcb\ + +definition High_tcb :: kernel_object where + "High_tcb \ TCB \tcb_ctable = CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2) , + tcb_vtable = ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0))), + tcb_reply = ReplyCap High_tcb_ptr True {AllowGrant, AllowWrite}, + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = BlockedOnNotification ntfn_ptr, + tcb_fault_handler = replicate word_bits False, + tcb_ipc_buffer = 0, + tcb_fault = None, + tcb_bound_notification = None, + tcb_mcpriority = High_mcp, + tcb_priority = High_prio, + tcb_time_slice = High_time_slice, + tcb_domain = High_domain, + tcb_flags = {}, + tcb_arch = \tcb_context = empty_context, tcb_vcpu = None, tcb_cur_fpu = False\\" + + +text \idle's tcb\ + +definition idle_tcb :: kernel_object where + "idle_tcb \ TCB \tcb_ctable = NullCap, + tcb_vtable = NullCap, + tcb_reply = NullCap, + tcb_caller = NullCap, + tcb_ipcframe = NullCap, + tcb_state = IdleThreadState, + tcb_fault_handler = replicate word_bits False, + tcb_ipc_buffer = 0, + tcb_fault = None, + tcb_bound_notification = None, + tcb_mcpriority = default_priority, + tcb_priority = default_priority, + tcb_time_slice = timeSlice, + tcb_domain = default_domain, + tcb_flags = {}, + tcb_arch = \tcb_context = empty_context, tcb_vcpu = None, tcb_cur_fpu = False\\" + +definition + "irq_cnode \ CNode 0 (Map.empty([] \ cap.NullCap))" + +abbreviation Low_pool' :: asid_pool where + "Low_pool' \ \idx. if idx = asid_low_bits_of Low_asid then Some (ASIDPoolVSpace Low_pd_ptr) else None" + +definition + "Low_pool \ ArchObj (ASIDPool Low_pool')" + +abbreviation + "High_pool' \ \idx. if idx = asid_low_bits_of High_asid then Some (ASIDPoolVSpace High_pd_ptr) else None" + +definition + "High_pool \ ArchObj (ASIDPool High_pool')" + +definition + "shared_page \ ArchObj (DataPage False max_page_size)" + +definition kh0 :: kheap where + "kh0 \ (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x + then Some (CNode 0 (empty_cnode 0)) + else None) + (Low_cnode_ptr \ Low_cnode, + High_cnode_ptr \ High_cnode, + Low_pool_ptr \ Low_pool, + High_pool_ptr \ High_pool, + Silc_cnode_ptr \ Silc_cnode, + ntfn_ptr \ ntfn, + irq_cnode_ptr \ irq_cnode, + Low_pd_ptr \ Low_pd, + High_pd_ptr \ High_pd, + Low_pt_ptr \ Low_pt, + High_pt_ptr \ High_pt, + Low_tcb_ptr \ Low_tcb, + High_tcb_ptr \ High_tcb, + idle_tcb_ptr \ idle_tcb, + shared_page_ptr_virt \ shared_page, + arm_global_pt_ptr \ ArchObj global_pt_obj)" + +lemma irq_node_offs_min: + "init_irq_node_ptr \ init_irq_node_ptr + (ucast (irq::irq) << 5)" + apply (rule_tac sz=59 in machine_word_plus_mono_right_split) + apply (simp add: unat_word_ariths mask_def shiftl_t2n s0_ptr_defs cte_level_bits_def) + apply (cut_tac x=irq and 'a=64 in ucast_less) + apply simp + apply (simp add: word_less_nat_alt) + apply (simp add: word_bits_def) + done + +lemma irq_node_offs_max: + "init_irq_node_ptr + (ucast (irq::irq) << 5) < init_irq_node_ptr + 0x4000" + apply (simp add: s0_ptr_defs cte_level_bits_def shiftl_t2n) + apply (cut_tac x=irq and 'a=machine_word_len in ucast_less) + apply simp + apply (simp add: word_less_nat_alt unat_word_ariths + cte_level_bits_def irq_len_val) + done + + +definition irq_node_offs_range where + "irq_node_offs_range \ {x. init_irq_node_ptr \ x \ x < init_irq_node_ptr + 0x4000} + \ {x. is_aligned x 5}" + +lemma irq_node_offs_in_range: + "init_irq_node_ptr + (ucast (irq::irq) << 5) + \ irq_node_offs_range" + apply (clarsimp simp: irq_node_offs_min irq_node_offs_max irq_node_offs_range_def) + apply (rule is_aligned_add[OF _ is_aligned_shift]) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def) + done + +lemma irq_node_offs_range_correct: + "x \ irq_node_offs_range + \ \irq. x = init_irq_node_ptr + (ucast (irq::irq) << 5)" + unfolding irq_node_offs_range_def + apply clarsimp + apply (rule_tac x="ucast ((x - init_irq_node_ptr) >> 5)" in exI) + apply (simp add: ucast_ucast_mask) + apply (subst aligned_shiftr_mask_shiftl) + apply (rule aligned_sub_aligned) + apply assumption + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def) + apply (simp add: cte_level_bits_def) + apply (rule_tac n="irq_len + 5" in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def irq_len_val) + apply (simp add: mask_twice irq_len_val cte_level_bits_def) + apply (simp add: diff_conv_add_uminus del: add_uminus_conv_diff) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def irq_len_val) + apply simp + apply (simp add: diff_conv_add_uminus del: add_uminus_conv_diff) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def irq_len_val) + apply (clarsimp simp: cte_level_bits_def irq_len_val) + apply (erule (1) aligned_intvl_neg_mask_start) + apply (simp add: is_aligned_def s0_ptr_defs cte_level_bits_def irq_len_val) + apply (simp add: cte_level_bits_def irq_len_val) + done + +lemma irq_node_offs_range_distinct[simp]: + "Low_cnode_ptr \ irq_node_offs_range" + "High_cnode_ptr \ irq_node_offs_range" + "Low_pool_ptr \ irq_node_offs_range" + "High_pool_ptr \ irq_node_offs_range" + "Silc_cnode_ptr \ irq_node_offs_range" + "ntfn_ptr \ irq_node_offs_range" + "irq_cnode_ptr \ irq_node_offs_range" + "Low_pd_ptr \ irq_node_offs_range" + "High_pd_ptr \ irq_node_offs_range" + "Low_pt_ptr \ irq_node_offs_range" + "High_pt_ptr \ irq_node_offs_range" + "Low_tcb_ptr \ irq_node_offs_range" + "High_tcb_ptr \ irq_node_offs_range" + "idle_tcb_ptr \ irq_node_offs_range" + "arm_global_pt_ptr \ irq_node_offs_range" + "shared_page_ptr_virt \ irq_node_offs_range" + by(simp add: irq_node_offs_range_def irq_len_val cte_level_bits_def s0_ptr_defs)+ + +lemma irq_node_offs_distinct[simp]: + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_cnode_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_cnode_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_pool_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_pool_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Silc_cnode_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ ntfn_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ irq_cnode_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_pd_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_pd_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_pt_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_pt_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ Low_tcb_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ High_tcb_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ idle_tcb_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ arm_global_pt_ptr" + "init_irq_node_ptr + (ucast (irq:: irq) << 5) \ shared_page_ptr_virt" + by (simp add:not_inD[symmetric, OF _ irq_node_offs_in_range])+ + +lemma kh0_dom: + "dom kh0 = {shared_page_ptr_virt, arm_global_pt_ptr, idle_tcb_ptr, High_tcb_ptr, Low_tcb_ptr, + High_pt_ptr, Low_pt_ptr, High_pd_ptr, Low_pd_ptr, irq_cnode_ptr, ntfn_ptr, + Silc_cnode_ptr, High_pool_ptr, Low_pool_ptr, High_cnode_ptr, Low_cnode_ptr} \ + irq_node_offs_range" + apply (rule equalityI) + apply (simp add: kh0_def dom_def) + apply (clarsimp simp: irq_node_offs_in_range) + apply (clarsimp simp: dom_def) + apply (rule conjI, clarsimp simp: kh0_def)+ + apply (force simp: kh0_def cte_level_bits_def dest: irq_node_offs_range_correct) + done + +lemmas kh0_SomeD' = set_mp[OF equalityD1[OF kh0_dom[simplified dom_def]], OF CollectI, simplified, OF exI] + +lemma kh0_SomeD: + "kh0 x = Some y \ + x = shared_page_ptr_virt \ y = shared_page \ + x = arm_global_pt_ptr \ y = ArchObj global_pt_obj \ + x = idle_tcb_ptr \ y = idle_tcb \ + x = High_tcb_ptr \ y = High_tcb \ + x = Low_tcb_ptr \ y = Low_tcb \ + x = High_pt_ptr \ y = High_pt \ + x = Low_pt_ptr \ y = Low_pt \ + x = High_pd_ptr \ y = High_pd \ + x = Low_pd_ptr \ y = Low_pd \ + x = irq_cnode_ptr \ y = irq_cnode \ + x = ntfn_ptr \ y = ntfn \ + x = Silc_cnode_ptr \ y = Silc_cnode \ + x = High_pool_ptr \ y = High_pool \ + x = Low_pool_ptr \ y = Low_pool \ + x = High_cnode_ptr \ y = High_cnode \ + x = Low_cnode_ptr \ y = Low_cnode \ + x \ irq_node_offs_range \ y = CNode 0 (empty_cnode 0)" + apply (frule kh0_SomeD') + apply (erule disjE, simp add: kh0_def | force simp: kh0_def split: if_split_asm)+ + done + +lemmas kh0_obj_def = + Low_cnode_def High_cnode_def Silc_cnode_def Low_pool_def High_pool_def Low_pd_def High_pd_def + Low_pt_def High_pt_def Low_tcb_def High_tcb_def idle_tcb_def irq_cnode_def ntfn_def + global_pt_obj_def vm_kernel_only_def shared_page_def + + +definition exst0 :: "det_ext" where + "exst0 \ \work_units_completed_internal = undefined, + cdt_list_internal = const []\" + +definition machine_state0 :: "machine_state" where + "machine_state0 \ \irq_masks = (\irq. if irq = timer_irq then False else True), + irq_state = 0, + underlying_memory = const 0, + device_state = Map.empty, + vcpu_state = default_vcpu_state, + fpu_state = FPUState (\_. 0) 0 0, + fpu_enabled = False, + machine_state_rest = undefined\" + +(* FIXME AARCH64 IF: override in Init_A *) +definition init_vspace_uses :: "vspace_ref \ arm_vspace_region_use" where + "init_vspace_uses p \ + if p \ kernel_window_range then ArmVSpaceKernelWindow + else ArmVSpaceInvalidRegion" + +definition max_numlistregs :: nat where + "max_numlistregs \ if config_ARM_GIC_V3 then 16 else 64" + +definition arch_state0 :: "arch_state" where + "arch_state0 \ \ + arm_asid_table = [asid_high_bits_of Low_asid \ Low_pool_ptr, + asid_high_bits_of High_asid \ High_pool_ptr], + arm_kernel_vspace = init_vspace_uses, + arm_asid_map = Map.empty, + arm_vmid_table = Map.empty, + arm_next_vmid = 0, + arm_us_global_vspace = arm_global_pt_ptr, + arm_current_vcpu = None, + arm_gicvcpu_numlistregs = max_numlistregs - 1, + arm_current_fpu_owner = None + \" + +definition s0_internal :: "det_ext state" where + "s0_internal \ \ + kheap = kh0, + cdt = Map.empty, + is_original_cap = (\_. False) ((Low_tcb_ptr, tcb_cnode_index 2) := True, + (High_tcb_ptr, tcb_cnode_index 2) := True), + cur_thread = Low_tcb_ptr, + idle_thread = idle_tcb_ptr, + scheduler_action = resume_cur_thread, + domain_list = [(0, 10), (1, 10), (0, 0)], + domain_index = 0, + domain_start_index = 0, + cur_domain = 0, + domain_time = 5, + ready_queues = (const (const [])), + machine_state = machine_state0, + interrupt_irq_node = (\irq. init_irq_node_ptr + (ucast irq << 5)), + interrupt_states = (\_. irq_state.IRQInactive) (timer_irq := irq_state.IRQTimer), + arch_state = arch_state0, + exst = exst0 + \" + +lemma kh_s0_def: + "(kheap s0_internal x = Some y) = ( + x = shared_page_ptr_virt \ y = shared_page \ + x = arm_global_pt_ptr \ y = ArchObj global_pt_obj \ + x = idle_tcb_ptr \ y = idle_tcb \ + x = High_tcb_ptr \ y = High_tcb \ + x = Low_tcb_ptr \ y = Low_tcb \ + x = High_pt_ptr \ y = High_pt \ + x = Low_pt_ptr \ y = Low_pt \ + x = High_pd_ptr \ y = High_pd \ + x = Low_pd_ptr \ y = Low_pd \ + x = irq_cnode_ptr \ y = irq_cnode \ + x = ntfn_ptr \ y = ntfn \ + x = Silc_cnode_ptr \ y = Silc_cnode \ + x = High_pool_ptr \ y = High_pool \ + x = Low_pool_ptr \ y = Low_pool \ + x = High_cnode_ptr \ y = High_cnode \ + x = Low_cnode_ptr \ y = Low_cnode \ + x \ irq_node_offs_range \ y = CNode 0 (empty_cnode 0))" + apply (clarsimp simp: s0_internal_def kh0_def) + apply (auto simp: irq_node_offs_in_range dest: irq_node_offs_range_correct) + done + + +subsubsection \Defining the policy graph\ + +definition Sys1AgentMap :: "(auth_graph_label subject_label) agent_map" where + "Sys1AgentMap \ + \ \set the range of the shared_page to Low, default everything else to IRQ0\ + (\p. if p \ ptr_range shared_page_ptr_virt (pageBitsForSize max_page_size) + then partition_label Low + else partition_label IRQ0) + (Low_cnode_ptr := partition_label Low, + High_cnode_ptr := partition_label High, + Low_pool_ptr := partition_label Low, + High_pool_ptr := partition_label High, + ntfn_ptr := partition_label High, + irq_cnode_ptr := partition_label IRQ0, + Silc_cnode_ptr := SilcLabel, + Low_pd_ptr := partition_label Low, + High_pd_ptr := partition_label High, + Low_pt_ptr := partition_label Low, + High_pt_ptr := partition_label High, + Low_tcb_ptr := partition_label Low, + High_tcb_ptr := partition_label High, + idle_tcb_ptr := partition_label Low)" + +lemma Sys1AgentMap_simps: + "Sys1AgentMap Low_cnode_ptr = partition_label Low" + "Sys1AgentMap High_cnode_ptr = partition_label High" + "Sys1AgentMap Low_pool_ptr = partition_label Low" + "Sys1AgentMap High_pool_ptr = partition_label High" + "Sys1AgentMap ntfn_ptr = partition_label High" + "Sys1AgentMap irq_cnode_ptr = partition_label IRQ0" + "Sys1AgentMap Silc_cnode_ptr = SilcLabel" + "Sys1AgentMap Low_pd_ptr = partition_label Low" + "Sys1AgentMap High_pd_ptr = partition_label High" + "Sys1AgentMap Low_pt_ptr = partition_label Low" + "Sys1AgentMap High_pt_ptr = partition_label High" + "Sys1AgentMap Low_tcb_ptr = partition_label Low" + "Sys1AgentMap High_tcb_ptr = partition_label High" + "Sys1AgentMap idle_tcb_ptr = partition_label Low" + "\p. p \ ptr_range shared_page_ptr_virt (pageBitsForSize max_page_size) + \ Sys1AgentMap p = partition_label Low" + unfolding Sys1AgentMap_def + apply simp_all + by (auto simp: s0_ptr_defs ptr_range_def) + +definition Sys1ASIDMap :: "(auth_graph_label subject_label) agent_asid_map" where + "Sys1ASIDMap \ + (\x. if asid_high_bits_of x = asid_high_bits_of Low_asid + then partition_label Low + else if asid_high_bits_of x = asid_high_bits_of High_asid + then partition_label High + else if asid_high_bits_of x = asid_high_bits_of Silc_asid + then SilcLabel + else undefined)" + +(* We include 2 domains, Low is associated to domain 0, High to domain 1, + we default the rest of the possible domains to High *) + +definition Sys1PAS :: "(auth_graph_label subject_label) PAS" where + "Sys1PAS \ + \pasObjectAbs = Sys1AgentMap, + pasASIDAbs = Sys1ASIDMap, + pasIRQAbs = (\_. partition_label IRQ0), + pasPolicy = Sys1AuthGraph, + pasSubject = partition_label Low, + pasMayActivate = True, + pasMayEditReadyQueues = True, pasMaySendIrqs = False, + pasDomainAbs = ((\_. {partition_label High})(0 := {partition_label Low}))\" + + +subsubsection \Proof of pas_refined for Sys1\ + +lemma High_caps_well_formed: "well_formed_cnode_n 10 High_caps" + by (auto simp: High_caps_def well_formed_cnode_n_def split: if_split_asm) + +lemma Low_caps_well_formed: "well_formed_cnode_n 10 Low_caps" + by (auto simp: Low_caps_def well_formed_cnode_n_def split: if_split_asm) + +lemma Silc_caps_well_formed: "well_formed_cnode_n 10 Silc_caps" + by (auto simp: Silc_caps_def well_formed_cnode_n_def split: if_split_asm) + +lemma s0_caps_of_state : + "caps_of_state s0_internal p = Some cap \ + cap = NullCap \ + (p,cap) \ + { ((Low_cnode_ptr,(the_nat_to_bl_10 1)), ThreadCap Low_tcb_ptr), + ((Low_cnode_ptr,(the_nat_to_bl_10 2)), CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((Low_cnode_ptr,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0)))), + ((Low_cnode_ptr,(the_nat_to_bl_10 6)), ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0)))), + ((Low_cnode_ptr,(the_nat_to_bl_10 4)), ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid)), + ((Low_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write max_page_size False (Some (Low_asid, 0)))), + ((Low_cnode_ptr,(the_nat_to_bl_10 318)), NotificationCap ntfn_ptr 0 {AllowSend}), + ((High_cnode_ptr,(the_nat_to_bl_10 1)), ThreadCap High_tcb_ptr), + ((High_cnode_ptr,(the_nat_to_bl_10 2)), CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((High_cnode_ptr,(the_nat_to_bl_10 3)), ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0)))), + ((High_cnode_ptr,(the_nat_to_bl_10 6)), ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0)))), + ((High_cnode_ptr,(the_nat_to_bl_10 4)), ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid)), + ((High_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (High_asid, 0)))), + ((High_cnode_ptr,(the_nat_to_bl_10 318)), NotificationCap ntfn_ptr 0 {AllowRecv}) , + ((Silc_cnode_ptr,(the_nat_to_bl_10 2)), CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((Silc_cnode_ptr,(the_nat_to_bl_10 5)), ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (Silc_asid, 0)))), + ((Silc_cnode_ptr,(the_nat_to_bl_10 318)), NotificationCap ntfn_ptr 0 {AllowSend}), + ((Low_tcb_ptr,(tcb_cnode_index 0)), CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((Low_tcb_ptr,(tcb_cnode_index 1)), ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0)))), + ((Low_tcb_ptr,(tcb_cnode_index 2)), ReplyCap Low_tcb_ptr True {AllowGrant, AllowWrite}), + ((Low_tcb_ptr,(tcb_cnode_index 3)), NullCap), + ((Low_tcb_ptr,(tcb_cnode_index 4)), NullCap), + ((High_tcb_ptr,(tcb_cnode_index 0)), CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2)), + ((High_tcb_ptr,(tcb_cnode_index 1)), ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0)))), + ((High_tcb_ptr,(tcb_cnode_index 2)), ReplyCap High_tcb_ptr True {AllowGrant, AllowWrite}), + ((High_tcb_ptr,(tcb_cnode_index 3)), NullCap), + ((High_tcb_ptr,(tcb_cnode_index 4)), NullCap)} " + supply if_cong[cong] + apply (insert High_caps_well_formed) + apply (insert Low_caps_well_formed) + apply (insert Silc_caps_well_formed) + apply (simp add: caps_of_state_cte_wp_at cte_wp_at_cases s0_internal_def kh0_def kh0_obj_def) + apply (case_tac p, clarsimp) + apply (clarsimp split: if_splits) + apply (clarsimp simp: cte_wp_at_cases tcb_cap_cases_def split: if_split_asm)+ + apply (clarsimp simp: Silc_caps_def split: if_splits) + apply (clarsimp simp: High_caps_def split: if_splits) + apply (clarsimp simp: Low_caps_def split: if_splits) + done + +lemma tcb_states_of_state_s0: + "tcb_states_of_state s0_internal = [High_tcb_ptr \ thread_state.BlockedOnNotification ntfn_ptr, + Low_tcb_ptr \ thread_state.Running, + idle_tcb_ptr \ thread_state.IdleThreadState ]" + unfolding s0_internal_def tcb_states_of_state_def + by (auto simp: get_tcb_def kh0_def kh0_obj_def) + +lemma thread_bounds_of_state_s0: + "thread_bound_ntfns s0_internal = Map.empty" + unfolding s0_internal_def thread_bound_ntfns_def + by (auto simp: get_tcb_def kh0_def kh0_obj_def) + +lemma Sys1_wellformed': + "policy_wellformed (pasPolicy Sys1PAS) False irqs x" + by (clarsimp simp: Sys1PAS_def Sys1AgentMap_simps Sys1AuthGraph_def policy_wellformed_def) + +corollary Sys1_wellformed: + "x \ range (pasObjectAbs Sys1PAS) \ \(range (pasDomainAbs Sys1PAS)) - {SilcLabel} + \ policy_wellformed (pasPolicy Sys1PAS) False irqs x" + by (rule Sys1_wellformed') + +lemma Sys1_pas_wellformed: + "pas_wellformed Sys1PAS" + by (clarsimp simp: Sys1PAS_def Sys1AgentMap_simps Sys1AuthGraph_def policy_wellformed_def) + +lemma domains_of_state_s0[simp]: + "domains_of_state s0_internal = {(High_tcb_ptr, High_domain), + (Low_tcb_ptr, Low_domain), + (idle_tcb_ptr, default_domain)}" + apply (rule equalityI) + apply (rule subsetI) + apply clarsimp + apply (erule domains_of_state_aux.cases) + apply (clarsimp simp: s0_internal_def etcbs_of'_def kh0_def kh0_obj_def split: if_split_asm) + apply (force simp: s0_internal_def etcbs_of'_def kh0_def kh0_obj_def intro: domains_of_state_aux.domtcbs)+ + done + +lemma pool_for_asid_s0: + "pool_for_asid asid s0_internal = (if asid_high_bits_of asid = asid_high_bits_of High_asid + then Some High_pool_ptr + else if asid_high_bits_of asid = asid_high_bits_of Low_asid + then Some Low_pool_ptr + else None)" + by (clarsimp simp: pool_for_asid_def s0_internal_def arch_state0_def) + +lemma asid_pools_of_s0: + "asid_pools_of s0_internal = [Low_pool_ptr \ Low_pool', High_pool_ptr \ High_pool']" + by (auto simp: asid_pools_of_ko_at obj_at_def s0_internal_def opt_map_def kh0_def kh0_obj_def + split: option.splits) + +lemma pts_of_s0: + "pts_of s0_internal = [Low_pd_ptr \ Low_pd', + High_pd_ptr \ High_pd', + Low_pt_ptr \ Low_pt', + High_pt_ptr \ High_pt', + arm_global_pt_ptr \ VSRootPT (\_. InvalidPTE)]" + by (auto simp: opt_map_def s0_internal_def kh0_def kh0_obj_def + split: option.splits if_splits)+ + + +lemma ptes_of_s0_PageTablePTE: + "\ ptes_of s0_internal VSRootPT_T ptr = Some pte; is_PageTablePTE pte \ + \ table_base VSRootPT_T ptr = Low_pd_ptr \ pte = PageTablePTE (ppn_from_pptr Low_pt_ptr) + \ table_base VSRootPT_T ptr = High_pd_ptr \ pte = PageTablePTE (ppn_from_pptr High_pt_ptr)" + by (auto simp: ptes_of_def pts_of_s0 obind_def kh0_obj_def split: option.splits if_splits) + +lemma Low_pt_is_aligned[simp]: + "is_aligned Low_pt_ptr (pt_bits NormalPT_T)" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + +lemma Low_pt_is_aligned'[simp]: + "is_aligned Low_pt_ptr pageBits" + by (fold pt_bits_NormalPT_T) simp + +lemma is_aligned_pptr_base: + "is_aligned pptr_base pptrBaseOffset_alignment" + by (simp add: is_aligned_def pptr_base_def pptrBase_def pptrBaseOffset_alignment_def) + +lemma pptr_base_leq[simp]: + "pptr_base \ Low_pt_ptr" + "pptr_base \ Low_pd_ptr" + "pptr_base \ High_pt_ptr" + "pptr_base \ High_pd_ptr" + unfolding Low_pt_ptr_def Low_pd_ptr_def High_pt_ptr_def High_pd_ptr_def + apply (all \rule is_aligned_no_wrap'[OF is_aligned_pptr_base]\) + apply (simp_all add: pptrBaseOffset_alignment_def) + done + +lemma pptr_base_less[simp]: + "Low_pt_ptr < pptrTop" + "Low_pd_ptr < pptrTop" + "High_pt_ptr < pptrTop" + "High_pd_ptr < pptrTop" + by (auto simp: Low_pt_ptr_def Low_pd_ptr_def High_pt_ptr_def High_pd_ptr_def pptrTop_def pptr_base_def pptrBase_def) + +lemma High_pt_is_aligned[simp]: + "is_aligned High_pt_ptr (pt_bits NormalPT_T)" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + +lemma High_pt_is_aligned'[simp]: + "is_aligned High_pt_ptr pageBits" + by (fold pt_bits_NormalPT_T) simp + +lemma Low_pd_is_aligned[simp]: + "is_aligned Low_pd_ptr (pt_bits VSRootPT_T)" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + +lemma High_pd_is_aligned[simp]: + "is_aligned High_pd_ptr (pt_bits VSRootPT_T)" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def) + + +lemma ptrFromPAddr_simps[simp]: + "ptrFromPAddr (paddr_from_ppn (ppn_from_pptr Low_pt_ptr)) = Low_pt_ptr" + "ptrFromPAddr (paddr_from_ppn (ppn_from_pptr High_pt_ptr)) = High_pt_ptr" + by (auto simp: ptrFromPAddr_addr_from_ppn) + +lemma table_base_simps[simp]: + "table_base VSRootPT_T (pt_slot_offset max_pt_level Low_pd_ptr vref) = Low_pd_ptr" + "table_base VSRootPT_T (pt_slot_offset max_pt_level High_pd_ptr vref) = High_pd_ptr" + by (auto intro: table_base_pt_slot_offset[where level=max_pt_level, simplified level_type_max]) + +lemma shared_page_ptr_is_aligned[simp]: + "is_aligned shared_page_ptr_virt (pageBitsForSize max_page_size)" + by (clarsimp simp: s0_ptr_defs pt_bits_def table_size_def max_page_size_def ptTranslationBits_def pte_bits_def word_size_bits_def is_aligned_def pageBits_def) + +lemma asid_high_low: + "\ asid_high_bits_of asid = asid_high_bits_of asid'; + asid_low_bits_of asid = asid_low_bits_of asid' \ \ + asid = asid'" + unfolding asid_high_bits_of_def asid_low_bits_of_def asid_high_bits_def asid_low_bits_def + by word_bitwise simp + +lemma vs_lookup_s0_SomeD: + "vs_lookup_table lvl asid vref s0_internal = Some (lvl', p) + \ (asid_high_bits_of asid = asid_high_bits_of High_asid \ lvl' = asid_pool_level \ p = High_pool_ptr + \ asid_high_bits_of asid = asid_high_bits_of Low_asid \ lvl' = asid_pool_level \ p = Low_pool_ptr + \ asid = High_asid \ lvl' = max_pt_level \ p = High_pd_ptr + \ asid = Low_asid \ lvl' = max_pt_level \ p = Low_pd_ptr + \ asid = High_asid \ lvl' = max_pt_level - 1 \ p = High_pt_ptr + \ asid = Low_asid \ lvl' = max_pt_level - 1 \ p = Low_pt_ptr)" + apply (clarsimp simp: vs_lookup_table_def obind_def split: option.splits if_splits) + apply (clarsimp simp: pool_for_asid_s0 split: if_splits) + apply (case_tac "lvl = max_pt_level") + apply (clarsimp simp: asid_pools_of_s0 pool_for_asid_s0 asid_high_low vspace_for_pool_def entry_for_pool_def + split: if_splits) + apply (case_tac "lvl = max_pt_level - 1") + apply (clarsimp simp: pt_walk.simps split: if_splits) + apply (drule (1) ptes_of_s0_PageTablePTE) + apply (auto simp: pptr_from_pte_def ptes_of_def asid_high_low + kh0_obj_def pts_of_s0 pool_for_asid_s0 asid_pools_of_s0 vspace_for_pool_def entry_for_pool_def + split: if_splits)[2] + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp split: if_splits) + apply (drule (1) ptes_of_s0_PageTablePTE) + apply (erule disjE; clarsimp) + apply (clarsimp simp: vspace_for_pool_def entry_for_pool_def pptr_from_pte_def asid_pools_of_s0 pool_for_asid_s0 + split: if_splits) + apply (clarsimp simp: pts_of_s0 asid_high_low) + apply (subst (asm) pt_walk.simps) + apply (clarsimp split: if_splits) + apply (clarsimp simp: level_pte_of_def pt_apply_def split: pt.splits option.splits if_splits simp: obind_def) + apply (clarsimp simp: vspace_for_pool_def entry_for_pool_def pptr_from_pte_def asid_pools_of_s0 pool_for_asid_s0 + split: if_splits) + apply (clarsimp simp: pts_of_s0 asid_high_low) + apply (subst (asm) pt_walk.simps) + apply (clarsimp split: if_splits) + apply (clarsimp simp: level_pte_of_def pt_apply_def split: pt.splits option.splits if_splits simp: obind_def) + apply (clarsimp simp: vspace_for_pool_def entry_for_pool_def pptr_from_pte_def asid_pools_of_s0 pool_for_asid_s0 + split: if_splits) + apply (clarsimp simp: pts_of_s0 asid_high_low) + apply (clarsimp simp: pts_of_s0 asid_high_low) + done + +lemma ptr_range_weaken: + "\ (x :: machine_word) \ ptr_range ptr sz'; sz' \ sz; sz \ word_bits; is_aligned ptr sz \ \ x \ ptr_range ptr sz" + apply (clarsimp simp: ptr_range_def) + apply (erule order.trans) + apply (frule (1) order.trans) + apply (subgoal_tac "ptr + mask sz' \ ptr + mask sz") + apply (clarsimp simp: mask_def p_assoc_help) + apply (subgoal_tac "is_aligned ptr sz \ is_aligned ptr sz'") + apply (rule aligned_mask_step; clarsimp simp: is_aligned_no_overflow_mask) + apply (auto elim: is_aligned_weaken) + done + +lemma max_page_level_def2: + "max_page_level = max_pt_level - 1" + by (simp add: max_pt_level_def max_page_level_def asid_pool_level_def) + +lemma ptr_range_max_pt_level_minus_1: + "\ (x :: machine_word) \ ptr_range ptr (pt_bits_left (max_pt_level - 1)); + is_aligned ptr (pageBitsForSize max_page_size)\ + \ x \ ptr_range ptr (pageBitsForSize max_page_size)" + apply (erule ptr_range_weaken) + apply (clarsimp simp: max_page_size_def2 max_page_level_def2) + apply (clarsimp simp: word_bits_def max_page_size_def pageBits_def ptTranslationBits_def split: if_splits) + apply assumption + done + +lemma Sys1_pas_refined: + "pas_refined Sys1PAS s0_internal" + apply (clarsimp simp: pas_refined_def) + apply (intro conjI) + apply (simp add: Sys1_pas_wellformed) + apply (clarsimp simp: irq_map_wellformed_aux_def s0_internal_def Sys1AgentMap_def Sys1PAS_def) + apply (clarsimp simp: s0_ptr_defs ptr_range_def ptTranslationBits_def pageBits_def cte_level_bits_def) + apply word_bitwise + apply (clarsimp simp: tcb_domain_map_wellformed_aux_def minBound_word High_domain_def Low_domain_def + Sys1PAS_def Sys1AgentMap_def default_domain_def) + apply (clarsimp simp: auth_graph_map_def Sys1PAS_def state_objs_to_policy_def state_bits_to_policy_def) + apply (erule state_bits_to_policyp.cases; clarsimp) + apply (drule s0_caps_of_state, clarsimp) + apply (simp add: Sys1AuthGraph_def) + apply (elim disjE; clarsimp simp: Sys1AgentMap_simps cap_auth_conferred_def ptr_range_def + arch_cap_auth_conferred_def vspace_cap_rights_to_auth_def + vm_read_write_def vm_read_only_def cap_rights_to_auth_def) + apply (drule s0_caps_of_state, clarsimp) + apply (elim disjE, simp_all)[1] + apply (clarsimp simp: state_refs_of_def thread_st_auth_def tcb_states_of_state_s0 + Sys1AuthGraph_def Sys1AgentMap_simps split: if_splits) + apply (clarsimp simp: state_refs_of_def thread_st_auth_def thread_bounds_of_state_s0) + apply (simp add: s0_internal_def) (* this is OK because cdt is empty..*) + apply (simp add: s0_internal_def) (* this is OK because cdt is empty..*) + apply (clarsimp simp: state_vrefs_def) + apply (drule vs_lookup_s0_SomeD) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: s0_internal_def kh0_obj_def opt_map_def vs_refs_aux_def + vm_read_only_def vspace_cap_rights_to_auth_def pte_ref2_def + Sys1AuthGraph_def Sys1AgentMap_simps graph_of_def + shared_page_ptr_phys_def + dest!: kh0_SomeD split: option.splits if_splits | drule ptr_range_max_pt_level_minus_1)+)[6] + apply (clarsimp simp: state_hyp_refs_of_def hyp_refs_of_def tcb_vcpu_refs_def + s0_internal_def refs_of_ao_def + split: option.splits kernel_object.splits arch_kernel_obj.splits) + apply (auto dest: kh0_SomeD simp: kh0_obj_def)[2] + apply (rule subsetI, clarsimp) + apply (erule state_asids_to_policy_aux.cases) + apply (drule s0_caps_of_state, clarsimp) + apply (fastforce simp: Sys1AuthGraph_def Sys1PAS_def Sys1ASIDMap_def Sys1AgentMap_def + Low_asid_def High_asid_def Silc_asid_def + asid_low_bits_def asid_high_bits_of_def) + apply (clarsimp simp: state_vrefs_def) + apply (drule vs_lookup_s0_SomeD) + apply (clarsimp simp: vs_refs_aux_def s0_internal_def arch_state0_def kh0_def kh0_obj_def + Sys1PAS_def Sys1ASIDMap_def Sys1AgentMap_simps Sys1AuthGraph_def + opt_map_def graph_of_def split: if_splits) + apply (clarsimp simp: Sys1PAS_def Sys1ASIDMap_def Sys1AgentMap_simps Sys1AuthGraph_def + s0_internal_def arch_state0_def split: if_splits) + apply (fastforce elim: state_irqs_to_policy_aux.cases dest: s0_caps_of_state) + done + +lemma Sys1_pas_cur_domain: + "pas_cur_domain Sys1PAS s0_internal" + by (simp add: s0_internal_def exst0_def Sys1PAS_def) + +lemma Sys1_current_subject_idemp: + "Sys1PAS\pasSubject := the_elem (pasDomainAbs Sys1PAS (cur_domain s0_internal))\ = Sys1PAS" + by (simp add: Sys1PAS_def s0_internal_def exst0_def) + +lemma pasMaySendIrqs_Sys1PAS[simp]: + "pasMaySendIrqs Sys1PAS = False" + by(auto simp: Sys1PAS_def) + +lemma Sys1_pas_domains_distinct: + "pas_domains_distinct Sys1PAS" + by (clarsimp simp: Sys1PAS_def pas_domains_distinct_def) + +lemma Sys1_pas_wellformed_noninterference: + "pas_wellformed_noninterference Sys1PAS" + apply (simp add: pas_wellformed_noninterference_def) + apply (intro conjI ballI allI) + apply (blast intro: Sys1_wellformed) + apply (clarsimp simp: Sys1PAS_def policy_wellformed_def Sys1AuthGraph_def) + apply (rule Sys1_pas_domains_distinct) + done + +lemma Sys1AgentMap_shared_page_ptr: + "Sys1AgentMap shared_page_ptr_virt = partition_label Low" + by (clarsimp simp: Sys1AgentMap_def s0_ptr_defs ptr_range_def bit_simps max_page_size_def) + +lemma silc_inv_s0: + "silc_inv Sys1PAS s0_internal s0_internal" + apply (clarsimp simp: silc_inv_def) + apply (rule conjI, simp add: Sys1PAS_def) + apply (rule conjI) + apply (clarsimp simp: Sys1PAS_def Sys1AgentMap_def s0_internal_def kh0_def obj_at_def kh0_obj_def + is_cap_table_def Silc_caps_well_formed split: if_split_asm) + apply (rule conjI) + apply (clarsimp simp: Sys1PAS_def Sys1AuthGraph_def) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=Silc_cnode_ptr in exI) + apply (rule conjI) + apply (subgoal_tac "(Silc_cnode_ptr,the_nat_to_bl_10 318) \ slots_holding_overlapping_caps cap s0_internal + \ (Silc_cnode_ptr, the_nat_to_bl_10 5) \ slots_holding_overlapping_caps cap s0_internal") + apply fastforce + apply clarsimp + apply (clarsimp simp: slots_holding_overlapping_caps_def2) + apply (case_tac "cap = NullCap") + apply clarsimp + apply (simp add: cte_wp_at_cases s0_internal_def kh0_def kh0_obj_def) + apply (case_tac a, clarsimp) + apply (clarsimp split: if_splits) + apply ((clarsimp simp: intra_label_cap_def cte_wp_at_cases tcb_cap_cases_def + cap_points_to_label_def split: if_split_asm)+)[8] + apply (clarsimp simp: intra_label_cap_def cap_points_to_label_def) + apply (drule cte_wp_at_caps_of_state' s0_caps_of_state)+ + apply ((erule disjE | + clarsimp simp: Sys1PAS_def Sys1AgentMap_simps + the_nat_to_bl_def nat_to_bl_def ctes_wp_at_def cte_wp_at_cases + s0_internal_def kh0_def kh0_obj_def Silc_caps_well_formed obj_refs_def + | simp add: Silc_caps_def)+)[1] + apply (clarsimp simp: Sys1PAS_def Sys1AgentMap_def) + apply (intro conjI) + apply (clarsimp simp: all_children_def s0_internal_def silc_dom_equiv_def equiv_for_refl) + apply (clarsimp simp: all_children_def s0_internal_def silc_dom_equiv_def equiv_for_refl) + apply (clarsimp simp: Invariants_AI.cte_wp_at_caps_of_state) + by (auto simp:is_transferable.simps dest:s0_caps_of_state) + + +lemma only_timer_irq_s0: + "only_timer_irq timer_irq s0_internal" + apply (clarsimp simp: only_timer_irq_def s0_internal_def irq_is_recurring_def is_irq_at_def + irq_at_def Let_def irq_oracle_def machine_state0_def timer_irq_def) + done + +lemma domain_sep_inv_s0: + "domain_sep_inv False s0_internal s0_internal" + apply (clarsimp simp: domain_sep_inv_def) + apply (force dest: cte_wp_at_caps_of_state' s0_caps_of_state + | rule conjI allI | clarsimp simp: s0_internal_def)+ + apply (clarsimp simp: timer_irq_def non_kernel_IRQs_def irqVGICMaintenance_def irqVTimerEvent_def) + done + +lemma only_timer_irq_inv_s0: + "only_timer_irq_inv timer_irq s0_internal s0_internal" + by (simp add: only_timer_irq_inv_def only_timer_irq_s0 domain_sep_inv_s0) + +lemma Sys1_guarded_pas_domain: + "guarded_pas_domain Sys1PAS s0_internal" + by (clarsimp simp: guarded_pas_domain_def Sys1PAS_def s0_internal_def exst0_def Sys1AgentMap_simps) + +lemma s0_valid_domain_list: + "valid_domain_list s0_internal" + by (clarsimp simp: valid_domain_list_2_def s0_internal_def exst0_def) + +definition + "s0 \ ((if ct_idle s0_internal then idle_context s0_internal else s0_context,s0_internal),KernelExit)" + + +subsubsection \einvs\ + +lemma well_formed_cnode_n_s0_caps[simp]: + "well_formed_cnode_n 10 High_caps" + "well_formed_cnode_n 10 Low_caps" + "well_formed_cnode_n 10 Silc_caps" + "\ well_formed_cnode_n 10 [[] \ NullCap]" + apply (simp add: High_caps_well_formed Low_caps_well_formed Silc_caps_well_formed)+ + apply (fastforce simp: well_formed_cnode_n_def dest: eqset_imp_iff[where x="[]"]) + done + +lemma valid_caps_s0[simp]: + "s0_internal \ ThreadCap Low_tcb_ptr" + "s0_internal \ ThreadCap High_tcb_ptr" + "s0_internal \ CNodeCap Low_cnode_ptr 10 (the_nat_to_bl_10 2)" + "s0_internal \ CNodeCap High_cnode_ptr 10 (the_nat_to_bl_10 2)" + "s0_internal \ CNodeCap Silc_cnode_ptr 10 (the_nat_to_bl_10 2)" + "s0_internal \ ArchObjectCap (ASIDPoolCap Low_pool_ptr Low_asid)" + "s0_internal \ ArchObjectCap (ASIDPoolCap High_pool_ptr High_asid)" + "s0_internal \ ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (Low_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (High_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0)))" + "s0_internal \ ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0)))" + "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_write max_page_size False (Some (Low_asid,0)))" + "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (High_asid,0)))" + "s0_internal \ ArchObjectCap (FrameCap shared_page_ptr_virt vm_read_only max_page_size False (Some (Silc_asid,0)))" + "s0_internal \ NotificationCap ntfn_ptr 0 {AllowWrite}" + "s0_internal \ NotificationCap ntfn_ptr 0 {AllowRead}" + "s0_internal \ ReplyCap Low_tcb_ptr True {AllowGrant,AllowWrite}" + "s0_internal \ ReplyCap High_tcb_ptr True {AllowGrant,AllowWrite}" + by (auto simp: s0_internal_def s0_ptr_defs kh0_def kh0_obj_def bit_simps word_bits_def + valid_cap_def cap_aligned_def is_aligned_def obj_at_def cte_level_bits_def + is_ntfn_def is_tcb_def is_cap_table_def a_type_def the_nat_to_bl_def nat_to_bl_def + Low_asid_def High_asid_def Silc_asid_def asid_low_bits_def asid_bits_def + wellformed_mapdata_def valid_vm_rights_def vmsz_aligned_def + max_page_size_def pageBits_def ptTranslationBits_def) + +lemma valid_obj_s0[simp]: + "valid_obj Low_cnode_ptr Low_cnode s0_internal" + "valid_obj High_cnode_ptr High_cnode s0_internal" + "valid_obj High_pool_ptr High_pool s0_internal" + "valid_obj Low_pool_ptr Low_pool s0_internal" + "valid_obj Silc_cnode_ptr Silc_cnode s0_internal" + "valid_obj ntfn_ptr ntfn s0_internal" + "valid_obj irq_cnode_ptr irq_cnode s0_internal" + "valid_obj Low_pd_ptr Low_pd s0_internal" + "valid_obj High_pd_ptr High_pd s0_internal" + "valid_obj Low_pt_ptr Low_pt s0_internal" + "valid_obj High_pt_ptr High_pt s0_internal" + "valid_obj Low_tcb_ptr Low_tcb s0_internal" + "valid_obj High_tcb_ptr High_tcb s0_internal" + "valid_obj idle_tcb_ptr idle_tcb s0_internal" + "valid_obj arm_global_pt_ptr (ArchObj global_pt_obj) s0_internal" + "valid_obj shared_page_ptr_virt shared_page s0_internal" + apply (simp_all add: valid_obj_def kh0_obj_def) + apply (simp add: valid_cs_def Low_caps_ran High_caps_ran Silc_caps_ran + valid_cs_size_def word_bits_def cte_level_bits_def)+ + apply (simp add: valid_ntfn_def obj_at_def s0_internal_def kh0_def High_tcb_def is_tcb_def) + apply (simp add: valid_cs_def valid_cs_size_def word_bits_def + cte_level_bits_def well_formed_cnode_n_def) + apply (clarsimp simp: valid_tcb_def tcb_cap_cases_def valid_tcb_state_def valid_arch_tcb_def + valid_pt_range_def invalid_mapping_slots_def + is_valid_vtable_root_def is_master_reply_cap_def is_ntfn_def obj_at_def + wellformed_pte_def valid_vm_rights_def vm_kernel_only_def + | fastforce simp: s0_internal_def kh0_def kh0_obj_def)+ + done + +lemma valid_objs_s0: + "valid_objs s0_internal" + apply (clarsimp simp: valid_objs_def) + apply (subst (asm) s0_internal_def, clarsimp) + apply (drule kh0_SomeD) + apply (elim disjE; clarsimp) + apply (fastforce simp: valid_obj_def valid_cs_def valid_cs_size_def + cte_level_bits_def word_bits_def well_formed_cnode_n_def) + done + +lemma pspace_aligned_s0: + "pspace_aligned s0_internal" + apply (clarsimp simp: pspace_aligned_def s0_internal_def) + apply (drule kh0_SomeD) + apply (auto simp: cte_level_bits_def irq_node_offs_range_def + is_aligned_def s0_ptr_defs kh0_obj_def bit_simps max_page_size_def) + done + +lemma pspace_distinct_s0: + "pspace_distinct s0_internal" + apply (clarsimp simp: pspace_distinct_def s0_internal_def) + apply (drule kh0_SomeD)+ + apply (case_tac "x \ irq_node_offs_range \ y \ irq_node_offs_range") + apply clarsimp + apply (drule irq_node_offs_range_correct)+ + apply clarsimp + apply (clarsimp simp: s0_ptr_defs cte_level_bits_def) + apply word_bitwise + apply auto[1] + apply (elim disjE) + (* slow *) + by ((simp | clarsimp simp: kh0_obj_def cte_level_bits_def s0_ptr_defs pte_bits_def bit_simps + | fastforce split: if_split_asm + | clarsimp simp: irq_node_offs_range_def s0_ptr_defs irq_len_def cte_level_bits_def, + drule_tac x="0x1F" in word_plus_strict_mono_right, simp, simp add: add.commute, + drule(1) notE[rotated, OF less_trans, OF _ _ leD, rotated 2] + | drule(1) notE[rotated, OF le_less_trans, OF _ _ leD, rotated 2], simp, assumption)+) + + +lemma valid_pspace_s0[simp]: + "valid_pspace s0_internal" + apply (simp add: valid_pspace_def pspace_distinct_s0 pspace_aligned_s0 valid_objs_s0) + apply (rule conjI) + apply (clarsimp simp: if_live_then_nonz_cap_def) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: ex_nonz_cap_to_def live_def arch_tcb_live_def + hyp_live_def obj_at_def kh0_def kh0_obj_def arch_live_def + split: if_splits) + apply (rule_tac x="High_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 1" in exI) + apply (force simp: s0_internal_def kh0_def kh0_obj_def High_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (rule_tac x="Low_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 1" in exI) + apply (force simp: s0_internal_def kh0_def kh0_obj_def Low_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (rule_tac x="High_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 318" in exI) + apply (force simp: s0_internal_def kh0_def kh0_obj_def High_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (intro conjI) + apply (force dest: s0_caps_of_state simp: cte_wp_at_caps_of_state zombies_final_def is_zombie_def) + apply (clarsimp simp: sym_refs_def state_refs_of_def state_hyp_refs_of_def + refs_of_def s0_internal_def kh0_def kh0_obj_def) + apply (clarsimp simp: sym_refs_def state_hyp_refs_of_def s0_internal_def kh0_def kh0_obj_def) + done + +lemma descendants_s0[simp]: + "descendants_of (a, b) (cdt s0_internal) = {}" + apply (rule set_eqI) + apply clarsimp + apply (drule descendants_of_NoneD[rotated]) + apply (simp add: s0_internal_def)+ + done + +lemma valid_mdb_s0[simp]: + "valid_mdb s0_internal" + apply (simp add: valid_mdb_def reply_mdb_def) + apply (intro conjI) + apply (clarsimp simp: mdb_cte_at_def s0_internal_def) + apply (force dest: s0_caps_of_state simp: untyped_mdb_def) + apply (clarsimp simp: descendants_inc_def) + apply (clarsimp simp: no_mloop_def s0_internal_def cdt_parent_defs) + apply (clarsimp simp: untyped_inc_def) + apply (drule s0_caps_of_state)+ + apply ((simp | erule disjE)+)[1] + apply (force dest: s0_caps_of_state simp: ut_revocable_def) + apply (force dest: s0_caps_of_state simp: irq_revocable_def) + apply (clarsimp simp: reply_master_revocable_def) + apply (drule s0_caps_of_state) + apply ((simp add: is_master_reply_cap_def s0_internal_def s0_ptr_defs | erule disjE)+)[1] + apply (force dest: s0_caps_of_state simp: reply_caps_mdb_def) + apply (clarsimp simp: reply_masters_mdb_def) + apply (simp add: s0_internal_def) + apply (clarsimp simp: valid_arch_mdb_def) + done + +lemma valid_ioc_s0[simp]: + "valid_ioc s0_internal" + by (clarsimp simp: cte_wp_at_cases valid_ioc_def s0_internal_def kh0_def kh0_obj_def) + +lemma valid_idle_s0[simp]: + "valid_idle s0_internal" + by (clarsimp simp: valid_idle_def valid_arch_idle_def pred_tcb_at_def obj_at_def + idle_thread_ptr_def idle_tcb_def kh0_def s0_ptr_defs s0_internal_def) + +lemma only_idle_s0[simp]: + "only_idle s0_internal" + apply (clarsimp simp: only_idle_def st_tcb_at_tcb_states_of_state_eq + identity_eq[symmetric] tcb_states_of_state_s0) + apply (simp add: s0_ptr_defs s0_internal_def) + done + +lemma if_unsafe_then_cap_s0[simp]: + "if_unsafe_then_cap s0_internal" + apply (clarsimp simp: if_unsafe_then_cap_def ex_cte_cap_wp_to_def) + apply (drule s0_caps_of_state) + apply (case_tac "a=Low_cnode_ptr") + apply (rule_tac x=Low_tcb_ptr in exI, rule_tac x="tcb_cnode_index 0" in exI) + apply (fastforce simp: cte_wp_at_cases s0_internal_def kh0_def kh0_obj_def) + apply (case_tac "a=High_cnode_ptr") + apply (rule_tac x=High_tcb_ptr in exI, rule_tac x="tcb_cnode_index 0" in exI) + apply (fastforce simp: cte_wp_at_cases s0_internal_def kh0_def kh0_obj_def) + apply (case_tac "a=Low_tcb_ptr") + apply (rule_tac x=Low_cnode_ptr in exI, rule_tac x="the_nat_to_bl_10 1" in exI) + apply (fastforce simp: s0_internal_def kh0_def kh0_obj_def Low_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (case_tac "a=High_tcb_ptr") + apply (rule_tac x=High_cnode_ptr in exI, rule_tac x="the_nat_to_bl_10 1" in exI) + apply (fastforce simp: s0_internal_def kh0_def kh0_obj_def High_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + apply (rule_tac x=Silc_cnode_ptr in exI, rule_tac x="the_nat_to_bl_10 2" in exI) + apply (fastforce simp: s0_internal_def kh0_def kh0_obj_def Silc_caps_def + cte_wp_at_cases well_formed_cnode_n_def) + done + +lemma valid_reply_caps_s0[simp]: + "valid_reply_caps s0_internal" + apply (clarsimp simp: valid_reply_caps_def) + apply (rule conjI) + apply (force dest: s0_caps_of_state + simp: cte_wp_at_caps_of_state has_reply_cap_def is_reply_cap_to_def) + apply (clarsimp simp: unique_reply_caps_def) + apply (drule s0_caps_of_state)+ + apply (erule disjE | simp add: is_reply_cap_def)+ + done + +lemma valid_reply_masters_s0[simp]: + "valid_reply_masters s0_internal" + apply (clarsimp simp: valid_reply_masters_def) + apply (force dest: s0_caps_of_state simp: cte_wp_at_caps_of_state is_master_reply_cap_to_def) + done + +lemma valid_global_refs_s0[simp]: + "valid_global_refs s0_internal" + apply (clarsimp simp: valid_global_refs_def valid_refs_def cte_wp_at_caps_of_state) + apply (drule s0_caps_of_state) + apply (clarsimp simp: global_refs_def s0_internal_def arch_state0_def) + apply (erule disjE | simp add: cap_range_def + | clarsimp simp: irq_node_offs_distinct[symmetric] + | simp only: s0_ptr_defs, force)+ + done + + +lemma valid_uses_init_A_st[simp]: "valid_uses_2 init_vspace_uses" +proof - + have "\p. p < pptrTop \ canonical_address p" + by (simp add: canonical_address_range canonical_bit_def mask_def pptrTop_def + word_le_nat_alt word_less_nat_alt) + moreover + have "pptr_base < pptrTop" + by (simp add: pptrTop_def pptr_base_def pptrBase_def) + moreover + have "pptrTop < kdev_base" + by (simp add: kdev_base_def kdevBase_def pptrTop_def) + ultimately + show ?thesis + unfolding valid_uses_2_def init_vspace_uses_def window_defs + by (auto simp: kernel_window_range_def) +qed + +lemma valid_arch_state_s0[simp]: + "valid_arch_state s0_internal" + apply (clarsimp simp: valid_arch_state_def s0_internal_def arch_state0_def) + apply (intro conjI) + apply (auto simp: valid_asid_table_def kh0_def kh0_obj_def opt_map_def asid_entry_def + asid_high_bits_of_def asid_low_bits_def Low_asid_def High_asid_def + split: option.splits)[1] + apply (clarsimp simp: vmid_inv_def is_inv_def) + apply (clarsimp simp: valid_vmid_table_def) + apply (clarsimp simp: cur_vcpu_def) + apply (clarsimp simp: valid_global_arch_objs_def obj_at_def kh0_def a_type_def + max_pt_level_not_asid_pool_level[symmetric] global_pt_obj_def) + apply (clarsimp simp: valid_global_tables_def opt_map_def kh0_def global_pt_obj_def empty_pt_def) + apply (clarsimp simp: valid_numlistregs_def word_bits_def max_numlistregs_def) + done + +lemma valid_irq_node_s0[simp]: + "valid_irq_node s0_internal" + apply (clarsimp simp: valid_irq_node_def) + apply (rule conjI) + apply (simp add: s0_internal_def) + apply (rule injI) + apply (simp add: cte_level_bits_def) + apply (rule ccontr) + apply (rule_tac bnd="0x200" and 'a=64 in shift_distinct_helper[rotated 3]) + apply assumption + apply (simp add: cte_level_bits_def) + apply simp + apply (rule ucast_less[where 'b=9, simplified]) + apply simp + apply (rule ucast_less[where 'b=9, simplified]) + apply simp + apply (rule notI) + apply (drule ucast_up_inj) + apply simp + apply simp + apply (clarsimp simp: obj_at_def s0_internal_def) + apply (force simp: kh0_def is_cap_table_def well_formed_cnode_n_def dom_empty_cnode) + done + +lemma valid_irq_handlers_s0[simp]: + "valid_irq_handlers s0_internal" + apply (clarsimp simp: valid_irq_handlers_def ran_def) + apply (force dest: s0_caps_of_state) + done + +lemma valid_irq_state_s0[simp]: + "valid_irq_states s0_internal" + by (clarsimp simp: valid_irq_states_def valid_irq_masks_def s0_internal_def machine_state0_def) + +lemma valid_machine_state_s0[simp]: + "valid_machine_state s0_internal" + by (clarsimp simp: valid_machine_state_def s0_internal_def const_def + machine_state0_def in_user_frame_def obj_at_def) + +lemma valid_arch_objs_s0[simp]: + "valid_vspace_objs s0_internal" + apply (clarsimp simp: valid_vspace_objs_def obj_at_def) + apply (drule vs_lookup_s0_SomeD) + apply (elim disjE) + by (auto simp: aobjs_of_Some kh_s0_def kh0_obj_def data_at_def obj_at_def + max_pt_level_def2 vmsize_of_level_def max_page_level_def + shared_page_ptr_phys_def max_page_size_def opt_map_def + split: option.splits) + +lemma valid_vs_lookup_s0_internal: + "valid_vs_lookup s0_internal" + supply pt_simps = pt_slot_offset_def pt_bits_left_def pt_index_def max_pt_level_def2 + supply user_region_simps = user_region_def canonical_user_def + supply caps_of_state_simps = caps_of_state_def get_cap_def gets_def get_def get_object_def + assert_def assert_opt_def fail_def return_def bind_def + apply (clarsimp simp: valid_vs_lookup_def vs_lookup_target_def vs_lookup_slot_def split: if_splits) + \ \asid pool level\ + apply (drule vs_lookup_level) + apply (clarsimp simp: pool_for_asid_vs_lookup pool_for_asid_s0 asid_pools_of_s0 entry_for_pool_def + vspace_for_pool_def user_region_def vref_for_level_asid_pool + dest!: asid_high_low split: if_splits) + \ \High asid\ + apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) + apply (rule_tac x=High_cnode_ptr in exI) + apply (rule_tac x="(the_nat_to_bl_10 3)" in exI) + apply (fastforce simp: High_cnode_def High_caps_def caps_of_state_def get_cap_def get_object_def + gets_def get_def assert_def assert_opt_def fail_def return_def bind_def + s0_internal_def kh0_def well_formed_cnode_n_def) + \ \Low asid\ + apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) + apply (rule_tac x=Low_cnode_ptr in exI) + apply (rule_tac x="(the_nat_to_bl_10 3)" in exI) + apply (fastforce simp: Low_cnode_def Low_caps_def caps_of_state_def get_cap_def get_object_def + gets_def get_def assert_def assert_opt_def fail_def return_def bind_def + s0_internal_def kh0_def well_formed_cnode_n_def) + \ \below asid pool level\ + apply (clarsimp simp: vs_lookup_table_def split: if_splits) + apply (clarsimp simp: pt_walk.simps) + apply (case_tac "bot_level < max_pt_level"; clarsimp) + + prefer 2 + \ \bot level = max pt level\ + + apply (clarsimp simp: pool_for_asid_s0 vspace_for_pool_def asid_pools_of_s0 entry_for_pool_def + dest!: asid_high_low split: if_splits) + \ \High asid\ + apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) + apply (rule_tac x=High_cnode_ptr in exI) + apply (rule_tac x="(the_nat_to_bl_10 6)" in exI) + apply (rule_tac x="ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (High_asid,0)))" in exI) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: in_omonad ptes_of_def High_pd_def + dest!: kh0_SomeD split: if_splits) + apply (intro conjI) + apply (fastforce simp: High_cnode_def High_caps_def caps_of_state_simps + s0_internal_def kh0_def well_formed_cnode_n_def) + apply (clarsimp simp: pptr_from_pte_def) + apply (clarsimp simp: vref_for_level_def user_region_simps mask_def bit_simps pt_simps asid_pool_level_def s0_ptr_defs split: if_splits) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (word_bitwise, clarsimp simp: bit_simps) + \ \Low asid\ + apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) + apply (rule_tac x=Low_cnode_ptr in exI) + apply (rule_tac x="(the_nat_to_bl_10 6)" in exI) + apply (rule_tac x="ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (Low_asid,0)))" in exI) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: in_omonad ptes_of_def Low_pd_def + dest!: kh0_SomeD split: if_splits) + apply (intro conjI) + apply (fastforce simp: Low_cnode_def Low_caps_def caps_of_state_simps + s0_internal_def kh0_def well_formed_cnode_n_def) + apply (clarsimp simp: pptr_from_pte_def) + apply (clarsimp simp: vref_for_level_def user_region_simps mask_def bit_simps pt_simps asid_pool_level_def s0_ptr_defs split: if_splits) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (word_bitwise, clarsimp simp: bit_simps) + \ \bot level < max pt level\ + apply (clarsimp simp: pool_for_asid_s0 vspace_for_pool_def asid_pools_of_s0 entry_for_pool_def + dest!: asid_high_low split: if_splits) + \ \High asid\ + apply (subst (asm) ptes_of_def) + apply (clarsimp simp: pts_of_s0) + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def + split: if_splits) + apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) + apply (prop_tac "pt_walk (max_pt_level - 1) bot_level High_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level - 1, High_pt_ptr)") + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def) + apply (rule_tac x=High_cnode_ptr in exI) + apply (rule_tac x="the_nat_to_bl_10 5" in exI) + apply (rule exI, intro conjI) + apply (fastforce simp: High_cnode_def High_caps_def caps_of_state_simps + s0_internal_def kh0_def well_formed_cnode_n_def) + apply (clarsimp split: if_splits) + apply (clarsimp split: if_splits) + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs asid_pool_level_def split: if_splits) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs asid_pool_level_def split: if_splits) + apply word_bitwise + apply word_bitwise + apply (subst (asm) ptes_of_def) + apply (clarsimp simp: pts_of_s0) + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def + split: if_splits) + apply (rule conjI, clarsimp simp: High_asid_def asid_low_bits_def) + apply (prop_tac "pt_walk (max_pt_level - 1) bot_level High_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level - 1, High_pt_ptr)") + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def) + + \ \Low asid\ + + apply (subst (asm) ptes_of_def) + apply (clarsimp simp: pts_of_s0) + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def + split: if_splits) + apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) + apply (prop_tac "pt_walk (max_pt_level - 1) bot_level Low_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level - 1, Low_pt_ptr)") + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def) + apply (rule_tac x=Low_cnode_ptr in exI) + apply (rule_tac x="the_nat_to_bl_10 5" in exI) + apply (rule exI, intro conjI) + apply (fastforce simp: Low_cnode_def Low_caps_def caps_of_state_simps + s0_internal_def kh0_def well_formed_cnode_n_def) + apply (clarsimp split: if_splits) + apply (clarsimp split: if_splits) + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs asid_pool_level_def split: if_splits) + apply word_bitwise + apply word_bitwise + apply (clarsimp simp: vref_for_level_def mask_def pt_simps user_region_simps bit_simps s0_ptr_defs asid_pool_level_def split: if_splits) + apply (word_bitwise, clarsimp simp: bit_simps) + apply (word_bitwise, clarsimp simp: bit_simps) + + \ \No lookups to other ptes\ + apply (subst (asm) ptes_of_def) + apply (clarsimp simp: pts_of_s0) + apply (clarsimp simp: in_omonad kh0_obj_def pptr_from_pte_def + split: if_splits) + apply (rule conjI, clarsimp simp: Low_asid_def asid_low_bits_def) + apply (prop_tac "pt_walk (max_pt_level - 1) bot_level Low_pt_ptr vref (ptes_of s0_internal) = + Some (max_pt_level - 1, Low_pt_ptr)") + apply (clarsimp simp: pt_walk.simps) + apply (clarsimp simp: ptes_of_def pts_of_s0 in_omonad split: if_splits) + apply (clarsimp simp: ptes_of_def pts_of_s0 shared_page_ptr_phys_def) + done + +lemma valid_arch_caps_s0[simp]: + "valid_arch_caps s0_internal" + supply if_split[split del] + supply caps_of_state_simps = caps_of_state_def get_cap_def gets_def get_def get_object_def + assert_def assert_opt_def fail_def return_def bind_def + apply (clarsimp simp: valid_arch_caps_def) + apply (intro conjI) + apply (simp add: valid_vs_lookup_s0_internal) + apply (clarsimp simp: valid_asid_pool_caps_def s0_internal_def arch_state0_def) + apply (clarsimp split: if_splits) + apply (rule_tac x="High_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 4" in exI) + apply (force simp: caps_of_state_simps well_formed_cnode_n_def s0_internal_def kh0_obj_def + kh0_def High_caps_def High_asid_def asid_high_bits_of_def asid_low_bits_def + split: if_splits) + apply (rule_tac x="Low_cnode_ptr" in exI) + apply (rule_tac x="the_nat_to_bl_10 4" in exI) + apply (force simp: caps_of_state_simps well_formed_cnode_n_def s0_internal_def kh0_obj_def + kh0_def Low_caps_def Low_asid_def asid_high_bits_of_def asid_low_bits_def + split: if_splits) + apply (clarsimp simp: valid_table_caps_def) + apply (fastforce simp: caps_of_state_simps pts_of_s0 s0_internal_def kh0_obj_def + tcb_cnode_map_def Silc_caps_def High_caps_def Low_caps_def + dest!: kh0_SomeD split: if_splits kernel_object.splits option.splits) + apply (clarsimp simp: unique_table_caps_def) + apply (clarsimp simp: caps_of_state_simps split: if_splits kernel_object.splits option.splits) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: kh0_def kh0_obj_def Silc_caps_def High_caps_def Low_caps_def + split: if_splits) + apply (subst (asm) s0_internal_def) + apply (clarsimp simp: kh0_def kh0_obj_def Silc_caps_def High_caps_def Low_caps_def + split: if_splits) + apply (clarsimp simp: s0_internal_def kh0_def kh0_obj_def split: if_splits; + clarsimp simp: tcb_cnode_map_def split: if_splits) + apply (clarsimp simp: s0_internal_def kh0_def kh0_obj_def split: if_splits; + clarsimp simp: tcb_cnode_map_def split: if_splits) + apply (clarsimp simp: unique_table_refs_def) + apply (drule s0_caps_of_state)+ + apply clarsimp + apply (elim disjE; clarsimp) + done + +lemma valid_global_objs_s0[simp]: + "valid_global_objs s0_internal" + by (clarsimp simp: valid_global_objs_def s0_internal_def arch_state0_def) + +lemma valid_kernel_mappings_s0[simp]: + "valid_kernel_mappings s0_internal" + by (clarsimp simp: valid_kernel_mappings_def s0_internal_def ran_def + split: kernel_object.splits arch_kernel_obj.splits) + +lemma equal_kernel_mappings_s0[simp]: + "equal_kernel_mappings s0_internal" + supply misc = vref_for_level_def pt_bits_left_def asid_pool_level_size + pageBits_def ptTranslationBits_def mask_def max_pt_level_def2 + apply (clarsimp simp: equal_kernel_mappings_def obj_at_def vspace_for_asid_def + vspace_for_pool_def pool_for_asid_s0 asid_pools_of_s0) + done + +lemma valid_asid_map_s0[simp]: + "valid_asid_map s0_internal" + by (clarsimp simp: valid_asid_map_def s0_internal_def arch_state0_def) + +lemma valid_global_pd_mappings_s0[simp]: + "valid_global_vspace_mappings s0_internal" + unfolding valid_global_vspace_mappings_def by simp + +lemma pspace_in_kernel_window_s0[simp]: + "pspace_in_kernel_window s0_internal" + apply (clarsimp simp: pspace_in_kernel_window_def kernel_window_def kernel_window_range_def + init_vspace_uses_def s0_internal_def arch_state0_def) + apply (drule kh0_SomeD) + apply (auto simp: s0_ptr_defs kh0_obj_def pageBits_def ptTranslationBits_def pptrTop_def table_size_def + pte_bits_def word_size_bits_def cte_level_bits_def max_page_size_def + dest!: irq_node_offs_range_correct + elim: dual_order.trans dual_order.strict_trans2[rotated]) + apply word_bitwise + apply clarsimp + apply word_bitwise + apply clarsimp + done + +lemma cap_refs_in_kernel_window_s0[simp]: + "cap_refs_in_kernel_window s0_internal" + apply (clarsimp simp: cap_refs_in_kernel_window_def valid_refs_def not_kernel_window_def + cap_range_def Invariants_AI.cte_wp_at_caps_of_state) + apply (subgoal_tac "- kernel_window s0_internal \ obj_refs cap = {}") + apply (fastforce dest: s0_caps_of_state) + apply (rule Int_emptyI, clarsimp) + apply (erule swap, clarsimp) + apply (drule s0_caps_of_state) + apply (clarsimp simp: kernel_window_def init_vspace_uses_def s0_internal_def arch_state0_def) + apply (auto simp: s0_ptr_defs kh0_obj_def pageBits_def ptTranslationBits_def pptrTop_def table_size_def + pte_bits_def word_size_bits_def cte_level_bits_def kernel_window_range_def + dest!: irq_node_offs_range_correct + elim: dual_order.trans dual_order.strict_trans2[rotated]) + done + +lemma cur_tcb_s0[simp]: + "cur_tcb s0_internal" + by (simp add: cur_tcb_def s0_ptr_defs s0_internal_def kh0_def kh0_obj_def obj_at_def is_tcb_def) + +lemma valid_list_s0[simp]: + "valid_list s0_internal" + by (simp add: valid_list_2_def s0_internal_def exst0_def const_def) + +lemma valid_sched_s0[simp]: + "valid_sched s0_internal" + apply (simp add: valid_sched_def s0_internal_def exst0_def) + apply (intro conjI) + apply (clarsimp simp: is_etcb_at'_def kh0_def kh0_obj_def + st_tcb_at_kh_def obj_at_kh_def obj_at_def) + apply (clarsimp simp: const_def) + apply (clarsimp simp: const_def) + apply (clarsimp simp: valid_sched_action_def is_activatable_def st_tcb_at_kh_def + obj_at_kh_def obj_at_def kh0_def kh0_obj_def s0_ptr_defs) + apply (clarsimp simp: ct_in_cur_domain_def in_cur_domain_def etcb_at'_def etcbs_of'_def kh0_def + kh0_obj_def s0_ptr_defs) + apply (clarsimp simp: const_def valid_blocked_def st_tcb_at_kh_def obj_at_kh_def obj_at_def + kh0_def kh0_obj_def split: if_split_asm) + apply (clarsimp simp: valid_idle_etcb_def etcb_at'_def etcbs_of'_def kh0_def kh0_obj_def s0_ptr_defs + idle_thread_ptr_def) + done + +lemma respects_device_trivial: + "pspace_respects_device_region s0_internal" + "cap_refs_respects_device_region s0_internal" + apply (clarsimp simp: s0_internal_def pspace_respects_device_region_def machine_state0_def kh0_def + kh0_obj_def device_mem_def in_device_frame_def obj_at_kh_def obj_at_def + split: if_splits) + apply fastforce + apply (clarsimp simp: cap_refs_respects_device_region_def Invariants_AI.cte_wp_at_caps_of_state + cap_range_respects_device_region_def machine_state0_def) + apply (intro conjI impI) + apply (drule s0_caps_of_state) + apply fastforce + apply (clarsimp simp: s0_internal_def machine_state0_def) + done + +lemma valid_cur_fpu_s0[simp]: + "valid_cur_fpu s0_internal" + by (auto simp: valid_cur_fpu_def s0_internal_def is_tcb_cur_fpu_def obj_at_def kh0_obj_def arch_state0_def dest!: kh0_SomeD) + +lemma einvs_s0: + "einvs s0_internal" + by (simp add: valid_state_def invs_def respects_device_trivial) + + +subsubsection \Haskell state\ + +text \One invariant we need on s0 is that there exists + an associated Haskell state satisfying the invariants. + This does not yet exist.\ + +lemma Sys1_valid_initial_state_noenabled: + assumes extras_s0: "step_restrict s0" + assumes utf_det: "\pl pr pxn tc ms s. det_inv InUserMode tc s \ einvs s \ + context_matches_state pl pr pxn ms s \ ct_running s + \ (\x. utf (cur_thread s) pl pr pxn (tc, ms) = {x})" + assumes utf_non_empty: "\t pl pr pxn tc ms. utf t pl pr pxn (tc, ms) \ {}" + assumes utf_non_interrupt: "\t pl pr pxn tc ms e f g. (e,f,g) \ utf t pl pr pxn (tc, ms) + \ e \ Some Interrupt" + assumes det_inv_invariant: "invariant_over_ADT_if det_inv utf" + assumes det_inv_s0: "det_inv KernelExit (cur_context s0_internal) s0_internal" + shows "valid_initial_state_noenabled det_inv utf s0_internal Sys1PAS timer_irq s0_context" + apply (unfold_locales, simp_all only: pasMaySendIrqs_Sys1PAS) + apply (insert det_inv_invariant)[9] + apply (erule(2) invariant_over_ADT_if.det_inv_abs_state) + apply ((erule invariant_over_ADT_if.det_inv_abs_state + invariant_over_ADT_if.check_active_irq_if_Idle_det_inv + invariant_over_ADT_if.check_active_irq_if_User_det_inv + invariant_over_ADT_if.do_user_op_if_det_inv + invariant_over_ADT_if.handle_preemption_if_det_inv + invariant_over_ADT_if.kernel_entry_if_Interrupt_det_inv + invariant_over_ADT_if.kernel_entry_if_det_inv + invariant_over_ADT_if.kernel_exit_if_det_inv + invariant_over_ADT_if.schedule_if_det_inv)+)[8] + apply (rule Sys1_pas_cur_domain) + apply (rule Sys1_pas_wellformed_noninterference) + apply (simp only: einvs_s0) + apply (simp add: Sys1_current_subject_idemp) + apply (simp add: only_timer_irq_inv_s0 silc_inv_s0 Sys1_pas_cur_domain + domain_sep_inv_s0 Sys1_pas_refined Sys1_guarded_pas_domain + idle_equiv_refl) + apply (clarsimp simp: valid_domain_list_2_def s0_internal_def exst0_def) + apply (intro conjI) + apply (clarsimp simp: valid_cur_hyp_def valid_cur_vcpu_def pred_tcb_at_def obj_at_def kh0_def + kh0_obj_def active_cur_vcpu_of_def arch_state0_def) + apply (clarsimp simp: cur_hyp_in_cur_domain_def cur_vcpu_in_cur_domain_def cur_vcpu_tcb_def arch_state0_def) + apply (clarsimp simp: cur_fpu_in_cur_domain_def arch_state0_def) + apply (simp add: det_inv_s0) + apply (simp add: s0_internal_def exst0_def) + apply (simp add: ct_in_state_def st_tcb_at_tcb_states_of_state_eq + identity_eq[symmetric] tcb_states_of_state_s0) + apply (simp add: s0_ptr_defs s0_internal_def) + apply (simp add: s0_internal_def exst0_def) + apply (rule utf_det) + apply (rule utf_non_empty) + apply (rule utf_non_interrupt) + apply (simp add: extras_s0[simplified s0_def]) + done + +text \the extra assumptions in valid_initial_state of being enabled, + and a serial system, follow from ADT_IF_Refine\ + +end + +end diff --git a/proof/infoflow/ADT_IF.thy b/proof/infoflow/ADT_IF.thy index 2de2da0253..fa6a2082d2 100644 --- a/proof/infoflow/ADT_IF.thy +++ b/proof/infoflow/ADT_IF.thy @@ -722,7 +722,7 @@ definition global_automaton_if :: (s_aux, Some e, s') \ do_user_opf \ e \ Interrupt} \ \ \User runs, no exception happens\ - {((s, InUserMode), (s', InUserMode) ) | s s_aux s'. (s, None, s_aux) \ get_active_irqf \ + {((s, InUserMode), (s', InUserMode)) | s s_aux s'. (s, None, s_aux) \ get_active_irqf \ (s_aux, None, s') \ do_user_opf} \ \ \Interrupt while in user mode\ {((s, InUserMode), (s', KernelEntry Interrupt)) | s s' i. (s, Some i, s') \ get_active_irqf} \ @@ -884,6 +884,82 @@ definition irq_state_next where locale ADT_IF_1 = + assumes dmo_getActiveIRQ_wp': + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)) + and domain_sep_inv False (st :: det_state) and valid_irq_states\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + and dmo_getActiveIRQ_wp: + "\\s :: det_state. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)\ + do_machine_op (getActiveIRQ False) + \P\" + and dmo_getActiveIRQ_valid_irq_states[wp]: + "do_machine_op (getActiveIRQ in_kernel) \\s :: det_state. valid_irq_states s\" + and deleted_irq_handler_valid_irq_states[wp]: + "deleted_irq_handler irq \\s :: det_state. valid_irq_states s\" + and arch_finalise_cap_valid_irq_states[wp]: + "arch_finalise_cap c x \\s :: det_state. valid_irq_states s\" + and arch_post_cap_deletion_valid_irq_states[wp]: + "arch_post_cap_deletion c \\s :: det_state. valid_irq_states s\" + and prepare_thread_delete_valid_irq_states[wp]: + "prepare_thread_delete ptr \\s :: det_state. valid_irq_states s\" + and cur_hyp_in_cur_domain_machine_state_update[simp]: + "\f. cur_hyp_in_cur_domain (machine_state_update f s) = cur_hyp_in_cur_domain s" + and cur_fpu_in_cur_domain_machine_state_update[simp]: + "\f. cur_fpu_in_cur_domain (machine_state_update f s) = cur_fpu_in_cur_domain s" + and thread_set_no_etcb_change_cur_fpu_in_cur_domain: + "(\P tcb. P (tcb_domain (f tcb)) = (P (tcb_domain tcb) :: bool)) \ thread_set f t' \cur_fpu_in_cur_domain\" + and thread_set_no_etcb_change_cur_hyp_in_cur_domain: + "(\P tcb. P (tcb_domain (f tcb)) = (P (tcb_domain tcb) :: bool)) \ thread_set f t' \cur_hyp_in_cur_domain\" + and thread_set_tcb_context_valid_cur_hyp[wp]: + "thread_set (tcb_arch_update (arch_tcb_context_set tc)) tcb \\s :: det_state. valid_cur_hyp s\" + and maybe_handle_interrupt_cur_hyp_in_cur_domain: + "maybe_handle_interrupt in_kernel \cur_hyp_in_cur_domain\" + and maybe_handle_interrupt_cur_fpu_in_cur_domain: + "maybe_handle_interrupt in_kernel \cur_fpu_in_cur_domain\" + and maybe_handle_interrupt_valid_cur_hyp: + "\valid_cur_hyp and invs\ maybe_handle_interrupt in_kernel \\_ s :: det_state. valid_cur_hyp s\" + and handle_event_cur_hyp_in_cur_domain[wp]: + "\cur_hyp_in_cur_domain and invs and ct_in_cur_domain and (\s. e \ Interrupt \ ct_active s) and (\s. scheduler_action s = resume_cur_thread)\ + handle_event e + \\_. cur_hyp_in_cur_domain\" + and handle_event_cur_fpu_in_cur_domain[wp]: + "\cur_fpu_in_cur_domain and einvs and (\s. e \ Interrupt \ ct_active s) and (\s. scheduler_action s = resume_cur_thread)\ + handle_event e + \\_. cur_fpu_in_cur_domain\" + and handle_event_valid_cur_hyp: + "\valid_cur_hyp and einvs and (\s. e \ Interrupt \ ct_active s) and (\s. scheduler_action s = resume_cur_thread)\ + handle_event e + \\_ s :: det_state. valid_cur_hyp s\" + and schedule_cur_hyp_in_cur_domain: + "\\s. cur_hyp_in_cur_domain s \ valid_sched s \ valid_objs s \ sym_refs (state_hyp_refs_of s)\ + schedule + \\_. cur_hyp_in_cur_domain\" + and schedule_cur_fpu_in_cur_domain: + "\\s. cur_fpu_in_cur_domain s \ valid_sched s \ valid_objs s \ sym_refs (state_hyp_refs_of s)\ + schedule + \\_. cur_fpu_in_cur_domain\" + and schedule_valid_cur_hyp: + "\valid_cur_hyp and valid_idle\ + schedule + \\_ s :: det_state. valid_cur_hyp s\" + and activate_thread_cur_hyp_in_cur_domain: + "activate_thread \cur_hyp_in_cur_domain\" + and activate_thread_cur_fpu_in_cur_domain: + "activate_thread \cur_fpu_in_cur_domain\" + and activate_thread_valid_cur_hyp: + "activate_thread \\s :: det_state. valid_cur_hyp s\" + and do_user_op_if_cur_hyp_in_cur_domain[wp]: + "do_user_op_if uop tc \cur_hyp_in_cur_domain\" + and do_user_op_if_cur_fpu_in_cur_domain[wp]: + "do_user_op_if uop tc \cur_fpu_in_cur_domain\" + and do_user_op_if_valid_cur_hyp[wp]: + "do_user_op_if uop tc \\s :: det_state. valid_cur_hyp s\" + + +locale ADT_IF_2 = ADT_IF_1 + fixes initial_aag :: "'a subject_label PAS" assumes do_user_op_if_invs[wp]: "do_user_op_if uop tc \invs and ct_running :: det_state \ bool\" @@ -913,18 +989,6 @@ locale ADT_IF_1 = "do_user_op_if uop tc \guarded_pas_domain aag\" and tcb_arch_ref_tcb_context_set[simp]: "tcb_arch_ref (tcb_arch_update (arch_tcb_context_set uc) tcb) = tcb_arch_ref tcb" - and arch_switch_to_idle_thread_pspace_aligned[wp]: - "arch_switch_to_idle_thread \\s :: det_ext state. pspace_aligned s\" - and arch_switch_to_idle_thread_valid_vspace_objs[wp]: - "arch_switch_to_idle_thread \\s :: det_ext state. valid_vspace_objs s\" - and arch_switch_to_idle_thread_valid_arch_state[wp]: - "arch_switch_to_idle_thread \\s :: det_ext state. valid_arch_state s\" - and arch_switch_to_thread_pspace_aligned[wp]: - "arch_switch_to_thread t \\s :: det_ext state. pspace_aligned s\" - and arch_switch_to_thread_valid_vspace_objs[wp]: - "arch_switch_to_thread t \\s :: det_ext state. valid_vspace_objs s\" - and arch_switch_to_thread_valid_arch_state[wp]: - "arch_switch_to_thread t \\s :: det_ext state. valid_arch_state s\" and arch_switch_to_thread_cur_thread[wp]: "\P. arch_switch_to_thread t \\s :: det_state. P (cur_thread s)\" and arch_activate_idle_thread_cur_thread[wp]: @@ -940,10 +1004,10 @@ locale ADT_IF_1 = and init_arch_objects_irq_state_of_state[wp]: "\P. init_arch_objects new_type dev ptr num_objects obj_sz refs \\s. P (irq_state_of_state s)\" and getActiveIRQ_None: - "(None, s') \ fst (do_machine_op (getActiveIRQ in_kernel) (s :: det_state)) + "(None, s') \ fst (do_machine_op (getActiveIRQ False) (s :: det_state)) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" and getActiveIRQ_Some: - "(Some irq, s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) + "(Some irq, s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some irq" and kernel_entry_if_idle_equiv: "\invs and (\s. e \ Interrupt \ ct_active s) and domain_sep_inv irqs st and idle_equiv st @@ -975,12 +1039,12 @@ locale ADT_IF_1 = and do_user_op_if_irq_measure_if: "\P. do_user_op_if uop tc \\s :: det_state. P (irq_measure_if s)\" and invoke_tcb_irq_state_inv: - "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) + "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) and valid_irq_states and tcb_inv_wf tinv and K (irq_is_recurring irq st)\ invoke_tcb tinv \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" and reset_untyped_cap_irq_state_inv: - "\irq_state_inv st and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False sta and valid_irq_states and K (irq_is_recurring irq st)\ reset_untyped_cap slot \\y. irq_state_inv st\, \\y. irq_state_next st\" and handle_vm_fault_irq_state_of_state[wp]: @@ -991,12 +1055,8 @@ locale ADT_IF_1 = "create_cap type bits untyped dev sl \\s. P (irq_state_of_state s)\" and arch_invoke_irq_control_irq_state_of_state[wp]: "arch_invoke_irq_control ici \\s. P (irq_state_of_state s)\" - and thread_set_pas_refined: - "\ \tcb. \(getF, v)\ran tcb_cap_cases. getF (f tcb) = getF tcb; - \tcb. tcb_state (f tcb) = tcb_state tcb; - \tcb. tcb_bound_notification (f tcb) = tcb_bound_notification tcb; - \tcb. tcb_domain (f tcb) = tcb_domain tcb \ - \ thread_set f t \pas_refined aag\" + and thread_set_context_pas_refined: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \pas_refined aag\" begin lemmas do_user_op_if_no_domain_caps[wp] = @@ -1012,7 +1072,7 @@ lemma kernel_entry_silc_inv[wp]: unfolding kernel_entry_if_def by (wpsimp simp: ran_tcb_cap_cases arch_tcb_update_aux2 wp: hoare_weak_lift_imp handle_event_silc_inv thread_set_silc_inv thread_set_invs_trivial - thread_set_not_state_valid_sched thread_set_pas_refined + thread_set_not_state_valid_sched thread_set_context_pas_refined | wp (once) hoare_vcg_imp_lift | force)+ lemma kernel_entry_pas_refined[wp]: @@ -1023,7 +1083,7 @@ lemma kernel_entry_pas_refined[wp]: \\_. pas_refined aag\" unfolding kernel_entry_if_def by (wpsimp simp: ran_tcb_cap_cases schact_is_rct_def arch_tcb_update_aux2 - wp: hoare_vcg_imp_lift' handle_event_pas_refined thread_set_pas_refined + wp: hoare_vcg_imp_lift' handle_event_pas_refined thread_set_context_pas_refined guarded_pas_domain_lift thread_set_invs_trivial thread_set_not_state_valid_sched)+ lemma kernel_entry_if_domain_sep_inv: @@ -1060,6 +1120,45 @@ lemma kernel_entry_if_valid_domain_list[wp]: unfolding kernel_entry_if_def by (wpsimp wp: thread_set_invs_trivial simp: ran_tcb_cap_cases arch_tcb_update_aux2) +lemma thread_set_tcb_context_ct_in_cur_domain[wp]: + "thread_set (\tcb. tcb\tcb_arch := arch_tcb_context_set tc (tcb_arch tcb)\) t \ct_in_cur_domain\" + by (wpsimp simp: thread_set_def set_object_def get_object_def) + +lemma thread_set_ct_active'[wp]: + "thread_set (\tcb. tcb\tcb_arch := arch_tcb_context_set tc (tcb_arch tcb)\) t \ct_active\" + by (simp add: arch_tcb_update_aux2 thread_set_tcb_context_update_ct_active) + +lemma kernel_entry_if_cur_fpu_in_cur_domain: + "\cur_fpu_in_cur_domain and einvs and (\s. e \ Interrupt \ ct_active s) + and (\s. scheduler_action s = resume_cur_thread)\ + kernel_entry_if e tc + \\_. cur_fpu_in_cur_domain\" + apply (simp add: kernel_entry_if_def) + apply (wpsimp wp: thread_set_not_state_valid_sched thread_set_no_etcb_change_cur_fpu_in_cur_domain + thread_set_invs_trivial ball_tcb_cap_casesI hoare_vcg_imp_lift') + done + +lemma kernel_entry_if_cur_hyp_in_cur_domain: + "\cur_hyp_in_cur_domain and einvs and (\s. e \ Interrupt \ ct_active s) + and (\s. scheduler_action s = resume_cur_thread)\ + kernel_entry_if e tc + \\_. cur_hyp_in_cur_domain\" + apply (simp add: kernel_entry_if_def) + apply (wpsimp wp: thread_set_no_etcb_change_cur_hyp_in_cur_domain thread_set_invs_trivial ball_tcb_cap_casesI + hoare_vcg_imp_lift') + apply (clarsimp simp: valid_sched_def) + done + +lemma kernel_entry_if_valid_cur_hyp: + "\valid_cur_hyp and einvs and (\s. e \ Interrupt \ ct_active s) + and (\s. scheduler_action s = resume_cur_thread)\ + kernel_entry_if e tc + \\_. valid_cur_hyp\" + apply (simp add: kernel_entry_if_def arch_tcb_update_aux2) + apply (wpsimp wp: handle_event_valid_cur_hyp thread_set_invs_trivial ball_tcb_cap_casesI + hoare_vcg_imp_lift' thread_set_not_state_valid_sched) + done + crunch schedule_if for pas_refined[wp]: "pas_refined aag" @@ -1094,7 +1193,12 @@ lemma handle_preemption_if_invs: by (wpsimp wp: handle_spurious_irq_invs) -context ADT_IF_1 begin +context ADT_IF_2 begin + +crunch handle_preemption_if + for cur_hyp_in_cur_domain: cur_hyp_in_cur_domain + and cur_fpu_in_cur_domain: cur_fpu_in_cur_domain + and valid_cur_hyp: "\s :: det_state. valid_cur_hyp s" lemma handle_kernel_interrupt_domain_sep_inv: "\domain_sep_inv irqs st and K (irq \ non_kernel_IRQs)\ @@ -1125,7 +1229,7 @@ lemma handle_kernel_interrupt_pas_refined: apply (rule conjI; rule impI;rule hoare_pre) apply ((wp send_signal_pas_refined get_cap_wp handle_reserved_irq_non_kernel_IRQs | wpc - | simp add: get_irq_slot_def get_irq_state_def )+) + | simp add: get_irq_slot_def get_irq_state_def)+) done lemma handle_preemption_if_pas_refined[wp]: @@ -1146,9 +1250,11 @@ end lemma handle_preemption_if_silc_inv[wp]: - "handle_preemption_if tc \silc_inv aag st\" + "\silc_inv aag st and domain_sep_inv False st\ + handle_preemption_if tc + \\_. silc_inv aag st\" unfolding handle_preemption_if_def maybe_handle_interrupt_def - by (wpsimp wp: handle_interrupt_silc_inv do_machine_op_silc_inv) + by (wpsimp wp: handle_interrupt_silc_inv' do_machine_op_silc_inv hoare_drop_imps) crunch handle_preemption_if for cur_domain[wp]: "\s::det_state. P (cur_domain s)" @@ -1251,7 +1357,7 @@ lemma set_thread_state_scheduler_action: done -context ADT_IF_1 begin +context ADT_IF_2 begin lemma schedule_guarded_pas_domain: "\guarded_pas_domain aag and einvs and pas_refined aag\ @@ -1315,10 +1421,11 @@ crunch schedule_if and valid_list[wp]: valid_list lemma schedule_if_irq_masks: - "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ schedule_if tc \\_ s. P (irq_masks_of_state s)\" - by (simp add: schedule_if_def | wp)+ + unfolding schedule_if_def + by (wpsimp wp: schedule_irq_masks[where st=st]) definition kernel_schedule_if :: @@ -1405,16 +1512,16 @@ definition ADT_A_if :: kernel_handle_preemption_if kernel_schedule_if kernel_exit_A_if \ {(s,s'). step_restrict s'})\" + +context ADT_IF_2 begin + lemma check_active_irq_if_wp: - "\\s. P ((irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))),tc) + "\\s :: det_state. P ((irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))),tc) (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)\ check_active_irq_if tc \P\" by (wpsimp wp: dmo_getActiveIRQ_wp simp: check_active_irq_if_def) - -context ADT_IF_1 begin - lemma handle_preemption_if_only_timer_irq_inv[wp]: "handle_preemption_if tc \only_timer_irq_inv irq st\" by (wp only_timer_irq_inv_pres handle_preemption_if_irq_masks handle_preemption_if_domain_sep_inv @@ -1424,9 +1531,12 @@ end lemma schedule_if_only_timer_irq_inv[wp]: - "schedule_if tc \only_timer_irq_inv irq st\" - by (wp only_timer_irq_inv_pres schedule_if_irq_masks | blast)+ - + "\only_timer_irq_inv irq st and domain_sep_inv False st and valid_irq_states\ + schedule_if tc + \\_. only_timer_irq_inv irq st\" + by (wpsimp wp: only_timer_irq_inv_pres[where P="domain_sep_inv False st and valid_irq_states"] + schedule_if_irq_masks + | simp)+ subsection \Big step IF automaton\ @@ -1550,7 +1660,8 @@ locale valid_initial_state_noenabled = invariant_over_ADT_if + (* FIXME: arch-sp pas_refined (current_aag s) s \ guarded_pas_domain (current_aag s) s \ idle_equiv s0_internal s \ - valid_domain_list s \ valid_vspace_objs_if s" + valid_domain_list s \ valid_vspace_objs_if s \ valid_cur_hyp s \ + cur_hyp_in_cur_domain s \ cur_fpu_in_cur_domain s" assumes Invs_s0_internal: "Invs s0_internal" assumes det_inv_s0: "det_inv KernelExit (cur_context s0_internal) s0_internal" assumes scheduler_action_s0_internal: "scheduler_action s0_internal = resume_cur_thread" @@ -1679,7 +1790,7 @@ lemma kernel_entry_if_noIRQ_domain_time_sep_inv: \\_ s. P (domain_time s)\" by (wpsimp wp: kernel_entry_if_noIRQ_domain_time_inv simp: no_domain_caps_strg) -context ADT_IF_1 begin +context ADT_IF_2 begin lemma kernel_entry_if_domain_time_sched_action: "\\s. domain_time s > 0\ @@ -2033,9 +2144,14 @@ lemma handle_preemption_if_valid_sched[wp]: locale ADT_valid_initial_state = - ADT_IF_1 initial_aag + valid_initial_state _ _ _ initial_aag for initial_aag + ADT_IF_2 initial_aag + valid_initial_state _ _ _ initial_aag for initial_aag begin +crunch schedule_if + for cur_hyp_in_cur_domain[wp]: "cur_hyp_in_cur_domain" + and cur_fpu_in_cur_domain[wp]: "cur_fpu_in_cur_domain" + and valid_cur_hyp[wp]: "\s :: det_state. valid_cur_hyp s" + lemma invs_if_Step_ADT_A_if: notes active_from_running[simp] shows "\ invs_if s; (s,t) \ Step (ADT_A_if utf) e \ \ invs_if t" @@ -2057,6 +2173,9 @@ lemma invs_if_Step_ADT_A_if: kernel_entry_if_idle_equiv kernel_entry_if_domain_time_sched_action kernel_entry_if_noIRQ_domain_time_sep_inv + kernel_entry_if_cur_hyp_in_cur_domain + kernel_entry_if_cur_fpu_in_cur_domain + kernel_entry_if_valid_cur_hyp hoare_false_imp ct_idle_lift | clarsimp intro!: guarded_pas_is_subject_current_aag[rule_format] | intro conjI)+ @@ -2087,6 +2206,9 @@ lemma invs_if_Step_ADT_A_if: kernel_entry_if_domain_sep_inv kernel_entry_if_guarded_pas_domain kernel_entry_if_domain_time_sched_action kernel_entry_if_noIRQ_domain_time_sep_inv + kernel_entry_if_cur_hyp_in_cur_domain + kernel_entry_if_cur_fpu_in_cur_domain + kernel_entry_if_valid_cur_hyp ct_idle_lift | clarsimp intro: guarded_pas_is_subject_current_aag)+ apply (rule conjI, fastforce intro!: active_from_running) @@ -2108,12 +2230,16 @@ lemma invs_if_Step_ADT_A_if: rule hoare_drop_imps) apply (wp handle_preemption_if_invs handle_preemption_if_domain_sep_inv handle_preemption_if_domain_time_sched_action - handle_preemption_if_det_inv ct_idle_lift) - apply fastforce + handle_preemption_if_det_inv ct_idle_lift + handle_preemption_if_cur_hyp_in_cur_domain + handle_preemption_if_cur_fpu_in_cur_domain + handle_preemption_if_valid_cur_hyp) + apply clarsimp apply (simp add: kernel_schedule_if_def | elim exE conjE)+ apply (erule use_valid) apply ((wp schedule_if_ct_running_or_ct_idle schedule_if_domain_time_nonzero' schedule_if_domain_time_nonzero schedule_if_det_inv hoare_false_imp + schedule_if_cur_hyp_in_cur_domain schedule_if_cur_fpu_in_cur_domain schedule_if_valid_cur_hyp | fastforce simp: invs_valid_idle)+)[2] apply (simp add: kernel_exit_A_if_def | elim exE conjE)+ apply (frule state_unchanged[OF kernel_exit_if_inv]) @@ -2133,7 +2259,7 @@ lemma invs_if_Step_ADT_A_if: apply simp apply (erule use_valid, erule use_valid[OF _ check_active_irq_if_wp]) apply (rule_tac Q'="\a. (invs and ct_running) and - (\b. valid_vspace_objs_if b \ valid_list b \ valid_sched b \ + (\b. valid_vspace_objs_if b \ valid_list b \ valid_sched b \ valid_cur_hyp b \ only_timer_irq_inv timer_irq s0_internal b \ silc_inv initial_aag s0_internal b \ pas_refined initial_aag b \ @@ -2141,7 +2267,8 @@ lemma invs_if_Step_ADT_A_if: idle_equiv s0_internal b \ domain_sep_inv False s0_internal b \ valid_domain_list b \ 0 < domain_time b \ - scheduler_action b = resume_cur_thread)" in hoare_strengthen_post) + scheduler_action b = resume_cur_thread \ + cur_hyp_in_cur_domain b \ cur_fpu_in_cur_domain b)" in hoare_strengthen_post) apply ((wp do_user_op_if_invs ct_idle_lift | simp add: ct_active_not_idle' | clarsimp)+)[2] apply (erule use_valid[OF _ check_active_irq_if_wp]) apply (simp add: ct_in_state_def) @@ -2155,7 +2282,7 @@ lemma invs_if_Step_ADT_A_if: apply simp apply (erule use_valid, erule use_valid[OF _ check_active_irq_if_wp]) apply (rule_tac Q'="\a. (invs and ct_running) and - (\b. valid_vspace_objs_if b \ valid_list b \ valid_sched b \ + (\b. valid_vspace_objs_if b \ valid_list b \ valid_sched b \ valid_cur_hyp b \ only_timer_irq_inv timer_irq s0_internal b \ silc_inv initial_aag s0_internal b \ pas_refined initial_aag b \ @@ -2163,7 +2290,8 @@ lemma invs_if_Step_ADT_A_if: idle_equiv s0_internal b \ domain_sep_inv False s0_internal b \ valid_domain_list b \ 0 < domain_time b \ - scheduler_action b = resume_cur_thread)" in hoare_strengthen_post) + scheduler_action b = resume_cur_thread \ + cur_hyp_in_cur_domain b \ cur_fpu_in_cur_domain b)" in hoare_strengthen_post) apply ((wp do_user_op_if_invs | simp | clarsimp simp: ct_active_not_idle')+)[2] apply (erule use_valid[OF _ check_active_irq_if_wp]) apply (simp add: ct_in_state_def) @@ -2323,7 +2451,7 @@ lemma next_irq_state_Suc': lemma is_irq_at_next_irq_state_dom': "is_irq_at s irq pos \ next_irq_state_dom (pos,irq_masks (machine_state s))" apply (rule next_irq_state.domintros) - apply (fastforce simp: is_irq_at_def ) + apply (fastforce simp: is_irq_at_def) done lemma is_irq_at_next_irq_state_dom: @@ -2476,23 +2604,6 @@ lemma OR_choiceE_wp: apply (fastforce split: prod.splits) done -lemma preemption_point_irq_state_inv'[wp]: - "\irq_state_inv st and K (irq_is_recurring irq st)\ - preemption_point - \\_. irq_state_inv st\, \\_. irq_state_next st\" - apply (simp add: preemption_point_def) - apply (wpsimp wp: OR_choiceE_wp[where P'="irq_state_inv st and K(irq_is_recurring irq st)" - and P''="irq_state_inv st and K(irq_is_recurring irq st)"] - simp: reset_work_units_def)+ - apply simp - apply (wpsimp wp: OR_choiceE_wp dmo_getActiveIRQ_wp simp: reset_work_units_def)+ - apply (clarsimp simp: irq_state_inv_def) - apply (simp add: next_irq_state_Suc[OF _ recurring_next_irq_state_dom]) - apply (clarsimp simp: irq_state_next_def) - apply (simp add: next_irq_state_Suc'[OF _ recurring_next_irq_state_dom]) - apply (wp | simp add: update_work_units_def irq_state_inv_def | fastforce)+ - done - lemma validE_validE_E': "\P\ f \Q\, \E\ \ \P\ f -, \E\" apply (rule validE_validE_E) @@ -2501,9 +2612,6 @@ lemma validE_validE_E': apply simp+ done -lemmas preemption_point_irq_state_inv[wp] = validE_validE_R'[OF preemption_point_irq_state_inv'] -lemmas preemption_point_irq_state_next[wp] = validE_validE_E'[OF preemption_point_irq_state_inv'] - lemma hoare_add_postE: "\ \S\ f \\_. S'\; \P\ f \\r s. S' s \ Q r s\, \\r s. S' s \ E r s\ \ \ \P and S\ f \Q\,\E\" @@ -2516,14 +2624,47 @@ lemma hoare_add_postE: apply (assumption, simp, fastforce split: sum.splits) done + +context ADT_IF_1 begin + +lemma preemption_point_valid_irq_states[wp]: + "preemption_point \\s :: det_state. valid_irq_states s\" + unfolding preemption_point_def + by (wp OR_choiceE_wp[where P'=valid_irq_states and P''=valid_irq_states] hoare_drop_imps + | wpc | simp)+ + +crunch cap_delete + for valid_irq_states[wp]: "\s :: det_state. valid_irq_states s" + (wp: crunch_wps mapM_x_wp hoare_drop_imps simp: crunch_simps) + +lemma preemption_point_irq_state_inv'[wp]: + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ + preemption_point + \\_. irq_state_inv st\, \\_. irq_state_next st\" + (is "validE ?P _ _ _") + apply (simp add: preemption_point_def) + apply (wpsimp wp: OR_choiceE_wp[where P'="?P" and P''="?P"] + simp: reset_work_units_def)+ + apply simp + apply (wpsimp wp: OR_choiceE_wp dmo_getActiveIRQ_wp'[where st=sta] simp: reset_work_units_def)+ + apply (clarsimp simp: irq_state_inv_def) + apply (simp add: next_irq_state_Suc[OF _ recurring_next_irq_state_dom]) + apply (clarsimp simp: irq_state_next_def) + apply (simp add: next_irq_state_Suc'[OF _ recurring_next_irq_state_dom]) + apply (wp | simp add: update_work_units_def irq_state_inv_def | fastforce)+ + done + +lemmas preemption_point_irq_state_inv[wp] = validE_validE_R'[OF preemption_point_irq_state_inv'] +lemmas preemption_point_irq_state_next[wp] = validE_validE_E'[OF preemption_point_irq_state_inv'] + lemma rec_del_irq_state_inv': notes drop_spec_valid[wp_split del] drop_spec_validE[wp_split del] rec_del.simps[simp del] shows - "s \ \irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "s \ \irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ rec_del call \\a s. (case call of FinaliseSlotCall x y \ y \ fst a \ snd a = NullCap | _ \ True) \ - domain_sep_inv False sta s \ irq_state_inv st s\, \\_. irq_state_next st\" + domain_sep_inv False sta s \ valid_irq_states s \ irq_state_inv st s\, \\_. irq_state_next st\" proof (induct s arbitrary: rule: rec_del.induct, simp_all only: rec_del_fails hoare_fail_any) case (1 slot exposed s) show ?case apply (simp add: split_def rec_del.simps) @@ -2548,12 +2689,13 @@ next (wp preemption_point_irq_state_inv[where irq=irq] | simp)+)[1] apply (rule spec_strengthen_postE) apply (rule "2.hyps"[simplified], fastforce+) - apply (wp finalise_cap_domain_sep_inv_cap get_cap_wp + apply (wp finalise_cap_domain_sep_inv_cap get_cap_wp finalise_cap_returns_NullCap[where irqs=False, simplified] drop_spec_validE[OF liftE_wp] set_cap_domain_sep_inv | simp add: without_preemption_def split del: if_split | wp (once) hoare_drop_imps - | wp irq_state_inv_triv)+ + | wp irq_state_inv_triv + | fastforce)+ apply (blast dest: cte_wp_at_domain_sep_inv_cap) done next @@ -2576,7 +2718,7 @@ next qed lemma rec_del_irq_state_inv: - "\irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ rec_del call \\_. irq_state_inv st\, \\_. irq_state_next st\" apply (rule hoare_strengthen_postE) @@ -2586,7 +2728,7 @@ lemma rec_del_irq_state_inv: done lemma cap_delete_irq_state_inv': - "\irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ cap_delete slot \\_. irq_state_inv st\, \\_. irq_state_next st\" by (wpsimp wp: rec_del_irq_state_inv simp: cap_delete_def) auto @@ -2597,7 +2739,7 @@ lemmas cap_delete_irq_state_next[wp] = validE_validE_E'[OF cap_delete_irq_state_ lemma cap_revoke_irq_state_inv'': notes drop_spec_valid[wp_split del] drop_spec_validE[wp_split del] shows - "s \ \irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "s \ \irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ cap_revoke slot \\_. irq_state_inv st\, \\_. irq_state_next st\" proof(induct rule: cap_revoke.induct[where ?a1.0=s]) @@ -2624,13 +2766,13 @@ lemmas cap_revoke_irq_state_inv[wp] = validE_validE_R'[OF cap_revoke_irq_state_i lemmas cap_revoke_irq_state_next[wp] = validE_validE_E'[OF cap_revoke_irq_state_inv'] lemma finalise_slot_irq_state_inv: - "\irq_state_inv st and domain_sep_inv False sta and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ finalise_slot p e \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" by (wpsimp wp: rec_del_irq_state_inv[folded validE_R_def] simp: finalise_slot_def) blast lemma invoke_cnode_irq_state_inv: - "\irq_state_inv st and domain_sep_inv False sta + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and valid_cnode_inv cnode_invocation and K (irq_is_recurring irq st)\ invoke_cnode cnode_invocation \\_. irq_state_inv st\, \\_. irq_state_next st\" @@ -2646,6 +2788,9 @@ lemma invoke_cnode_irq_state_inv: apply fastforce done +end + + lemma checked_insert_irq_state_of_state[wp]: "check_cap_at a b (check_cap_at c d (cap_insert e f g)) \\s. P (irq_state_of_state s)\" by (wp | simp add: check_cap_at_def)+ @@ -2695,7 +2840,7 @@ lemma irq_state_inv_trivE': done -context ADT_IF_1 begin +context ADT_IF_2 begin crunch invoke_irq_control for irq_state_of_state[wp]: "\s. P (irq_state_of_state s)" @@ -2705,17 +2850,18 @@ lemma invoke_irq_control_noErr[wp]: by (cases a; wpsimp simp: arch_invoke_irq_control_noErr) lemma invoke_untyped_irq_state_inv: - "\irq_state_inv st and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) + and valid_irq_states and K (irq_is_recurring irq st)\ invoke_untyped ui \\_. irq_state_inv st\, \\_. irq_state_next st\" apply (cases ui, simp add: invoke_untyped_def mapM_x_def[symmetric]) apply (rule hoare_pre) apply (wp mapM_x_wp' whenE_wp reset_untyped_cap_irq_state_inv[where irq=irq] - | rule irq_state_inv_triv | simp)+ + | rule irq_state_inv_triv | fastforce)+ done lemma perform_invocation_irq_state_inv: - "\irq_state_inv st and domain_sep_inv False (sta :: det_state) + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and valid_invocation op and K (irq_is_recurring irq st) and (\s. \i. op = InvokeIRQHandler i \ (\p. cte_wp_at ((=) (IRQHandlerCap (irq_of_handler_inv i))) p s))\ @@ -2725,14 +2871,16 @@ lemma perform_invocation_irq_state_inv: (solves \(wp invoke_untyped_irq_state_inv[where irq=irq] irq_state_inv_triv invoke_tcb_irq_state_inv invoke_cnode_irq_state_inv[simplified validE_R_def] | clarsimp | simp add: invoke_domain_def)+\)?) + apply wp + apply (wpsimp wp: irq_state_inv_triv' invoke_irq_control_irq_masks) + apply assumption + apply auto[1] apply wp - apply (wpsimp wp: irq_state_inv_triv' invoke_irq_control_irq_masks) + apply (wp irq_state_inv_triv' invoke_irq_handler_irq_masks | clarsimp)+ apply assumption apply auto[1] - apply wp - apply (wp irq_state_inv_triv' invoke_irq_handler_irq_masks | clarsimp)+ - apply assumption - apply auto[1] + apply (wp irq_state_inv_triv' arch_perform_invocation_irq_masks) + apply fastforce done lemma hoare_drop_impE: @@ -2781,12 +2929,16 @@ lemma handle_event_irq_state_inv: end +lemma schedule_if_irq_state_of_state[wp]: + "schedule_if tc \\s. P (irq_state_of_state s)\" + by (wpsimp simp: schedule_if_def activate_thread_def wp: hoare_drop_imps) + lemma schedule_if_irq_state_inv: - "schedule_if tc \irq_state_inv st\" - by (wp irq_state_inv_triv - | simp add: schedule_if_def activate_thread_def - | wpc - | wp (once) hoare_drop_imps)+ + "\irq_state_inv st and domain_sep_inv False st and valid_irq_states\ + schedule_if tc + \\_. irq_state_inv st\" + unfolding irq_state_inv_def + by (wpsimp wp: schedule_if_irq_masks[where st=st] | wps)+ lemma irq_measure_if_inv: assumes irq_state: @@ -2835,7 +2987,7 @@ abbreviation next_irq_state_of_state where "next_irq_state_of_state s \ next_irq_state (Suc (irq_state_of_state s)) (irq_masks_of_state s)" -context ADT_IF_1 begin +context ADT_IF_2 begin lemma kernel_entry_if_next_irq_state_of_state: "\ event \ Interrupt; invs i_s; domain_sep_inv False (st :: det_state) i_s; @@ -2853,7 +3005,7 @@ lemma kernel_entry_if_next_irq_state_of_state: thread_set_invs_trivial irq_is_recurring_triv simp: ran_tcb_cap_cases)+ apply (erule use_valid) - apply (wp | simp )+ + apply (wp | simp)+ apply (simp add: irq_state_inv_def) done @@ -2874,7 +3026,7 @@ lemma kernel_entry_if_next_irq_state_of_state_next: thread_set_invs_trivial irq_is_recurring_triv simp: ran_tcb_cap_cases)+ apply (erule use_valid) - apply (wp | simp )+ + apply (wp | simp)+ apply (simp add: irq_state_inv_def) done @@ -2900,18 +3052,20 @@ end lemma schedule_if_irq_measure_if: - "(r, b) \ fst (schedule_if uc i_s) \ irq_measure_if b \ irq_measure_if i_s" + "\ (r, b) \ fst (schedule_if uc i_s); domain_sep_inv False st i_s; valid_irq_states i_s \ + \ irq_measure_if b \ irq_measure_if i_s" apply (fold irq_measure_if_inv_def) apply (erule use_valid[OF _ irq_measure_if_inv'] | wp schedule_if_irq_state_inv | simp)+ - apply (simp add: irq_measure_if_inv_def) + apply (simp add: irq_measure_if_inv_def domain_sep_inv_refl) done lemma schedule_if_next_irq_state_of_state: - "(r, b) \ fst (schedule_if uc i_s) \ next_irq_state_of_state b = next_irq_state_of_state i_s" + "\ (r, b) \ fst (schedule_if uc i_s); domain_sep_inv False st i_s; valid_irq_states i_s \ + \ next_irq_state_of_state b = next_irq_state_of_state i_s" apply (erule use_valid) apply (rule_tac Q'="\_. irq_state_inv i_s" in hoare_strengthen_post) apply (wp schedule_if_irq_state_inv) - apply (auto simp: irq_state_inv_def) + apply (auto simp: irq_state_inv_def domain_sep_inv_refl) done lemma next_irq_state_of_state_triv: @@ -3045,11 +3199,11 @@ lemma ADT_A_if_Step_measure_if': apply (clarsimp split: if_splits) apply (rule Suc_le_lessD) apply (simp add: kernel_schedule_if_def) - apply (blast intro: schedule_if_irq_measure_if) + apply (blast intro: schedule_if_irq_measure_if invs_valid_irq_states) apply (simp add: kernel_schedule_if_def) - apply (blast intro: schedule_if_next_irq_state_of_state) + apply (blast intro: schedule_if_next_irq_state_of_state invs_valid_irq_states) apply (simp add: kernel_schedule_if_def) - apply (blast intro: schedule_if_next_irq_state_of_state) + apply (blast intro: schedule_if_next_irq_state_of_state invs_valid_irq_states) apply (clarsimp simp: kernel_exit_A_if_def split: if_splits) apply (clarsimp simp: kernel_exit_A_if_def) apply ((erule use_valid, wp | simp)+)[1] @@ -3139,7 +3293,7 @@ lemma ADT_A_if_Step_measure_if'': apply (clarsimp split: if_splits) apply (rule Suc_le_lessD) apply (simp add: kernel_schedule_if_def) - apply (blast intro: schedule_if_irq_measure_if) + apply (blast intro: schedule_if_irq_measure_if invs_valid_irq_states) apply (clarsimp simp: kernel_exit_A_if_def split: if_splits) apply (clarsimp simp: kernel_exit_A_if_def) apply ((erule use_valid, wp | simp)+)[1] @@ -3184,7 +3338,7 @@ lemma ADT_A_if_Step_irq_masks: apply (erule use_valid[OF _ handle_preemption_if_irq_masks]) apply fastforce apply (erule use_valid[OF _ schedule_if_irq_masks]) - apply fastforce + apply (blast intro: invs_valid_irq_states) apply (erule use_valid[OF _ kernel_exit_irq_masks]) apply simp done diff --git a/proof/infoflow/ARM/ArchADT_IF.thy b/proof/infoflow/ARM/ArchADT_IF.thy index 59e5f2dd7b..d1b3f5b433 100644 --- a/proof/infoflow/ARM/ArchADT_IF.thy +++ b/proof/infoflow/ARM/ArchADT_IF.thy @@ -15,10 +15,78 @@ theory ArchADT_IF imports ADT_IF begin -context Arch begin global_naming ARM +context Arch begin arch_global_naming named_theorems ADT_IF_assms +lemma dmo_getActiveIRQ_wp'[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)) + and domain_sep_inv False st and valid_irq_states\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma dmo_getActiveIRQ_wp[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\))\ + do_machine_op (getActiveIRQ False) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma deleted_irq_handler_valid_irq_states[ADT_IF_assms,wp]: + "deleted_irq_handler irq \valid_irq_states\" + unfolding deleted_irq_handler_def set_irq_state_def valid_irq_states_def valid_irq_masks_def maskInterrupt_def + by (wpsimp wp: dmo_wp) + +lemma dmo_valid_irq_states[wp]: + "(\P. f \\s. P (irq_masks s)\) \ do_machine_op f \valid_irq_states\" + unfolding valid_irq_states_def do_machine_op_def + by (wpsimp, erule use_valid; assumption) + +lemma dmo_getActiveIRQ_valid_irq_states[ADT_IF_assms,wp]: + "do_machine_op (getActiveIRQ in_kernel) \valid_irq_states\" + unfolding getActiveIRQ_def by wpsimp + +lemmas [wp] = invalidateLocalTLB_ASID_irq_masks cleanCaches_PoU_irq_masks + setHardwareASID_irq_masks set_current_pd_irq_masks + +crunch prepare_thread_delete, arch_finalise_cap, arch_post_cap_deletion + for valid_irq_states[ADT_IF_assms,wp]: "\s :: det_state. valid_irq_states s" + (wp: crunch_wps mapM_x_wp hoare_drop_imps simp: crunch_simps) + +lemmas [ADT_IF_assms] = + cur_hyp_in_cur_domain_taut + cur_fpu_in_cur_domain_taut + cur_hyp_in_cur_domain_wp + cur_fpu_in_cur_domain_wp + valid_cur_hyp_triv + +end + + +global_interpretation ADT_IF_1?: ADT_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_assms | solves \wp only: ADT_IF_assms; simp\)?) +qed + + +context Arch begin arch_global_naming + lemma dmo_getExMonitor_wp[wp]: "\\s. P (exclusive_state (machine_state s)) s\ do_machine_op getExMonitor @@ -123,12 +191,6 @@ lemma tcb_arch_ref_tcb_context_set[ADT_IF_assms, simp]: "tcb_arch_ref (tcb_arch_update (arch_tcb_context_set tc) tcb) = tcb_arch_ref tcb" by (simp add: tcb_arch_ref_def) -crunch arch_switch_to_idle_thread, arch_switch_to_thread - for pspace_aligned[ADT_IF_assms, wp]: "\s :: det_state. pspace_aligned s" - and valid_vspace_objs[ADT_IF_assms, wp]: "\s :: det_state. valid_vspace_objs s" - and valid_arch_state[ADT_IF_assms, wp]: "\s :: det_state. valid_arch_state s" - (wp: crunch_wps) - crunch arch_activate_idle_thread, arch_switch_to_thread for cur_thread[ADT_IF_assms, wp]: "\s. P (cur_thread s)" @@ -157,14 +219,14 @@ crunch init_arch_objects (wp: crunch_wps dmo_wp ignore: do_machine_op) lemma getActiveIRQ_None[ADT_IF_assms]: - "(None,s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) \ + "(None,s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) by simp lemma getActiveIRQ_Some[ADT_IF_assms]: - "(Some i, s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) + "(Some i, s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some i" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) @@ -305,11 +367,18 @@ lemma do_user_op_if_irq_measure_if[ADT_IF_assms]: | wps |wp dmo_wp | wpc)+ done -crunch set_flags +crunch set_flags, arch_post_set_flags for irq_states_of_state[wp]: "\s. P (irq_state_of_state s)" +lemma checked_cap_insert_valid_irq_states[wp]: + "check_cap_at a b (check_cap_at c d (cap_insert a b e)) \valid_irq_states\" + by (wpsimp simp: check_cap_at_def)+ + +crunch set_mcpriority + for valid_irq_states[wp]: valid_irq_states + lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: - "\(\s. irq_state_inv st s) and domain_sep_inv False sta + "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) and valid_irq_states and tcb_inv_wf tinv and K (irq_is_recurring irq st)\ invoke_tcb tinv \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" @@ -320,10 +389,10 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: | clarsimp | wp (once) irq_state_inv_triv)+)[3] defer - apply ((wp irq_state_inv_triv | simp)+)[2] - (* just ThreadControl left *) - apply (simp add: split_def cong: option.case_cong) - by (wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R + apply ((wp irq_state_inv_triv | simp)+)[2] + apply (simp add: split_def cong: option.case_cong) + by (clarsimp split del: if_split cong: conj_cong + | wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R checked_cap_insert_domain_sep_inv cap_delete_deletes cap_delete_irq_state_inv[where st=st and sta=sta and irq=irq] cap_delete_irq_state_next[where st=st and sta=sta and irq=irq] @@ -335,19 +404,33 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: | wp (once) irq_state_inv_triv hoare_drop_imps | clarsimp split: option.splits | intro impI conjI allI)+ +crunch freeMemory + for irq_masks[wp]: "\s. P (irq_masks s)" + (wp: mapM_x_wp) + +lemma valid_irq_states_kheap_update[simp]: + "valid_irq_states (kheap_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +crunch delete_objects + for valid_irq_states[wp]: valid_irq_states + (wp: dmo_machine_state_lift simp: crunch_simps detype_def) + lemma reset_untyped_cap_irq_state_inv[ADT_IF_assms]: - "\irq_state_inv st and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ reset_untyped_cap slot \\y. irq_state_inv st\, \\y. irq_state_next st\" apply (cases "irq_is_recurring irq st", simp_all) apply (simp add: reset_untyped_cap_def) apply (rule hoare_pre) - apply (wp no_irq_clearMemory mapME_x_wp' hoare_vcg_const_imp_lift - get_cap_wp preemption_point_irq_state_inv'[where irq=irq] - | rule irq_state_inv_triv - | simp add: unless_def - | wp (once) dmo_wp)+ - done + by (wp no_irq_clearMemory hoare_vcg_const_imp_lift set_cap_domain_sep_inv + hoare_post_addE[where Q'="domain_sep_inv False sta and valid_irq_states", OF mapME_x_wp'] + get_cap_wp preemption_point_irq_state_inv'[where irq=irq] + | rule hoare_vcg_conj_lift + | rule irq_state_inv_triv + | simp add: unless_def + | wp (once) dmo_wp + | fastforce)+ crunch handle_vm_fault, handle_hypervisor_fault @@ -381,10 +464,31 @@ lemma thread_set_pas_refined[ADT_IF_assms]: | wps thread_set_caps_of_state_trivial[OF cps] thread_set_thread_st_auth_trivT[OF st] thread_set_thread_bound_ntfns_trivT[OF ntfn])+ + +lemma thread_set_context_state_hyp_refs_of: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \\s. P (state_hyp_refs_of s)\" + by (wpsimp simp: thread_set_def wp: set_object_wp ) + +lemma thread_set_context_pas_refined[ADT_IF_assms]: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \pas_refined aag\" + unfolding pas_refined_def state_objs_to_policy_def + apply (rule hoare_weaken_pre) + apply (wpsimp wp: tcb_domain_map_wellformed_lift_strong thread_set_edomains) + apply (wps thread_set_state_vrefs thread_set_context_state_hyp_refs_of) + apply (rule hoare_lift_Pf2[where f="caps_of_state"]) + apply (rule hoare_lift_Pf2[where f="thread_st_auth"]) + apply (rule hoare_lift_Pf2[where f="thread_bound_ntfns"]) + apply wp + apply (wpsimp wp: thread_set_thread_bound_ntfns_trivT ) + apply (wpsimp wp: thread_set_thread_st_auth_trivT) + apply (wpsimp wp: thread_set_caps_of_state_trivial simp: ran_tcb_cap_cases) + apply simp + done + end -global_interpretation ADT_IF_1?: ADT_IF_1 +global_interpretation ADT_IF_2?: ADT_IF_2 proof goal_cases interpret Arch . case 1 show ?case @@ -393,7 +497,7 @@ qed sublocale valid_initial_state \ valid_initial_state?: ADT_valid_initial_state .. -hide_fact ADT_IF_1.do_user_op_silc_inv +hide_fact ADT_IF_2.do_user_op_silc_inv requalify_facts ARM.do_user_op_silc_inv declare do_user_op_silc_inv[wp] diff --git a/proof/infoflow/ARM/ArchArch_IF.thy b/proof/infoflow/ARM/ArchArch_IF.thy index 39e2151856..de89079c6b 100644 --- a/proof/infoflow/ARM/ArchArch_IF.thy +++ b/proof/infoflow/ARM/ArchArch_IF.thy @@ -110,11 +110,10 @@ lemma store_word_offs_reads_respects[Arch_IF_assms]: apply (simp add: storeWord_def) apply (simp add: do_machine_op_bind) apply wp - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def in_monad) apply (fastforce intro: equiv_forI elim: equiv_forE) - apply (rule use_spec_ev do_machine_op_spec_reads_respects assert_ev2 + apply (rule do_machine_op_reads_respects assert_ev2 | simp add: spec_equiv_valid_def | wp modify_wp)+ done @@ -143,24 +142,13 @@ lemma set_thread_state_globals_equiv[Arch_IF_assms]: split: option.splits kernel_object.splits)+ done -lemma set_cap_globals_equiv''[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state\ - set_cap cap p - \\_. globals_equiv s\" - unfolding set_cap_def - apply (simp only: split_def) - apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def)+ - done - -lemma as_user_globals_equiv[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ - as_user tptr f - \\_. globals_equiv s\" - unfolding as_user_def - apply (wpsimp wp: set_object_globals_equiv simp: split_def) - apply (clarsimp simp: valid_arch_state_def get_tcb_def obj_at_def) - done +lemma thread_set_non_idle_globals_equiv[Arch_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv st\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + by (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def) declare arch_prepare_set_domain_inv[Arch_IF_assms] declare arch_prepare_next_domain_inv[Arch_IF_assms] @@ -185,7 +173,7 @@ global_interpretation Arch_IF_1?: Arch_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Arch_IF_assms)?) + by (unfold_locales; (fact Arch_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -773,11 +761,11 @@ lemma perform_page_invocation_reads_respects: apply (simp add: mapM_discarded swp_def) apply (wp dmo_mol_reads_respects dmo_cacheRangeOp_reads_respects mapM_x_ev'' store_pte_reads_respects set_cap_reads_respects mapM_ev'' store_pde_reads_respects - unmap_page_reads_respects set_vm_root_reads_respects dmo_mol_2_reads_respects + unmap_page_reads_respects set_vm_root_reads_respects set_vm_root_for_flush_reads_respects get_cap_rev do_flush_reads_respects invalidate_tlb_by_asid_reads_respects get_master_pte_reads_respects get_master_pde_reads_respects set_mrs_reads_respects set_message_info_reads_respects - | simp add: cleanByVA_PoU_def pte_check_if_mapped_def pde_check_if_mapped_def + | simp add: cleanByVA_PoU_def pte_check_if_mapped_def pde_check_if_mapped_def dmo_distr | wpc | wp (once) hoare_drop_imps[where Q'="\r s. r"])+ apply (clarsimp simp: authorised_page_inv_def valid_page_inv_def) apply (auto simp: cte_wp_at_caps_of_state valid_slots_def cap_auth_conferred_def @@ -1312,7 +1300,7 @@ lemma perform_page_table_invocation_globals_equiv: \\_. globals_equiv st\" unfolding perform_page_table_invocation_def cleanCacheRange_PoU_def apply (rule hoare_weaken_pre) - apply (wp store_pde_globals_equiv set_cap_globals_equiv'' dmo_cacheRangeOp_lift + apply (wp store_pde_globals_equiv set_cap_globals_equiv dmo_cacheRangeOp_lift mapM_x_swp_store_pte_globals_equiv unmap_page_table_globals_equiv | wpc | simp add: cleanByVA_PoU_def)+ apply (fastforce simp: authorised_for_globals_page_table_inv_def @@ -1491,7 +1479,7 @@ lemma perform_page_invocation_globals_equiv: apply (rule hoare_weaken_pre) apply (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift dmo_cacheRangeOp_lift mapM_swp_store_pde_globals_equiv mapM_x_swp_store_pte_globals_equiv - mapM_x_swp_store_pde_globals_equiv set_cap_globals_equiv'' + mapM_x_swp_store_pde_globals_equiv set_cap_globals_equiv unmap_page_globals_equiv store_pte_globals_equiv store_pde_globals_equiv hoare_weak_lift_imp do_flush_globals_equiv set_mrs_globals_equiv set_message_info_globals_equiv | wpc | simp add: do_machine_op_bind cleanByVA_PoU_def)+ @@ -1519,7 +1507,7 @@ lemma perform_asid_control_invocation_globals_equiv: apply (rule hoare_pre) apply wpc apply (rename_tac word1 cslot_ptr1 cslot_ptr2 word2) - apply (wp modify_wp cap_insert_globals_equiv'' + apply (wp modify_wp cap_insert_globals_equiv retype_region_ASIDPoolObj_globals_equiv[simplified] retype_region_invs_extras(5)[where sz=pageBits] retype_region_invs_extras(6)[where sz=pageBits] @@ -1595,7 +1583,7 @@ lemma perform_asid_pool_invocation_globals_equiv: "\globals_equiv s and valid_arch_state\ perform_asid_pool_invocation api \\_. globals_equiv s\" unfolding perform_asid_pool_invocation_def apply (rule hoare_weaken_pre) - apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' + apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv get_cap_wp | wpc | simp)+ done @@ -1726,22 +1714,19 @@ lemma mapM_x_swp_store_pte_reads_respects': (mapM_x (swp store_pte InvalidPTE) [word , word + 4 .e. word + 2 ^ pt_bits - 1])" apply (rule gen_asm_ev) apply (wp mapM_x_ev) - apply simp - apply (rule equiv_valid_guard_imp) - apply (wp store_pte_reads_respects) - apply simp - apply (elim conjE) - apply (subgoal_tac "is_aligned word pt_bits") - apply (frule (1) word_aligned_pt_slots) apply simp - apply (frule cte_wp_valid_cap) - apply (rule invs_valid_objs) + apply (rule equiv_valid_guard_imp) + apply (wp store_pte_reads_respects) + apply clarsimp + apply (subgoal_tac "is_aligned word pt_bits") + apply (frule (1) word_aligned_pt_slots) + apply simp apply simp - apply (simp add: valid_cap_def cap_aligned_def pt_bits_def pageBits_def) - apply simp - apply wp - apply simp - apply (fastforce simp: is_cap_simps dest!: cte_wp_at_pt_exists_cap[OF invs_valid_objs]) + apply wpsimp+ + apply (frule cte_wp_valid_cap) + apply (rule invs_valid_objs) + apply simp + apply (simp add: valid_cap_def cap_aligned_def pt_bits_def pageBits_def) done lemma word_shiftr_20_le_1_shift_pageBits: @@ -1778,18 +1763,19 @@ lemma mapM_x_swp_store_pde_reads_respects': and K (is_subject aag w)) (mapM_x (swp store_pde InvalidPDE) (map ((\x. x + w) \ swp (<<) 2) [0 .e. (kernel_base >> 20) - 1]))" + apply (rule gen_asm_ev) apply (wp mapM_x_ev) - apply simp - apply (rule equiv_valid_guard_imp) - apply (wp store_pde_reads_respects) + apply simp + apply (rule equiv_valid_guard_imp) + apply (wp store_pde_reads_respects) + apply clarsimp + apply (subgoal_tac "is_aligned w pd_bits") + apply (clarsimp simp add: pd_bits_store_pde_helper) + apply simp + apply wpsimp+ + apply (frule cte_wp_valid_cap) apply clarsimp - apply (subgoal_tac "is_aligned w pd_bits") - apply (simp add: pd_bits_store_pde_helper) - apply (frule (1) cte_wp_valid_cap) - apply (simp add: valid_cap_def cap_aligned_def pd_bits_def pageBits_def) - apply simp - apply wp - apply (clarsimp simp: wellformed_pde_def)+ + apply (simp add: valid_cap_def cap_aligned_def pd_bits_def pageBits_def) done lemma mapM_x_swp_store_pte_pas_refined_simple: @@ -1834,14 +1820,10 @@ lemma thread_set_globals_equiv: end -hide_fact as_user_globals_equiv - -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts authorised_for_globals_arch_inv -requalify_facts +arch_requalify_facts arch_post_cap_deletion_valid_global_objs get_thread_state_globals_equiv auth_ipc_buffers_mem_Write' @@ -1851,11 +1833,7 @@ requalify_facts length_msg_lt_msg_max set_mrs_globals_equiv arch_perform_invocation_globals_equiv - as_user_globals_equiv - prepare_thread_delete_st_tcb_at_halted - make_arch_fault_msg_inv check_valid_ipc_buffer_inv - arch_tcb_update_aux2 arch_perform_invocation_reads_respects_g declare @@ -1865,10 +1843,6 @@ declare arch_post_modify_registers_cur_thread[wp] prepare_thread_delete_st_tcb_at_halted[wp] -end - -declare as_user_globals_equiv[wp] - axiomatization dmo_reads_respects where dmo_getDFSR_reads_respects: "reads_respects aag l \ (do_machine_op ARM.getDFSR)" and dmo_getFAR_reads_respects: "reads_respects aag l \ (do_machine_op ARM.getFAR)" and diff --git a/proof/infoflow/ARM/ArchCNode_IF.thy b/proof/infoflow/ARM/ArchCNode_IF.thy index 8d6647b00c..92bd020674 100644 --- a/proof/infoflow/ARM/ArchCNode_IF.thy +++ b/proof/infoflow/ARM/ArchCNode_IF.thy @@ -34,24 +34,14 @@ lemma set_object_globals_equiv'': \\_. globals_equiv s\" by (wpsimp wp: set_object_globals_equiv) -lemma set_cap_globals_equiv': - "\globals_equiv s and (\ s. fst p \ arm_global_pd (arch_state s))\ - set_cap cap p - \\_. globals_equiv s\" - unfolding set_cap_def - apply (simp only: split_def) - apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: obj_at_def is_tcb_def) - done - lemma set_cap_globals_equiv[CNode_IF_assms]: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ set_cap cap p \\_. globals_equiv s\" unfolding set_cap_def apply (simp only: split_def) apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: valid_global_objs_def valid_vso_at_def obj_at_def is_tcb_def) + apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def)+ done (* moved from ADT_IF *) @@ -128,8 +118,7 @@ lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: notes gets_ev[wp del] shows "reads_respects aag l (invs and only_timer_irq_inv irq st) (do_machine_op (getActiveIRQ in_kernel))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects') + apply (rule do_machine_op_reads_respects') apply (simp add: getActiveIRQ_def) apply (wp irq_state_increment_reads_respects_memory irq_state_increment_reads_respects_device gets_ev[where f="irq_oracle \ irq_state"] equiv_valid_inv_conj_lift @@ -138,6 +127,15 @@ lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: apply (rule only_timer_irq_inv_determines_irq_masks, blast+) done +lemma dmo_getActiveIRQ_globals_equiv[CNode_IF_assms]: + "do_machine_op (getActiveIRQ in_kernel) \globals_equiv st\" + unfolding globals_equiv_def arch_globals_equiv_def idle_equiv_def + apply (rule hoare_weaken_pre) + apply wps + apply wpsimp + apply clarsimp + done + end diff --git a/proof/infoflow/ARM/ArchFinalCaps.thy b/proof/infoflow/ARM/ArchFinalCaps.thy index 6525f48c9d..e2b7b7a5d4 100644 --- a/proof/infoflow/ARM/ArchFinalCaps.thy +++ b/proof/infoflow/ARM/ArchFinalCaps.thy @@ -346,6 +346,10 @@ lemma invoke_tcb_silc_inv[FinalCaps_assms]: | intro impI | rule conjI)+ +lemma handle_reserved_irq_non_kernel_IRQs[FinalCaps_assms]: + "\P and K (irq \ non_kernel_IRQs)\ handle_reserved_irq irq \\_. P\" + unfolding handle_reserved_irq_def by wpsimp + end @@ -356,4 +360,12 @@ proof goal_cases by (unfold_locales; (fact FinalCaps_assms)?) qed + +global_interpretation FinalCaps_3?: FinalCaps_3 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms | solves \wp only: FinalCaps_assms; simp\)?) +qed + end \ No newline at end of file diff --git a/proof/infoflow/ARM/ArchFinalise_IF.thy b/proof/infoflow/ARM/ArchFinalise_IF.thy index 6b0de4e7cf..4f19b278b5 100644 --- a/proof/infoflow/ARM/ArchFinalise_IF.thy +++ b/proof/infoflow/ARM/ArchFinalise_IF.thy @@ -19,8 +19,7 @@ crunch arch_post_cap_deletion lemma dmo_maskInterrupt_reads_respects[Finalise_IF_assms]: "reads_respects aag l \ (do_machine_op (maskInterrupt m irq))" unfolding maskInterrupt_def - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (simp add: equiv_valid_def2) apply (rule modify_ev2) apply (fastforce simp: equiv_for_def) @@ -165,21 +164,16 @@ lemma set_notification_equiv_but_for_labels[Finalise_IF_assms]: done lemma thread_set_reads_respects[Finalise_IF_assms]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects aag l \ (thread_set x y)" - unfolding thread_set_def fun_app_def - apply (case_tac "aag_can_read aag y \ aag_can_affect aag l y") - apply (wp set_object_reads_respects) - apply (clarsimp, rule reads_affects_equiv_get_tcb_eq, simp+)[1] - apply (simp add: equiv_valid_def2) - apply (rule equiv_valid_rv_guard_imp) - apply (rule_tac L="{pasObjectAbs aag y}" and L'="{pasObjectAbs aag y}" - in ev2_invisible[OF domains_distinct]) - apply (assumption | simp add: labels_are_invisible_def)+ - apply (rule modifies_at_mostI[where P="\"] - | wp set_object_equiv_but_for_labels - | simp - | (clarify, drule get_tcb_not_asid_pool_at))+ + "reads_respects aag l \ (thread_set f thread)" + unfolding thread_set_def + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q=\ and ptr=thread in reads_respects_unit_cases) + apply (rule gen_asm_ev') + apply (wpsimp wp: set_object_reads_respects) + apply (wp set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def) + apply wpsimp + apply (auto intro: reads_affects_equiv_get_tcb_eq) done lemma aag_cap_auth_ASIDPoolCap: @@ -381,7 +375,7 @@ global_interpretation Finalise_IF_1?: Finalise_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Finalise_IF_assms)?) + by (unfold_locales; (fact Finalise_IF_assms | solves \wp only: Finalise_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/ARM/ArchIRQMasks_IF.thy b/proof/infoflow/ARM/ArchIRQMasks_IF.thy index ffaf96a87d..657226cef9 100644 --- a/proof/infoflow/ARM/ArchIRQMasks_IF.thy +++ b/proof/infoflow/ARM/ArchIRQMasks_IF.thy @@ -163,6 +163,9 @@ lemma invoke_tcb_irq_masks[IRQMasks_IF_assms]: crunch arch_prepare_set_domain for inv[IRQMasks_IF_assms,wp]: P +crunch arch_prepare_next_domain + for valid_irq_states[IRQMasks_IF_assms,wp]: valid_irq_states + end @@ -170,7 +173,7 @@ global_interpretation IRQMasks_IF_2?: IRQMasks_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact IRQMasks_IF_assms)?) + by (unfold_locales; (fact IRQMasks_IF_assms | solves \wp only: IRQMasks_IF_assms; simp\)?) qed diff --git a/proof/infoflow/ARM/ArchInfoFlow.thy b/proof/infoflow/ARM/ArchInfoFlow.thy index 073faff05d..8ea5654145 100644 --- a/proof/infoflow/ARM/ArchInfoFlow.thy +++ b/proof/infoflow/ARM/ArchInfoFlow.thy @@ -10,6 +10,8 @@ imports "Lib.EquivValid" begin +consts equiv_for :: "('a \ bool) \ ('b \ 'a \ 'c) \ 'b \ 'b \ bool" + context Arch begin global_naming ARM section \Arch-specific equivalence properties\ @@ -66,6 +68,12 @@ definition arch_globals_equiv :: "obj_ref \ obj_ref \ kh declare arch_globals_equiv_def[simp] +definition equiv_hyp :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_hyp P s s' \ True" + +definition equiv_fpu :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_fpu P s s' \ True" + end context begin interpretation Arch . diff --git a/proof/infoflow/ARM/ArchInfoFlow_IF.thy b/proof/infoflow/ARM/ArchInfoFlow_IF.thy index 5430ea10b3..480c25dc34 100644 --- a/proof/infoflow/ARM/ArchInfoFlow_IF.thy +++ b/proof/infoflow/ARM/ArchInfoFlow_IF.thy @@ -82,6 +82,72 @@ lemma equiv_asids_guard_imp[InfoFlow_IF_assms]: "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" by (auto simp: equiv_asids_def) + +definition identical_hyp_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_hyp_state_updates _ _ _ _ _ \ True" + +definition identical_fpu_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_fpu_state_updates _ _ _ _ _ \ True" + +definition no_hyp :: "'m machine_monad \ bool" where + "no_hyp f \ True" + +definition no_fpu :: "'m machine_monad \ bool" where + "no_fpu f \ True" + +lemma equiv_hyp_taut[intro!,simp]: + "equiv_hyp P s s'" + "equiv_hyp P st s = equiv_hyp P' st' s'" + by (simp_all add: equiv_hyp_def) + +lemma equiv_fpu_taut[intro!,simp]: + "equiv_fpu P s s'" + "equiv_fpu P st s = equiv_fpu P' st' s'" + by (simp_all add: equiv_fpu_def) + +lemma identical_hyp_states_updates_taut[intro!,simp]: + "identical_hyp_state_updates P s s' ms ms'" + by (simp add: identical_hyp_state_updates_def) + +lemma identical_fpu_states_updates_taut[intro!,simp]: + "identical_fpu_state_updates P s s' ms ms'" + by (simp add: identical_fpu_state_updates_def) + +lemma no_hyp_taut[intro!,simp]: + "no_hyp f" + by (simp add: no_hyp_def) + +lemma no_fpu_taut[intro!,simp]: + "no_fpu f" + by (simp add: no_fpu_def) + +lemmas equiv_arch_taut = + equiv_hyp_taut + equiv_fpu_taut + identical_hyp_states_updates_taut + identical_fpu_states_updates_taut + no_hyp_taut + no_fpu_taut + +end + +arch_requalify_consts + identical_hyp_state_updates + identical_fpu_state_updates + no_hyp + no_fpu + + +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 identical_hyp_state_updates identical_fpu_state_updates +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact InfoFlow_IF_assms | solves \rule equiv_arch_taut\)?) +qed + + +context Arch begin arch_global_naming + lemma dmo_loadWord_rev[InfoFlow_IF_assms]: "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) (do_machine_op (loadWord p))" @@ -107,14 +173,51 @@ lemma dmo_loadWord_rev[InfoFlow_IF_assms]: apply (wp wp_post_taut loadWord_inv | simp)+ done +lemma do_machine_op_reads_respects'[InfoFlow_IF_assms]: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) + (equiv_machine_state (aag_can_affect aag l)) Q f" + assumes guard: + "\s. P s \ Q (machine_state s)" + and no_hyp: "no_hyp f" + and no_fpu: "no_fpu f" + shows + "reads_respects aag l P (do_machine_op f)" + apply (rule use_spec_ev) + unfolding do_machine_op_def spec_equiv_valid_def + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. equiv_machine_state (aag_can_read aag or aag_can_affect aag l) rv rv' \ + equiv_irq_state rv rv'" + and Q="\r s. st = s \ Q r" and Q'="\ r s. Q r" and P="(=) st" and P'="\" in equiv_valid_2_bind) + apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) + apply (rule gen_asm_ev2_r') + apply (rule_tac R'="\(r,ms') (r',ms''). r = r' \ + equiv_machine_state (aag_can_read aag) ms' ms'' \ + equiv_machine_state (aag_can_affect aag l) ms' ms'' \ + equiv_irq_state ms' ms''" + and Q="\r s. st = s" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) + apply (fastforce intro: reads_equiv_machine_state_update affects_equiv_machine_state_update) + apply (insert equiv_dmo)[1] + apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or split_def equiv_for_def)[1] + apply (drule_tac x=rv in spec, drule_tac x=rv' in spec) + apply (fastforce) + apply (rule select_f_inv) + apply (rule wp_post_taut) + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (wp | simp add: guard)+ + done + end -global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_2 identical_hyp_state_updates identical_fpu_state_updates no_hyp no_fpu proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact InfoFlow_IF_assms)?) + by (unfold_locales; (fact InfoFlow_IF_assms | solves \rule equiv_arch_taut\)?) qed end diff --git a/proof/infoflow/ARM/ArchInterrupt_IF.thy b/proof/infoflow/ARM/ArchInterrupt_IF.thy index 73a08f219e..364ee831f2 100644 --- a/proof/infoflow/ARM/ArchInterrupt_IF.thy +++ b/proof/infoflow/ARM/ArchInterrupt_IF.thy @@ -40,12 +40,12 @@ lemma arch_invoke_irq_control_reads_respects[Interrupt_IF_assms]: done lemma arch_invoke_irq_control_globals_equiv[Interrupt_IF_assms]: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ arch_invoke_irq_control ai \\_. globals_equiv st\" apply (induct ai; wpsimp wp: set_irq_state_globals_equiv set_irq_state_valid_global_objs - cap_insert_globals_equiv'' dmo_mol_globals_equiv + cap_insert_globals_equiv dmo_mol_globals_equiv simp: setIRQTrigger_def) done diff --git a/proof/infoflow/ARM/ArchIpc_IF.thy b/proof/infoflow/ARM/ArchIpc_IF.thy index d76b74d895..0fc0d25aff 100644 --- a/proof/infoflow/ARM/ArchIpc_IF.thy +++ b/proof/infoflow/ARM/ArchIpc_IF.thy @@ -54,6 +54,7 @@ lemma storeWord_equiv_but_for_labels[Ipc_IF_assms]: apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply auto[2] apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=ready_queues]) done @@ -203,9 +204,7 @@ lemma dmo_loadWord_reads_respects[Ipc_IF_assms]: "reads_respects aag l (K (for_each_byte_of_word (\ x. aag_can_read_or_affect aag l x) p)) (do_machine_op (loadWord p))" apply (rule gen_asm_ev) - apply (rule use_spec_ev) - apply (rule spec_equiv_valid_hoist_guard) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" and Q="\\" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) @@ -288,7 +287,7 @@ global_interpretation Ipc_IF_1?: Ipc_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Ipc_IF_assms)?) + by (unfold_locales; (fact Ipc_IF_assms | solves \wp only: Ipc_IF_assms; simp\)?) qed @@ -442,7 +441,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (simp add: equiv_valid_def2) apply (rule equiv_valid_rv_guard_imp) apply (case_tac buf) - apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in ev_invisible[OF domains_distinct]) + apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in revrv_invisible[OF domains_distinct]) apply (clarsimp simp: labels_are_invisible_def) apply (rule modifies_at_mostI) apply (simp add: set_mrs_def) @@ -452,7 +451,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (rename_tac buf') apply (rule_tac Q="\" and L="{pasObjectAbs aag thread} \ (pasObjectAbs aag) ` (ptr_range buf' msg_align_bits)" - in ev_invisible[OF domains_distinct]) + in revrv_invisible[OF domains_distinct]) apply (auto simp: labels_are_invisible_def ipc_buffer_has_auth_def dest: reads_read_page_read_thread simp: aag_can_affect_label_def)[1] apply (rule modifies_at_mostI) diff --git a/proof/infoflow/ARM/ArchNoninterference.thy b/proof/infoflow/ARM/ArchNoninterference.thy index 45933ae086..52db56880b 100644 --- a/proof/infoflow/ARM/ArchNoninterference.thy +++ b/proof/infoflow/ARM/ArchNoninterference.thy @@ -257,6 +257,7 @@ lemma dmo_storeWord_reads_respects_g[Noninterference_assms, wp]: equiv_for_def equiv_asids_def equiv_asid_def silc_dom_equiv_def) apply (rule affects_equiv_machine_state_update, assumption) apply (fastforce simp: equiv_for_def affects_equiv_def states_equiv_for_def) + apply auto[2] apply (simp add: equiv_valid_def2 equiv_valid_2_def) done @@ -275,6 +276,7 @@ lemma dmo_clearExMonitor_reads_respects_g': apply (simp add: reads_equiv_g_def reads_equiv_def2 affects_equiv_def2 globals_equiv_def idle_equiv_def states_equiv_for_def equiv_for_def equiv_asids_def equiv_asid_def) apply metis + apply simp done lemma arch_switch_to_thread_reads_respects_g'[Noninterference_assms]: @@ -423,6 +425,56 @@ lemma arch_tcb_get_registers_equality[Noninterference_assms]: \ tcb_arch tcb = tcb_arch tcb'" by (auto simp: arch_tcb_get_registers_def intro: arch_tcb.equality user_context.expand) +lemma getActiveIRQ_ev2[Noninterference_assms]: + "equiv_valid_2 (scheduler_equiv aag) + (scheduler_affects_equiv aag l) (scheduler_affects_equiv aag l) + (\irq irq'. irq = irq' \ irq = None \ irq' \ Some ` non_kernel_IRQs) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ True)) (do_machine_op (getActiveIRQ False))" + apply (simp add: getActiveIRQ_no_non_kernel_IRQs) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid, rule dmo_getActiveIRQ_wp)+ + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def irq_at_def Let_def) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def + silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI impI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def equiv_asids_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + done + +lemma arch_prepare_next_domain_reads_respects_g[Noninterference_assms]: + "reads_respects_g aag l invs arch_prepare_next_domain" + unfolding arch_prepare_next_domain_def by wpsimp + +lemma partitionIntegrity_subjectAffects_tcb_fpu[Noninterference_assms]: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (TCB tcb)" + "kheap s' x = Some (TCB tcb')" + "tcb' = tcb\tcb_arch := new_arch\" + "arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb)" + "tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb)" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_fpu_in_cur_domain s" "cur_fpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" + apply (insert assms(2,3,4,5,7)) + apply (clarsimp simp: arch_tcb_get_registers_def) + apply (subgoal_tac "new_arch = tcb_arch tcb") + apply clarsimp + apply (rule arch_tcb.equality; clarsimp?) + apply (rule user_context.expand; clarsimp) + done + end context begin interpretation Arch . @@ -437,7 +489,8 @@ global_interpretation Noninterference_1?: Noninterference_1 _ arch_globals_equiv proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\)?) + by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\ + | solves \wp only: Noninterference_assms; simp\)?) qed sublocale valid_initial_state \ valid_initial_state?: diff --git a/proof/infoflow/ARM/ArchPasUpdates.thy b/proof/infoflow/ARM/ArchPasUpdates.thy index 93d97b720a..d7997f7db4 100644 --- a/proof/infoflow/ARM/ArchPasUpdates.thy +++ b/proof/infoflow/ARM/ArchPasUpdates.thy @@ -81,7 +81,7 @@ declare arch_prepare_set_domain_inv[PasUpdates_assms] end -global_interpretation PasUpdates_2?: PasUpdates_2 +global_interpretation PasUpdates_2?: PasUpdates_1 proof goal_cases interpret Arch . case 1 show ?case diff --git a/proof/infoflow/ARM/ArchRetype_IF.thy b/proof/infoflow/ARM/ArchRetype_IF.thy index 703841e13c..53f81ecc05 100644 --- a/proof/infoflow/ARM/ArchRetype_IF.thy +++ b/proof/infoflow/ARM/ArchRetype_IF.thy @@ -82,11 +82,6 @@ lemma dmo_cacheRangeOp_reads_respects: apply (rule hoare_TrueI) done -lemma dmo_cleanCacheRange_PoU_reads_respects: - "reads_respects aag l \ (do_machine_op (cleanCacheRange_PoU vsrat vend pstart))" - unfolding cleanCacheRange_PoU_def - by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects | simp add: cleanByVA_PoU_def)+ - lemma set_pd_globals_equiv: "\globals_equiv st and (\s. a \ arm_global_pd (arch_state s))\ set_pd a b \\_. globals_equiv st\" unfolding set_pd_def @@ -181,7 +176,8 @@ lemma copy_global_mappings_reads_respects_g: pspace_aligned s \ valid_arch_state s" in hoare_weaken_pre) apply (rule gets_sp) apply (assumption) - apply (wp mapM_x_ev store_pde_reads_respects_g get_pde_revg) + apply (rule mapM_x_ev) + apply (wp mapM_x_ev store_pde_reads_respects_g get_pde_revg) apply (drule subsetD[OF copy_global_mappings_index_subset]) apply (clarsimp simp: pd_shifting' invs_aligned_pdD) apply (wp get_pde_inv store_pde_aligned store_pde_valid_arch | simp | fastforce)+ @@ -220,33 +216,12 @@ lemma dmo_cleanCacheRange_PoU_globals_equiv: unfolding cleanCacheRange_PoU_def by (wp dmo_mol_globals_equiv dmo_cacheRangeOp_lift | simp add: cleanByVA_PoU_def)+ -lemma dmo_cleanCacheRange_PoU_reads_respects_g: - "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_PoU x y z))" - apply (rule equiv_valid_guard_imp[OF reads_respects_g]) - apply (rule dmo_cleanCacheRange_PoU_reads_respects) - apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_PoU_globals_equiv]) - by simp - lemma dmo_cleanCacheRange_RAM_globals_equiv: "do_machine_op (cleanCacheRange_RAM x y z) \globals_equiv s\" unfolding cleanCacheRange_RAM_def by (wpsimp wp: dmo_mol_globals_equiv dmo_cacheRangeOp_lift simp: dmo_bind_valid dsb_def cleanCacheRange_PoC_def cleanByVA_def cleanL2Range_def) -lemma dmo_cleanCacheRange_RAM_reads_respects: - "reads_respects aag l \ (do_machine_op (cleanCacheRange_RAM vsrat vend pstart))" - unfolding cleanCacheRange_RAM_def - by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects empty_fail_cleanByVA empty_fail_cacheRangeOp - | simp add: cleanL2Range_def dsb_def cleanCacheRange_PoC_def cleanByVA_def - | subst do_machine_op_bind)+ - -lemma dmo_cleanCacheRange_RAM_reads_respects_g: - "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_RAM x y z))" - apply (rule equiv_valid_guard_imp[OF reads_respects_g]) - apply (rule dmo_cleanCacheRange_RAM_reads_respects) - apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_RAM_globals_equiv]) - by simp - lemma mol_globals_equiv: "machine_op_lift mop \\ms. globals_equiv st (s\machine_state := ms\)\" unfolding machine_op_lift_def @@ -283,26 +258,6 @@ lemma dmo_freeMemory_globals_equiv[Retype_IF_assms]: apply (simp_all) done -lemma init_arch_objects_reads_respects_g: - "reads_respects_g aag l ((\s. arm_global_pd (arch_state s) \ set refs \ - pspace_aligned s \ valid_arch_state s) and - K (\x\set refs. is_subject aag x) and - K (\x\set refs. new_type = ArchObject PageDirectoryObj - \ is_aligned x pd_bits) and - K ((0::obj_ref) < of_nat num_objects)) - (init_arch_objects new_type dev ptr num_objects obj_sz refs)" - apply (unfold init_arch_objects_def fun_app_def) - apply (rule gen_asm_ev)+ - apply (rule equiv_valid_guard_imp) - apply (wp dmo_cleanCacheRange_RAM_reads_respects_g - dmo_cleanCacheRange_PoU_reads_respects_g - mapM_x_ev'' when_ev - equiv_valid_guard_imp[OF copy_global_mappings_reads_respects_g] - copy_global_mappings_valid_arch_state copy_global_mappings_pspace_aligned - hoare_vcg_ball_lift | wpc | simp)+ - apply clarsimp - done - lemma copy_global_mappings_globals_equiv: "\globals_equiv s and (\s. x \ arm_global_pd (arch_state s) \ is_aligned x pd_bits)\ copy_global_mappings x @@ -428,7 +383,7 @@ global_interpretation Retype_IF_1?: Retype_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Retype_IF_assms)?) + by (unfold_locales; (fact Retype_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -499,7 +454,6 @@ lemma reset_untyped_cap_reads_respects_g: apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps free_index_of_def invs_valid_global_objs) apply (simp add: aligned_add_aligned is_aligned_shiftl) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (rule hoare_pre) apply (wp preemption_point_inv' set_untyped_cap_invs_simple set_cap_cte_wp_at set_cap_no_overlap only_timer_irq_inv_pres[where Q=\, OF _ set_cap_domain_sep_inv] @@ -549,6 +503,52 @@ lemma retype_region_ret_pd_aligned: apply (clarsimp simp: obj_bits_api_def default_arch_object_def pd_bits_def pageBits_def) done +lemma dmo_cleanCacheRange_PoU_reads_respects: + "reads_respects aag l \ (do_machine_op (cleanCacheRange_PoU vsrat vend pstart))" + unfolding cleanCacheRange_PoU_def + by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects | simp add: cleanByVA_PoU_def)+ + +lemma dmo_cleanCacheRange_PoU_reads_respects_g: + "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_PoU x y z))" + apply (rule equiv_valid_guard_imp[OF reads_respects_g]) + apply (rule dmo_cleanCacheRange_PoU_reads_respects) + apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_PoU_globals_equiv]) + by simp + +lemma dmo_cleanCacheRange_RAM_reads_respects: + "reads_respects aag l \ (do_machine_op (cleanCacheRange_RAM vsrat vend pstart))" + unfolding cleanCacheRange_RAM_def + by (wp dmo_cacheRangeOp_reads_respects dmo_mol_reads_respects empty_fail_cleanByVA empty_fail_cacheRangeOp + | simp add: cleanL2Range_def dsb_def cleanCacheRange_PoC_def cleanByVA_def + | subst do_machine_op_bind)+ + +lemma dmo_cleanCacheRange_RAM_reads_respects_g: + "reads_respects_g aag l \ (do_machine_op (cleanCacheRange_RAM x y z))" + apply (rule equiv_valid_guard_imp[OF reads_respects_g]) + apply (rule dmo_cleanCacheRange_RAM_reads_respects) + apply (rule doesnt_touch_globalsI[where P="\", simplified, OF dmo_cleanCacheRange_RAM_globals_equiv]) + by simp + +lemma init_arch_objects_reads_respects_g: + "reads_respects_g aag l ((\s. arm_global_pd (arch_state s) \ set refs \ + pspace_aligned s \ valid_arch_state s) and + K (\x\set refs. is_subject aag x) and + K (\x\set refs. new_type = ArchObject PageDirectoryObj + \ is_aligned x pd_bits) and + K ((0::obj_ref) < of_nat num_objects)) + (init_arch_objects new_type dev ptr num_objects obj_sz refs)" + apply (unfold init_arch_objects_def fun_app_def) + apply (rule gen_asm_ev)+ + apply (rule equiv_valid_guard_imp) + apply (wp dmo_cleanCacheRange_RAM_reads_respects_g + dmo_cleanCacheRange_PoU_reads_respects_g + mapM_x_ev'' when_ev + equiv_valid_guard_imp[OF copy_global_mappings_reads_respects_g] + copy_global_mappings_valid_arch_state copy_global_mappings_pspace_aligned + hoare_vcg_ball_lift | wpc | simp)+ + apply clarsimp + done + lemma invoke_untyped_reads_respects_g_wcap[Retype_IF_assms]: notes blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff Int_atLeastAtMost @@ -691,7 +691,6 @@ lemma reset_untyped_cap_globals_equiv: apply (clarsimp simp: is_cap_simps ptr_range_def[symmetric] cap_aligned_def bits_of_def free_index_of_def) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (strengthen invs_valid_global_objs invs_arch_state) apply (wp delete_objects_invs_ex hoare_vcg_const_imp_lift get_cap_wp)+ apply (clarsimp simp: cte_wp_at_caps_of_state descendants_range_def2 is_cap_simps bits_of_def diff --git a/proof/infoflow/ARM/ArchScheduler_IF.thy b/proof/infoflow/ARM/ArchScheduler_IF.thy index b78cdfe9ce..363a99bc29 100644 --- a/proof/infoflow/ARM/ArchScheduler_IF.thy +++ b/proof/infoflow/ARM/ArchScheduler_IF.thy @@ -131,6 +131,7 @@ lemma equiv_asid_equiv_update[Scheduler_IF_assms]: by (clarsimp simp: equiv_asid_def obj_at_def get_tcb_def) declare arch_prepare_next_domain_inv[Scheduler_IF_assms] +declare arch_activate_idle_thread_domain_fields_invs[Scheduler_IF_assms] end @@ -148,7 +149,7 @@ global_interpretation Scheduler_IF_1?: proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Scheduler_IF_assms)?) + by (unfold_locales; (fact Scheduler_IF_assms | solves \wp only: Scheduler_IF_assms; simp\)?) qed @@ -234,7 +235,7 @@ lemma ev_asahi_to_asahi_ex_dmo_clearExMonitor: apply (rule conjI) apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def silc_dom_equiv_def equiv_for_def) - apply (clarsimp simp: midstrength_scheduler_affects_equiv_def asahi_scheduler_affects_equiv_def + apply (auto simp: midstrength_scheduler_affects_equiv_def asahi_scheduler_affects_equiv_def asahi_ex_scheduler_affects_equiv_def states_equiv_for_def equiv_for_def arch_scheduler_affects_equiv_def equiv_asids_def equiv_asid_def scheduler_globals_frame_equiv_def @@ -255,8 +256,8 @@ lemma store_cur_thread_fragment_midstrength_reads_respects: apply simp done -lemma arch_switch_to_thread_globals_equiv_scheduler': - "\invs and globals_equiv_scheduler sta\ +lemma set_vm_root_globals_equiv_scheduler: + "\valid_arch_state and globals_equiv_scheduler sta\ set_vm_root t \\_. globals_equiv_scheduler sta\" by (rule globals_equiv_scheduler_inv', wpsimp) @@ -270,7 +271,7 @@ lemma reads_respects_scheduler_clearExMonitor[wp]: apply (rule conjI) apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def silc_dom_equiv_def equiv_for_def) - apply (clarsimp simp: scheduler_affects_equiv_def arch_scheduler_affects_equiv_def + apply (auto simp: scheduler_affects_equiv_def arch_scheduler_affects_equiv_def states_equiv_for_def equiv_for_def equiv_asids_def equiv_asid_def scheduler_globals_frame_equiv_def simp del: split_paired_All) @@ -318,11 +319,11 @@ lemma arch_switch_to_thread_midstrength_reads_respects_scheduler[Scheduler_IF_as done lemma arch_switch_to_idle_thread_globals_equiv_scheduler[Scheduler_IF_assms, wp]: - "\invs and globals_equiv_scheduler sta\ + "\valid_arch_state and globals_equiv_scheduler sta\ arch_switch_to_idle_thread \\_. globals_equiv_scheduler sta\" unfolding arch_switch_to_idle_thread_def storeWord_def - by (wp dmo_wp modify_wp thread_get_wp' arch_switch_to_thread_globals_equiv_scheduler') + by (wp dmo_wp modify_wp thread_get_wp' set_vm_root_globals_equiv_scheduler) lemma arch_switch_to_idle_thread_unobservable[Scheduler_IF_assms]: "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and @@ -371,6 +372,19 @@ lemma next_domain_midstrength_equiv_scheduler[Scheduler_IF_assms]: states_equiv_for_def idle_equiv_def) done +lemma arch_switch_to_idle_thread_midstrength_reads_respects[Scheduler_IF_assms]: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) arch_switch_to_idle_thread" + apply (rule equiv_valid_inv_unobservable) + apply (rule hoare_pre) + apply (rule scheduler_equiv_lift') + apply (wpsimp wp: silc_dom_lift)+ + apply assumption + apply (wp midstrength_scheduler_affects_equiv_unobservable + | simp | wps)+ + apply (auto simp: scheduler_equiv_sym midstrength_scheduler_affects_equiv_sym) + done + lemma resetTimer_exclusive_state[wp]: "resetTimer \\s. P (exclusive_state s)\" by (wpsimp simp: resetTimer_def wp: mol_exclusive_state) @@ -438,6 +452,32 @@ lemma thread_set_scheduler_affects_equiv[Scheduler_IF_assms, wp]: apply simp+ done +lemma thread_set_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l (valid_arch_state and K (valid_tcb_context_update f)) + (thread_set f t)" + apply (rule gen_asm_ev) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + unfolding thread_set_def gets_the_def gets_def get_def return_def assert_opt_def fail_def set_object_def get_object_def assert_def put_def + apply (clarsimp simp: bind_def split: option.splits if_splits) + apply (clarsimp simp: get_tcb_ko_at obj_at_def) + unfolding valid_tcb_context_update_def + apply (rename_tac s' tcb tcb') + apply (erule_tac x=tcb in allE) + apply (erule_tac x=tcb' in allE) + apply (rule conjI) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def) + apply (intro conjI) + apply (clarsimp simp: arch_globals_equiv_scheduler_def) + apply (clarsimp simp: idle_equiv_def tcb_at_def get_tcb_def arch_tcb_context_get_def) + apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI; clarsimp?) + apply (clarsimp simp: equiv_asids_def equiv_asid_def obj_at_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def arch_scheduler_affects_equiv_def) + done + lemma set_object_reads_respects_scheduler[Scheduler_IF_assms, wp]: "reads_respects_scheduler aag l \ (set_object ptr obj)" unfolding equiv_valid_def2 equiv_valid_2_def @@ -456,15 +496,53 @@ lemma arch_prepare_next_domain_ev[Scheduler_IF_assms]: "equiv_valid_inv I A (\_. True) arch_prepare_next_domain" unfolding arch_prepare_next_domain_def by wp +lemma arch_switch_to_thread_silc_dom_equiv[Scheduler_IF_assms,wp]: + "arch_switch_to_thread t \silc_dom_equiv aag (st :: det_state)\" + by (wpsimp wp: silc_dom_lift) + +lemma arch_switch_to_idle_thread_silc_dom_equiv[Scheduler_IF_assms,wp]: + "arch_switch_to_idle_thread \silc_dom_equiv aag (st :: det_state)\" + by (wpsimp wp: silc_dom_lift) + +definition cur_hyp_in_cur_domain :: "det_state \ bool" where + "cur_hyp_in_cur_domain s \ True" + +definition cur_fpu_in_cur_domain :: "det_state \ bool" where + "cur_fpu_in_cur_domain s \ True" + +lemma cur_hyp_in_cur_domain_taut[intro!,simp]: + "cur_hyp_in_cur_domain s" + "cur_hyp_in_cur_domain s = cur_hyp_in_cur_domain s'" + by (simp_all add: cur_hyp_in_cur_domain_def) + +lemma cur_fpu_in_cur_domain_taut[intro!,simp]: + "cur_fpu_in_cur_domain s" + "cur_fpu_in_cur_domain s = cur_fpu_in_cur_domain s'" + by (simp_all add: cur_fpu_in_cur_domain_def) + +lemma cur_hyp_in_cur_domain_wp[Scheduler_IF_assms,wp]: + "\\\ f \\_. cur_hyp_in_cur_domain\" + unfolding cur_hyp_in_cur_domain_def by wp + +lemma cur_fpu_in_cur_domain_wp[Scheduler_IF_assms,wp]: + "\\\ f \\_. cur_fpu_in_cur_domain\" + unfolding cur_fpu_in_cur_domain_def by wp + +declare pas_wellformed_noninterference_domains_distinct[Scheduler_IF_assms] + end +arch_requalify_consts + cur_hyp_in_cur_domain + cur_fpu_in_cur_domain + global_interpretation Scheduler_IF_2?: - Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv + Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv _ cur_hyp_in_cur_domain cur_fpu_in_cur_domain proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Scheduler_IF_assms)?) + by (unfold_locales; (fact Scheduler_IF_assms | solves \wp only: Scheduler_IF_assms; simp\)?) qed diff --git a/proof/infoflow/ARM/ArchSyscall_IF.thy b/proof/infoflow/ARM/ArchSyscall_IF.thy index de737f91b9..6ebcc38d1c 100644 --- a/proof/infoflow/ARM/ArchSyscall_IF.thy +++ b/proof/infoflow/ARM/ArchSyscall_IF.thy @@ -189,7 +189,7 @@ global_interpretation Syscall_IF_1?: Syscall_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Syscall_IF_assms)?) + by (unfold_locales; (fact Syscall_IF_assms | solves \wp only: Syscall_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/ARM/ArchTcb_IF.thy b/proof/infoflow/ARM/ArchTcb_IF.thy index e26ad55331..8db4aeb460 100644 --- a/proof/infoflow/ARM/ArchTcb_IF.thy +++ b/proof/infoflow/ARM/ArchTcb_IF.thy @@ -76,7 +76,7 @@ global_interpretation Tcb_IF_1?: Tcb_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Tcb_IF_assms)?) + by (unfold_locales; (fact Tcb_IF_assms | solves \wp only: Tcb_IF_assms; simp\)?) qed @@ -255,7 +255,7 @@ global_interpretation Tcb_IF_2?: Tcb_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Tcb_IF_assms)?) + by (unfold_locales; (fact Tcb_IF_assms | solves \wp only: Tcb_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/ARM/ArchUserOp_IF.thy b/proof/infoflow/ARM/ArchUserOp_IF.thy index 394b5ac167..f59db01978 100644 --- a/proof/infoflow/ARM/ArchUserOp_IF.thy +++ b/proof/infoflow/ARM/ArchUserOp_IF.thy @@ -124,7 +124,7 @@ global_interpretation UserOp_IF_1?: UserOp_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact UserOp_IF_assms)?) + by (unfold_locales; (fact UserOp_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -919,6 +919,8 @@ lemma dmo_getExMonitor_reads_respects_g: "reads_respects_g aag l (\s. cur_thread s \ idle_thread s) (do_machine_op getExMonitor)" apply (simp add: getExMonitor_def) apply (wp dmo_ev gets_ev'') + prefer 2 + apply assumption apply (clarsimp simp: reads_equiv_g_def globals_equiv_def) done diff --git a/proof/infoflow/ARM/Example_Valid_State.thy b/proof/infoflow/ARM/Example_Valid_State.thy index 106b75d233..09cb287cdb 100644 --- a/proof/infoflow/ARM/Example_Valid_State.thy +++ b/proof/infoflow/ARM/Example_Valid_State.thy @@ -1167,7 +1167,7 @@ lemma domain_sep_inv_s0: "domain_sep_inv False s0_internal s0_internal" apply (clarsimp simp: domain_sep_inv_def) apply (force dest: cte_wp_at_caps_of_state' s0_caps_of_state - | rule conjI allI | clarsimp simp: s0_internal_def)+ + | rule conjI allI | clarsimp simp: s0_internal_def non_kernel_IRQs_def)+ done lemma only_timer_irq_inv_s0: @@ -1833,7 +1833,7 @@ lemma Sys1_valid_initial_state_noenabled: apply (simp add: only_timer_irq_inv_s0 silc_inv_s0 Sys1_pas_cur_domain domain_sep_inv_s0 Sys1_pas_refined Sys1_guarded_pas_domain idle_equiv_refl) - apply (clarsimp simp: obj_valid_pdpt_kh0 valid_domain_list_2_def s0_internal_def exst0_def) + apply (clarsimp simp: obj_valid_pdpt_kh0 valid_domain_list_2_def s0_internal_def exst0_def valid_cur_hyp_def) apply (simp add: det_inv_s0) apply (simp add: s0_internal_def exst0_def) apply (simp add: ct_in_state_def st_tcb_at_tcb_states_of_state_eq diff --git a/proof/infoflow/Arch_IF.thy b/proof/infoflow/Arch_IF.thy index 4ec8da0f3a..cc3256d8bb 100644 --- a/proof/infoflow/Arch_IF.thy +++ b/proof/infoflow/Arch_IF.thy @@ -19,7 +19,6 @@ lemmas [wp] = do_ipc_transfer_valid_arch_no_caps abbreviation irq_state_of_state :: "det_state \ nat" where "irq_state_of_state s \ irq_state (machine_state s)" - crunch cap_insert, cap_swap_for_delete for irq_state_of_state[wp]: "\s. P (irq_state_of_state s)" (wp: crunch_wps) @@ -148,18 +147,12 @@ lemma throw_on_false_reads_respects: \ reads_respects aag l P (throw_on_false ex f)" unfolding throw_on_false_def fun_app_def unlessE_def by wpsimp -lemma dmo_mol_2_reads_respects: - "reads_respects aag l \ (do_machine_op (machine_op_lift mop >>= (\ y. machine_op_lift mop')))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - by (wpsimp wp: machine_op_lift_ev)+ - lemma tl_subseteq: "set (tl xs) \ set xs" by (induct xs, auto) -abbreviation(input) aag_can_read_label where +abbreviation (input) aag_can_read_label where "aag_can_read_label aag l \ l \ subjectReads (pasPolicy aag) (pasSubject aag)" definition labels_are_invisible where @@ -167,38 +160,60 @@ definition labels_are_invisible where (\d \ L. \ aag_can_read_label aag d) \ (aag_can_affect_label aag l \ (\d \ L. d \ subjectReads (pasPolicy aag) l))" - -lemma equiv_but_for_reads_equiv: - "\ pas_domains_distinct aag; labels_are_invisible aag l L; equiv_but_for_labels aag L s s' \ +lemma equiv_but_for_reads_equiv': + "\ pas_domains_distinct aag \ equiv_for (aag_can_read_domain aag) ready_queues s s'; + labels_are_invisible aag l L; equiv_but_for_labels aag L s s' \ \ reads_equiv aag s s'" apply (simp add: reads_equiv_def2) apply (rule conjI) apply (clarsimp simp: labels_are_invisible_def equiv_but_for_labels_def) apply (rule states_equiv_forI) - apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+ - apply (auto intro!: equiv_forI elim!: states_equiv_forE elim!: equiv_forD simp: o_def)[1] - apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+ - apply (fastforce simp: equiv_asids_def elim: states_equiv_forE elim: equiv_forD) + apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+ + apply (auto intro!: equiv_forI elim!: states_equiv_forE elim!: equiv_forD simp: o_def)[1] + apply (fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+ + apply (fastforce simp: equiv_asids_def elim: states_equiv_forE elim: equiv_forD) + apply (fastforce elim!: states_equiv_forE equiv_hyp_guard_imp) + apply (fastforce elim!: states_equiv_forE equiv_fpu_guard_imp) apply (clarsimp simp: equiv_for_def states_equiv_for_def disjoint_iff_not_equal) apply (metis pas_domains_distinct_inj) apply (fastforce simp: equiv_but_for_labels_def) done -lemma equiv_but_for_affects_equiv: - "\ pas_domains_distinct aag; labels_are_invisible aag l L; equiv_but_for_labels aag L s s' \ +lemma equiv_but_for_affects_equiv': + "\ pas_domains_distinct aag \ equiv_for (aag_can_affect_domain aag l) ready_queues s s'; + labels_are_invisible aag l L; equiv_but_for_labels aag L s s' \ \ affects_equiv aag l s s'" apply (subst affects_equiv_def2) apply (clarsimp simp: labels_are_invisible_def equiv_but_for_labels_def aag_can_affect_label_def) apply (rule states_equiv_forI) - apply (fastforce intro!: equiv_forI elim!: states_equiv_forE equiv_forD)+ - apply (fastforce simp: equiv_asids_def elim!: states_equiv_forE elim!: equiv_forD) + apply (fastforce intro!: equiv_forI elim!: states_equiv_forE equiv_forD)+ + apply (fastforce simp: equiv_asids_def elim!: states_equiv_forE elim!: equiv_forD) + apply (fastforce elim!: states_equiv_forE equiv_hyp_guard_imp) + apply (fastforce elim!: states_equiv_forE equiv_fpu_guard_imp) apply (clarsimp simp: equiv_for_def states_equiv_for_def disjoint_iff_not_equal) apply (metis pas_domains_distinct_inj) done +lemmas equiv_but_for_reads_equiv = equiv_but_for_reads_equiv'[OF disjI1] + and equiv_but_for_affects_equiv = equiv_but_for_affects_equiv'[OF disjI1] + +lemma equiv_for_lift: + assumes "\P. m \\s. P (f s)\" + shows "m \\s. equiv_for P f st s\" + and "m \\s. equiv_for P f s st\" + using assms + by (fastforce simp: equiv_for_def valid_def)+ + +lemma equiv_for_lift2: + assumes "\P. m \\s. P (f (g s))\" + shows "m \\s. equiv_for P f st (g s)\" + using assms + by (fastforce simp: equiv_for_def valid_def) + (* consider rewriting the return-value assumption using equiv_valid_rv_inv *) -lemma ev2_invisible: - assumes domains_distinct: "pas_domains_distinct aag" +lemma ev2_invisible': + assumes "pas_domains_distinct aag \ (\P. f \\s. P (ready_queues s)\) \ + (\P. g \\s. P (ready_queues s)\)" shows "\ labels_are_invisible aag l L; labels_are_invisible aag l L'; modifies_at_most aag L Q f; modifies_at_most aag L' Q' g; @@ -210,40 +225,63 @@ lemma ev2_invisible: apply blast apply (drule_tac s=s in modifies_at_mostD, assumption+) apply (drule_tac s=t in modifies_at_mostD, assumption+) - apply (frule (1) equiv_but_for_reads_equiv[OF domains_distinct]) - apply (frule_tac s=t in equiv_but_for_reads_equiv[OF domains_distinct], assumption) - apply (drule (1) equiv_but_for_affects_equiv[OF domains_distinct]) - apply (drule_tac s=t in equiv_but_for_affects_equiv[OF domains_distinct], assumption) - apply (blast intro: reads_equiv_trans reads_equiv_sym affects_equiv_trans affects_equiv_sym) + apply (insert assms) + apply (frule equiv_but_for_reads_equiv'[rotated 2]) + apply (erule disjE; clarsimp intro!: disjCI2) + apply (erule use_valid, wpsimp wp: equiv_for_lift, rule equiv_for_refl) + apply assumption + apply (drule equiv_but_for_affects_equiv'[rotated 2]) + apply (erule disjE; clarsimp intro!: disjCI2) + apply (erule use_valid, wpsimp wp: equiv_for_lift, rule equiv_for_refl) + apply assumption + apply (frule equiv_but_for_reads_equiv'[rotated 2]) + apply (erule disjE; clarsimp intro!: disjCI2) + apply (rule equiv_for_sym, erule use_valid, wpsimp wp: equiv_for_lift, rule equiv_for_refl) + apply assumption + apply (drule equiv_but_for_affects_equiv'[rotated 2]) + apply (erule disjE; clarsimp intro!: disjCI2) + apply (erule use_valid, wpsimp wp: equiv_for_lift, rule equiv_for_refl) + apply assumption + apply (meson reads_equiv_sym reads_equiv_trans affects_equiv_sym affects_equiv_trans) done -lemma ev_invisible: +lemmas ev2_invisible = ev2_invisible'[OF disjI1] + +lemma revrv_invisible: assumes domains_distinct: "pas_domains_distinct aag" shows "\ labels_are_invisible aag l L; modifies_at_most aag L Q f; \s t. P s \ P t \ (\(rva, s') \ fst (f s). \(rvb, t') \ fst(f t). W rva rvb) \ - \ equiv_valid_2 (reads_equiv aag) (affects_equiv aag l) (affects_equiv aag l) - W (P and Q) (P and Q) f f" + \ reads_equiv_valid_rv_inv (affects_equiv aag l) aag W (P and Q) f" by (rule ev2_invisible[OF domains_distinct]; simp) -lemma modify_det: - "det (modify f)" - by (clarsimp simp: det_def modify_def get_def put_def bind_def) +lemma reads_respects_unit_invisible: + "\ labels_are_invisible aag l L; modifies_at_most aag L P f; \P. f \\s. P (ready_queues s)\ \ + \ reads_respects aag l P (f :: (det_state,unit) nondet_monad)" + apply (rule equiv_valid_guard_imp) + apply (simp add: equiv_valid_def2) + apply (rule ev2_invisible') + by simp+ + +lemma reads_respects_unit_cases': + "\ reads_respects aag l (P and K (aag_can_read_or_affect aag l ptr)) f; + modifies_at_most aag {pasObjectAbs aag ptr} (Q and K (\ aag_can_read_or_affect aag l ptr)) f; + \P. f \\s. P (ready_queues s)\ \ + \ reads_respects aag l (if aag_can_read_or_affect aag l ptr then P else Q) (f :: (det_state,unit) nondet_monad)" + apply (case_tac "aag_can_read_or_affect aag l ptr") + apply clarsimp + apply (rule_tac L="{pasObjectAbs aag ptr}" in reads_respects_unit_invisible) + apply (clarsimp simp: labels_are_invisible_def) + apply (clarsimp simp: modifies_at_most_def) + apply simp + done + +lemmas reads_respects_unit_cases = reads_respects_unit_cases'[OF _ modifies_at_mostI] lemma dummy_kheap_update: "st = st\kheap := kheap st\" by simp -lemma reads_affects_equiv_kheap_eq: - "\ reads_equiv aag s s'; affects_equiv aag l s s'; aag_can_affect aag l x \ aag_can_read aag x \ - \ kheap s x = kheap s' x" - by (fastforce elim: affects_equivE reads_equivE equiv_forE) - -lemma reads_affects_equiv_get_tcb_eq: - "\ aag_can_read aag t \ aag_can_affect aag l t; reads_equiv aag s s'; affects_equiv aag l s s' \ - \ get_tcb t s = get_tcb t s'" - by (fastforce simp: get_tcb_def reads_affects_equiv_kheap_eq) - lemma equiv_valid_get_assert: "equiv_valid_inv I A P f \ equiv_valid_inv I A P (get >>= (\ s. assert (g s) >>= (\ y. f)))" @@ -409,23 +447,22 @@ locale Arch_IF_1 = "\globals_equiv s and valid_arch_state\ set_endpoint ptr ep \\_. globals_equiv s\" - and set_cap_globals_equiv'': - "\globals_equiv s and valid_arch_state\ - set_cap cap p - \\_. globals_equiv s\" and set_thread_state_globals_equiv: "\globals_equiv s and valid_arch_state\ set_thread_state ref ts \\_. globals_equiv s\" - and as_user_globals_equiv: - "\f :: unit user_monad. - \globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ - as_user tptr f - \\_. globals_equiv s\" + and thread_set_non_idle_globals_equiv: + "\globals_equiv st and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv st\" and arch_prepare_set_domain_irq_state_of_state[wp]: "arch_prepare_set_domain t new_dom \\s. P (irq_state_of_state s)\" and arch_prepare_next_domain_irq_state_of_state[wp]: "arch_prepare_next_domain \\s. P (irq_state_of_state s)\" + and equiv_hyp_machine_state_rest_update[simp]: + "\P. equiv_hyp P st (s\machine_state := ms\machine_state_rest := rest\\) = equiv_hyp P st (s\machine_state := ms\)" + and equiv_fpu_machine_state_rest_update[simp]: + "\P. equiv_fpu P st (s\machine_state := ms\machine_state_rest := rest\\) = equiv_fpu P st (s\machine_state := ms\)" begin crunch empty_slot @@ -465,7 +502,7 @@ lemma mol_states_equiv_for: apply (simp add: machine_rest_lift_def split_def) apply (wp modify_wp) apply (clarsimp simp: states_equiv_for_def equiv_asids_def) - apply (fastforce elim!: equiv_forE intro!: equiv_forI) + apply (auto elim!: equiv_forE intro!: equiv_forI) done lemma do_machine_op_mol_states_equiv_for: @@ -488,17 +525,15 @@ lemma set_mrs_reads_respects: "reads_respects aag l (K (aag_can_read aag t \ aag_can_affect aag l t)) (set_mrs t buf msgs)" apply (simp add: set_mrs_def cong: option.case_cong_weak) apply (wp mapM_x_ev' store_word_offs_reads_respects set_object_reads_respects - | wpc | simp add: split_def split del: if_split add: zipWithM_x_mapM_x)+ + | wpc | simp add: split_def split del: if_split add: zipWithM_x_mapM_x)+ apply (auto intro: reads_affects_equiv_get_tcb_eq) done -lemma cap_insert_globals_equiv'': - "\globals_equiv s and valid_global_objs and valid_arch_state\ - cap_insert new_cap src_slot dest_slot +lemma as_user_globals_equiv[wp]: + "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ + as_user tptr f \\_. globals_equiv s\" - unfolding cap_insert_def - by (wpsimp wp: set_original_globals_equiv update_cdt_globals_equiv - set_cap_globals_equiv'' dxo_wp_weak hoare_drop_imps) + by (wpsimp wp: as_user_wp_thread_set_helper thread_set_non_idle_globals_equiv) lemma set_message_info_globals_equiv: "\globals_equiv s and valid_arch_state and (\s. thread \ idle_thread s)\ diff --git a/proof/infoflow/CNode_IF.thy b/proof/infoflow/CNode_IF.thy index 6f389db0b1..ec3dd5e7c5 100644 --- a/proof/infoflow/CNode_IF.thy +++ b/proof/infoflow/CNode_IF.thy @@ -46,7 +46,7 @@ lemma get_object_rev: lemma get_cap_rev: "reads_equiv_valid_inv A aag (K (aag_can_read aag (fst slot))) (get_cap slot)" unfolding get_cap_def - by (wp get_object_rev | wpc | simp add: split_def)+ + by (wpsimp wp: get_object_rev) declare if_weak_cong[cong] @@ -321,14 +321,9 @@ locale CNode_IF_1 = fixes state_ext_t :: "'s :: state_ext itself" and irq_at :: "nat \ (irq \ bool) \ irq option" assumes set_cap_globals_equiv: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ set_cap cap p \\_. globals_equiv s\" - and dmo_getActiveIRQ_wp: - "\\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) - (s\machine_state := machine_state s\irq_state := irq_state (machine_state s) + 1\\)\ - do_machine_op (getActiveIRQ in_kernel) - \\rv s :: 's state. P rv s\" and arch_globals_equiv_irq_state_update[simp]: "arch_globals_equiv ct it kh kh' as as' ms (irq_state_update f ms') = arch_globals_equiv ct it kh kh' as as' ms ms'" @@ -340,7 +335,7 @@ crunch set_untyped_cap_as_full for globals_equiv[wp]: "globals_equiv st" lemma cap_insert_globals_equiv: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ cap_insert new_cap src_slot dest_slot \\_. globals_equiv s\" unfolding cap_insert_def fun_app_def @@ -348,14 +343,14 @@ lemma cap_insert_globals_equiv: set_cap_globals_equiv hoare_drop_imps dxo_wp_weak) lemma cap_move_globals_equiv: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ cap_move new_cap src_slot dest_slot \\_. globals_equiv s\" unfolding cap_move_def fun_app_def by (wpsimp wp: set_original_globals_equiv set_cdt_globals_equiv set_cap_globals_equiv dxo_wp_weak) lemma cap_swap_globals_equiv: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ cap_swap cap1 slot1 cap2 slot2 \\_. globals_equiv s\" unfolding cap_swap_def @@ -478,12 +473,6 @@ lemma only_timer_irq_inv_determines_irq_masks: apply fastforce+ done -lemma dmo_getActiveIRQ_globals_equiv: - "\globals_equiv st\ do_machine_op (getActiveIRQ in_kernel) \\_. globals_equiv st\" - apply (wp dmo_getActiveIRQ_wp) - apply (auto simp: globals_equiv_def idle_equiv_def) - done - crunch reset_work_units, work_units_limit_reached, update_work_units for only_timer_irq_inv[wp]: "only_timer_irq_inv irq st" (simp: only_timer_irq_inv_def only_timer_irq_def irq_is_recurring_def is_irq_at_def) @@ -660,9 +649,11 @@ locale CNode_IF_3 = CNode_IF_2 + fixes aag :: "'a subject_label PAS" assumes dmo_getActiveIRQ_reads_respects: "reads_respects aag l (invs and only_timer_irq_inv irq st) (do_machine_op (getActiveIRQ in_kernel))" + and dmo_getActiveIRQ_globals_equiv: + "do_machine_op (getActiveIRQ in_kernel) \globals_equiv st\" begin -lemma dmo_getActiveIRQ_reads_respects_g : +lemma dmo_getActiveIRQ_reads_respects_g: "reads_respects_g aag l (invs and only_timer_irq_inv irq st) (do_machine_op (getActiveIRQ in_kernel))" apply (rule equiv_valid_guard_imp[OF reads_respects_g]) apply (rule dmo_getActiveIRQ_reads_respects) @@ -736,18 +727,6 @@ lemma reads_respects_f_g: apply (fastforce intro: globals_equivI) done -lemma reads_equiv_valid_rv_inv_f: - assumes a: "reads_equiv_valid_rv_inv A aag R P f" - assumes b: "\P. \P\ f \\_. P\" - shows "equiv_valid_rv_inv (reads_equiv_f aag) A R P f" - apply (clarsimp simp: equiv_valid_2_def reads_equiv_f_def) - apply (insert a, clarsimp simp: equiv_valid_2_def) - apply (drule_tac x=s in spec, drule_tac x=t in spec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply (drule (1) bspec, clarsimp) - apply (drule state_unchanged[OF b])+ - by simp - lemma set_cap_silc_inv': "\silc_inv aag st and (\s. \ cap_points_to_label aag cap (pasObjectAbs aag (fst slot)) \ (\lslot. lslot \ slots_holding_overlapping_caps cap s \ diff --git a/proof/infoflow/Decode_IF.thy b/proof/infoflow/Decode_IF.thy index de4b28b31a..328d1132d3 100644 --- a/proof/infoflow/Decode_IF.thy +++ b/proof/infoflow/Decode_IF.thy @@ -268,7 +268,7 @@ lemma decode_irq_control_invocation_rev: | simp add: Let_def)+ apply safe apply simp+ - apply (blast intro: aag_Control_into_owns_irq ) + apply (blast intro: aag_Control_into_owns_irq) apply (drule_tac x="caps ! 0" in bspec) apply (fastforce intro: bang_0_in_set) apply (drule (1) is_cnode_into_is_subject; blast dest: prop_of_obj_ref_of_cnode_cap) @@ -347,7 +347,7 @@ begin lemma decode_invocation_reads_respects_f: "reads_respects_f aag l - (silc_inv aag st and pas_refined aag and valid_cap cap and invs and ct_active + (silc_inv aag st and pas_refined aag and invs and ct_active and domain_sep_inv irqs st' and cte_wp_at ((=) cap) slot and ex_cte_cap_to slot and (\s. \r\zobj_refs cap. ex_nonz_cap_to r s) diff --git a/proof/infoflow/FinalCaps.thy b/proof/infoflow/FinalCaps.thy index 64e2747f44..b46eb3a0f9 100644 --- a/proof/infoflow/FinalCaps.thy +++ b/proof/infoflow/FinalCaps.thy @@ -335,16 +335,12 @@ locale FinalCaps_1 = "arch_finalise_cap c x \silc_inv aag st\" and prepare_thread_delete_silc_inv[wp]: "prepare_thread_delete p \silc_inv aag st\" - and handle_reserved_irq_silc_inv[wp]: - "handle_reserved_irq irq \silc_inv aag st\" - and arch_mask_irq_signal_silc_inv[wp]: - "arch_mask_irq_signal irq \silc_inv aag st\" and handle_vm_fault_silc_inv[wp]: "handle_vm_fault t vmft \silc_inv aag st\" + and arch_mask_irq_signal_silc_inv[wp]: + "arch_mask_irq_signal irq \silc_inv aag st\" and handle_vm_fault_cur_thread[wp]: "\P. handle_vm_fault t vmft \\s :: det_state. P (cur_thread s)\" - and handle_hypervisor_fault_silc_inv[wp]: - "handle_hypervisor_fault t hvft \silc_inv aag st\" and arch_activate_idle_threadt_silc_inv[wp]: "arch_activate_idle_thread t \silc_inv aag st\" and arch_switch_to_idle_thread_silc_inv[wp]: @@ -2714,15 +2710,15 @@ end lemma thread_set_tcb_ipc_buffer_update_silc_inv[wp]: - "\silc_inv aag st\ - thread_set (tcb_ipc_buffer_update blah) t - \\_. silc_inv aag st\" + "thread_set (tcb_ipc_buffer_update f) t \silc_inv aag st\" by (rule thread_set_silc_inv; simp add: tcb_cap_cases_def) lemma thread_set_tcb_fault_handler_update_silc_inv[wp]: - "\silc_inv aag st\ - thread_set (tcb_fault_handler_update blah) t - \\_. silc_inv aag st\" + "thread_set (tcb_fault_handler_update f) t \silc_inv aag st\" + by (rule thread_set_silc_inv; simp add: tcb_cap_cases_def) + +lemma thread_set_tcb_arch_update_silc_inv[wp]: + "thread_set (tcb_arch_update f) t \silc_inv aag st\" by (rule thread_set_silc_inv; simp add: tcb_cap_cases_def) lemma thread_set_tcb_fault_handler_update_invs: @@ -2846,7 +2842,7 @@ lemma handle_reply_silc_inv: handle_reply \\_. silc_inv aag st\" unfolding handle_reply_def - apply (wp hoare_vcg_all_lift get_cap_wp | wpc )+ + apply (wp hoare_vcg_all_lift get_cap_wp | wpc)+ by (force dest: cap_auth_caps_of_state silc_inv_not_subject simp: cte_wp_at_caps_of_state aag_cap_auth_def cap_auth_conferred_def reply_cap_rights_to_auth_def @@ -2885,10 +2881,58 @@ crunch timer_tick, handle_yield for silc_inv[wp]: "silc_inv aag st" (simp: tcb_cap_cases_def) +end + + +locale FinalCaps_3 = FinalCaps_2 + + assumes handle_reserved_irq_silc_inv[wp]: + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + handle_reserved_irq irq + \\_. silc_inv aag st\" + and handle_hypervisor_fault_silc_inv[wp]: + "\silc_inv aag st and invs and pas_refined aag and is_subject aag o cur_thread and K (is_subject aag t)\ + handle_hypervisor_fault t hvft + \\_. silc_inv aag st\" + and handle_reserved_irq_in_kernel_inv: + "\P and K (irq \ non_kernel_IRQs)\ + handle_reserved_irq irq + \\_. P :: det_state \ bool\" +begin + lemma handle_interrupt_silc_inv: - "handle_interrupt irq \silc_inv aag st\" + "\silc_inv aag st and invs and pas_refined aag and (\s. ct_active s \ is_subject aag (cur_thread s))\ + handle_interrupt irq + \\_. silc_inv aag st\" unfolding handle_interrupt_def by (wpsimp wp: hoare_drop_imps) +(* FIXME: cleanup *) +lemma irq_inactive_or_timer: + "\domain_sep_inv False st and Q IRQTimer and Q IRQInactive\ + get_irq_state irq + \Q\" + apply (simp add:get_irq_state_def) + apply wp + apply (clarsimp simp add: domain_sep_inv_def) + apply (drule_tac x=irq in spec) + apply (case_tac "interrupt_states st irq") + by fastforce+ + +lemma handle_interrupt_silc_inv': + "\silc_inv aag st and domain_sep_inv False st\ + handle_interrupt irq + \\_. silc_inv aag st\" + unfolding handle_interrupt_def + apply (wpsimp wp: irq_inactive_or_timer) + apply fastforce + done + +lemma handle_interrupt_in_kernel_silc_inv: + "\silc_inv aag st and K (irq \ non_kernel_IRQs)\ + handle_interrupt irq + \\_. silc_inv aag st\" + unfolding handle_interrupt_def get_irq_state_def + by (wpsimp wp: handle_reserved_irq_in_kernel_inv) + lemma handle_event_silc_inv: "\silc_inv aag st and einvs and simple_sched_action and pas_refined aag and domain_sep_inv (pasMaySendIrqs aag) st' @@ -2896,7 +2940,7 @@ lemma handle_event_silc_inv: and (\s. ct_active s \ is_subject aag (cur_thread s))\ handle_event ev \\_. silc_inv aag st\" - apply (case_tac ev; simp_all add: maybe_handle_interrupt_def) + apply (case_tac ev; simp_all add: maybe_handle_interrupt_def) by (wpsimp wp: handle_send_silc_inv[where st'=st'] handle_call_silc_inv[where st'=st'] handle_recv_silc_inv @@ -2904,7 +2948,8 @@ lemma handle_event_silc_inv: handle_interrupt_silc_inv handle_vm_fault_silc_inv handle_hypervisor_fault_silc_inv - simp: invs_valid_objs invs_mdb invs_sym_refs)+ + simp: invs_valid_objs invs_mdb invs_sym_refs + | wp (once) hoare_drop_imps)+ crunch activate_thread for silc_inv[wp]: "silc_inv aag st" @@ -2915,6 +2960,7 @@ crunch schedule ignore: set_scheduler_action simp: crunch_simps) +(* FIXME IF: delete if unused *) lemma call_kernel_silc_inv: "\silc_inv aag st and einvs and simple_sched_action and pas_refined aag and (\s. ev \ Interrupt \ ct_active s) @@ -2922,7 +2968,13 @@ lemma call_kernel_silc_inv: call_kernel ev \\_. silc_inv aag st\" unfolding call_kernel_def maybe_handle_interrupt_def - by (wpsimp wp: handle_interrupt_silc_inv handle_event_silc_inv[where st'=st']) + apply (wpsimp wp: handle_interrupt_in_kernel_silc_inv handle_event_silc_inv[where st'=st']) + apply (rule_tac Q'="\rv s. rv \ Some ` non_kernel_IRQs \ silc_inv aag st s" in hoare_strengthen_post[rotated]) + apply clarsimp + apply (wpsimp wp: getActiveIRQ_neq_non_kernel) + apply (wpsimp wp: handle_event_silc_inv[where st'=st']) + apply clarsimp + done end diff --git a/proof/infoflow/Finalise_IF.thy b/proof/infoflow/Finalise_IF.thy index 683c46a28e..2a6d1cff57 100644 --- a/proof/infoflow/Finalise_IF.thy +++ b/proof/infoflow/Finalise_IF.thy @@ -30,7 +30,7 @@ locale Finalise_IF_1 = and set_bound_notification_none_reads_respects: "pas_domains_distinct aag \ reads_respects aag l \ (set_bound_notification ref None)" and thread_set_reads_respects: - "pas_domains_distinct aag \ reads_respects aag l \ (thread_set x y)" + "reads_respects aag l \ (thread_set f thread)" and set_tcb_queue_reads_respects[wp]: "reads_respects aag l \ (set_tcb_queue d prio queue)" and set_notification_equiv_but_for_labels: @@ -38,9 +38,13 @@ locale Finalise_IF_1 = set_notification ntfnptr ntfn \\_. equiv_but_for_labels aag L st\" and prepare_thread_delete_reads_respects_f: - "reads_respects_f aag l \ (prepare_thread_delete t)" + "pas_domains_distinct aag + \ reads_respects_f aag l (silc_inv aag st and pas_refined aag and valid_arch_state + and valid_cur_fpu and K (is_subject aag thread)) + (prepare_thread_delete thread)" and arch_finalise_cap_reads_respects: - "reads_respects aag l (pas_refined aag and invs and cte_wp_at ((=) (ArchObjectCap cap)) slot + "pas_domains_distinct aag + \ reads_respects aag l (pas_refined aag and invs and cte_wp_at ((=) (ArchObjectCap cap)) slot and K (pas_cap_cur_auth aag (ArchObjectCap cap))) (arch_finalise_cap cap is_final)" and arch_finalise_cap_makes_halted: @@ -65,7 +69,7 @@ locale Finalise_IF_1 = arch_finalise_cap acap ex \\_. globals_equiv st\" and prepare_thread_delete_globals_equiv[wp]: - "prepare_thread_delete t \globals_equiv st\" + "\globals_equiv s and invs\ prepare_thread_delete t \\_. globals_equiv s\" begin lemma set_irq_state_reads_respects: @@ -528,6 +532,13 @@ crunch set_simple_ko for sched_act[wp]: "\s. P (scheduler_action s)" (wp: crunch_wps) +lemma thread_get_reads_respects: + "reads_respects aag l (K (aag_can_read aag thread \ aag_can_affect aag l thread)) + (thread_get f thread)" + unfolding thread_get_def fun_app_def + apply (wp gets_the_ev) + apply (auto intro: reads_affects_equiv_get_tcb_eq) + done context Finalise_IF_1 begin @@ -545,18 +556,17 @@ lemma tcb_sched_action_reads_respects: apply (simp add: tcb_sched_action_def get_tcb_queue_def) apply (subst gets_apply) apply (case_tac "aag_can_read aag t \ aag_can_affect aag l t") - apply (simp add: thread_get_def) apply wp - apply (rule_tac Q="\s. pasObjectAbs aag t \ pasDomainAbs aag (tcb_domain rv)" + apply (rule_tac Q="\s. pasObjectAbs aag t \ pasDomainAbs aag rv" in equiv_valid_guard_imp) - apply (wp gets_apply_ev') + apply (wp gets_apply_ev) apply (fastforce simp: reads_equiv_def affects_equiv_def equiv_for_def states_equiv_for_def) - apply (wp | simp)+ + apply (wp thread_get_reads_respects | simp)+ apply (intro conjI impI allI | fastforce simp: get_tcb_def elim: reads_equivE affects_equivE equiv_forE)+ apply (clarsimp simp: pas_refined_def tcb_domain_map_wellformed_aux_def split: option.splits) - apply (erule_tac x="(t, tcb_domain y)" in ballE, force) - apply (force intro: domtcbs simp: get_tcb_Some etcbs_of'_def) + apply (erule_tac x="(t, tcb_domain tcb)" in ballE, force) + apply (force intro: domtcbs simp: obj_at_def get_tcb_Some etcbs_of'_def) apply (simp add: equiv_valid_def2 thread_get_def) apply (rule equiv_valid_rv_bind) apply (wpsimp wp: equiv_valid_rv_trivial') @@ -695,14 +705,6 @@ lemma get_bound_notification_reads_respects': apply simp+ done -lemma thread_get_reads_respects: - "reads_respects aag l (K (aag_can_read aag thread \ aag_can_affect aag l thread)) - (thread_get f thread)" - unfolding thread_get_def fun_app_def - apply (wp gets_the_ev) - apply (auto intro: reads_affects_equiv_get_tcb_eq) - done - lemma get_bound_notification_reads_respects: "reads_respects aag l (\ s. aag_can_read aag thread \ aag_can_affect aag l thread) (get_bound_notification thread)" @@ -956,7 +958,7 @@ lemma cancel_signal_owned_reads_respects: lemma as_user_get_register_reads_respects: "reads_respects aag l (K (is_subject aag thread)) (as_user thread (getRegister reg))" - by (fastforce simp: equiv_valid_guard_imp[OF as_user_reads_respects] det_getRegister) + by (wpsimp wp: as_user_reads_respects simp: det_getRegister) lemma update_restart_pc_reads_respects[wp]: assumes domains_distinct[wp]: "pas_domains_distinct aag" @@ -1040,6 +1042,14 @@ lemma deleting_irq_handler_reads_respects: by (wp cap_delete_one_reads_respects_f reads_respects_f[OF get_irq_slot_reads_respects] | simp | blast)+ +crunch unbind_notification, set_original, fast_finalise + for valid_arch_state[wp]: "valid_arch_state" + (wp: dxo_wp_weak mapM_x_wp) + +crunch suspend + for valid_arch_state[wp]: "\s :: det_state. valid_arch_state s" + (wp: mapM_x_wp_inv crunch_wps simp: crunch_simps tcb_cap_cases_def) + lemma finalise_cap_reads_respects: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows @@ -1056,7 +1066,7 @@ lemma finalise_cap_reads_respects: suspend_reads_respects_f[where st=st] deleting_irq_handler_reads_respects unbind_notification_is_subj_reads_respects unbind_maybe_notification_reads_respects - unbind_notification_invs unbind_maybe_notification_invs + unbind_notification_invs unbind_maybe_notification_invs suspend_silc_inv | simp add: when_def invs_valid_objs invs_sym_refs aag_cap_auth_def cap_auth_conferred_def cap_rights_to_auth_def cap_links_irq_def aag_has_Control_iff_owns cte_wp_at_caps_of_state @@ -1464,7 +1474,7 @@ crunch set_original lemma empty_slot_globals_equiv: "\globals_equiv st and valid_arch_state\ empty_slot s b \\_. globals_equiv st\" unfolding empty_slot_def post_cap_deletion_def - by (wpsimp wp: set_cap_globals_equiv'' set_original_globals_equiv hoare_vcg_if_lift2 + by (wpsimp wp: set_cap_globals_equiv set_original_globals_equiv hoare_vcg_if_lift2 set_cdt_globals_equiv dxo_wp_weak hoare_drop_imps hoare_vcg_all_lift) crunch fast_finalise @@ -1473,7 +1483,7 @@ crunch fast_finalise crunch cap_delete_one for globals_equiv: "globals_equiv st" - (wp: set_cap_globals_equiv'' hoare_drop_imps simp: crunch_simps unless_def) + (wp: set_cap_globals_equiv hoare_drop_imps simp: crunch_simps unless_def) (*FIXME: Lots of this stuff should be in arch *) crunch deleting_irq_handler @@ -1505,7 +1515,7 @@ lemma finalise_cap_globals_equiv: by (wp cancel_all_ipc_globals_equiv cancel_all_ipc_valid_global_objs cancel_all_signals_globals_equiv cancel_all_signals_valid_global_objs arch_finalise_cap_globals_equiv unbind_maybe_notification_globals_equiv - unbind_notification_globals_equiv liftM_wp when_def + unbind_notification_invs unbind_notification_globals_equiv liftM_wp when_def | clarsimp simp: valid_cap_def | intro impI conjI)+ end diff --git a/proof/infoflow/IRQMasks_IF.thy b/proof/infoflow/IRQMasks_IF.thy index 5dc06f4fd2..9168933851 100644 --- a/proof/infoflow/IRQMasks_IF.thy +++ b/proof/infoflow/IRQMasks_IF.thy @@ -60,8 +60,6 @@ locale IRQMasks_IF_1 = "send_signal ntfnptr badge \\s. P (irq_masks_of_state s)\" and handle_vm_fault_irq_masks[wp]: "handle_vm_fault t vmft \\s. P (irq_masks_of_state s)\" - and handle_hypervisor_fault_irq_masks[wp]: - "handle_hypervisor_fault t hvft \\s. P (irq_masks_of_state s)\" and handle_interrupt_irq_masks: "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and K (irq \ maxIRQ)\ handle_interrupt irq @@ -78,8 +76,6 @@ locale IRQMasks_IF_1 = \\rv s :: det_state. (\x. rv = Some x \ x \ maxIRQ)\" and activate_thread_irq_masks[wp]: "activate_thread \\s. P (irq_masks_of_state s)\" - and schedule_irq_masks[wp]: - "schedule \\s. P (irq_masks_of_state s)\" and handle_spurious_irq_masks[wp]: "handle_spurious_irq \\s. P (irq_masks_of_state s)\" begin @@ -287,14 +283,29 @@ locale IRQMasks_IF_2 = IRQMasks_IF_1 state_t for state_t :: "'s :: state_ext state" + assumes do_reply_transfer_irq_masks[wp]: "do_reply_transfer sender receiver slot grant \\s. P (irq_masks_of_state s)\" - and arch_perform_invocation_irq_masks[wp]: - "arch_perform_invocation i \\s. P (irq_masks_of_state s)\" + and arch_perform_invocation_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st\ + arch_perform_invocation i + \\rv s. P (irq_masks_of_state s)\" and arch_prepare_set_domain_irq_masks_of_state[wp]: "arch_prepare_set_domain t new_dom \\s. P (irq_masks_of_state s)\" and invoke_tcb_irq_masks: "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and tcb_inv_wf tinv\ invoke_tcb tinv \\_ s. P (irq_masks_of_state s)\" + and handle_hypervisor_fault_irq_masks[wp]: + "handle_hypervisor_fault t hvft \\s. P (irq_masks_of_state s)\" + and arch_switch_to_idle_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + arch_switch_to_idle_thread \\rv s. P (irq_masks_of_state s)\" + and arch_switch_to_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False st and valid_irq_states\ + arch_switch_to_thread t + \\rv s. P (irq_masks_of_state s)\" + and arch_prepare_next_domain_irq_masks[wp]: + "arch_prepare_next_domain \\s. P (irq_masks_of_state s)\" + and arch_prepare_next_domain_valid_irq_states[wp]: + "arch_prepare_next_domain \\s :: det_state. valid_irq_states s\" begin crunch invoke_domain @@ -311,6 +322,7 @@ lemma perform_invocation_irq_masks: by (wpsimp wp: invoke_tcb_irq_masks invoke_cnode_irq_masks[where st=st] invoke_irq_control_irq_masks[where st=st] invoke_irq_handler_irq_masks[where st=st] + arch_perform_invocation_irq_masks[where st=st] | fastforce)+ lemma handle_invocation_irq_masks: @@ -349,22 +361,71 @@ lemma handle_event_irq_masks: apply wpsimp+ done -lemma call_kernel_irq_masks: - "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and einvs - and (\s. ev \ Interrupt \ ct_active s)\ - call_kernel ev +lemma switch_to_idle_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + switch_to_idle_thread \\rv s. P (irq_masks_of_state s)\" - apply (simp add: call_kernel_def maybe_handle_interrupt_def) - apply (wpsimp wp: handle_interrupt_irq_masks[where st=st]) - apply (rule_tac Q'="\rv s. P (irq_masks_of_state s) \ domain_sep_inv False st s \ - (\x. rv = Some x \ x \ maxIRQ)" in hoare_strengthen_post) - apply (wp | simp)+ - apply (rule_tac Q'="\x s. P (irq_masks_of_state s) \ domain_sep_inv False st s" - and E="E" for E in hoare_strengthen_postE) - apply (rule valid_validE) - apply (wp handle_event_irq_masks[where st=st] valid_validE[OF handle_event_domain_sep_inv] - | simp)+ - done + unfolding switch_to_idle_thread_def + by (wpsimp wp: arch_switch_to_idle_thread_irq_masks[where st=st]) + +lemma switch_to_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + switch_to_thread t + \\rv s. P (irq_masks_of_state s)\" + unfolding switch_to_thread_def + by (wpsimp wp: arch_switch_to_thread_irq_masks[where st=st]) + +lemma guarded_switch_to_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + guarded_switch_to t + \\rv s. P (irq_masks_of_state s)\" + unfolding guarded_switch_to_def + by (wpsimp wp: switch_to_thread_irq_masks[where st=st] hoare_drop_imps) + +lemma choose_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + choose_thread + \\rv s. P (irq_masks_of_state s)\" + unfolding choose_thread_def + by (wpsimp wp: guarded_switch_to_irq_masks[where st=st] + switch_to_idle_thread_irq_masks[where st=st]) + +lemma do_extended_op_irq_masks[wp]: + "do_extended_op f \\s. P (irq_masks_of_state s)\" + by (wpsimp wp: dxo_wp_weak) + +lemma do_extended_op_valid_irq_states[wp]: + "do_extended_op f \valid_irq_states\" + by (wpsimp wp: dxo_wp_weak) + +lemma valid_irq_states_domain_index_update[simp]: + "valid_irq_states (domain_index_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +lemma valid_irq_states_cur_domain_update[simp]: + "valid_irq_states (cur_domain_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +crunch next_domain + for irq_masks[wp]: "\s. P (irq_masks_of_state s)" + and valid_irq_states[wp]: "valid_irq_states" + (simp: crunch_simps) + +lemma schedule_choose_new_thread_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + schedule_choose_new_thread + \\rv s. P (irq_masks_of_state s)\" + unfolding schedule_choose_new_thread_def + by (wpsimp wp: choose_thread_irq_masks[where st=st]) + +lemma schedule_irq_masks: + "\(\s. P (irq_masks_of_state s)) and domain_sep_inv False (st :: 's state) and valid_irq_states\ + schedule + \\rv s. P (irq_masks_of_state s)\" + unfolding schedule_def + by (wpsimp wp: schedule_choose_new_thread_irq_masks[where st=st] + guarded_switch_to_irq_masks[where st=st] + hoare_drop_imps gts_wp) end diff --git a/proof/infoflow/InfoFlow.thy b/proof/infoflow/InfoFlow.thy index 39a035f50f..24936ddd2c 100644 --- a/proof/infoflow/InfoFlow.thy +++ b/proof/infoflow/InfoFlow.thy @@ -156,9 +156,35 @@ abbreviation aag_can_read_domain :: "'a PAS \ domain \ b subsection \Generic equivalence\ -definition equiv_for where +defs equiv_for_def: "equiv_for P f c c' \ \x. P x \ f c x = f c' x" +definition identical_updates_rv where + "identical_updates_rv R s t s' t' \ (\R s' t' \ (R s s' \ R t t'))" + +abbreviation identical_updates_for_rv where + "identical_updates_for_rv P R s t s' t' \ \x. P x \ identical_updates_rv R (s x) (t x) (s' x) (t' x)" + +abbreviation identical_updates_for where + "identical_updates_for P \ identical_updates_for_rv P (=)" + +abbreviation identical_updates where + "identical_updates \ identical_updates_for (\_. True)" + +lemmas identical_updates_def = identical_updates_rv_def + +abbreviation identical_kheap_updates where + "identical_kheap_updates s s' kh kh' \ identical_updates (kheap s) (kheap s') kh kh'" + +lemmas identical_kheap_updates_def = identical_updates_def + + +subsection \Arch equivalence\ + +arch_requalify_consts + equiv_hyp + equiv_fpu + subsection \Machine state equivalence\ @@ -173,14 +199,6 @@ subsection \ASID equivalence\ definition equiv_asids :: "(asid \ bool) \ det_state \ det_state \ bool" where "equiv_asids R s s' \ \asid. asid \ 0 \ R asid \ equiv_asid asid s s'" -definition identical_updates where - "identical_updates k k' kh kh' \ \x. (kh x \ kh' x \ (k x = kh x \ k' x = kh' x))" - -abbreviation identical_kheap_updates where - "identical_kheap_updates s s' kh kh' \ identical_updates (kheap s) (kheap s') kh kh'" - -lemmas identical_kheap_updates_def = identical_updates_def - subsection \Generic state equivalence\ @@ -207,7 +225,9 @@ definition states_equiv_for :: equiv_for Q interrupt_states s s' \ equiv_for Q interrupt_irq_node s s' \ equiv_for S ready_queues s s' \ - equiv_asids R s s'" + equiv_asids R s s' \ + equiv_hyp P s s' \ + equiv_fpu P s s'" (* This the main use of states_equiv_for : P is use to restrict the labels we want to consider *) abbreviation states_equiv_for_labels :: @@ -361,6 +381,9 @@ abbreviation aag_can_affect_domain where "aag_can_affect_domain aag l \ \x. aag_can_affect_label aag l \ pasDomainAbs aag x \ subjectReads (pasPolicy aag) l \ {}" +abbreviation (input) aag_can_read_or_affect where + "aag_can_read_or_affect aag l \ \x. aag_can_read aag x \ aag_can_affect aag l x" + section \reads_respects\ diff --git a/proof/infoflow/InfoFlow_IF.thy b/proof/infoflow/InfoFlow_IF.thy index 09b0885b6c..829c6e9fbb 100644 --- a/proof/infoflow/InfoFlow_IF.thy +++ b/proof/infoflow/InfoFlow_IF.thy @@ -78,6 +78,8 @@ lemma states_equiv_forI: equiv_for Q interrupt_states s s'; equiv_for Q interrupt_irq_node s s'; equiv_asids R s s'; + equiv_hyp P s s'; + equiv_fpu P s s'; equiv_for S ready_queues s s' \ \ states_equiv_for P Q R S s s'" by (auto simp: states_equiv_for_def) @@ -85,79 +87,156 @@ lemma states_equiv_forI: definition for_each_byte_of_word :: "(obj_ref \ bool) \ obj_ref \ bool" where "for_each_byte_of_word P w \ \y\{w..w + (word_size - 1)}. P y" + locale InfoFlow_IF_1 = - fixes aag :: "'a PAS" + fixes identical_hyp_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" + and identical_fpu_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" + \ \equiv_asids lemmas\ assumes equiv_asids_refl: "equiv_asids R s s" and equiv_asids_sym: "equiv_asids R s t \ equiv_asids R t s" and equiv_asids_trans: "\ equiv_asids R s t; equiv_asids R t u \ \ equiv_asids R s u" + and equiv_asids_guard_imp: + "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" and equiv_asids_identical_kheap_updates: "\ equiv_asids R s s'; identical_kheap_updates s s' kh kh' \ - \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" - and equiv_asids_False: - "(\x. P x \ False) \ equiv_asids P x y" + \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" and equiv_asids_triv: "\ equiv_asids R s s'; kheap t = kheap s; kheap t' = kheap s'; arch_state t = arch_state s; arch_state t' = arch_state s' \ - \ equiv_asids R t t'" + \ equiv_asids R t t'" and equiv_asids_non_asid_pool_kheap_update: - "\ equiv_asids R s s'; non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh' \ + "\ equiv_asids R s s'; non_asid_pool_kheap_update s kh; non_asid_pool_kheap_update s' kh' \ \ equiv_asids R (s\kheap := kh\) (s'\kheap := kh'\)" + \ \equiv_hyp lemmas\ + and equiv_hyp_refl: + "equiv_hyp P s s" + and equiv_hyp_sym: + "equiv_hyp P s t \ equiv_hyp P t s" + and equiv_hyp_trans: + "\ equiv_hyp P s t; equiv_hyp P t u \ \ equiv_hyp P s u" + and equiv_hyp_guard_imp: + "\ equiv_hyp P s s'; \x. P' x \ P x \ \ equiv_hyp P' s s'" + and equiv_hypI: + "\ \x. P x \ equiv_hyp ((=) x) s t \ + \ equiv_hyp P s t" + and equiv_hyp_triv: + "\ equiv_hyp P s s'; arch_state t = arch_state s; arch_state t' = arch_state s'; + machine_state t = machine_state s; machine_state t' = machine_state s' \ + \ equiv_hyp P t t'" + and equiv_hyp_machine_state_update: + "\ equiv_hyp P s s'; identical_hyp_state_updates P s s' ms ms' \ + \ equiv_hyp P (s\machine_state := ms\) (s'\machine_state := ms'\)" + \ \equiv_fpu lemmas\ + and equiv_fpu_refl: + "equiv_fpu P s s" + and equiv_fpu_sym: + "equiv_fpu P s t \ equiv_fpu P t s" + and equiv_fpu_trans: + "\ equiv_fpu P s t; equiv_fpu P t u \ \ equiv_fpu P s u" + and equiv_fpu_guard_imp: + "\ equiv_fpu P s s'; \x. P' x \ P x \ \ equiv_fpu P' s s'" + and equiv_fpuI: + "\ \x. P x \ equiv_fpu ((=) x) s t \ + \ equiv_fpu P s t" + and equiv_fpu_triv: + "\ equiv_fpu P s s'; arch_state t = arch_state s; arch_state t' = arch_state s'; + machine_state t = machine_state s; machine_state t' = machine_state s' \ + \ equiv_fpu P t t'" + and equiv_fpu_machine_state_update: + "\ equiv_fpu P s s'; identical_fpu_state_updates P s s' ms ms' \ + \ equiv_fpu P (s\machine_state := ms\) (s'\machine_state := ms'\)" + \ \globals_equiv lemmas\ and globals_equiv_refl: "globals_equiv s s" and globals_equiv_sym: "globals_equiv s t \ globals_equiv t s" and globals_equiv_trans: "\ globals_equiv s t; globals_equiv t u \ \ globals_equiv s u" - and equiv_asids_guard_imp: - "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" - and dmo_loadWord_rev: - "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) - (do_machine_op (loadWord p))" begin +lemma equiv_asids_False: + "(\x. R x \ False) \ equiv_asids R x y" + by (auto simp: equiv_asids_def) + +lemma equiv_hyp_False: + "(\x. P x \ False) \ equiv_hyp P x y" + by (fastforce intro: equiv_hypI) + +lemma equiv_fpu_False: + "(\x. P x \ False) \ equiv_fpu P x y" + by (fastforce intro: equiv_fpuI) + +lemma equiv_hyp_updates[simp]: + "\f. equiv_hyp P st (kheap_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (kheap_update f st) s = equiv_hyp P st s" + "\f. equiv_hyp P st (ready_queues_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (ready_queues_update f st) s = equiv_hyp P st s" + "\f. equiv_hyp P st (cur_thread_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (cur_thread_update f st) s = equiv_hyp P st s" + "\f. equiv_hyp P st (scheduler_action_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (scheduler_action_update f st) s = equiv_hyp P st s" + "\f. equiv_hyp P st (domain_time_update f s) = equiv_hyp P st s" + "\f. equiv_hyp P (domain_time_update f st) s = equiv_hyp P st s" + by (auto elim: equiv_hyp_triv) + +lemma equiv_fpu_updates[simp]: + "\f. equiv_fpu P st (kheap_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (kheap_update f st) s = equiv_fpu P st s" + "\f. equiv_fpu P st (ready_queues_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (ready_queues_update f st) s = equiv_fpu P st s" + "\f. equiv_fpu P st (cur_thread_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (cur_thread_update f st) s = equiv_fpu P st s" + "\f. equiv_fpu P st (scheduler_action_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (scheduler_action_update f st) s = equiv_fpu P st s" + "\f. equiv_fpu P st (domain_time_update f s) = equiv_fpu P st s" + "\f. equiv_fpu P (domain_time_update f st) s = equiv_fpu P st s" + by (auto elim: equiv_fpu_triv) + lemma states_equiv_for_machine_state_update: - "\ states_equiv_for P Q R S s s'; equiv_machine_state P kh kh' \ - \ states_equiv_for P Q R S (s\machine_state := kh\) (s'\machine_state := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv - intro: equiv_forI simp: states_equiv_for_def) + "\ states_equiv_for P Q R S s s'; equiv_machine_state P ms ms'; + identical_hyp_state_updates P s s' ms ms'; identical_fpu_state_updates P s s' ms ms' \ + \ states_equiv_for P Q R S (s\machine_state := ms\) (s'\machine_state := ms'\)" + by (fastforce elim: equiv_forE + elim!: equiv_asids_triv equiv_hyp_machine_state_update equiv_fpu_machine_state_update + intro: equiv_forI simp: states_equiv_for_def)+ lemma states_equiv_for_cdt_update: "\ states_equiv_for P Q R S s s'; equiv_for (P \ fst) id kh kh' \ \ states_equiv_for P Q R S (s\cdt := kh\) (s'\cdt := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_cdt_list_update: "\ states_equiv_for P Q R S s s'; equiv_for (P \ fst) id (kh (cdt_list s)) (kh' (cdt_list s')) \ \ states_equiv_for P Q R S (cdt_list_update kh s) (cdt_list_update kh' s')" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_is_original_cap_update: "\ states_equiv_for P Q R S s s'; equiv_for (P \ fst) id kh kh' \ \ states_equiv_for P Q R S (s\is_original_cap := kh\) (s'\is_original_cap := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_interrupt_states_update: "\ states_equiv_for P Q R S s s'; equiv_for Q id kh kh' \ \ states_equiv_for P Q R S (s\interrupt_states := kh\) (s'\interrupt_states := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_interrupt_irq_node_update: "\ states_equiv_for P Q R S s s'; equiv_for Q id kh kh' \ \ states_equiv_for P Q R S (s\interrupt_irq_node := kh\) (s'\interrupt_irq_node := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_ready_queues_update: "\ states_equiv_for P Q R S s s'; equiv_for S id kh kh' \ \ states_equiv_for P Q R S (s\ready_queues := kh\) (s'\ready_queues := kh'\)" - by (fastforce elim: equiv_forE elim!: equiv_asids_triv + by (fastforce elim: equiv_forE elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv intro: equiv_forI simp: states_equiv_for_def) lemma states_equiv_for_identical_kheap_updates: @@ -180,6 +259,8 @@ lemma states_equiv_forE: "equiv_for Q interrupt_states s s'" "equiv_for Q interrupt_irq_node s s'" "equiv_asids R s s'" + "equiv_hyp P s s'" + "equiv_fpu P s s'" "equiv_for S ready_queues s s'" using sef[simplified states_equiv_for_def] by auto @@ -249,17 +330,17 @@ context InfoFlow_IF_1 begin lemma states_equiv_for_refl: "states_equiv_for P Q R S s s" - by (auto simp: states_equiv_for_def intro: equiv_for_refl equiv_asids_refl) + by (auto simp: states_equiv_for_def intro: equiv_for_refl equiv_asids_refl equiv_hyp_refl equiv_fpu_refl) lemma states_equiv_for_sym: "states_equiv_for P Q R S s t \ states_equiv_for P Q R S t s" - by (auto simp: states_equiv_for_def intro: equiv_for_sym equiv_asids_sym simp: equiv_for_def) + by (auto simp: states_equiv_for_def intro: equiv_for_sym equiv_asids_sym simp: equiv_for_def equiv_hyp_sym equiv_fpu_sym) lemma states_equiv_for_trans: "\ states_equiv_for P Q R S s t; states_equiv_for P Q R S t u \ \ states_equiv_for P Q R S s u" by (auto simp: states_equiv_for_def - intro: equiv_for_trans equiv_asids_trans equiv_forI + intro: equiv_for_trans equiv_asids_trans equiv_hyp_trans equiv_fpu_trans equiv_forI elim: equiv_forE) end @@ -288,6 +369,19 @@ lemma equiv_asids_aag_can_read_asid: (\d \ subjectReads (pasPolicy aag) (pasSubject aag). equiv_asids (\x. d = pasASIDAbs aag x) s s')" by (auto simp: equiv_asids_def) + +context InfoFlow_IF_1 begin + +lemma equiv_hyp_aag_can_read: + "equiv_hyp (aag_can_read aag) s s' = + (\d \ subjectReads (pasPolicy aag) (pasSubject aag). equiv_hyp (\x. d = pasObjectAbs aag x) s s')" + by (fastforce intro: equiv_hypI elim: equiv_hyp_guard_imp) + +lemma equiv_fpu_aag_can_read: + "equiv_fpu (aag_can_read aag) s s' = + (\d \ subjectReads (pasPolicy aag) (pasSubject aag). equiv_fpu (\x. d = pasObjectAbs aag x) s s')" + by (fastforce intro: equiv_fpuI elim: equiv_fpu_guard_imp) + lemma reads_equiv_def2: "reads_equiv aag s s' = (states_equiv_for (aag_can_read aag) (aag_can_read_irq aag) (aag_can_read_asid aag) (aag_can_read_domain aag) s s' \ @@ -296,7 +390,8 @@ lemma reads_equiv_def2: scheduler_action s = scheduler_action s' \ work_units_completed s = work_units_completed s' \ irq_state (machine_state s) = irq_state (machine_state s'))" - by (auto simp: reads_equiv_def equiv_for_def states_equiv_for_def equiv_asids_aag_can_read_asid) + by (auto simp: reads_equiv_def equiv_for_def states_equiv_for_def + equiv_hyp_aag_can_read equiv_fpu_aag_can_read equiv_asids_aag_can_read_asid) lemma reads_equivE: assumes sef: "reads_equiv aag s s'" @@ -308,6 +403,8 @@ lemma reads_equivE: "equiv_for (aag_can_read_irq aag) interrupt_states s s'" "equiv_for (aag_can_read_irq aag) interrupt_irq_node s s'" "equiv_asids (aag_can_read_asid aag) s s'" + "equiv_hyp (aag_can_read aag) s s'" + "equiv_fpu (aag_can_read aag) s s'" "equiv_for (aag_can_read_domain aag) ready_queues s s'" "cur_thread s = cur_thread s'" "cur_domain s = cur_domain s'" @@ -316,9 +413,6 @@ lemma reads_equivE: "irq_state (machine_state s) = irq_state (machine_state s')" using sef by (auto simp: reads_equiv_def2 elim: states_equiv_forE) - -context InfoFlow_IF_1 begin - lemma globals_equiv_updates[simp]: "\f. globals_equiv st (trans_state f s) = globals_equiv st s" "\f. globals_equiv s (cdt_update f s') = globals_equiv s s'" @@ -329,8 +423,11 @@ lemma globals_equiv_updates[simp]: by (simp add: globals_equiv_def idle_equiv_def)+ lemma reads_equiv_machine_state_update: - "\ reads_equiv aag s s'; equiv_machine_state (aag_can_read aag) kh kh'; irq_state kh = irq_state kh' \ - \ reads_equiv aag (s\machine_state := kh\) (s'\machine_state := kh'\)" + "\ reads_equiv aag s s'; equiv_machine_state (aag_can_read aag) ms ms'; + irq_state ms = irq_state ms'; + identical_hyp_state_updates (aag_can_read aag) s s' ms ms'; + identical_fpu_state_updates (aag_can_read aag) s s' ms ms' \ + \ reads_equiv aag (s\machine_state := ms\) (s'\machine_state := ms'\)" by (fastforce simp: reads_equiv_def2 intro: states_equiv_for_machine_state_update) lemma states_equiv_for_non_asid_pool_kheap_update: @@ -384,18 +481,21 @@ lemma reads_equiv_ready_queues_update: lemma reads_equiv_scheduler_action_update: "reads_equiv aag s s' \ reads_equiv aag (s\scheduler_action := kh\) (s'\scheduler_action := kh\)" - by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma reads_equiv_work_units_completed_update: "reads_equiv aag s s' \ reads_equiv aag (s\work_units_completed := kh\) (s'\work_units_completed := kh\)" - by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma reads_equiv_work_units_completed_update': "reads_equiv aag s s' \ reads_equiv aag (s\work_units_completed := (f (work_units_completed s))\) (s'\work_units_completed := (f (work_units_completed s'))\)" - by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: reads_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma affects_equiv_def2: "affects_equiv aag l s s' = states_equiv_for (aag_can_affect aag l) @@ -405,7 +505,7 @@ lemma affects_equiv_def2: by (auto simp: affects_equiv_def dest: equiv_forD elim!: states_equiv_forE - intro!: states_equiv_forI equiv_forI equiv_asids_False) + intro!: states_equiv_forI equiv_forI equiv_asids_False equiv_hyp_False equiv_fpu_False) lemma affects_equivE: assumes sef: "affects_equiv aag l s s'" @@ -417,13 +517,17 @@ lemma affects_equivE: "equiv_for (aag_can_affect_irq aag l) interrupt_states s s'" "equiv_for (aag_can_affect_irq aag l) interrupt_irq_node s s'" "equiv_asids (aag_can_affect_asid aag l) s s'" + "equiv_hyp (aag_can_affect aag l) s s'" + "equiv_fpu (aag_can_affect aag l) s s'" "equiv_for (aag_can_affect_domain aag l) ready_queues s s'" using sef by (auto simp: affects_equiv_def2 elim: states_equiv_forE) lemma affects_equiv_machine_state_update: - "\ affects_equiv aag l s s'; equiv_machine_state (aag_can_affect aag l) kh kh' \ - \ affects_equiv aag l (s\machine_state := kh\) (s'\machine_state := kh'\)" - by (fastforce simp: affects_equiv_def2 intro: states_equiv_for_machine_state_update) + "\ affects_equiv aag l s s'; equiv_machine_state (aag_can_affect aag l) ms ms'; + identical_hyp_state_updates (aag_can_affect aag l) s s' ms ms'; + identical_fpu_state_updates (aag_can_affect aag l) s s' ms ms' \ + \ affects_equiv aag l (s\machine_state := ms\) (s'\machine_state := ms'\)" + by (auto simp: affects_equiv_def2 intro: states_equiv_for_machine_state_update) lemma affects_equiv_non_asid_pool_kheap_update: "\ affects_equiv aag l s s'; equiv_for (aag_can_affect aag l) id kh kh'; @@ -470,18 +574,21 @@ lemma affects_equiv_ready_queues_update: lemma affects_equiv_scheduler_action_update: "affects_equiv aag l s s' \ affects_equiv aag l (s\scheduler_action := kh\) (s'\scheduler_action := kh\)" - by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma affects_equiv_work_units_completed_update: "affects_equiv aag l s s' \ affects_equiv aag l (s\work_units_completed := kh\) (s'\work_units_completed := kh\)" - by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) lemma affects_equiv_work_units_completed_update': "affects_equiv aag l s s' \ affects_equiv aag l (s\work_units_completed := (f (work_units_completed s))\) (s'\work_units_completed := (f (work_units_completed s'))\)" - by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def elim!: equiv_asids_triv) + by (fastforce simp: affects_equiv_def2 states_equiv_for_def equiv_for_def + elim!: equiv_asids_triv equiv_hyp_triv equiv_fpu_triv) (* reads_equiv and affects_equiv want to be equivalence relations *) lemma reads_equiv_refl: @@ -601,11 +708,13 @@ lemma states_equiv_for_guard_imp: and "\x. R' x \ R x" and "\x. S' x \ S x" shows "states_equiv_for P' Q' R' S' s s'" - using assms by (auto simp: states_equiv_for_def intro: equiv_for_guard_imp equiv_asids_guard_imp) + using assms + by (auto simp: states_equiv_for_def + intro: equiv_for_guard_imp equiv_asids_guard_imp equiv_hyp_guard_imp equiv_fpu_guard_imp) lemma set_object_reads_respects: "reads_respects aag l \ (set_object ptr obj)" - apply(clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def set_object_def get_object_def bind_def' get_def gets_def put_def return_def fail_def assert_def) apply (rule conjI) apply (erule reads_equiv_identical_kheap_updates) @@ -614,9 +723,6 @@ lemma set_object_reads_respects: apply (clarsimp simp: identical_kheap_updates_def) done -end - - lemma cur_subject_reads_equiv_affects_equiv: "\ pasSubject aag = l; reads_equiv aag s s' \ \ affects_equiv aag l s s'" by (auto simp: reads_equiv_def2 affects_equiv_def equiv_for_def states_equiv_for_def) @@ -633,6 +739,12 @@ lemma requiv_get_tcb_eq[intro]: \ get_tcb thread s = get_tcb thread t" by (auto simp: reads_equiv_def2 get_tcb_def elim: states_equiv_forE_kheap) +(* FIXME AARCH64 IF: delete if unused *) +lemma requiv_get_tcb_eq'[intro]: + "\ reads_equiv aag s t; aag_can_read aag thread \ + \ get_tcb thread s = get_tcb thread t" + by (auto simp: reads_equiv_def2 get_tcb_def elim: states_equiv_forE_kheap) + lemma requiv_cur_thread_eq[intro]: "reads_equiv aag s t \ cur_thread s = cur_thread t" by (simp add: reads_equiv_def2) @@ -722,9 +834,6 @@ lemma as_user_rev: apply simp_all done - -context InfoFlow_IF_1 begin - lemma gets_kheap_revrv: "reads_equiv_valid_rv_inv (affects_equiv aag l) aag (equiv_for (aag_can_read aag or aag_can_affect aag l) id) \ (gets kheap)" @@ -789,21 +898,32 @@ lemma gets_ready_queues_revrv: apply (clarsimp simp: equiv_for_def disjoint_iff_not_equal elim!: reads_equivE affects_equivE) done +lemma reads_affects_equiv_kheap_eq: + "\ reads_equiv aag s s'; affects_equiv aag l s s'; aag_can_affect aag l x \ aag_can_read aag x \ + \ kheap s x = kheap s' x" + by (fastforce elim: affects_equivE reads_equivE equiv_forE) + +lemma reads_affects_equiv_get_tcb_eq: + "\ aag_can_read aag t \ aag_can_affect aag l t; reads_equiv aag s s'; affects_equiv aag l s s' \ + \ get_tcb t s = get_tcb t s'" + by (fastforce simp: get_tcb_def reads_affects_equiv_kheap_eq) + lemma as_user_reads_respects: - "reads_respects aag l (K (det f \ is_subject aag thread)) (as_user thread f)" + "reads_respects aag l (K (det f \ aag_can_read_or_affect aag l thread)) (as_user thread f)" apply (simp add: as_user_def split_def) apply (rule gen_asm_ev) - apply (wp set_object_reads_respects select_f_ev gets_the_ev) - apply fastforce + apply (wpsimp wp: set_object_reads_respects select_f_ev gets_the_ev) + apply (drule (2) reads_affects_equiv_get_tcb_eq) + apply auto done -end - - lemma get_message_info_rev: "reads_equiv_valid_inv A aag (K (is_subject aag ptr)) (get_message_info ptr)" by (wpsimp wp: as_user_rev getRegister_inv simp: get_message_info_def det_getRegister) +end + + lemma syscall_rev: assumes reads_res_m_fault: "reads_equiv_valid_inv A aag P m_fault" @@ -853,56 +973,9 @@ lemma syscall_reads_respects_g: context InfoFlow_IF_1 begin -lemma do_machine_op_spec_reads_respects': - assumes equiv_dmo: - "equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) - (equiv_machine_state (aag_can_affect aag l)) Q f" - assumes guard: - "\s. P s \ Q (machine_state s)" - shows - "spec_reads_respects st aag l P (do_machine_op f)" - unfolding do_machine_op_def spec_equiv_valid_def - apply (rule equiv_valid_2_guard_imp) - apply (rule_tac R'="\ rv rv'. equiv_machine_state (aag_can_read aag or aag_can_affect aag l) rv rv' \ equiv_irq_state rv rv'" and Q="\ r s. st = s \ Q r" and Q'="\ r s. Q r" and P="(=) st" and P'="\" in equiv_valid_2_bind) - apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) - apply (rule gen_asm_ev2_r') - apply (rule_tac R'="\ (r, ms') (r', ms''). r = r' \ equiv_machine_state (aag_can_read aag) ms' ms'' \ equiv_machine_state (aag_can_affect aag l) ms' ms'' \ equiv_irq_state ms' ms''" and Q="\ r s. st = s" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) - apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) - apply (fastforce intro: reads_equiv_machine_state_update affects_equiv_machine_state_update) - apply (insert equiv_dmo)[1] - apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or simp: split_def split: prod.splits simp: equiv_for_def)[1] - apply (drule_tac x=rv in spec, drule_tac x=rv' in spec) - apply (fastforce) - apply (rule select_f_inv) - apply (rule wp_post_taut) - apply simp+ - apply (clarsimp simp: equiv_valid_2_def in_monad) - apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) - apply (wp | simp add: guard)+ - done - -(* most of the time (i.e. always except for getActiveIRQ) you'll want this rule *) -lemma do_machine_op_spec_reads_respects: - assumes equiv_dmo: - "equiv_valid_inv (equiv_machine_state (aag_can_read aag)) (equiv_machine_state (aag_can_affect aag l)) \ f" - assumes irq_state_inv: - "\P. \\ms. P (irq_state ms)\ f \\_ ms. P (irq_state ms)\" - shows - "spec_reads_respects st aag l \ (do_machine_op f)" - apply (rule do_machine_op_spec_reads_respects'[where Q=\, simplified]) - apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) - apply (subgoal_tac "equiv_irq_state b ba", simp) - apply (insert equiv_dmo, fastforce simp: equiv_valid_def2 equiv_valid_2_def) - apply (insert irq_state_inv) - apply (drule_tac x="\ms. ms = irq_state s" in meta_spec) - apply (clarsimp simp: valid_def) - apply (frule_tac x=s in spec) - apply (erule (1) impE) - apply (drule bspec, assumption, simp) - apply (drule_tac x=t in spec, simp) - apply (drule bspec, assumption) - apply simp - done +lemma equiv_for_disj: + "equiv_for (\x. P x \ Q x) f c c' = (equiv_for P f c c' \ equiv_for Q f c c')" + by (auto simp: equiv_for_def) lemma do_machine_op_rev: assumes equiv_dmo: "equiv_valid_inv (equiv_machine_state (aag_can_read aag)) \\ \ f" @@ -925,9 +998,6 @@ lemma do_machine_op_rev: apply wpsimp done -end - - lemma do_machine_op_spec_rev: assumes equiv_dmo: "spec_equiv_valid_inv (machine_state st) (equiv_machine_state (aag_can_read aag)) \\ \ f" @@ -969,6 +1039,18 @@ lemma do_machine_op_spec_rev: apply (wp | simp)+ done +lemma modifies_at_mostI: + assumes hoare: "\st. \P and equiv_but_for_labels aag L st\ f \\_. equiv_but_for_labels aag L st\" + shows "modifies_at_most aag L P f" + apply (clarsimp simp: modifies_at_most_def) + apply (erule use_valid) + apply (rule hoare) + apply (fastforce simp: equiv_but_for_labels_def states_equiv_for_refl) + done + +end + + lemma spec_equiv_valid_hoist_guard: "((P st) \ spec_equiv_valid_inv st I A \ f) \ spec_equiv_valid_inv st I A P f" by (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def) @@ -989,7 +1071,19 @@ lemma invs_kernel_mappings: by (auto simp: invs_def valid_state_def) -context InfoFlow_IF_1 begin +locale InfoFlow_IF_2 = InfoFlow_IF_1 + + fixes no_hyp :: "'m machine_monad \ bool" + and no_fpu :: "'m machine_monad \ bool" + and aag :: "'a PAS" + assumes dmo_loadWord_rev: + "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) + (do_machine_op (loadWord p))" + and do_machine_op_reads_respects': + "\ equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) + (equiv_machine_state (aag_can_affect aag l)) Q f; + \s. P s \ Q (machine_state s); no_hyp f; no_fpu f\ + \ reads_respects aag l P (do_machine_op f)" +begin lemma load_word_offs_rev: "for_each_byte_of_word (aag_can_read aag) (a + of_nat x * of_nat word_size) @@ -997,15 +1091,100 @@ lemma load_word_offs_rev: unfolding load_word_offs_def fun_app_def by (fastforce intro: equiv_valid_guard_imp[OF dmo_loadWord_rev]) -lemma modifies_at_mostI: - assumes hoare: "\st. \P and equiv_but_for_labels aag L st\ f \\_. equiv_but_for_labels aag L st\" - shows "modifies_at_most aag L P f" - apply (clarsimp simp: modifies_at_most_def) - apply (erule use_valid) - apply (rule hoare) - apply (fastforce simp: equiv_but_for_labels_def states_equiv_for_refl) +(* most of the time (i.e. always except for getActiveIRQ) you'll want this rule *) +lemma do_machine_op_reads_respects: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (aag_can_read aag)) + (equiv_machine_state (aag_can_affect aag l)) \ f" + assumes irq_state_inv: "\P. \\ms. P (irq_state ms)\ f \\_ ms. P (irq_state ms)\" + assumes no_hyp: "no_hyp f" + assumes no_fpu: "no_fpu f" + shows "reads_respects aag l \ (do_machine_op f)" + apply (rule do_machine_op_reads_respects'[where Q=\, simplified, OF _ no_hyp no_fpu]) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (subgoal_tac "equiv_irq_state b ba", simp) + apply (insert equiv_dmo, fastforce simp: equiv_valid_def2 equiv_valid_2_def) + apply (insert irq_state_inv) + apply (drule_tac x="\ms. ms = irq_state s" in meta_spec) + apply (clarsimp simp: valid_def) + apply (frule_tac x=s in spec) + apply (erule (1) impE) + apply (drule bspec, assumption, simp) + apply (drule_tac x=t in spec, simp) + apply (drule bspec, assumption) + apply simp done end +lemma tcb_domain_wellformed: + "\ pas_refined aag s; etcbs_of s t = Some a \ + \ pasObjectAbs aag t \ pasDomainAbs aag (etcb_domain a)" + apply (clarsimp simp add: pas_refined_def tcb_domain_map_wellformed_aux_def) + apply (drule_tac x="(t,etcb_domain a)" in bspec) + apply (rule domtcbs) + apply force+ + done + +lemma equiv_valid_inv_split_lr: + assumes "equiv_valid_rv_inv I \\ \\ P f" + and "equiv_valid_inv \\ A P f" + shows "equiv_valid_inv I A P f" + using assms + by (fastforce simp: equiv_valid_2_def equiv_valid_def2) + +lemma equiv_valid_inv_split_rl: + assumes "equiv_valid_inv I \\ P f" + and "equiv_valid_rv_inv \\ A \\ P f" + shows "equiv_valid_inv I A P f" + using assms + by (fastforce simp: equiv_valid_2_def equiv_valid_def2) + +lemma equiv_valid_rv_inv_lift: + assumes inv: "\st. \P and I st and A st\ f \\_. I st and A st\" + assumes symI: "\st s. I st s = I s st" + assumes symA: "\st s. A st s = A s st" + shows "equiv_valid_rv_inv I A \\ P f" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (subst symI) + apply (subst symA) + apply (erule use_valid) + apply (wp inv[simplified pred_conj_def]) + apply (subst symI) + apply (subst symA) + apply (erule use_valid) + apply (wp inv[simplified pred_conj_def]) + apply simp + done + +lemma equiv_valid_inv_lift: + assumes inv: "\st. \P and I st and A st\ f \\_. I st and A st\" + assumes symI: "\st s. I st s = I s st" + assumes symA: "\st s. A st s = A s st" + shows "equiv_valid_inv I A P (f :: ('s,unit) nondet_monad)" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (subst symI) + apply (subst symA) + apply (erule use_valid) + apply (wp inv[simplified pred_conj_def]) + apply (subst symI) + apply (subst symA) + apply (erule use_valid) + apply (wp inv[simplified pred_conj_def]) + apply simp + done + +lemma equiv_valid_conseq: + "\ equiv_valid I' A' B' P' f; + \s t. I s t \ A s t \ P s \ P t \ I' s t \ A' s t \ P' s \ P' t; + \s t. I' s t \ B' s t \ I s t \ B s t \ + \ equiv_valid I A B P f" + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule_tac x=s in allE) + apply (erule_tac x=t in allE, drule mp, fastforce) + apply fastforce + done + +declare equiv_valid_guard_imp[wp_pre] + end diff --git a/proof/infoflow/Interrupt_IF.thy b/proof/infoflow/Interrupt_IF.thy index 8dbdb13a65..65287cc612 100644 --- a/proof/infoflow/Interrupt_IF.thy +++ b/proof/infoflow/Interrupt_IF.thy @@ -21,7 +21,7 @@ locale Interrupt_IF_1 = "reads_respects aag l (K (arch_authorised_irq_ctl_inv aag irq_ctl_inv)) (arch_invoke_irq_control irq_ctl_inv)" and arch_invoke_irq_control_globals_equiv: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ arch_invoke_irq_control ai \\_. globals_equiv st\" and arch_invoke_irq_handler_globals_equiv[wp]: @@ -74,20 +74,20 @@ lemma invoke_irq_control_reads_respects: done lemma invoke_irq_control_globals_equiv: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ invoke_irq_control a \\_. globals_equiv st\" apply (induct a) - apply (wpsimp wp: set_irq_state_globals_equiv cap_insert_globals_equiv'' + apply (wpsimp wp: set_irq_state_globals_equiv cap_insert_globals_equiv set_irq_state_valid_global_objs arch_invoke_irq_control_globals_equiv)+ done lemma invoke_irq_handler_globals_equiv: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ invoke_irq_handler a \\_. globals_equiv st\" apply (induct a) - by (wpsimp wp: modify_wp cap_insert_globals_equiv'' + by (wpsimp wp: modify_wp cap_insert_globals_equiv cap_delete_one_globals_equiv cap_delete_one_valid_global_objs)+ subsection "reads_respects_g" diff --git a/proof/infoflow/Ipc_IF.thy b/proof/infoflow/Ipc_IF.thy index 852a5476c4..91f050ac96 100644 --- a/proof/infoflow/Ipc_IF.thy +++ b/proof/infoflow/Ipc_IF.thy @@ -19,11 +19,6 @@ definition ipc_buffer_has_read_auth :: "'a PAS \ 'a \ ob (\buf'. is_aligned buf' msg_align_bits \ (\x \ ptr_range buf' msg_align_bits. (l,Read,pasObjectAbs aag x) \ (pasPolicy aag)))" -abbreviation aag_can_read_or_affect where - "aag_can_read_or_affect aag l x \ - aag_can_read aag x \ aag_can_affect aag l x" - - lemma get_cap_reads_respects: "reads_respects aag l (K (aag_can_read aag (fst slot) \ aag_can_affect aag l (fst slot))) (get_cap slot)" apply (simp add: get_cap_def split_def) @@ -64,14 +59,16 @@ lemma tcb_sched_action_equiv_but_for_labels: apply (simp add: tcb_sched_action_def, wp) apply (clarsimp simp: etcb_at_def equiv_but_for_labels_def split: option.splits) apply (rule states_equiv_forI) - apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD[where f=kheap]) - apply (simp add: states_equiv_for_def) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) - apply (fastforce simp: equiv_asids_def elim: states_equiv_forE) + apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD[where f=kheap]) + apply (simp add: states_equiv_for_def) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) + apply (fastforce simp: equiv_asids_def elim: states_equiv_forE) + apply (fastforce elim: states_equiv_forE) + apply (fastforce elim: states_equiv_forE) apply (clarsimp simp: pas_refined_def tcb_domain_map_wellformed_aux_def split: option.splits) apply (rule equiv_forI) apply (erule_tac x="(thread, etcb_domain (the (etcbs_of s thread)))" in ballE) @@ -159,7 +156,7 @@ locale Ipc_IF_1 = and handle_arch_fault_reply_reads_respects: "reads_respects aag l (K (aag_can_read aag thread)) (handle_arch_fault_reply afault thread x y)" and arch_get_sanitise_register_info_reads_respects[wp]: - "reads_respects aag l \ (arch_get_sanitise_register_info t)" + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (arch_get_sanitise_register_info t)" and arch_get_sanitise_register_info_valid_global_objs[wp]: "arch_get_sanitise_register_info t \\s :: det_state. valid_global_objs s\" and handle_arch_fault_reply_valid_global_objs[wp]: @@ -465,7 +462,7 @@ lemma blocked_cancel_ipc_nosts_reads_respects: gts_reads_respects set_simple_ko_reads_respects gts_wp simp: get_blocking_object_def get_thread_state_rev)+ apply (clarsimp simp: pred_tcb_at_def obj_at_def) - by (fastforce dest:read_sync_ep_read_receivers ) + by (fastforce dest:read_sync_ep_read_receivers) next case False thus ?thesis apply - \ \can't read or affect ep\ @@ -555,7 +552,7 @@ lemma send_signal_reads_respects: gts_reads_respects gts_wp hoare_vcg_imp_lift get_simple_ko_wp get_simple_ko_reads_respects update_waiting_ntfn_reads_respects | wpc - | simp )+ + | simp)+ apply (insert visible) apply clarsimp apply (rule conjI[rotated]) @@ -1171,14 +1168,6 @@ lemma load_word_offs_reads_respects: end -lemma as_user_reads_respects: - "reads_respects aag l (K (det f \ aag_can_read_or_affect aag l thread)) (as_user thread f)" - apply (simp add: as_user_def split_def) - apply (rule gen_asm_ev) - apply (wp set_object_reads_respects select_f_ev gets_the_ev) - apply (auto intro: reads_affects_equiv_get_tcb_eq[where aag=aag]) - done - lemma get_mi_length': "\\\ get_message_info sender \\rv s. buffer_cptr_index + unat (mi_extra_caps rv) < 2 ^ (msg_align_bits - word_size_bits)\" @@ -1666,7 +1655,7 @@ lemma setup_caller_cap_globals_equiv: setup_caller_cap sender receiver grant \\_. globals_equiv s\" unfolding setup_caller_cap_def - apply (wp cap_insert_globals_equiv'' set_thread_state_globals_equiv) + apply (wp cap_insert_globals_equiv set_thread_state_globals_equiv) apply (simp_all) done @@ -1694,7 +1683,7 @@ next apply (wp set_extra_badge_globals_equiv)+ apply (rule Cons.hyps) apply (simp) - apply (wp cap_insert_globals_equiv'') + apply (wp cap_insert_globals_equiv) apply (rule_tac Q'="\_. globals_equiv st and valid_arch_state and valid_global_objs" and E'="\_. globals_equiv st and valid_arch_state and valid_global_objs" in hoare_strengthen_postE) @@ -2049,8 +2038,7 @@ end lemma reply_from_kernel_globals_equiv: - "\globals_equiv s and valid_objs and valid_arch_state and valid_global_refs and pspace_distinct - and pspace_aligned and (\s. thread \ idle_thread s)\ + "\globals_equiv s and valid_arch_state and (\s. thread \ idle_thread s)\ reply_from_kernel thread x \\_. globals_equiv s\" unfolding reply_from_kernel_def @@ -2205,10 +2193,8 @@ lemma handle_reply_reads_respects_g: lemma reply_from_kernel_reads_respects_g: assumes domains_distinct: "pas_domains_distinct aag" shows - "reads_respects_g aag l (valid_global_objs and valid_objs and valid_arch_state - and valid_global_refs and pspace_distinct - and pspace_aligned and (\s. thread \ idle_thread s) - and K (is_subject aag thread)) + "reads_respects_g aag l (valid_arch_state and (\s. thread \ idle_thread s) + and K (is_subject aag thread)) (reply_from_kernel thread x)" apply (rule equiv_valid_guard_imp[OF reads_respects_g]) apply (rule reply_from_kernel_reads_respects[OF domains_distinct]) diff --git a/proof/infoflow/Noninterference.thy b/proof/infoflow/Noninterference.thy index b8fa1db534..e50e7b54bf 100644 --- a/proof/infoflow/Noninterference.thy +++ b/proof/infoflow/Noninterference.thy @@ -386,15 +386,6 @@ lemma kernel_entry_if_globals_equiv_scheduler: apply fastforce done -lemma domain_fields_equiv_lift: - assumes a: "\P. \domain_fields P and Q\ f \\_. domain_fields P\" - assumes b: "\P. \(\s. P (cur_domain s)) and R\ f \\_ s. P (cur_domain s)\" - shows "\domain_fields_equiv st and Q and R\ f \\_. domain_fields_equiv st\" - apply (clarsimp simp: valid_def domain_fields_equiv_def) - apply (erule use_valid, wp a b) - apply simp - done - lemma check_active_irq_if_partitionIntegrity: "check_active_irq_if tc \partitionIntegrity aag st\" apply (simp add: check_active_irq_if_def) @@ -570,7 +561,13 @@ lemmas integrity_subjects_device = integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct1] lemmas integrity_subjects_asids = - integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2] + integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct1] + +lemmas integrity_subjects_hyps = + integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct1] + +lemmas integrity_subjects_fpus = + integrity_subjects_def[THEN meta_eq_to_obj_eq, THEN iffD1, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2, THEN conjunct2] lemma pas_wellformed_pasSubject_update_Control: "\ pas_wellformed (aag\pasSubject := pasObjectAbs aag p\); @@ -596,7 +593,6 @@ lemma fun_noteqD: "f \ g \ \a. f a \ g a" by blast - locale Noninterference_1 = fixes current_aag :: "det_state \ 'a subject_label PAS" and arch_globals_equiv_strengthener :: "machine_state \ machine_state \ bool" @@ -613,9 +609,9 @@ locale Noninterference_1 = and sameFor_scheduler_affects_equiv: "\s s'. \ (s,s') \ same_for aag PSched; (s,s') \ same_for aag (Partition l'); invs (internal_state_if s); invs (internal_state_if s') \ - \ scheduler_equiv aag (internal_state_if s) (internal_state_if s') \ - scheduler_affects_equiv aag (OrdinaryLabel l') - (internal_state_if s) (internal_state_if s')" + \ scheduler_equiv aag (internal_state_if s) (internal_state_if s') \ + scheduler_affects_equiv aag (OrdinaryLabel l') + (internal_state_if s) (internal_state_if s')" and do_user_op_if_partitionIntegrity: "\aag :: 'a subject_label PAS. \partitionIntegrity aag st and pas_refined aag and invs and is_subject aag \ cur_thread\ @@ -634,20 +630,16 @@ locale Noninterference_1 = and integrity_fpu_update_reference_state: "is_subject aag t \ integrity_fpu aag {pasSubject aag} x s (s\kheap := (kheap s)(t \ blah)\)" - and partitionIntegrity_subjectAffects_aobj: - "\ partitionIntegrity aag s s'; kheap s x = Some (ArchObj ao); kheap s x \ kheap s' x; - silc_inv aag st s; pas_refined aag s; pas_wellformed_noninterference aag \ - \ subject_can_affect_label_directly aag (pasObjectAbs aag x)" and partitionIntegrity_subjectAffects_asid: "\ partitionIntegrity aag s s'; pas_refined aag s; valid_objs s; valid_arch_state s; valid_arch_state s'; pas_wellformed_noninterference aag; silc_inv aag st s'; invs s'; \ equiv_asids (\x. pasASIDAbs aag x = a) s s'\ - \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" + \ a \ subjectAffects (pasPolicy aag) (pasSubject aag)" and arch_switch_to_thread_reads_respects_g': "equiv_valid (reads_equiv_g aag) (affects_equiv aag l) (\s s'. affects_equiv aag l s s' \ arch_globals_equiv_strengthener (machine_state s) (machine_state s')) - (\s. is_subject aag t) (arch_switch_to_thread t)" + (\s. invs s \ is_subject aag t) (arch_switch_to_thread t)" and arch_globals_equiv_strengthener_thread_independent: "arch_globals_equiv_strengthener (machine_state s) (machine_state s') \ \ct ct' it it'. arch_globals_equiv ct it (kheap s) (kheap s') @@ -661,14 +653,14 @@ locale Noninterference_1 = \st :: det_state. f \\s. arch_globals_equiv_strengthener (machine_state st) (machine_state s)\; \st :: det_state. g \\s. arch_globals_equiv_strengthener (machine_state st) (machine_state s)\; \s t. P s \ P' t \ (\(rva,s') \ fst (f s). \(rvb,t') \ fst (g t). W rva rvb) \ - \ equiv_valid_2 (reads_equiv_g aag) - (\s s'. affects_equiv aag l s s' \ - arch_globals_equiv_strengthener (machine_state s) (machine_state s')) - (\s s'. affects_equiv aag l s s' \ - arch_globals_equiv_strengthener (machine_state s) (machine_state s')) - (W :: unit \ unit \ bool) (P and Q) (P' and Q') f g" + \ equiv_valid_2 (reads_equiv_g aag) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + (\s s'. affects_equiv aag l s s' \ + arch_globals_equiv_strengthener (machine_state s) (machine_state s')) + (W :: unit \ unit \ bool) (P and Q) (P' and Q') f g" and arch_switch_to_idle_thread_reads_respects_g[wp]: - "reads_respects_g aag l \ (arch_switch_to_idle_thread)" + "reads_respects_g aag l valid_arch_state (arch_switch_to_idle_thread)" and arch_globals_equiv_threads_eq: "arch_globals_equiv t' t'' kh kh' as as' ms ms' \ arch_globals_equiv t t kh kh' as as' ms ms'" @@ -683,14 +675,48 @@ locale Noninterference_1 = (do_machine_op (getActiveIRQ in_kernel))" and handle_spurious_irq_reads_respects_scheduler[wp]: "reads_respects_scheduler aag l \ handle_spurious_irq" - (* FIXME IF: precludes ARM_HYP *) - and getActiveIRQ_no_non_kernel_IRQs: - "getActiveIRQ True = getActiveIRQ False" - and valid_cur_hyp_triv: - "valid_cur_hyp s" - and arch_tcb_get_registers_equality: - "arch_tcb_get_registers (tcb_arch tcb) = arch_tcb_get_registers (tcb_arch tcb') - \ tcb_arch (tcb :: tcb) = tcb_arch (tcb' :: tcb)" + and getActiveIRQ_ev2: + "equiv_valid_2 (scheduler_equiv aag) + (scheduler_affects_equiv aag l) (scheduler_affects_equiv aag l) + (\irq irq'. irq = irq' \ irq = None \ irq' \ Some ` non_kernel_IRQs) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ True)) (do_machine_op (getActiveIRQ False))" + and arch_prepare_next_domain_reads_respects_g: + "reads_equiv_valid_g_inv (affects_equiv aag l) aag invs + arch_prepare_next_domain" + and partitionIntegrity_subjectAffects_aobj: + "\ partitionIntegrity aag s s'; kheap s x = Some (ArchObj ao); + kheap s x \ kheap s' x; silc_inv aag st s; + pas_wellformed_noninterference aag; pas_refined aag s; + pas_refined aag s'; pas_cur_domain aag s; pas_cur_domain aag s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; invs s; invs s' \ + \ subject_can_affect_label_directly aag (pasObjectAbs aag x)" + and partitionIntegrity_subjectAffects_hyp: + "\ partitionIntegrity aag s s'; invs s; invs s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; + pas_refined aag s; pas_refined aag s'; pas_cur_domain aag s; + pas_cur_domain aag s'; pas_domains_distinct aag; + \ equiv_hyp (\x. pasObjectAbs aag x = a) s s'\ + \ subject_can_affect_label_directly aag a" + and partitionIntegrity_subjectAffects_fpu: + "\ partitionIntegrity aag s s'; invs s; invs s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; pas_refined aag s; + pas_refined aag s'; pas_cur_domain aag s; pas_cur_domain aag s'; + pas_domains_distinct aag; + \ equiv_fpu (\x. pasObjectAbs aag x = a) s s' \ + \ subject_can_affect_label_directly aag a" + and partitionIntegrity_subjectAffects_tcb_fpu: + "\ partitionIntegrity aag s s'; kheap s x = Some (TCB tcb); + kheap s' x = Some (TCB tcb'); tcb' = tcb\tcb_arch := new_arch\; + arch_tcb_get_registers new_arch = + arch_tcb_get_registers (tcb_arch tcb); + tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb); + kheap s x \ kheap s' x; silc_inv aag st s; + pas_wellformed_noninterference aag; pas_refined aag s; + pas_refined aag s'; pas_cur_domain aag s; pas_cur_domain aag s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; invs s; invs s' \ + \ subject_can_affect_label_directly aag (pasObjectAbs aag x)" begin lemma integrity_update_reference_state: @@ -706,7 +732,7 @@ lemma integrity_update_reference_state: be identical to the initial one, but it isn't because we first update the context of cur_thread *) lemma kernel_entry_if_integrity: - "\einvs and schact_is_rct and pas_refined aag and is_subject aag \ cur_thread + "\einvs and valid_cur_hyp and schact_is_rct and pas_refined aag and is_subject aag \ cur_thread and domain_sep_inv (pasMaySendIrqs aag) st' and guarded_pas_domain aag and (\s. e \ Interrupt \ ct_active s) and (=) st\ kernel_entry_if e tc @@ -721,9 +747,9 @@ lemma kernel_entry_if_integrity: \ cur_thread s = cur_thread st" in hoare_strengthen_post) apply (wp handle_event_integrity handle_event_cur_thread | simp)+ apply (fastforce intro: integrity_update_reference_state) - apply (wp thread_set_integrity_autarch thread_set_pas_refined guarded_pas_domain_lift + apply (wp thread_set_integrity_autarch thread_set_context_pas_refined guarded_pas_domain_lift thread_set_invs_trivial thread_set_not_state_valid_sched - | simp add: tcb_cap_cases_def schact_is_rct_def arch_tcb_update_aux2 valid_cur_hyp_triv)+ + | simp add: tcb_cap_cases_def schact_is_rct_def arch_tcb_update_aux2)+ apply (wp thread_set_tcb_context_update_wp)+ apply (clarsimp simp: schact_is_rct_def) apply (rule conjI) @@ -801,9 +827,8 @@ lemma kernel_entry_if_domain_fields_equiv: simp: ran_tcb_cap_cases arch_tcb_update_aux2) fastforce - lemma kernel_entry_if_partitionIntegrity: - "\silc_inv aag st and pas_refined aag and einvs and schact_is_rct + "\silc_inv aag st and pas_refined aag and einvs and valid_cur_hyp and schact_is_rct and is_subject aag \ cur_thread and domain_sep_inv (pasMaySendIrqs aag) st' and guarded_pas_domain aag and (\s. ev \ Interrupt \ ct_active s) and (=) st\ kernel_entry_if ev tc @@ -835,149 +860,144 @@ text \ \ lemma partitionIntegrity_subjectAffects_obj: assumes par_inte: "partitionIntegrity (aag :: 'a subject_label PAS) s s'" - assumes pas_ref: "pas_refined aag s" - assumes invs: "invs s" + assumes pas_ref: "pas_refined aag s" "pas_refined aag s'" + assumes pas_dom: "pas_cur_domain aag s" "pas_cur_domain aag s'" + assumes cur_vcpu: "cur_hyp_in_cur_domain s" "cur_hyp_in_cur_domain s'" + assumes cur_fpu: "cur_fpu_in_cur_domain s" "cur_fpu_in_cur_domain s'" + assumes invs: "invs s" "invs s'" assumes pwni: "pas_wellformed_noninterference aag" assumes silc_inv: "silc_inv aag st s" assumes kh_diff: "kheap s x \ kheap s' x" notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, - THEN spec[where x=x], simplified integrity_obj_def, simplified] + THEN spec[where x=x], simplified] shows "pasObjectAbs aag x \ subjectAffects (pasPolicy aag) (pasSubject aag)" - proof - + note hyps = pwni pas_ref invs silc_inv kh_diff + hence sym_helper: "\auth tcb. kheap s x = Some (TCB tcb) \ + (pasObjectAbs aag x, auth, pasObjectAbs aag x) \ pasPolicy aag" + by (fastforce elim!: pas_wellformed_noninterference_policy_refl + silc_inv_cnode_onlyE obj_atE + simp: is_cap_table_def) show ?thesis - using inte_obj - proof (induct "kheap s x" rule: converse_rtranclp_induct) - case base - thus ?case using kh_diff by force + using tro_tro_alt[OF inte_obj] + proof (induct rule: integrity_obj_alt.induct) + case tro_alt_lrefl + thus ?case by (simp add: subjectAffects.intros(1)) next - case (step z) - note troa = step.hyps(1) - show ?case - proof (cases "z = kheap s x") - case True - thus ?thesis using step.hyps by blast - next - case False - note hyps = this pwni pas_ref invs silc_inv kh_diff - hence sym_helper: "\auth tcb. kheap s x = Some (TCB tcb) \ - (pasObjectAbs aag x, auth, pasObjectAbs aag x) \ pasPolicy aag" - by (fastforce elim!: pas_wellformed_noninterference_policy_refl - silc_inv_cnode_onlyE obj_atE - simp: is_cap_table_def) - show ?thesis - using troa - proof (cases rule: integrity_obj_atomic.cases) - case troa_lrefl - thus ?thesis by (fastforce intro: subjectAffects.intros) - next - case (troa_ntfn ntfn ntfn' auth s) - thus ?thesis by (fastforce intro: affects_ep) - next - case (troa_ep ep ep' auth s) - thus ?thesis by (fastforce intro: affects_ep) - next - case (troa_ep_unblock ep ep' tcb ntfn) - thus ?thesis by (fastforce intro: affects_ep_bound_trans) - next - case (troa_tcb_send tcb tcb' ctxt' ep) - thus ?thesis using hyps - apply (clarsimp simp: direct_send_def indirect_send_def) - apply (erule disjE) - apply (clarsimp simp: receive_blocked_on_def2) - apply (frule (2) pas_refined_tcb_st_to_auth) - apply (fastforce intro!: affects_send sym_helper) - apply (fastforce intro!: affects_send bound_tcb_at_implies_receive - pred_tcb_atI sym_helper) - done - next - case (troa_tcb_call tcb tcb' caller R ctxt' ep) - thus ?thesis using hyps - apply (clarsimp simp add: direct_call_def ep_recv_blocked_def) - apply (rule affects_send[rotated 2]) - apply (erule (1) pas_refined_tcb_st_to_auth[rotated 2]; force) - apply (fastforce intro: sym_helper) - apply assumption - apply blast - done - next - case (troa_tcb_reply tcb tcb' new_st ctxt') - thus ?thesis using hyps - apply clarsimp - apply (erule affects_reply) - by (rule sym_helper) - next - case (troa_tcb_receive tcb tcb' new_st ep) - thus ?thesis using hyps - by (auto intro: affects_recv pas_refined_tcb_st_to_auth simp: send_blocked_on_def2) - next - case (troa_tcb_restart tcb tcb' ep) - thus ?thesis using hyps - by (fastforce intro: affects_reset[where auth=Receive] affects_reset[where auth=SyncSend] - elim: blocked_on.elims pas_refined_tcb_st_to_auth[rotated 2] - intro!: sym_helper) - next - case (troa_tcb_unbind tcb tcb') - thus ?thesis using hyps - apply - - by (cases "tcb_bound_notification tcb" ; - fastforce intro: affects_reset[where auth=Receive] bound_tcb_at_implies_receive + case tro_alt_orefl + thus ?case by (simp add: assms) + next + case (tro_alt_ntfn ntfn ntfn' auth) + thus ?case by (fastforce intro: affects_ep) + next + case (tro_alt_ep ep ep' auth) + thus ?case by (fastforce intro: affects_ep) + next + case (tro_alt_ep_unblock ep ep') + thus ?case by (fastforce intro: affects_ep_bound_trans) + next + case (tro_alt_tcb_send tcb tcb' ccap' cap' ntfn' new_arch ep) + thus ?case using hyps + apply (clarsimp simp: direct_send_def indirect_send_def) + apply (erule disjE) + apply (clarsimp simp: receive_blocked_on_def2) + apply (frule (2) pas_refined_tcb_st_to_auth) + apply (fastforce intro!: affects_send sym_helper) + apply (fastforce intro!: affects_send bound_tcb_at_implies_receive pred_tcb_atI sym_helper) - next - case (troa_tcb_empty_ctable tcb tcb' cap') - thus ?thesis using hyps - apply (clarsimp simp:reply_cap_deletion_integrity_def; elim disjE; clarsimp) - apply (rule affects_delete_derived) - apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], - assumption) - apply (frule cap_auth_caps_of_state[rotated,where p ="(x,tcb_cnode_index 0)"], - force simp: caps_of_state_def') - by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def reply_cap_rights_to_auth_def - split: if_splits) - next - case (troa_tcb_empty_caller tcb tcb' cap') - thus ?thesis using hyps - apply (clarsimp simp:reply_cap_deletion_integrity_def) - apply (elim disjE; clarsimp) - apply (rule affects_delete_derived) - apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], - assumption) - apply (frule cap_auth_caps_of_state[rotated,where p ="(x,tcb_cnode_index 3)"], - force simp: caps_of_state_def') - by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def - reply_cap_rights_to_auth_def - split: if_splits) - next - case (troa_tcb_activate tcb tcb') - thus ?thesis by blast - next - case (troa_tcb_fpu tcb tcb' new_arch) - thus ?thesis - by (auto intro!: step tcb.equality arch_tcb_get_registers_equality) - next - case (troa_arch ao ao') - thus ?thesis - using assms by (fastforce dest: partitionIntegrity_subjectAffects_aobj) - next - case (troa_cnode n content content') - thus ?thesis - using hyps unfolding cnode_integrity_def - apply clarsimp - apply (drule fun_noteqD) - apply (erule exE, rename_tac l) - apply (drule_tac x=l in spec) - apply (clarsimp dest!:not_sym[where t=None]) - apply (clarsimp simp:reply_cap_deletion_integrity_def) - apply (rule affects_delete_derived) - apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], - assumption) - apply (frule_tac p="(x,l)" in cap_auth_caps_of_state[rotated]) - apply (force simp: caps_of_state_def' intro:well_formed_cnode_invsI) - by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def - reply_cap_rights_to_auth_def - split: if_splits) - qed - qed + done + next + case (tro_alt_tcb_call tcb tcb' ccap' cap' ntfn' new_arch caller R ep) + thus ?case using hyps + apply (clarsimp simp add: direct_call_def ep_recv_blocked_def) + apply (rule affects_send[rotated 2]) + apply (erule (1) pas_refined_tcb_st_to_auth[rotated 2]; force) + apply (fastforce intro: sym_helper) + apply assumption + apply blast + done + next + case (tro_alt_tcb_reply tcb tcb' ccap' cap' ntfn' new_st new_arch) + thus ?case using hyps + apply (clarsimp simp: direct_reply_def) + apply (erule affects_reply) + by (rule sym_helper) + next + case (tro_alt_tcb_receive tcb tcb' ccap' cap' ntfn' new_arch new_st ep) + thus ?case using hyps + by (auto intro: affects_recv pas_refined_tcb_st_to_auth simp: send_blocked_on_def2) + next + case (tro_alt_tcb_restart tcb tcb' ccap' cap' ntfn' new_arch ep) + thus ?case using hyps + by (fastforce intro: affects_reset[where auth=Receive] affects_reset[where auth=SyncSend] + elim: blocked_on.elims pas_refined_tcb_st_to_auth[rotated 2] + intro!: sym_helper) + next + case (tro_alt_tcb_generic tcb tcb' ccap' cap' ntfn' new_arch) + have "tcb_bound_notification tcb \ ntfn' \ ?case" + using tro_alt_tcb_generic hyps + apply (clarsimp simp: tcb_bound_notification_reset_integrity_def) + by (cases "tcb_bound_notification tcb" ; + fastforce intro: affects_reset[where auth=Receive] bound_tcb_at_implies_receive + pred_tcb_atI sym_helper) + moreover have "tcb_caller tcb \ cap' \ ?case" + using tro_alt_tcb_generic(2,3,4,5,8) hyps + apply (clarsimp simp:reply_cap_deletion_integrity_def) + apply (rule affects_delete_derived) + apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], + assumption) + apply (frule cap_auth_caps_of_state[rotated,where p ="(x,tcb_cnode_index 3)"], + force simp: caps_of_state_def') + by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def + reply_cap_rights_to_auth_def + split: if_splits) + moreover have "tcb_ctable tcb \ ccap' \ ?case" + using tro_alt_tcb_generic(2,3,4,5,9) hyps + apply (clarsimp simp: reply_cap_deletion_integrity_def) + apply (rule affects_delete_derived) + apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], + assumption) + apply (frule cap_auth_caps_of_state[rotated,where p ="(x,tcb_cnode_index 0)"], + force simp: caps_of_state_def') + by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def reply_cap_rights_to_auth_def + split: if_splits) + moreover have "\ tcb_ctable tcb = ccap'; tcb_caller tcb = cap'; + tcb_bound_notification tcb = ntfn'; tcb_arch tcb \ new_arch \ \ ?case" + using tro_alt_tcb_generic(2,3,4,5,6) assms + by (fastforce intro: partitionIntegrity_subjectAffects_tcb_fpu) + ultimately show ?case + using tro_alt_tcb_generic(2,3,4) kh_diff + apply clarsimp + apply (case_tac "tcb_ctable tcb \ ccap'", fastforce) + apply (case_tac "tcb_caller tcb \ cap'", fastforce) + apply (case_tac "tcb_bound_notification tcb \ ntfn'", fastforce) + apply (case_tac "tcb_arch tcb \ new_arch", fastforce) + apply simp + done + next + case (tro_alt_tcb_activate tcb tcb' ntfn' ccap' cap' new_arch) + thus ?case by simp + next + case (tro_alt_cnode n content content') + thus ?case + using hyps unfolding cnode_integrity_def + apply clarsimp + apply (drule fun_noteqD) + apply (erule exE, rename_tac l) + apply (drule_tac x=l in spec) + apply (clarsimp dest!:not_sym[where t=None]) + apply (clarsimp simp:reply_cap_deletion_integrity_def) + apply (rule affects_delete_derived) + apply (rule aag_wellformed_delete_derived[rotated -1, OF pas_refined_wellformed], + assumption) + apply (frule_tac p="(x,l)" in cap_auth_caps_of_state[rotated]) + apply (force simp: caps_of_state_def' intro:well_formed_cnode_invsI) + by (fastforce simp: aag_cap_auth_def cap_auth_conferred_def + reply_cap_rights_to_auth_def + split: if_splits) + next + case (tro_alt_arch ao ao') + thus ?case using assms by (fastforce dest: partitionIntegrity_subjectAffects_aobj) qed qed @@ -1225,19 +1245,32 @@ lemma valid_sched_valid_blocked: "valid_sched s \ valid_blocked context Noninterference_1 begin lemma partitionIntegrity_subjectAffects_etcbs: - "\ partitionIntegrity (aag :: 'a subject_label PAS) s s'; pas_refined aag s; - valid_objs s; einvs s; einvs s'; pas_wellformed_noninterference aag; + assumes par_inte: "partitionIntegrity (aag :: 'a subject_label PAS) s s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows + "\ pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; + einvs s; einvs s'; pas_wellformed_noninterference aag; silc_inv aag st s; silc_inv aag st' s'; etcbs_of s x \ etcbs_of s' x \ \ pasObjectAbs aag x \ subjectAffects (pasPolicy aag) (pasSubject aag)" + apply (insert par_inte) apply (prop_tac "kheap s x \ kheap s' x") apply (clarsimp simp: etcbs_of'_def) + apply (case_tac "is_subject aag x") + using affects_lrefl apply fastforce apply (erule partitionIntegrity_subjectAffects_obj; simp) done lemma partitionIntegrity_subjectAffects_ready_queues: assumes domains_distinct: "pas_domains_distinct (aag :: 'a subject_label PAS)" - shows "\ partitionIntegrity aag s s'; pas_refined aag s; valid_objs s; einvs s; einvs s'; - pas_refined aag s'; pas_cur_domain aag s; pas_wellformed_noninterference aag; + shows "\ partitionIntegrity aag s s'; pas_refined aag s; pas_refined aag s'; + pas_cur_domain aag s; pas_cur_domain aag s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; + einvs s; einvs s'; pas_wellformed_noninterference aag; silc_inv aag st s; silc_inv aag st' s'; ready_queues s d \ ready_queues s' d; cur_thread s \ idle_thread s \ is_subject aag (cur_thread s); cur_thread s' \ idle_thread s' \ is_subject aag (cur_thread s') \ @@ -1267,12 +1300,12 @@ lemma partitionIntegrity_subjectAffects_ready_queues: apply (fastforce dest: domains_distinct[THEN pas_domains_distinct_inj]) apply (case_tac "etcbs_of s tcb_ptr \ etcbs_of s' tcb_ptr") apply (rule_tac s=s and s'=s' in partitionIntegrity_subjectAffects_etcbs) - apply (simp add: partitionIntegrity_def)+ + apply (simp add: partitionIntegrity_def)+ apply (subgoal_tac "kheap s tcb_ptr \ kheap s' tcb_ptr") apply (rule partitionIntegrity_subjectAffects_obj) - apply (fastforce simp add: partitionIntegrity_def valid_sched_def)+ - apply (rule_tac threads="tcb_ptr # tcbs" in ready_queues_alters_kheap) apply (fastforce simp add: partitionIntegrity_def valid_sched_def)+ + apply (rule_tac threads="tcb_ptr # tcbs" in ready_queues_alters_kheap) + apply (fastforce simp add: partitionIntegrity_def valid_sched_def)+ done end @@ -1319,10 +1352,18 @@ lemma sameFor_subject_def2: apply (rule conjI, rule refl) apply (rule conjI) apply (rule states_equiv_forI) - apply ((fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+)[5] - apply (fastforce intro: equiv_forI elim: states_equiv_forE_is_original_cap) - apply ((fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+)[2] - apply (solves \clarsimp simp: equiv_asids_def states_equiv_for_def\) + apply ((fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+)[4] + apply (fastforce intro: equiv_forI elim: states_equiv_forE_is_original_cap) + apply ((fastforce intro: equiv_forI elim: states_equiv_forE equiv_forD)+)[2] + apply (solves \clarsimp simp: equiv_asids_def states_equiv_for_def\) + apply (rule equiv_hypI) + apply (clarsimp simp: states_equiv_for_def) + apply (drule (1) bspec) + apply (fastforce elim!: equiv_hyp_guard_imp) + apply (rule equiv_fpuI) + apply (clarsimp simp: states_equiv_for_def) + apply (drule (1) bspec) + apply (fastforce elim!: equiv_fpu_guard_imp) apply (fastforce intro: equiv_forI elim: states_equiv_forE_ready_queues) apply fastforce done @@ -1366,9 +1407,12 @@ context Noninterference_1 begin lemma partsSubjectAffects_bounds_subjects_affects: assumes domains_distinct: "pas_domains_distinct (aag :: 'a subject_label PAS)" - shows "\ partitionIntegrity aag s s'; pas_refined aag s; pas_refined aag s'; valid_objs s; - valid_arch_state s'; einvs s; einvs s'; silc_inv aag st s; silc_inv aag st' s'; - pas_wellformed_noninterference aag; pas_cur_domain aag s; + shows "\ partitionIntegrity aag s s'; pas_refined aag s; pas_refined aag s'; + einvs s; einvs s'; + cur_hyp_in_cur_domain s; cur_hyp_in_cur_domain s'; + cur_fpu_in_cur_domain s; cur_fpu_in_cur_domain s'; + silc_inv aag st s; silc_inv aag st' s'; + pas_wellformed_noninterference aag; pas_cur_domain aag s; pas_cur_domain aag s'; guarded_is_subject_cur_thread aag s; guarded_is_subject_cur_thread aag s'; d \ partsSubjectAffects (pasPolicy aag) (label_of (pasSubject aag)); d \ PSched \ \ (((uc,s),mode),((uc',s'),mode')) \ same_for aag d" @@ -1377,12 +1421,16 @@ lemma partsSubjectAffects_bounds_subjects_affects: apply (cases d) prefer 2 apply simp + apply (unfold sameFor_def sameFor_subject_def2) apply (clarsimp simp: sameFor_def sameFor_subject_def2 states_equiv_for_def equiv_for_def - partsSubjectAffects_def image_def label_can_affect_partition_def) + partsSubjectAffects_def image_def label_can_affect_partition_def) apply (safe del: iffI notI) + apply (drule partitionIntegrity_subjectAffects_hyp) + apply (simp add: domains_distinct)+ + apply fastforce + apply (fastforce dest: partitionIntegrity_subjectAffects_asid) apply (fastforce dest: partitionIntegrity_subjectAffects_obj) - apply ((auto dest: partitionIntegrity_subjectAffects_obj - partitionIntegrity_subjectAffects_mem + apply ((auto dest: partitionIntegrity_subjectAffects_mem partitionIntegrity_subjectAffects_device partitionIntegrity_subjectAffects_cdt partitionIntegrity_subjectAffects_cdt_list @@ -1395,7 +1443,10 @@ lemma partsSubjectAffects_bounds_subjects_affects: OF domains_distinct] domains_distinct[THEN pas_domains_distinct_inj] | fastforce simp: partitionIntegrity_def - silc_dom_equiv_def equiv_for_def)+)[11] + silc_dom_equiv_def equiv_for_def)+)[10] + apply (drule partitionIntegrity_subjectAffects_fpu) + apply (simp add: domains_distinct)+ + apply fastforce apply ((fastforce intro: affects_lrefl simp: partitionIntegrity_def domain_fields_equiv_def dest: domains_distinct[THEN pas_domains_distinct_inj])+)[16] @@ -1404,17 +1455,6 @@ lemma partsSubjectAffects_bounds_subjects_affects: end -lemma cur_thread_not_SilcLabel: - "\ silc_inv aag st s; invs s \ \ pasObjectAbs aag (cur_thread s) \ SilcLabel" - apply (rule notI) - apply (simp add: silc_inv_def) - apply (drule tcb_at_invs) - apply clarify - apply (drule_tac x="cur_thread s" in spec, erule (1) impE) - apply (auto simp: obj_at_def is_tcb_def is_cap_table_def) - apply (case_tac ko, simp_all) - done - lemma ev_add_pre: "equiv_valid_inv I A P f \ equiv_valid_inv I A (P and Q) f" apply (rule equiv_valid_guard_imp) @@ -1424,7 +1464,7 @@ lemma ev_add_pre: crunch check_active_irq_if for invs[wp]: "einvs" - (wp: dmo_getActiveIRQ_wp ignore: do_machine_op) + (ignore: do_machine_op) crunch thread_set for schact_is_rct[wp]: "schact_is_rct" @@ -1946,11 +1986,15 @@ lemma integrity_part: apply (fastforce dest!: reachable_invs_if[OF reachable_Step'] simp: invs_if_def Invs_def) apply (fastforce dest!: reachable_invs_if simp: invs_if_def Invs_def) apply (fastforce dest!: reachable_invs_if[OF reachable_Step'] simp: invs_if_def Invs_def) + apply (fastforce dest!: reachable_invs_if simp: invs_if_def Invs_def) + apply (fastforce dest!: reachable_invs_if[OF reachable_Step'] simp: invs_if_def Invs_def) apply (fastforce dest: silc_inv_initial_aag_reachable simp: silc_inv_cur) - apply (frule Step_current_aag_unchanged[symmetric];simp) + apply (frule Step_current_aag_unchanged[symmetric]; simp) apply (fastforce dest: silc_inv_initial_aag_reachable[OF reachable_Step'] simp: silc_inv_cur) apply (rule pas_wellformed_cur) apply (simp add: current_aag_def) + apply (frule Step_current_aag_unchanged[symmetric];simp) + apply (simp add: current_aag_def) apply (fastforce dest!: reachable_invs_if domains_distinct[THEN pas_domains_distinct_inj] simp: invs_if_def Invs_def guarded_pas_domain_def guarded_is_subject_cur_thread_def current_aag_def) @@ -2148,11 +2192,12 @@ lemma tcb_sched_action_reads_respects_g': apply (wp set_tcb_queue_reads_respects_g') apply (rule_tac Q="\s. pasObjectAbs aag thread \ pasDomainAbs aag (tcb_domain rv)" in equiv_valid_guard_imp) - apply (wp gets_apply_ev') + apply (wp gets_apply_ev) apply (clarsimp simp: reads_equiv_g_def) apply (elim reads_equivE affects_equivE equiv_forE) apply (clarsimp simp: disjoint_iff_not_equal) - apply metis (* only one that works *) + apply (erule_tac x="tcb_domain rv" in meta_allE)+ + apply blast apply (wp | simp)+ apply (intro conjI impI allI | fastforce simp: get_tcb_def reads_equiv_g_def @@ -2185,7 +2230,7 @@ lemma tcb_sched_action_reads_respects_g': lemma switch_to_thread_reads_respects_g: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows "reads_respects_g aag (l :: 'a subject_label) - (pas_refined aag and (\s. is_subject aag t)) (switch_to_thread t)" + (pas_refined aag and invs and (\s. is_subject aag t)) (switch_to_thread t)" apply (simp add: switch_to_thread_def) apply (subst bind_assoc[symmetric]) apply (rule equiv_valid_guard_imp) @@ -2202,7 +2247,7 @@ lemma switch_to_thread_reads_respects_g: lemma guarded_switch_to_reads_respects_g: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows "reads_respects_g aag (l :: 'a subject_label) - (pas_refined aag and valid_idle and (\s. is_subject aag t)) + (pas_refined aag and invs and (\s. is_subject aag t)) (guarded_switch_to t)" apply (simp add: guarded_switch_to_def) apply (wp switch_to_thread_reads_respects_g get_thread_state_reads_respects_g gts_wp) @@ -2219,7 +2264,7 @@ lemma cur_thread_update_idle_reads_respects_g': done lemma switch_to_idle_thread_reads_respects_g[wp]: - "reads_respects_g aag (l :: 'a subject_label) \ (switch_to_idle_thread)" + "reads_respects_g aag (l :: 'a subject_label) valid_arch_state (switch_to_idle_thread)" apply (simp add: switch_to_idle_thread_def) apply (wp cur_thread_update_idle_reads_respects_g') apply (fastforce simp: reads_equiv_g_def globals_equiv_idle_thread_ptr) @@ -2239,7 +2284,7 @@ lemma choose_thread_reads_respects_g: apply (clarsimp simp: reads_equiv_g_def reads_equiv_def2 states_equiv_for_def equiv_for_def disjoint_iff_not_equal) apply (metis reads_lrefl) - apply (simp add: invs_valid_idle) + apply (simp add: invs_arch_state) (* everything from here clagged from Syscall_AC.choose_thread_respects *) apply (clarsimp simp: pas_refined_def) apply (clarsimp simp: tcb_domain_map_wellformed_aux_def) @@ -2299,7 +2344,7 @@ lemma reads_equiv_valid_g_inv_schedule_switch_thread_fastfail: lemma reads_respects_gets_ready_queues: "reads_respects aag l (\s. pasSubject aag \ pasDomainAbs aag d) (gets (\s. f (ready_queues s d)))" - apply (wp gets_ev'') + apply (wp gets_ev) apply (force elim: reads_equivE simp: equiv_for_def) done @@ -2326,11 +2371,11 @@ lemma schedule_choose_new_thread_reads_respects_g: ((\s. domain_time s \ 0) and einvs and pas_cur_domain aag and pas_refined aag and (\s. (cur_thread s \ idle_thread s \ is_subject aag (cur_thread s)))) schedule_choose_new_thread" - apply (simp add: schedule_choose_new_thread_def ) + apply (simp add: schedule_choose_new_thread_def) apply (subst gets_app_rewrite[where y=domain_time and f="\x. x = 0"])+ apply (wp gets_domain_time_zero_ev set_scheduler_action_reads_respects_g choose_thread_reads_respects_g ev_pre_cont[where f=next_domain] - arch_prepare_next_domain_ev hoare_pre_cont[where f=next_domain] when_ev) + arch_prepare_next_domain_reads_respects_g hoare_pre_cont[where f=next_domain] when_ev) apply (clarsimp simp: valid_sched_def word_neq_0_conv) done @@ -2832,52 +2877,32 @@ lemma kernel_schedule_if_confidentiality': end -lemma thread_set_tcb_context_update_runnable_globals_equiv: - "\globals_equiv st and st_tcb_at runnable t and invs\ - thread_set (tcb_arch_update (arch_tcb_context_set uc)) t - \\_. globals_equiv st\" - apply (rule hoare_pre) - apply (rule thread_set_context_globals_equiv) - apply clarsimp - apply (frule invs_valid_idle) - apply (fastforce simp: valid_idle_def pred_tcb_at_def obj_at_def) - done - -lemma thread_set_tcb_context_update_reads_respects_g: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_g aag (l :: 'a subject_label) (st_tcb_at runnable t and invs) - (thread_set (tcb_arch_update (arch_tcb_context_set uc)) t)" +lemma thread_set_reads_respects_g: + "reads_respects_g aag (l :: 'a subject_label) (st_tcb_at runnable t and invs) (thread_set f t)" apply (rule equiv_valid_guard_imp) apply (rule reads_respects_g) - apply (rule thread_set_reads_respects[OF domains_distinct]) + apply (rule thread_set_reads_respects) apply (rule doesnt_touch_globalsI) - apply (wp thread_set_tcb_context_update_runnable_globals_equiv) + apply (wp thread_set_globals_equiv') apply simp+ + apply (fastforce dest: invs_valid_idle simp: valid_idle_def pred_tcb_at_def obj_at_def) done -lemma thread_set_tcb_context_update_silc_inv[wp]: - "thread_set (tcb_arch_update (arch_tcb_context_set f)) t \silc_inv aag st\" - apply (rule thread_set_silc_inv) - apply (simp add: tcb_cap_cases_def) - done - -lemmas thread_set_tcb_context_update_reads_respects_f_g = - reads_respects_f_g'[where Q="\", simplified, - OF thread_set_tcb_context_update_reads_respects_g, - OF _ thread_set_tcb_context_update_silc_inv] +lemmas thread_set_reads_respects_f_g = + reads_respects_f_g'[where Q="\", simplified, OF thread_set_reads_respects_g] lemma kernel_entry_if_reads_respects_f_g: assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_f_g aag l (ct_active and silc_inv aag st and einvs + shows "reads_respects_f_g aag l (ct_active and silc_inv aag st and einvs and valid_cur_hyp and only_timer_irq_inv irq st' and schact_is_rct and pas_refined aag and pas_cur_domain aag and guarded_pas_domain aag and K (ev \ Interrupt \ \ pasMaySendIrqs aag)) (kernel_entry_if ev tc)" apply (simp add: kernel_entry_if_def) - apply (wp handle_event_reads_respects_f_g thread_set_tcb_context_update_reads_respects_f_g - thread_set_tcb_context_update_silc_inv only_timer_irq_inv_pres[where P="\" and Q="\"] - thread_set_invs_trivial thread_set_not_state_valid_sched thread_set_pas_refined + apply (wp handle_event_reads_respects_f_g thread_set_reads_respects_f_g + only_timer_irq_inv_pres[where P="\" and Q="\"] + thread_set_invs_trivial thread_set_not_state_valid_sched thread_set_context_pas_refined | simp add: tcb_cap_cases_def arch_tcb_update_aux2)+ apply (elim conjE) apply (frule (1) ct_active_cur_thread_not_idle_thread[OF invs_valid_idle]) @@ -3500,6 +3525,22 @@ lemma handle_preemption_agnostic_tc: context Noninterference_1 begin +lemma handle_non_kernel_IRQ_ev2: + "equiv_valid_2 I A A R P (domain_sep_inv False st and K (irq \ maxIRQ \ irq \ non_kernel_IRQs)) + LHS (handle_interrupt irq >>= RHS)" + unfolding handle_interrupt_def + apply (rule EquivValid.gen_asm_ev2_r) + apply (prop_tac "\maxIRQ < irq") + apply (clarsimp simp: not_less) + apply (clarsimp simp: bind_assoc) + apply (rule_tac Q="\irq _. irq = IRQInactive" in equiv_valid_2_bind_right) + apply (rule gen_asm_ev2_r) + apply (clarsimp simp: fail_ev2_r) + apply (wpsimp simp: get_irq_state_def)+ + apply (fastforce simp: domain_sep_inv_def) + apply simp + done + lemma preemption_interrupt_scheduler_invisible: assumes domains_distinct[wp]: "pas_domains_distinct (aag :: 'a subject_label PAS)" shows "equiv_valid_2 (scheduler_equiv aag) (scheduler_affects_equiv aag l) @@ -3515,21 +3556,24 @@ lemma preemption_interrupt_scheduler_invisible: and (\s. ct_idle s \ uc' = idle_context s) and (\s. \ reads_scheduler_cur_domain aag l s)) (handle_preemption_if uc) (kernel_entry_if Interrupt uc')" - apply (simp add: kernel_entry_if_def handle_preemption_if_def maybe_handle_interrupt_def - getActiveIRQ_no_non_kernel_IRQs) + apply (simp add: kernel_entry_if_def handle_preemption_if_def maybe_handle_interrupt_def) apply (rule equiv_valid_2_bind_right) apply (rule equiv_valid_2_bind_right) apply (simp add: liftE_def bind_assoc) apply (simp only: option.case_eq_if) - apply (rule equiv_valid_2_bind_pre[where R'="(=)"]) + apply (rule equiv_valid_2_bind_pre[OF _ getActiveIRQ_ev2]) + apply (elim disjE) apply (simp split del: if_split) apply (rule equiv_valid_2_bind_pre[where R'="(=)" and Q="\\" and Q'="\\"]) apply (rule return_ev2) apply simp apply (rule equiv_valid_2) apply (wp handle_interrupt_reads_respects_scheduler[where st=st and st'=st'] | simp)+ - apply (rule equiv_valid_2) - apply (rule dmo_getActive_IRQ_reads_respect_scheduler) + apply clarsimp + apply (rule equiv_valid_2_guard_imp) + apply (rule handle_non_kernel_IRQ_ev2) + apply simp + apply fastforce apply (wp dmo_getActiveIRQ_return_axiom[simplified try_some_magic] | simp add: imp_conjR arch_tcb_update_aux2 | elim conjE @@ -3592,7 +3636,7 @@ lemma kernel_entry_scheduler_equiv_2: | wp (once) hoare_drop_imps)+ apply (rule context_update_cur_thread_snippit) apply (wp thread_set_invs_trivial guarded_pas_domain_lift - thread_set_pas_refined thread_set_not_state_valid_sched + thread_set_context_pas_refined thread_set_not_state_valid_sched | simp add: tcb_cap_cases_def arch_tcb_update_aux2)+ apply (fastforce simp: silc_inv_not_cur_thread cur_thread_idle)+ done @@ -3894,9 +3938,10 @@ lemma schedule_step: done lemma schedule_if_reads_respects_scheduler: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "reads_respects_scheduler aag l - (einvs and pas_refined aag and silc_inv aag st and guarded_pas_domain aag and tick_done) + (einvs and pas_refined aag and silc_inv aag st and guarded_pas_domain aag and tick_done and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain) (schedule_if uc)" apply (simp add: schedule_if_def) apply (wp schedule_reads_respects_scheduler schedule_guarded_pas_domain) @@ -4015,7 +4060,7 @@ lemma scheduler_step_2_confidentiality: apply (rule equiv_valid_2E[where s="internal_state_if s" and t="internal_state_if t", OF schedule_if_reads_respects_scheduler_2 [where aag="initial_aag" and st="s0_internal" - and l="label_for_partition u", OF domains_distinct]], + and l="label_for_partition u", OF policy_wellformed]], assumption,assumption) apply (rule uwr_scheduler_affects_equiv,simp+) apply ((clarsimp simp: blob)+)[2] diff --git a/proof/infoflow/Noninterference_Base.thy b/proof/infoflow/Noninterference_Base.thy index 9c163a697f..d7d29b4c77 100644 --- a/proof/infoflow/Noninterference_Base.thy +++ b/proof/infoflow/Noninterference_Base.thy @@ -1287,7 +1287,7 @@ lemma Noninfluence_gen_integrity_u: apply (drule_tac x=s in spec, drule_tac x="{s}" in spec) apply (simp add: sources_Step sameFor_dom_def uwr_equiv_def Step_def ipurge_Cons ipurge_Nil uwr_refl policy_refl execution_Nil uwr_sym - split: if_splits ) + split: if_splits) done lemma Noninfluence_strong_uwr_integrity_u: diff --git a/proof/infoflow/PasUpdates.thy b/proof/infoflow/PasUpdates.thy index 4dc274e8d5..89e6dd7a1d 100644 --- a/proof/infoflow/PasUpdates.thy +++ b/proof/infoflow/PasUpdates.thy @@ -72,8 +72,7 @@ lemma tcb_domain_map_wellformed_pasSubject_update: by (clarsimp simp: tcb_domain_map_wellformed_aux_def) -(* FIXME: rename PasUpdates_2 to PasUpdates_1; original PasUpdates_1 was removed *) -locale PasUpdates_2 = +locale PasUpdates_1 = fixes aag :: "'a subject_label PAS" assumes state_asids_to_policy_pasSubject_update: "state_asids_to_policy (aag\pasSubject := subject\) s = @@ -203,7 +202,7 @@ lemma state_irqs_to_policy_pasMayEditReadyQueues_update: done -context PasUpdates_2 begin +context PasUpdates_1 begin lemma pas_refined_pasMayActivate_update: "pas_refined aag s diff --git a/proof/infoflow/RISCV64/ArchADT_IF.thy b/proof/infoflow/RISCV64/ArchADT_IF.thy index e1bdb8cc48..7ec47b1afc 100644 --- a/proof/infoflow/RISCV64/ArchADT_IF.thy +++ b/proof/infoflow/RISCV64/ArchADT_IF.thy @@ -19,6 +19,74 @@ context Arch begin global_naming RISCV64 named_theorems ADT_IF_assms +lemma dmo_getActiveIRQ_wp'[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\)) + and domain_sep_inv False st and valid_irq_states\ + do_machine_op (getActiveIRQ in_kernel) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma dmo_getActiveIRQ_wp[ADT_IF_assms]: + "\(\s. P (irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s))) + (s\machine_state := (machine_state s\irq_state := irq_state (machine_state s) + 1\)\))\ + do_machine_op (getActiveIRQ False) + \P\" + apply (simp add: do_machine_op_def getActiveIRQ_def non_kernel_IRQs_def) + apply (wp modify_wp | wpc)+ + apply clarsimp + apply (erule use_valid) + apply (wp modify_wp) + apply (auto simp: Let_def non_kernel_IRQs_def irq_at_def split: if_splits) + done + +lemma deleted_irq_handler_valid_irq_states[ADT_IF_assms,wp]: + "deleted_irq_handler irq \valid_irq_states\" + unfolding deleted_irq_handler_def set_irq_state_def valid_irq_states_def valid_irq_masks_def maskInterrupt_def + by (wpsimp wp: dmo_wp) + +lemma dmo_valid_irq_states[ADT_IF_assms,wp]: + "(\P. f \\s. P (irq_masks s)\) \ do_machine_op f \valid_irq_states\" + unfolding valid_irq_states_def do_machine_op_def + by (wpsimp, erule use_valid; assumption) + +lemma dmo_getActiveIRQ_valid_irq_states[ADT_IF_assms,wp]: + "do_machine_op (getActiveIRQ in_kernel) \valid_irq_states\" + unfolding getActiveIRQ_def by wpsimp + +crunch setVSpaceRoot, sfence, hwASIDFlush + for irq_masks[wp]: "\s. P (irq_masks s)" + +crunch prepare_thread_delete, arch_finalise_cap, arch_post_cap_deletion + for valid_irq_states[ADT_IF_assms,wp]: "\s :: det_state. valid_irq_states s" + (wp: crunch_wps mapM_x_wp hoare_drop_imps simp: crunch_simps) + +lemmas [ADT_IF_assms] = + cur_hyp_in_cur_domain_taut + cur_fpu_in_cur_domain_taut + cur_hyp_in_cur_domain_wp + cur_fpu_in_cur_domain_wp + valid_cur_hyp_triv + +end + + +global_interpretation ADT_IF_1?: ADT_IF_1 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_assms | solves \wp only: ADT_IF_assms; simp\)?) +qed + + +context Arch begin global_naming RISCV64 + (* FIXME: clagged from AInvs.do_user_op_invs *) lemma do_user_op_if_invs[ADT_IF_assms]: "\invs and ct_running\ @@ -81,12 +149,6 @@ lemma tcb_arch_ref_tcb_context_set[ADT_IF_assms, simp]: "tcb_arch_ref (tcb_arch_update (arch_tcb_context_set tc) tcb) = tcb_arch_ref tcb" by (simp add: tcb_arch_ref_def) -crunch arch_switch_to_idle_thread, arch_switch_to_thread - for pspace_aligned[ADT_IF_assms, wp]: "\s :: det_state. pspace_aligned s" - and valid_vspace_objs[ADT_IF_assms, wp]: "\s :: det_state. valid_vspace_objs s" - and valid_arch_state[ADT_IF_assms, wp]: "\s :: det_state. valid_arch_state s" - (wp: crunch_wps simp: crunch_simps) - crunch arch_activate_idle_thread, arch_switch_to_thread for cur_thread[ADT_IF_assms, wp]: "\s. P (cur_thread s)" @@ -106,14 +168,14 @@ lemma arch_invoke_irq_control_noErr[ADT_IF_assms, wp]: by (cases a; wpsimp) lemma getActiveIRQ_None[ADT_IF_assms]: - "(None,s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) \ + "(None,s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = None" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) by simp lemma getActiveIRQ_Some[ADT_IF_assms]: - "(Some i, s') \ fst (do_machine_op (getActiveIRQ in_kernel) s) + "(Some i, s') \ fst (do_machine_op (getActiveIRQ False) s) \ irq_at (irq_state (machine_state s) + 1) (irq_masks (machine_state s)) = Some i" apply (erule use_valid) apply (wp dmo_getActiveIRQ_wp) @@ -235,11 +297,18 @@ lemma do_user_op_if_irq_measure_if[ADT_IF_assms]: | wps |wp dmo_wp | wpc)+ done -crunch set_flags +crunch set_flags, arch_post_set_flags for irq_states_of_state[wp]: "\s. P (irq_state_of_state s)" +lemma checked_cap_insert_valid_irq_states[wp]: + "check_cap_at a b (check_cap_at c d (cap_insert a b e)) \valid_irq_states\" + by (wpsimp simp: check_cap_at_def)+ + +crunch set_mcpriority + for valid_irq_states[wp]: valid_irq_states + lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: - "\(\s. irq_state_inv st s) and domain_sep_inv False sta + "\(\s. irq_state_inv st s) and domain_sep_inv False (sta :: det_state) and valid_irq_states and tcb_inv_wf tinv and K (irq_is_recurring irq st)\ invoke_tcb tinv \\_ s. irq_state_inv st s\, \\_. irq_state_next st\" @@ -252,7 +321,8 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: defer apply ((wp irq_state_inv_triv | simp)+)[2] apply (simp add: split_def cong: option.case_cong) - by (wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R + by (clarsimp split del: if_split cong: conj_cong + | wp hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_vcg_const_imp_liftE_R checked_cap_insert_domain_sep_inv cap_delete_deletes cap_delete_irq_state_inv[where st=st and sta=sta and irq=irq] cap_delete_irq_state_next[where st=st and sta=sta and irq=irq] @@ -264,19 +334,33 @@ lemma invoke_tcb_irq_state_inv[ADT_IF_assms]: | wp (once) irq_state_inv_triv hoare_drop_imps | clarsimp split: option.splits | intro impI conjI allI)+ +crunch freeMemory + for irq_masks[wp]: "\s. P (irq_masks s)" + (wp: mapM_x_wp) + +lemma valid_irq_states_kheap_update[simp]: + "valid_irq_states (kheap_update f s) = valid_irq_states s" + by (simp add: valid_irq_states_def) + +crunch delete_objects + for valid_irq_states[wp]: valid_irq_states + (wp: dmo_machine_state_lift simp: crunch_simps detype_def) + lemma reset_untyped_cap_irq_state_inv[ADT_IF_assms]: - "\irq_state_inv st and K (irq_is_recurring irq st)\ + "\irq_state_inv st and domain_sep_inv False (sta :: det_state) and valid_irq_states and K (irq_is_recurring irq st)\ reset_untyped_cap slot \\y. irq_state_inv st\, \\y. irq_state_next st\" apply (cases "irq_is_recurring irq st", simp_all) apply (simp add: reset_untyped_cap_def) apply (rule hoare_pre) - apply (wp no_irq_clearMemory mapME_x_wp' hoare_vcg_const_imp_lift - get_cap_wp preemption_point_irq_state_inv'[where irq=irq] - | rule irq_state_inv_triv - | simp add: unless_def - | wp (once) dmo_wp)+ - done + by (wp no_irq_clearMemory hoare_vcg_const_imp_lift set_cap_domain_sep_inv + hoare_post_addE[where Q'="domain_sep_inv False sta and valid_irq_states", OF mapME_x_wp'] + get_cap_wp preemption_point_irq_state_inv'[where irq=irq] + | rule hoare_vcg_conj_lift + | rule irq_state_inv_triv + | simp add: unless_def + | wp (once) dmo_wp + | fastforce)+ crunch handle_vm_fault, handle_hypervisor_fault @@ -311,20 +395,43 @@ lemma thread_set_pas_refined[ADT_IF_assms]: thread_set_thread_st_auth_trivT[OF st] thread_set_thread_bound_ntfns_trivT[OF ntfn])+ + +lemma thread_set_context_state_hyp_refs_of: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \\s. P (state_hyp_refs_of s)\" + by (wpsimp simp: thread_set_def wp: set_object_wp ) + +lemma thread_set_context_pas_refined[ADT_IF_assms]: + "thread_set (tcb_arch_update (arch_tcb_context_set ctxt)) t \pas_refined aag\" + unfolding pas_refined_def state_objs_to_policy_def + apply (rule hoare_weaken_pre) + apply (wpsimp wp: tcb_domain_map_wellformed_lift_strong thread_set_edomains) + apply (wps thread_set_state_vrefs thread_set_context_state_hyp_refs_of) + apply (rule hoare_lift_Pf2[where f="caps_of_state"]) + apply (rule hoare_lift_Pf2[where f="thread_st_auth"]) + apply (rule hoare_lift_Pf2[where f="thread_bound_ntfns"]) + apply wp + apply (wpsimp wp: thread_set_thread_bound_ntfns_trivT ) + apply (wpsimp wp: thread_set_thread_st_auth_trivT) + apply (wpsimp wp: thread_set_caps_of_state_trivial simp: ran_tcb_cap_cases) + apply simp + done + +declare init_arch_objects_inv[ADT_IF_assms] + end -global_interpretation ADT_IF_1?: ADT_IF_1 +global_interpretation ADT_IF_2?: ADT_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact ADT_IF_assms | wp init_arch_objects_inv)?) + by (unfold_locales; (fact ADT_IF_assms)?) qed sublocale valid_initial_state \ valid_initial_state?: ADT_valid_initial_state .. -hide_fact ADT_IF_1.do_user_op_silc_inv +hide_fact ADT_IF_2.do_user_op_silc_inv requalify_facts RISCV64.do_user_op_silc_inv declare do_user_op_silc_inv[wp] diff --git a/proof/infoflow/RISCV64/ArchArch_IF.thy b/proof/infoflow/RISCV64/ArchArch_IF.thy index c9fa7ca9a9..60f54bc57e 100644 --- a/proof/infoflow/RISCV64/ArchArch_IF.thy +++ b/proof/infoflow/RISCV64/ArchArch_IF.thy @@ -106,11 +106,10 @@ lemma store_word_offs_reads_respects[Arch_IF_assms]: apply (simp add: storeWord_def) apply (simp add: do_machine_op_bind) apply wp - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def in_monad) apply (fastforce intro: equiv_forI elim: equiv_forE simp: upto.simps comp_def) - apply (rule use_spec_ev do_machine_op_spec_reads_respects assert_ev2 + apply (rule do_machine_op_reads_respects assert_ev2 | simp add: spec_equiv_valid_def | wp modify_wp)+ done @@ -139,26 +138,14 @@ lemma set_thread_state_globals_equiv[Arch_IF_assms]: split: option.splits kernel_object.splits)+ done -lemma set_cap_globals_equiv''[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state\ - set_cap cap p - \\_. globals_equiv s\" - unfolding set_cap_def - apply (simp only: split_def) - apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def - dest: valid_global_arch_objs_pt_at)+ - done - -lemma as_user_globals_equiv[Arch_IF_assms]: - "\globals_equiv s and valid_arch_state and (\s. tptr \ idle_thread s)\ - as_user tptr f - \\_. globals_equiv s\" - unfolding as_user_def - apply (wpsimp wp: set_object_globals_equiv simp: split_def) - apply (fastforce simp: valid_arch_state_def get_tcb_def obj_at_def - dest: valid_global_arch_objs_pt_at) - done +lemma thread_set_non_idle_globals_equiv[Arch_IF_assms]: + "\globals_equiv st and valid_arch_state and (\s. tptr \ idle_thread s)\ + thread_set f tptr + \\_. globals_equiv st\" + unfolding thread_set_def + apply (wp set_object_globals_equiv) + by (fastforce simp: valid_arch_state_def obj_at_def get_tcb_def + dest: valid_global_arch_objs_pt_at) declare arch_prepare_set_domain_inv[Arch_IF_assms] declare arch_prepare_next_domain_inv[Arch_IF_assms] @@ -180,7 +167,7 @@ global_interpretation Arch_IF_1?: Arch_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Arch_IF_assms)?) + by (unfold_locales; (fact Arch_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -397,9 +384,9 @@ lemma perform_page_invocation_reads_respects: perform_pg_inv_unmap_def perform_pg_inv_get_addr_def apply (rule equiv_valid_guard_imp) apply (wp dmo_mol_reads_respects mapM_x_ev'' store_pte_reads_respects set_cap_reads_respects - mapM_ev'' store_pte_reads_respects unmap_page_reads_respects dmo_mol_2_reads_respects + mapM_ev'' store_pte_reads_respects unmap_page_reads_respects get_cap_rev set_mrs_reads_respects set_message_info_reads_respects - | simp add: sfence_def + | simp add: sfence_def dmo_distr | wpc | wp (once) hoare_drop_imps[where Q'="\r s. r"])+ apply (clarsimp simp: authorised_page_inv_def valid_page_inv_def) apply (auto simp: cte_wp_at_caps_of_state authorised_slots_def cap_links_asid_slot_def @@ -815,14 +802,14 @@ lemma perform_pt_inv_map_globals_equiv: perform_pt_inv_map x11 x12 x13 x14 \\_. globals_equiv st\" unfolding perform_pt_inv_map_def - by (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv'' simp: sfence_def) + by (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv simp: sfence_def) lemma perform_pt_inv_unmap_globals_equiv: "\invs and globals_equiv st and cte_wp_at ((=) (ArchObjectCap cap)) ct_slot\ perform_pt_inv_unmap cap ct_slot \\_. globals_equiv st\" unfolding perform_pt_inv_unmap_def - apply (wpsimp wp: set_cap_globals_equiv'' mapM_x_swp_store_pte_globals_equiv) + apply (wpsimp wp: set_cap_globals_equiv mapM_x_swp_store_pte_globals_equiv) apply (strengthen invs_imps invs_valid_global_vspace_mappings) apply (clarsimp cong: conj_cong) apply (wpsimp wp: unmap_page_table_globals_equiv unmap_page_table_invs) @@ -852,7 +839,7 @@ lemma perform_page_table_invocation_globals_equiv: perform_page_table_invocation pti \\_. globals_equiv st\" unfolding perform_page_table_invocation_def - apply (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv'' + apply (wpsimp wp: store_pte_globals_equiv set_cap_globals_equiv perform_pt_inv_map_globals_equiv perform_pt_inv_unmap_globals_equiv) apply (case_tac pti; clarsimp simp: authorised_for_globals_page_table_inv_def valid_pti_def) @@ -991,7 +978,7 @@ lemma perform_pg_inv_unmap_globals_equiv: unfolding perform_pg_inv_unmap_def apply (rule hoare_weaken_pre) apply (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv - set_cap_globals_equiv'' unmap_page_globals_equiv store_pte_globals_equiv + set_cap_globals_equiv unmap_page_globals_equiv store_pte_globals_equiv store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv unmap_page_valid_arch_state perform_pg_inv_get_addr_globals_equiv | wpc | simp add: do_machine_op_bind sfence_def)+ @@ -1008,7 +995,7 @@ lemma perform_pg_inv_map_globals_equiv: \\_. globals_equiv st\" unfolding perform_pg_inv_map_def by (wp mapM_swp_store_pte_globals_equiv hoare_vcg_all_lift mapM_x_swp_store_pte_globals_equiv - set_cap_globals_equiv'' unmap_page_globals_equiv store_pte_globals_equiv + set_cap_globals_equiv unmap_page_globals_equiv store_pte_globals_equiv store_pte_globals_equiv hoare_weak_lift_imp set_message_info_globals_equiv unmap_page_valid_arch_state perform_pg_inv_get_addr_globals_equiv | wpc | simp add: do_machine_op_bind sfence_def | fastforce)+ @@ -1052,7 +1039,7 @@ lemma perform_asid_control_invocation_globals_equiv: apply (rule hoare_pre) apply wpc apply (rename_tac word1 cslot_ptr1 cslot_ptr2 word2) - apply (wp modify_wp cap_insert_globals_equiv'' + apply (wp modify_wp cap_insert_globals_equiv retype_region_ASIDPoolObj_globals_equiv[simplified] retype_region_invs_extras(5)[where sz=pageBits] retype_region_invs_extras(6)[where sz=pageBits] @@ -1135,7 +1122,7 @@ lemma store_asid_pool_entry_globals_equiv: store_asid_pool_entry pool_ptr asid ptr \\_. globals_equiv st\" unfolding store_asid_pool_entry_def - by (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' get_cap_wp | wpc | simp)+ + by (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv get_cap_wp | wpc | simp)+ lemma perform_asid_pool_invocation_globals_equiv: "\globals_equiv s and invs and valid_apinv api\ @@ -1143,7 +1130,7 @@ lemma perform_asid_pool_invocation_globals_equiv: \\_. globals_equiv s\" unfolding perform_asid_pool_invocation_def apply (rule hoare_weaken_pre) - apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv'' + apply (wp modify_wp set_asid_pool_globals_equiv set_cap_globals_equiv store_asid_pool_entry_globals_equiv copy_global_mappings_globals_equiv copy_global_mappings_valid_arch_state get_cap_wp | wpc | simp)+ @@ -1236,14 +1223,10 @@ lemma thread_set_globals_equiv: end -hide_fact as_user_globals_equiv - -context begin interpretation Arch . - -requalify_consts +arch_requalify_consts authorised_for_globals_arch_inv -requalify_facts +arch_requalify_facts arch_post_cap_deletion_valid_global_objs get_thread_state_globals_equiv auth_ipc_buffers_mem_Write' @@ -1253,11 +1236,7 @@ requalify_facts length_msg_lt_msg_max set_mrs_globals_equiv arch_perform_invocation_globals_equiv - as_user_globals_equiv - prepare_thread_delete_st_tcb_at_halted - make_arch_fault_msg_inv check_valid_ipc_buffer_inv - arch_tcb_update_aux2 arch_perform_invocation_reads_respects_g declare @@ -1267,10 +1246,6 @@ declare arch_post_modify_registers_cur_thread[wp] prepare_thread_delete_st_tcb_at_halted[wp] -end - -declare as_user_globals_equiv[wp] - axiomatization dmo_reads_respects where dmo_read_stval_reads_respects: "reads_respects aag l \ (do_machine_op read_stval)" diff --git a/proof/infoflow/RISCV64/ArchCNode_IF.thy b/proof/infoflow/RISCV64/ArchCNode_IF.thy index 7e4206eb53..38d487eee9 100644 --- a/proof/infoflow/RISCV64/ArchCNode_IF.thy +++ b/proof/infoflow/RISCV64/ArchCNode_IF.thy @@ -34,25 +34,15 @@ lemma set_object_globals_equiv'': \\_. globals_equiv s\" by (wpsimp wp: set_object_globals_equiv) -lemma set_cap_globals_equiv': - "\globals_equiv s and (\ s. fst p \ riscv_global_pt (arch_state s))\ - set_cap cap p - \\_. globals_equiv s\" - unfolding set_cap_def - apply (simp only: split_def) - apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: obj_at_def is_tcb_def) - done - lemma set_cap_globals_equiv[CNode_IF_assms]: - "\globals_equiv s and valid_global_objs and valid_arch_state\ + "\globals_equiv s and valid_arch_state\ set_cap cap p \\_. globals_equiv s\" unfolding set_cap_def apply (simp only: split_def) apply (wp set_object_globals_equiv hoare_vcg_all_lift get_object_wp | wpc | simp)+ - apply (fastforce simp: is_tcb_def obj_at_def valid_arch_state_def - dest: valid_global_arch_objs_pt_at) + apply (fastforce simp: valid_arch_state_def obj_at_def is_tcb_def + dest: valid_global_arch_objs_pt_at)+ done definition irq_at :: "nat \ (irq \ bool) \ irq option" where @@ -124,8 +114,7 @@ lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: notes gets_ev[wp del] shows "reads_respects aag l (invs and only_timer_irq_inv irq st) (do_machine_op (getActiveIRQ in_kernel))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects') + apply (rule do_machine_op_reads_respects') apply (simp add: getActiveIRQ_def) apply (wp irq_state_increment_reads_respects_memory irq_state_increment_reads_respects_device gets_ev[where f="irq_oracle \ irq_state"] equiv_valid_inv_conj_lift @@ -134,6 +123,15 @@ lemma dmo_getActiveIRQ_reads_respects[CNode_IF_assms]: apply (rule only_timer_irq_inv_determines_irq_masks, blast+) done +lemma dmo_getActiveIRQ_globals_equiv[CNode_IF_assms]: + "do_machine_op (getActiveIRQ in_kernel) \globals_equiv st\" + unfolding globals_equiv_def arch_globals_equiv_def idle_equiv_def + apply (rule hoare_weaken_pre) + apply wps + apply wpsimp + apply clarsimp + done + end diff --git a/proof/infoflow/RISCV64/ArchFinalCaps.thy b/proof/infoflow/RISCV64/ArchFinalCaps.thy index 6748f9ded7..07d403f90a 100644 --- a/proof/infoflow/RISCV64/ArchFinalCaps.thy +++ b/proof/infoflow/RISCV64/ArchFinalCaps.thy @@ -315,6 +315,10 @@ lemma invoke_tcb_silc_inv[FinalCaps_assms]: authorised_tcb_inv_def emptyable_def split: cap.splits option.splits)+ +lemma handle_reserved_irq_non_kernel_IRQs[FinalCaps_assms]: + "\P and K (irq \ non_kernel_IRQs)\ handle_reserved_irq irq \\_. P\" + unfolding handle_reserved_irq_def by wpsimp + end @@ -325,4 +329,12 @@ proof goal_cases by (unfold_locales; (fact FinalCaps_assms)?) qed + +global_interpretation FinalCaps_3?: FinalCaps_3 +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact FinalCaps_assms | solves \wp only: FinalCaps_assms; simp\)?) +qed + end diff --git a/proof/infoflow/RISCV64/ArchFinalise_IF.thy b/proof/infoflow/RISCV64/ArchFinalise_IF.thy index b8c153e13d..d91d35baa6 100644 --- a/proof/infoflow/RISCV64/ArchFinalise_IF.thy +++ b/proof/infoflow/RISCV64/ArchFinalise_IF.thy @@ -19,8 +19,7 @@ crunch arch_post_cap_deletion lemma dmo_maskInterrupt_reads_respects[Finalise_IF_assms]: "reads_respects aag l \ (do_machine_op (maskInterrupt m irq))" unfolding maskInterrupt_def - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) + apply (rule do_machine_op_reads_respects) apply (simp add: equiv_valid_def2) apply (rule modify_ev2) apply (fastforce simp: equiv_for_def) @@ -165,21 +164,16 @@ lemma set_notification_equiv_but_for_labels[Finalise_IF_assms]: done lemma thread_set_reads_respects[Finalise_IF_assms]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects aag l \ (thread_set x y)" - unfolding thread_set_def fun_app_def - apply (case_tac "aag_can_read aag y \ aag_can_affect aag l y") - apply (wp set_object_reads_respects) - apply (clarsimp, rule reads_affects_equiv_get_tcb_eq, simp+)[1] - apply (simp add: equiv_valid_def2) - apply (rule equiv_valid_rv_guard_imp) - apply (rule_tac L="{pasObjectAbs aag y}" and L'="{pasObjectAbs aag y}" - in ev2_invisible[OF domains_distinct]) - apply (assumption | simp add: labels_are_invisible_def)+ - apply (rule modifies_at_mostI[where P="\"] - | wp set_object_equiv_but_for_labels - | simp - | (clarify, drule get_tcb_not_asid_pool_at))+ + "reads_respects aag l \ (thread_set f thread)" + unfolding thread_set_def + apply (rule equiv_valid_guard_imp) + apply (rule_tac Q=\ and ptr=thread in reads_respects_unit_cases) + apply (rule gen_asm_ev') + apply (wpsimp wp: set_object_reads_respects) + apply (wp set_object_equiv_but_for_labels) + apply (clarsimp simp: get_tcb_def obj_at_def) + apply wpsimp + apply (auto intro: reads_affects_equiv_get_tcb_eq) done lemma aag_cap_auth_ASIDPoolCap: @@ -356,7 +350,7 @@ global_interpretation Finalise_IF_1?: Finalise_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Finalise_IF_assms)?) + by (unfold_locales; (fact Finalise_IF_assms | solves \wp only: Finalise_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy b/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy index cdf4d07659..b1ab9cee82 100644 --- a/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy +++ b/proof/infoflow/RISCV64/ArchIRQMasks_IF.thy @@ -158,6 +158,9 @@ lemma init_arch_objects_irq_masks: crunch arch_prepare_set_domain for inv[IRQMasks_IF_assms,wp]: P +crunch arch_prepare_next_domain + for valid_irq_states[wp]: valid_irq_states + end @@ -165,7 +168,7 @@ global_interpretation IRQMasks_IF_2?: IRQMasks_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact IRQMasks_IF_assms)?) + by (unfold_locales; (fact IRQMasks_IF_assms | solves wpsimp)?) qed diff --git a/proof/infoflow/RISCV64/ArchInfoFlow.thy b/proof/infoflow/RISCV64/ArchInfoFlow.thy index 9c532a8d9a..3965e19b0a 100644 --- a/proof/infoflow/RISCV64/ArchInfoFlow.thy +++ b/proof/infoflow/RISCV64/ArchInfoFlow.thy @@ -10,6 +10,8 @@ imports "Lib.EquivValid" begin +consts equiv_for :: "('a \ bool) \ ('b \ 'a \ 'c) \ 'b \ 'b \ bool" + context Arch begin global_naming RISCV64 section \Arch-specific equivalence properties\ @@ -62,6 +64,12 @@ definition arch_globals_equiv :: "obj_ref \ obj_ref \ kh declare arch_globals_equiv_def[simp] +definition equiv_hyp :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_hyp P s s' \ True" + +definition equiv_fpu :: "(obj_ref \ bool) \ det_state \ det_state \ bool" where + "equiv_fpu P s s' \ True" + end requalify_consts diff --git a/proof/infoflow/RISCV64/ArchInfoFlow_IF.thy b/proof/infoflow/RISCV64/ArchInfoFlow_IF.thy index 84e35db011..2e4f8e9e60 100644 --- a/proof/infoflow/RISCV64/ArchInfoFlow_IF.thy +++ b/proof/infoflow/RISCV64/ArchInfoFlow_IF.thy @@ -83,6 +83,72 @@ lemma equiv_asids_guard_imp[InfoFlow_IF_assms]: "\ equiv_asids R s s'; \x. Q x \ R x \ \ equiv_asids Q s s'" by (auto simp: equiv_asids_def) + +definition identical_hyp_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_hyp_state_updates _ _ _ _ _ \ True" + +definition identical_fpu_state_updates :: "(obj_ref \ bool) \ det_state \ det_state \ machine_state \ machine_state \ bool" where + "identical_fpu_state_updates _ _ _ _ _ \ True" + +definition no_hyp :: "'m machine_monad \ bool" where + "no_hyp f \ True" + +definition no_fpu :: "'m machine_monad \ bool" where + "no_fpu f \ True" + +lemma equiv_hyp_taut[intro!,simp]: + "equiv_hyp P s s'" + "equiv_hyp P st s = equiv_hyp P' st' s'" + by (simp_all add: equiv_hyp_def) + +lemma equiv_fpu_taut[intro!,simp]: + "equiv_fpu P s s'" + "equiv_fpu P st s = equiv_fpu P' st' s'" + by (simp_all add: equiv_fpu_def) + +lemma identical_hyp_states_updates_taut[intro!,simp]: + "identical_hyp_state_updates P s s' ms ms'" + by (simp add: identical_hyp_state_updates_def) + +lemma identical_fpu_states_updates_taut[intro!,simp]: + "identical_fpu_state_updates P s s' ms ms'" + by (simp add: identical_fpu_state_updates_def) + +lemma no_hyp_taut[intro!,simp]: + "no_hyp f" + by (simp add: no_hyp_def) + +lemma no_fpu_taut[intro!,simp]: + "no_fpu f" + by (simp add: no_fpu_def) + +lemmas equiv_arch_taut = + equiv_hyp_taut + equiv_fpu_taut + identical_hyp_states_updates_taut + identical_fpu_states_updates_taut + no_hyp_taut + no_fpu_taut + +end + +arch_requalify_consts + identical_hyp_state_updates + identical_fpu_state_updates + no_hyp + no_fpu + + +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 identical_hyp_state_updates identical_fpu_state_updates +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact InfoFlow_IF_assms | solves \rule equiv_arch_taut\)?) +qed + + +context Arch begin arch_global_naming + lemma dmo_loadWord_rev[InfoFlow_IF_assms]: "reads_equiv_valid_inv A aag (K (for_each_byte_of_word (aag_can_read aag) p)) (do_machine_op (loadWord p))" @@ -109,14 +175,51 @@ lemma dmo_loadWord_rev[InfoFlow_IF_assms]: apply (wp wp_post_taut loadWord_inv | simp)+ done +lemma do_machine_op_reads_respects'[InfoFlow_IF_assms]: + assumes equiv_dmo: + "equiv_valid_inv (equiv_machine_state (aag_can_read aag) and equiv_irq_state) + (equiv_machine_state (aag_can_affect aag l)) Q f" + assumes guard: + "\s. P s \ Q (machine_state s)" + and no_hyp: "no_hyp f" + and no_fpu: "no_fpu f" + shows + "reads_respects aag l P (do_machine_op f)" + apply (rule use_spec_ev) + unfolding do_machine_op_def spec_equiv_valid_def + apply (rule equiv_valid_2_guard_imp) + apply (rule_tac R'="\rv rv'. equiv_machine_state (aag_can_read aag or aag_can_affect aag l) rv rv' \ + equiv_irq_state rv rv'" + and Q="\r s. st = s \ Q r" and Q'="\ r s. Q r" and P="(=) st" and P'="\" in equiv_valid_2_bind) + apply (rule gen_asm_ev2_l[simplified K_def pred_conj_def]) + apply (rule gen_asm_ev2_r') + apply (rule_tac R'="\(r,ms') (r',ms''). r = r' \ + equiv_machine_state (aag_can_read aag) ms' ms'' \ + equiv_machine_state (aag_can_affect aag l) ms' ms'' \ + equiv_irq_state ms' ms''" + and Q="\r s. st = s" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (clarsimp simp: modify_def get_def put_def bind_def return_def equiv_valid_2_def) + apply (fastforce intro: reads_equiv_machine_state_update affects_equiv_machine_state_update) + apply (insert equiv_dmo)[1] + apply (clarsimp simp: select_f_def equiv_valid_2_def equiv_valid_def2 equiv_for_or split_def equiv_for_def)[1] + apply (drule_tac x=rv in spec, drule_tac x=rv' in spec) + apply (fastforce) + apply (rule select_f_inv) + apply (rule wp_post_taut) + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad) + apply (fastforce elim: reads_equivE affects_equivE equiv_forE intro: equiv_forI) + apply (wp | simp add: guard)+ + done + end -global_interpretation InfoFlow_IF_1?: InfoFlow_IF_1 +global_interpretation InfoFlow_IF_1?: InfoFlow_IF_2 identical_hyp_state_updates identical_fpu_state_updates no_hyp no_fpu proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact InfoFlow_IF_assms)?) + by (unfold_locales; (fact InfoFlow_IF_assms | solves \rule equiv_arch_taut\)?) qed end diff --git a/proof/infoflow/RISCV64/ArchInterrupt_IF.thy b/proof/infoflow/RISCV64/ArchInterrupt_IF.thy index f756c4029b..be591c46b2 100644 --- a/proof/infoflow/RISCV64/ArchInterrupt_IF.thy +++ b/proof/infoflow/RISCV64/ArchInterrupt_IF.thy @@ -29,13 +29,13 @@ lemma arch_invoke_irq_control_reads_respects[Interrupt_IF_assms]: done lemma arch_invoke_irq_control_globals_equiv[Interrupt_IF_assms]: - "\globals_equiv st and valid_arch_state and valid_global_objs\ + "\globals_equiv st and valid_arch_state\ arch_invoke_irq_control ai \\_. globals_equiv st\" apply (induct ai) apply (simp add: setIRQTrigger_def) apply (wpsimp wp: set_irq_state_globals_equiv set_irq_state_valid_global_objs - cap_insert_globals_equiv'' dmo_mol_globals_equiv) + cap_insert_globals_equiv dmo_mol_globals_equiv) done lemma arch_invoke_irq_handler_globals_equiv[Interrupt_IF_assms, wp]: diff --git a/proof/infoflow/RISCV64/ArchIpc_IF.thy b/proof/infoflow/RISCV64/ArchIpc_IF.thy index c137fd0f2b..90cc15a6bf 100644 --- a/proof/infoflow/RISCV64/ArchIpc_IF.thy +++ b/proof/infoflow/RISCV64/ArchIpc_IF.thy @@ -36,24 +36,25 @@ lemma storeWord_equiv_but_for_labels[Ipc_IF_assms]: apply (wp modify_wp) apply (clarsimp simp: equiv_but_for_labels_def) apply (rule states_equiv_forI) - apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD) - apply (simp add: states_equiv_for_def) - apply (rule conjI) - apply (rule equiv_forI) - apply clarsimp - apply (drule_tac f=underlying_memory in equiv_forD,fastforce) - apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right - simp: is_aligned_mask for_each_byte_of_word_def word_size_def upto.simps) - apply (rule equiv_forI) - apply clarsimp - apply (drule_tac f=device_state in equiv_forD,fastforce) - apply clarsimp - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) - apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) - apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply (fastforce intro!: equiv_forI elim!: states_equiv_forE dest: equiv_forD) + apply (simp add: states_equiv_for_def) + apply (rule conjI) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=underlying_memory in equiv_forD,fastforce) + apply (fastforce intro: is_aligned_no_wrap' word_plus_mono_right + simp: is_aligned_mask for_each_byte_of_word_def word_size_def upto.simps) + apply (rule equiv_forI) + apply clarsimp + apply (drule_tac f=device_state in equiv_forD,fastforce) + apply clarsimp + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=cdt_list]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=is_original_cap]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_states]) + apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=interrupt_irq_node]) + apply (fastforce simp: equiv_asids_def equiv_asid_def elim: states_equiv_forE) + apply auto[2] apply (fastforce elim: states_equiv_forE intro: equiv_forI dest: equiv_forD[where f=ready_queues]) done @@ -202,24 +203,22 @@ lemma dmo_loadWord_reads_respects[Ipc_IF_assms]: "reads_respects aag l (K (for_each_byte_of_word (\ x. aag_can_read_or_affect aag l x) p)) (do_machine_op (loadWord p))" apply (rule gen_asm_ev) - apply (rule use_spec_ev) - apply (rule spec_equiv_valid_hoist_guard) - apply (rule do_machine_op_spec_reads_respects) - apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) - apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" - and Q="\\" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) - apply (rule_tac R'="(=)" and Q="\ r s. p && mask 3 = 0" and Q'="\ r s. p && mask 3 = 0" - and P="\" and P'="\" in equiv_valid_2_bind_pre) - apply (rule return_ev2) - apply (rule_tac f="word_rcat" in arg_cong) - apply (fastforce simp: upto.simps is_aligned_mask for_each_byte_of_word_def word_size_def - intro: is_aligned_no_wrap' word_plus_mono_right) - apply (rule assert_ev2[OF refl]) - apply (rule assert_wp)+ - apply simp+ - apply (clarsimp simp: equiv_valid_2_def in_monad for_each_byte_of_word_def) - apply (fastforce elim: equiv_forD orthD1 simp: ptr_range_def add.commute) - apply (wp wp_post_taut loadWord_inv | simp)+ + apply (rule do_machine_op_reads_respects) + apply (simp add: loadWord_def equiv_valid_def2 spec_equiv_valid_def) + apply (rule_tac R'="\rv rv'. for_each_byte_of_word (\y. rv y = rv' y) p" + and Q="\\" and Q'="\\" and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule_tac R'="(=)" and Q="\ r s. p && mask 3 = 0" and Q'="\ r s. p && mask 3 = 0" + and P="\" and P'="\" in equiv_valid_2_bind_pre) + apply (rule return_ev2) + apply (rule_tac f="word_rcat" in arg_cong) + apply (fastforce simp: upto.simps is_aligned_mask for_each_byte_of_word_def word_size_def + intro: is_aligned_no_wrap' word_plus_mono_right) + apply (rule assert_ev2[OF refl]) + apply (rule assert_wp)+ + apply simp+ + apply (clarsimp simp: equiv_valid_2_def in_monad for_each_byte_of_word_def) + apply (fastforce elim: equiv_forD orthD1 simp: ptr_range_def add.commute) + apply (wp wp_post_taut loadWord_inv | simp)+ done lemma complete_signal_reads_respects[Ipc_IF_assms]: @@ -287,7 +286,7 @@ global_interpretation Ipc_IF_1?: Ipc_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Ipc_IF_assms)?) + by (unfold_locales; (fact Ipc_IF_assms | solves \wp only: Ipc_IF_assms; simp\)?) qed @@ -441,7 +440,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (simp add: equiv_valid_def2) apply (rule equiv_valid_rv_guard_imp) apply (case_tac buf) - apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in ev_invisible[OF domains_distinct]) + apply (rule_tac Q="\" and P="\" and L="{pasObjectAbs aag thread}" in revrv_invisible[OF domains_distinct]) apply (clarsimp simp: labels_are_invisible_def) apply (rule modifies_at_mostI) apply (simp add: set_mrs_def) @@ -451,7 +450,7 @@ lemma set_mrs_reads_respects'[Ipc_IF_assms]: apply (rename_tac buf') apply (rule_tac Q="\" and L="{pasObjectAbs aag thread} \ (pasObjectAbs aag) ` (ptr_range buf' msg_align_bits)" - in ev_invisible[OF domains_distinct]) + in revrv_invisible[OF domains_distinct]) apply (auto simp: labels_are_invisible_def ipc_buffer_has_auth_def dest: reads_read_page_read_thread simp: aag_can_affect_label_def)[1] apply (rule modifies_at_mostI) diff --git a/proof/infoflow/RISCV64/ArchNoninterference.thy b/proof/infoflow/RISCV64/ArchNoninterference.thy index 6fc8316d8c..202b57ceb0 100644 --- a/proof/infoflow/RISCV64/ArchNoninterference.thy +++ b/proof/infoflow/RISCV64/ArchNoninterference.thy @@ -285,9 +285,11 @@ lemma dmo_storeWord_reads_respects_g[Noninterference_assms, wp]: equiv_for_def equiv_asids_def equiv_asid_def silc_dom_equiv_def upto.simps) apply (rule affects_equiv_machine_state_update, assumption) apply (fastforce simp: equiv_for_def affects_equiv_def states_equiv_for_def upto.simps) + apply auto[2] apply (simp add: equiv_valid_def2 equiv_valid_2_def) done + lemma set_vm_root_reads_respects: "reads_respects aag l \ (set_vm_root tcb)" by (rule reads_respects_unobservable_unit_return) wp+ @@ -399,6 +401,56 @@ lemma arch_tcb_get_registers_equality[Noninterference_assms]: \ tcb_arch tcb = tcb_arch tcb'" by (auto simp: arch_tcb_get_registers_def intro: arch_tcb.equality user_context.expand) +lemma getActiveIRQ_ev2[Noninterference_assms]: + "equiv_valid_2 (scheduler_equiv aag) + (scheduler_affects_equiv aag l) (scheduler_affects_equiv aag l) + (\irq irq'. irq = irq' \ irq = None \ irq' \ Some ` non_kernel_IRQs) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (\s. irq_masks_of_state st = irq_masks_of_state s) + (do_machine_op (getActiveIRQ True)) (do_machine_op (getActiveIRQ False))" + apply (simp add: getActiveIRQ_no_non_kernel_IRQs) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + apply (erule use_valid, rule dmo_getActiveIRQ_wp)+ + apply clarsimp + apply (clarsimp simp: scheduler_equiv_def irq_at_def Let_def) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def + silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI impI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def equiv_asids_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def) + apply (clarsimp simp: arch_scheduler_affects_equiv_def) + done + +lemma arch_prepare_next_domain_reads_respects_g[Noninterference_assms]: + "reads_respects_g aag l invs arch_prepare_next_domain" + unfolding arch_prepare_next_domain_def by wpsimp + +lemma partitionIntegrity_subjectAffects_tcb_fpu[Noninterference_assms]: + assumes par_inte: "partitionIntegrity aag s s'" + and "kheap s x = Some (TCB tcb)" + "kheap s' x = Some (TCB tcb')" + "tcb' = tcb\tcb_arch := new_arch\" + "arch_tcb_get_registers new_arch = arch_tcb_get_registers (tcb_arch tcb)" + "tcb_hyp_refs new_arch = tcb_hyp_refs (tcb_arch tcb)" + "kheap s x \ kheap s' x" + "silc_inv aag st s" + "pas_wellformed_noninterference aag" + "pas_refined aag s" "pas_refined aag s'" + "pas_cur_domain aag s" "pas_cur_domain aag s'" + "cur_fpu_in_cur_domain s" "cur_fpu_in_cur_domain s'" + "invs s" "invs s'" + notes inte_obj = par_inte[THEN partitionIntegrity_integrity, THEN integrity_subjects_obj, + THEN spec[where x=x], simplified integrity_obj_def, simplified] + shows "subject_can_affect_label_directly aag (pasObjectAbs aag x)" + apply (insert assms(2,3,4,5,7)) + apply (clarsimp simp: arch_tcb_get_registers_def) + apply (subgoal_tac "new_arch = tcb_arch tcb") + apply clarsimp + apply (rule arch_tcb.equality; clarsimp?) + apply (rule user_context.expand; clarsimp) + done + end @@ -410,7 +462,8 @@ global_interpretation Noninterference_1?: Noninterference_1 _ arch_globals_equiv proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\)?) + by (unfold_locales; (fact Noninterference_assms | solves \rule integrity_arch_triv\ + | solves \wp only: Noninterference_assms; simp\)?) qed diff --git a/proof/infoflow/RISCV64/ArchPasUpdates.thy b/proof/infoflow/RISCV64/ArchPasUpdates.thy index 8752f7c869..cafef0519e 100644 --- a/proof/infoflow/RISCV64/ArchPasUpdates.thy +++ b/proof/infoflow/RISCV64/ArchPasUpdates.thy @@ -78,7 +78,7 @@ lemma state_asids_to_policy_pasMayEditReadyQueues_update[PasUpdates_assms]: end -global_interpretation PasUpdates_2?: PasUpdates_2 +global_interpretation PasUpdates_1?: PasUpdates_1 proof goal_cases interpret Arch . case 1 show ?case diff --git a/proof/infoflow/RISCV64/ArchRetype_IF.thy b/proof/infoflow/RISCV64/ArchRetype_IF.thy index bb3292268c..ea32d4d220 100644 --- a/proof/infoflow/RISCV64/ArchRetype_IF.thy +++ b/proof/infoflow/RISCV64/ArchRetype_IF.thy @@ -167,7 +167,8 @@ lemma copy_global_mappings_reads_respects_g: pspace_aligned s \ valid_global_arch_objs s" in hoare_weaken_pre) apply (rule gets_sp) apply (assumption) - apply (wp mapM_x_ev store_pte_reads_respects_g get_pte_revg) + apply (rule mapM_x_ev) + apply (wp store_pte_reads_respects_g get_pte_revg) apply (simp only: pt_index_def) apply (subst table_base_offset_id) apply clarsimp @@ -352,7 +353,7 @@ global_interpretation Retype_IF_1?: Retype_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Retype_IF_assms)?) + by (unfold_locales; (fact Retype_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -423,7 +424,6 @@ lemma reset_untyped_cap_reads_respects_g: apply (clarsimp simp: valid_cap_simps cap_aligned_def field_simps free_index_of_def invs_valid_global_objs) apply (simp add: aligned_add_aligned is_aligned_shiftl) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (rule hoare_pre) apply (wp preemption_point_inv' set_untyped_cap_invs_simple set_cap_cte_wp_at set_cap_no_overlap only_timer_irq_inv_pres[where Q=\, OF _ set_cap_domain_sep_inv] @@ -619,7 +619,6 @@ lemma reset_untyped_cap_globals_equiv: preemption_point_inv | simp add: if_apply_def2)+ apply (clarsimp simp: is_cap_simps ptr_range_def[symmetric] cap_aligned_def bits_of_def free_index_of_def) - apply (clarsimp simp: Kernel_Config.resetChunkBits_def) apply (strengthen invs_valid_global_objs invs_arch_state) apply (wp delete_objects_invs_ex hoare_vcg_const_imp_lift get_cap_wp)+ apply (clarsimp simp: cte_wp_at_caps_of_state descendants_range_def2 is_cap_simps bits_of_def diff --git a/proof/infoflow/RISCV64/ArchScheduler_IF.thy b/proof/infoflow/RISCV64/ArchScheduler_IF.thy index ad767505eb..4fbac62261 100644 --- a/proof/infoflow/RISCV64/ArchScheduler_IF.thy +++ b/proof/infoflow/RISCV64/ArchScheduler_IF.thy @@ -130,6 +130,7 @@ lemma equiv_asid_equiv_update[Scheduler_IF_assms]: by (clarsimp simp: equiv_asid_def obj_at_def get_tcb_def) declare arch_prepare_next_domain_inv[Scheduler_IF_assms] +declare arch_activate_idle_thread_domain_fields_invs[Scheduler_IF_assms] end @@ -143,7 +144,7 @@ global_interpretation Scheduler_IF_1?: proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Scheduler_IF_assms)?) + by (unfold_locales; (fact Scheduler_IF_assms | solves \wp only: Scheduler_IF_assms; simp\)?) qed @@ -215,8 +216,8 @@ lemma store_cur_thread_fragment_midstrength_reads_respects: simp del: split_paired_All) done -lemma arch_switch_to_thread_globals_equiv_scheduler': - "\invs and globals_equiv_scheduler sta\ +lemma set_vm_root_globals_equiv_scheduler: + "\valid_arch_state and globals_equiv_scheduler sta\ set_vm_root t \\_. globals_equiv_scheduler sta\" by (rule globals_equiv_scheduler_inv', wpsimp) @@ -263,11 +264,11 @@ lemma arch_switch_to_thread_midstrength_reads_respects_scheduler[Scheduler_IF_as done lemma arch_switch_to_idle_thread_globals_equiv_scheduler[Scheduler_IF_assms, wp]: - "\invs and globals_equiv_scheduler sta\ + "\valid_arch_state and globals_equiv_scheduler sta\ arch_switch_to_idle_thread \\_. globals_equiv_scheduler sta\" unfolding arch_switch_to_idle_thread_def storeWord_def - by (wp dmo_wp modify_wp thread_get_wp' arch_switch_to_thread_globals_equiv_scheduler') + by (wp dmo_wp modify_wp thread_get_wp' set_vm_root_globals_equiv_scheduler) lemma arch_switch_to_idle_thread_unobservable[Scheduler_IF_assms]: "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and @@ -304,6 +305,19 @@ lemma next_domain_midstrength_equiv_scheduler[Scheduler_IF_assms]: states_equiv_for_def idle_equiv_def) done +lemma arch_switch_to_idle_thread_midstrength_reads_respects[Scheduler_IF_assms]: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) arch_switch_to_idle_thread" + apply (rule equiv_valid_inv_unobservable) + apply (rule hoare_pre) + apply (rule scheduler_equiv_lift') + apply (wpsimp wp: silc_dom_lift)+ + apply assumption + apply (wp midstrength_scheduler_affects_equiv_unobservable + | simp | wps)+ + apply (auto simp: scheduler_equiv_sym midstrength_scheduler_affects_equiv_sym) + done + lemma resetTimer_irq_state[wp]: "resetTimer \\s. P (irq_state s)\" apply (simp add: resetTimer_def machine_op_lift_def machine_rest_lift_def) @@ -365,6 +379,32 @@ lemma thread_set_scheduler_affects_equiv[Scheduler_IF_assms, wp]: apply simp+ done +lemma thread_set_reads_respects_scheduler[Scheduler_IF_assms]: + "reads_respects_scheduler aag l (valid_arch_state and K (valid_tcb_context_update f)) + (thread_set f t)" + apply (rule gen_asm_ev) + apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def) + unfolding thread_set_def gets_the_def gets_def get_def return_def assert_opt_def fail_def set_object_def get_object_def assert_def put_def + apply (clarsimp simp: bind_def split: option.splits if_splits) + apply (clarsimp simp: get_tcb_ko_at obj_at_def) + unfolding valid_tcb_context_update_def + apply (rename_tac s' tcb tcb') + apply (erule_tac x=tcb in allE) + apply (erule_tac x=tcb' in allE) + apply (rule conjI) + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def) + apply (intro conjI) + apply (clarsimp simp: valid_global_arch_objs_def arch_globals_equiv_scheduler_def) + apply (clarsimp simp: idle_equiv_def tcb_at_def get_tcb_def arch_tcb_context_get_def) + apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) + apply (clarsimp simp: scheduler_affects_equiv_def) + apply (intro conjI) + apply (clarsimp simp: states_equiv_for_def equiv_for_def) + apply (intro conjI; clarsimp?) + apply (clarsimp simp: equiv_asids_def equiv_asid_def obj_at_def) + apply (clarsimp simp: scheduler_globals_frame_equiv_def arch_scheduler_affects_equiv_def) + done + lemma set_object_reads_respects_scheduler[Scheduler_IF_assms, wp]: "reads_respects_scheduler aag l \ (set_object ptr obj)" unfolding equiv_valid_def2 equiv_valid_2_def @@ -383,15 +423,53 @@ lemma arch_prepare_next_domain_ev[Scheduler_IF_assms]: "equiv_valid_inv I A (\_. True) arch_prepare_next_domain" unfolding arch_prepare_next_domain_def by wp +lemma arch_switch_to_thread_silc_dom_equiv[Scheduler_IF_assms,wp]: + "arch_switch_to_thread t \silc_dom_equiv aag (st :: det_state)\" + by (wpsimp wp: silc_dom_lift) + +lemma arch_switch_to_idle_thread_silc_dom_equiv[Scheduler_IF_assms,wp]: + "arch_switch_to_idle_thread \silc_dom_equiv aag (st :: det_state)\" + by (wpsimp wp: silc_dom_lift) + + +definition cur_hyp_in_cur_domain :: "det_state \ bool" where + "cur_hyp_in_cur_domain s \ True" + +definition cur_fpu_in_cur_domain :: "det_state \ bool" where + "cur_fpu_in_cur_domain s \ True" + +lemma cur_hyp_in_cur_domain_taut[intro!,simp]: + "cur_hyp_in_cur_domain s" + "cur_hyp_in_cur_domain s = cur_hyp_in_cur_domain s'" + by (simp_all add: cur_hyp_in_cur_domain_def) + +lemma cur_fpu_in_cur_domain_taut[intro!,simp]: + "cur_fpu_in_cur_domain s" + "cur_fpu_in_cur_domain s = cur_fpu_in_cur_domain s'" + by (simp_all add: cur_fpu_in_cur_domain_def) + +lemma cur_hyp_in_cur_domain_wp[Scheduler_IF_assms,wp]: + "\\\ f \\_. cur_hyp_in_cur_domain\" + unfolding cur_hyp_in_cur_domain_def by wp + +lemma cur_fpu_in_cur_domain_wp[Scheduler_IF_assms,wp]: + "\\\ f \\_. cur_fpu_in_cur_domain\" + unfolding cur_fpu_in_cur_domain_def by wp + +declare pas_wellformed_noninterference_domains_distinct[Scheduler_IF_assms] + end +arch_requalify_consts + cur_hyp_in_cur_domain + cur_fpu_in_cur_domain global_interpretation Scheduler_IF_2?: - Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv + Scheduler_IF_2 arch_globals_equiv_scheduler arch_scheduler_affects_equiv _ cur_hyp_in_cur_domain cur_fpu_in_cur_domain proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Scheduler_IF_assms)?) + by (unfold_locales; (fact Scheduler_IF_assms | solves \wp only: Scheduler_IF_assms; simp\)?) qed diff --git a/proof/infoflow/RISCV64/ArchSyscall_IF.thy b/proof/infoflow/RISCV64/ArchSyscall_IF.thy index e742e1d546..e94b9d711d 100644 --- a/proof/infoflow/RISCV64/ArchSyscall_IF.thy +++ b/proof/infoflow/RISCV64/ArchSyscall_IF.thy @@ -204,7 +204,7 @@ global_interpretation Syscall_IF_1?: Syscall_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Syscall_IF_assms)?) + by (unfold_locales; (fact Syscall_IF_assms | solves \wp only: Syscall_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/RISCV64/ArchTcb_IF.thy b/proof/infoflow/RISCV64/ArchTcb_IF.thy index e550162043..a90664c333 100644 --- a/proof/infoflow/RISCV64/ArchTcb_IF.thy +++ b/proof/infoflow/RISCV64/ArchTcb_IF.thy @@ -75,7 +75,7 @@ global_interpretation Tcb_IF_1?: Tcb_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Tcb_IF_assms)?) + by (unfold_locales; (fact Tcb_IF_assms | solves \wp only: Tcb_IF_assms; simp\)?) qed @@ -263,7 +263,7 @@ global_interpretation Tcb_IF_2?: Tcb_IF_2 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact Tcb_IF_assms)?) + by (unfold_locales; (fact Tcb_IF_assms | solves \wp only: Tcb_IF_assms; simp\)?) qed end diff --git a/proof/infoflow/RISCV64/ArchUserOp_IF.thy b/proof/infoflow/RISCV64/ArchUserOp_IF.thy index 7e0168d38f..411c370544 100644 --- a/proof/infoflow/RISCV64/ArchUserOp_IF.thy +++ b/proof/infoflow/RISCV64/ArchUserOp_IF.thy @@ -109,7 +109,7 @@ global_interpretation UserOp_IF_1?: UserOp_IF_1 proof goal_cases interpret Arch . case 1 show ?case - by (unfold_locales; (fact UserOp_IF_assms)?) + by (unfold_locales; (fact UserOp_IF_assms | solves \rule equiv_arch_taut\)?) qed @@ -566,9 +566,17 @@ proof - apply (frule_tac level=level in valid_vspace_objs_pte) apply clarsimp apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def) - apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned] - dest: valid_arch_state_asid_table dest!: pt_lookup_vs_lookupI - intro: vs_lookup_level) + apply (drule pt_lookup_vs_lookupI) + apply (fastforce simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned]) + apply (clarsimp simp: table_base_pt_slot_offset[OF vs_lookup_table_is_aligned]) + apply (rule_tac x=asid in exI) + apply (rule_tac x=x in exI) + apply (subst table_base_pt_slot_offset[OF vs_lookup_table_is_aligned]) + apply fastforce+ + apply (fastforce dest: valid_arch_state_asid_table) + apply fastforce + apply clarsimp + apply (erule vs_lookup_level) apply (erule disjE[OF _ _ FalseE]) prefer 2 apply (clarsimp simp: pt_lookup_slot_def pt_lookup_slot_from_level_def in_omonad pt_walk.simps) diff --git a/proof/infoflow/RISCV64/Example_Valid_State.thy b/proof/infoflow/RISCV64/Example_Valid_State.thy index 16b616fc80..1e91c4d236 100644 --- a/proof/infoflow/RISCV64/Example_Valid_State.thy +++ b/proof/infoflow/RISCV64/Example_Valid_State.thy @@ -1232,7 +1232,7 @@ lemma domain_sep_inv_s0: "domain_sep_inv False s0_internal s0_internal" apply (clarsimp simp: domain_sep_inv_def) apply (force dest: cte_wp_at_caps_of_state' s0_caps_of_state - | rule conjI allI | clarsimp simp: s0_internal_def)+ + | rule conjI allI | clarsimp simp: s0_internal_def non_kernel_IRQs_def)+ done lemma only_timer_irq_inv_s0: @@ -1894,17 +1894,17 @@ lemma Sys1_valid_initial_state_noenabled: assumes det_inv_s0: "det_inv KernelExit (cur_context s0_internal) s0_internal" shows "valid_initial_state_noenabled det_inv utf s0_internal Sys1PAS timer_irq s0_context" apply (unfold_locales, simp_all only: pasMaySendIrqs_Sys1PAS) - apply (insert det_inv_invariant)[9] - apply (erule(2) invariant_over_ADT_if.det_inv_abs_state) - apply ((erule invariant_over_ADT_if.det_inv_abs_state - invariant_over_ADT_if.check_active_irq_if_Idle_det_inv - invariant_over_ADT_if.check_active_irq_if_User_det_inv - invariant_over_ADT_if.do_user_op_if_det_inv - invariant_over_ADT_if.handle_preemption_if_det_inv - invariant_over_ADT_if.kernel_entry_if_Interrupt_det_inv - invariant_over_ADT_if.kernel_entry_if_det_inv - invariant_over_ADT_if.kernel_exit_if_det_inv - invariant_over_ADT_if.schedule_if_det_inv)+)[8] + apply (insert det_inv_invariant)[9] + apply (erule(2) invariant_over_ADT_if.det_inv_abs_state) + apply ((erule invariant_over_ADT_if.det_inv_abs_state + invariant_over_ADT_if.check_active_irq_if_Idle_det_inv + invariant_over_ADT_if.check_active_irq_if_User_det_inv + invariant_over_ADT_if.do_user_op_if_det_inv + invariant_over_ADT_if.handle_preemption_if_det_inv + invariant_over_ADT_if.kernel_entry_if_Interrupt_det_inv + invariant_over_ADT_if.kernel_entry_if_det_inv + invariant_over_ADT_if.kernel_exit_if_det_inv + invariant_over_ADT_if.schedule_if_det_inv)+)[8] apply (rule Sys1_pas_cur_domain) apply (rule Sys1_pas_wellformed_noninterference) apply (simp only: einvs_s0) @@ -1912,7 +1912,7 @@ lemma Sys1_valid_initial_state_noenabled: apply (simp add: only_timer_irq_inv_s0 silc_inv_s0 Sys1_pas_cur_domain domain_sep_inv_s0 Sys1_pas_refined Sys1_guarded_pas_domain idle_equiv_refl) - apply (clarsimp simp: valid_domain_list_2_def s0_internal_def exst0_def) + apply (clarsimp simp: valid_domain_list_2_def s0_internal_def exst0_def valid_cur_hyp_def) apply (simp add: det_inv_s0) apply (simp add: s0_internal_def exst0_def) apply (simp add: ct_in_state_def st_tcb_at_tcb_states_of_state_eq diff --git a/proof/infoflow/Retype_IF.thy b/proof/infoflow/Retype_IF.thy index 914b13a9a2..994074505f 100644 --- a/proof/infoflow/Retype_IF.thy +++ b/proof/infoflow/Retype_IF.thy @@ -72,15 +72,6 @@ lemma machine_op_lift_irq_state[wp]: "machine_op_lift mop \\ms. P (irq_state ms)\" by (simp add: machine_op_lift_def machine_rest_lift_def | wp | wpc)+ -lemma dmo_mol_reads_respects: - "reads_respects aag l \ (do_machine_op (machine_op_lift mop))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - apply (rule equiv_valid_guard_imp[OF machine_op_lift_ev]) - apply simp - apply wp - done - lemma dmo_bind_ev: "equiv_valid_inv I A P (do_machine_op (a >>= b)) = equiv_valid_inv I A P (do_machine_op a >>= (\rv. do_machine_op (b rv)))" @@ -134,7 +125,6 @@ lemma dmo_mapM_x_ev: shows "equiv_valid_inv D A I (do_machine_op (mapM_x m lst))" using assms by (auto intro: dmo_mapM_x_ev_pre) - locale Retype_IF_1 = assumes clearMemory_ev: "equiv_valid_inv (equiv_machine_state P) (equiv_machine_state Q) \ (clearMemory ptr bits)" @@ -159,23 +149,31 @@ locale Retype_IF_1 = and K (range_cover p sz (obj_bits_api type o_bits) num \ 0 < num)\ retype_region p num o_bits type dev \\_. globals_equiv s\" + and machine_op_lift_no_hyp[wp]: + "no_hyp (machine_op_lift mop)" + and machine_op_lift_no_fpu[wp]: + "no_fpu (machine_op_lift mop)" + and clearMemory_no_hyp[wp]: + "no_hyp (clearMemory ptr bits)" + and clearMemory_no_fpu[wp]: + "no_fpu (clearMemory ptr bits)" + and freeMemory_no_hyp[wp]: + "no_hyp (freeMemory ptr bits)" + and freeMemory_no_fpu[wp]: + "no_fpu (freeMemory ptr bits)" begin +lemma dmo_mol_reads_respects: + "reads_respects aag l \ (do_machine_op (machine_op_lift mop))" + by (wpsimp wp: do_machine_op_reads_respects equiv_valid_guard_imp[OF machine_op_lift_ev]) + lemma dmo_clearMemory_reads_respects: "reads_respects aag l \ (do_machine_op (clearMemory ptr bits))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - apply (rule equiv_valid_guard_imp[OF clearMemory_ev], rule TrueI) - apply wp - done + by (wpsimp wp: do_machine_op_reads_respects equiv_valid_guard_imp[OF clearMemory_ev]) lemma dmo_freeMemory_reads_respects: "reads_respects aag l \ (do_machine_op (freeMemory ptr bits))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects) - apply (rule equiv_valid_guard_imp[OF freeMemory_ev], rule TrueI) - apply wp - done + by (wpsimp wp: do_machine_op_reads_respects equiv_valid_guard_imp[OF freeMemory_ev]) lemma dmo_clearMemory_reads_respects_g: "reads_respects_g aag l \ (do_machine_op (clearMemory ptr (2 ^bits)))" diff --git a/proof/infoflow/Scheduler_IF.thy b/proof/infoflow/Scheduler_IF.thy index 871895f75e..20e7b31118 100644 --- a/proof/infoflow/Scheduler_IF.thy +++ b/proof/infoflow/Scheduler_IF.thy @@ -8,6 +8,55 @@ theory Scheduler_IF imports "ArchSyscall_IF" "ArchPasUpdates" begin +definition valid_silc_label where + "valid_silc_label aag s \ (SilcLabel \ pasSubject aag) \ + (\x. pasObjectAbs aag x = SilcLabel \ (\sz. cap_table_at sz x s))" + +lemma valid_silc_label_lift: + assumes "\P T p. f \\s. P (typ_at T p s)\" + shows "f \valid_silc_label aag\" + unfolding valid_silc_label_def + by (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift hoare_vcg_ex_lift assms simp: cap_table_at_typ) + +lemma valid_silc_label_silc_dom_equiv: + assumes "\P T p. f \\s. P (typ_at T p s)\" + shows "f \valid_silc_label aag\" + unfolding valid_silc_label_def + by (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift hoare_vcg_ex_lift assms simp: cap_table_at_typ) + +lemma silc_dom_equiv_upds[simp]: + "\f. silc_dom_equiv aag st (arch_state_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (cur_thread_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (ready_queues_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (machine_state_update f s) = silc_dom_equiv aag st s" + by (auto simp add: silc_dom_equiv_def equiv_for_def) + +lemma set_object_silc_dom_equiv: + "\silc_dom_equiv aag st and valid_silc_label aag and K (\sz. \is_cap_table sz obj)\ + set_object ptr obj + \\_. silc_dom_equiv aag st\" + apply (wp set_object_wp_strong) + apply (clarsimp simp: valid_silc_label_def silc_dom_equiv_def equiv_for_def obj_at_def) + apply (erule_tac x=ptr in allE)+ + apply clarsimp + apply (case_tac obj; case_tac ko; clarsimp simp: is_cap_table_def a_type_def) + done + +lemma as_user_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ as_user ptr f \\_. silc_dom_equiv aag st\" + unfolding as_user_def + by (wpsimp wp: set_object_silc_dom_equiv simp: is_cap_table_def) + +lemma arch_thread_set_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ arch_thread_set ptr f \\_. silc_dom_equiv aag st\" + unfolding arch_thread_set_def + by (wpsimp wp: set_object_silc_dom_equiv simp: is_cap_table_def) + +lemma valid_silc_label_arch_state_update[simp]: + "valid_silc_label aag (arch_state_update f s) = valid_silc_label aag s" + by (simp add: valid_silc_label_def) + + (* After SELFOUR-553 scheduler no longer writes to shared memory *) abbreviation scheduler_affects_globals_frame where "scheduler_affects_globals_frame s \ {}" @@ -26,6 +75,15 @@ definition domain_fields_equiv :: "det_state \ det_state \ domain_start_index s = domain_start_index s' \ domain_list s = domain_list s'" +lemma domain_fields_equiv_lift: + assumes "\P. \domain_fields P and Q\ f \\_. domain_fields P\" + assumes "\P. \(\s. P (cur_domain s)) and R\ f \\_ s. P (cur_domain s)\" + shows "\domain_fields_equiv st and Q and R\ f \\_. domain_fields_equiv st\" + apply (clarsimp simp: valid_def domain_fields_equiv_def) + apply (erule use_valid, wp assms) + apply simp + done + definition reads_scheduler where "reads_scheduler aag l \ if (l = SilcLabel) then {} else subjectReads (pasPolicy aag) l" @@ -82,10 +140,6 @@ locale Scheduler_IF_1 = arch_scheduler_affects_equiv s s'" "\f. arch_scheduler_affects_equiv s (domain_time_update f s') = arch_scheduler_affects_equiv s s'" - and arch_switch_to_thread_kheap[wp]: - "\P t. arch_switch_to_thread t \\s :: det_state. P (kheap s)\" - and arch_switch_to_idle_thread_kheap[wp]: - "\P. arch_switch_to_idle_thread \\s :: det_state. P (kheap s)\" and arch_switch_to_thread_idle_thread[wp]: "\P t. arch_switch_to_thread t \\s :: det_state. P (idle_thread s)\" and arch_switch_to_idle_thread_idle_thread[wp]: @@ -93,9 +147,7 @@ locale Scheduler_IF_1 = and arch_switch_to_idle_thread_cur_domain[wp]: "\P. arch_switch_to_idle_thread \\s :: det_state. P (cur_domain s)\" and arch_switch_to_idle_thread_globals_equiv[wp]: - "arch_switch_to_idle_thread \globals_equiv st\" - and arch_switch_to_idle_thread_states_equiv_for[wp]: - "\P Q R S. arch_switch_to_idle_thread \states_equiv_for P Q R S st\" + "\valid_arch_state and globals_equiv st\ arch_switch_to_idle_thread \\_. globals_equiv st\" and arch_switch_to_idle_thread_work_units_completed[wp]: "\P. arch_switch_to_idle_thread \\s. P (work_units_completed s)\" and equiv_asid_equiv_update: @@ -119,8 +171,8 @@ locale Scheduler_IF_1 = "\P. arch_activate_idle_thread t \\s :: det_state. P (idle_thread s)\" and arch_activate_idle_thread_irq_state_of_state[wp]: "\P. arch_activate_idle_thread t \\s. P (irq_state_of_state s)\" - and arch_prepare_next_domain_kheap[wp]: - "\P. arch_prepare_next_domain \\s :: det_state. P (kheap s)\" + and arch_activate_idle_thread_domain_fields[wp]: + "\P. arch_activate_idle_thread t \domain_fields P\" and arch_prepare_next_domain_idle_thread[wp]: "\P. arch_prepare_next_domain \\s :: det_state. P (idle_thread s)\" begin @@ -370,15 +422,6 @@ lemma silc_dom_equiv_cur_thread_update'[simp]: "silc_dom_equiv aag (st\cur_thread := x\) s = silc_dom_equiv aag st s" by (simp add: silc_dom_equiv_def equiv_for_def) -lemma tcb_domain_wellformed: - "\ pas_refined aag s; etcbs_of s t = Some a \ - \ pasObjectAbs aag t \ pasDomainAbs aag (etcb_domain a)" - apply (clarsimp simp add: pas_refined_def tcb_domain_map_wellformed_aux_def) - apply (drule_tac x="(t,etcb_domain a)" in bspec) - apply (rule domtcbs) - apply force+ - done - lemma silc_dom_equiv_trans_state[simp]: "silc_dom_equiv aag st (trans_state f s) = silc_dom_equiv aag st s" by (simp add: silc_dom_equiv_def equiv_for_def) @@ -522,6 +565,8 @@ definition midstrength_scheduler_affects_equiv :: (reads_scheduler_cur_domain aag l s \ reads_scheduler_cur_domain aag l s' \ work_units_completed s = work_units_completed s')" +declare equiv_hyp_False[simp] equiv_fpu_False[simp] + lemma globals_frame_equiv_as_states_equiv: "scheduler_globals_frame_equiv st s = states_equiv_for (\x. x \ scheduler_affects_globals_frame s) \ \ \ @@ -531,7 +576,7 @@ lemma globals_frame_equiv_as_states_equiv: lemma silc_dom_equiv_as_states_equiv: "silc_dom_equiv aag st s = states_equiv_for (\x. pasObjectAbs aag x = SilcLabel) \ \ \ (s\kheap := kheap st\) s" - by (simp add: states_equiv_for_def equiv_for_def silc_dom_equiv_def equiv_asids_def) + by (auto simp add: states_equiv_for_def equiv_for_def silc_dom_equiv_def equiv_asids_def equiv_hyp_refl equiv_fpu_refl) lemma silc_dom_equiv_states_equiv_lift: assumes a: "\P Q R S st. f \states_equiv_for P Q R S st\" @@ -540,7 +585,7 @@ lemma silc_dom_equiv_states_equiv_lift: apply (clarsimp simp add: valid_def) apply (frule use_valid[OF _ a]) apply assumption - apply (simp add: states_equiv_for_def equiv_for_def equiv_asids_def) + apply (auto simp add: states_equiv_for_def equiv_for_def equiv_asids_def equiv_hyp_refl equiv_fpu_refl) done @@ -592,7 +637,7 @@ proof - apply (clarsimp simp add: valid_def) apply (frule use_valid[OF _ a]) apply assumption - apply (simp add: states_equiv_for_def equiv_for_def equiv_asids_def) + apply (simp add: states_equiv_for_def equiv_for_def equiv_asids_def equiv_hyp_False equiv_fpu_False) done show ?thesis apply (simp add: scheduler_affects_equiv_def[abs_def]) @@ -618,10 +663,6 @@ crunch guarded_switch_to,schedule for idle_thread[wp]: "\(s :: det_state). P (idle_thread s)" (wp: crunch_wps simp: crunch_simps) -crunch guarded_switch_to, schedule - for kheap[wp]: "\s :: det_state. P (kheap s)" - (wp: dxo_wp_weak crunch_wps simp: crunch_simps) - end @@ -798,6 +839,19 @@ lemma midstrength_cur_domain_unobservable: apply (drule_tac x="(aa,ba)" in bspec,clarsimp+) done +lemma weak_cur_domain_unobservable: + "reads_respects_scheduler aag l (P and (\s. \ reads_scheduler_cur_domain aag l s)) f + \ weak_reads_respects_scheduler aag l + (P and (\s. \ reads_scheduler_cur_domain aag l s)) f" + apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def scheduler_affects_equiv_def + equiv_valid_def2 equiv_valid_2_def weak_scheduler_affects_equiv_def) + apply (drule_tac x=s in spec) + apply (drule_tac x=t in spec) + apply clarsimp + apply (drule_tac x="(a,b)" in bspec,clarsimp+) + apply (drule_tac x="(aa,ba)" in bspec,clarsimp+) + done + lemma midstrength_reads_respects_scheduler_cases: assumes domains_distinct: "pas_domains_distinct aag" assumes b: "pasObjectAbs aag t \ reads_scheduler aag l @@ -967,20 +1021,30 @@ lemma globals_equiv_scheduler[wp]: end +definition valid_tcb_context_update where + "valid_tcb_context_update f \ + \tcb tcb'. arch_tcb_context_get (tcb_arch tcb) = arch_tcb_context_get (tcb_arch tcb') + \ arch_tcb_context_get (tcb_arch (f tcb)) = arch_tcb_context_get (tcb_arch (f tcb'))" + + locale Scheduler_IF_2 = Scheduler_IF_1 + fixes aag :: "'a subject_label PAS" + and cur_hyp_in_cur_domain :: "det_state \ bool" + and cur_fpu_in_cur_domain :: "det_state \ bool" assumes arch_switch_to_thread_globals_equiv_scheduler: "\invs and globals_equiv_scheduler sta\ arch_switch_to_thread thread \\_. globals_equiv_scheduler sta\" and arch_switch_to_idle_thread_globals_equiv_scheduler[wp]: - "\invs and globals_equiv_scheduler sta\ + "\valid_arch_state and globals_equiv_scheduler sta\ arch_switch_to_idle_thread \\_. globals_equiv_scheduler sta\" and arch_switch_to_thread_midstrength_reads_respects_scheduler[wp]: - "pas_domains_distinct aag + "pas_wellformed_noninterference aag \ midstrength_reads_respects_scheduler aag l - (invs and pas_refined aag and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) + (invs and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) (do _ <- arch_switch_to_thread t; _ <- modify (cur_thread_update (\_. t)); modify (scheduler_action_update (\_. resume_cur_thread)) @@ -989,20 +1053,26 @@ locale Scheduler_IF_2 = Scheduler_IF_1 + "(\st. \P and globals_equiv st\ (f :: (det_state, unit) nondet_monad) \\_. globals_equiv st\) \ \P and globals_equiv_scheduler s\ f \\_. globals_equiv_scheduler s\" and arch_switch_to_idle_thread_unobservable: - "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and - scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and invs\ - arch_switch_to_idle_thread - \\_ s. scheduler_affects_equiv aag l st s\" + "pas_wellformed_noninterference aag + \ \(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_hyp_in_cur_domain and valid_silc_label aag and pas_refined aag\ + arch_switch_to_idle_thread + \\_ s. scheduler_affects_equiv aag l st s\" and arch_switch_to_thread_unobservable: - "\(\s. \ reads_scheduler_cur_domain aag l s) and - scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and invs\ - arch_switch_to_thread t - \\_ s. scheduler_affects_equiv aag l st s\" + "pas_wellformed_noninterference aag + \ \(\s. \ reads_scheduler_cur_domain aag l s) and + (\s. pasObjectAbs aag t \ reads_scheduler aag l) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and + valid_silc_label aag and pas_refined aag\ + arch_switch_to_thread t + \\_ s. scheduler_affects_equiv aag l st s\" and next_domain_midstrength_equiv_scheduler: "equiv_valid (scheduler_equiv aag) (weak_scheduler_affects_equiv aag l) (midstrength_scheduler_affects_equiv aag l) \ next_domain" - and arch_prepare_next_domain_ev: - "equiv_valid_inv (I :: det_state \ det_state \ bool) A \ arch_prepare_next_domain" + and arch_prepare_next_domain_weak_scheduler_reads_respects: + "weak_reads_respects_scheduler aag l (invs and valid_silc_label aag) arch_prepare_next_domain" and dmo_resetTimer_reads_respects_scheduler: "reads_respects_scheduler aag l \ (do_machine_op resetTimer)" and ackInterrupt_reads_respects_scheduler: @@ -1012,8 +1082,9 @@ locale Scheduler_IF_2 = Scheduler_IF_1 + (\s. x = idle_thread s \ tc = idle_context s) and scheduler_affects_equiv aag l st\ thread_set (tcb_arch_update (arch_tcb_context_set tc)) x \\_. scheduler_affects_equiv aag l st\" - and set_object_reads_respects_scheduler[wp]: - "reads_respects_scheduler aag l \ (set_object ptr obj)" + and thread_set_reads_respects_scheduler: + "\f. reads_respects_scheduler aag l (valid_arch_state and K (valid_tcb_context_update f)) + (thread_set f t)" and arch_activate_idle_thread_reads_respects_scheduler[wp]: "reads_respects_scheduler aag l \ (arch_activate_idle_thread rv)" and arch_activate_idle_thread_silc_dom_equiv[wp]: @@ -1021,14 +1092,50 @@ locale Scheduler_IF_2 = Scheduler_IF_1 + and arch_activate_idle_thread_scheduler_affects_equiv[wp]: "arch_activate_idle_thread t \scheduler_affects_equiv aag l s\" and arch_prepare_next_domain_globals_equiv_scheduler[wp]: - "arch_prepare_next_domain \\s:: det_state. globals_equiv_scheduler st s\" + "\invs and globals_equiv_scheduler st\ arch_prepare_next_domain \\_. globals_equiv_scheduler st\" + and arch_switch_to_idle_thread_midstrength_reads_respects: + "equiv_valid_inv (scheduler_equiv aag) (midstrength_scheduler_affects_equiv aag l) + (valid_arch_state and valid_silc_label aag) arch_switch_to_idle_thread" + and arch_switch_to_thread_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ + arch_switch_to_thread t + \\_. silc_dom_equiv aag (st :: det_state)\" + and arch_switch_to_idle_thread_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ + arch_switch_to_idle_thread + \\_. silc_dom_equiv aag st\" + and set_scheduler_action_cur_hyp_in_cur_domain[wp]: + "set_scheduler_action act \cur_hyp_in_cur_domain\" + and set_scheduler_action_cur_fpu_in_cur_domain[wp]: + "set_scheduler_action act \cur_fpu_in_cur_domain\" + and tcb_sched_action_cur_hyp_in_cur_domain[wp]: + "tcb_sched_action a t \cur_hyp_in_cur_domain\" + and tcb_sched_action_cur_fpu_in_cur_domain[wp]: + "tcb_sched_action a t \cur_fpu_in_cur_domain\" + and next_domain_snippet_cur_hyp_in_cur_domain: + "\\\ do y <- arch_prepare_next_domain; next_domain od \\_. cur_hyp_in_cur_domain\" + and next_domain_snippet_cur_fpu_in_cur_domain: + "\\\ do y <- arch_prepare_next_domain; next_domain od \\_. cur_fpu_in_cur_domain\" + and arch_prepare_next_domain_silc_dom_equiv[wp]: + "\silc_dom_equiv aag st and valid_silc_label aag\ + arch_prepare_next_domain + \\_. silc_dom_equiv aag st\" + and arch_prepare_next_domain_typ_at[wp]: + "\P. arch_prepare_next_domain \\s :: det_state. P (typ_at T ptr s)\" begin +crunch choose_thread + for silc_dom_equiv[wp]: "silc_dom_equiv aag (st :: det_state)" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + lemma switch_to_thread_midstrength_reads_respects_scheduler[wp]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "midstrength_reads_respects_scheduler aag l - (invs and pas_refined aag and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) + (invs and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) (switch_to_thread t >>= (\_. set_scheduler_action resume_cur_thread))" apply (simp add: switch_to_thread_def) apply (subst oblivious_modify_swap[symmetric, OF tcb_action_oblivious_cur_thread]) @@ -1056,9 +1163,12 @@ lemma switch_to_thread_globals_equiv_scheduler[wp]: done lemma guarded_switch_to_thread_midstrength_reads_respects_scheduler[wp]: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "midstrength_reads_respects_scheduler aag l - (invs and pas_refined aag and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) + (invs and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and (\s. pasObjectAbs aag t \ pasDomainAbs aag (cur_domain s))) (guarded_switch_to t >>= (\_. set_scheduler_action resume_cur_thread))" apply (simp add: guarded_switch_to_def bind_assoc) apply (subst bind_assoc[symmetric]) @@ -1070,14 +1180,12 @@ lemma switch_to_idle_thread_globals_equiv_scheduler[wp]: "\invs and globals_equiv_scheduler sta\ switch_to_idle_thread \\_. globals_equiv_scheduler sta\" - apply (simp add: switch_to_idle_thread_def) - apply (wp | simp)+ - done + by (wpsimp simp: switch_to_idle_thread_def) lemmas globals_equiv_scheduler_inv = globals_equiv_scheduler_inv'[where P="\",simplified] lemma switch_to_idle_thread_midstrength_reads_respects_scheduler[wp]: - "midstrength_reads_respects_scheduler aag l (invs and pas_refined aag) + "midstrength_reads_respects_scheduler aag l (invs and pas_refined aag and valid_silc_label aag) (switch_to_idle_thread >>= (\_. set_scheduler_action resume_cur_thread))" apply (simp add: switch_to_idle_thread_def) apply (rule equiv_valid_guard_imp) @@ -1085,12 +1193,7 @@ lemma switch_to_idle_thread_midstrength_reads_respects_scheduler[wp]: apply (rule bind_ev_general) apply (rule bind_ev_general) apply (rule store_cur_thread_midstrength_reads_respects) - apply (rule_tac P="\" and P'="\" in equiv_valid_inv_unobservable) - apply (rule hoare_pre) - apply (rule scheduler_equiv_lift'[where P=\]) - apply (wp globals_equiv_scheduler_inv silc_dom_lift | simp)+ - apply (wp midstrength_scheduler_affects_equiv_unobservable - | simp | wps)+ + apply (rule arch_switch_to_idle_thread_midstrength_reads_respects) apply (wp cur_thread_update_not_subject_reads_respects_scheduler arch_stit_invs | assumption | simp | fastforce)+ apply (clarsimp simp: scheduler_equiv_def) @@ -1219,9 +1322,11 @@ end context Scheduler_IF_2 begin lemma choose_thread_reads_respects_scheduler_cur_domain: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "midstrength_reads_respects_scheduler aag l - (invs and pas_refined aag and valid_queues + (invs and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and valid_queues and (\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l \ {})) (choose_thread >>= (\_. set_scheduler_action resume_cur_thread))" apply (simp add: choose_thread_def bind_assoc) @@ -1241,8 +1346,12 @@ lemma choose_thread_reads_respects_scheduler_cur_domain: done lemma switch_to_idle_thread_unobservable: - "\(\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l = {}) and - scheduler_affects_equiv aag l st and (\s. cur_domain s = cur_domain st) and invs\ + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + scheduler_affects_equiv aag l st and (\s. cur_domain st = cur_domain s) and + invs and cur_hyp_in_cur_domain and valid_silc_label aag and pas_refined aag\ switch_to_idle_thread \\_. scheduler_affects_equiv aag l st\" apply (simp add: switch_to_idle_thread_def) @@ -1270,29 +1379,38 @@ lemma tcb_sched_action_unobservable: done lemma switch_to_thread_unobservable: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "\(\s. \ reads_scheduler_cur_domain aag l s) and - (\s. pasObjectAbs aag t \ reads_scheduler aag l) and - scheduler_affects_equiv aag l st and scheduler_equiv aag st and invs and pas_refined aag\ - switch_to_thread t - \\_. scheduler_affects_equiv aag l st\" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "\(\s. \ reads_scheduler_cur_domain aag l s) and + (\s. pasObjectAbs aag t \ reads_scheduler aag l) and + scheduler_affects_equiv aag l st and scheduler_equiv aag st and + invs and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and + valid_silc_label aag and pas_refined aag\ + switch_to_thread t + \\_. scheduler_affects_equiv aag l st\" apply (simp add: switch_to_thread_def) - apply (wp cur_thread_update_unobservable arch_switch_to_idle_thread_unobservable - tcb_sched_action_unobservable arch_switch_to_thread_unobservable) + apply (wp cur_thread_update_unobservable tcb_sched_action_unobservable arch_switch_to_thread_unobservable) apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) done +(* need a wellformedness condition on silc labels so silc dom can be preserved *) lemma choose_thread_reads_respects_scheduler_other_domain: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_scheduler aag l ( invs and pas_refined aag and valid_queues and - (\s. \ reads_scheduler_cur_domain aag l s)) choose_thread" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows + "reads_respects_scheduler aag l (invs and pas_refined aag and valid_silc_label aag and valid_queues + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and (\s. \ reads_scheduler_cur_domain aag l s)) + choose_thread" apply (rule reads_respects_scheduler_unobservable'' - [where P'="\s. \ reads_scheduler_cur_domain aag l s \ - invs s \ pas_refined aag s \ valid_queues s"]) + [where P'="\s. \ reads_scheduler_cur_domain aag l s \ invs s \ pas_refined aag s \ + valid_silc_label aag s \ cur_hyp_in_cur_domain s \ + cur_fpu_in_cur_domain s \ valid_queues s"]) apply (rule hoare_pre) - apply (rule scheduler_equiv_lift'[where P="invs"]) + apply (rule scheduler_equiv_lift'[where P="invs and valid_silc_label aag"]) apply (simp add: choose_thread_def) - apply (wp guarded_switch_to_lift silc_dom_lift | simp)+ + apply (wp guarded_switch_to_lift | simp)+ apply force apply (simp add: choose_thread_def) apply (wp guarded_switch_to_lift switch_to_idle_thread_unobservable switch_to_thread_unobservable @@ -1310,13 +1428,16 @@ lemma choose_thread_reads_respects_scheduler_other_domain: done lemma choose_thread_reads_respects_scheduler: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "midstrength_reads_respects_scheduler aag l (invs and pas_refined aag and valid_queues) + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "midstrength_reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_queues + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain) (choose_thread >>= (\_. set_scheduler_action resume_cur_thread))" apply (rule equiv_valid_cases [where P="\s. pasDomainAbs aag (cur_domain s) \ reads_scheduler aag l \ {}"]) apply (rule equiv_valid_guard_imp) - apply (rule choose_thread_reads_respects_scheduler_cur_domain[OF domains_distinct]) + apply (rule choose_thread_reads_respects_scheduler_cur_domain[OF wellformed]) apply simp apply (rule equiv_valid_guard_imp) apply (rule midstrength_cur_domain_unobservable) @@ -1327,9 +1448,16 @@ lemma choose_thread_reads_respects_scheduler: apply (simp add: scheduler_equiv_def domain_fields_equiv_def) done +crunch next_domain + for typ_at[wp]: "\s. P (typ_at T ptr s)" + (wp: dxo_wp_weak simp: Let_def) + lemma next_domain_snippit: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_scheduler aag l (invs and pas_refined aag and valid_queues) + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_queues + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and ct_in_cur_domain) (do dom_time \ gets domain_time; y \ when (dom_time = 0) (do y <- arch_prepare_next_domain; next_domain @@ -1340,26 +1468,30 @@ lemma next_domain_snippit: apply (simp add: when_def) apply (rule bind_ev_pre) apply (rule bind_ev_general) - apply (rule choose_thread_reads_respects_scheduler[OF domains_distinct]) + apply (rule choose_thread_reads_respects_scheduler[OF wellformed]) apply (rule ev_weaken_pre_relation[THEN if_ev]) apply (rule bind_ev_general) apply (rule next_domain_midstrength_equiv_scheduler) - apply (rule arch_prepare_next_domain_ev) - apply wp + apply (rule arch_prepare_next_domain_weak_scheduler_reads_respects) + apply wp+ apply fastforce apply (rule ev_weaken_pre_relation) apply wp apply fastforce - apply (wp next_domain_valid_queues)+ + apply (wpsimp wp: valid_silc_label_lift hoare_wp_simps + next_domain_snippet_cur_hyp_in_cur_domain + next_domain_snippet_cur_fpu_in_cur_domain)+ apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def) done lemma schedule_choose_new_thread_read_respects_scheduler: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_scheduler aag l (invs and pas_refined aag and valid_queues) - schedule_choose_new_thread" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + shows "reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_queues + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain and ct_in_cur_domain) + schedule_choose_new_thread" unfolding schedule_choose_new_thread_def K_bind_def fun_app_def - by (rule next_domain_snippit[OF domains_distinct]) + by (rule next_domain_snippit[OF wellformed]) end @@ -1464,7 +1596,7 @@ lemma schedule_no_domain_switch: apply (wpsimp wp: hoare_drop_imps gts_wp simp: if_apply_def2 | simp add: schedule_choose_new_thread_def | wpc - | rule hoare_pre_cont[where f=next_domain] )+ + | rule hoare_pre_cont[where f=next_domain])+ done lemma schedule_no_domain_fields: @@ -1475,7 +1607,7 @@ lemma schedule_no_domain_fields: apply (wpsimp wp: hoare_drop_imps gts_wp simp: if_apply_def2 | simp add: schedule_choose_new_thread_def | wpc - | rule hoare_pre_cont[where f=next_domain] )+ + | rule hoare_pre_cont[where f=next_domain])+ done lemma set_scheduler_action_unobservable: @@ -1525,20 +1657,25 @@ lemma dec_domain_time_reads_respects_scheduler[wp]: apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def globals_equiv_scheduler_def scheduler_globals_frame_equiv_def silc_dom_equiv_def states_equiv_for_def scheduler_affects_equiv_def equiv_for_def equiv_asids_def idle_equiv_def) + apply simp done end + context Scheduler_IF_2 begin lemma reads_respects_scheduler_invisible_domain_switch: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l (\s. pas_refined aag s \ invs s \ valid_queues s - \ guarded_pas_domain aag s \ domain_time s = 0 - \ scheduler_action s = choose_new_thread - \ \ reads_scheduler_cur_domain aag l s) + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (\s. pas_refined aag s \ valid_silc_label aag s \ invs s \ valid_queues s + \ guarded_pas_domain aag s \ domain_time s = 0 + \ scheduler_action s = choose_new_thread \ ct_in_cur_domain s + \ cur_hyp_in_cur_domain s \ cur_fpu_in_cur_domain s + \ \ reads_scheduler_cur_domain aag l s) schedule" + supply valid_silc_label_lift[wp] apply (rule equiv_valid_guard_imp) apply (simp add: schedule_def) apply (simp add: equiv_valid_def2) @@ -1553,7 +1690,7 @@ lemma reads_respects_scheduler_invisible_domain_switch: apply simp apply (rule equiv_valid_2_bind_pre) apply (rule equiv_valid_2) - apply (rule schedule_choose_new_thread_read_respects_scheduler[OF domains_distinct]) + apply (rule schedule_choose_new_thread_read_respects_scheduler[OF wellformed]) apply (rule_tac P="\" and S="\" and P'="pas_refined aag and (\s. runnable rva @@ -1602,10 +1739,12 @@ crunch schedule simp: crunch_simps) lemma choose_thread_unobservable: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows "\(\s. \ reads_scheduler_cur_domain aag l s) and scheduler_affects_equiv aag l st and - invs and valid_queues and pas_refined aag and scheduler_equiv aag st\ + invs and valid_queues and pas_refined aag and valid_silc_label aag and + scheduler_equiv aag st and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain\ choose_thread \\_. scheduler_affects_equiv aag l st\" apply (simp add: choose_thread_def) @@ -1627,10 +1766,12 @@ lemma tcb_sched_action_scheduler_equiv[wp]: by (rule scheduler_equiv_lift; wp) lemma schedule_choose_new_thread_schedule_affects_no_switch: - assumes domains_distinct[wp]: "pas_domains_distinct aag" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] shows - "\\s. invs s \ pas_refined aag s \ valid_queues s \ domain_time s \ 0 + "\\s. invs s \ pas_refined aag s \ valid_silc_label aag s \ valid_queues s \ domain_time s \ 0 \ \ reads_scheduler_cur_domain aag l s \ scheduler_equiv aag st s + \ cur_hyp_in_cur_domain s \ cur_fpu_in_cur_domain s \ scheduler_affects_equiv aag l st s \ cur_domain st = cur_domain s\ schedule_choose_new_thread \\_. scheduler_affects_equiv aag l st\" @@ -1638,26 +1779,40 @@ lemma schedule_choose_new_thread_schedule_affects_no_switch: by (wpsimp wp: set_scheduler_action_unobservable choose_thread_unobservable hoare_pre_cont[where f=next_domain]) +lemma silc_dom_equiv_updates'[simp]: + "\f. silc_dom_equiv aag st (domain_index_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (domain_time_update f s) = silc_dom_equiv aag st s" + "\f. silc_dom_equiv aag st (cur_domain_update f s) = silc_dom_equiv aag st s" + by (auto simp add: silc_dom_equiv_def equiv_for_def) + +crunch next_domain + for silc_dom_equiv[wp]: "silc_dom_equiv aag st" + (wp: dxo_wp_weak simp: Let_def) + +crunch schedule + for silc_dom_equiv[wp]: "silc_dom_equiv aag (st :: det_state)" + (wp: crunch_wps valid_silc_label_lift simp: crunch_simps) + lemma reads_respects_scheduler_invisible_no_domain_switch: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l - (\s. pas_refined aag s \ invs s \ valid_sched s \ guarded_pas_domain aag s - \ domain_time s \ 0 \ \ reads_scheduler_cur_domain aag l s) - schedule" - supply if_split[split del] + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (\s. pas_refined aag s \ valid_silc_label aag s \ invs s \ valid_sched s \ + guarded_pas_domain aag s \ cur_hyp_in_cur_domain s \ cur_fpu_in_cur_domain s \ + domain_time s \ 0 \ \ reads_scheduler_cur_domain aag l s) + schedule" + supply if_split[split del] valid_silc_label_lift[wp] apply (rule reads_respects_scheduler_unobservable''[where P=Q and P'=Q and Q=Q for Q]) apply (rule hoare_pre) - apply (rule scheduler_equiv_lift'[where P="invs and (\s. domain_time s \ 0)"]) - apply (wp schedule_no_domain_switch schedule_no_domain_fields - silc_dom_lift | simp)+ + apply (rule scheduler_equiv_lift'[where P="invs and valid_silc_label aag and (\s. domain_time s \ 0)"]) + apply (wp schedule_no_domain_switch schedule_no_domain_fields| simp)+ apply (simp add: schedule_def) apply (wp guarded_switch_to_lift scheduler_equiv_lift schedule_choose_new_thread_schedule_affects_no_switch set_scheduler_action_unobservable tcb_sched_action_unobservable - switch_to_thread_unobservable silc_dom_lift + switch_to_thread_unobservable gts_wp hoare_vcg_all_lift hoare_vcg_disj_lift @@ -1670,65 +1825,71 @@ lemma reads_respects_scheduler_invisible_no_domain_switch: apply (wp hoare_if[rotated]) apply (wp tcb_sched_action_unobservable gts_wp schedule_choose_new_thread_schedule_affects_no_switch - hoare_vcg_all_lift hoare_vcg_imp_lift' )+ + hoare_vcg_all_lift hoare_vcg_imp_lift')+ apply (clarsimp simp: if_apply_def2) (* slow 15s *) by (safe; (fastforce simp: switch_thread_runnable | fastforce dest!: switch_to_cur_domain cur_thread_cur_domain | fastforce simp: st_tcb_at_def obj_at_def))+ + lemma read_respects_scheduler_switch_thread_case: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l - (invs and valid_queues and (\s. scheduler_action s = switch_thread t) - and valid_sched_action and pas_refined aag) - (do tcb_sched_action tcb_sched_enqueue t; - set_scheduler_action choose_new_thread; - schedule_choose_new_thread - od)" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and valid_queues and (\s. scheduler_action s = switch_thread t) + and valid_sched_action and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain) + (do tcb_sched_action tcb_sched_enqueue t; + set_scheduler_action choose_new_thread; + schedule_choose_new_thread + od)" unfolding schedule_choose_new_thread_def apply (rule equiv_valid_guard_imp) apply simp apply (rule bind_ev) apply (rule bind_ev) - apply (rule next_domain_snippit[OF domains_distinct]) + apply (rule next_domain_snippit[OF wellformed]) apply wp[1] apply (simp add: pred_conj_def) apply (rule hoare_vcg_conj_lift) - apply (wp tcb_action_reads_respects_scheduler)+ + apply (wp tcb_action_reads_respects_scheduler valid_silc_label_lift)+ apply (clarsimp simp: valid_sched_action_def weak_valid_sched_action_def) done lemma read_respects_scheduler_switch_thread_case_app: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l - (invs and valid_queues and (\s. scheduler_action s = switch_thread t) - and valid_sched_action and pas_refined aag) - (do tcb_sched_action tcb_sched_append t; - set_scheduler_action choose_new_thread; - schedule_choose_new_thread - od)" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and valid_queues and (\s. scheduler_action s = switch_thread t) + and valid_sched_action and pas_refined aag and valid_silc_label aag + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain) + (do tcb_sched_action tcb_sched_append t; + set_scheduler_action choose_new_thread; + schedule_choose_new_thread + od)" unfolding schedule_choose_new_thread_def apply (rule equiv_valid_guard_imp) apply simp apply (rule bind_ev) apply (rule bind_ev) - apply (rule next_domain_snippit[OF domains_distinct]) + apply (rule next_domain_snippit[OF wellformed]) apply wp[1] apply (simp add: pred_conj_def) apply (rule hoare_vcg_conj_lift) - apply (wp tcb_action_reads_respects_scheduler)+ + apply (wp tcb_action_reads_respects_scheduler valid_silc_label_lift)+ apply (clarsimp simp: valid_sched_action_def weak_valid_sched_action_def) done lemma schedule_reads_respects_scheduler_cur_domain: - assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l (invs and pas_refined aag and valid_sched - and guarded_pas_domain aag - and (\s. reads_scheduler_cur_domain aag l s)) schedule" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_sched + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and guarded_pas_domain aag and (\s. reads_scheduler_cur_domain aag l s)) + schedule" + supply valid_silc_label_lift[wp] apply (simp add: schedule_def schedule_switch_thread_fastfail_def) apply (rule equiv_valid_guard_imp) apply (rule bind_ev)+ @@ -1738,17 +1899,17 @@ lemma schedule_reads_respects_scheduler_cur_domain: prefer 2 (* choose new thread *) apply (rule bind_ev) - apply (rule schedule_choose_new_thread_read_respects_scheduler[OF domains_distinct]) + apply (rule schedule_choose_new_thread_read_respects_scheduler[OF wellformed]) apply ((wpsimp wp: when_ev gts_wp get_thread_state_reads_respects_scheduler)+)[2] (* switch thread *) apply (rule bind_ev)+ apply (rule if_ev) - apply (rule read_respects_scheduler_switch_thread_case[OF domains_distinct]) + apply (rule read_respects_scheduler_switch_thread_case[OF wellformed]) apply (rule if_ev) - apply (rule read_respects_scheduler_switch_thread_case_app[OF domains_distinct]) + apply (rule read_respects_scheduler_switch_thread_case_app[OF wellformed]) apply simp apply (rule ev_weaken_pre_relation) - apply (rule guarded_switch_to_thread_midstrength_reads_respects_scheduler[OF domains_distinct]) + apply (rule guarded_switch_to_thread_midstrength_reads_respects_scheduler[OF wellformed]) apply fastforce apply (rule gets_highest_prio_ev_from_weak_sae) apply fastforce @@ -1781,11 +1942,10 @@ lemma schedule_reads_respects_scheduler_cur_domain: apply (frule st_tcb_at_tcb_at, drule (1) etcb_in_domains_of_state) apply (drule (1) bspec) apply simp - by (metis Int_emptyI assms pas_domains_distinct_inj) + by (metis Int_emptyI assms pas_domains_distinct_inj[OF domains_distinct]) end - lemma switch_to_cur_domain': "\ valid_sched_action s; scheduler_action s = switch_thread x; pas_refined aag s \ \ pasObjectAbs aag x \ pasDomainAbs aag (cur_domain s)" @@ -1825,21 +1985,24 @@ definition tick_done where "tick_done s \ domain_time s = 0 \ scheduler_action s = choose_new_thread" lemma schedule_reads_respects_scheduler: - assumes domains_distinct: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l (invs and pas_refined aag and valid_sched - and guarded_pas_domain aag and tick_done) schedule" + assumes wellformed[wp]: "pas_wellformed_noninterference aag" + notes domains_distinct[wp] = pas_wellformed_noninterference_domains_distinct[OF wellformed] + shows "reads_respects_scheduler aag l + (invs and pas_refined aag and valid_silc_label aag and valid_sched + and cur_hyp_in_cur_domain and cur_fpu_in_cur_domain + and guarded_pas_domain aag and tick_done) + schedule" apply (rule_tac P="\s. reads_scheduler_cur_domain aag l s" in equiv_valid_cases) apply (rule equiv_valid_guard_imp) - apply (rule schedule_reads_respects_scheduler_cur_domain[OF domains_distinct]) + apply (rule schedule_reads_respects_scheduler_cur_domain[OF wellformed]) apply simp apply (rule_tac P="\s. domain_time s = 0" in equiv_valid_cases) apply (rule equiv_valid_guard_imp) - apply (rule reads_respects_scheduler_invisible_domain_switch[OF domains_distinct]) + apply (rule reads_respects_scheduler_invisible_domain_switch[OF wellformed]) apply (clarsimp simp: tick_done_def valid_sched_def) apply (rule equiv_valid_guard_imp) - apply (rule reads_respects_scheduler_invisible_no_domain_switch[OF domains_distinct]) + apply (rule reads_respects_scheduler_invisible_no_domain_switch[OF wellformed]) apply simp apply (clarsimp simp: scheduler_equiv_def domain_fields_equiv_def)+ done @@ -1914,13 +2077,8 @@ lemma thread_set_time_slice_reads_respect_scheduler[wp]: "reads_respects_scheduler aag l (invs and (\s. t \ idle_thread s \ pasObjectAbs aag t \ SilcLabel) and guarded_pas_domain aag) (thread_set (tcb_time_slice_update f) t)" - apply (rule reads_respects_scheduler_cases[where P'=\]) - prefer 3 - apply (rule reads_respects_scheduler_unobservable'') - apply (wp | simp | elim conjE)+ - apply (simp add: thread_set_def) - apply wp - apply (fastforce simp: scheduler_affects_equiv_def get_tcb_def states_equiv_for_def equiv_for_def)+ + apply (wp thread_set_reads_respects_scheduler) + apply (clarsimp simp: valid_tcb_context_update_def) done lemma thread_set_time_slice_pas_refined[wp]: @@ -2005,7 +2163,7 @@ lemma timer_tick_reads_respects_scheduler_unobservable: apply (intro impI conjI allI) apply (fastforce dest: st_tcb_at_not_idle_thread) apply (fastforce dest!: cur_thread_cur_domain)+ - apply ((clarsimp simp add: st_tcb_at_def obj_at_def valid_sched_def )+)[2] + apply ((clarsimp simp add: st_tcb_at_def obj_at_def valid_sched_def)+)[2] apply (fastforce dest: st_tcb_at_not_idle_thread) apply (fastforce dest!: cur_thread_cur_domain) apply force @@ -2034,22 +2192,6 @@ lemma gets_ev': "equiv_valid_inv I A (P and K(\s t. P s \ P t \ I s t \ A s t \ f s = f t)) (gets f)" by (clarsimp simp: equiv_valid_def2 equiv_valid_2_def gets_def get_def bind_def return_def) -lemma irq_inactive_or_timer: - "\domain_sep_inv False st and Q IRQTimer and Q IRQInactive\ - get_irq_state irq - \Q\" - apply (simp add:get_irq_state_def) - apply wp - apply (clarsimp simp add: domain_sep_inv_def) - apply (drule_tac x=irq in spec) - apply (drule_tac x=a in spec) (*makes yellow variables*) - apply (drule_tac x=b in spec) - apply (drule_tac x=aa in spec, drule_tac x=ba in spec) - apply clarsimp - apply (case_tac "interrupt_states st irq") - apply clarsimp+ - done - (*FIXME: MOVE corres-like statement for out of step equiv_valid. Move to scheduler_IF?*) lemma equiv_valid_2_bind_right: "\ \rv. equiv_valid_2 D A A R T' (Q rv) g' (g rv); @@ -2095,16 +2237,15 @@ context Scheduler_IF_2 begin lemma handle_interrupt_reads_respects_scheduler: assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows - "reads_respects_scheduler aag l (invs and guarded_pas_domain aag and pas_refined aag and - valid_sched and domain_sep_inv False st and silc_inv aag st' and - K (irq \ maxIRQ)) - (handle_interrupt irq)" - apply (simp add: handle_interrupt_def ) - apply (rule conjI; rule impI ) + shows "reads_respects_scheduler aag l (invs and guarded_pas_domain aag and pas_refined aag + and valid_sched and domain_sep_inv False st + and silc_inv aag st' and K (irq \ maxIRQ)) + (handle_interrupt irq)" + apply (simp add: handle_interrupt_def) + apply (rule conjI; rule impI) apply (rule gen_asm_ev) apply simp - apply (wp modify_wp | simp )+ + apply (wp modify_wp | simp)+ apply (rule ackInterrupt_reads_respects_scheduler) apply (rule_tac Q="rv = IRQTimer \ rv = IRQInactive" in gen_asm_ev(2)) apply (elim disjE) @@ -2124,25 +2265,51 @@ lemma thread_set_scheduler_equiv[wp]: apply (wpsimp wp: thread_set_context_globals_equiv | simp)+ done +lemma set_thread_state_def2: + "set_thread_state ref ts \ do + thread_set (tcb_state_update (\_. ts)) ref; + set_thread_state_act ref + od" + by (simp add: set_thread_state_def thread_set_def bind_assoc) + + lemma sts_reads_respects_scheduler: "reads_respects_scheduler aag l (K (pasObjectAbs aag rv \ reads_scheduler aag l) and reads_scheduler_cur_domain aag l - and valid_idle and (\s. rv \ idle_thread s)) + and valid_idle and valid_arch_state + and (\s. rv \ idle_thread s)) (set_thread_state rv st)" - apply (simp add: set_thread_state_def) + apply (simp add: set_thread_state_def2) apply (simp add: set_thread_state_act_def) - apply (wp when_ev get_thread_state_reads_respects_scheduler gts_wp set_object_wp) + apply (wp when_ev get_thread_state_reads_respects_scheduler gts_wp + set_object_wp thread_set_reads_respects_scheduler thread_set_wp) apply (clarsimp simp: get_tcb_scheduler_equiv valid_idle_def pred_tcb_at_def obj_at_def) + apply (clarsimp simp: valid_tcb_context_update_def) + done + +lemma as_user_def2: + "as_user t m = do + tcb \ gets_the (get_tcb t); + (a,uc) \ select_f (m (arch_tcb_context_get (tcb_arch tcb))); + thread_set (\tcb. tcb\tcb_arch := arch_tcb_context_set uc (tcb_arch tcb)\) t; + return a + od" + apply (simp add: thread_set_def as_user_def) + apply (rule ext) + apply (rule bind_apply_cong [OF refl])+ + apply (simp add: select_f_def in_monad gets_the_def gets_def) + apply (clarsimp simp add: get_def bind_def return_def assert_opt_def) done lemma as_user_reads_respects_scheduler: "reads_respects_scheduler aag l (K (pasObjectAbs aag rv \ reads_scheduler aag l) and - (\s. rv \ idle_thread s) and K (det f)) + (\s. rv \ idle_thread s) and valid_arch_state and K (det f)) (as_user rv f)" apply (rule gen_asm_ev) - apply (simp add: as_user_def) - apply (wp select_f_ev | wpc | simp)+ + apply (simp add: as_user_def2) + apply (wp select_f_ev thread_set_reads_respects_scheduler | wpc | simp)+ apply (clarsimp simp: get_tcb_scheduler_equiv) + apply (clarsimp simp: valid_tcb_context_update_def) done end @@ -2177,15 +2344,6 @@ lemma sts_silc_dom_equiv[wp]: apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) done -lemma as_user_silc_dom_equiv[wp]: - "\K (pasObjectAbs aag x \ SilcLabel) and silc_dom_equiv aag st\ - as_user x f - \\_. silc_dom_equiv aag st\" - apply (simp add: as_user_def) - apply (wp dxo_wp_weak set_object_wp | wpc | simp)+ - apply (clarsimp simp: silc_dom_equiv_def equiv_for_def) - done - lemma set_scheduler_action_wp[wp]: "\\s. P () (s\scheduler_action := a\)\ set_scheduler_action a \P\" by (simp add: set_scheduler_action_def | wp)+ @@ -2241,7 +2399,6 @@ lemma agnostic_to_ev2: shows "equiv_valid_2 I A B (\r r'. r = (g u) \ r' = (g u')) P P (f u) (f u')" proof - have b: "\a b s u. (a,b) \ fst (f u s) \ a = g u" - apply (erule use_valid[OF _ ret_agnostic]) apply simp done @@ -2282,7 +2439,7 @@ lemma op_eq_unit_dc: lemma cur_thread_idle': "\ valid_idle s; only_idle s \ \ ct_idle s = (cur_thread s = idle_thread s)" apply (rule iffI) - apply (clarsimp simp: only_idle_def ct_in_state_def ) + apply (clarsimp simp: only_idle_def ct_in_state_def) apply (clarsimp simp: valid_idle_def ct_in_state_def pred_tcb_at_def obj_at_def) done @@ -2295,6 +2452,10 @@ lemma cur_thread_idle: context Scheduler_IF_2 begin +lemma silc_inv_valid_silc_label[elim!]: + "silc_inv aag st s \ valid_silc_label aag s" + by (simp add: silc_inv_def valid_silc_label_def) + lemma activate_thread_reads_respects_scheduler[wp]: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows "reads_respects_scheduler aag l (invs and silc_inv aag st and guarded_pas_domain aag) @@ -2314,7 +2475,7 @@ lemma activate_thread_reads_respects_scheduler[wp]: guarded_pas_domain aag s \ invs s"]) apply ((wp scheduler_equiv_lift'[where P="invs and silc_inv aag st"] globals_equiv_scheduler_inv'[where P="valid_arch_state and valid_idle"] - set_thread_state_globals_equiv gts_wp + set_thread_state_globals_equiv gts_wp valid_silc_label_lift | wpc | clarsimp simp: restart_not_idle silc_inv_not_cur_thread | force)+)[1] @@ -2328,15 +2489,8 @@ lemma thread_set_reads_respect_scheduler[wp]: and (\s. t = idle_thread s \ tc = idle_context s) and guarded_pas_domain aag) (thread_set (tcb_arch_update (arch_tcb_context_set tc)) t)" - apply (rule reads_respects_scheduler_cases[where P'=\]) - prefer 3 - apply (rule reads_respects_scheduler_unobservable'') - apply (wp | simp | elim conjE)+ - apply (simp add: thread_set_def) - apply wp - apply (fastforce simp: scheduler_affects_equiv_def get_tcb_def states_equiv_for_def - equiv_for_def scheduler_equiv_def domain_fields_equiv_def equiv_asids_def - split: option.splits kernel_object.splits)+ + apply (wp thread_set_reads_respects_scheduler) + apply (clarsimp simp: valid_tcb_context_update_def) done lemma context_update_cur_thread_snippit_unobservable: diff --git a/proof/infoflow/Syscall_IF.thy b/proof/infoflow/Syscall_IF.thy index e54755b18f..7ac4717621 100644 --- a/proof/infoflow/Syscall_IF.thy +++ b/proof/infoflow/Syscall_IF.thy @@ -61,23 +61,29 @@ locale Syscall_IF_1 = and arch_mask_irq_signal_globals_equiv[wp]: "arch_mask_irq_signal irq \globals_equiv st\" and handle_reserved_irq_globals_equiv[wp]: - "handle_reserved_irq irq \globals_equiv st\" + "\globals_equiv st and invs\ handle_reserved_irq irq \\_. globals_equiv st\" and handle_spurious_irq_globals_equiv[wp]: "handle_spurious_irq \globals_equiv st\" and arch_prepare_set_domain_globals_equiv[wp]: - "arch_prepare_set_domain t new_dom \globals_equiv st\" + "\globals_equiv st and invs\ arch_prepare_set_domain t new_dom \\_. globals_equiv st\" and arch_prepare_set_domain_valid_arch_state[wp]: "arch_prepare_set_domain t new_dom \\s :: det_state. valid_arch_state s\" and handle_vm_fault_reads_respects: - "reads_respects aag l (K (is_subject aag thread)) (handle_vm_fault thread vmfault_type)" + "reads_respects aag l (pas_refined aag and valid_cur_hyp + and schact_is_rct and ct_in_cur_domain + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_vm_fault thread vmfault_type)" and handle_hypervisor_fault_reads_respects: - "reads_respects aag l \ (handle_hypervisor_fault thread hypfault_type)" + "pas_domains_distinct aag \ + reads_respects aag l (invs and pas_refined aag and pas_cur_domain aag + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_hypervisor_fault thread hypfault_type)" and handle_vm_fault_globals_equiv: "\globals_equiv st and valid_arch_state and (\s. thread \ idle_thread s)\ handle_vm_fault thread vmfault_type \\_. globals_equiv st\" and handle_hypervisor_fault_globals_equiv: - "handle_hypervisor_fault thread hypfault_type \globals_equiv st\" + "\globals_equiv st and invs\ handle_hypervisor_fault thread hypfault_type \\_. globals_equiv st\" and arch_activate_idle_thread_globals_equiv[wp]: "arch_activate_idle_thread t \globals_equiv st\" and select_f_setNextPC_reads_respects[wp]: @@ -264,7 +270,7 @@ lemma invoke_cnode_reads_respects_f: apply (clarsimp simp: cnode_inv_auth_derivations_def authorised_cnode_inv_def) apply (auto intro: real_cte_emptyable_strg[rule_format] simp: silc_inv_def reads_equiv_f_def requiv_cur_thread_eq caps_of_state_cteD - aag_cap_auth_recycle_EndpointCap cte_wp_at_weak_derived_ReplyCap ) + aag_cap_auth_recycle_EndpointCap cte_wp_at_weak_derived_ReplyCap) done lemma cap_swap_reads_respects_g: @@ -792,12 +798,6 @@ lemma handle_recv_reads_respects_f_g: apply simp+ done -lemma dmo_return_reads_respects: - "reads_respects aag l \ (do_machine_op (return ()))" - apply (rule use_spec_ev) - apply (rule do_machine_op_spec_reads_respects; wp) - done - lemma dmo_return_globals_equiv: "do_machine_op (return ()) \globals_equiv st\" by simp @@ -886,7 +886,9 @@ lemma handle_interrupt_globals_equiv: done lemma handle_vm_fault_reads_respects_g: - "reads_respects_g aag l (K (is_subject aag t) and (valid_arch_state and (\s. t \ idle_thread s))) + "reads_respects_g aag l (pas_refined aag and valid_cur_hyp and schact_is_rct and ct_in_cur_domain + and is_subject aag \ cur_thread and K (is_subject aag t) + and (valid_arch_state and (\s. t \ idle_thread s))) (handle_vm_fault t vmfault_type)" apply (rule reads_respects_g) apply (rule handle_vm_fault_reads_respects) @@ -896,23 +898,28 @@ lemma handle_vm_fault_reads_respects_g: done lemma handle_hypervisor_fault_reads_respects_g: - "reads_respects_g aag l \ (handle_hypervisor_fault thread hyp)" - apply (rule reads_respects_g[where P="\" and Q="\", simplified]) - apply (rule handle_hypervisor_fault_reads_respects) - apply (rule doesnt_touch_globalsI) - apply (wp handle_hypervisor_fault_globals_equiv) + assumes domains_distinct[wp]: "pas_domains_distinct aag" + shows "reads_respects_g aag l (invs and pas_refined aag and pas_cur_domain aag + and is_subject aag \ cur_thread and K (is_subject aag thread)) + (handle_hypervisor_fault thread hyp)" + apply (rule equiv_valid_guard_imp) + apply (rule reads_respects_g[OF handle_hypervisor_fault_reads_respects]) + apply wp + apply (rule doesnt_touch_globalsI) + apply (wp handle_hypervisor_fault_globals_equiv) apply simp done (* we explicitly exclude the case where ev is Interrupt since this is a scheduler action *) lemma handle_event_reads_respects_f_g: assumes domains_distinct[wp]: "pas_domains_distinct aag" - shows "reads_respects_f_g aag l (silc_inv aag st and only_timer_irq_inv irq st' and einvs - and schact_is_rct and is_subject aag \ cur_thread - and domain_sep_inv (pasMaySendIrqs aag) st' - and (\s. ev \ Interrupt \ (ct_active s)) - and pas_refined aag and pas_cur_domain aag - and K (\ pasMaySendIrqs aag)) + shows "reads_respects_f_g aag l (silc_inv aag st and only_timer_irq_inv irq st' + and einvs and valid_cur_hyp + and schact_is_rct and is_subject aag \ cur_thread + and domain_sep_inv (pasMaySendIrqs aag) st' + and (\s. ev \ Interrupt \ (ct_active s)) + and pas_refined aag and pas_cur_domain aag + and K (\ pasMaySendIrqs aag)) (handle_event ev)" apply (rule gen_asm_ev) apply (rule_tac Q="ev \ Interrupt" in equiv_valid_hoist_guard) @@ -953,17 +960,22 @@ lemma handle_event_reads_respects_f_g: | clarsimp simp: reads_equiv_f_g_conj requiv_g_cur_thread_eq schact_is_rct_simple | wpc | intro impI conjI allI)+ apply (rule equiv_valid_guard_imp) - apply ((wp reads_respects_f_g'[OF handle_hypervisor_fault_reads_respects_g, where Q=\] + apply ((wp reads_respects_f_g'[OF handle_hypervisor_fault_reads_respects_g] handle_hypervisor_fault_silc_inv | simp)+)[1] - prefer 2 - apply ((wp reads_respects_f_g'[OF handle_fault_reads_respects_g, where st=st] | simp)+)[1] - apply (simp add: validE_E_def) - apply (wp hv_invs handle_vm_fault_silc_inv)+ - apply (simp add: invs_imps invs_mdb invs_valid_idle)+ + apply simp + apply (wp hv_invs handle_vm_fault_silc_inv)+ apply (fastforce simp: requiv_g_cur_thread_eq reads_equiv_f_g_conj ct_active_not_idle) done +lemma getRestartPC_reads_respects: + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (as_user t getRestartPC)" + by (wpsimp wp: as_user_reads_respects simp: det_getRestartPC) + +lemma setNextPC_reads_respects: + "reads_respects aag l (K (aag_can_read_or_affect aag l t)) (as_user t (setNextPC pc))" + by (wpsimp wp: as_user_reads_respects simp: det_setNextPC) + lemma activate_thread_reads_respects: assumes domains_distinct[wp]: "pas_domains_distinct aag" shows "reads_respects aag (l :: 'a subject_label) @@ -971,9 +983,9 @@ lemma activate_thread_reads_respects: activate_thread" apply (simp add: activate_thread_def) apply (wpsimp wp: set_thread_state_runnable_reads_respects get_thread_state_rev) - by (wp set_object_reads_respects get_thread_state_rev - | simp add: as_user_def select_f_returns tcb_at_st_tcb_at[symmetric] cur_tcb_def - | rule hoare_drop_imps conjI requiv_cur_thread_eq requiv_get_tcb_eq' + by (wpsimp wp: set_object_reads_respects get_thread_state_rev + getRestartPC_reads_respects setNextPC_reads_respects + | rule hoare_drop_imps conjI requiv_cur_thread_eq | clarsimp simp: st_tcb_at_def obj_at_def is_tcb_def)+ lemma activate_thread_globals_equiv: diff --git a/proof/infoflow/Tcb_IF.thy b/proof/infoflow/Tcb_IF.thy index 8ebed3048a..1188438143 100644 --- a/proof/infoflow/Tcb_IF.thy +++ b/proof/infoflow/Tcb_IF.thy @@ -22,7 +22,7 @@ lemma setup_reply_master_globals_equiv: setup_reply_master t \\_. globals_equiv st\" unfolding setup_reply_master_def - apply (wp set_cap_globals_equiv'' set_original_globals_equiv get_cap_wp) + apply (wp set_cap_globals_equiv set_original_globals_equiv get_cap_wp) apply clarsimp done @@ -42,7 +42,7 @@ lemma cap_swap_for_delete_globals_equiv[wp]: cap_swap_for_delete a b \\_. globals_equiv st\" unfolding cap_swap_for_delete_def cap_swap_def set_original_def - by (wp modify_wp set_cdt_globals_equiv set_cap_globals_equiv'' dxo_wp_weak | simp)+ + by (wp modify_wp set_cdt_globals_equiv set_cap_globals_equiv dxo_wp_weak | simp)+ lemma rec_del_preservation2': assumes finalise_cap_P: "\cap final. \R cap and P\ finalise_cap cap final \\_. P\" @@ -191,7 +191,7 @@ locale Tcb_IF_1 = and arch_post_modify_registers_reads_respects_f[wp]: "reads_respects_f aag l \ (arch_post_modify_registers cur t)" and arch_get_sanitise_register_info_reads_respects_f[wp]: - "reads_respects_f aag l \ (arch_get_sanitise_register_info t)" + "reads_respects_f aag l (K (aag_can_read_or_affect aag l t)) (arch_get_sanitise_register_info t)" begin crunch cap_swap_for_delete @@ -206,7 +206,7 @@ lemma rec_del_globals_equiv: rec_del_preservation2[where Q="valid_arch_state" and R="\cap s. invs s \ valid_cap cap s \ (\p. cap = ThreadCap p \ p \ idle_thread s)"]) - apply (wp set_cap_globals_equiv'') + apply (wp set_cap_globals_equiv) apply simp apply (wp empty_slot_globals_equiv)+ apply simp @@ -295,9 +295,12 @@ locale Tcb_IF_2 = Tcb_IF_1 + and K (authorised_tcb_inv aag ti \ authorised_tcb_inv_extra aag ti)) (invoke_tcb ti)" and arch_post_set_flags_globals_equiv[wp]: - "arch_post_set_flags t flags \globals_equiv st\" + "\globals_equiv st and invs\ + arch_post_set_flags t flags + \\_. globals_equiv st\" and arch_post_set_flags_reads_respects_f: - "reads_respects_f aag l \ (arch_post_set_flags t flags)" + "pas_domains_distinct aag \ + reads_respects_f aag l (silc_inv aag st and valid_cur_fpu and K (is_subject aag t)) (arch_post_set_flags t flags)" begin crunch suspend, restart @@ -325,9 +328,8 @@ lemma invoke_tcb_globals_equiv: weak_if_wp')+ apply (intro conjI impI; clarsimp simp: no_cap_to_idle_thread)+ apply (simp del: invoke_tcb.simps tcb_inv_wf.simps) - apply (wp invoke_tcb_thread_preservation cap_delete_globals_equiv - cap_insert_globals_equiv'' thread_set_globals_equiv set_mcpriority_globals_equiv - set_priority_globals_equiv + apply (wp invoke_tcb_thread_preservation cap_delete_globals_equiv cap_insert_globals_equiv + thread_set_globals_equiv set_mcpriority_globals_equiv set_priority_globals_equiv | fastforce)+ done @@ -417,7 +419,7 @@ lemma set_mcpriority_reads_respects: assumes domains_distinct: "pas_domains_distinct aag" shows "reads_respects aag (l :: 'a subject_label) \ (set_mcpriority x y)" unfolding set_mcpriority_def - by (rule thread_set_reads_respects[OF domains_distinct]) + by (rule thread_set_reads_respects) lemma checked_cap_insert_only_timer_irq_inv: "check_cap_at a b (check_cap_at c d (cap_insert a b e)) \only_timer_irq_inv irq (st :: det_state)\" @@ -481,6 +483,10 @@ lemma thread_set_tcb_flags_update_silc_inv[wp]: "thread_set (tcb_flags_update f) t \silc_inv aag st\" by (rule thread_set_silc_inv; simp add: tcb_cap_cases_def) +crunch set_flags + for silc_inv[wp]: "silc_inv aag st" + (ignore: thread_set) + lemma set_flags_reads_respects_f: assumes "pas_domains_distinct aag" shows "reads_respects_f aag l (silc_inv aag st) (set_flags t flags)" @@ -528,7 +534,7 @@ lemma invoke_tcb_reads_respects_f: idle_no_ex_cap[OF invs_valid_global_refs invs_valid_objs]\) defer apply ((wp suspend_reads_respects_f[where st=st] restart_reads_respects_f[where st=st] - | simp add: authorised_tcb_inv_def )+)[2] + | simp add: authorised_tcb_inv_def)+)[2] \ \NotificationControl\ apply (rename_tac option) apply (case_tac option, simp_all)[1] diff --git a/proof/infoflow/UserOp_IF.thy b/proof/infoflow/UserOp_IF.thy index 9e720918d7..fc15748bbd 100644 --- a/proof/infoflow/UserOp_IF.thy +++ b/proof/infoflow/UserOp_IF.thy @@ -116,6 +116,14 @@ locale UserOp_IF_1 = arch_globals_equiv ct it kh kh' as as' ms ms'" "\f. arch_globals_equiv ct it kh kh' as as' ms (device_state_update f ms') = arch_globals_equiv ct it kh kh' as as' ms ms'" + and no_hyp_modify[wp,simp]: + "\f. no_hyp (modify (\ms :: machine_state. ms\underlying_memory := f ms\))" + "\f. no_hyp (modify (\ms :: machine_state. ms\device_state := f ms\))" + "\f. no_hyp (modify (\ms :: machine_state. ms\machine_state_rest := f ms\))" + and no_fpu_modify[wp,simp]: + "\f. no_fpu (modify (\ms :: machine_state. ms\underlying_memory := f ms\))" + "\f. no_fpu (modify (\ms :: machine_state. ms\device_state := f ms\))" + "\f. no_fpu (modify (\ms :: machine_state. ms\machine_state_rest := f ms\))" begin (* Assumptions: @@ -132,13 +140,10 @@ lemma dmo_user_memory_update_reads_respects_g: apply (subgoal_tac "reads_respects aag l \ (do_machine_op (user_memory_update um))") apply (fastforce simp: equiv_valid_def2 equiv_valid_2_def in_monad do_machine_op_def user_memory_update_def select_f_def idle_equiv_def) - apply (rule use_spec_ev) apply (simp add: user_memory_update_def) - apply (rule do_machine_op_spec_reads_respects) - apply (simp add: equiv_valid_def2) - apply (rule modify_ev2) - apply (fastforce intro: equiv_forI elim: equiv_forE split: option.splits) - apply (wp | simp)+ + apply (wpsimp wp: do_machine_op_reads_respects modify_ev) + apply (fastforce intro: equiv_forI elim: equiv_forE split: option.splits) + apply wpsimp+ done lemma dmo_device_state_update_reads_respects_g: @@ -150,13 +155,10 @@ lemma dmo_device_state_update_reads_respects_g: apply (subgoal_tac "reads_respects aag l \ (do_machine_op (device_memory_update um))") apply (fastforce simp: equiv_valid_def2 equiv_valid_2_def in_monad do_machine_op_def device_memory_update_def select_f_def idle_equiv_def) - apply (rule use_spec_ev) apply (simp add: device_memory_update_def) - apply (rule do_machine_op_spec_reads_respects) - apply (simp add: equiv_valid_def2) - apply (rule modify_ev2) - apply (fastforce intro: map_add_eq equiv_forI elim: equiv_forE split: option.splits) - apply (wp | simp)+ + apply (wpsimp wp: do_machine_op_reads_respects modify_ev) + apply (fastforce intro: map_add_eq equiv_forI elim: equiv_forE split: option.splits) + apply wpsimp+ done end diff --git a/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy new file mode 100644 index 0000000000..13186268c7 --- /dev/null +++ b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine.thy @@ -0,0 +1,431 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchADT_IF_Refine +imports ADT_IF_Refine +begin + +context Arch begin arch_global_naming + +named_theorems ADT_IF_Refine_assms + +defs arch_extras_def: + "arch_extras \ \s. True" + +declare arch_extras_def[simp] + +lemma kernelEntry_invs'[ADT_IF_Refine_assms, wp]: + "\invs' and (\s. e \ Interrupt \ ct_running' s) + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and arch_extras\ + kernelEntry_if e tc + \\_. invs'\" + apply (simp add: kernelEntry_if_def) + apply (wp threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp + | wp (once) hoare_drop_imps + | clarsimp)+ + done + +lemma kernelEntry_arch_extras[ADT_IF_Refine_assms, wp]: + "\invs' and (\s. e \ Interrupt \ ct_running' s) + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and arch_extras\ + kernelEntry_if e tc + \\_. arch_extras\" + apply (simp add: kernelEntry_if_def) + apply (wp threadSet_invs_trivial threadSet_ct_running' hoare_weak_lift_imp + | wp (once) hoare_drop_imps + | clarsimp)+ + done + +crunch threadSet + for arch_extras[ADT_IF_Refine_assms, wp]: "arch_extras" + +lemma arch_tcb_context_set_tcb_relation[ADT_IF_Refine_assms]: + "tcb_relation tcb tcb' + \ tcb_relation (tcb\tcb_arch := arch_tcb_context_set tc (tcb_arch tcb)\) + (tcbArch_update (atcbContextSet tc) tcb')" + by (simp add: tcb_relation_def arch_tcb_relation_def arch_tcb_context_set_def atcbContextSet_def) + +lemma arch_tcb_context_get_atcbContextGet[ADT_IF_Refine_assms]: + "tcb_relation tcb tcb' + \ (arch_tcb_context_get \ tcb_arch) tcb = (atcbContextGet \ tcbArch) tcb'" + by (simp add: tcb_relation_def arch_tcb_relation_def arch_tcb_context_get_def atcbContextGet_def) + +definition + "ptable_attrs_s' s \ ptable_attrs (ksCurThread s) (absKState s)" + +definition + "ptable_xn_s' s \ \addr. Execute \ ptable_attrs_s' s addr" + +definition doUserOp_if :: + "user_transition_if \ user_context \ (event option \ user_context) kernel" where + "doUserOp_if uop tc \ + do pr \ gets ptable_rights_s'; + pxn \ gets (\s x. pr x \ {} \ ptable_xn_s' s x); + pl \ gets (\s. ptable_lift_s' s |` {x. pr x \ {}}); + allow_read \ return {y. \x. pl x = Some y \ AllowRead \ pr x}; + allow_write \ return {y. \x. pl x = Some y \ AllowWrite \ pr x}; + t \ getCurThread; + um \ gets (\s. (user_mem' s \ ptrFromPAddr)); + dm \ gets (\s. (device_mem' s \ ptrFromPAddr)); + ds \ gets (device_state \ ksMachineState); + assert (dom (um \ addrFromPPtr) \ - dom ds); + assert (dom (dm \ addrFromPPtr) \ dom ds); + u \ + return + (uop t pl pr pxn + (tc, um |` allow_read, + (ds \ ptrFromPAddr) |` allow_read)); + assert (u \ {}); + (e, tc', um',ds') \ select u; + doMachineOp + (user_memory_update + ((um' |` allow_write \ addrFromPPtr) |` (- (dom ds)))); + doMachineOp + (device_memory_update + ((ds' |` allow_write \ addrFromPPtr) |` dom ds)); + return (e, tc') + od" + +lemma ptable_attrs_abs_state[simp]: + "ptable_attrs thread (abs_state s) = ptable_attrs thread s" + by (simp add: ptable_attrs_def abs_state_def) + +lemma doUserOp_if_empty_fail[ADT_IF_Refine_assms]: + "empty_fail (doUserOp_if uop tc)" + apply (simp add: doUserOp_if_def) + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (wp (once)) + apply wp + apply (subst bind_assoc[symmetric]) + apply (rule empty_fail_bind) + apply (rule empty_fail_select_bind) + apply (wp | wpc)+ + done + +lemma do_user_op_if_corres[ADT_IF_Refine_assms]: + "corres (=) (einvs and ct_running and (\_. \t pl pr pxn tcu. f t pl pr pxn tcu \ {})) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running') + (do_user_op_if f tc) (doUserOp_if f tc)" + apply (rule corres_gen_asm) + apply (simp add: do_user_op_if_def doUserOp_if_def) + apply (rule corres_gets_same) + apply (clarsimp simp: ptable_rights_s_def ptable_rights_s'_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: ptable_attrs_s'_def ptable_attrs_s_def ptable_xn_s'_def ptable_xn_s_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: absArchState_correct curthread_relation ptable_lift_s'_def + ptable_lift_s_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (simp add: getCurThread_def) + apply (rule corres_gets_same) + apply (simp add: curthread_relation) + apply simp + apply (rule corres_gets_same[where R ="\r s. dom (r \ addrFromPPtr) \ - device_region s"]) + apply (clarsimp simp add: user_mem_relation dest!: invs_valid_stateI invs_valid_stateI') + apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) + apply fastforce + apply (rule corres_gets_same[where R ="\r s. dom (r \ addrFromPPtr) \ device_region s"]) + apply (clarsimp simp add: device_mem_relation dest!: invs_valid_stateI invs_valid_stateI') + apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) + apply fastforce + apply (rule corres_gets_same[where R ="\r s. dom r = device_region s"]) + apply (clarsimp simp: state_relation_def) + apply simp + apply (rule corres_assert_imp_r) + apply fastforce + apply (rule corres_assert_imp_r) + apply fastforce + apply (rule corres_guard_imp) + apply (rule corres_split[where r'="(=)"]) + apply (clarsimp simp: select_def corres_underlying_def) + apply clarsimp + apply (rule corres_split[OF corres_machine_op', where r'="(=)"]) + apply (rule corres_underlying_trivial) + apply (clarsimp simp: user_memory_update_def) + apply (rule no_fail_modify) + apply (rule corres_split[OF corres_machine_op,where r'="(=)"]) + apply (rule corres_underlying_trivial) + apply wp + apply (rule corres_trivial, clarsimp) + apply (wp hoare_TrueI[where P = \] | simp)+ + done + +lemma doUserOp_if_invs'[ADT_IF_Refine_assms, wp]: + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and ex_abs (einvs)\ + doUserOp_if f tc + \\_. invs'\" + apply (simp add: doUserOp_if_def split_def ex_abs_def) + apply (wp device_update_invs' dmo_invs' | simp)+ + apply (clarsimp simp add: no_irq_modify user_memory_update_def) + apply wpsimp + apply wp+ + apply (clarsimp simp: user_memory_update_def simpler_modify_def + restrict_map_def + split: option.splits) + apply (auto dest: ptable_rights_imp_UserData[rotated 2] + simp: ptable_rights_s'_def ptable_lift_s'_def) + done + +lemma doUserOp_valid_duplicates[ADT_IF_Refine_assms, wp]: + "doUserOp_if f tc \arch_extras\" + apply (simp add: doUserOp_if_def split_def) + apply (wp dmo_invs' | simp)+ + done + +lemma doUserOp_if_schedact[ADT_IF_Refine_assms, wp]: + "doUserOp_if f tc \\s. P (ksSchedulerAction s)\" + apply (simp add: doUserOp_if_def) + apply (wp | wpc | simp)+ + done + +lemma doUserOp_if_st_tcb_at[ADT_IF_Refine_assms, wp]: + "doUserOp_if f tc \st_tcb_at' st t\" + apply (simp add: doUserOp_if_def) + apply (wp | wpc | simp)+ + done + +lemma doUserOp_if_cur_thread[ADT_IF_Refine_assms, wp]: + "doUserOp_if f tc \\s. P (ksCurThread s)\" + apply (simp add: doUserOp_if_def) + apply (wp | wpc | simp)+ + done + +lemma do_user_op_if_corres'[ADT_IF_Refine_assms]: + "corres_underlying state_relation nf False (=) (einvs and ct_running) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running') + (do_user_op_if f tc) (doUserOp_if f tc)" + apply (simp add: do_user_op_if_def doUserOp_if_def) + apply (rule corres_gets_same) + apply (clarsimp simp: ptable_rights_s_def ptable_rights_s'_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: ptable_attrs_s'_def ptable_attrs_s_def ptable_xn_s'_def ptable_xn_s_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: absArchState_correct curthread_relation ptable_lift_s'_def + ptable_lift_s_def) + apply (subst absKState_correct, fastforce, assumption+) + apply (clarsimp elim!: state_relationE) + apply simp + apply (simp add: getCurThread_def) + apply (rule corres_gets_same) + apply (simp add: curthread_relation) + apply simp + apply (rule corres_gets_same[where R ="\r s. dom (r \ addrFromPPtr) \ - device_region s"]) + apply (clarsimp simp add: user_mem_relation dest!: invs_valid_stateI invs_valid_stateI') + apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) + apply fastforce + apply (rule corres_gets_same[where R ="\r s. dom (r \ addrFromPPtr) \ device_region s"]) + apply (clarsimp simp add: device_mem_relation dest!: invs_valid_stateI invs_valid_stateI') + apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def dom_def) + apply (rule corres_gets_same[where R ="\r s. dom r = device_region s"]) + apply (clarsimp simp: state_relation_def) + apply simp + apply (rule corres_assert_imp_r) + apply fastforce + apply (rule corres_assert_imp_r) + apply fastforce + apply (rule corres_guard_imp) + apply (rule corres_split[where r'="dc"]) + apply (rule corres_assert') + apply simp + apply (rule corres_split[where r'="(=)"]) + apply (clarsimp simp: select_def corres_underlying_def) + apply clarsimp + apply (rule corres_split[OF corres_machine_op',where r'="(=)"]) + apply (rule corres_underlying_trivial, clarsimp) + apply (rule corres_split[OF corres_machine_op', where r'="(=)"]) + apply (rule corres_underlying_trivial, clarsimp) + apply (rule corres_trivial, clarsimp) + apply (wp hoare_TrueI[where P = \] | simp)+ + apply force + apply force + done + +lemma getActiveIRQ_nf: + "no_fail (\_. True) (getActiveIRQ in_kernel)" + apply (simp add: getActiveIRQ_def) + apply (rule no_fail_pre) + apply (rule no_fail_gets no_fail_modify + no_fail_return | rule no_fail_bind | simp + | intro impI conjI)+ + apply (wp del: no_irq | simp)+ + done + +lemma dmo_getActiveIRQ_corres[ADT_IF_Refine_assms]: + "corres (=) \ \ (do_machine_op (getActiveIRQ in_kernel)) (doMachineOp (getActiveIRQ in_kernel))" + apply (rule SubMonad_R.corres_machine_op) + apply (rule corres_Id) + apply (simp add: getActiveIRQ_def non_kernel_IRQs_def) + apply simp + apply (rule getActiveIRQ_nf) + done + +lemma dmo'_getActiveIRQ_wp[ADT_IF_Refine_assms]: + "\\s. P (irq_at (irq_state (ksMachineState s) + 1) (irq_masks (ksMachineState s))) + (s\ksMachineState := (ksMachineState s\irq_state := irq_state (ksMachineState s) + 1\)\)\ + doMachineOp (getActiveIRQ False) + \P\" + apply(simp add: doMachineOp_def getActiveIRQ_def non_kernel_IRQs_def) + apply(wp modify_wp | wpc)+ + apply clarsimp + apply(erule use_valid) + apply (wp modify_wp) + apply(auto simp: irq_at_def) + done + +lemma scheduler_if'_arch_extras[ADT_IF_Refine_assms, wp]: + "\invs' and arch_extras\ + schedule'_if tc + \\_. arch_extras\" + apply (simp add: schedule'_if_def) + apply (wp hoare_drop_imps | simp)+ + done + +lemma handlePreemption_if_arch_extras[ADT_IF_Refine_assms, wp]: + "handlePreemption_if tc \arch_extras\" + apply (simp add: handlePreemption_if_def) + apply (wp dmo'_getActiveIRQ_wp hoare_drop_imps) + done + +crunch doUserOp_if + for ksDomainTime_inv[ADT_IF_Refine_assms, wp]: "\s. P (ksDomainTime s)" + and ksDomSchedule_inv[ADT_IF_Refine_assms, wp]: "\s. P (ksDomSchedule s)" + +crunch checkActiveIRQ_if + for arch_extras[ADT_IF_Refine_assms, wp]: arch_extras + +lemma valid_device_abs_state_eq[ADT_IF_Refine_assms]: + "valid_machine_state s \ abs_state s = s" + apply (simp add: abs_state_def observable_memory_def) + apply (case_tac s) + apply clarsimp + apply (case_tac machine_state) + apply clarsimp + apply (rule ext) + apply (fastforce simp: user_mem_def option_to_0_def valid_machine_state_def) + done + +lemma doUserOp_if_no_interrupt[ADT_IF_Refine_assms]: + "\K (uop_sane uop)\ + doUserOp_if uop tc + \\r s. (fst r) \ Some Interrupt\" + apply (simp add: doUserOp_if_def del: split_paired_All) + apply (wp | wpc)+ + apply (clarsimp simp: uop_sane_def simp del: split_paired_All) + done + +lemma handleEvent_corres_arch_extras[ADT_IF_Refine_assms]: + "corres (dc \ dc) + (einvs and (\s. event \ Interrupt \ ct_running s) and schact_is_rct) + (invs' and (\s. event \ Interrupt \ ct_running' s) + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and arch_extras) + (handle_event event) (handleEvent event)" + by (fastforce intro: corres_guard2_imp[OF handleEvent_corres]) + +lemma handle_event_valid_domain_time_IRQ: + "\\s. 0 < domain_time s \ + handle_event Interrupt + \\_ s::det_state. domain_time s = 0 \ scheduler_action s = choose_new_thread\, -" + by (wpsimp wp: maybe_handle_interrupt_valid_domain_time wp_del: handle_event_domain_time_valid) + +lemma kernel_entry_if_corres[ADT_IF_Refine_assms]: + "corres (prod_lift (dc \ dc)) + (einvs and no_domain_caps + and (\s. event \ Interrupt \ ct_running s) + and schact_is_rct + and (\s. 0 < domain_time s) and valid_domain_list) + (invs' and (\s. event \ Interrupt \ ct_running' s) + and arch_extras + and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (kernel_entry_if event tc) (kernelEntry_if event tc)" + supply local.getActiveIRQ_inv[wp del] + supply Machine_AI.AARCH64.getActiveIRQ_inv[wp del] + apply (simp add: kernel_entry_if_def kernelEntry_if_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getCurThread_corres]) + apply (rule corres_split) + apply simp + apply (rule threadset_corresT) + apply (erule arch_tcb_context_set_tcb_relation) + apply (clarsimp simp: tcb_cap_cases_def) + apply (rule allI[OF ball_tcb_cte_casesI]; clarsimp) + apply fastforce + apply fastforce + apply fastforce + apply (rule corres_split[OF handleEvent_corres_arch_extras]) + apply (rule corres_stateAssert_assume_stronger[where Q=\ and + P="\s. valid_domain_list s \ + (event \ Interrupt \ 0 < domain_time s) \ + (event = Interrupt \ domain_time s = 0 \ + scheduler_action s = choose_new_thread)"]) + apply (clarsimp simp: prod_lift_def) + apply (clarsimp simp: state_relation_def) + apply (wp add: threadSet_invs_trivial thread_set_invs_trivial thread_set_ct_in_state + threadSet_ct_running' thread_set_not_state_valid_sched + hoare_vcg_const_imp_lift + handle_interrupt_valid_domain_time handle_event_valid_domain_time_IRQ + handle_event_noIRQ_domain_time_inv + no_domain_caps_sep_inv_lift[OF thread_set_tcb_arch_update_domain_sep_inv] + del: handle_event_domain_time_valid + | simp add: tcb_cap_cases_def schact_is_rct_def maybe_handle_interrupt_def + arch_tcb_update_aux2 + | wpc + | wps + | wp (once) hoare_drop_imp)+ + apply (fastforce simp: invs_def cur_tcb_def valid_state_def) + apply force + done + +end + +arch_requalify_consts doUserOp_if + + +global_interpretation ADT_IF_Refine_1?: ADT_IF_Refine_1 doUserOp_if +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_Refine_assms)?) +qed + + +sublocale valid_initial_state_noenabled \ valid_initial_state_noenabled?: + ADT_valid_initial_state_noenabled doUserOp_if .. + +sublocale valid_initial_state_noenabled \ valid_initial_state .. + +end diff --git a/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy new file mode 100644 index 0000000000..dfabbfc18a --- /dev/null +++ b/proof/infoflow/refine/AARCH64/ArchADT_IF_Refine_C.thy @@ -0,0 +1,330 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchADT_IF_Refine_C +imports ADT_IF_Refine_C +begin + +context kernel_m begin + +named_theorems ADT_IF_Refine_assms + +lemma handleInvocation_ccorres'[ADT_IF_Refine_assms]: + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_active' and sch_act_simple) + (UNIV \ {s. isCall_' s = from_bool isCall} + \ {s. isBlocking_' s = from_bool isBlocking}) [] + (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" + apply (simp only: arch_extras_def pred_top_right_neutral) + apply (rule handleInvocation_ccorres) + done + +definition + "ptable_rights_s'' s \ ptable_rights (cur_thread (cstate_to_A s)) (cstate_to_A s)" + +definition + "ptable_lift_s'' s \ ptable_lift (cur_thread (cstate_to_A s)) (cstate_to_A s)" + +definition + "ptable_attrs_s'' s \ ptable_attrs (cur_thread (cstate_to_A s)) (cstate_to_A s)" + +definition + "ptable_xn_s'' s \ \addr. Execute \ ptable_attrs_s'' s addr" + +definition + doMachineOp_C :: "(machine_state, 'a) nondet_monad \ (cstate, 'a) nondet_monad" +where + "doMachineOp_C mop \ + do + ms \ gets (\s. phantom_machine_state_' (globals s)); + (r, ms') \ select_f (mop ms); + modify (\s. s \globals := globals s \ phantom_machine_state_' := ms' \\); + return r + od" + +definition doUserOp_C_if + :: "user_transition_if \ user_context \ (cstate, (event option \ user_context)) nondet_monad" + where + "doUserOp_C_if uop tc \ + do + pr \ gets ptable_rights_s''; + pxn \ gets (\s x. pr x \ {} \ ptable_xn_s'' s x); + pl \ gets (\s. restrict_map (ptable_lift_s'' s) {x. pr x \ {}}); + allow_read \ return {y. \x. pl x = Some y \ AllowRead \ pr x}; + allow_write \ return {y. \x. pl x = Some y \ AllowWrite \ pr x}; + t \ gets (\s. cur_thread (cstate_to_A s)); + um \ gets (\s. user_mem_C (globals s) \ ptrFromPAddr); + dm \ gets (\s. device_mem_C (globals s) \ ptrFromPAddr); + ds \ gets (\s. device_state (phantom_machine_state_' (globals s))); + assert (dom (um \ addrFromPPtr) \ - dom ds); + assert (dom (dm \ addrFromPPtr) \ dom ds); + u \ return (uop t pl pr pxn (tc, um |` allow_read, (ds \ ptrFromPAddr)|` allow_read)); + assert (u \ {}); + (e,(tc',um',ds')) \ select u; + setUserMem_C ((um' |` allow_write \ addrFromPPtr) |` (- dom ds)); + setDeviceState_C ((ds' |` allow_write \ addrFromPPtr) |` dom ds); + return (e,tc') + od" + +lemma corres_underlying_split4: + "(\a b c d. corres_underlying srel nf nf' rrel (Q a b c d) (Q' a b c d) (f a b c d) (f' a b c d)) + \ corres_underlying srel nf nf' rrel (case x of (a,b,c,d) \ Q a b c d) + (case x of (a,b,c,d) \ Q' a b c d) + (case x of (a,b,c,d) \ f a b c d) + (case x of (a,b,c,d) \ f' a b c d)" + by (cases x; simp) + +lemma do_user_op_if_C_corres[ADT_IF_Refine_assms]: + "corres_underlying rf_sr False False (=) + (invs' and ex_abs einvs and (\_. uop_nonempty f)) \ + (doUserOp_if f tc) (doUserOp_C_if f tc)" + apply (rule corres_gen_asm) + apply (simp add: doUserOp_if_def doUserOp_C_if_def uop_nonempty_def del: split_paired_All) + apply (rule corres_gets_same) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt + simp: absKState_crelation ptable_rights_s'_def ptable_rights_s''_def + rf_sr_def cstate_relation_def Let_def cstate_to_H_correct) + apply simp + apply (rule corres_gets_same) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt + simp: ptable_xn_s'_def ptable_xn_s''_def ptable_attrs_s_def + absKState_crelation ptable_attrs_s'_def ptable_attrs_s''_def rf_sr_def) + apply simp + apply (rule corres_gets_same) + apply clarsimp + apply (frule ex_abs_ksReadyQueues_asrt) + apply (clarsimp simp: absKState_crelation curthread_relation ptable_lift_s'_def ptable_lift_s''_def + ptable_lift_s_def rf_sr_def) + apply simp + apply (simp add: getCurThread_def) + apply (rule corres_gets_same) + apply (fastforce dest: ex_abs_ksReadyQueues_asrt simp: absKState_crelation rf_sr_def) + apply simp + apply (rule corres_gets_same) + apply (rule fun_cong[where x=ptrFromPAddr]) + apply (rule_tac f=comp in arg_cong) + apply (rule user_mem_C_relation[symmetric]) + apply (simp add: rf_sr_def cstate_relation_def Let_def cpspace_relation_def) + apply fastforce + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: rf_sr_def cstate_relation_def Let_def + cpspace_relation_def) + apply (drule device_mem_C_relation[symmetric]) + apply fastforce + apply (simp add: comp_def) + apply simp + apply (rule corres_gets_same) + apply (clarsimp simp: cstate_relation_def rf_sr_def + Let_def cmachine_state_relation_def) + apply simp + apply (rule corres_guard_imp) + apply (rule_tac P=\ and P'=\ and r'="(=)" in corres_split) + apply (clarsimp simp add: corres_underlying_def fail_def + assert_def return_def + split: if_splits) + apply simp + apply (rule_tac P=\ and P'=\ and r'="(=)" in corres_split) + apply (clarsimp simp add: corres_underlying_def fail_def + assert_def return_def + split: if_splits) + apply simp + apply (rule_tac r'="(=)" in corres_split[OF corres_select]) + apply clarsimp + apply simp + apply (rule corres_underlying_split4) + apply (rule corres_split[OF user_memory_update_corres_C]) + apply (rule corres_split[OF device_update_corres_C]) + apply (wp | simp)+ + apply (clarsimp simp: ex_abs_def restrict_map_def invs_pspace_aligned' + invs_pspace_distinct' ptable_lift_s'_def ptable_rights_s'_def + split: if_splits) + apply (drule ptable_rights_imp_UserData[rotated -1]) + apply ((fastforce | intro conjI)+)[4] + apply (clarsimp simp: user_mem'_def device_mem'_def dom_def split: if_splits) + apply fastforce + apply (clarsimp simp add: invs'_def valid_state'_def valid_pspace'_def ex_abs_def) + done + +lemma check_active_irq_corres_C[ADT_IF_Refine_assms]: + "corres_underlying rf_sr False False (=) \ \ + (checkActiveIRQ_if tc) (checkActiveIRQ_C_if tc)" + apply (simp add: checkActiveIRQ_if_def checkActiveIRQ_C_if_def) + apply (simp add: getActiveIRQ_C_def) + apply (subst bind_assoc[symmetric]) + apply (rule corres_guard_imp) + apply (rule corres_split[where r'="\a c. case a of None \ c = ucast irqInvalid + | Some x \ c = ucast x \ c \ ucast irqInvalid", + OF ccorres_corres_u_xf]) + apply (rule ccorres_guard_imp) + apply (rule ccorres_rel_imp, rule ccorres_guard_imp) + apply (rule getActiveIRQ_ccorres) + apply simp+ + apply (clarsimp split: option.splits) + apply simp+ + apply (rule no_fail_dmo') + apply (rule no_fail_getActiveIRQ) + apply (rule corres_trivial, clarsimp split: if_split option.splits) + apply wp+ + apply simp+ + apply fastforce + done + +lemma obs_cpspace_user_data_relation[ADT_IF_Refine_assms]: + "\pspace_aligned' bd;pspace_distinct' bd; + cpspace_user_data_relation (ksPSpace bd) (underlying_memory (ksMachineState bd)) hgs\ + \ cpspace_user_data_relation (ksPSpace bd) (underlying_memory (observable_memory (ksMachineState bd) (user_mem' bd))) hgs" + apply (clarsimp simp: cmap_relation_def dom_heap_to_user_data) + apply (drule bspec,fastforce) + apply (clarsimp simp: cuser_user_data_relation_def observable_memory_def + heap_to_user_data_def map_comp_def Let_def + split: option.split_asm) + apply (drule_tac x = off in spec) + apply (subst option_to_0_user_mem') + apply (subst map_option_byte_to_word_heap) + apply (clarsimp simp: projectKO_opt_user_data pointerInUserData_def field_simps + split: kernel_object.split_asm option.split_asm) + apply (frule(1) pspace_alignedD') + apply (subst neg_mask_add_aligned) + apply (simp add: objBits_simps) + apply (simp add: word_less_nat_alt) + apply (rule le_less_trans[OF unat_plus_gt]) + apply (subst add.commute) + apply (subst unat_mult_simple) + apply (simp add: word_bits_def) + apply (rule less_le_trans[OF unat_lt2p]) + apply simp + apply simp + apply (rule nat_add_offset_less [where n = 3, simplified]) + apply simp + apply (rule unat_lt2p) + apply (simp add: pageBits_def objBits_simps) + apply (frule(1) pspace_distinctD') + apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def objBits_simps) + apply simp + done + + +definition handleHypervisorFault_C_body_if :: "machine_word \ (globals myvars, int, strictc_errortype) com" + where + "handleHypervisorFault_C_body_if hyp_fault_type == + IF hyp_fault_type = 0x2000000 \ \UNKNOWN_FAULT\ THEN + \ret__unsigned_long :== CALL getESR();; + \current_fault :== CALL seL4_Fault_UserException_new(\ret__unsigned_long,0);; + CALL handleFault(\ksCurThread) + ELSE + \current_fault :== CALL seL4_Fault_VCPUFault_new(hyp_fault_type);; + CALL handleFault(\ksCurThread) + FI;; + \ret__unsigned_long :== scast EXCEPTION_NONE" + +definition hyp_fault_type_from_H :: "hyp_fault_type \ machine_word" where + "hyp_fault_type_from_H fault \ + case fault of hyp_fault_type.ARMVCPUFault f \ ucast f" + +lemma handleHypervisorFault_C_body_ccorres[ADT_IF_Refine_assms]: + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (UNIV) [] + (liftE (do thread <- getCurThread; + handleHypervisorFault thread flt + od)) + (handleHypervisorFault_C_body_if (hyp_fault_type_from_H flt))" + apply (rule ccorres_guard_imp) + apply (simp add: liftE_def bind_assoc handleHypervisorFault_C_body_if_def) + apply (rule ccorres_pre_getCurThread) + apply (rule ccorres_split_nothrow_novcg) + apply (simp only: handleHypervisorFault_def handleHypervisorFault_C_body_if_def hyp_fault_type_from_H_def) + apply wpc + apply (rule_tac P="ARMVCPUFault x = ARMVCPUFault 0x2000000" in ccorres_cases) + apply clarsimp + apply (rule ccorres_cond_univ) + apply (rule ccorres_rhs_assoc)+ + apply (ctac (no_vcg) add: getESR_ccorres) + apply (rule ccorres_symb_exec_r) + apply (rule_tac P="\s. ksCurThread s = thread" in ccorres_cross_over_guard) + apply (rule_tac xf'=xfdc in ccorres_call) + apply (ctac (no_vcg) add: handleFault_ccorres) + apply simp + apply simp + apply simp + apply vcg + apply (clarsimp, rule conseqPre, vcg) + apply clarsimp + apply wp + apply (prop_tac "ucast x \ (0x2000000 :: machine_word)") + apply (fastforce dest: eq_ucast_ucast_eq[rotated, OF sym]) + apply clarsimp + apply (rule ccorres_cond_empty) + apply (rule ccorres_symb_exec_r) + apply (rule_tac P="\s. ksCurThread s = thread" in ccorres_cross_over_guard) + apply (rule_tac xf'=xfdc in ccorres_call) + apply (ctac (no_vcg) add: handleFault_ccorres) + apply simp + apply simp + apply simp + apply vcg + apply (rule conseqPre, vcg) + apply clarsimp + apply ceqv + apply clarsimp + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (clarsimp simp: return_def) + apply wp + apply (simp add: guard_is_UNIV_def) + apply clarsimp + apply (auto simp: ct_in_state'_def isReply_def is_cap_fault_def + cfault_rel_def seL4_Fault_UnknownSyscall_lift seL4_Fault_UserException_lift + seL4_Fault_VCPUFault_lift ucast_and_mask_drop + elim: pred_tcb'_weakenE st_tcb_ex_cap'' + dest: st_tcb_at_idle_thread' rf_sr_ksCurThread split: if_splits) + done + +declare handleSpuriousIRQ_ccorres[ADT_IF_Refine_assms] +declare hvmf_invs_lift[ADT_IF_Refine_assms] + +lemma checkInterrupt_ccorres'[ADT_IF_Refine_assms]: + "ccorres dc xfdc (\s. invs' s \ (\inKernel \ sch_act_not (ksCurThread s) s)) UNIV [] + (maybeHandleInterrupt inKernel) (Call checkInterrupt_'proc)" + unfolding maybeHandleInterrupt_def + apply cinit' + apply (rule ccorres_guard_imp) + apply (simp add: liftE_def bind_assoc) + apply (ctac (no_vcg) add: getActiveIRQ_ccorres) + apply (rule_tac P="\_. rv \ None" and R=\ in ccorres_cond_both) + apply (auto split: option.splits)[1] + apply (rule_tac P="rv \ None" in ccorres_gen_asm) + apply clarsimp + apply wpfix + apply (rule ccorres_call[where xf'=xfdc, OF handleInterrupt_ccorres]; simp) + apply (rule_tac P="rv = None" in ccorres_gen_asm) + apply clarsimp + apply wpfix + apply (ctac (no_vcg) add: handleSpuriousIRQ_ccorres) + apply wp + apply (simp add: guard_is_UNIV_def) + apply (rule_tac Q'="\rv s. invs' s \ (\irq. rv = Some irq \ irq \ non_kernel_IRQs \ + sch_act_not (ksCurThread s) s)" + in hoare_post_imp) + apply (solves clarsimp) + apply (wpsimp wp: dmo_getActiveIRQ_inKernel_sch_act_not) + apply assumption + apply assumption + apply (clarsimp simp: invs'_def valid_state'_def) + done + +end + + +sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if handleHypervisorFault_C_body_if hyp_fault_type_from_H +proof goal_cases + interpret Arch . + case 1 show ?case + by (unfold_locales; (fact ADT_IF_Refine_assms)?) +qed + +end diff --git a/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy b/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy new file mode 100644 index 0000000000..0d52da31e5 --- /dev/null +++ b/proof/infoflow/refine/AARCH64/Example_Valid_StateH.thy @@ -0,0 +1,4343 @@ +(* + * Copyright 2023, Proofcraft Pty Ltd + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory Example_Valid_StateH +imports "InfoFlow.Example_Valid_State" ArchADT_IF_Refine +begin + +(* FIXME AARCH64 IF: major cleanup *) + +context Arch begin arch_global_naming + +definition pg_index_bits :: nat where + "pg_index_bits \ pageBitsForSize (max_page_size) - pageBits" + +lemma pg_index_bits_def2: + "pg_index_bits \ if config_ARM_PA_SIZE_BITS_40 then 9 else 18" + apply (rule eq_reflection) + apply (simp add: pg_index_bits_def max_page_size_def bit_simps) + done + +lemma pg_index_bits_ge0[simp, intro!]: "0 < pg_index_bits" + by (simp add: pg_index_bits_def2) + +typedef pg_index_len = "{n :: nat. n < pg_index_bits}" by auto + +end + +instantiation AARCH64.pg_index_len :: len0 +begin + interpretation Arch . + definition len_of_pg_index_len: "len_of (x::pg_index_len itself) \ CARD(pg_index_len)" + instance .. +end + +instantiation AARCH64.pg_index_len :: len +begin + interpretation Arch . + instance + proof + show "0 < LENGTH(pg_index_len)" + by (simp add: len_of_pg_index_len type_definition.card[OF type_definition_pg_index_len]) + qed +end + +context Arch begin arch_global_naming + +type_synonym pg_index = "pg_index_len word" + +lemma length_pg_index_len[simp]: + "LENGTH(pg_index_len) = pg_index_bits" + by (simp add: len_of_pg_index_len type_definition.card[OF type_definition_pg_index_len]) + +end + +context begin interpretation Arch . + +section \Haskell state\ + +text \One invariant we need on s0 is that there exists + an associated Haskell state satisfying the invariants. + This does not yet exist.\ + +subsection \Defining the State\ + +definition empty_cte :: "nat \ bool list \ (capability \ mdbnode) option" where + "empty_cte bits \ \x. if length x = bits then Some (NullCap, MDB 0 0 False False) else None" + +abbreviation (input) Null_mdb :: "mdbnode" where + "Null_mdb \ MDB 0 0 False False" + + +text \Low's CSpace\ + +definition Low_capsH :: "cnode_index \ (capability \ mdbnode) option" where + "Low_capsH \ + (empty_cte 10) + ((the_nat_to_bl_10 1) + \ (ThreadCap Low_tcb_ptr, Null_mdb), + (the_nat_to_bl_10 2) + \ (CNodeCap Low_cnode_ptr 10 2 10, MDB 0 Low_tcb_ptr False False), + (the_nat_to_bl_10 3) + \ (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid, 0))), + MDB 0 (Low_tcb_ptr + 0x20) False False), + (the_nat_to_bl_10 4) + \ (ArchObjectCap (ASIDPoolCap Low_pool_ptr (ucast Low_asid)), Null_mdb), + (the_nat_to_bl_10 5) + \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite max_page_size + False (Some (ucast Low_asid, 0))), + MDB 0 (Silc_cnode_ptr + 0xA0) False False), + (the_nat_to_bl_10 6) + \ (ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (ucast Low_asid, 0))), Null_mdb), + (the_nat_to_bl_10 318) + \ (NotificationCap ntfn_ptr 0 True False, MDB (Silc_cnode_ptr + 318 * 0x20) 0 False False))" + +definition Low_cte' :: "10 word \ cte option" where + "Low_cte' \ (map_option (\(cap, mdb). CTE cap mdb)) \ Low_capsH \ to_bl" + +definition Low_cte :: "obj_ref \ obj_ref \ kernel_object option" where + "Low_cte \ \base offs. + if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then map_option (\cte. KOCTE cte) (Low_cte' (ucast (offs - base >> 5))) + else None" + + +text \High's Cspace\ + +definition High_capsH :: "cnode_index \ (capability \ mdbnode) option" where + "High_capsH \ + (empty_cte 10) + ((the_nat_to_bl_10 1) + \ (ThreadCap High_tcb_ptr, Null_mdb), + (the_nat_to_bl_10 2) + \ (CNodeCap High_cnode_ptr 10 2 10, MDB 0 High_tcb_ptr False False), + (the_nat_to_bl_10 3) + \ (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0))), + MDB 0 (High_tcb_ptr + 0x20) False False), + (the_nat_to_bl_10 4) + \ (ArchObjectCap (ASIDPoolCap High_pool_ptr (ucast High_asid)), Null_mdb), + (the_nat_to_bl_10 5) + \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size + False (Some (ucast High_asid, 0))), + MDB (Silc_cnode_ptr + 0xA0) 0 False False), + (the_nat_to_bl_10 6) + \ (ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (ucast High_asid, 0))), + Null_mdb), + (the_nat_to_bl_10 318) + \ (NotificationCap ntfn_ptr 0 False True, MDB 0 (Silc_cnode_ptr + 318 * 0x20) False False))" + +definition High_cte' :: "10 word \ cte option" where + "High_cte' \ (map_option (\(cap, mdb). CTE cap mdb)) \ High_capsH \ to_bl" + +definition High_cte :: "obj_ref \ obj_ref \ kernel_object option" where + "High_cte \ \base offs. + if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then map_option (\cte. KOCTE cte) (High_cte' (ucast (offs - base >> 5))) + else None" + + +text \We need a copy of boundary crossing caps owned by SilcLabel.\ + +definition Silc_capsH :: "cnode_index \ (capability \ mdbnode) option" where + "Silc_capsH \ + (empty_cte 10) + ((the_nat_to_bl_10 2) + \ (CNodeCap Silc_cnode_ptr 10 2 10, Null_mdb), + (the_nat_to_bl_10 5) + \ (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size + False (Some (ucast Silc_asid, 0))), + MDB (Low_cnode_ptr + 0xA0) (High_cnode_ptr + 0xA0) False False), + (the_nat_to_bl_10 318) + \ (NotificationCap ntfn_ptr 0 True False, + MDB (High_cnode_ptr + 318 * 0x20) (Low_cnode_ptr + 318 * 0x20) False False))" + +definition Silc_cte' :: "10 word \ cte option" where + "Silc_cte' \ (map_option (\(cap, mdb). CTE cap mdb)) \ Silc_capsH \ to_bl" + +definition Silc_cte :: "obj_ref \ obj_ref \ kernel_object option" where + "Silc_cte \ \base offs. + if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then map_option (\cte. KOCTE cte) (Silc_cte' (ucast (offs - base >> 5))) + else None" + + +text \Notification between Low and High\ + +definition ntfnH :: notification where + "ntfnH \ NTFN (ntfn.WaitingNtfn [High_tcb_ptr]) None" + + +text \Global page table\ + +abbreviation (input) pt_lift where + "pt_lift pt_t pt \ \base offs. + if is_aligned offs 3 \ base \ offs \ offs \ base + 2 ^ (pt_bits pt_t) - 1 + then Some (KOArch (KOPTE (pt (ucast (offs - base >> 3))))) + else None" + +definition global_ptH :: "obj_ref \ obj_ref \ kernel_object option" where + "global_ptH \ pt_lift VSRootPT_T (\_. InvalidPTE)" + +text \Low's page tables\ + +definition Low_pt'H :: "pt_index \ pte" where + "Low_pt'H \ + (\_. InvalidPTE) + (0 := PagePTE shared_page_ptr_phys False False True False VMReadWrite)" + +definition Low_ptH :: "obj_ref \ obj_ref \ kernel_object option" where + "Low_ptH \ pt_lift NormalPT_T Low_pt'H" + +definition Low_pd'H :: "vs_index \ pte" where + "Low_pd'H \ + (\_. InvalidPTE) + (0 := PageTablePTE (addrFromPPtr Low_pt_ptr >> pageBits))" + +definition Low_pdH :: "obj_ref \ obj_ref \ kernel_object option" where + "Low_pdH \ pt_lift VSRootPT_T Low_pd'H" + + +text \High's page tables\ + +definition High_pt'H :: "pt_index \ pte" where + "High_pt'H \ + (\_. InvalidPTE) + (0 := PagePTE shared_page_ptr_phys False False True False VMReadOnly)" + +definition High_ptH :: "obj_ref \ obj_ref \ kernel_object option" where + "High_ptH \ pt_lift NormalPT_T High_pt'H" + +definition High_pd'H :: "vs_index \ pte" where + "High_pd'H \ + (\_. InvalidPTE) + (0 := PageTablePTE (addrFromPPtr High_pt_ptr >> pageBits))" + +definition High_pdH :: "obj_ref \ obj_ref \ kernel_object option" where + "High_pdH \ pt_lift VSRootPT_T High_pd'H" + + +text \Low's tcb\ + +definition Low_tcbH :: tcb where + "Low_tcbH \ Thread + \ \tcbCTable =\ (CTE (CNodeCap Low_cnode_ptr 10 2 10) + (MDB (Low_cnode_ptr + 0x40) 0 False False)) + \ \tcbVTable =\ (CTE (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid, 0)))) + (MDB (Low_cnode_ptr + 0x60) 0 False False)) + \ \tcbReply =\ (CTE (ReplyCap Low_tcb_ptr True True) (MDB 0 0 True True)) + \ \tcbCaller =\ (CTE NullCap Null_mdb) + \ \tcbIPCBufferFrame =\ (CTE NullCap Null_mdb) + \ \tcbDomain =\ Low_domain + \ \tcbState =\ Running + \ \tcbMCPriority =\ Low_mcp + \ \tcbPriority =\ Low_prio + \ \tcbQueued =\ False + \ \tcbFault =\ None + \ \tcbTimeSlice =\ Low_time_slice + \ \tcbFaultHandler =\ 0 + \ \tcbIPCBuffer =\ 0 + \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None + \ \tcbFlags =\ 0 + \ \tcbContext =\ (ArchThread empty_context None)" + + +text \High's tcb\ + +definition High_tcbH :: tcb where + "High_tcbH \ Thread + \ \tcbCTable =\ (CTE (CNodeCap High_cnode_ptr 10 2 10) + (MDB (High_cnode_ptr + 0x40) 0 False False)) + \ \tcbVTable =\ (CTE (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0)))) + (MDB (High_cnode_ptr + 0x60) 0 False False)) + \ \tcbReply =\ (CTE (ReplyCap High_tcb_ptr True True) (MDB 0 0 True True)) + \ \tcbCaller =\ (CTE NullCap Null_mdb) + \ \tcbIPCBufferFrame =\ (CTE NullCap Null_mdb) + \ \tcbDomain =\ High_domain + \ \tcbState =\ (BlockedOnNotification ntfn_ptr) + \ \tcbMCPriority =\ High_mcp + \ \tcbPriority =\ High_prio + \ \tcbQueued =\ False + \ \tcbFault =\ None + \ \tcbTimeSlice =\ High_time_slice + \ \tcbFaultHandler =\ 0 + \ \tcbIPCBuffer =\ 0 + \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None + \ \tcbFlags =\ 0 + \ \tcbContext =\ (ArchThread empty_context None)" + +text \idle's tcb\ + +definition idle_tcbH :: tcb where + "idle_tcbH \ Thread + \ \tcbCTable =\ (CTE NullCap Null_mdb) + \ \tcbVTable =\ (CTE NullCap Null_mdb) + \ \tcbReply =\ (CTE NullCap Null_mdb) + \ \tcbCaller =\ (CTE NullCap Null_mdb) + \ \tcbIPCBufferFrame =\ (CTE NullCap Null_mdb) + \ \tcbDomain =\ default_domain + \ \tcbState =\ IdleThreadState + \ \tcbMCPriority =\ default_priority + \ \tcbPriority =\ default_priority + \ \tcbQueued =\ False + \ \tcbFault =\ None + \ \tcbTimeSlice =\ timeSlice + \ \tcbFaultHandler =\ 0 + \ \tcbIPCBuffer =\ 0 + \ \tcbBoundNotification =\ None + \ \tcbSchedPrev =\ None + \ \tcbSchedNext =\ None + \ \tcbFlags =\ 0 + \ \tcbContext =\ (ArchThread empty_context None)" + + +text \Low's asid pool\ + +abbreviation Low_poolH' :: "asid \ asidpool_entry" where + "Low_poolH' \ \idx. if idx = ucast (asid_low_bits_of Low_asid) then Some (ASIDPoolVSpace None Low_pd_ptr) else None" + +definition Low_poolH :: arch_kernel_object where + "Low_poolH \ KOASIDPool (ASIDPool Low_poolH')" + + +text \High's asid pool\ + +abbreviation High_poolH' :: "asid \ asidpool_entry" where + "High_poolH' \ \idx. if idx = ucast (asid_low_bits_of High_asid) then Some (ASIDPoolVSpace None High_pd_ptr) else None" + +definition High_poolH :: arch_kernel_object where + "High_poolH \ KOASIDPool (ASIDPool High_poolH')" + + +text \Shared page\ + +definition shared_pageH :: "obj_ref \ obj_ref \ kernel_object option" where + "shared_pageH \ \base. + (\offs. if is_aligned offs 12 \ base \ offs \ offs \ base + mask (pageBitsForSize max_page_size) + then Some KOUserData else None)" + + +text \Initial ksPSpace\ + +definition irq_cte :: cte where + "irq_cte \ CTE NullCap Null_mdb" + +definition option_update_range :: "('a \ 'b option) \ ('a \ 'b option) \ ('a \ 'b option)" where + "option_update_range f g \ \x. case f x of None \ g x | Some y \ Some y" + +definition kh0H :: "(obj_ref \ kernel_object)" where + "kh0H \ (option_update_range (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x + then Some (KOCTE (CTE NullCap Null_mdb)) else None) \ + option_update_range (Low_cte Low_cnode_ptr) \ + option_update_range (High_cte High_cnode_ptr) \ + option_update_range (Silc_cte Silc_cnode_ptr) \ + option_update_range [ntfn_ptr \ KONotification ntfnH] \ + option_update_range [irq_cnode_ptr \ KOCTE irq_cte] \ + option_update_range (Low_pdH Low_pd_ptr) \ + option_update_range (High_pdH High_pd_ptr) \ + option_update_range (Low_ptH Low_pt_ptr) \ + option_update_range (High_ptH High_pt_ptr) \ + option_update_range [Low_pool_ptr \ KOArch Low_poolH] \ + option_update_range [High_pool_ptr \ KOArch High_poolH] \ + option_update_range [Low_tcb_ptr \ KOTCB Low_tcbH] \ + option_update_range [High_tcb_ptr \ KOTCB High_tcbH] \ + option_update_range [idle_tcb_ptr \ KOTCB idle_tcbH] \ + option_update_range (shared_pageH shared_page_ptr_virt) \ + option_update_range (global_ptH arm_global_pt_ptr) + ) Map.empty" + +lemma s0_ptrs_aligned: + "is_aligned arm_global_pt_ptr (pt_bits VSRootPT_T)" + "is_aligned High_pd_ptr (pt_bits VSRootPT_T)" + "is_aligned Low_pd_ptr (pt_bits VSRootPT_T)" + "is_aligned arm_global_pt_ptr 13" + "is_aligned High_pd_ptr 13" + "is_aligned Low_pd_ptr 13" + "is_aligned High_pt_ptr 12" + "is_aligned Low_pt_ptr 12" + "is_aligned Silc_cnode_ptr 15" + "is_aligned High_cnode_ptr 15" + "is_aligned Low_cnode_ptr 15" + "is_aligned High_tcb_ptr 11" + "is_aligned Low_tcb_ptr 11" + "is_aligned idle_tcb_ptr 11" + "is_aligned ntfn_ptr 5" + "is_aligned shared_page_ptr_virt 30" + "is_aligned irq_cnode_ptr 10" + "is_aligned Low_pool_ptr 12" + "is_aligned High_pool_ptr 12" + by (simp add: is_aligned_def s0_ptr_defs bit_simps)+ + + +text \Page offset lemmas\ + +declare pg_index_bits_def2[bit_simps] + +lemma page_offs_min': + "is_aligned ptr 30 \ (ptr :: obj_ref) \ ptr + (ucast (x :: pg_index) << 12)" + unfolding bit_simps + apply (erule is_aligned_no_wrap') + apply (auto split: if_splits) + apply (rule ucast_less_shiftl_helper') + apply (auto simp: bit_simps)[2] + done + +lemma page_offs_min: + "shared_page_ptr_virt \ shared_page_ptr_virt + (ucast (x:: pg_index) << 12)" + by (simp_all add: page_offs_min' s0_ptrs_aligned) + +lemma pageBitsForSize_max_page_size[bit_simps]: + "pageBitsForSize max_page_size = (if config_ARM_PA_SIZE_BITS_40 then 21 else 30)" + by (auto simp: max_page_size_def bit_simps) + +lemma page_offs_max': + "is_aligned ptr 30 \ (ptr :: obj_ref) + (ucast (x :: pg_index) << 12) \ ptr + mask (pageBitsForSize max_page_size)" + apply (rule word_plus_mono_right) + apply (simp add: shiftl_t2n mult.commute) + apply (rule div_to_mult_word_lt) + apply (rule plus_one_helper) + apply (cut_tac ucast_less[where x=x]) + apply (auto simp add: bit_simps mask_def split: if_splits)[2] + apply (drule_tac y="pageBitsForSize max_page_size" in is_aligned_weaken) + apply (simp add: bit_simps) + apply (drule is_aligned_no_overflow) + apply (simp add: mask_2pm1 p_assoc_help) + done + +lemma page_offs_max: + "shared_page_ptr_virt + (ucast (x :: pg_index) << 12) \ shared_page_ptr_virt + mask (pageBitsForSize max_page_size)" + by (simp_all add: page_offs_max' s0_ptrs_aligned) + + +definition page_offs_range where + "page_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + mask (pageBitsForSize max_page_size)} + \ {x. is_aligned x 12}" + +lemma page_offs_in_range': + "is_aligned ptr 30 \ ptr + (ucast (x :: pg_index) << 12) \ page_offs_range ptr" + apply (clarsimp simp: page_offs_min' page_offs_max' page_offs_range_def add.commute) + apply (rule is_aligned_add[OF _ is_aligned_shift]) + apply (erule is_aligned_weaken) + apply simp + done + +lemma page_offs_in_range: + "shared_page_ptr_virt + (ucast (x :: pg_index) << 12) \ page_offs_range shared_page_ptr_virt" + by (simp_all add: page_offs_in_range' s0_ptrs_aligned) + +lemma page_offs_range_correct': + "\ x \ page_offs_range ptr; is_aligned ptr 30 \ + \ \y. x = ptr + (ucast (y :: pg_index) << 12)" + apply (clarsimp simp: page_offs_range_def s0_ptr_defs bit_simps) + apply (rule_tac x="ucast ((x - ptr) >> 12)" in exI) + apply (clarsimp simp: ucast_ucast_mask) + apply (subst aligned_shiftr_mask_shiftl) + apply (rule aligned_sub_aligned) + apply assumption + apply (erule is_aligned_weaken) + apply simp + apply simp + apply (simp add: bit_simps split: if_splits) + apply (drule is_aligned_weaken[where y=21], solves simp) + apply (rule_tac n=21 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + mask 21" and n=21 in neg_mask_mono_le) + apply (simp add: add_ac) + apply (drule_tac n=21 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + apply (rule_tac n=30 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + mask 30" and n=30 in neg_mask_mono_le) + apply (simp add: add_ac) + apply (drule_tac n=30 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + done + +lemma page_offs_range_correct: + "x \ page_offs_range shared_page_ptr_virt + \ \y. x = shared_page_ptr_virt + (ucast (y :: pg_index) << 12)" + by (simp_all add: page_offs_range_correct' s0_ptrs_aligned) + + +text \Page table offset lemmas\ + +lemma pt_offs_min': + "is_aligned ptr 12 \ (ptr :: obj_ref) \ ptr + (ucast (x :: pt_index) << 3)" + unfolding bit_simps + apply (erule is_aligned_no_wrap') + apply (rule ucast_less_shiftl_helper') + apply (auto simp: bit_simps) + done + +lemma vs_offs_min': + "is_aligned ptr 13 \ (ptr :: obj_ref) \ ptr + (ucast (x :: vs_index) << 3)" + unfolding bit_simps + apply (erule is_aligned_no_wrap') + apply (auto split: if_splits) + apply (rule ucast_less_shiftl_helper') + apply (auto simp: bit_simps)[2] + done + +lemma pt_offs_min: + "Low_pd_ptr \ Low_pd_ptr + (ucast (x :: vs_index) << 3)" + "High_pd_ptr \ High_pd_ptr + (ucast (x :: vs_index) << 3)" + "Low_pt_ptr \ Low_pt_ptr + (ucast (y :: pt_index) << 3)" + "High_pt_ptr \ High_pt_ptr + (ucast (y :: pt_index) << 3)" + "arm_global_pt_ptr \ arm_global_pt_ptr + (ucast (x :: vs_index) << 3)" + by (auto intro: pt_offs_min' vs_offs_min' s0_ptrs_aligned) + +lemma pt_offs_max': + assumes "is_aligned ptr 12" + shows "(ptr :: obj_ref) + (ucast (x :: pt_index) << 3) \ ptr + 0xFFF" + apply (rule word_plus_mono_right) + apply (simp add: shiftl_t2n mult.commute) + apply (rule div_to_mult_word_lt) + apply (simp add: bit_simps mask_def) + apply (rule plus_one_helper) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply simp + apply (fastforce elim: dual_order.strict_trans[rotated]) + apply (insert is_aligned_no_overflow[OF assms]) + apply (auto simp add: add.commute bit_simps mask_def split: if_splits) + done + +lemma vs_offs_max': + assumes "is_aligned ptr (pt_bits VSRootPT_T)" + shows "(ptr :: obj_ref) + (ucast (x :: vs_index) << 3) \ ptr + mask (pt_bits VSRootPT_T)" + apply (rule word_plus_mono_right) + apply (simp add: shiftl_t2n mult.commute) + apply (rule div_to_mult_word_lt) + apply (auto simp add: bit_simps mask_def)[1] + apply (rule plus_one_helper) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply (simp add: bit_simps split: if_splits) + apply (simp add: bit_simps) + apply (rule plus_one_helper) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply (simp add: bit_simps split: if_splits) + apply (simp add: bit_simps) + apply (insert is_aligned_no_overflow[OF assms]) + apply (auto simp add: add.commute bit_simps mask_def split: if_splits) + done + +lemma pt_offs_max: + "Low_pd_ptr + (ucast (x :: vs_index) << 3) \ Low_pd_ptr + mask (pt_bits VSRootPT_T)" + "High_pd_ptr + (ucast (x :: vs_index) << 3) \ High_pd_ptr + mask (pt_bits VSRootPT_T)" + "Low_pt_ptr + (ucast (y :: pt_index) << 3) \ Low_pt_ptr + 0xFFF" + "High_pt_ptr + (ucast (y :: pt_index) << 3) \ High_pt_ptr + 0xFFF" + "arm_global_pt_ptr + (ucast (x :: vs_index) << 3) \ arm_global_pt_ptr + mask (pt_bits VSRootPT_T)" + by (rule pt_offs_max' vs_offs_max', rule s0_ptrs_aligned)+ + +definition pt_offs_range where + "pt_offs_range (pt_t :: pt_type) (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ (pt_bits pt_t) - 1} + \ {x. is_aligned x 3}" + +lemma pt_offs_in_range': + "is_aligned ptr 12 + \ ptr + (ucast (x :: pt_index) << 3) \ pt_offs_range NormalPT_T ptr" + apply (clarsimp simp: pt_offs_min' pt_offs_range_def add.commute) + apply (rule conjI) + apply (rule order.trans) + apply (erule pt_offs_max') + apply (simp add: bit_simps add_ac) + apply (rule is_aligned_add[OF _ is_aligned_shift]) + apply (erule is_aligned_weaken) + apply (simp add: bit_simps) + done + +lemma vs_offs_in_range': + "is_aligned ptr 13 + \ ptr + (ucast (x :: vs_index) << 3) \ pt_offs_range VSRootPT_T ptr" + apply (clarsimp simp: pt_offs_range_def vs_offs_min') + apply (rule conjI) + apply (rule order.trans) + apply (rule vs_offs_max') + apply (erule is_aligned_weaken) + apply (simp add: bit_simps) + apply (simp add: bit_simps add_ac mask_def) + apply (rule is_aligned_add[OF _ is_aligned_shift]) + apply (erule is_aligned_weaken) + apply (simp add: bit_simps) + done + +lemma pt_offs_in_range: + "Low_pd_ptr + (ucast (x :: vs_index) << 3) \ pt_offs_range VSRootPT_T Low_pd_ptr" + "High_pd_ptr + (ucast (x :: vs_index) << 3) \ pt_offs_range VSRootPT_T High_pd_ptr" + "Low_pt_ptr + (ucast (y :: pt_index) << 3) \ pt_offs_range NormalPT_T Low_pt_ptr" + "High_pt_ptr + (ucast (y :: pt_index) << 3) \ pt_offs_range NormalPT_T High_pt_ptr" + "arm_global_pt_ptr + (ucast (x :: vs_index) << 3) \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + by (simp_all add: pt_offs_in_range' vs_offs_in_range' s0_ptrs_aligned) + +lemma is_aligned_pt_bitsD: + "is_aligned ptr (pt_bits pt_t) \ is_aligned ptr 12" + by (erule is_aligned_weaken, simp add: bit_simps) + +lemma pt_offs_range_correct': + "\ x \ pt_offs_range NormalPT_T ptr; is_aligned ptr 12 \ + \ \y. x = ptr + (ucast (y :: pt_index) << 3)" + apply (clarsimp simp: pt_offs_range_def s0_ptr_defs bit_simps) + apply (rule_tac x="ucast ((x - ptr) >> 3)" in exI) + apply (clarsimp simp: ucast_ucast_mask) + apply (subst aligned_shiftr_mask_shiftl) + apply (rule aligned_sub_aligned) + apply assumption + apply (erule is_aligned_weaken) + apply simp + apply simp + apply simp + apply (rule_tac n=12 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + 0xFFF" and n=12 in neg_mask_mono_le) + apply (simp add: add_ac) + apply (drule_tac n=12 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + done + +lemma vs_offs_range_correct': + "\ x \ pt_offs_range VSRootPT_T ptr; is_aligned ptr 13 \ + \ \y. x = ptr + (ucast (y :: vs_index) << 3)" + apply (clarsimp simp: pt_offs_range_def s0_ptr_defs) + apply (rule_tac x="ucast ((x - ptr) >> 3)" in exI) + apply (clarsimp simp: ucast_ucast_mask) + apply (subst aligned_shiftr_mask_shiftl) + apply (rule aligned_sub_aligned) + apply assumption + apply (erule is_aligned_weaken) + apply simp + apply simp + apply (simp add: bit_simps split: if_splits) + apply (rule_tac n=13 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + 0x1FFF" and n=13 in neg_mask_mono_le) + apply (simp add: add_ac) + apply (drule_tac n=13 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + apply (drule is_aligned_weaken[where y=12], solves simp) + apply (rule_tac n=12 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + 0xFFF" and n=12 in neg_mask_mono_le) + apply (simp add: add_ac) + apply (drule_tac n=12 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + done + +lemma pt_offs_range_correct: + "x \ pt_offs_range VSRootPT_T Low_pd_ptr \ \y. x = Low_pd_ptr + (ucast (y :: vs_index) << 3)" + "x \ pt_offs_range VSRootPT_T High_pd_ptr \ \y. x = High_pd_ptr + (ucast (y :: vs_index) << 3)" + "x \ pt_offs_range NormalPT_T Low_pt_ptr \ \y. x = Low_pt_ptr + (ucast (y :: pt_index) << 3)" + "x \ pt_offs_range NormalPT_T High_pt_ptr \ \y. x = High_pt_ptr + (ucast (y :: pt_index) << 3)" + "x \ pt_offs_range VSRootPT_T arm_global_pt_ptr \ \y. x = arm_global_pt_ptr + (ucast (y :: vs_index) << 3)" + by (simp_all add: pt_offs_range_correct' vs_offs_range_correct' s0_ptrs_aligned) + + +text \CNode offset lemmas\ + +lemma bl_to_bin_le2p_aux: + "bl_to_bin_aux bs w \ (w + 1) * (2 ^ length bs) - 1" + apply (induct bs arbitrary: w) + apply clarsimp + apply (clarsimp split del: split_of_bool) + apply (drule meta_spec, erule xtr8 [rotated], simp)+ + done + +lemma bl_to_bin_le2p: + "bl_to_bin bs \ (2 ^ length bs) - 1" + apply (unfold bl_to_bin_def) + apply (rule xtr3) + prefer 2 + apply (rule bl_to_bin_le2p_aux) + apply simp + done + +lemma of_bl_length_le: + "\ length x = k; k < len_of TYPE('a) \ \ (of_bl x :: 'a :: len word) \ 2 ^ k - 1" + apply (unfold of_bl_def word_less_alt word_numeral_alt) + apply safe + apply (simp add: word_le_def take_bit_int_def uint_2p_alt uint_word_arith_bintrs(2)) + apply (subst mod_pos_pos_trivial) + apply simp + using not_le apply fastforce + apply (subst uint_word_of_int) + apply (subst mod_pos_pos_trivial) + apply (rule bl_to_bin_ge0) + apply (rule order_less_trans) + apply (rule bl_to_bin_lt2p) + apply simp + apply (rule bl_to_bin_le2p) + done + +lemma cnode_offs_min': + "\ is_aligned ptr 15; length x = 10 \ \ (ptr :: obj_ref) \ ptr + of_bl x * 0x20" + apply (erule is_aligned_no_wrap') + apply (rule div_lt_mult) + apply (drule of_bl_length_less[where 'a=64]) + apply simp + apply simp + apply simp + done + +lemma cnode_offs_min: + "length x = 10 \ Low_cnode_ptr \ Low_cnode_ptr + of_bl x * 0x20" + "length x = 10 \ High_cnode_ptr \ High_cnode_ptr + of_bl x * 0x20" + "length x = 10 \ Silc_cnode_ptr \ Silc_cnode_ptr + of_bl x * 0x20" + by (simp_all add: cnode_offs_min' s0_ptrs_aligned) + +lemma cnode_offs_max': + "\ is_aligned ptr 15; length x = 10 \ \ (ptr :: obj_ref) + of_bl x * 0x20 \ ptr + 0x7fff" + apply (rule word_plus_mono_right) + apply (rule div_to_mult_word_lt) + apply simp + apply (rule plus_one_helper) + apply simp + apply (drule of_bl_length_less[where 'a=64]) + apply simp + apply simp + apply (drule is_aligned_no_overflow) + apply (simp add: add.commute) + done + +lemma cnode_offs_max: + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ Low_cnode_ptr + 0x7fff" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ High_cnode_ptr + 0x7fff" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ Silc_cnode_ptr + 0x7fff" + by (simp_all add: cnode_offs_max' s0_ptrs_aligned) + +definition cnode_offs_range where + "cnode_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 2 ^ 15 - 1} + \ {x. is_aligned x 5}" + +lemma cnode_offs_in_range': + "\ is_aligned ptr 15; length x = 10 \ \ ptr + of_bl x * 0x20 \ cnode_offs_range ptr" + apply (simp add: cnode_offs_min' cnode_offs_max' cnode_offs_range_def add.commute) + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply simp + apply (rule_tac is_aligned_mult_triv2[where x="of_bl x" and n=5, simplified]) + done + +lemma cnode_offs_in_range: + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ cnode_offs_range Low_cnode_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ cnode_offs_range High_cnode_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ cnode_offs_range Silc_cnode_ptr" + by (simp_all add: cnode_offs_in_range' s0_ptrs_aligned) + +lemma le_mask_eq: + "x \ 2 ^ n - 1 \ x AND mask n = (x :: 'a :: len word)" + apply (unfold word_less_alt word_numeral_alt) + apply (simp add: word_of_int_power_hom mask_eq_exp_minus_1[symmetric]) + apply (erule word_le_mask_eq) + done + +lemma word_div_mult': + fixes c :: obj_ref + shows "\ 0 < c; a \ b * c \ \ a div c \ b" + apply (simp add: word_le_nat_alt unat_div) + apply (simp add: less_Suc_eq_le[symmetric]) + apply (subst td_gal_lt [symmetric]) + apply (simp add: word_less_nat_alt) + apply (erule order_less_le_trans) + apply (subst unat_word_ariths) + apply (rule_tac y="Suc (unat b * unat c)" in order_trans) + apply simp + apply (simp add: word_less_nat_alt) + done + +lemma cnode_offs_range_correct': + "\ x \ cnode_offs_range ptr; is_aligned ptr 15 \ + \ \y. length y = 10 \ (x = ptr + of_bl y * 0x20)" + apply (clarsimp simp: cnode_offs_range_def s0_ptr_defs) + apply (rule_tac x="to_bl (ucast ((x - ptr) div 0x20) :: 10 word)" in exI) + apply (clarsimp simp: to_bl_ucast of_bl_drop) + apply (subst le_mask_eq) + apply simp + apply (rule word_div_mult') + apply simp + apply simp + apply (rule word_diff_ls') + apply (drule_tac a=x and n=5 in aligned_le_sharp) + apply simp + apply (simp add: add.commute) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + apply simp + apply (clarsimp simp: neg_mask_is_div[where n=5, simplified, symmetric]) + apply (subst is_aligned_neg_mask_eq) + apply (rule aligned_sub_aligned) + apply assumption + apply (erule is_aligned_weaken) + apply simp + apply simp + apply simp + done + +lemma cnode_offs_range_correct: + "x \ cnode_offs_range Low_cnode_ptr \ \y. length y = 10 \ (x = Low_cnode_ptr + of_bl y * 0x20)" + "x \ cnode_offs_range High_cnode_ptr \ \y. length y = 10 \ (x = High_cnode_ptr + of_bl y * 0x20)" + "x \ cnode_offs_range Silc_cnode_ptr \ \y. length y = 10 \ (x = Silc_cnode_ptr + of_bl y * 0x20)" + by (simp_all add: cnode_offs_range_correct' s0_ptrs_aligned) + + +text \TCB offset lemmas\ + +lemma tcb_offs_min': + "is_aligned ptr 11 \ (ptr :: obj_ref) \ ptr + ucast (x :: 11 word)" + apply (erule is_aligned_no_wrap') + apply (cut_tac x=x and 'a=64 in ucast_less) + apply simp + apply simp + done + +lemma tcb_offs_min: + "Low_tcb_ptr \ Low_tcb_ptr + ucast (x :: 11 word)" + "High_tcb_ptr \ High_tcb_ptr + ucast (x :: 11 word)" + "idle_tcb_ptr \ idle_tcb_ptr + ucast (x :: 11 word)" + by (simp_all add: tcb_offs_min' s0_ptrs_aligned) + +lemma tcb_offs_max': + "is_aligned ptr 11 \ (ptr :: obj_ref) + ucast (x :: 11 word) \ ptr + 0x7FF" + apply (rule word_plus_mono_right) + apply (rule plus_one_helper) + apply (cut_tac ucast_less[where x=x and 'a=64]) + apply simp + apply (simp add: mask_def) + apply (drule is_aligned_no_overflow) + apply (simp add: add.commute) + done + +lemma tcb_offs_max: + "Low_tcb_ptr + ucast (x :: 11 word) \ Low_tcb_ptr + 0x7FF" + "High_tcb_ptr + ucast (x :: 11 word) \ High_tcb_ptr + 0x7FF" + "idle_tcb_ptr + ucast (x :: 11 word) \ idle_tcb_ptr + 0x7FF" + by (simp_all add: tcb_offs_max' s0_ptrs_aligned) + +definition tcb_offs_range where + "tcb_offs_range (ptr :: obj_ref) \ {x. ptr \ x \ x \ ptr + 0x7FF}" + +lemma tcb_offs_in_range': + "is_aligned ptr 11 \ ptr + ucast (x :: 11 word) \ tcb_offs_range ptr" + by (clarsimp simp: tcb_offs_min' tcb_offs_max' tcb_offs_range_def add.commute) + +lemma tcb_offs_in_range: + "Low_tcb_ptr + ucast (x :: 11 word) \ tcb_offs_range Low_tcb_ptr" + "High_tcb_ptr + ucast (x :: 11 word) \ tcb_offs_range High_tcb_ptr" + "idle_tcb_ptr + ucast (x :: 11 word) \ tcb_offs_range idle_tcb_ptr" + by (simp_all add: tcb_offs_in_range' s0_ptrs_aligned) + +lemma tcb_offs_range_correct': + "\ x \ tcb_offs_range ptr; is_aligned ptr 11 \ + \ \y. x = ptr + ucast (y :: 11 word)" + apply (clarsimp simp: tcb_offs_range_def s0_ptr_defs) + apply (rule_tac x="ucast (x - ptr)" in exI) + apply (clarsimp simp: ucast_ucast_mask) + apply (rule_tac n=11 in mask_eqI) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_def) + apply (simp add: mask_twice) + apply (subst diff_conv_add_uminus) + apply (subst add.commute[symmetric]) + apply (subst mask_add_aligned) + apply (simp add: is_aligned_minus) + apply simp + apply (subst diff_conv_add_uminus) + apply (subst add_mask_lower_bits) + apply (simp add: is_aligned_def) + apply clarsimp + apply (cut_tac x=x and y="ptr + 0x7FF" and n=11 in neg_mask_mono_le) + apply (simp add: mask_def) + apply (drule_tac n=11 in aligned_le_sharp) + apply (simp add: is_aligned_def) + apply (subst(asm) mask_out_add_aligned[symmetric]) + apply (erule is_aligned_weaken) + apply simp + apply (simp add: mask_def) + done + +lemma tcb_offs_range_correct: + "x \ tcb_offs_range Low_tcb_ptr \ \y. x = Low_tcb_ptr + ucast (y:: 11 word)" + "x \ tcb_offs_range High_tcb_ptr \ \y. x = High_tcb_ptr + ucast (y:: 11 word)" + "x \ tcb_offs_range idle_tcb_ptr \ \y. x = idle_tcb_ptr + ucast (y:: 11 word)" + by (simp_all add: tcb_offs_range_correct' s0_ptrs_aligned) + +lemma caps_dom_length_10: + "Silc_caps x = Some y \ length x = 10" + "High_caps x = Some y \ length x = 10" + "Low_caps x = Some y \ length x = 10" + by (auto simp: Silc_caps_def High_caps_def Low_caps_def the_nat_to_bl_def nat_to_bl_def + split: if_splits) + +lemma dom_caps: + "dom Silc_caps = {x. length x = 10}" + "dom High_caps = {x. length x = 10}" + "dom Low_caps = {x. length x = 10}" + by (auto simp: Silc_caps_def High_caps_def Low_caps_def the_nat_to_bl_def nat_to_bl_def dom_def + split: if_split_asm) + +lemmas kh0H_obj_def = + Low_cte_def High_cte_def Silc_cte_def ntfnH_def irq_cte_def Low_pdH_def + High_pdH_def Low_ptH_def High_ptH_def Low_tcbH_def High_tcbH_def idle_tcbH_def + global_ptH_def shared_pageH_def High_poolH_def Low_poolH_def + +lemmas kh0H_all_obj_def = + Low_pd'H_def High_pd'H_def Low_pt'H_def High_pt'H_def + Low_cte'_def Low_capsH_def High_cte'_def High_capsH_def + Silc_cte'_def Silc_capsH_def empty_cte_def kh0H_obj_def + +lemma not_in_range_None: + "x \ cnode_offs_range Low_cnode_ptr \ Low_cte Low_cnode_ptr x = None" + "x \ cnode_offs_range High_cnode_ptr \ High_cte High_cnode_ptr x = None" + "x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte Silc_cnode_ptr x = None" + "x \ pt_offs_range VSRootPT_T Low_pd_ptr \ Low_pdH Low_pd_ptr x = None" + "x \ pt_offs_range VSRootPT_T High_pd_ptr \ High_pdH High_pd_ptr x = None" + "x \ pt_offs_range VSRootPT_T arm_global_pt_ptr \ global_ptH arm_global_pt_ptr x = None" + "x \ pt_offs_range NormalPT_T Low_pt_ptr \ Low_ptH Low_pt_ptr x = None" + "x \ pt_offs_range NormalPT_T High_pt_ptr \ High_ptH High_pt_ptr x = None" + "x \ page_offs_range shared_page_ptr_virt \ shared_pageH shared_page_ptr_virt x = None" + by (auto simp: page_offs_range_def cnode_offs_range_def pt_offs_range_def s0_ptr_defs kh0H_obj_def) + +lemma in_range_not_None: + "x \ cnode_offs_range Low_cnode_ptr \ Low_cte Low_cnode_ptr x \ None" + "x \ cnode_offs_range High_cnode_ptr \ High_cte High_cnode_ptr x \ None" + "x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte Silc_cnode_ptr x \ None" + "x \ pt_offs_range VSRootPT_T Low_pd_ptr \ Low_pdH Low_pd_ptr x \ None" + "x \ pt_offs_range VSRootPT_T High_pd_ptr \ High_pdH High_pd_ptr x \ None" + "x \ pt_offs_range VSRootPT_T arm_global_pt_ptr \ global_ptH arm_global_pt_ptr x \ None" + "x \ pt_offs_range NormalPT_T Low_pt_ptr \ Low_ptH Low_pt_ptr x \ None" + "x \ pt_offs_range NormalPT_T High_pt_ptr \ High_ptH High_pt_ptr x \ None" + "x \ page_offs_range shared_page_ptr_virt \ shared_pageH shared_page_ptr_virt x \ None" + by (auto simp: page_offs_range_def cnode_offs_range_def pt_offs_range_def s0_ptr_defs kh0H_all_obj_def) + +lemma kh0H_dom_distinct: + "idle_tcb_ptr \ cnode_offs_range Silc_cnode_ptr" + "High_tcb_ptr \ cnode_offs_range Silc_cnode_ptr" + "Low_tcb_ptr \ cnode_offs_range Silc_cnode_ptr" + "High_pool_ptr \ cnode_offs_range Silc_cnode_ptr" + "Low_pool_ptr \ cnode_offs_range Silc_cnode_ptr" + "irq_cnode_ptr \ cnode_offs_range Silc_cnode_ptr" + "ntfn_ptr \ cnode_offs_range Silc_cnode_ptr" + "idle_tcb_ptr \ cnode_offs_range Low_cnode_ptr" + "High_tcb_ptr \ cnode_offs_range Low_cnode_ptr" + "Low_tcb_ptr \ cnode_offs_range Low_cnode_ptr" + "High_pool_ptr \ cnode_offs_range Low_cnode_ptr" + "Low_pool_ptr \ cnode_offs_range Low_cnode_ptr" + "irq_cnode_ptr \ cnode_offs_range Low_cnode_ptr" + "ntfn_ptr \ cnode_offs_range Low_cnode_ptr" + "idle_tcb_ptr \ cnode_offs_range High_cnode_ptr" + "High_tcb_ptr \ cnode_offs_range High_cnode_ptr" + "Low_tcb_ptr \ cnode_offs_range High_cnode_ptr" + "High_pool_ptr \ cnode_offs_range High_cnode_ptr" + "Low_pool_ptr \ cnode_offs_range High_cnode_ptr" + "irq_cnode_ptr \ cnode_offs_range High_cnode_ptr" + "ntfn_ptr \ cnode_offs_range High_cnode_ptr" + "idle_tcb_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "High_tcb_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "Low_tcb_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "High_pool_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "Low_pool_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "irq_cnode_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "ntfn_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr" + "idle_tcb_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "High_tcb_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "Low_tcb_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "High_pool_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "Low_pool_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "irq_cnode_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "ntfn_ptr \ pt_offs_range VSRootPT_T High_pd_ptr" + "idle_tcb_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "High_tcb_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "Low_tcb_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "High_pool_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "Low_pool_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "irq_cnode_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "ntfn_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr" + "idle_tcb_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "High_tcb_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "Low_tcb_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "High_pool_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "Low_pool_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "irq_cnode_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "ntfn_ptr \ pt_offs_range NormalPT_T Low_pt_ptr" + "idle_tcb_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "High_tcb_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "Low_tcb_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "High_pool_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "Low_pool_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "irq_cnode_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "ntfn_ptr \ pt_offs_range NormalPT_T High_pt_ptr" + "idle_tcb_ptr \ tcb_offs_range Low_tcb_ptr" + "High_tcb_ptr \ tcb_offs_range Low_tcb_ptr" + "High_pool_ptr \ tcb_offs_range Low_tcb_ptr" + "Low_pool_ptr \ tcb_offs_range Low_tcb_ptr" + "irq_cnode_ptr \ tcb_offs_range Low_tcb_ptr" + "ntfn_ptr \ tcb_offs_range Low_tcb_ptr" + "idle_tcb_ptr \ tcb_offs_range High_tcb_ptr" + "Low_tcb_ptr \ tcb_offs_range High_tcb_ptr" + "High_pool_ptr \ tcb_offs_range High_tcb_ptr" + "Low_pool_ptr \ tcb_offs_range High_tcb_ptr" + "irq_cnode_ptr \ tcb_offs_range High_tcb_ptr" + "ntfn_ptr \ tcb_offs_range High_tcb_ptr" + "High_tcb_ptr \ tcb_offs_range idle_tcb_ptr" + "Low_tcb_ptr \ tcb_offs_range idle_tcb_ptr" + "High_pool_ptr \ tcb_offs_range idle_tcb_ptr" + "Low_pool_ptr \ tcb_offs_range idle_tcb_ptr" + "irq_cnode_ptr \ tcb_offs_range idle_tcb_ptr" + "ntfn_ptr \ tcb_offs_range idle_tcb_ptr" + "idle_tcb_ptr \ page_offs_range shared_page_ptr_virt" + "High_tcb_ptr \ page_offs_range shared_page_ptr_virt" + "Low_tcb_ptr \ page_offs_range shared_page_ptr_virt" + "High_pool_ptr \ page_offs_range shared_page_ptr_virt" + "Low_pool_ptr \ page_offs_range shared_page_ptr_virt" + "irq_cnode_ptr \ page_offs_range shared_page_ptr_virt" + "ntfn_ptr \ page_offs_range shared_page_ptr_virt" + "idle_tcb_ptr \ cnode_offs_range init_irq_node_ptr" + "High_tcb_ptr \ cnode_offs_range init_irq_node_ptr" + "Low_tcb_ptr \ cnode_offs_range init_irq_node_ptr" + "High_pool_ptr \ cnode_offs_range init_irq_node_ptr" + "Low_pool_ptr \ cnode_offs_range init_irq_node_ptr" + "irq_cnode_ptr \ cnode_offs_range init_irq_node_ptr" + "ntfn_ptr \ cnode_offs_range init_irq_node_ptr" + by (auto simp: tcb_offs_range_def pt_offs_range_def page_offs_range_def + cnode_offs_range_def kh0H_obj_def s0_ptr_defs bit_simps) + +lemma kh0H_dom_sets_distinct: + "irq_node_offs_range \ cnode_offs_range Silc_cnode_ptr = {}" + "irq_node_offs_range \ cnode_offs_range High_cnode_ptr = {}" + "irq_node_offs_range \ cnode_offs_range Low_cnode_ptr = {}" + "irq_node_offs_range \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "irq_node_offs_range \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "irq_node_offs_range \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "irq_node_offs_range \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "irq_node_offs_range \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "irq_node_offs_range \ tcb_offs_range High_tcb_ptr = {}" + "irq_node_offs_range \ tcb_offs_range Low_tcb_ptr = {}" + "irq_node_offs_range \ tcb_offs_range idle_tcb_ptr = {}" + "irq_node_offs_range \ page_offs_range shared_page_ptr_virt = {}" + "cnode_offs_range Silc_cnode_ptr \ cnode_offs_range High_cnode_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ cnode_offs_range Low_cnode_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ tcb_offs_range High_tcb_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "cnode_offs_range Silc_cnode_ptr \ page_offs_range shared_page_ptr_virt = {}" + "cnode_offs_range High_cnode_ptr \ cnode_offs_range Low_cnode_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "cnode_offs_range High_cnode_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "cnode_offs_range High_cnode_ptr \ tcb_offs_range High_tcb_ptr = {}" + "cnode_offs_range High_cnode_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "cnode_offs_range High_cnode_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "cnode_offs_range High_cnode_ptr \ page_offs_range shared_page_ptr_virt = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ tcb_offs_range High_tcb_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "cnode_offs_range Low_cnode_ptr \ page_offs_range shared_page_ptr_virt = {}" + "cnode_offs_range init_irq_node_ptr \ cnode_offs_range High_cnode_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ cnode_offs_range Low_cnode_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range VSRootPT_T arm_global_pt_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ tcb_offs_range High_tcb_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "cnode_offs_range init_irq_node_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ pt_offs_range VSRootPT_T High_pd_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range VSRootPT_T arm_global_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ pt_offs_range VSRootPT_T Low_pd_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range VSRootPT_T High_pd_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ pt_offs_range NormalPT_T High_pt_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range VSRootPT_T Low_pd_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ pt_offs_range NormalPT_T Low_pt_ptr = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range NormalPT_T High_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" + "pt_offs_range NormalPT_T Low_pt_ptr \ tcb_offs_range High_tcb_ptr = {}" + "pt_offs_range NormalPT_T Low_pt_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "pt_offs_range NormalPT_T Low_pt_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "pt_offs_range NormalPT_T Low_pt_ptr \ page_offs_range shared_page_ptr_virt = {}" + "tcb_offs_range High_tcb_ptr \ tcb_offs_range Low_tcb_ptr = {}" + "tcb_offs_range High_tcb_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "tcb_offs_range High_tcb_ptr \ page_offs_range shared_page_ptr_virt = {}" + "tcb_offs_range Low_tcb_ptr \ tcb_offs_range idle_tcb_ptr = {}" + "tcb_offs_range Low_tcb_ptr \ page_offs_range shared_page_ptr_virt = {}" + "page_offs_range shared_page_ptr_virt \ tcb_offs_range idle_tcb_ptr = {}" + by (rule disjointI, clarsimp simp: tcb_offs_range_def pt_offs_range_def page_offs_range_def + irq_node_offs_range_def cnode_offs_range_def s0_ptr_defs bit_simps + , drule (1) order_trans le_less_trans, fastforce split: if_splits)+ + +lemmas offs_in_range = + pt_offs_in_range page_offs_in_range tcb_offs_in_range cnode_offs_in_range irq_node_offs_in_range + +lemmas offs_range_correct = + pt_offs_range_correct page_offs_range_correct tcb_offs_range_correct + cnode_offs_range_correct irq_node_offs_range_correct + +lemma kh0H_dom_distinct': + fixes y :: pt_index + and v :: vs_index + and z :: "pg_index" + shows + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ idle_tcb_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ High_tcb_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ Low_tcb_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ High_pool_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ Low_pool_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ irq_cnode_ptr" + "length x = 10 \ Silc_cnode_ptr + of_bl x * 0x20 \ ntfn_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ idle_tcb_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ High_tcb_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ High_pool_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ Low_pool_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ Low_tcb_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ irq_cnode_ptr" + "length x = 10 \ Low_cnode_ptr + of_bl x * 0x20 \ ntfn_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ idle_tcb_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ High_tcb_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ Low_tcb_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ High_pool_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ Low_pool_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ irq_cnode_ptr" + "length x = 10 \ High_cnode_ptr + of_bl x * 0x20 \ ntfn_ptr" + "Low_pd_ptr + (ucast v << 3) \ idle_tcb_ptr" + "Low_pd_ptr + (ucast v << 3) \ High_tcb_ptr" + "Low_pd_ptr + (ucast v << 3) \ Low_tcb_ptr" + "Low_pd_ptr + (ucast v << 3) \ High_pool_ptr" + "Low_pd_ptr + (ucast v << 3) \ Low_pool_ptr" + "Low_pd_ptr + (ucast v << 3) \ irq_cnode_ptr" + "Low_pd_ptr + (ucast v << 3) \ ntfn_ptr" + "High_pd_ptr + (ucast v << 3) \ idle_tcb_ptr" + "High_pd_ptr + (ucast v << 3) \ High_tcb_ptr" + "High_pd_ptr + (ucast v << 3) \ Low_tcb_ptr" + "High_pd_ptr + (ucast v << 3) \ High_pool_ptr" + "High_pd_ptr + (ucast v << 3) \ Low_pool_ptr" + "High_pd_ptr + (ucast v << 3) \ irq_cnode_ptr" + "High_pd_ptr + (ucast v << 3) \ ntfn_ptr" + "Low_pt_ptr + (ucast y << 3) \ idle_tcb_ptr" + "Low_pt_ptr + (ucast y << 3) \ High_tcb_ptr" + "Low_pt_ptr + (ucast y << 3) \ Low_tcb_ptr" + "Low_pt_ptr + (ucast y << 3) \ High_pool_ptr" + "Low_pt_ptr + (ucast y << 3) \ Low_pool_ptr" + "Low_pt_ptr + (ucast y << 3) \ irq_cnode_ptr" + "Low_pt_ptr + (ucast y << 3) \ ntfn_ptr" + "High_pt_ptr + (ucast y << 3) \ idle_tcb_ptr" + "High_pt_ptr + (ucast y << 3) \ High_tcb_ptr" + "High_pt_ptr + (ucast y << 3) \ Low_tcb_ptr" + "High_pt_ptr + (ucast y << 3) \ High_pool_ptr" + "High_pt_ptr + (ucast y << 3) \ Low_pool_ptr" + "High_pt_ptr + (ucast y << 3) \ irq_cnode_ptr" + "High_pt_ptr + (ucast y << 3) \ ntfn_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ idle_tcb_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ High_tcb_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ Low_tcb_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ High_pool_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ Low_pool_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ irq_cnode_ptr" + "arm_global_pt_ptr + (ucast v << 3) \ ntfn_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ idle_tcb_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ High_tcb_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ Low_tcb_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ High_pool_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ Low_pool_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ irq_cnode_ptr" + "shared_page_ptr_virt + (ucast z << 12) \ ntfn_ptr" + apply (drule offs_in_range, fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=v in offs_in_range(1), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=v in offs_in_range(2), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac y=y in offs_in_range(3), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac y=y in offs_in_range(4), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=v in offs_in_range(5), fastforce simp: kh0H_dom_distinct)+ + apply (cut_tac x=z in offs_in_range(6), fastforce simp: kh0H_dom_distinct)+ + done + +lemma not_disjointI: + "\ x = y; x \ A; y \ B \ \ A \ B \ {}" + by fastforce + +lemma shared_pageH_KOUserData[simp]: + "shared_pageH shared_page_ptr_virt (shared_page_ptr_virt + (UCAST(pg_index_len \ 64) y << 12)) = Some KOUserData" + apply (clarsimp simp: shared_pageH_def page_offs_min page_offs_max add.commute) + apply (rule is_aligned_add) + apply (rule is_aligned_weaken, rule s0_ptrs_aligned, simp) + apply (clarsimp simp: is_aligned_mask) + done + +lemma kh0H_simps[simp]: + fixes y :: pt_index + and v :: vs_index + and z :: "pg_index" + shows + "kh0H (init_irq_node_ptr + (ucast (irq :: irq) << 5)) = Some (KOCTE (CTE NullCap Null_mdb))" + "kh0H ntfn_ptr = Some (KONotification ntfnH)" + "kh0H irq_cnode_ptr = Some (KOCTE irq_cte)" + "kh0H Low_pool_ptr = Some (KOArch Low_poolH)" + "kh0H High_pool_ptr = Some (KOArch High_poolH)" + "kh0H Low_tcb_ptr = Some (KOTCB Low_tcbH)" + "kh0H High_tcb_ptr = Some (KOTCB High_tcbH)" + "kh0H idle_tcb_ptr = Some (KOTCB idle_tcbH)" + "length x = 10 \ kh0H (Low_cnode_ptr + of_bl x * 0x20) = Low_cte Low_cnode_ptr (Low_cnode_ptr + of_bl x * 0x20)" + "length x = 10 \ kh0H (High_cnode_ptr + of_bl x * 0x20) = High_cte High_cnode_ptr (High_cnode_ptr + of_bl x * 0x20)" + "length x = 10 \ kh0H (Silc_cnode_ptr + of_bl x * 0x20) = Silc_cte Silc_cnode_ptr (Silc_cnode_ptr + of_bl x * 0x20)" + "kh0H (Low_pd_ptr + (ucast v << 3)) = Low_pdH Low_pd_ptr (Low_pd_ptr + (ucast v << 3))" + "kh0H (High_pd_ptr + (ucast v << 3)) = High_pdH High_pd_ptr (High_pd_ptr + (ucast v << 3))" + "kh0H (Low_pt_ptr + (ucast y << 3)) = Low_ptH Low_pt_ptr (Low_pt_ptr + (ucast y << 3))" + "kh0H (High_pt_ptr + (ucast y << 3)) = High_ptH High_pt_ptr (High_pt_ptr + (ucast y << 3))" + "kh0H (arm_global_pt_ptr + (ucast v << 3)) = global_ptH arm_global_pt_ptr (arm_global_pt_ptr + (ucast v << 3))" + "kh0H (shared_page_ptr_virt + (ucast z << 12)) = Some KOUserData" + supply option.case_cong[cong] + apply (fastforce simp: kh0H_def option_update_range_def) + by ((clarsimp simp: kh0H_def kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_None offs_in_range + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_None + | rule conjI | clarsimp split: option.splits)+, + drule not_disjointI, + (erule offs_in_range | rule offs_in_range), + (erule offs_in_range | rule offs_in_range), + erule notE, rule kh0H_dom_sets_distinct)+ + +lemma kh0H_dom: + "dom kh0H = {idle_tcb_ptr, High_tcb_ptr, Low_tcb_ptr, + High_pool_ptr, Low_pool_ptr, irq_cnode_ptr, ntfn_ptr} \ + irq_node_offs_range \ + page_offs_range shared_page_ptr_virt \ + cnode_offs_range Silc_cnode_ptr \ + cnode_offs_range High_cnode_ptr \ + cnode_offs_range Low_cnode_ptr \ + pt_offs_range VSRootPT_T arm_global_pt_ptr \ + pt_offs_range VSRootPT_T High_pd_ptr \ + pt_offs_range VSRootPT_T Low_pd_ptr \ + pt_offs_range NormalPT_T High_pt_ptr \ + pt_offs_range NormalPT_T Low_pt_ptr" + apply (rule equalityI) + apply (simp add: kh0H_def dom_def) + apply (clarsimp simp: offs_in_range option_update_range_def not_in_range_None split: if_split_asm) + apply (clarsimp simp: dom_def) + apply (rule conjI) + apply (force simp: kh0H_def kh0H_dom_distinct option_update_range_def not_in_range_None + dest: irq_node_offs_range_correct split: option.splits) + apply (intro conjI) + by (auto simp: kh0H_def kh0H_dom_distinct option_update_range_def not_in_range_None in_range_not_None + split: option.splits) + +lemmas kh0H_SomeD' = set_mp[OF equalityD1[OF kh0H_dom[simplified dom_def]], OF CollectI, simplified, OF exI] + +lemma kh0H_SomeD: + "kh0H x = Some y + \ x = ntfn_ptr \ y = KONotification ntfnH \ + x = Low_tcb_ptr \ y = KOTCB Low_tcbH \ + x = High_tcb_ptr \ y = KOTCB High_tcbH \ + x = idle_tcb_ptr \ y = KOTCB idle_tcbH \ + x \ pt_offs_range VSRootPT_T arm_global_pt_ptr \ global_ptH arm_global_pt_ptr x \ None + \ y = the (global_ptH arm_global_pt_ptr x) \ + x \ irq_node_offs_range \ y = KOCTE (CTE NullCap Null_mdb) \ + x \ pt_offs_range NormalPT_T Low_pt_ptr \ Low_ptH Low_pt_ptr x \ None \ y = the (Low_ptH Low_pt_ptr x) \ + x \ pt_offs_range NormalPT_T High_pt_ptr \ High_ptH High_pt_ptr x \ None \ y = the (High_ptH High_pt_ptr x) \ + x \ pt_offs_range VSRootPT_T Low_pd_ptr \ Low_pdH Low_pd_ptr x \ None \ y = the (Low_pdH Low_pd_ptr x) \ + x \ pt_offs_range VSRootPT_T High_pd_ptr \ High_pdH High_pd_ptr x \ None \ y = the (High_pdH High_pd_ptr x) \ + x = Low_pool_ptr \ y = KOArch Low_poolH \ + x = High_pool_ptr \ y = KOArch High_poolH \ + x \ cnode_offs_range Low_cnode_ptr \ Low_cte Low_cnode_ptr x \ None \ y = the (Low_cte Low_cnode_ptr x) \ + x \ cnode_offs_range High_cnode_ptr \ High_cte High_cnode_ptr x \ None \ y = the (High_cte High_cnode_ptr x) \ + x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte Silc_cnode_ptr x \ None \ y = the (Silc_cte Silc_cnode_ptr x) \ + x = irq_cnode_ptr \ y = KOCTE irq_cte \ + x \ page_offs_range shared_page_ptr_virt \ y = KOUserData" + apply (frule kh0H_SomeD') + apply (elim disjE) + by (clarsimp | drule offs_range_correct)+ + +definition arch_state0H :: Arch.kernel_state where + "arch_state0H \ ARMKernelState + \ \armKSASIDTable =\ [ucast (asid_high_bits_of Low_asid) \ Low_pool_ptr, + ucast (asid_high_bits_of High_asid) \ High_pool_ptr] + \ \armKSKernelVSpace =\ Example_Valid_State.init_vspace_uses + \ \armKSVMIDTable =\ Map.empty + \ \armKSNextVMID =\ 0 + \ \armKSGlobalUserVSpace =\ arm_global_pt_ptr + \ \armHSCurVCPU =\ None + \ \armKSGICVCPUNumListRegs =\ (max_armKSGICVCPUNumListRegs - 1) + \ \gsPTTypes =\ [Low_pt_ptr \ NormalPT_T, + High_pt_ptr \ NormalPT_T, + Low_pd_ptr \ VSRootPT_T, + High_pd_ptr \ VSRootPT_T, + arm_global_pt_ptr \ VSRootPT_T] + \ \armKSGlobalPTs =\ None" + +definition s0H_internal :: "kernel_state" where + "s0H_internal \ \ + ksPSpace = kh0H, + gsUserPages = [shared_page_ptr_virt \ max_page_size], + gsCNodes = (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x + then Some 0 else None) + (Low_cnode_ptr \ 10, + High_cnode_ptr \ 10, + Silc_cnode_ptr \ 10, + irq_cnode_ptr \ 0), + gsUntypedZeroRanges = ran (map_comp untypedZeroRange (option_map cteCap o map_to_ctes kh0H)), + gsMaxObjectSize = card (UNIV :: obj_ref set), + ksDomScheduleIdx = 0, + ksDomScheduleStart = 0, + ksDomSchedule = [(0, 10), (1, 10), (0, 0)], + ksCurDomain = 0, + ksDomainTime = 5, + ksReadyQueues = const emptyQueue, + ksReadyQueuesL1Bitmap = const 0, + ksReadyQueuesL2Bitmap = const 0, + ksCurThread = Low_tcb_ptr, + ksIdleThread = idle_tcb_ptr, + ksSchedulerAction = ResumeCurrentThread, + ksInterruptState = InterruptState init_irq_node_ptr ((\_. IRQInactive) (timer_irq := IRQTimer)), + ksWorkUnitsCompleted = undefined, + ksArchState = arch_state0H, + ksMachineState = machine_state0\" + +definition Low_cte_cte :: "obj_ref \ obj_ref \ cte option" where + "Low_cte_cte \ \base offs. if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then Low_cte' (ucast (offs - base >> 5)) else None" + +definition High_cte_cte :: "obj_ref \ obj_ref \ cte option" where + "High_cte_cte \ \base offs. if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then High_cte' (ucast (offs - base >> 5)) else None" + +definition Silc_cte_cte :: "obj_ref \ obj_ref \ cte option" where + "Silc_cte_cte \ \base offs. if is_aligned offs 5 \ base \ offs \ offs \ base + 2 ^ 15 - 1 + then Silc_cte' (ucast (offs - base >> 5)) else None" + +definition Low_tcb_cte :: "obj_ref \ cte option" where + "Low_tcb_cte \ [Low_tcb_ptr \ tcbCTable Low_tcbH, + Low_tcb_ptr + 0x20 \ tcbVTable Low_tcbH, + Low_tcb_ptr + 0x40 \ tcbReply Low_tcbH, + Low_tcb_ptr + 0x60 \ tcbCaller Low_tcbH, + Low_tcb_ptr + 0x80 \ tcbIPCBufferFrame Low_tcbH]" + +definition High_tcb_cte :: "obj_ref \ cte option" where + "High_tcb_cte \ [High_tcb_ptr \ tcbCTable High_tcbH, + High_tcb_ptr + 0x20 \ tcbVTable High_tcbH, + High_tcb_ptr + 0x40 \ tcbReply High_tcbH, + High_tcb_ptr + 0x60 \ tcbCaller High_tcbH, + High_tcb_ptr + 0x80 \ tcbIPCBufferFrame High_tcbH]" + +definition idle_tcb_cte :: "obj_ref \ cte option" where + "idle_tcb_cte \ [idle_tcb_ptr \ tcbCTable idle_tcbH, + idle_tcb_ptr + 0x20 \ tcbVTable idle_tcbH, + idle_tcb_ptr + 0x40 \ tcbReply idle_tcbH, + idle_tcb_ptr + 0x60 \ tcbCaller idle_tcbH, + idle_tcb_ptr + 0x80 \ tcbIPCBufferFrame idle_tcbH]" + + +lemma not_in_range_cte_None: + "x \ cnode_offs_range Low_cnode_ptr \ Low_cte_cte Low_cnode_ptr x = None" + "x \ cnode_offs_range High_cnode_ptr \ High_cte_cte High_cnode_ptr x = None" + "x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte_cte Silc_cnode_ptr x = None" + "x \ cnode_offs_range init_irq_node_ptr \ \irq. x \ init_irq_node_ptr + (UCAST(9 \ 64) irq << 5)" + "x \ tcb_offs_range Low_tcb_ptr \ Low_tcb_cte x = None" + "x \ tcb_offs_range High_tcb_ptr \ High_tcb_cte x = None" + "x \ tcb_offs_range idle_tcb_ptr \ idle_tcb_cte x = None" + apply (clarsimp simp: cnode_offs_range_def page_offs_range_def tcb_offs_range_def s0_ptr_defs Low_cte_cte_def + High_cte_cte_def Silc_cte_cte_def Low_tcb_cte_def High_tcb_cte_def idle_tcb_cte_def mask_def)+ + apply safe + apply word_bitwise + apply word_bitwise + apply (erule swap) + apply clarsimp + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_def) + apply (rule is_aligned_shift) + apply (auto simp: cnode_offs_range_def page_offs_range_def tcb_offs_range_def s0_ptr_defs Low_cte_cte_def + High_cte_cte_def Silc_cte_cte_def Low_tcb_cte_def High_tcb_cte_def idle_tcb_cte_def mask_def) + done + +lemma mask_neg_le: + "x && ~~ mask n \ x" + apply (clarsimp simp: neg_mask_is_div) + apply (rule word_div_mult_le) + done + +lemma mask_in_tcb_offs_range: + "x && ~~ mask 11 = ptr \ x \ tcb_offs_range ptr" + apply (clarsimp simp: tcb_offs_range_def word_and_le2 objBitsKO_def) + apply (cut_tac and_neg_mask_plus_mask_mono[where p=x and n=11]) + apply (simp add: add.commute mask_def) + done + +lemma set_mem_neq: + "\ y \ S; x \ S \ \ x \ y" + by fastforce + +lemma neg_mask_decompose: + "x && ~~ mask n = ptr \ x = ptr + (x && mask n)" + by (clarsimp simp: AND_NOT_mask_plus_AND_mask_eq) + +lemma opt_None_not_dom: + "m a = None \ a \ dom m" + by (simp add: dom_def) + +lemma tcb_offs_range_mask_eq: + "\ x \ tcb_offs_range ptr; is_aligned ptr 11 \ \ x && ~~ mask 11 = ptr" + apply (drule(1) tcb_offs_range_correct') + apply (clarsimp simp: objBitsKO_def) + apply (drule_tac d="ucast y" in is_aligned_add_helper) + apply (cut_tac x=y and 'a=64 in ucast_less) + apply simp + apply simp + apply simp + done + +lemma not_in_tcb_offs: + "\tcb. kh0H (x && ~~ mask 11) \ Some (KOTCB tcb) + \ x \ tcb_offs_range Low_tcb_ptr" + "\tcb. kh0H (x && ~~ mask 11) \ Some (KOTCB tcb) + \ x \ tcb_offs_range High_tcb_ptr" + "\tcb. kh0H (x && ~~ mask 11) \ Some (KOTCB tcb) + \ x \ tcb_offs_range idle_tcb_ptr" + by (fastforce simp: s0_ptrs_aligned dest: tcb_offs_range_mask_eq)+ + +lemma range_tcb_not_kh0H_dom: + "{(x && ~~ mask 11) + 1..(x && ~~ mask 11) + 2 ^ 11 - 1} \ dom kh0H \ {} \ (x && ~~ mask 11) \ High_tcb_ptr" + "{(x && ~~ mask 11) + 1..(x && ~~ mask 11) + 2 ^ 11 - 1} \ dom kh0H \ {} \ (x && ~~ mask 11) \ Low_tcb_ptr" + "{(x && ~~ mask 11) + 1..(x && ~~ mask 11) + 2 ^ 11 - 1} \ dom kh0H \ {} \ (x && ~~ mask 11) \ idle_tcb_ptr" + apply clarsimp + apply (drule int_not_emptyD) + apply (clarsimp simp: kh0H_dom) + apply (subgoal_tac "xa \ tcb_offs_range High_tcb_ptr") + prefer 2 + apply (clarsimp simp: tcb_offs_range_def objBitsKO_def) + apply (rule conjI) + apply (erule dual_order.trans) + apply (simp add: s0_ptr_defs) + apply (erule order.trans) + apply (simp add: s0_ptr_defs mask_def) + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] | + clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1])+)[1] + apply (clarsimp simp: s0_ptr_defs tcb_offs_range_def) + apply clarsimp + apply (drule int_not_emptyD) + apply (clarsimp simp: kh0H_dom) + apply (subgoal_tac "xa \ tcb_offs_range Low_tcb_ptr") + prefer 2 + apply (clarsimp simp: tcb_offs_range_def objBitsKO_def) + apply (rule conjI) + apply (erule dual_order.trans) + apply (simp add: s0_ptr_defs) + apply (erule order.trans) + apply (simp add: s0_ptr_defs mask_def) + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] | + clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1])+)[1] + apply (clarsimp simp: s0_ptr_defs tcb_offs_range_def) + apply clarsimp + apply (drule int_not_emptyD) + apply (clarsimp simp: kh0H_dom) + apply (subgoal_tac "xa \ tcb_offs_range idle_tcb_ptr") + prefer 2 + apply (clarsimp simp: tcb_offs_range_def objBitsKO_def) + apply (rule conjI) + apply (erule dual_order.trans) + apply (simp add: s0_ptr_defs) + apply (erule order.trans) + apply (simp add: s0_ptr_defs mask_def) + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] | + clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1])+)[1] + apply (clarsimp simp: s0_ptr_defs tcb_offs_range_def) + done + +lemma kh0H_dom_tcb: + "kh0H x = Some (KOTCB tcb) + \ x = Low_tcb_ptr \ x = High_tcb_ptr \ x = idle_tcb_ptr" + apply (frule domI[where m="kh0H"]) + apply (simp add: kh0H_dom) + apply (elim disjE) + by (auto dest: offs_range_correct simp: kh0H_all_obj_def s0_ptrs_aligned split: if_split_asm) + +lemma vs_index_bits_less_word_len[simp]: + "vs_index_bits < 64" + by (auto simp: bit_simps) + +lemma vs_index_bits_pt_bits: + "vs_index_bits + 3 = pt_bits VSRootPT_T" + by (simp add: bit_simps) + +lemma map_to_ctes_kh0H: + "map_to_ctes kh0H = + (option_update_range + (\x. if \irq :: irq. init_irq_node_ptr + (ucast irq << 5) = x + then Some (CTE NullCap Null_mdb) else None) \ + option_update_range (Low_cte_cte Low_cnode_ptr) \ + option_update_range (High_cte_cte High_cnode_ptr) \ + option_update_range (Silc_cte_cte Silc_cnode_ptr) \ + option_update_range [irq_cnode_ptr \ CTE NullCap Null_mdb] \ + option_update_range Low_tcb_cte \ + option_update_range High_tcb_cte \ + option_update_range idle_tcb_cte + ) Map.empty" + supply option.case_cong[cong] if_cong[cong] + supply objBits_defs[simp] + apply (rule ext) + apply (case_tac "kh0H x") + apply (clarsimp simp add: map_to_ctes_def Let_def objBitsKO_def) + apply (rule conjI) + apply clarsimp + apply (thin_tac "x \ y = {}" for x y) + apply (frule kh0H_dom_tcb) + apply (elim disjE) + apply (clarsimp simp: option_update_range_def) + apply (frule mask_in_tcb_offs_range) + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply (simp add: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None + | simp add: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+ + apply (rule conjI, clarsimp) + apply (clarsimp split: option.splits) + apply (rule conjI) + apply (fastforce simp: tcb_cte_cases_def Low_tcb_cte_def dest: neg_mask_decompose) + subgoal by (fastforce simp: Low_tcb_cte_def tcb_cte_cases_def + split: if_split_asm dest: neg_mask_decompose) + apply (clarsimp simp: option_update_range_def) + apply (frule mask_in_tcb_offs_range) + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply (simp add: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None + | simp add: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+ + apply (rule conjI, clarsimp) + apply clarsimp + apply (clarsimp split: option.splits) + apply (rule conjI) + apply (fastforce simp: tcb_cte_cases_def High_tcb_cte_def dest: neg_mask_decompose) + subgoal by (fastforce simp: High_tcb_cte_def tcb_cte_cases_def + split: if_split_asm dest: neg_mask_decompose) + apply (clarsimp simp: option_update_range_def) + apply (frule mask_in_tcb_offs_range) + apply (clarsimp simp: kh0H_dom_distinct[THEN set_mem_neq]) + apply (simp add: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None + | simp add: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+ + apply (rule conjI, clarsimp) + apply clarsimp + apply (clarsimp split: option.splits) + apply (rule conjI) + apply (fastforce simp: tcb_cte_cases_def idle_tcb_cte_def dest: neg_mask_decompose) + subgoal by (fastforce simp: idle_tcb_cte_def tcb_cte_cases_def + split: if_split_asm dest: neg_mask_decompose) + apply (drule_tac m="kh0H" in opt_None_not_dom) + apply (rule conjI) + apply (clarsimp simp: kh0H_dom option_update_range_def) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] not_in_tcb_offs not_in_range_cte_None offs_in_range + | clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+)[1] + apply (rule impI) + apply (frule range_tcb_not_kh0H_dom(1)[simplified]) + apply (frule range_tcb_not_kh0H_dom(2)[simplified]) + apply (drule range_tcb_not_kh0H_dom(3)[simplified]) + apply (clarsimp simp: kh0H_dom split del: if_split) + apply (clarsimp simp: option_update_range_def) + apply ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] not_in_tcb_offs not_in_range_cte_None offs_in_range + | clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None)+)[1] + apply (subst not_in_range_cte_None, + clarsimp simp: tcb_offs_range_mask_eq s0_ptrs_aligned)+ + apply (clarsimp simp: irq_node_offs_in_range) + apply (frule kh0H_SomeD) + apply (elim disjE) + defer + apply ((clarsimp simp: map_to_ctes_def Let_def split del: if_split, + subst if_split_eq1, rule conjI, rule impI, + (subst is_aligned_neg_mask_eq, simp add: is_aligned_def s0_ptr_defs objBitsKO_def)+, + ((clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None | + clarsimp simp: idle_tcb_cte_def High_tcb_cte_def Low_tcb_cte_def)+)[1], + rule impI, + (subst (asm) is_aligned_neg_mask_eq, simp add: is_aligned_def s0_ptr_defs objBitsKO_def)+, + clarsimp, + clarsimp simp: kh0H_dom objBitsKO_def s0_ptr_defs irq_node_offs_range_def + cnode_offs_range_def pt_offs_range_def page_offs_range_def, + rule FalseE, drule int_not_emptyD, clarsimp, + (elim disjE, (clarsimp | drule(1) order_trans le_less_trans, fastforce)+)[1])+)[3] + defer 2 + apply ((clarsimp simp: map_to_ctes_def Let_def split del: if_split, + subst if_split_eq1, rule conjI, rule impI, drule pt_offs_range_correct, + clarsimp simp: kh0H_obj_def kh0H_dom_distinct option_update_range_def not_in_range_cte_None split: if_split_asm, + rule impI, subst if_split_eq1, rule conjI, rule impI, rule FalseE, + drule pt_offs_range_correct, clarsimp, cut_tac x=ya and 'a=64 in ucast_less, simp add: bit_simps, + drule shiftl_less_t2n'[where n=3], simp add: bit_simps, simp, + drule plus_one_helper[where n="2 ^ (vs_index_bits + 3) - 1", simplified] + plus_one_helper[where n="0xFFF", simplified], + drule kh0H_dom_tcb, + (elim disjE, (clarsimp simp: s0_ptr_defs objBitsKO_def, + erule notE[rotated], + rule_tac a="x::obj_ref" for x in dual_order.strict_implies_not_eq, + rule less_le_trans[rotated, OF aligned_le_sharp], + rule word_plus_mono_right2[rotated], simp add: order_less_imp_le, + simp add: bit_simps, simp add: is_aligned_def, simp)+)[1], + rule impI, + clarsimp simp: option_update_range_def kh0H_dom_distinct[THEN set_mem_neq] not_in_range_cte_None, + ((clarsimp simp: kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None irq_node_offs_in_range | + clarsimp simp: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1])+)[5] + prefer 8 + apply ((clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split, + subst if_split_eq1, rule conjI, + clarsimp, drule kh0H_dom_tcb, fastforce simp: s0_ptr_defs mask_def objBitsKO_def, + fastforce simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None)+)[3] + apply ((clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def objBitsKO_def + split: if_split_asm split del: if_split, + subst if_split_eq1, rule conjI, rule impI, + clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None, + (clarsimp simp: option_update_range_def kh0H_dom_distinct[THEN set_mem_neq] + kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+, + rule conjI, clarsimp, drule offs_range_correct, + fastforce simp: Low_cte_cte_def High_cte_cte_def Silc_cte_cte_def, + rule impI, rule FalseE, drule offs_range_correct, + clarsimp simp: Low_cte_def High_cte_def Silc_cte_def cnode_offs_min cnode_offs_max, + cut_tac x="of_bl y" and z="0x20::obj_ref" and y="2 ^ 15 - 1" in div_to_mult_word_lt, + frule_tac 'a=64 in of_bl_length_le, simp, simp, drule int_not_emptyD, + clarsimp simp: kh0H_dom s0_ptr_defs cnode_offs_range_def page_offs_range_def + pt_offs_range_def irq_node_offs_range_def, + (elim disjE, ((subst (asm) pt_bits_def, simp add: bit_simps split: if_splits; unat_arith) + | clarsimp simp: s0_ptr_defs, + drule_tac b="x + y * 0x20" and n=5 for x y in aligned_le_sharp, + fastforce simp: is_aligned_def, clarsimp simp: add.commute, + subst (asm) mask_out_add_aligned[symmetric], + simp add: is_aligned_mult_triv2[where n=5, simplified], + simp add: mask_def, drule word_leq_le_minus_one, + subst add.commute, rule neq_0_no_wrap, + erule word_plus_mono_right2[rotated], + fastforce, fastforce, fastforce simp: add.commute | unat_arith)+)[1])+)[3] + apply (clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split, + subst if_split_eq1, rule conjI, rule impI, + clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None, rule impI, + clarsimp simp: kh0H_dom objBitsKO_def s0_ptr_defs is_aligned_def page_offs_range_def + cnode_offs_range_def pt_offs_range_def irq_node_offs_range_def, + rule FalseE, drule int_not_emptyD, clarsimp, + (elim disjE, (clarsimp simp: bit_simps split: if_splits | drule(1) order_trans le_less_trans, fastforce)+)[1]) + apply (clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split) + apply (subst if_split_eq1) + apply (rule conjI, clarsimp) + apply (fastforce dest: kh0H_dom_tcb simp: page_offs_range_def objBitsKO_def) + apply (clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None) + apply (rule conjI; clarsimp) + apply (rule conjI; clarsimp) + apply (subst is_aligned_neg_mask_eq, clarsimp simp: objBitsKO_def page_offs_range_def is_aligned_weaken)+ + apply (clarsimp split: option.splits) + apply (intro conjI impI; drule kh0H_dom_sets_distinct[THEN orthD2] + kh0H_dom_sets_distinct[THEN orthD1], + drule not_in_range_cte_None, solves clarsimp) + apply (clarsimp simp: map_to_ctes_def Let_def kh0H_obj_def split del: if_split) + apply (frule irq_node_offs_range_correct) + apply (subst if_split_eq1) + apply (rule conjI) + apply (rule impI) + apply (clarsimp simp: option_update_range_def kh0H_dom_distinct not_in_range_cte_None) + apply fastforce + apply (rule impI) + apply clarsimp + apply (erule impE) + apply (rule is_aligned_add) + apply (simp add: is_aligned_def s0_ptr_defs objBitsKO_def) + apply (rule is_aligned_shiftl) + apply (clarsimp simp: objBitsKO_def) + apply (rule FalseE) + apply (clarsimp simp: s0_ptr_defs cnode_offs_range_def page_offs_range_def pt_offs_range_def + irq_node_offs_range_def objBitsKO_def kh0H_dom) + apply (cut_tac x=irq and 'a=64 in ucast_less) + apply simp + apply (drule shiftl_less_t2n'[where n=5]) + apply simp + apply simp + apply (drule plus_one_helper[where n="0x3FFF", simplified]) + apply (elim disjE) + apply (unat_arith+)[7] + apply (drule int_not_emptyD) + apply clarsimp + apply (elim disjE, + (((subst (asm) pt_bits_def, simp add: bit_simps split: if_splits; unat_arith) | + clarsimp, + drule(1) aligned_le_sharp, + clarsimp simp: add.commute, + subst(asm) mask_out_add_aligned[symmetric], + simp add: is_aligned_shiftl, + simp add: mask_def, + drule word_leq_le_minus_one, + subst add.commute, + rule neq_0_no_wrap, + erule word_plus_mono_right2[rotated], + fastforce, + fastforce, + fastforce simp: add.commute) + | unat_arith)+)[1] + done + +lemma option_update_range_map_comp: + "option_update_range m m' = map_add m' m" + by (simp add: fun_eq_iff option_update_range_def map_comp_def map_add_def split: option.split) + +lemma tcb_offs_in_rangeI: + "\ ptr \ ptr + x; ptr + x \ ptr + 2 ^ 11 - 1 \ \ ptr + x \ tcb_offs_range ptr" + apply (simp add: tcb_offs_range_def) + by (simp add: Groups.add_ac(2)) + +lemma map_to_ctes_kh0H_simps[simp]: + "map_to_ctes kh0H (init_irq_node_ptr + (ucast (irq :: irq) << 5)) = Some (CTE NullCap Null_mdb)" + "map_to_ctes kh0H irq_cnode_ptr = Some (CTE NullCap Null_mdb)" + "length x = 10 \ map_to_ctes kh0H (Low_cnode_ptr + of_bl x * 0x20) = + Low_cte_cte Low_cnode_ptr (Low_cnode_ptr + of_bl x * 0x20)" + "length x = 10 \ map_to_ctes kh0H (High_cnode_ptr + of_bl x * 0x20) = + High_cte_cte High_cnode_ptr (High_cnode_ptr + of_bl x * 0x20)" + "length x = 10 \ map_to_ctes kh0H (Silc_cnode_ptr + of_bl x * 0x20) = + Silc_cte_cte Silc_cnode_ptr (Silc_cnode_ptr + of_bl x * 0x20)" + "map_to_ctes kh0H Low_tcb_ptr = Low_tcb_cte Low_tcb_ptr" + "map_to_ctes kh0H (Low_tcb_ptr + 0x20) = Low_tcb_cte (Low_tcb_ptr + 0x20)" + "map_to_ctes kh0H (Low_tcb_ptr + 0x40) = Low_tcb_cte (Low_tcb_ptr + 0x40)" + "map_to_ctes kh0H (Low_tcb_ptr + 0x60) = Low_tcb_cte (Low_tcb_ptr + 0x60)" + "map_to_ctes kh0H (Low_tcb_ptr + 0x80) = Low_tcb_cte (Low_tcb_ptr + 0x80)" + "map_to_ctes kh0H High_tcb_ptr = High_tcb_cte High_tcb_ptr" + "map_to_ctes kh0H (High_tcb_ptr + 0x20) = High_tcb_cte (High_tcb_ptr + 0x20)" + "map_to_ctes kh0H (High_tcb_ptr + 0x40) = High_tcb_cte (High_tcb_ptr + 0x40)" + "map_to_ctes kh0H (High_tcb_ptr + 0x60) = High_tcb_cte (High_tcb_ptr + 0x60)" + "map_to_ctes kh0H (High_tcb_ptr + 0x80) = High_tcb_cte (High_tcb_ptr + 0x80)" + "map_to_ctes kh0H idle_tcb_ptr = idle_tcb_cte idle_tcb_ptr" + "map_to_ctes kh0H (idle_tcb_ptr + 0x20) = idle_tcb_cte (idle_tcb_ptr + 0x20)" + "map_to_ctes kh0H (idle_tcb_ptr + 0x40) = idle_tcb_cte (idle_tcb_ptr + 0x40)" + "map_to_ctes kh0H (idle_tcb_ptr + 0x60) = idle_tcb_cte (idle_tcb_ptr + 0x60)" + "map_to_ctes kh0H (idle_tcb_ptr + 0x80) = idle_tcb_cte (idle_tcb_ptr + 0x80)" + supply option.case_cong[cong] if_cong[cong] + apply (clarsimp simp: map_to_ctes_kh0H option_update_range_def) + apply fastforce + apply (clarsimp simp: map_to_ctes_kh0H option_update_range_def kh0H_dom_distinct not_in_range_cte_None) + apply ((clarsimp simp: option_update_range_def not_in_range_cte_None cnode_offs_in_range + kh0H_dom_distinct kh0H_dom_distinct' map_to_ctes_kh0H s0_ptrs_aligned, + ((clarsimp simp: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None | + clarsimp simp: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1], + intro conjI, + (clarsimp, drule not_disjointI, + (erule offs_in_range | rule offs_in_range), + (erule offs_in_range | rule offs_in_range), + erule notE, rule kh0H_dom_sets_distinct)+, + clarsimp split: option.splits)+)[3] + apply (clarsimp simp: option_update_range_def not_in_range_cte_None + map_to_ctes_kh0H kh0H_dom_distinct split: option.splits) + apply (cut_tac ptr="Low_tcb_ptr" and x="0x20" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: not_in_range_cte_None option_update_range_def + map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="Low_tcb_ptr" and x="0x40" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="Low_tcb_ptr" and x="0x60" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="Low_tcb_ptr" and x="0x80" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: map_to_ctes_kh0H option_update_range_def kh0H_dom_distinct not_in_range_cte_None split: option.splits) + apply (cut_tac ptr="High_tcb_ptr" and x="0x20" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="High_tcb_ptr" and x="0x40" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="High_tcb_ptr" and x="0x60" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="High_tcb_ptr" and x="0x80" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: map_to_ctes_kh0H option_update_range_def kh0H_dom_distinct not_in_range_cte_None split: option.splits) + apply (cut_tac ptr="idle_tcb_ptr" and x="0x20" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="idle_tcb_ptr" and x="0x40" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="idle_tcb_ptr" and x="0x60" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (cut_tac ptr="idle_tcb_ptr" and x="0x80" in tcb_offs_in_rangeI, simp add: s0_ptr_defs, simp add: s0_ptr_defs) + apply (clarsimp simp: map_to_ctes_kh0H kh0H_dom_distinct kh0H_dom_distinct' + option_update_range_def not_in_range_cte_None + split: option.splits) + apply ((simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD1] not_in_range_cte_None + | simp add: offs_in_range kh0H_dom_sets_distinct[THEN orthD2] not_in_range_cte_None)+)[1] + apply (intro conjI impI allI) + apply (simp add: s0_ptr_defs) + apply clarsimp + apply (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + apply (clarsimp simp: kh0H_dom_distinct) + apply clarsimp + by (drule not_disjointI, + rule irq_node_offs_in_range, + assumption, + erule notE, + rule kh0H_dom_sets_distinct) + +lemma map_to_ctes_kh0H_dom: + "dom (map_to_ctes kh0H) = {idle_tcb_ptr, idle_tcb_ptr + 0x20, idle_tcb_ptr + 0x40, + idle_tcb_ptr + 0x60, idle_tcb_ptr + 0x80, + Low_tcb_ptr, Low_tcb_ptr + 0x20, Low_tcb_ptr + 0x40, + Low_tcb_ptr + 0x60, Low_tcb_ptr + 0x80, + High_tcb_ptr, High_tcb_ptr + 0x20, High_tcb_ptr + 0x40, + High_tcb_ptr + 0x60, High_tcb_ptr + 0x80, + irq_cnode_ptr} + \ irq_node_offs_range + \ cnode_offs_range Silc_cnode_ptr + \ cnode_offs_range High_cnode_ptr + \ cnode_offs_range Low_cnode_ptr" + supply option.case_cong[cong] if_cong[cong] + apply (rule equalityI) + apply (simp add: map_to_ctes_kh0H dom_def) + apply clarsimp + apply (clarsimp simp: offs_in_range option_update_range_def split: option.splits if_split_asm) + apply (clarsimp simp: idle_tcb_cte_def) + apply (clarsimp simp: High_tcb_cte_def) + apply (clarsimp simp: Low_tcb_cte_def) + apply (clarsimp simp: Silc_cte_cte_def cnode_offs_range_def split: if_split_asm) + apply (clarsimp simp: High_cte_cte_def cnode_offs_range_def split: if_split_asm) + apply (clarsimp simp: Low_cte_cte_def cnode_offs_range_def split: if_split_asm) + apply (clarsimp simp: dom_def) + apply (clarsimp simp: idle_tcb_cte_def Low_tcb_cte_def High_tcb_cte_def) + apply (rule conjI) + apply (fastforce dest: irq_node_offs_range_correct) + apply (rule conjI) + apply clarsimp + apply (frule cnode_offs_range_correct) + apply (clarsimp simp: Silc_cte_cte_def Silc_cte'_def Silc_capsH_def empty_cte_def cnode_offs_range_def) + apply (rule conjI) + apply clarsimp + apply (frule cnode_offs_range_correct) + apply (clarsimp simp: High_cte_cte_def High_cte'_def High_capsH_def empty_cte_def cnode_offs_range_def) + apply clarsimp + apply (frule cnode_offs_range_correct) + apply (clarsimp simp: Low_cte_cte_def Low_cte'_def Low_capsH_def empty_cte_def cnode_offs_range_def) + done + +lemmas map_to_ctes_kh0H_SomeD' = + set_mp[OF equalityD1[OF map_to_ctes_kh0H_dom[simplified dom_def]], OF CollectI, simplified, OF exI] + +lemma map_to_ctes_kh0H_SomeD: + "map_to_ctes kh0H x = Some y + \ x = idle_tcb_ptr \ y = (CTE NullCap Null_mdb) \ + x = idle_tcb_ptr + 0x20 \ y = (CTE NullCap Null_mdb) \ + x = idle_tcb_ptr + 0x40 \ y = (CTE NullCap Null_mdb) \ + x = idle_tcb_ptr + 0x60 \ y = (CTE NullCap Null_mdb) \ + x = idle_tcb_ptr + 0x80 \ y = (CTE NullCap Null_mdb) \ + x = Low_tcb_ptr \ y = (CTE (CNodeCap Low_cnode_ptr 10 2 10) (MDB (Low_cnode_ptr + 0x40) 0 False False)) \ + x = Low_tcb_ptr + 0x20 \ y = (CTE (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid,0)))) + (MDB (Low_cnode_ptr + 0x60) 0 False False)) \ + x = Low_tcb_ptr + 0x40 \ y = (CTE (ReplyCap Low_tcb_ptr True True) (MDB 0 0 True True)) \ + x = Low_tcb_ptr + 0x60 \ y = (CTE NullCap Null_mdb) \ + x = Low_tcb_ptr + 0x80 \ y = (CTE NullCap Null_mdb) \ + x = High_tcb_ptr \ y = (CTE (CNodeCap High_cnode_ptr 10 2 10) (MDB (High_cnode_ptr + 0x40) 0 False False)) \ + x = High_tcb_ptr + 0x20 \ y = (CTE (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0)))) + (MDB (High_cnode_ptr + 0x60) 0 False False)) \ + x = High_tcb_ptr + 0x40 \ y = (CTE (ReplyCap High_tcb_ptr True True) (MDB 0 0 True True)) \ + x = High_tcb_ptr + 0x60 \ y = (CTE NullCap Null_mdb) \ + x = High_tcb_ptr + 0x80 \ y = (CTE NullCap Null_mdb) \ + x = irq_cnode_ptr \ y = (CTE NullCap Null_mdb) \ + x \ irq_node_offs_range \ y = (CTE NullCap Null_mdb) \ + x \ cnode_offs_range Silc_cnode_ptr \ Silc_cte_cte Silc_cnode_ptr x \ None + \ y = the (Silc_cte_cte Silc_cnode_ptr x) \ + x \ cnode_offs_range High_cnode_ptr \ High_cte_cte High_cnode_ptr x \ None \ y = the (High_cte_cte High_cnode_ptr x) \ + x \ cnode_offs_range Low_cnode_ptr \ Low_cte_cte Low_cnode_ptr x \ None \ y = the (Low_cte_cte Low_cnode_ptr x)" + apply (frule map_to_ctes_kh0H_SomeD') + apply (erule disjE, rule disjI1, clarsimp simp: idle_tcb_cte_def idle_tcbH_def + Low_tcb_cte_def Low_tcbH_def Low_capsH_def + High_tcb_cte_def High_tcbH_def High_capsH_def + the_nat_to_bl_def nat_to_bl_def, rule disjI2)+ + apply ((erule disjE)?, drule offs_range_correct, clarsimp simp: offs_in_range)+ + done + +lemma mask_neg_add_aligned: + "is_aligned q n \ p + q && ~~ mask n = (p && ~~ mask n) + q" + apply (subst add.commute) + apply (simp add: mask_out_add_aligned[symmetric]) + done + +lemma mask_neg_add_aligned': + "is_aligned q n \ q + p && ~~ mask n = (p && ~~ mask n) + q" + by (simp add: mask_out_add_aligned[symmetric]) + +lemma kh_s0H[simp]: + "ksPSpace s0H_internal = kh0H" + by (simp add: s0H_internal_def) + +lemma pspace_distinct'_split: + notes less_1_simp[simp del] shows + "(\(y, ko) \ graph_of (ksPSpace ks). (x \ y \ y + (1 << objBitsKO ko) - 1 < x) + \ y \ y + (1 << objBitsKO ko) - 1) + \ pspace_distinct' (ks \ksPSpace := restrict_map (ksPSpace ks) {..< x}\) + \ pspace_distinct' (ks \ksPSpace := restrict_map (ksPSpace ks) {x ..}\) + \ pspace_distinct' ks" + apply (clarsimp simp: pspace_distinct'_def) + apply (drule bspec, erule graph_ofI, clarsimp) + apply (simp add: Ball_def) + apply (drule_tac x=xa in spec)+ + apply (erule disjE) + apply (simp add: domI) + apply (thin_tac "P \ Q" for P Q) + apply (simp add: ps_clear_def) + apply (erule trans[rotated]) + apply auto[1] + apply (clarsimp simp add: domI) + apply (drule mp, erule(1) order_le_less_trans) + apply (thin_tac "P \ Q" for P Q) + apply (simp add: ps_clear_def) + apply (erule trans[rotated]) + apply (fastforce simp: mask_eq_exp_minus_1 add_diff_eq) + done + +lemma irq_node_offs_range_def2: + "irq_node_offs_range = {x. init_irq_node_ptr \ x \ x \ init_irq_node_ptr + 0x3FFF} \ + {x. is_aligned x 5}" + apply (safe, simp_all add: irq_node_offs_range_def add.commute) + by (auto dest: word_less_sub_1 simp: s0_ptr_defs elim: dual_order.strict_trans2[rotated]) + +(* FIXME IF: fix repetitiveness *) +lemma s0H_pspace_distinct': + notes pteBits_def[simp] objBits_defs[simp] + shows "pspace_distinct' s0H_internal" + supply option.case_cong[cong] if_cong[cong] + apply (clarsimp simp: pspace_distinct'_def ps_clear_def mask_eq_exp_minus_1) + apply (rule disjointI) + apply clarsimp + apply (drule kh0H_SomeD)+ + \ \ntfn_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal by ((elim disjE; clarsimp), + (thin_tac "_ \ _", clarsimp simp: pt_offs_range_def page_offs_range_def + cnode_offs_range_def irq_node_offs_range_def2 + , drule dual_order.trans, assumption + , clarsimp simp: s0_ptr_defs objBitsKO_def + | solves \clarsimp simp: s0_ptr_defs objBitsKO_def\)+) + \ \Low_tcb_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal by ((elim disjE; clarsimp), + (thin_tac "_ \ _", clarsimp simp: pt_offs_range_def page_offs_range_def + cnode_offs_range_def irq_node_offs_range_def2 + , drule dual_order.trans, assumption + , clarsimp simp: s0_ptr_defs objBitsKO_def + | solves \clarsimp simp: s0_ptr_defs objBitsKO_def\)+) + \ \High_tcb_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal by ((elim disjE; clarsimp), + (thin_tac "_ \ _", clarsimp simp: pt_offs_range_def page_offs_range_def + cnode_offs_range_def irq_node_offs_range_def2 + , drule dual_order.trans, assumption + , clarsimp simp: s0_ptr_defs objBitsKO_def + | solves \clarsimp simp: s0_ptr_defs objBitsKO_def\)+) + \ \Idle_tcb_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal by ((elim disjE; clarsimp), + (thin_tac "_ \ _", clarsimp simp: pt_offs_range_def page_offs_range_def + cnode_offs_range_def irq_node_offs_range_def2 + , drule dual_order.trans, assumption + , clarsimp simp: s0_ptr_defs objBitsKO_def + | solves \clarsimp simp: s0_ptr_defs objBitsKO_def\)+) + \ \arm_global_pt_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + (thin_tac "ya \ _", thin_tac "_ \ ya", + drule_tac b=ya and a="_ + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs)+)[4] + apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def split: if_splits\)+)[12] + \ \irq_node_offs_range\ + apply (erule_tac P="_ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply (clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="init_irq_node_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply (clarsimp simp: irq_node_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def + split: if_split_asm; + (drule(1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="init_irq_node_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \Low_pt_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="Low_pt_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def split: if_split_asm, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def\)+)[1] + apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \High_pt_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="High_pt_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def split: if_split_asm, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def\)+) + apply (clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def))+ + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \Low_pd_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="Low_pd_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + solves \simp add: s0_ptr_defs mask_def bit_simps split: if_splits\) + apply (solves \clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)\)+ + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def bit_simps split: if_splits\)+)[7] + \ \High_pd_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply (clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pt_offs_range_def objBitsKO_def, + drule dual_order.trans, assumption, + drule dual_order.trans[where c="High_pd_ptr"], assumption, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+ + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + solves \simp add: s0_ptr_defs mask_def bit_simps split: if_splits\) + apply (solves \clarsimp simp: pt_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def bit_simps + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)\)+ + apply ((thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def2 cnode_offs_range_def page_offs_range_def, + drule_tac a=x in aligned_le_sharp, assumption, + solves \drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def bit_simps split: if_splits\)+)[7] + \ \Low_pool_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal for x y ya yb + by ((elim disjE; clarsimp), + ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def cnode_offs_range_def + page_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def, + (thin_tac "ya \ _", drule dual_order.trans, assumption | + thin_tac "_ \ ya", drule dual_order.trans, assumption)?, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+)) + \ \High_pool_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal for x y ya yb + by ((elim disjE; clarsimp), + ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def cnode_offs_range_def + page_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def, + (thin_tac "ya \ _", drule dual_order.trans, assumption | + thin_tac "_ \ ya", drule dual_order.trans, assumption)?, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+)) + \ \Low_cnode_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply (clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 pt_offs_range_def, + drule order.trans, assumption, drule order.trans, assumption, + solves \simp add: s0_ptr_defs bit_simps split: if_splits\)+ + apply (clarsimp simp: objBitsKO_def kh0H_obj_def Low_cte'_def Low_capsH_def cnode_offs_range_def + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \High_cnode_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply (clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 pt_offs_range_def, + drule order.trans, assumption, drule order.trans, assumption, + solves \simp add: s0_ptr_defs bit_simps split: if_splits\)+ + apply (clarsimp simp: objBitsKO_def kh0H_obj_def High_cte'_def High_capsH_def cnode_offs_range_def + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \Silc_cnode_ptr\ + apply (erule_tac P="_ \ _ \ y = _" in disjE) + apply (elim disjE; clarsimp) + apply (clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 pt_offs_range_def, + drule order.trans, assumption, drule order.trans, assumption, + solves \simp add: s0_ptr_defs bit_simps split: if_splits\)+ + apply (clarsimp simp: objBitsKO_def kh0H_obj_def Silc_cte'_def Silc_capsH_def cnode_offs_range_def + split: if_split_asm; + (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def)) + apply (thin_tac "_ \ _", + clarsimp simp: kh0H_obj_def objBitsKO_def archObjSize_def bit_simps pt_offs_range_def + irq_node_offs_range_def cnode_offs_range_def page_offs_range_def, + drule_tac a=x and b="_ + _" in aligned_le_sharp, assumption, + drule dual_order.trans[rotated], + erule word_plus_mono_left, simp add: s0_ptr_defs mask_def, + (drule_tac b=ya and a="(_ && ~~ mask _) + _" in dual_order.trans, assumption)?, + simp add: s0_ptr_defs mask_def)+ + \ \irq_cnode_ptr\ + apply (erule_tac P="_ \ y = _" in disjE) + subgoal for x y ya yb + by ((elim disjE; clarsimp), + ((clarsimp simp: irq_node_offs_range_def2 pt_offs_range_def cnode_offs_range_def + page_offs_range_def objBitsKO_def archObjSize_def kh0H_obj_def, + (thin_tac "ya \ _", drule dual_order.trans, assumption | + thin_tac "_ \ ya", drule dual_order.trans, assumption)?, + solves \clarsimp simp: s0_ptr_defs bit_simps split: if_splits\)+)) + \ \shared_page_ptr\ + apply (elim disjE; clarsimp) + apply (clarsimp simp: cnode_offs_range_def irq_node_offs_range_def2 + page_offs_range_def pt_offs_range_def objBitsKO_def, + drule order.trans, assumption, drule order.trans, assumption, + solves \simp add: s0_ptr_defs bit_simps split: if_splits\)+ + apply (clarsimp simp: page_offs_range_def objBitsKO_def archObjSize_def bit_simps) + apply (drule (1) aligned_le_sharp, simp add: mask_neg_add_aligned', fastforce simp: mask_def) + done + +lemma pspace_distinctD'': + "\ \v. ksPSpace s x = Some v \ objBitsKO v = n; pspace_distinct' s \ + \ ps_clear x n s" + apply clarsimp + apply (drule(1) pspace_distinctD') + apply simp + done + +lemma cnode_offs_min2': + "is_aligned ptr 15 \ (ptr :: obj_ref) \ ptr + 0x20 * (x && mask 10)" + apply (erule is_aligned_no_wrap') + apply (subst mult.commute) + apply (rule div_lt_mult) + apply (cut_tac and_mask_less'[where n=10]) + apply simp + apply simp + apply simp + done + +lemma cnode_offs_min2: + "Low_cnode_ptr \ Low_cnode_ptr + 0x20 * (x && mask 10)" + "High_cnode_ptr \ High_cnode_ptr + 0x20 * (x && mask 10)" + "Silc_cnode_ptr \ Silc_cnode_ptr + 0x20 * (x && mask 10)" + by (simp_all add: cnode_offs_min2' s0_ptrs_aligned) + +lemma cnode_offs_max2': + "is_aligned ptr 15 \ (ptr::obj_ref) + 0x20 * (x && mask 10) \ ptr + 0x7fff" + apply (rule word_plus_mono_right) + apply (subst mult.commute) + apply (rule div_to_mult_word_lt) + apply simp + apply (rule plus_one_helper) + apply simp + apply (cut_tac and_mask_less'[where n=10]) + apply simp + apply simp + apply (drule is_aligned_no_overflow) + apply (simp add: add.commute) + done + +lemma cnode_offs_max2: + "Low_cnode_ptr + 0x20 * (x && mask 10) \ Low_cnode_ptr + 0x7fff" + "High_cnode_ptr + 0x20 * (x && mask 10) \ High_cnode_ptr + 0x7fff" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ Silc_cnode_ptr + 0x7fff" + by (simp_all add: cnode_offs_max2' s0_ptrs_aligned) + +lemma cnode_offs_in_range2': + "is_aligned ptr 15 \ ptr + 0x20 * (x && mask 10) \ cnode_offs_range ptr" + apply (clarsimp simp: cnode_offs_min2' cnode_offs_max2' cnode_offs_range_def add.commute) + apply (rule is_aligned_add) + apply (erule is_aligned_weaken) + apply simp + apply (rule_tac is_aligned_mult_triv1[where n=5, simplified]) + done + +lemma cnode_offs_in_range2: + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ cnode_offs_range Silc_cnode_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ cnode_offs_range Low_cnode_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ cnode_offs_range High_cnode_ptr" + by (simp_all add: cnode_offs_in_range2' s0_ptrs_aligned)+ + +lemma kh0H_dom_distinct2: + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ idle_tcb_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ High_tcb_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ Low_tcb_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ High_pool_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ Low_pool_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ irq_cnode_ptr" + "Silc_cnode_ptr + 0x20 * (x && mask 10) \ ntfn_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ idle_tcb_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ High_tcb_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ Low_tcb_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ High_pool_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ Low_pool_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ irq_cnode_ptr" + "Low_cnode_ptr + 0x20 * (x && mask 10) \ ntfn_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ idle_tcb_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ High_tcb_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ Low_tcb_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ High_pool_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ Low_pool_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ irq_cnode_ptr" + "High_cnode_ptr + 0x20 * (x && mask 10) \ ntfn_ptr" + by (cut_tac x=x in cnode_offs_in_range2(1), fastforce simp: kh0H_dom_distinct + | cut_tac x=x in cnode_offs_in_range2(2), fastforce simp: kh0H_dom_distinct + | cut_tac x=x in cnode_offs_in_range2(3), fastforce simp: kh0H_dom_distinct)+ + +lemma kh0H_cnode_simps2[simp]: + "kh0H (Low_cnode_ptr + 0x20 * (x && mask 10)) = Low_cte Low_cnode_ptr (Low_cnode_ptr + 0x20 * (x && mask 10))" + "kh0H (High_cnode_ptr + 0x20 * (x && mask 10)) = High_cte High_cnode_ptr (High_cnode_ptr + 0x20 * (x && mask 10))" + "kh0H (Silc_cnode_ptr + 0x20 * (x && mask 10)) = Silc_cte Silc_cnode_ptr (Silc_cnode_ptr + 0x20 * (x && mask 10))" + supply option.case_cong[cong] if_cong[cong] + by (clarsimp simp: kh0H_def option_update_range_def cnode_offs_in_range' s0_ptrs_aligned + kh0H_dom_distinct kh0H_dom_distinct2 not_in_range_None, + ((clarsimp simp: cnode_offs_in_range2 kh0H_dom_sets_distinct[THEN orthD1] not_in_range_None + | clarsimp simp: cnode_offs_in_range2 kh0H_dom_sets_distinct[THEN orthD2] not_in_range_None)+), + intro conjI, + (clarsimp, drule not_disjointI, + (rule irq_node_offs_in_range cnode_offs_in_range2 | erule offs_in_range), + (rule irq_node_offs_in_range cnode_offs_in_range2 | erule offs_in_range), + erule notE, rule kh0H_dom_sets_distinct)+, + clarsimp split: option.splits)+ + +lemma cnode_offs_aligned2: + "is_aligned (Low_cnode_ptr + 0x20 * (addr && mask 10)) 5" + "is_aligned (High_cnode_ptr + 0x20 * (addr && mask 10)) 5" + "is_aligned (Silc_cnode_ptr + 0x20 * (addr && mask 10)) 5" + by (rule is_aligned_add, rule is_aligned_weaken, rule s0_ptrs_aligned, + simp, rule is_aligned_mult_triv1[where n=5, simplified])+ + +lemma less_t2n_ex_ucast: + "\ (x::'a::len word) < 2 ^ n; len_of TYPE('b) = n \ \ \y. x = ucast (y::'b::len word)" + apply (rule_tac x="ucast x" in exI) + apply (rule ucast_ucast_len[symmetric]) + apply simp + done + +lemma pd_offs_aligned: + "is_aligned (Low_pd_ptr + (ucast (x :: pt_index) << 3)) 3" + "is_aligned (High_pd_ptr + (ucast (x :: pt_index) << 3)) 3" + by (rule is_aligned_add[OF _ is_aligned_shift], simp add: s0_ptr_defs is_aligned_def)+ + +lemma less_VSRootBits_exists_ucast: + "p < 2 ^ ptTranslationBits VSRootPT_T \ \p'. p = UCAST(vs_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ vs_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps) + done + +lemma less_eq_0x1FF_exists_ucast: + "p \ 0x1FF \ \p'. p = UCAST(9 \ 64) p'" + apply (rule_tac x="UCAST(64 \ 9) p" in exI) + apply word_bitwise + apply clarsimp + done + +lemma less_pageBits_exists_ucast: + "p < 2 ^ (pageBitsForSize max_page_size - pageBits) \ \p'. p = UCAST(pg_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ pg_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps split: if_splits) + done + +lemma koTypeOf_PTET[simp]: + "koTypeOf ko = ArchT PTET \ (\pte. ko = KOArch (KOPTE pte))" + apply (case_tac ko; clarsimp) + apply (case_tac x8; clarsimp) + done + +lemma valid_caps_s0H[simp]: + notes pteBits_def[simp] objBits_defs[simp] + shows + "valid_cap' NullCap s0H_internal" + "valid_cap' (ThreadCap Low_tcb_ptr) s0H_internal" + "valid_cap' (ThreadCap High_tcb_ptr) s0H_internal" + "valid_cap' (CNodeCap Low_cnode_ptr 10 2 10) s0H_internal" + "valid_cap' (CNodeCap High_cnode_ptr 10 2 10) s0H_internal" + "valid_cap' (CNodeCap Silc_cnode_ptr 10 2 10) s0H_internal" + "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite max_page_size False (Some (ucast Low_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size False (Some (ucast High_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size False (Some (ucast Silc_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (ucast Low_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (ucast High_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0)))) s0H_internal" + "valid_cap' (ArchObjectCap (ASIDPoolCap Low_pool_ptr (ucast Low_asid))) s0H_internal" + "valid_cap' (ArchObjectCap (ASIDPoolCap High_pool_ptr (ucast High_asid))) s0H_internal" + "valid_cap' (NotificationCap ntfn_ptr 0 True False) s0H_internal" + "valid_cap' (NotificationCap ntfn_ptr 0 False True) s0H_internal" + "valid_cap' (ReplyCap Low_tcb_ptr True True) s0H_internal" + "valid_cap' (ReplyCap High_tcb_ptr True True) s0H_internal" + supply option.case_cong[cong] if_cong[cong] + apply (simp | simp add: valid_cap'_def s0H_internal_def capAligned_def word_bits_def + objBits_def s0_ptrs_aligned obj_at'_def, + intro conjI, simp add: objBitsKO_def s0_ptrs_aligned, simp add: objBitsKO_def, + simp add: objBitsKO_def s0_ptrs_aligned mask_def, + rule pspace_distinctD'[OF _ s0H_pspace_distinct', simplified s0H_internal_def], + simp)+ + apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) + apply (intro conjI) + apply (simp add: objBitsKO_def s0_ptrs_aligned) + apply (simp add: objBitsKO_def) + apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) + apply (clarsimp simp: Low_cte_def Low_cte'_def Low_capsH_def cnode_offs_min2 objBitsKO_def + cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned empty_cte_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: Low_cte_def Low_cte'_def Low_capsH_def empty_cte_def objBitsKO_def + cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) + apply (intro conjI) + apply (simp add: objBitsKO_def s0_ptrs_aligned) + apply (simp add: objBitsKO_def) + apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) + apply (clarsimp simp: High_cte_def High_cte'_def High_capsH_def cnode_offs_min2 cnode_offs_max2 + cnode_offs_aligned2 add.commute s0_ptrs_aligned objBitsKO_def empty_cte_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: High_cte_def High_cte'_def High_capsH_def empty_cte_def objBitsKO_def + cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply (simp add: valid_cap'_def capAligned_def word_bits_def objBits_def s0_ptrs_aligned obj_at'_def) + apply (intro conjI) + apply (simp add: objBitsKO_def s0_ptrs_aligned) + apply (simp add: objBitsKO_def) + apply (simp add: objBitsKO_def s0_ptrs_aligned mask_def) + apply (clarsimp simp: Silc_cte_def Silc_cte'_def Silc_capsH_def cnode_offs_min2 objBitsKO_def + empty_cte_def cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: Silc_cte_def Silc_cte'_def Silc_capsH_def empty_cte_def objBitsKO_def + cnode_offs_min2 cnode_offs_max2 cnode_offs_aligned2 add.commute s0_ptrs_aligned) + (* FIXME AARCH64 IF: boilerplate *) + apply (clarsimp simp: valid_cap'_def) + apply (intro conjI) + apply (auto simp: valid_cap'_def capAligned_def word_bits_def s0_ptrs_aligned + Low_asid_def High_asid_def Silc_asid_def asid_bits_defs bit_simps + vmsz_aligned_def frame_at'_def typ_at'_def ko_wp_at'_def + s0_ptr_defs is_aligned_def + wellformed_mapdata'_def asid_wf_def mask_def)[3] + apply (clarsimp simp: frame_at'_def typ_at'_def ko_wp_at'_def) + apply (drule less_pageBits_exists_ucast) + apply (clarsimp simp: pageBits_def objBitsKO_def s0_ptrs_aligned) + apply (rule conjI) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + + apply (clarsimp simp: valid_cap'_def) + apply (intro conjI) + apply (auto simp: valid_cap'_def capAligned_def word_bits_def s0_ptrs_aligned + Low_asid_def High_asid_def Silc_asid_def asid_bits_defs bit_simps + vmsz_aligned_def frame_at'_def typ_at'_def ko_wp_at'_def + s0_ptr_defs is_aligned_def + wellformed_mapdata'_def asid_wf_def mask_def)[3] + apply (clarsimp simp: frame_at'_def typ_at'_def ko_wp_at'_def) + apply (drule less_pageBits_exists_ucast) + apply (clarsimp simp: pageBits_def objBitsKO_def s0_ptrs_aligned) + apply (rule conjI) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + + apply (clarsimp simp: valid_cap'_def) + apply (intro conjI) + apply (auto simp: valid_cap'_def capAligned_def word_bits_def s0_ptrs_aligned + Low_asid_def High_asid_def Silc_asid_def asid_bits_defs bit_simps + vmsz_aligned_def frame_at'_def typ_at'_def ko_wp_at'_def + s0_ptr_defs is_aligned_def + wellformed_mapdata'_def asid_wf_def mask_def)[3] + apply (clarsimp simp: frame_at'_def typ_at'_def ko_wp_at'_def) + apply (drule less_pageBits_exists_ucast) + apply (clarsimp simp: pageBits_def objBitsKO_def s0_ptrs_aligned) + apply (rule conjI) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + + apply ((clarsimp simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + bit_simps mask_def archObjSize_def pt_offs_min objBitsKO_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def + dest!: less_eq_0x1FF_exists_ucast, safe, + rule pspace_distinctD''[OF _ s0H_pspace_distinct'], + simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def, + clarsimp simp: is_aligned_mask mask_def s0_ptr_defs, word_bitwise, + fastforce simp: pt_offs_max add.commute)+)[4] + + apply (clarsimp simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + mask_def archObjSize_def pt_offs_min objBitsKO_def pte_bits_def word_size_bits_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def, safe) + apply (rule is_aligned_weaken, rule s0_ptrs_aligned, simp add: bit_simps, simp add: bit_simps) + apply ((clarsimp simp: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + mask_def archObjSize_def pt_offs_min objBitsKO_def pte_bits_def word_size_bits_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def + dest!: less_VSRootBits_exists_ucast, safe)) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (simp add: add_mask_fold pt_offs_max) + + apply (clarsimp simp: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + mask_def archObjSize_def pt_offs_min objBitsKO_def pte_bits_def word_size_bits_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def, safe) + apply (rule is_aligned_weaken, rule s0_ptrs_aligned, simp add: bit_simps, simp add: bit_simps) + apply ((clarsimp simp: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned wellformed_mapdata'_def + mask_def archObjSize_def pt_offs_min objBitsKO_def pte_bits_def word_size_bits_def + page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def + dest!: less_VSRootBits_exists_ucast, safe)) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: pt_offs_min kh0H_obj_def archObjSize_def bit_simps objBitsKO_def) + apply (rule is_aligned_add) + apply (clarsimp simp: is_aligned_mask mask_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (simp add: add_mask_fold pt_offs_max) + + apply ((simp add: valid_cap'_def capAligned_def word_bits_def Low_asid_def High_asid_def + asid_bits_defs asid_wf_def s0_ptrs_aligned bit_simps wellformed_mapdata'_def + mask_def page_table_at'_def typ_at'_def ko_wp_at'_def kh0H_obj_def + objBitsKO_def archObjSize_def pt_offs_min, + intro conjI, clarsimp simp: is_aligned_mask mask_def s0_ptr_defs, + rule pspace_distinctD''[OF _ s0H_pspace_distinct'], + simp add: kh0H_obj_def archObjSize_def bit_simps objBitsKO_def)+)[2] + by (simp add: valid_cap'_def s0H_internal_def capAligned_def word_bits_def objBits_def obj_at'_def, + intro conjI, simp add: objBitsKO_def s0_ptrs_aligned, simp add: objBitsKO_def, + simp add: objBitsKO_def s0_ptrs_aligned mask_def, + rule pspace_distinctD'[OF _ s0H_pspace_distinct', simplified s0H_internal_def], simp)+ + +text \We can only instantiate our example state (featuring high and low domains) if the number + of configured domains is > 1, i.e. that maxDomain is 1 or greater. When seL4 is configured for a + single domain only, none of the state instantiation proofs below are relevant.\ + +lemma s0H_valid_objs': + "1 \ maxDomain \ valid_objs' s0H_internal" + supply objBits_defs[simp] + apply (clarsimp simp: valid_objs'_def ran_def) + apply (drule kh0H_SomeD) + apply (elim disjE) + apply (clarsimp simp: valid_obj'_def ntfnH_def valid_ntfn'_def obj_at'_def) + apply (rule conjI) + apply (clarsimp simp: is_aligned_def s0_ptr_defs objBitsKO_def) + apply (clarsimp simp: pspace_distinctD'[OF _ s0H_pspace_distinct']) + apply (clarsimp simp: valid_obj'_def valid_tcb'_def valid_tcb_state'_def + Low_domain_def minBound_word valid_arch_tcb'_def + Low_mcp_def Low_prio_def maxPriority_def numPriorities_def + tcb_cte_cases_def Low_capsH_def kh0H_obj_def) + apply (clarsimp simp: valid_obj'_def valid_tcb'_def valid_tcb_state'_def + High_domain_def minBound_word valid_arch_tcb'_def + High_mcp_def High_prio_def maxPriority_def numPriorities_def + tcb_cte_cases_def High_capsH_def obj_at'_def kh0H_obj_def) + apply (rule conjI) + apply (simp add: is_aligned_def s0_ptr_defs objBitsKO_def) + apply (clarsimp simp: ntfnH_def pspace_distinctD'[OF _ s0H_pspace_distinct']) + apply (clarsimp simp: valid_obj'_def valid_tcb'_def kh0H_obj_def valid_tcb_state'_def + default_domain_def minBound_word valid_arch_tcb'_def + default_priority_def tcb_cte_cases_def) + defer 2 + apply (auto simp: is_aligned_def addrFromPPtr_def ptrFromPAddr_def pptrBaseOffset_def + valid_obj'_def s0_ptr_defs kh0H_obj_def valid_arch_obj'_def bit_simps + kh0H_all_obj_def canonical_address_def canonical_address_of_def paddrBase_def)[5] + apply (auto simp: valid_obj'_def valid_cte'_def empty_cte_def irq_cte_def + valid_arch_obj'_def kh0H_all_obj_def + Low_cte_def Low_cte'_def Low_capsH_def + High_cte_def High_cte'_def High_capsH_def + Silc_cte_def Silc_cte'_def Silc_capsH_def) + done + +lemmas the_nat_to_bl_simps = the_nat_to_bl_def nat_to_bl_def + +lemma ucast_shiftr_13E: + "\ ucast (p - ptr >> 5) = (0x13E :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5 \ + \ p = (ptr :: obj_ref) + 0x27C0" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x27C0" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_6: + "\ ucast (p - ptr >> 5) = (0x6 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0xC0" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0xC0" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_5: + "\ ucast (p - ptr >> 5) = (5 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0xA0" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0xA0" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_4: + "\ ucast (p - ptr >> 5) = (4 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0x80" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x80" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_3: + "\ucast (p - ptr >> 5) = (3 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0x60" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x60" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_2: + "\ucast (p - ptr >> 5) = (2 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0x40" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x40" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemma ucast_shiftr_1: + "\ucast (p - ptr >> 5) = (1 :: 10 word); p \ 0x7FFF + ptr; ptr \ p; + is_aligned ptr 15; is_aligned p 5\ + \ p = (ptr :: obj_ref) + 0x20" + apply (subst(asm) up_ucast_inj_eq[symmetric, where 'b=64]) + apply simp + apply simp + apply (subst(asm) ucast_ucast_len) + apply simp + apply (rule shiftr_less_t2n[where m=10, simplified]) + apply simp + apply (rule word_leq_minus_one_le) + apply simp + apply simp + apply (rule word_diff_ls') + apply simp + apply simp + apply (drule shiftr_eqD[where y="0x20" and n=5 and 'a=64, simplified]) + apply (erule(1) aligned_sub_aligned[OF _ is_aligned_weaken]) + apply simp + apply simp + apply (simp add: is_aligned_def) + apply (simp add: diff_eq_eq) + done + +lemmas kh0H_all_obj_def' = Low_cte_cte_def High_cte_cte_def Silc_cte_cte_def + Low_tcb_cte_def High_tcb_cte_def idle_tcb_cte_def kh0H_all_obj_def + +lemma map_to_ctes_kh0H_simps'[simp]: + "map_to_ctes kh0H (Low_cnode_ptr + 0x20) = Some (CTE (ThreadCap Low_tcb_ptr) Null_mdb)" + "map_to_ctes kh0H (Low_cnode_ptr + 0x40) = Some (CTE (CNodeCap Low_cnode_ptr 10 2 10) + (MDB 0 Low_tcb_ptr False False))" + "map_to_ctes kh0H (Low_cnode_ptr + 0x60) = Some (CTE (ArchObjectCap (PageTableCap Low_pd_ptr VSRootPT_T (Some (ucast Low_asid, 0)))) + (MDB 0 (Low_tcb_ptr + 0x20) False False))" + "map_to_ctes kh0H (Low_cnode_ptr + 0x80) = Some (CTE (ArchObjectCap (ASIDPoolCap Low_pool_ptr (ucast Low_asid))) Null_mdb)" + "map_to_ctes kh0H (Low_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadWrite max_page_size + False (Some (ucast Low_asid, 0)))) + (MDB 0 (Silc_cnode_ptr + 0xA0) False False))" + "map_to_ctes kh0H (Low_cnode_ptr + 0xC0) = Some (CTE (ArchObjectCap (PageTableCap Low_pt_ptr NormalPT_T (Some (ucast Low_asid, 0)))) Null_mdb)" + "map_to_ctes kh0H (Low_cnode_ptr + 0x27C0) = Some (CTE (NotificationCap ntfn_ptr 0 True False) + (MDB (Silc_cnode_ptr + 0x27C0) 0 False False))" + "map_to_ctes kh0H (High_cnode_ptr + 0x20) = Some (CTE (ThreadCap High_tcb_ptr) Null_mdb)" + "map_to_ctes kh0H (High_cnode_ptr + 0x40) = Some (CTE (CNodeCap High_cnode_ptr 10 2 10) (MDB 0 High_tcb_ptr False False))" + "map_to_ctes kh0H (High_cnode_ptr + 0x60) = Some (CTE (ArchObjectCap (PageTableCap High_pd_ptr VSRootPT_T (Some (ucast High_asid, 0)))) + (MDB 0 (High_tcb_ptr + 0x20) False False))" + "map_to_ctes kh0H (High_cnode_ptr + 0x80) = Some (CTE (ArchObjectCap (ASIDPoolCap High_pool_ptr (ucast High_asid))) Null_mdb)" + "map_to_ctes kh0H (High_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size + False (Some (ucast High_asid, 0)))) + (MDB (Silc_cnode_ptr + 0xA0) 0 False False))" + "map_to_ctes kh0H (High_cnode_ptr + 0xC0) = Some (CTE (ArchObjectCap (PageTableCap High_pt_ptr NormalPT_T (Some (ucast High_asid, 0)))) Null_mdb)" + "map_to_ctes kh0H (High_cnode_ptr + 0x27C0) = Some (CTE (NotificationCap ntfn_ptr 0 False True) + (MDB 0 (Silc_cnode_ptr + 0x27C0) False False))" + "map_to_ctes kh0H (Silc_cnode_ptr + 0x40) = Some (CTE (CNodeCap Silc_cnode_ptr 10 2 10) Null_mdb)" + "map_to_ctes kh0H (Silc_cnode_ptr + 0xA0) = Some (CTE (ArchObjectCap (FrameCap shared_page_ptr_virt VMReadOnly max_page_size + False (Some (ucast Silc_asid, 0)))) + (MDB (Low_cnode_ptr + 0xA0) (High_cnode_ptr + 0xA0) False False))" + "map_to_ctes kh0H (Silc_cnode_ptr + 0x27C0) = Some (CTE (NotificationCap ntfn_ptr 0 True False) + (MDB (High_cnode_ptr + 318 * 0x20) (Low_cnode_ptr + 318 * 0x20) False False))" + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 1", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 2", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 3", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 4", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 5", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 6", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(3)[where x="the_nat_to_bl_10 318", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 1", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 2", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 3", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 4", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 5", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 6", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(4)[where x="the_nat_to_bl_10 318", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(5)[where x="the_nat_to_bl_10 2", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(5)[where x="the_nat_to_bl_10 5", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + apply (clarsimp simp: map_to_ctes_kh0H_simps(5)[where x="the_nat_to_bl_10 318", simplified the_nat_to_bl_simps, simplified] + kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps, fastforce simp: s0_ptr_defs is_aligned_def) + done + +lemma mdb_next_s0H: + "p' \ 0 + \ map_to_ctes kh0H \ p \ p' = + (p = Low_cnode_ptr + 0x27C0 \ p' = Silc_cnode_ptr + 0x27C0 \ + p = Silc_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0 \ + p = High_cnode_ptr + 0xA0 \ p' = Silc_cnode_ptr + 0xA0 \ + p = Silc_cnode_ptr + 0xA0 \ p' = Low_cnode_ptr + 0xA0 \ + p = Low_tcb_ptr \ p' = Low_cnode_ptr + 0x40 \ + p = Low_tcb_ptr + 0x20 \ p' = Low_cnode_ptr + 0x60 \ + p = High_tcb_ptr \ p' = High_cnode_ptr + 0x40 \ + p = High_tcb_ptr + 0x20 \ p' = High_cnode_ptr + 0x60)" + apply (rule iffI) + apply (simp add: next_unfold') + apply (elim exE conjE) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_13E ucast_shiftr_5 s0_ptrs_aligned + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_5 s0_ptrs_aligned + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_13E ucast_shiftr_5 s0_ptrs_aligned + split: if_split_asm) + apply (clarsimp simp: next_unfold') + apply (elim disjE, simp_all add: kh0H_all_obj_def') + done + +lemma mdb_prev_s0H: + "p \ 0 + \ map_to_ctes kh0H \ p \ p' = + (p = Low_cnode_ptr + 0x27C0 \ p' = Silc_cnode_ptr + 0x27C0 \ + p = Silc_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0 \ + p = High_cnode_ptr + 0xA0 \ p' = Silc_cnode_ptr + 0xA0 \ + p = Silc_cnode_ptr + 0xA0 \ p' = Low_cnode_ptr + 0xA0 \ + p = Low_tcb_ptr \ p' = Low_cnode_ptr + 0x40 \ + p = Low_tcb_ptr + 0x20 \ p' = Low_cnode_ptr + 0x60 \ + p = High_tcb_ptr \ p' = High_cnode_ptr + 0x40 \ + p = High_tcb_ptr + 0x20 \ p' = High_cnode_ptr + 0x60)" + apply (rule iffI) + apply (simp add: mdb_prev_def) + apply (elim exE conjE) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all)[1] + apply clarsimp + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_13E ucast_shiftr_5 s0_ptrs_aligned + split: if_split_asm) + apply clarsimp + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_13E ucast_shiftr_3 ucast_shiftr_2 s0_ptrs_aligned + split: if_split_asm) + apply clarsimp + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + ucast_shiftr_5 ucast_shiftr_3 ucast_shiftr_2 s0_ptrs_aligned + split: if_split_asm) + apply (clarsimp simp: mdb_prev_def map_to_ctes_kh0H_dom) + apply (elim disjE, simp_all add: kh0H_all_obj_def') + done + +lemma mdb_next_trancl_s0H: + "p' \ 0 + \ map_to_ctes kh0H \ p \\<^sup>+ p' = + (p = Low_cnode_ptr + 0x27C0 \ p' = Silc_cnode_ptr + 0x27C0 \ + p = Silc_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0 \ + p = Low_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0 \ + p = High_cnode_ptr + 0xA0 \ p' = Silc_cnode_ptr + 0xA0 \ + p = Silc_cnode_ptr + 0xA0 \ p' = Low_cnode_ptr + 0xA0 \ + p = High_cnode_ptr + 0xA0 \ p' = Low_cnode_ptr + 0xA0 \ + p = Low_tcb_ptr \ p' = Low_cnode_ptr + 0x40 \ + p = Low_tcb_ptr + 0x20 \ p' = Low_cnode_ptr + 0x60 \ + p = High_tcb_ptr \ p' = High_cnode_ptr + 0x40 \ + p = High_tcb_ptr + 0x20 \ p' = High_cnode_ptr + 0x60)" + apply (rule iffI) + apply (erule converse_trancl_induct) + apply (clarsimp simp: mdb_next_s0H) + apply (subst (asm) mdb_next_s0H) + apply (clarsimp simp: s0_ptr_defs) + apply (clarsimp simp: s0_ptr_defs del: disjCI) + subgoal for y by ((erule_tac P="y = _ \ _" in disjE | clarsimp)+)[1] + apply (elim disjE) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_r_into_trancl[where b="Silc_cnode_ptr + 0x27C0"]) + apply (simp add: mdb_next_s0H s0_ptr_defs) + apply (simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_r_into_trancl[where b="Silc_cnode_ptr + 0xA0"]) + apply (simp add: mdb_next_s0H s0_ptr_defs) + apply (simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + apply (rule r_into_trancl, simp add: mdb_next_s0H) + done + +lemma mdb_next_rtrancl_not_0_s0H: + "\ map_to_ctes kh0H \ p \\<^sup>* p'; p' \ 0 \ \ p \ 0" + apply (drule rtranclD) + apply (clarsimp simp: mdb_next_trancl_s0H s0_ptr_defs) + done + +lemma sameRegionAs_s0H: + "\ map_to_ctes kh0H p = Some (CTE cap mdb); map_to_ctes kh0H p' = Some (CTE cap' mdb'); + sameRegionAs cap cap'; p \ p' \ + \ (p = Low_cnode_ptr + 0x27C0 \ (p' = Silc_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0) \ + p = Silc_cnode_ptr + 0x27C0 \ (p' = Low_cnode_ptr + 0x27C0 \ p' = High_cnode_ptr + 0x27C0) \ + p = High_cnode_ptr + 0x27C0 \ (p' = Low_cnode_ptr + 0x27C0 \ p' = Silc_cnode_ptr + 0x27C0) \ + p = Low_cnode_ptr + 0xA0 \ (p' = Silc_cnode_ptr + 0xA0 \ p' = High_cnode_ptr + 0xA0) \ + p = Silc_cnode_ptr + 0xA0 \ (p' = Low_cnode_ptr + 0xA0 \ p' = High_cnode_ptr + 0xA0) \ + p = High_cnode_ptr + 0xA0 \ (p' = Low_cnode_ptr + 0xA0 \ p' = Silc_cnode_ptr + 0xA0) \ + p = Low_tcb_ptr \ p' = Low_cnode_ptr + 0x40 \ + p = Low_cnode_ptr + 0x40 \ p' = Low_tcb_ptr \ + p = Low_tcb_ptr + 0x20 \ p' = Low_cnode_ptr + 0x60 \ + p = Low_cnode_ptr + 0x60 \ p' = Low_tcb_ptr + 0x20 \ + p = High_tcb_ptr \ p' = High_cnode_ptr + 0x40 \ + p = High_cnode_ptr + 0x40 \ p' = High_tcb_ptr \ + p = High_tcb_ptr + 0x20 \ p' = High_cnode_ptr + 0x60 \ + p = High_cnode_ptr + 0x60 \ p' = High_tcb_ptr + 0x20)" + supply option.case_cong[cong] if_cong[cong] s0_ptrs_aligned[simp] + apply (frule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def isCap_simps)[1] + apply (clarsimp simp: kh0H_all_obj_def' s0_ptr_defs split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' s0_ptr_defs split: if_split_asm) + apply (clarsimp simp: to_bl_use_of_bl the_nat_to_bl_simps kh0H_all_obj_def' ucast_shiftr_2 + split: if_split_asm) + apply ((frule_tac x=p' in map_to_ctes_kh0H_SomeD, + (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps)[1], + ((clarsimp simp: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps to_bl_use_of_bl + the_nat_to_bl_simps kh0H_all_obj_def' ucast_shiftr_2 ucast_shiftr_3 + split: if_split_asm)+)[3])+)[5] + apply (clarsimp simp: kh0H_all_obj_def' split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def isCap_simps)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + split: if_split_asm) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def isCap_simps)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + split: if_split_asm) + apply (drule(2) ucast_shiftr_6; clarsimp) + apply (drule(2) ucast_shiftr_6; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_4; clarsimp) + apply (drule(2) ucast_shiftr_4; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_3; clarsimp) + apply (drule(2) ucast_shiftr_3; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_1; clarsimp) + apply (drule(2) ucast_shiftr_1; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def isCap_simps)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_13E + split: if_split_asm) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (drule(2) ucast_shiftr_13E; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_6; clarsimp) + apply (drule(2) ucast_shiftr_6; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps + split: if_split_asm) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (drule(2) ucast_shiftr_5; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_4; clarsimp) + apply (drule(2) ucast_shiftr_4; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_3; clarsimp) + apply (drule(2) ucast_shiftr_3; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (drule(2) ucast_shiftr_2; clarsimp) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def isCap_simps + split: if_split_asm)[1] + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps ucast_shiftr_3 + split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (clarsimp simp: kh0H_all_obj_def' to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_1; clarsimp) + apply (drule(2) ucast_shiftr_1; clarsimp) + done + +lemma mdb_prevI: + "m p = Some c \ m \ mdbPrev (cteMDBNode c) \ p" + by (simp add: mdb_prev_def) + +lemma mdb_nextI: + "m p = Some c \ m \ p \ mdbNext (cteMDBNode c)" + by (simp add: mdb_next_unfold) + +lemma above_pptr_base_canonical: + "\ pptr_base \ p; p \ pptrTop - 1 \ \ canonical_address p" + apply (simp add: canonical_address_range pptr_base_def pptrBase_def NOT_mask canonical_bit_def pptrTop_def mask_def) + apply (erule order.trans) + apply clarsimp + done + +lemma s0H_valid_pspace': + notes pteBits_def[simp] objBits_defs[simp] + notes valid_arch_badges_def[simp] mdb_chunked_arch_assms_def[simp] + assumes "1 \ maxDomain" + shows "valid_pspace' s0H_internal" + using assms + supply option.case_cong[cong] if_cong[cong] + apply (clarsimp simp: valid_pspace'_def s0H_pspace_distinct' s0H_valid_objs') + apply (intro conjI) + apply (clarsimp simp: pspace_aligned'_def) + apply (drule kh0H_SomeD) + apply (elim disjE; clarsimp simp: s0_ptr_defs kh0H_all_obj_def objBitsKO_def archObjSize_def + cnode_offs_range_def page_offs_range_def pt_offs_range_def + irq_node_offs_range_def is_aligned_mask mask_def bit_simps + split: if_splits) + apply (clarsimp simp: pspace_canonical'_def) + apply (drule kh0H_SomeD') + apply (rule above_pptr_base_canonical) + apply (fastforce elim: dual_order.trans + intro: above_pptr_base_canonical + simp: irq_node_offs_range_def cnode_offs_range_def pptrTop_def + pt_offs_range_def page_offs_range_def s0_ptr_defs) + apply (elim disjE; clarsimp simp: irq_node_offs_range_def2 cnode_offs_range_def pptrTop_def + pt_offs_range_def page_offs_range_def s0_ptr_defs bit_simps mask_def + split: if_splits) + apply (fastforce elim: order.trans)+ + apply (clarsimp simp: no_0_obj'_def) + apply (rule ccontr, clarsimp) + apply (drule kh0H_SomeD) + apply (simp add: irq_node_offs_range_def cnode_offs_range_def + page_offs_range_def pt_offs_range_def s0_ptr_defs) + apply (simp add: valid_mdb'_def) + apply (clarsimp simp: valid_mdb_ctes_def) + apply (intro conjI) + apply (clarsimp simp: valid_dlist_def3) + apply (rule conjI) + apply (clarsimp simp: mdb_next_s0H) + apply (subst mdb_prev_s0H) + apply (fastforce simp: s0_ptr_defs) + apply simp + apply (clarsimp simp: mdb_prev_s0H) + apply (subst mdb_next_s0H) + apply (fastforce simp: s0_ptr_defs) + apply simp + apply (clarsimp simp: no_0_def) + apply (rule ccontr) + apply clarsimp + apply (drule map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: irq_node_offs_range_def + cnode_offs_range_def s0_ptr_defs)+)[1] + apply (clarsimp simp: mdb_chain_0_def) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE) + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[5] + apply ((rule r_r_into_trancl[OF next_fold next_fold], simp+)+)[2] + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[3] + apply ((rule r_r_into_trancl[OF next_fold next_fold], simp+)+)[2] + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[5] + apply (clarsimp simp: kh0H_all_obj_def Silc_cte_cte_def cnode_offs_range_def + split: if_split_asm) + apply ((rule r_r_into_trancl[OF next_fold next_fold], simp+)+)[2] + apply (erule r_into_trancl[OF next_fold], simp) + apply (erule r_into_trancl[OF next_fold], simp) + apply (clarsimp simp: kh0H_all_obj_def High_cte_cte_def cnode_offs_range_def + split: if_split_asm) + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[2] + apply (rule trancl_into_trancl2[OF next_fold], simp+)[1] + apply (rule r_r_into_trancl[OF next_fold next_fold], simp+)[1] + apply ((erule r_into_trancl[OF next_fold], clarsimp)+)[5] + apply (clarsimp simp: kh0H_all_obj_def Low_cte_cte_def cnode_offs_range_def + split: if_split_asm) + apply (rule trancl_into_trancl2[OF next_fold], simp+)[1] + apply (rule r_r_into_trancl[OF next_fold next_fold], simp+)[1] + apply (erule r_into_trancl[OF next_fold], simp)+ + apply (clarsimp simp: valid_badges_def) + apply (rule conjI) + apply (frule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: Low_cte_cte_def High_cte_cte_def Silc_cte_cte_def + kh0H_all_obj_def isCap_simps + split: if_split_asm)+)[1] + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: Low_cte_cte_def High_cte_cte_def Silc_cte_cte_def + kh0H_all_obj_def isCap_simps sameRegionAs_def + split: if_split_asm)+)[1] + apply (intro conjI impI) + apply (clarsimp simp: High_cte_cte_def kh0H_all_obj_def isCap_simps split: if_split_asm) + apply (drule(1) sameRegion_ntfn) + apply (clarsimp simp: High_cte_cte_def kh0H_all_obj_def isCap_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: High_cte_cte_def Low_cte_cte_def + Silc_cte_cte_def kh0H_all_obj_def + split: if_split_asm)+)[1] + apply (intro conjI impI) + apply (clarsimp simp: Low_cte_cte_def kh0H_all_obj_def isCap_simps split: if_split_asm) + apply (drule(1) sameRegion_ntfn) + apply (clarsimp simp: Low_cte_cte_def kh0H_all_obj_def isCap_simps split: if_split_asm) + apply (frule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: High_cte_cte_def Low_cte_cte_def + Silc_cte_cte_def kh0H_all_obj_def + split: if_split_asm)+)[1] + apply (case_tac "p' = 0") + apply clarsimp + apply (frule_tac x=0 in map_to_ctes_kh0H_SomeD) + apply (clarsimp simp: s0_ptr_defs irq_node_offs_range_def cnode_offs_range_def) + apply (clarsimp simp: mdb_next_s0H) + apply (auto simp: isArchSGISignalCap_def)[1] + apply (clarsimp simp: caps_contained'_def) + apply (drule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all)[1] + apply (clarsimp simp: Silc_cte_cte_def kh0H_all_obj_def split: if_split_asm) + apply (clarsimp simp: High_cte_cte_def kh0H_all_obj_def split: if_split_asm) + apply (clarsimp simp: Low_cte_cte_def kh0H_all_obj_def split: if_split_asm) + apply (clarsimp simp: mdb_chunked_def) + apply (frule sameRegionAs_s0H, simp, simp, simp) + apply (clarsimp simp: conj_disj_distribL) + apply (prop_tac "p \ 0 \ p' \ 0") + apply (elim disjE; clarsimp simp: s0_ptr_defs) + apply (intro conjI; clarsimp) + apply (simp add: mdb_next_trancl_s0H) + apply (elim disjE, simp_all)[1] + apply (thin_tac "_ \ _") + apply (clarsimp simp: mdb_next_trancl_s0H) + apply (elim disjE) + apply ((clarsimp simp: is_chunk_def, + drule mdb_next_rtrancl_not_0_s0H, fastforce simp: s0_ptr_defs, + clarsimp simp: mdb_next_trancl_s0H, + (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def + isCap_simps kh0H_all_obj_def' + , (fastforce simp: s0_ptr_defs)+)[1])+)[10] + apply (thin_tac "_ \ _") + apply (clarsimp simp: mdb_next_trancl_s0H) + apply (elim disjE) + apply ((clarsimp simp: is_chunk_def, + drule mdb_next_rtrancl_not_0_s0H, fastforce simp: s0_ptr_defs, + clarsimp simp: mdb_next_trancl_s0H, + (elim disjE, simp_all add: sameRegionAs_def AARCH64_H.sameRegionAs_def + isCap_simps kh0H_all_obj_def' + , (fastforce simp: s0_ptr_defs)+)[1])+)[10] + apply (clarsimp simp: untyped_mdb'_def) + apply (drule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: untyped_inc'_def) + apply (rule FalseE) + apply (drule_tac x=p in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: valid_nullcaps_def) + apply (drule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: kh0H_all_obj_def' nullMDBNode_def) + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: ut_revocable'_def) + apply (drule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: class_links_def) + apply (subst(asm) mdb_next_s0H) + apply (drule_tac x=p' in map_to_ctes_kh0H_SomeD) + apply (elim disjE, (clarsimp simp: s0_ptr_defs irq_node_offs_range_def cnode_offs_range_def)+)[1] + apply (elim disjE, (clarsimp simp: kh0H_all_obj_def')+)[1] + apply (clarsimp simp: distinct_zombies_def distinct_zombie_caps_def) + apply (drule_tac x=ptr in map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: irq_control_def) + apply (drule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (clarsimp simp: reply_masters_rvk_fb_def ran_def) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: isCap_simps kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + done + +end + + +(* Instantiate the current, abstract domain scheduler into the + concrete scheduler required for this example *) +axiomatization where + newKSDomSched: "newKSDomSchedule = [(0,0xA), (1, 0xA)]" + +axiomatization where + newKSDomainTime: "newKSDomainTime = 5" + +(* kernel_data_refs is an undefined constant at the moment, and therefore + cannot be referred to in valid_global_refs' and pspace_domain_valid. + We use an axiomatization for the moment. *) +axiomatization where + kdr_valid_global_refs': "valid_global_refs' s0H_internal" and + kdr_pspace_domain_valid: "pspace_domain_valid s0H_internal" + + +context begin interpretation Arch . + +lemma ksArchState0H[simp]: + "ksArchState s0H_internal = arch_state0H" + by (simp add: s0H_internal_def) + +(* FIXME AARCH64: canonical_address no longer applicable to arm_global_pt_ptr instantiation + due to kernel ELF window changes *) +(* +lemma valid_arch_state_s0H: + "valid_arch_state' s0H_internal" + apply (clarsimp simp: valid_arch_state'_def) + apply (intro conjI) + apply (clarsimp simp: valid_asid_table'_def s0H_internal_def arch_state0H_def asid_bits_defs + asid_high_bits_of_def Low_asid_def High_asid_def mask_def s0_ptr_defs) + apply (clarsimp simp: arch_state0H_def) + apply (clarsimp simp: arch_state0H_def) + apply (clarsimp simp: arch_state0H_def max_armKSGICVCPUNumListRegs_def) + apply (clarsimp simp: arch_state0H_def s0_ptr_defs) + apply (clarsimp simp: canonical_address_def canonical_address_of_def addrFromKPPtr_def + kernelELFBaseOffset_def kernelELFBase_def kernelELFPAddrBase_def) + done +*) + +lemma timer_irq_not_outside_range[simp]: + "\ maxIRQ < timer_irq" + by (simp add: timer_irq_def) + +(* FIXME AARCH64 IF: uncomment after kernel ELF window changes addressed *) +(* +lemma s0H_invs: + assumes "1 \ maxDomain" + notes pteBits_def[simp] objBits_defs[simp] + shows "invs' s0H_internal" + using assms + supply option.case_cong[cong] if_cong[cong] + supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) + apply (clarsimp simp: invs'_def valid_state'_def s0H_valid_pspace') + apply (rule conjI) + apply (clarsimp simp: sch_act_wf_def ct_in_state'_def st_tcb_at'_def obj_at'_def + s0H_internal_def s0_ptrs_aligned objBitsKO_def Low_tcbH_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (rule conjI) + apply (clarsimp simp: sym_refs_def state_refs_of'_def refs_of'_def split: option.splits) + apply (frule kh0H_SomeD) + apply (elim disjE, simp_all)[1] + apply (clarsimp simp: ntfnH_def ntfn_q_refs_of'_def) + apply (rule conjI) + apply (clarsimp simp: tcb_st_refs_of'_def High_tcbH_def) + apply (clarsimp simp: objBitsKO_def s0_ptrs_aligned) + apply (erule notE, rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: objBitsKO_def) + apply (clarsimp simp: tcb_st_refs_of'_def Low_tcbH_def) + apply (clarsimp simp: tcb_st_refs_of'_def High_tcbH_def) + apply (rule conjI) + apply (clarsimp simp: ntfnH_def) + apply (clarsimp simp: objBitsKO_def ntfnH_def) + apply (erule impE, simp add: is_aligned_def s0_ptr_defs) + apply (erule notE, rule pspace_distinctD''[OF _ s0H_pspace_distinct']) + apply (simp add: objBitsKO_def ntfnH_def) + apply (clarsimp simp: tcb_st_refs_of'_def idle_tcbH_def) + apply (clarsimp simp: global_ptH_def split: if_splits) + apply (clarsimp simp: Low_ptH_def split: if_splits) + apply (clarsimp simp: High_ptH_def split: if_splits) + apply (clarsimp simp: Low_pdH_def split: if_splits) + apply (clarsimp simp: High_pdH_def split: if_splits) + apply (clarsimp simp: Low_cte_def Low_cte'_def split: if_split_asm) + apply (clarsimp simp: High_cte_def High_cte'_def split: if_split_asm) + apply (clarsimp simp: Silc_cte_def Silc_cte'_def split: if_split_asm) + apply (rule conjI) + apply (subgoal_tac "state_hyp_refs_of' s0H_internal = (\p. {})") + apply (clarsimp simp: sym_refs_def) + apply (rule ext, rule equals0I) + apply (clarsimp simp: state_hyp_refs_of'_def hyp_refs_of'_def tcb_vcpu_refs'_def + split: option.splits if_splits dest!: kh0H_SomeD) + apply (elim disjE; clarsimp simp: tcb_vcpu_refs'_def kh0H_all_obj_def split: if_splits) + apply (rule conjI) + apply (clarsimp simp: if_live_then_nonz_cap'_def ko_wp_at'_def) + apply (drule kh0H_SomeD) + apply (elim disjE, simp_all add: kh0H_all_obj_def' objBitsKO_def live'_def hyp_live'_def)[1] + apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) + apply (rule_tac x="Silc_cnode_ptr + 0x27C0" in exI) + apply (clarsimp simp: kh0H_all_obj_def') + apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) + apply (rule_tac x="Low_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def') + apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) + apply (rule_tac x="High_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def') + apply (clarsimp split: if_split_asm simp: live'_def hyp_live'_def arch_live'_def)+ + apply (rule conjI) + apply (clarsimp simp: if_unsafe_then_cap'_def ex_cte_cap_wp_to'_def cte_wp_at_ctes_of) + apply (frule map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: kh0H_all_obj_def')[1] + apply (rule_tac x="Low_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="Low_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="Low_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="High_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="High_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="High_cnode_ptr + 0x20" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def) + apply (rule_tac x="Silc_cnode_ptr + 0x40" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E, rule s0_ptrs_aligned, simp) + apply (rule_tac x="(0x27C0 >> 5)" in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_5, rule s0_ptrs_aligned, simp) + apply (rule_tac x=5 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_2, rule s0_ptrs_aligned, simp) + apply (rule_tac x=2 in bexI) + apply simp + apply (simp add: mask_def) + apply (rule_tac x="High_cnode_ptr + 0x40" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E, rule s0_ptrs_aligned, simp) + apply (rule_tac x="0x13E" in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_6, rule s0_ptrs_aligned, simp) + apply (rule_tac x=6 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_5, rule s0_ptrs_aligned, simp) + apply (rule_tac x=5 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_4, rule s0_ptrs_aligned, simp) + apply (rule_tac x=4 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_3, rule s0_ptrs_aligned, simp) + apply (rule_tac x=3 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_2, rule s0_ptrs_aligned, simp) + apply (rule_tac x=2 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_1, rule s0_ptrs_aligned, simp) + apply (rule_tac x=1 in bexI) + apply simp + apply (simp add: mask_def) + apply (rule_tac x="Low_cnode_ptr + 0x40" in exI) + apply (clarsimp simp: kh0H_all_obj_def' image_def to_bl_use_of_bl the_nat_to_bl_simps split: if_split_asm) + apply (drule(2) ucast_shiftr_13E, rule s0_ptrs_aligned, simp) + apply (rule_tac x="0x13E" in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_6, rule s0_ptrs_aligned, simp) + apply (rule_tac x=6 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_5, rule s0_ptrs_aligned, simp) + apply (rule_tac x=5 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_4, rule s0_ptrs_aligned, simp) + apply (rule_tac x=4 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_3, rule s0_ptrs_aligned, simp) + apply (rule_tac x=3 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_2, rule s0_ptrs_aligned, simp) + apply (rule_tac x=2 in bexI) + apply simp + apply (simp add: mask_def) + apply (drule(2) ucast_shiftr_1, rule s0_ptrs_aligned, simp) + apply (rule_tac x=1 in bexI) + apply simp + apply (simp add: mask_def) + apply (rule conjI) + apply (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def objBitsKO_def idle_tcb'_def) + apply (clarsimp simp: s0H_internal_def s0_ptrs_aligned idle_tcbH_def) + apply (rule conjI) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (clarsimp simp: idle_tcb_ptr_def idle_thread_ptr_def) + apply (rule conjI) + apply (clarsimp simp: kdr_valid_global_refs') (* use axiomatization for now *) + apply (rule conjI) + apply (clarsimp simp: valid_arch_state_s0H) + apply (rule conjI) + apply (clarsimp simp: valid_irq_node'_def) + apply (rule conjI) + apply (clarsimp simp: s0H_internal_def is_aligned_def s0_ptr_defs word_size) + apply (clarsimp simp: obj_at'_def objBitsKO_def s0H_internal_def + shiftl_t2n[where n=4, simplified, symmetric]) + apply (rule conjI) + apply (rule is_aligned_add) + apply (simp add: is_aligned_def s0_ptr_defs) + apply (rule is_aligned_shift) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (rule conjI) + apply (clarsimp simp: valid_irq_handlers'_def cteCaps_of_def ran_def) + apply (drule_tac map_to_ctes_kh0H_SomeD) + apply (elim disjE, simp_all add: kh0H_all_obj_def')[1] + apply ((clarsimp split: if_split_asm)+)[3] + apply (rule conjI) + apply (clarsimp simp: valid_irq_states'_def s0H_internal_def machine_state0_def) + apply (rule conjI) + apply (clarsimp simp: valid_machine_state'_def s0H_internal_def machine_state0_def) + apply (rule conjI) + apply (clarsimp simp: irqs_masked'_def s0H_internal_def) + apply (rule conjI) + apply (clarsimp simp: sym_heap_def opt_map_def projectKOs split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (rule conjI) + apply (clarsimp simp: valid_sched_pointers_def opt_map_def projectKOs split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (rule conjI) + apply (clarsimp simp: valid_bitmaps_def valid_bitmapQ_def bitmapQ_def s0H_internal_def emptyHeadEndPtrs_def + tcbQueueEmpty_def bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def) + apply (rule conjI) + apply (clarsimp simp: ct_not_inQ_def obj_at'_def objBitsKO_def + s0H_internal_def s0_ptrs_aligned Low_tcbH_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (rule conjI) + apply (clarsimp simp: ct_idle_or_in_cur_domain'_def obj_at'_def tcb_in_cur_domain'_def + s0H_internal_def Low_tcbH_def Low_domain_def objBitsKO_def s0_ptrs_aligned) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + apply (rule conjI) + apply (clarsimp simp: kdr_pspace_domain_valid) (* use axiomatization for now *) + apply (clarsimp simp: s0H_internal_def cteCaps_of_def untyped_ranges_zero_inv_def + dschDomain_def dschLength_def valid_dom_schedule'_def maxDomainDuration_def mask_def) + apply (clarsimp simp: cur_tcb'_def obj_at'_def s0H_internal_def objBitsKO_def s0_ptrs_aligned) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBitsKO_def) + done +*) + +lemma ptTranslationBits_NormalPT[simp]: + "ptTranslationBits NormalPT_T = 9" + by (simp add: bit_simps) + +lemma less_0x200_exists_ucast: + "p < 0x200 \ \p'. p = UCAST(pg_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ pg_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps) + apply word_bitwise + apply auto + done + +lemma less_0x40000_exists_ucast: + "\ p < 0x40000; \ config_ARM_PA_SIZE_BITS_40 \ \ \p'. p = UCAST(pg_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ pg_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps) + apply word_bitwise + done + +lemma kh0_pspace_dom: + "pspace_dom kh0 = {idle_tcb_ptr, High_tcb_ptr, Low_tcb_ptr, + High_pool_ptr, Low_pool_ptr, irq_cnode_ptr, ntfn_ptr} \ + irq_node_offs_range \ + page_offs_range shared_page_ptr_virt \ + cnode_offs_range Silc_cnode_ptr \ + cnode_offs_range High_cnode_ptr \ + cnode_offs_range Low_cnode_ptr \ + pt_offs_range VSRootPT_T arm_global_pt_ptr \ + pt_offs_range VSRootPT_T High_pd_ptr \ + pt_offs_range VSRootPT_T Low_pd_ptr \ + pt_offs_range NormalPT_T High_pt_ptr \ + pt_offs_range NormalPT_T Low_pt_ptr" + apply (rule equalityI) + apply (simp add: dom_def pspace_dom_def) + apply clarsimp + apply (clarsimp simp: kh0_def obj_relation_cuts_def page_offs_in_range pt_offs_in_range pageBits_def + cnode_offs_in_range irq_node_offs_in_range s0_ptrs_aligned pte_bits_def word_size_bits_def + kh0_obj_def cte_map_def' caps_dom_length_10 mask_def max_page_size_def + dest!: less_VSRootBits_exists_ucast less_eq_0x1FF_exists_ucast + less_0x40000_exists_ucast less_0x200_exists_ucast + split: if_split_asm) + apply (clarsimp simp: pspace_dom_def dom_def) + apply (rule conjI) + apply (rule_tac x=idle_tcb_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=High_tcb_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=Low_tcb_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=High_pool_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=Low_pool_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply (rule_tac x=irq_cnode_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def cte_map_def) + apply (rule conjI) + apply (rule_tac x=ntfn_ptr in exI) + apply (clarsimp simp: kh0_def kh0_obj_def s0_ptr_defs image_def) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=x in exI) + apply (drule offs_range_correct) + apply clarsimp + apply (force simp: kh0_def kh0_obj_def image_def cte_map_def') + apply (rule conjI) + apply clarsimp + apply (rule_tac x=shared_page_ptr_virt in exI) + apply (drule offs_range_correct) + apply (auto simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps bit_simps max_page_size_def)[1] + apply (rule_tac x="UCAST (pg_index_len \ 64) y" in exI) + apply clarsimp + apply (rule xtr7[rotated]) + apply (rule ucast_leq_mask) + apply simp + apply (rule order.refl) + apply (clarsimp simp: bit_simps mask_def) + apply (rule_tac x="UCAST (pg_index_len \ 64) y" in exI) + apply clarsimp + apply (rule xtr7[rotated]) + apply (rule ucast_leq_mask) + apply simp + apply (rule order.refl) + apply (clarsimp simp: bit_simps mask_def) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=Silc_cnode_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=High_cnode_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=Low_cnode_ptr in exI) + apply (drule offs_range_correct) + apply (force simp: kh0_def kh0_obj_def image_def s0_ptr_defs cte_map_def' dom_caps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=arm_global_pt_ptr in exI) + apply (drule offs_range_correct) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs) + apply (rule exI) + apply (rule_tac x="UCAST(vs_index_len \ 64) y" in bexI) + apply (rule conjI, simp add: bit_simps, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp add: bit_simps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=High_pd_ptr in exI) + apply (drule offs_range_correct) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs) + apply (rule exI) + apply (rule_tac x="UCAST(vs_index_len \ 64) y" in bexI) + apply (rule conjI, simp add: bit_simps, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp add: bit_simps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=Low_pd_ptr in exI) + apply (drule offs_range_correct) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs) + apply (rule exI) + apply (rule_tac x="UCAST(vs_index_len \ 64) y" in bexI) + apply (rule conjI, simp add: bit_simps, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp add: bit_simps) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=High_pt_ptr in exI) + apply (drule offs_range_correct) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (rule exI) + apply (rule_tac x="UCAST(9 \ 64) y" in bexI) + apply (rule conjI, rule refl, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp) + apply clarsimp + apply (rule_tac x=Low_pt_ptr in exI) + apply (drule offs_range_correct) + apply (clarsimp simp: kh0_def kh0_obj_def image_def s0_ptr_defs bit_simps) + apply (rule exI) + apply (rule_tac x="UCAST(9 \ 64) y" in bexI) + apply (rule conjI, rule refl, rule refl) + apply clarsimp + apply (rule ucast_leq_mask, simp) + done + + +lemma shiftl_shiftr_3_pt_index[simp]: + "ucast (((ucast (x :: pt_index) << 3) :: obj_ref) >> 3) = x" + apply (subst shiftl_shiftr_id) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply (erule less_trans) + apply simp + apply simp + apply (rule ucast_ucast_id) + apply simp + done + +lemma mult_shiftr_id[simp]: + "length x = 10 \ of_bl x * (0x20 :: obj_ref) >> 5 = of_bl x" + apply (simp add: shiftl_t2n[symmetric, where n=5, simplified mult.commute, simplified]) + apply (subst shiftl_shiftr_id) + apply simp + apply (rule less_trans) + apply (rule of_bl_length_less) + apply assumption + apply simp + apply simp + apply simp + done + +lemma to_bl_ucast_of_bl[simp]: + "length x = 10 \ to_bl ((ucast (of_bl x :: obj_ref)) :: 10 word) = x" + apply (subst ucast_of_bl_up) + apply (simp add: word_size) + apply (simp add: word_rep_drop) + done + +lemma is_aligned_shiftr_3[simp]: + "is_aligned (arm_global_pt_ptr + (n << 3)) 3" + "is_aligned (High_pd_ptr + (n << 3)) 3" + "is_aligned (Low_pd_ptr + (n << 3)) 3" + "is_aligned (High_pt_ptr + (n << 3)) 3" + "is_aligned (Low_pt_ptr + (n << 3)) 3" + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(1), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(2), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(3), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(7), where y=3, simplified bit_simps]]; fastforce) + apply (rule is_aligned_add[OF is_aligned_weaken[OF s0_ptrs_aligned(8), where y=3, simplified bit_simps]]; fastforce) + done + +lemma ucast_ucast_vs_index_helper[simp]: + "UCAST(64 \ vs_index_len) (UCAST(vs_index_len \ 64) p) = p" + apply (rule ucast_up_ucast_id) + by (simp add: is_up_def source_size_def target_size_def bit_simps) + +lemma less_eq_VSRootBits_exists_ucast: + "p \ 2 ^ ptTranslationBits VSRootPT_T - 1 \ \p'. p = UCAST(vs_index_len \ 64) p'" + apply (rule_tac x="UCAST(64 \ vs_index_len) p" in exI) + apply (rule sym) + apply (rule ucast_ucast_le_mask) + apply (simp add: mask_def bit_simps) + done + +lemma shiftl_shiftr_3_vs_index[simp]: + "ucast (((ucast (x :: vs_index) << 3) :: obj_ref) >> 3) = x" + apply (subst shiftl_shiftr_id) + apply simp + apply (cut_tac ucast_less[where x=x]) + apply (erule less_trans) + apply (simp add: bit_simps) + apply simp + apply (rule ucast_ucast_id) + apply simp + done + +lemma s0_pspace_rel: + "pspace_relation (kheap s0_internal) kh0H" + apply (simp add: pspace_relation_def s0_internal_def s0H_internal_def kh0H_dom kh0_pspace_dom) + apply clarsimp + apply (drule kh0_SomeD) + apply (elim disjE) + apply (clarsimp simp: kh0_obj_def) + apply (drule less_pageBits_exists_ucast) + apply (clarsimp simp: kh0_obj_def bit_simps max_page_size_def dest!: less_0x40000_exists_ucast) + defer + apply ((clarsimp simp: kh0_obj_def kh0H_obj_def bit_simps word_bits_def + fault_rel_optionation_def tcb_relation_cut_def + tcb_relation_def arch_tcb_relation_def the_nat_to_bl_simps + split del: if_split)+)[3] + prefer 13 + apply (clarsimp simp: kh0_obj_def mask_def) + apply (drule less_VSRootBits_exists_ucast) + apply ((auto simp: kh0_obj_def kh0H_all_obj_def add.commute pte_bits_def + pt_offs_max pt_offs_min pte_relation_def mask_def bit_simps))[1] + apply (insert pt_offs_max(5)[simplified mask_2pm1])[2] + apply (erule_tac x=p' in meta_allE) + apply (clarsimp simp: bit_simps) + apply (erule_tac x=p' in meta_allE) + apply (clarsimp simp: bit_simps) + apply (((clarsimp simp: kh0_obj_def kh0H_all_obj_def bit_simps add.commute + pt_offs_max pt_offs_min pte_relation_def mask_def + vm_read_only_def vmrights_map_def ucast_ucast_id vm_read_write_def + kh0H_simps(14,15)[where y=0, simplified] + dest!: less_eq_0x1FF_exists_ucast, + clarsimp simp: s0_ptr_defs is_aligned_def addrFromPPtr_def ppn_from_pptr_def + pageBits_def pptrBaseOffset_def pptrBase_def paddrBase_def); fail?)+)[2] + apply (clarsimp simp: kh0_obj_def mask_def) + apply (drule less_VSRootBits_exists_ucast) + apply (clarsimp simp: pte_bits_def word_size_bits_def kh0H_all_obj_def) + apply (((clarsimp simp: kh0_obj_def kh0H_all_obj_def add.commute + pt_offs_max pt_offs_min pte_relation_def mask_def + vm_read_only_def vmrights_map_def ucast_ucast_id vm_read_write_def + pte_bits_def word_size_bits_def + dest!: less_eq_VSRootBits_exists_ucast))) + apply (auto simp: ppn_from_pptr_def)[1] + apply (clarsimp simp: bit_simps s0_ptr_defs is_aligned_def addrFromPPtr_def pageBits_def + ppn_from_pptr_def pptrBaseOffset_def pptrBase_def paddrBase_def) + apply (insert pt_offs_max(2)[simplified mask_2pm1])[1] + apply (erule_tac x=p' in meta_allE) + apply (clarsimp simp: bit_simps add_diff_eq) + apply (clarsimp simp: kh0_obj_def mask_def) + apply (drule less_VSRootBits_exists_ucast) + apply (clarsimp simp: pte_bits_def word_size_bits_def kh0H_all_obj_def) + apply (((clarsimp simp: kh0_obj_def kh0H_all_obj_def add.commute + pt_offs_max pt_offs_min pte_relation_def mask_def + vm_read_only_def vmrights_map_def ucast_ucast_id vm_read_write_def + pte_bits_def word_size_bits_def + dest!: less_eq_VSRootBits_exists_ucast))) + apply (auto simp: ppn_from_pptr_def)[1] + apply (clarsimp simp: bit_simps s0_ptr_defs is_aligned_def addrFromPPtr_def ppn_from_pptr_def pageBits_def pptrBaseOffset_def pptrBase_def paddrBase_def) + apply (insert pt_offs_max(1)[simplified mask_2pm1])[1] + apply (erule_tac x=p' in meta_allE) + apply (clarsimp simp: bit_simps add_diff_eq) + apply (clarsimp simp: kh0_obj_def kh0H_obj_def well_formed_cnode_n_def + cte_relation_def cte_map_def bit_simps) + apply (clarsimp simp: kh0H_obj_def bit_simps ntfn_def other_obj_relation_def ntfn_relation_def) + defer + apply ((clarsimp simp: kh0_obj_def kh0H_obj_def other_obj_relation_def + asid_pool_relation_def comp_def inv_into_def2 other_aobj_relation_def, + rule ext, + clarsimp simp: asid_low_bits_of_def asid_low_bits_def High_asid_def abs_asid_entry_def, word_bitwise)+)[2] + apply (clarsimp simp: kh0H_obj_def kh0_obj_def cte_relation_def cte_map_def') + apply (cut_tac dom_caps(2))[1] + apply (frule_tac m=High_caps in domI) + apply (cut_tac x=y in cnode_offs_in_range(2), simp) + apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def High_caps_def max_page_size_def + the_nat_to_bl_simps vmrights_map_def vm_read_only_def + split: if_split_asm) + apply (clarsimp simp: kh0H_obj_def kh0_obj_def cte_relation_def cte_map_def') + apply (cut_tac dom_caps(3))[1] + apply (frule_tac m=Low_caps in domI) + apply (cut_tac x=y in cnode_offs_in_range(1), simp) + apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def Low_caps_def max_page_size_def + the_nat_to_bl_simps vmrights_map_def vm_read_write_def + split: if_split_asm) + apply (fastforce simp: kh0H_obj_def cte_map_def cte_relation_def well_formed_cnode_n_def + dest: irq_node_offs_range_correct split: if_split_asm) + apply (clarsimp simp: kh0H_obj_def kh0_obj_def cte_relation_def cte_map_def') + apply (cut_tac dom_caps(1))[1] + apply (frule_tac m=Silc_caps in domI) + apply (cut_tac x=y in cnode_offs_in_range(3), simp) + apply (clarsimp simp: cnode_offs_range_def kh0H_all_obj_def Silc_caps_def max_page_size_def + the_nat_to_bl_simps vmrights_map_def vm_read_only_def + split: if_split_asm) + done + +lemma subtree_node_Some: + "m \ a \ b \ m a \ None" + by (erule subtree.cases) (auto simp: parentOf_def) + +lemma max_numlistregs_rel[simp]: + "max_numlistregs = max_armKSGICVCPUNumListRegs" + by (simp add: max_numlistregs_def max_armKSGICVCPUNumListRegs_def) + +lemma s0_srel: + "1 \ maxDomain \ (s0_internal, s0H_internal) \ state_relation" + apply (simp add: state_relation_def) + apply (intro conjI) + apply (simp add: s0_pspace_rel) + apply (simp add: s0_internal_def exst0_def s0H_internal_def sched_act_relation_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def + ready_queues_relation_def ready_queue_relation_def + list_queue_relation_def queue_end_valid_def + prev_queue_head_def inQ_def tcbQueueEmpty_def + projectKOs opt_map_def opt_pred_def emptyHeadEndPtrs_def + split: option.splits) + using kh0H_dom_tcb + apply (fastforce simp: kh0H_obj_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def ghost_relation_def) + apply (intro conjI) + apply (fastforce simp: kh0_def kh0_obj_def max_page_size_def dest: kh0_SomeD) + apply clarsimp + apply (rule conjI) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: irq_node_offs_in_range) + apply (fastforce simp: kh0_def well_formed_cnode_n_def empty_cnode_def dom_def) + apply clarsimp + apply (prop_tac "a \ irq_node_offs_range") + apply (fastforce dest: irq_node_offs_range_correct) + apply (clarsimp simp: s0_ptr_defs) + apply (intro conjI impI) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Low_caps_def + well_formed_cnode_n_def empty_cnode_def) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs High_caps_def + well_formed_cnode_n_def empty_cnode_def) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Silc_caps_def + well_formed_cnode_n_def empty_cnode_def) + apply clarsimp + apply (rule iffI) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (fastforce simp: kh0_def kh0_obj_def dom_def s0_ptr_defs Silc_caps_def + well_formed_cnode_n_def empty_cnode_def) + apply clarsimp + apply (drule kh0_SomeD) + apply (clarsimp simp: s0_ptr_defs kh0_obj_def) + apply (clarsimp simp: s0H_internal_def arch_state0H_def) + apply auto[1] + apply (drule kh0_SomeD, clarsimp simp: kh0_obj_def, clarsimp simp: kh0_def kh0_obj_def)+ + apply (drule kh0_SomeD, clarsimp simp: kh0_obj_def) + apply (clarsimp simp: s0H_internal_def cdt_relation_def) + apply (clarsimp simp: descendants_of'_def) + apply (frule subtree_parent) + apply (drule subtree_mdb_next) + apply (case_tac "x = 0") + apply (cut_tac s0H_valid_pspace') + apply (simp add: valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def + parentOf_def isMDBParentOf_def kh0H_all_obj_def') + apply simp + apply (clarsimp simp: mdb_next_trancl_s0H) + apply (elim disjE, (clarsimp simp: parentOf_def isMDBParentOf_def kh0H_all_obj_def')+)[1] + apply (clarsimp simp: cdt_list_relation_def s0_internal_def exst0_def split: option.splits) + apply (clarsimp simp: next_slot_def) + apply (cut_tac p="(a, b)" and t="(const [])" and m="Map.empty" in next_not_child_NoneI) + apply fastforce + apply (simp add: next_sib_def) + apply (simp add: finite_depth_def) + apply simp + apply (clarsimp simp: revokable_relation_def) + apply (clarsimp simp: null_filter_def split: if_split_asm) + apply (drule s0_caps_of_state) + apply clarsimp + apply (elim disjE) + apply (clarsimp simp: s0H_internal_def s0_internal_def + cte_map_def' kh0H_all_obj_def' + split: if_split_asm)+ + apply (clarsimp simp: tcb_cnode_index_def ucast_bl[symmetric] + Low_tcb_cte_def Low_tcbH_def High_tcb_cte_def High_tcbH_def) + apply ((clarsimp simp: cte_map_def' s0H_internal_def s0_internal_def, + clarsimp simp: tcb_cnode_index_def ucast_bl[symmetric] + Low_tcb_cte_def Low_tcbH_def High_tcb_cte_def High_tcbH_def)+)[5] + apply (clarsimp simp: s0_internal_def s0H_internal_def arch_state0_def arch_state0H_def + arch_state_relation_def asid_high_bits_of_def asid_low_bits_def + High_asid_def Low_asid_def max_pt_level_def2 maxPTLevel_def comp_def + split: if_splits) + apply safe + apply (rule ext) + apply clarsimp + apply (word_bitwise, fastforce) + + apply (rule ext) + apply (clarsimp simp: vmid_for_asid_2'_def obind_def opt_map_def asid_pool_of'_def kh0H_all_obj_def vmids_of_pool'_def) + apply (clarsimp simp: s0_internal_def s0H_internal_def exst0_def cte_level_bits_def + interrupt_state_relation_def irq_state_relation_def) + apply (clarsimp simp: s0_internal_def exst0_def s0H_internal_def)+ + done + +definition + "s0H \ ((if ct_idle' s0H_internal then idle_context s0_internal else s0_context, s0H_internal), KernelExit)" + +(* FIXME AARCH64 IF: uncomment after kernel ELF window changes addressed *) +(* +lemma step_restrict_s0: + "1 \ maxDomain \ step_restrict s0" + supply option.case_cong[cong] if_cong[cong] + apply (clarsimp simp: step_restrict_def has_srel_state_def) + apply (rule_tac x="fst (fst s0H)" in exI) + apply (rule_tac x="snd (fst s0H)" in exI) + apply (rule_tac x="snd s0H" in exI) + apply (simp add: s0H_def lift_fst_rel_def lift_snd_rel_def s0_srel s0_def split del: if_split) + apply (rule conjI) + apply (clarsimp split: if_split_asm) + apply (rule conjI) + apply clarsimp + apply (frule ct_idle'_related[OF s0_srel s0H_invs]; solves simp) + apply clarsimp + apply (drule ct_idle_related[OF s0_srel]; simp) + apply (clarsimp simp: full_invs_if'_def s0H_invs) + apply (rule conjI) + apply (simp only: ex_abs_def) + apply (rule_tac x="s0_internal" in exI) + apply (subst pred_conj_def[where f=einvs]) + apply (simp only: einvs_s0 s0_srel) + apply (simp add: no_domain_caps_def) + apply (rule_tac x="s0_internal" in exI) + apply (clarsimp simp: domain_sep_inv_def F[symmetric]) + apply (drule s0_caps_of_state) + apply auto[1] + apply (clarsimp simp: ct_in_state'_def st_tcb_at'_def obj_at'_def + s0H_internal_def objBits_simps' s0_ptrs_aligned Low_tcbH_def) + apply (rule pspace_distinctD''[OF _ s0H_pspace_distinct', simplified s0H_internal_def]) + apply (simp add: objBits_simps') + done + +lemma Sys1_valid_initial_state_noenabled: + assumes domains: "1 \ maxDomain" + assumes utf_det: "\pl pr pxn tc ms s. det_inv InUserMode tc s \ einvs s \ context_matches_state pl pr pxn ms s \ ct_running s + \ (\x. utf (cur_thread s) pl pr pxn (tc, ms) = {x})" + assumes utf_non_empty: "\t pl pr pxn tc ms. utf t pl pr pxn (tc, ms) \ {}" + assumes utf_non_interrupt: "\t pl pr pxn tc ms e f g. (e,f,g) \ utf t pl pr pxn (tc, ms) \ e \ Some Interrupt" + assumes det_inv_invariant: "invariant_over_ADT_if det_inv utf" + assumes det_inv_s0: "det_inv KernelExit (cur_context s0_internal) s0_internal" + shows "valid_initial_state_noenabled det_inv utf s0_internal Sys1PAS timer_irq s0_context" + by (rule Sys1_valid_initial_state_noenabled[OF step_restrict_s0 utf_det utf_non_empty + utf_non_interrupt det_inv_invariant det_inv_s0 + ], + rule domains) +*) + +end + +end diff --git a/proof/infoflow/refine/ADT_IF_Refine.thy b/proof/infoflow/refine/ADT_IF_Refine.thy index 973429862a..f676605584 100644 --- a/proof/infoflow/refine/ADT_IF_Refine.thy +++ b/proof/infoflow/refine/ADT_IF_Refine.thy @@ -229,11 +229,11 @@ locale ADT_IF_Refine_1 = (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running') (do_user_op_if f tc) (doUserOp_if f tc)" and dmo_getActiveIRQ_corres: - "corres (=) \ \ (do_machine_op (getActiveIRQ in_kernel)) (doMachineOp (getActiveIRQ in_kernel'))" + "corres (=) \ \ (do_machine_op (getActiveIRQ in_kernel)) (doMachineOp (getActiveIRQ in_kernel))" and dmo'_getActiveIRQ_wp: "\\s. P (irq_at (irq_state (ksMachineState s) + 1) (irq_masks (ksMachineState s))) (s\ksMachineState := (ksMachineState s\irq_state := irq_state (ksMachineState s) + 1\)\)\ - doMachineOp (getActiveIRQ in_kernel) + doMachineOp (getActiveIRQ False) \P\" and handlePreemption_arch_extras[wp]: "handlePreemption_if tc \arch_extras\" @@ -359,11 +359,6 @@ lemma checkActiveIRQ_ex_abs[wp]: apply (clarsimp simp: ex_abs_def) done -lemma handlePreemption_invs'[wp]: - "handlePreemption_if tc \invs'\" - unfolding handlePreemption_if_def - by (wpsimp wp: dmo'_getActiveIRQ_wp hoare_drop_imps) - lemma handle_preemption_if_corres: "corres (=) (einvs and valid_domain_list and (\s. 0 < domain_time s)) (invs') (handle_preemption_if tc) (handlePreemption_if tc)" @@ -831,6 +826,11 @@ lemma ex_abs_pred_conjD1: (* FIXME: move *) "ex_abs (P and Q) s \ ex_abs P s" by (auto simp: ex_abs_def) +lemma handlePreemption_invs'[wp]: + "handlePreemption_if tc \invs'\" + unfolding handlePreemption_if_def + by (wpsimp wp: dmo'_getActiveIRQ_wp hoare_drop_imps) + lemma haskell_invs: "global_automaton_invs checkActiveIRQ_H_if (doUserOp_H_if uop) kernelCall_H_if handlePreemption_H_if @@ -966,7 +966,7 @@ lemma extras_inter'[dest!]: lemma fw_sim_abs_conc: "LI (ADT_abs) (ADT_conc) (lift_fst_rel srel) (invs_abs \ invs_conc)" - apply (unfold LI_def ) + apply (unfold LI_def) apply (intro conjI allI) apply (rule init_refinement) apply (clarsimp simp: rel_semi_def relcomp_unfold lift_fst_rel_def diff --git a/proof/infoflow/refine/ADT_IF_Refine_C.thy b/proof/infoflow/refine/ADT_IF_Refine_C.thy index 59807b8b25..df07eb67c7 100644 --- a/proof/infoflow/refine/ADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/ADT_IF_Refine_C.thy @@ -82,11 +82,69 @@ definition handleVMFaultEvent_C_body_if context kernel_m begin +definition + checkActiveIRQ_C_if :: "user_context \ (cstate, irq option \ user_context) nondet_monad" + where + "checkActiveIRQ_C_if tc \ + do + getActiveIRQ_C; + irq \ gets ret__unsigned_long_'; + return (if irq = ucast irqInvalid then None else Some (ucast irq), tc) + od" + +definition + check_active_irq_C_if + where + "check_active_irq_C_if \ {((tc, s), irq, (tc', s')). ((irq, tc'), s') \ fst (checkActiveIRQ_C_if tc s)}" + definition handleInterruptEntry_C_body_if (*:: "(globals myvars, int, l4c_errortype) com"*) where -"handleInterruptEntry_C_body_if \ ( + "handleInterruptEntry_C_body_if \ ( (CALL checkInterrupt());; \ret__unsigned_long :== scast EXCEPTION_NONE)" +definition + handlePreemption_C_if :: "user_context \ (cstate,user_context) nondet_monad" where + "handlePreemption_C_if tc \ do (exec_C \ handleInterruptEntry_C_body_if); return tc od" + +end + + +locale ADT_IF_Refine_1 = kernel_m + + fixes doUserOp_C_if :: + "user_transition_if \ user_context \ (cstate, (event option \ user_context)) nondet_monad" + and handleHypervisorFault_C_body_if :: "machine_word \ (globals myvars, int, strictc_errortype) com" + and hyp_fault_type_from_H :: "hyp_fault_type \ machine_word" + assumes do_user_op_if_C_corres: + "corres_underlying rf_sr False False (=) (invs' and ex_abs einvs and (\_. uop_nonempty f)) + \ (doUserOp_if f tc) (doUserOp_C_if f tc)" + and handleInvocation_ccorres': + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_active' and sch_act_simple) + (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] + (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" + and handleHypervisorFault_C_body_ccorres: + "ccorres ((\irq :: irq. K dc irq) \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (UNIV) [] + (liftE (do thread <- getCurThread; + handleHypervisorFault thread flt + od)) + (handleHypervisorFault_C_body_if (hyp_fault_type_from_H flt))" + and checkInterrupt_ccorres': + "ccorres dc xfdc (\s. invs' s \ (\inKernel \ sch_act_not (ksCurThread s) s)) UNIV [] + (maybeHandleInterrupt inKernel) (Call checkInterrupt_'proc)" + and hvmf_invs_lift: + "\ \s m. P (s\ksMachineState := ksMachineState s\machine_state_rest := m\\) = P s \ + \ \P\ handleVMFault t hf \\_ _. True\, \\_. P\" + and check_active_irq_corres_C: + "corres_underlying rf_sr False False (=) \ \ (checkActiveIRQ_if tc) (checkActiveIRQ_C_if tc)" + and obs_cpspace_user_data_relation: + "\ pspace_aligned' bd; pspace_distinct' bd; + cpspace_user_data_relation (ksPSpace bd) (underlying_memory (ksMachineState bd)) hgs \ + \ cpspace_user_data_relation (ksPSpace bd) + (underlying_memory (observable_memory (ksMachineState bd) (user_mem' bd))) hgs" +begin + definition "callKernel_C_body_if e \ case e of SyscallEvent n \ (handleSyscall_C_body_if (ucast (syscall_from_H n))) @@ -94,7 +152,7 @@ definition | UserLevelFault w1 w2 \ (handleUserLevelFault_C_body_if w1 w2) | Interrupt \ (handleInterruptEntry_C_body_if) | VMFaultEvent t \ (handleVMFaultEvent_C_body_if (vm_fault_type_from_H t)) - | HypervisorEvent t \ (SKIP ;; \ret__unsigned_long :== scast EXCEPTION_NONE)" + | HypervisorEvent t \ (handleHypervisorFault_C_body_if (hyp_fault_type_from_H t))" definition kernelEntry_C_if (*:: @@ -121,51 +179,10 @@ definition {(s, b, (tc,s'))|s b tc s' r. ((r,tc),s') \ fst (split (kernelEntry_C_if fp e) s) \ b = (case r of Inl x \ True | Inr x \ False)}" -definition - checkActiveIRQ_C_if :: "user_context \ (cstate, irq option \ user_context) nondet_monad" - where - "checkActiveIRQ_C_if tc \ - do - getActiveIRQ_C; - irq \ gets ret__unsigned_long_'; - return (if irq = ucast irqInvalid then None else Some (ucast irq), tc) - od" - -definition - check_active_irq_C_if - where - "check_active_irq_C_if \ {((tc, s), irq, (tc', s')). ((irq, tc'), s') \ fst (checkActiveIRQ_C_if tc s)}" - -lemma corres_select_f': - "\ \s s'. P s \ P' s' \ \s' \ fst S'. \s \ fst S. rvr s s'; nf' \ \ snd S' \ - \ corres_underlying sr nf nf' rvr P P' (select_f S) (select_f S')" - by (clarsimp simp: select_f_def corres_underlying_def) - -lemma cur_thread_of_absKState[simp]: - "cur_thread (absKState s) = (ksCurThread s)" - by (clarsimp simp: cstate_relation_def Let_def absKState_def cstate_to_H_def) - -lemma absKState_crelation: - "\ cstate_relation s (globals s'); invs' s; ksReadyQueues_asrt s\ - \ cstate_to_A s' = absKState s" - apply (clarsimp simp add: cstate_to_H_correct invs'_def cstate_to_A_def) - apply (clarsimp simp: absKState_def absExst_def observable_memory_def) - apply (case_tac s) - apply clarsimp - apply (case_tac ksMachineState) - apply clarsimp - apply (rule ext) - by (clarsimp simp: option_to_0_def user_mem'_def pointerInUserData_def ko_wp_at'_def - obj_at'_def typ_at'_def ps_clear_def - split: if_splits) - -definition - handlePreemption_C_if :: "user_context \ (cstate,user_context) nondet_monad" where - "handlePreemption_C_if tc \ do (exec_C \ handleInterruptEntry_C_body_if); return tc od" - lemma handleInterrupt_no_fail: "no_fail (ex_abs (einvs) and invs' - and (\s. intStateIRQTable (ksInterruptState s) a \ irqstate.IRQInactive)) + and (\s. intStateIRQTable (ksInterruptState s) a \ irqstate.IRQInactive) + and (\s. a \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)) (handleInterrupt a)" apply (rule no_fail_pre) apply (rule corres_nofail) @@ -181,54 +198,31 @@ lemma handleSpuriousIRQ_no_fail[intro!, wp, simp]: by wpsimp lemma handleEvent_Interrupt_no_fail: - "no_fail (invs' and ex_abs einvs) (handleEvent Interrupt)" + "no_fail (invs' and ex_abs einvs and (\s. ksSchedulerAction s = ResumeCurrentThread)) (handleEvent Interrupt)" apply (simp add: handleEvent_def maybeHandleInterrupt_def) apply (wpsimp wp: handleInterrupt_no_fail) apply (simp add: crunch_simps) apply (rule_tac Q'="\r s. ex_abs (einvs) s \ invs' s \ (\irq. r = Some irq - \ intStateIRQTable (ksInterruptState s) irq \ irqstate.IRQInactive)" + \ intStateIRQTable (ksInterruptState s) irq \ irqstate.IRQInactive) + \ (\irq. r = Some irq \ irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s)" in hoare_strengthen_post) apply (rule hoare_vcg_conj_lift) apply (rule corres_ex_abs_lift) apply (rule dmo_getActiveIRQ_corres) apply wpsimp apply (wpsimp wp: doMachineOp_getActiveIRQ_IRQ_active) + apply (wp hoare_vcg_all_lift hoare_drop_imps) + apply wpsimp apply clarsimp apply wpsimp apply (clarsimp simp: invs'_def valid_state'_def) done -end - - -locale ADT_IF_Refine_1 = kernel_m + - fixes doUserOp_C_if :: - "user_transition_if \ user_context \ (cstate, (event option \ user_context)) nondet_monad" - assumes do_user_op_if_C_corres: - "corres_underlying rf_sr False False (=) (invs' and ex_abs einvs and (\_. uop_nonempty f)) - \ (doUserOp_if f tc) (doUserOp_C_if f tc)" - and handleInvocation_ccorres': - "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') - (invs' and arch_extras and ct_active' and sch_act_simple) - (UNIV \ {s. isCall_' s = from_bool isCall} \ {s. isBlocking_' s = from_bool isBlocking}) [] - (handleInvocation isCall isBlocking) (Call handleInvocation_'proc)" - and checkInterrupt_ccorres': - "ccorres dc xfdc (\s. invs' s \ (\inKernel \ sch_act_not (ksCurThread s) s)) UNIV [] - (maybeHandleInterrupt inKernel) (Call checkInterrupt_'proc)" - and check_active_irq_corres_C: - "corres_underlying rf_sr False False (=) \ \ (checkActiveIRQ_if tc) (checkActiveIRQ_C_if tc)" - and obs_cpspace_user_data_relation: - "\ pspace_aligned' bd; pspace_distinct' bd; - cpspace_user_data_relation (ksPSpace bd) (underlying_memory (ksMachineState bd)) hgs \ - \ cpspace_user_data_relation (ksPSpace bd) - (underlying_memory (observable_memory (ksMachineState bd) (user_mem' bd))) hgs" -begin - lemma handleInterrupt_if_ccorres: "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') (\s. invs' s \ (\inKernel \ sch_act_not (ksCurThread s) s)) - (UNIV) + UNIV [] (liftE (maybeHandleInterrupt inKernel)) (handleInterruptEntry_C_body_if)" @@ -352,7 +346,8 @@ lemma handleEvent_ccorres: apply simp apply simp apply simp - apply (wp hv_inv_ex') + apply (wp hvmf_invs_lift) + apply (fastforce simp: invs'_machine valid_machine_state'_def) apply (simp add: guard_is_UNIV_def) apply (vcg exspec=handleVMFault_modifies) apply ceqv @@ -362,20 +357,12 @@ lemma handleEvent_ccorres: apply (clarsimp simp: return_def) apply wp apply (simp add: guard_is_UNIV_def) - apply (auto simp: ct_in_state'_def isReply_def is_cap_fault_def - cfault_rel_def seL4_Fault_UnknownSyscall_lift seL4_Fault_UserException_lift - elim: pred_tcb'_weakenE st_tcb_ex_cap'' - dest: st_tcb_at_idle_thread' rf_sr_ksCurThread) \ \HypervisorEvent\ - apply (simp add: liftE_def bind_assoc) - apply (rule ccorres_guard_imp2) - apply (rule ccorres_symb_exec_l) - apply (case_tac x6; simp add: handleHypervisorFault_def) - apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) - apply (rule allI, rule conseqPre, vcg) - apply (clarsimp simp: return_def) - apply wp+ - apply clarsimp + apply (rule handleHypervisorFault_C_body_ccorres) + apply (auto simp: ct_in_state'_def isReply_def is_cap_fault_def + cfault_rel_def seL4_Fault_UnknownSyscall_lift seL4_Fault_UserException_lift + elim: pred_tcb'_weakenE st_tcb_ex_cap'' + dest: st_tcb_at_idle_thread' rf_sr_ksCurThread split: if_splits) done lemma kernelEntry_corres_C: @@ -511,11 +498,6 @@ lemma handle_preemption_corres_C: apply (fastforce simp: ex_abs_def schedaction_related)+ done -end - - -context kernel_m begin - definition handle_preemption_C_if where @@ -613,6 +595,34 @@ lemma preserves'_trivial: "preserves' mode UNIV f" apply (simp add: preserves'_def) done +lemma corres_select_f': + "\ \s s'. P s \ P' s' \ \s' \ fst S'. \s \ fst S. rvr s s'; nf' \ \ snd S' \ + \ corres_underlying sr nf nf' rvr P P' (select_f S) (select_f S')" + by (clarsimp simp: select_f_def corres_underlying_def) + + +context kernel_m begin + +lemma cur_thread_of_absKState[simp]: + "cur_thread (absKState s) = (ksCurThread s)" + by (clarsimp simp: cstate_relation_def Let_def absKState_def cstate_to_H_def) + +lemma absKState_crelation: + "\ cstate_relation s (globals s'); invs' s; ksReadyQueues_asrt s\ + \ cstate_to_A s' = absKState s" + apply (clarsimp simp add: cstate_to_H_correct invs'_def cstate_to_A_def) + apply (clarsimp simp: absKState_def absExst_def observable_memory_def) + apply (case_tac s) + apply clarsimp + apply (case_tac ksMachineState) + apply clarsimp + apply (rule ext) + by (clarsimp simp: option_to_0_def user_mem'_def pointerInUserData_def ko_wp_at'_def + obj_at'_def typ_at'_def ps_clear_def + split: if_splits) + +end + context ADT_IF_Refine_1 begin diff --git a/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy b/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy index e0a934dd27..0eeaaef345 100644 --- a/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/ARM/ArchADT_IF_Refine_C.thy @@ -310,10 +310,51 @@ lemma obs_cpspace_user_data_relation[ADT_IF_Refine_assms]: apply simp done +declare handleSpuriousIRQ_ccorres[ADT_IF_Refine_assms] + +lemma dmo_getActiveIRQ_inKernel_sch_act_not: + "\\s. \inKernel \ sch_act_not (ksCurThread s) s\ + doMachineOp (getActiveIRQ inKernel) + \\rv s. \irq. rv = Some irq \ irq \ non_kernel_IRQs \ sch_act_not (ksCurThread s) s\" + unfolding doMachineOp_def + apply (cases inKernel; wpsimp) + apply (drule use_valid, rule getActiveIRQ_neq_non_kernel, rule TrueI) + apply clarsimp + done + +lemma hvmf_invs_lift[ADT_IF_Refine_assms]: + "\ \s m. P (s\ksMachineState := ksMachineState s\machine_state_rest := m\\) = P s \ + \ \P\ handleVMFault t hf \\_ _. True\, \\_. P\" + by (rule hv_inv_ex') + +definition handleHypervisorFault_C_body_if :: "machine_word \ (globals myvars, int, strictc_errortype) com" + where + "handleHypervisorFault_C_body_if hyp_fault_type == + (SKIP ;; \ret__unsigned_long :== scast EXCEPTION_NONE)" + +definition hyp_fault_type_from_H :: "hyp_fault_type \ machine_word" where + "hyp_fault_type_from_H fault \ undefined" + +lemma handleHypervisorFault_C_body_ccorres[ADT_IF_Refine_assms]: + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)) UNIV [] + (liftE (do thread <- getCurThread; + handleHypervisorFault thread flt + od)) + (handleHypervisorFault_C_body_if (hyp_fault_type_from_H flt))" + apply (case_tac flt) + apply (simp add: liftE_def bind_assoc handleHypervisorFault_def handleHypervisorFault_C_body_if_def) + apply (rule ccorres_guard_imp) + apply (rule ccorres_pre_getCurThread) + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (auto simp: return_def) + done + end -sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if +sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if handleHypervisorFault_C_body_if hyp_fault_type_from_H proof goal_cases interpret Arch . case 1 show ?case diff --git a/proof/infoflow/refine/InfoFlowC_Image_Toplevel.thy b/proof/infoflow/refine/InfoFlowC_Image_Toplevel.thy new file mode 100644 index 0000000000..a666ad1082 --- /dev/null +++ b/proof/infoflow/refine/InfoFlowC_Image_Toplevel.thy @@ -0,0 +1,16 @@ +(* + * Copyright 2026, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +(* This theory serves as a top-level theory for testing InfoFlowC. + It should import everything that we want tested as part of building the + InfoFlowC image. *) + +theory InfoFlowC_Image_Toplevel +imports + Noninterference_Refinement + Example_Valid_StateH +begin +end diff --git a/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy b/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy index ed4c671358..a7a601afab 100644 --- a/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy +++ b/proof/infoflow/refine/RISCV64/ArchADT_IF_Refine_C.thy @@ -22,8 +22,8 @@ lemma handleInvocation_ccorres'[ADT_IF_Refine_assms]: apply (rule handleInvocation_ccorres) done -lemma irqInvalid_eq[simp]: - "ucast irqInvalid = scast Kernel_C.irqInvalid" +lemma Kernel_C_irqInvalid: + "scast Kernel_C.irqInvalid = ucast irqInvalid" by (simp add: irqInvalid_def Kernel_C.irqInvalid_def) lemma handleSpuriousIRQ_ccorres: @@ -53,7 +53,7 @@ lemma checkInterrupt_ccorres'[ADT_IF_Refine_assms]: apply (simp add: liftE_def bind_assoc) apply (ctac (no_vcg) add: getActiveIRQ_ccorres) apply (rule_tac P="\_. rv \ None" and R=\ in ccorres_cond_both) - apply (auto split: option.splits)[1] + apply (auto simp: Kernel_C_irqInvalid split: option.splits)[1] apply (rule_tac P="rv \ None" in ccorres_gen_asm) apply clarsimp apply wpfix @@ -257,10 +257,39 @@ lemma obs_cpspace_user_data_relation[ADT_IF_Refine_assms]: apply simp done +lemma hvmf_invs_lift[ADT_IF_Refine_assms]: + "\ \s m. P (s\ksMachineState := ksMachineState s\machine_state_rest := m\\) = P s \ + \ \P\ handleVMFault t hf \\_ _. True\, \\_. P\" + by (rule hv_inv_ex') + +definition handleHypervisorFault_C_body_if :: "64 word \ (globals myvars, int, strictc_errortype) com" + where + "handleHypervisorFault_C_body_if hyp_fault_type == + (SKIP ;; \ret__unsigned_long :== scast EXCEPTION_NONE)" + +definition hyp_fault_type_from_H :: "hyp_fault_type \ machine_word" where + "hyp_fault_type_from_H fault \ undefined" + +lemma handleHypervisorFault_C_body_ccorres[ADT_IF_Refine_assms]: + "ccorres (K dc \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') + (invs' and arch_extras and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)) UNIV [] + (liftE (do thread <- getCurThread; + handleHypervisorFault thread flt + od)) + (handleHypervisorFault_C_body_if (hyp_fault_type_from_H flt))" + apply (case_tac flt) + apply (simp add: liftE_def bind_assoc handleHypervisorFault_def handleHypervisorFault_C_body_if_def) + apply (rule ccorres_guard_imp) + apply (rule ccorres_pre_getCurThread) + apply (rule_tac P=\ and P'=UNIV in ccorres_from_vcg) + apply (rule allI, rule conseqPre, vcg) + apply (auto simp: return_def) + done + end -sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if +sublocale kernel_m \ ADT_IF_Refine_1?: ADT_IF_Refine_1 _ _ _ doUserOp_C_if handleHypervisorFault_C_body_if hyp_fault_type_from_H proof goal_cases interpret Arch . case 1 show ?case diff --git a/run_tests b/run_tests index 2b6c3cf4b4..91d00be0b6 100755 --- a/run_tests +++ b/run_tests @@ -64,7 +64,6 @@ EXCLUDE["RISCV64"]=[ EXCLUDE["AARCH64"]=[ # To be eliminated/refined as development progresses "ASepSpec", - "InfoFlow", # Tools and unrelated content, removed for development "AutoCorres",