From 40ac22a20183b8cd3b0377cb73f29a005eea1519 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Wed, 13 May 2026 05:48:14 +1000 Subject: [PATCH 1/7] refine: improve TcbAcc_R arch-split Allows copyMRs_corres and getMRs_corres to become generic. Signed-off-by: Rafal Kolanski --- proof/refine/AARCH64/ArchTcbAcc_R.thy | 393 +++++++------------------ proof/refine/ARM/ArchTcbAcc_R.thy | 393 +++++++------------------ proof/refine/ARM_HYP/ArchTcbAcc_R.thy | 393 +++++++------------------ proof/refine/RISCV64/ArchTcbAcc_R.thy | 393 +++++++------------------ proof/refine/TcbAcc_R.thy | 245 +++++++++++++++- proof/refine/X64/ArchTcbAcc_R.thy | 395 ++++++++------------------ 6 files changed, 795 insertions(+), 1417 deletions(-) diff --git a/proof/refine/AARCH64/ArchTcbAcc_R.thy b/proof/refine/AARCH64/ArchTcbAcc_R.thy index cbbcfc39ae..9d49188acc 100644 --- a/proof/refine/AARCH64/ArchTcbAcc_R.thy +++ b/proof/refine/AARCH64/ArchTcbAcc_R.thy @@ -313,6 +313,24 @@ lemma pspace_dom_dom[TcbAcc_R_assms]: apply (simp add: pageBitsForSize_def bit_simps split: vmpage_size.split) done +lemma less_max_ipc_words_less_2p_msg_align_bits[TcbAcc_R_assms]: + assumes y: "y < unat max_ipc_words" + shows "word_of_nat y * (word_size :: machine_word) < 2 ^ msg_align_bits" + apply (simp add: word_size_def word_size_bits_def) + apply (rule word_less_power_trans_ofnat[where k = 3, simplified]) + apply (rule order_less_le_trans[OF y]) + apply (simp add: msg_align_bits max_ipc_words)+ + done + +lemma is_aligned_word_size_bits_less_max_ipc_words[TcbAcc_R_assms]: + "y < unat max_ipc_words \ is_aligned (word_of_nat y * word_size) word_size_bits" + by (simp add: word_size_def word_size_bits_def) + (rule is_aligned_mult_triv2[where n=3, simplified]) + +lemma msg_align_bits_le_pageBitsForSize[TcbAcc_R_assms]: + "msg_align_bits \ pageBitsForSize sz" + by (simp add: msg_align_bits pageBitsForSize_def bit_simps split: vmpage_size.split) + lemmas [TcbAcc_R_assms] = dmo_getirq_inv getActiveIRQ_masked @@ -598,95 +616,12 @@ lemma addToBitmap_valid_bitmapQ_except[TcbAcc_R_2_assms]: dest: prioToL1Index_bits_low_high_eq) done -lemma valid_ipc_buffer_ptr'D: - assumes yv: "y < unat max_ipc_words" - and buf: "valid_ipc_buffer_ptr' a s" - shows "pointerInUserData (a + of_nat y * 8) s" - using buf unfolding valid_ipc_buffer_ptr'_def pointerInUserData_def - apply clarsimp - apply (subgoal_tac - "(a + of_nat y * 8) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 3, simplified]) - apply (rule order_less_le_trans [OF yv]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp_all add: msg_align_bits pageBits_def) - done - -lemma in_user_frame_eq: +lemma in_user_frame_eq[TcbAcc_R_2_assms]: assumes y: "y < unat max_ipc_words" and al: "is_aligned a msg_align_bits" - shows "in_user_frame (a + of_nat y * 8) s = in_user_frame a s" -proof - - have "\sz. (a + of_nat y * 8) && ~~ mask (pageBitsForSize sz) = - a && ~~ mask (pageBitsForSize sz)" - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (rule is_aligned_add_helper [OF al, THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 3, simplified]) - apply (rule order_less_le_trans [OF y]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp add: msg_align_bits pageBits_def) - apply (case_tac sz, simp_all add: msg_align_bits bit_simps) - done - - thus ?thesis by (simp add: in_user_frame_def) -qed - -lemma loadWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + of_nat y * 8))" - unfolding loadWordUser_def - apply (rule corres_stateAssert_assume [rotated]) - apply (erule valid_ipc_buffer_ptr'D[OF y]) - apply (rule corres_guard_imp) - apply (simp add: load_word_offs_def word_size_def) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_pre) - apply wp - apply (simp add: word_size_bits_def) - apply (erule aligned_add_aligned) - apply (rule is_aligned_mult_triv2[where n = 3, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply (simp add: valid_ipc_buffer_ptr'_def msg_align_bits) - done - -lemma storeWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres dc (in_user_frame a) (valid_ipc_buffer_ptr' a) - (store_word_offs a y w) (storeWordUser (a + of_nat y * 8) w)" - apply (simp add: storeWordUser_def bind_assoc[symmetric] - store_word_offs_def word_size_def) - apply (rule corres_guard2_imp) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_guard1_imp) - apply (rule_tac r'=dc in corres_split) - apply (simp add: stateAssert_def) - apply (rule_tac r'=dc in corres_split) - apply (rule corres_trivial) - apply simp - apply (rule corres_assert) - apply wp+ - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl]) - apply simp - apply (rule no_fail_pre) - apply (wp no_fail_storeWord) - apply (erule_tac n=msg_align_bits in aligned_add_aligned) - apply (rule is_aligned_mult_triv2 [where n = 3, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply wp+ - apply (simp add: in_user_frame_eq[OF y]) - apply simp - apply (rule conjI) - apply (frule (1) valid_ipc_buffer_ptr'D [OF y]) - apply (simp add: valid_ipc_buffer_ptr'_def) - done + shows "in_user_frame (a + of_nat y * word_size) s = in_user_frame a s" + using in_user_frame_eq_helper[OF y al] + by (simp add: in_user_frame_def) lemmas msgRegisters_unfold = AARCH64_H.msgRegisters_def @@ -708,55 +643,25 @@ lemma thread_get_registers: apply (clarsimp simp: map_upd_triv select_f_def image_def return_def) done -lemma getMRs_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) - (case_option \ valid_ipc_buffer_ptr' buf) - (get_mrs t buf mi) (getMRs t buf (message_info_map mi))" - proof - - have S: "get = gets id" - by (simp add: gets_def) - have T: "corres (\con regs. regs = map con msg_registers) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (thread_get (arch_tcb_get_registers o tcb_arch) t) - (asUser t (mapM getRegister AARCH64_H.msgRegisters))" - apply (subst thread_get_registers) - apply (rule asUser_corres') - apply (subst mapM_gets) - apply (simp add: getRegister_def) - apply (simp add: S AARCH64_H.msgRegisters_def msg_registers_def) - done - show ?thesis - apply (case_tac mi, simp add: get_mrs_def getMRs_def split del: if_split) - apply (case_tac buf) - apply (rule corres_guard_imp) - apply (rule corres_split [where R = "\_. \" and R' = "\_. \", OF T]) - apply simp - apply wp+ - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule corres_split[OF T]) - apply (simp only: option.simps return_bind fun_app_def - load_word_offs_def doMachineOp_mapM loadWord_empty_fail) - apply (rule corres_split_eqr) - apply (simp only: mapM_map_simp msgMaxLength_def msgLengthBits_def - msg_max_length_def o_def upto_enum_word) - apply (rule corres_mapM [where r'="(=)" and S="{a. fst a = snd a \ fst a < unat max_ipc_words}"]) - apply simp - apply simp - apply (simp add: word_size wordSize_def wordBits_def) - apply (rule loadWordUser_corres) - apply simp - apply wp+ - apply simp - apply (unfold msgRegisters_unfold)[1] - apply simp - apply (clarsimp simp: set_zip) - apply (simp add: msgRegisters_unfold max_ipc_words nth_append) - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift | simp add: valid_ipc_buffer_ptr'_def)+ +lemma msgRegisters_msg_registers[TcbAcc_R_2_assms]: + "msgRegisters = msg_registers" + by (simp add: msgRegisters_unfold) + +lemma suc_len_msg_registers_less_2p_word_bits[TcbAcc_R_2_assms]: + "Suc (length msg_registers) < 2 ^ word_bits" + by (simp add: msgRegisters_unfold word_bits_def) + +lemma asUser_mapM_getRegister_corres[TcbAcc_R_2_assms]: + "corres (\con regs. regs = map con msg_registers) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (arch_tcb_get_registers o tcb_arch) t) + (asUser t (mapM getRegister msgRegisters))" + apply (subst thread_get_registers) + apply (rule asUser_corres') + apply (subst mapM_gets) + apply (simp add: getRegister_def) + apply (simp add: msgRegisters_msg_registers) done -qed lemma thread_set_as_user_registers: "thread_set (\tcb. tcb \ tcb_arch := arch_tcb_set_registers (f (arch_tcb_get_registers (tcb_arch tcb))) @@ -781,154 +686,6 @@ lemma UserContext_fold: apply (metis user_context.sel) done -lemma setMRs_corres: - assumes m: "mrs' = mrs" - shows - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) - (case_option \ valid_ipc_buffer_ptr' buf) - (set_mrs t buf mrs) (setMRs t buf mrs')" -proof - - have setRegister_def2: - "setRegister = (\r v. modify (\s. UserContext (user_fpu_state s) ((user_regs s)(r := v))))" - by ((rule ext)+, simp add: setRegister_def) - - have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" - by (simp add: zip_take_triv2 drop_take) - - note upt.simps[simp del] upt_rec_numeral[simp del] - - show ?thesis using m - unfolding setMRs_def set_mrs_def - apply (clarsimp cong: option.case_cong split del: if_split) - apply (subst bind_assoc[symmetric]) - apply (fold thread_set_def[simplified]) - apply (subst thread_set_as_user_registers) - apply (cases buf) - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold - modify_registers_def - cong: if_cong simp del: the_index.simps) - apply simp - apply (rule corres_trivial, simp) - apply ((wp |simp)+)[4] - \ \buf = Some a\ - using if_split[split del] - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute - msgMaxLength_def msgLengthBits_def) - apply (simp add: msg_max_length_def) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (simp only: msgRegisters_unfold cong: if_cong) - apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) - apply simp - apply (rule corres_split_nor) - apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * 8)) \ x < unat max_ipc_words}" - in zipWithM_x_corres) - apply (fastforce intro: storeWordUser_corres) - apply wp+ - apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) - apply (simp add: wordSize_def wordBits_def word_size max_ipc_words - upt_Suc_append[symmetric] upto_enum_word) - apply simp - apply (rule corres_trivial, clarsimp simp: min.commute) - apply wp+ - apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ - done -qed - -lemma copyMRs_corres: - "corres (=) (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct - and case_option \ in_user_frame sb - and case_option \ in_user_frame rb - and K (unat n \ msg_max_length)) - (case_option \ valid_ipc_buffer_ptr' sb - and case_option \ valid_ipc_buffer_ptr' rb) - (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" -proof - - have U: "unat n \ msg_max_length \ - map (toEnum :: nat \ machine_word) [7 ..< Suc (unat n)] = map of_nat [7 ..< Suc (unat n)]" - unfolding msg_max_length_def by auto - note R'=msgRegisters_unfold[THEN meta_eq_to_obj_eq, THEN arg_cong[where f=length]] - note R=R'[simplified] - - have as_user_bit: - "\v :: machine_word. - corres dc (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct) - \ - (mapM - (\ra. do v \ as_user s (getRegister ra); - as_user r (setRegister ra v) - od) - (take (unat n) msg_registers)) - (mapM - (\ra. do v \ asUser s (getRegister ra); - asUser r (setRegister ra v) - od) - (take (unat n) msgRegisters))" - apply (rule corres_guard_imp) - apply (rule_tac S=Id in corres_mapM, simp+) - apply (rule corres_split_eqr[OF asUser_getRegister_corres asUser_setRegister_corres]) - apply (wp | clarsimp simp: msg_registers_def msgRegisters_def)+ - done - - have wordSize[simp]: "of_nat wordSize = 8" - by (simp add: wordSize_def wordBits_def word_size) - - show ?thesis - apply (rule corres_assume_pre) - apply (simp add: copy_mrs_def copyMRs_def word_size - cong: option.case_cong - split del: if_split del: upt.simps) - apply (cases sb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (cases rb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (simp add: R del: upt.simps) - apply (rule corres_guard_imp) - apply (rename_tac sb_ptr rb_ptr) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_split_eqr) - apply (rule_tac S="{(x, y). y = of_nat x \ x < unat max_ipc_words}" - in corres_mapM, simp+) - apply (rule corres_split_eqr) - apply (rule loadWordUser_corres) - apply simp - apply (rule storeWordUser_corres) - apply simp - apply (wp hoare_vcg_all_lift | simp)+ - apply (clarsimp simp: upto_enum_def) - apply arith - apply (subst set_zip) - apply (simp add: upto_enum_def U del: upt.simps) - apply (clarsimp simp del: upt.simps) - apply (clarsimp simp: msg_max_length_def word_le_nat_alt nth_append - max_ipc_words) - apply (erule order_less_trans) - apply simp - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift mapM_wp' - | simp add: valid_ipc_buffer_ptr'_def)+ - done -qed - lemma cte_at_tcb_at_32': (* FIXME arch-split: can't be generic with this 32 *) "tcb_at' t s \ cte_at' (t + 32) s" by (simp add: cte_at'_obj_at' tcb_cte_cases_def cteSizeBits_def) @@ -1100,6 +857,9 @@ lemma tcbSchedAppend_pspace_in_kernel_mappings'[TcbAcc_R_2_assms]: "tcbSchedAppend t \pspace_in_kernel_mappings'\" by wpsimp +(* length_type is machine_word on all architectures *) +lemmas [TcbAcc_R_2_assms] = meta_eq_to_obj_eq[OF nat_to_len_def] + end (* Arch *) interpretation TcbAcc_R_2?: TcbAcc_R_2 @@ -1112,6 +872,67 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms +lemma setMRs_corres: + assumes m: "mrs' = mrs" + shows + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) + (case_option \ valid_ipc_buffer_ptr' buf) + (set_mrs t buf mrs) (setMRs t buf mrs')" +proof - + have setRegister_def2: + "setRegister = (\r v. modify (\s. UserContext (user_fpu_state s) ((user_regs s)(r := v))))" + by ((rule ext)+, simp add: setRegister_def) + + have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" + by (simp add: zip_take_triv2 drop_take) + + note upt.simps[simp del] upt_rec_numeral[simp del] + + show ?thesis using m + unfolding setMRs_def set_mrs_def + apply (clarsimp cong: option.case_cong split del: if_split) + apply (subst bind_assoc[symmetric]) + apply (fold thread_set_def[simplified]) + apply (subst thread_set_as_user_registers) + apply (cases buf) + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold + modify_registers_def + cong: if_cong simp del: the_index.simps) + apply simp + apply (rule corres_trivial, simp) + apply ((wp |simp)+)[4] + \ \buf = Some a\ + using if_split[split del] + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute + msgMaxLength_def msgLengthBits_def) + apply (simp add: msg_max_length_def) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (simp only: msgRegisters_unfold cong: if_cong) + apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) + apply simp + apply (rule corres_split_nor) + apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * word_size)) \ x < unat max_ipc_words}" + in zipWithM_x_corres) + apply (fastforce intro: storeWordUser_corres) + apply wp+ + apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) + apply (simp add: wordSize_word_size max_ipc_words + upt_Suc_append[symmetric] upto_enum_word) + apply simp + apply (rule corres_trivial, clarsimp simp: min.commute) + apply wp+ + apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ + done +qed + lemma sts_iflive'[TcbAcc_R_3_assms, wp]: "\\s. if_live_then_nonz_cap' s \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) @@ -1134,6 +955,10 @@ lemma asUser_invs[wp]: apply (wpsimp wp: threadSet_invs_trivial threadGet_wp) done +(* interface lemma, but can't be done via locale *) +crunch storeWordUser + for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -1151,9 +976,11 @@ arch_requalify_facts asUser_corres asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' lemmas [wp] = asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' end diff --git a/proof/refine/ARM/ArchTcbAcc_R.thy b/proof/refine/ARM/ArchTcbAcc_R.thy index c7f5555d9b..8171c5867f 100644 --- a/proof/refine/ARM/ArchTcbAcc_R.thy +++ b/proof/refine/ARM/ArchTcbAcc_R.thy @@ -295,6 +295,24 @@ lemma pspace_dom_dom[TcbAcc_R_assms]: apply (case_tac vmpage_size, simp_all add: pageBits_def) done +lemma less_max_ipc_words_less_2p_msg_align_bits[TcbAcc_R_assms]: + assumes y: "y < unat max_ipc_words" + shows "word_of_nat y * (word_size :: machine_word) < 2 ^ msg_align_bits" + apply (simp add: word_size_def word_size_bits_def) + apply (rule word_less_power_trans_ofnat[where k = 2, simplified]) + apply (rule order_less_le_trans[OF y]) + apply (simp add: msg_align_bits max_ipc_words)+ + done + +lemma is_aligned_word_size_bits_less_max_ipc_words[TcbAcc_R_assms]: + "y < unat max_ipc_words \ is_aligned (word_of_nat y * word_size) word_size_bits" + by (simp add: word_size_def word_size_bits_def) + (rule is_aligned_mult_triv2[where n=2, simplified]) + +lemma msg_align_bits_le_pageBitsForSize[TcbAcc_R_assms]: + "msg_align_bits \ pageBitsForSize sz" + by (simp add: msg_align_bits pageBitsForSize_def split: vmpage_size.split) + lemmas [TcbAcc_R_assms] = dmo_getirq_inv getActiveIRQ_masked @@ -571,95 +589,12 @@ lemma addToBitmap_valid_bitmapQ_except[TcbAcc_R_2_assms]: dest: prioToL1Index_bits_low_high_eq) done -lemma valid_ipc_buffer_ptr'D: - assumes yv: "y < unat max_ipc_words" - and buf: "valid_ipc_buffer_ptr' a s" - shows "pointerInUserData (a + of_nat y * 4) s" - using buf unfolding valid_ipc_buffer_ptr'_def pointerInUserData_def - apply clarsimp - apply (subgoal_tac - "(a + of_nat y * 4) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 2, simplified]) - apply (rule order_less_le_trans [OF yv]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp_all add: msg_align_bits pageBits_def) - done - -lemma in_user_frame_eq: +lemma in_user_frame_eq[TcbAcc_R_2_assms]: assumes y: "y < unat max_ipc_words" and al: "is_aligned a msg_align_bits" - shows "in_user_frame (a + of_nat y * 4) s = in_user_frame a s" -proof - - have "\sz. (a + of_nat y * 4) && ~~ mask (pageBitsForSize sz) = - a && ~~ mask (pageBitsForSize sz)" - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (rule is_aligned_add_helper [OF al, THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 2, simplified]) - apply (rule order_less_le_trans [OF y]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp add: msg_align_bits pageBits_def) - apply (case_tac sz, simp_all add: msg_align_bits) - done - - thus ?thesis by (simp add: in_user_frame_def) -qed - -lemma loadWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + of_nat y * 4))" - unfolding loadWordUser_def - apply (rule corres_stateAssert_assume [rotated]) - apply (erule valid_ipc_buffer_ptr'D[OF y]) - apply (rule corres_guard_imp) - apply (simp add: load_word_offs_def word_size_def) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_pre) - apply wp - apply (simp add: word_size_bits_def) - apply (erule aligned_add_aligned) - apply (rule is_aligned_mult_triv2[where n = 2, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply (simp add: valid_ipc_buffer_ptr'_def msg_align_bits) - done - -lemma storeWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres dc (in_user_frame a) (valid_ipc_buffer_ptr' a) - (store_word_offs a y w) (storeWordUser (a + of_nat y * 4) w)" - apply (simp add: storeWordUser_def bind_assoc[symmetric] - store_word_offs_def word_size_def) - apply (rule corres_guard2_imp) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_guard1_imp) - apply (rule_tac r'=dc in corres_split) - apply (simp add: stateAssert_def) - apply (rule_tac r'=dc in corres_split) - apply (rule corres_trivial) - apply simp - apply (rule corres_assert) - apply wp+ - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl]) - apply simp - apply (rule no_fail_pre) - apply (wp no_fail_storeWord) - apply (erule_tac n=msg_align_bits in aligned_add_aligned) - apply (rule is_aligned_mult_triv2[where n = 2, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply wp+ - apply (simp add: in_user_frame_eq[OF y]) - apply simp - apply (rule conjI) - apply (frule (1) valid_ipc_buffer_ptr'D [OF y]) - apply (simp add: valid_ipc_buffer_ptr'_def) - done + shows "in_user_frame (a + of_nat y * word_size) s = in_user_frame a s" + using in_user_frame_eq_helper[OF y al] + by (simp add: in_user_frame_def) lemmas msgRegisters_unfold = ARM_H.msgRegisters_def @@ -681,55 +616,25 @@ lemma thread_get_registers: apply (clarsimp simp: map_upd_triv select_f_def image_def return_def) done -lemma getMRs_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) - (case_option \ valid_ipc_buffer_ptr' buf) - (get_mrs t buf mi) (getMRs t buf (message_info_map mi))" - proof - - have S: "get = gets id" - by (simp add: gets_def) - have T: "corres (\con regs. regs = map con msg_registers) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (thread_get (arch_tcb_get_registers o tcb_arch) t) - (asUser t (mapM getRegister ARM_H.msgRegisters))" - apply (subst thread_get_registers) - apply (rule asUser_corres') - apply (subst mapM_gets) - apply (simp add: getRegister_def) - apply (simp add: S ARM_H.msgRegisters_def msg_registers_def) - done - show ?thesis - apply (case_tac mi, simp add: get_mrs_def getMRs_def split del: if_split) - apply (case_tac buf) - apply (rule corres_guard_imp) - apply (rule corres_split [where R = "\_. \" and R' = "\_. \", OF T]) - apply simp - apply wp+ - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule corres_split[OF T]) - apply (simp only: option.simps return_bind fun_app_def - load_word_offs_def doMachineOp_mapM loadWord_empty_fail) - apply (rule corres_split_eqr) - apply (simp only: mapM_map_simp msgMaxLength_def msgLengthBits_def - msg_max_length_def o_def upto_enum_word) - apply (rule corres_mapM [where r'="(=)" and S="{a. fst a = snd a \ fst a < unat max_ipc_words}"]) - apply simp - apply simp - apply (simp add: word_size wordSize_def wordBits_def) - apply (rule loadWordUser_corres) - apply simp - apply wp+ - apply simp - apply (unfold msgRegisters_unfold)[1] - apply simp - apply (clarsimp simp: set_zip) - apply (simp add: msgRegisters_unfold max_ipc_words nth_append) - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift | simp add: valid_ipc_buffer_ptr'_def)+ +lemma msgRegisters_msg_registers[TcbAcc_R_2_assms]: + "msgRegisters = msg_registers" + by (simp add: msgRegisters_unfold) + +lemma suc_len_msg_registers_less_2p_word_bits[TcbAcc_R_2_assms]: + "Suc (length msg_registers) < 2 ^ word_bits" + by (simp add: msgRegisters_unfold word_bits_def) + +lemma asUser_mapM_getRegister_corres[TcbAcc_R_2_assms]: + "corres (\con regs. regs = map con msg_registers) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (arch_tcb_get_registers o tcb_arch) t) + (asUser t (mapM getRegister msgRegisters))" + apply (subst thread_get_registers) + apply (rule asUser_corres') + apply (subst mapM_gets) + apply (simp add: getRegister_def) + apply (simp add: msgRegisters_msg_registers) done -qed lemma thread_set_as_user_registers: "thread_set (\tcb. tcb \ tcb_arch := arch_tcb_set_registers (f (arch_tcb_get_registers (tcb_arch tcb))) @@ -753,154 +658,6 @@ lemma UserContext_fold: apply (clarsimp split: prod.splits) by (metis user_context.sel(1)) -lemma setMRs_corres: - assumes m: "mrs' = mrs" - shows - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) - (case_option \ valid_ipc_buffer_ptr' buf) - (set_mrs t buf mrs) (setMRs t buf mrs')" -proof - - have setRegister_def2: - "setRegister = (\r v. modify (\s. UserContext ((user_regs s)(r := v))))" - by ((rule ext)+, simp add: setRegister_def) - - have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" - by (simp add: zip_take_triv2 drop_take) - - note upt.simps[simp del] upt_rec_numeral[simp del] - - show ?thesis using m - unfolding setMRs_def set_mrs_def - apply (clarsimp cong: option.case_cong split del: if_split) - apply (subst bind_assoc[symmetric]) - apply (fold thread_set_def[simplified]) - apply (subst thread_set_as_user_registers) - apply (cases buf) - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold - modify_registers_def - cong: if_cong simp del: the_index.simps) - apply simp - apply (rule corres_trivial, simp) - apply ((wp |simp)+)[4] - \ \buf = Some a\ - using if_split[split del] - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute - msgMaxLength_def msgLengthBits_def) - apply (simp add: msg_max_length_def) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (simp only: msgRegisters_unfold cong: if_cong) - apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) - apply simp - apply (rule corres_split_nor) - apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * 4)) \ x < unat max_ipc_words}" - in zipWithM_x_corres) - apply (fastforce intro: storeWordUser_corres) - apply wp+ - apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) - apply (simp add: wordSize_def wordBits_def word_size max_ipc_words - upt_Suc_append[symmetric] upto_enum_word) - apply simp - apply (rule corres_trivial, clarsimp simp: min.commute) - apply wp+ - apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ - done -qed - -lemma copyMRs_corres: - "corres (=) (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct - and case_option \ in_user_frame sb - and case_option \ in_user_frame rb - and K (unat n \ msg_max_length)) - (case_option \ valid_ipc_buffer_ptr' sb - and case_option \ valid_ipc_buffer_ptr' rb) - (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" -proof - - have U: "unat n \ msg_max_length \ - map (toEnum :: nat \ machine_word) [7 ..< Suc (unat n)] = map of_nat [7 ..< Suc (unat n)]" - unfolding msg_max_length_def by auto - note R'=msgRegisters_unfold[THEN meta_eq_to_obj_eq, THEN arg_cong[where f=length]] - note R=R'[simplified] - - have as_user_bit: - "\v :: machine_word. - corres dc (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct) - \ - (mapM - (\ra. do v \ as_user s (getRegister ra); - as_user r (setRegister ra v) - od) - (take (unat n) msg_registers)) - (mapM - (\ra. do v \ asUser s (getRegister ra); - asUser r (setRegister ra v) - od) - (take (unat n) msgRegisters))" - apply (rule corres_guard_imp) - apply (rule_tac S=Id in corres_mapM, simp+) - apply (rule corres_split_eqr[OF asUser_getRegister_corres asUser_setRegister_corres]) - apply (wp | clarsimp simp: msg_registers_def msgRegisters_def)+ - done - - have wordSize[simp]: "of_nat wordSize = 4" - by (simp add: wordSize_def wordBits_def word_size) - - show ?thesis - apply (rule corres_assume_pre) - apply (simp add: copy_mrs_def copyMRs_def word_size - cong: option.case_cong - split del: if_split del: upt.simps) - apply (cases sb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (cases rb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (simp add: R del: upt.simps) - apply (rule corres_guard_imp) - apply (rename_tac sb_ptr rb_ptr) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_split_eqr) - apply (rule_tac S="{(x, y). y = of_nat x \ x < unat max_ipc_words}" - in corres_mapM, simp+) - apply (rule corres_split_eqr) - apply (rule loadWordUser_corres) - apply simp - apply (rule storeWordUser_corres) - apply simp - apply (wp hoare_vcg_all_lift | simp)+ - apply (clarsimp simp: upto_enum_def) - apply arith - apply (subst set_zip) - apply (simp add: upto_enum_def U del: upt.simps) - apply (clarsimp simp del: upt.simps) - apply (clarsimp simp: msg_max_length_def word_le_nat_alt nth_append - max_ipc_words) - apply (erule order_less_trans) - apply simp - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift mapM_wp' - | simp add: valid_ipc_buffer_ptr'_def)+ - done -qed - lemma cte_at_tcb_at_16': (* FIXME arch-split: can't be generic with this 16 *) "tcb_at' t s \ cte_at' (t + 16) s" by (simp add: cte_at'_obj_at' tcb_cte_cases_def cteSizeBits_def) @@ -1072,6 +829,9 @@ lemma tcbSchedAppend_pspace_in_kernel_mappings'[TcbAcc_R_2_assms]: "tcbSchedAppend t \pspace_in_kernel_mappings'\" by wpsimp +(* length_type is machine_word on all architectures *) +lemmas [TcbAcc_R_2_assms] = meta_eq_to_obj_eq[OF nat_to_len_def] + end (* Arch *) interpretation TcbAcc_R_2?: TcbAcc_R_2 @@ -1084,6 +844,67 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms +lemma setMRs_corres: + assumes m: "mrs' = mrs" + shows + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) + (case_option \ valid_ipc_buffer_ptr' buf) + (set_mrs t buf mrs) (setMRs t buf mrs')" +proof - + have setRegister_def2: + "setRegister = (\r v. modify (\s. UserContext ((user_regs s)(r := v))))" + by ((rule ext)+, simp add: setRegister_def) + + have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" + by (simp add: zip_take_triv2 drop_take) + + note upt.simps[simp del] upt_rec_numeral[simp del] + + show ?thesis using m + unfolding setMRs_def set_mrs_def + apply (clarsimp cong: option.case_cong split del: if_split) + apply (subst bind_assoc[symmetric]) + apply (fold thread_set_def[simplified]) + apply (subst thread_set_as_user_registers) + apply (cases buf) + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold + modify_registers_def + cong: if_cong simp del: the_index.simps) + apply simp + apply (rule corres_trivial, simp) + apply ((wp |simp)+)[4] + \ \buf = Some a\ + using if_split[split del] + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute + msgMaxLength_def msgLengthBits_def) + apply (simp add: msg_max_length_def) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (simp only: msgRegisters_unfold cong: if_cong) + apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) + apply simp + apply (rule corres_split_nor) + apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * word_size)) \ x < unat max_ipc_words}" + in zipWithM_x_corres) + apply (fastforce intro: storeWordUser_corres) + apply wp+ + apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) + apply (simp add: wordSize_word_size max_ipc_words + upt_Suc_append[symmetric] upto_enum_word) + apply simp + apply (rule corres_trivial, clarsimp simp: min.commute) + apply wp+ + apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ + done +qed + lemma sts_iflive'[TcbAcc_R_3_assms, wp]: "\\s. if_live_then_nonz_cap' s \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) @@ -1106,6 +927,10 @@ lemma asUser_invs[wp]: apply (wpsimp wp: threadSet_invs_trivial threadGet_wp) done +(* interface lemma, but can't be done via locale *) +crunch storeWordUser + for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -1123,9 +948,11 @@ arch_requalify_facts asUser_corres asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' lemmas [wp] = asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' end diff --git a/proof/refine/ARM_HYP/ArchTcbAcc_R.thy b/proof/refine/ARM_HYP/ArchTcbAcc_R.thy index be426a064b..beab48d04f 100644 --- a/proof/refine/ARM_HYP/ArchTcbAcc_R.thy +++ b/proof/refine/ARM_HYP/ArchTcbAcc_R.thy @@ -324,6 +324,24 @@ lemma pspace_dom_dom[TcbAcc_R_assms]: apply (case_tac vmpage_size, simp_all add: pageBits_def) done +lemma less_max_ipc_words_less_2p_msg_align_bits[TcbAcc_R_assms]: + assumes y: "y < unat max_ipc_words" + shows "word_of_nat y * (word_size :: machine_word) < 2 ^ msg_align_bits" + apply (simp add: word_size_def word_size_bits_def) + apply (rule word_less_power_trans_ofnat[where k = 2, simplified]) + apply (rule order_less_le_trans[OF y]) + apply (simp add: msg_align_bits max_ipc_words)+ + done + +lemma is_aligned_word_size_bits_less_max_ipc_words[TcbAcc_R_assms]: + "y < unat max_ipc_words \ is_aligned (word_of_nat y * word_size) word_size_bits" + by (simp add: word_size_def word_size_bits_def) + (rule is_aligned_mult_triv2[where n=2, simplified]) + +lemma msg_align_bits_le_pageBitsForSize[TcbAcc_R_assms]: + "msg_align_bits \ pageBitsForSize sz" + by (simp add: msg_align_bits pageBitsForSize_def split: vmpage_size.split) + lemmas [TcbAcc_R_assms] = dmo_getirq_inv getActiveIRQ_masked @@ -609,95 +627,12 @@ lemma addToBitmap_valid_bitmapQ_except[TcbAcc_R_2_assms]: dest: prioToL1Index_bits_low_high_eq) done -lemma valid_ipc_buffer_ptr'D: - assumes yv: "y < unat max_ipc_words" - and buf: "valid_ipc_buffer_ptr' a s" - shows "pointerInUserData (a + of_nat y * 4) s" - using buf unfolding valid_ipc_buffer_ptr'_def pointerInUserData_def - apply clarsimp - apply (subgoal_tac - "(a + of_nat y * 4) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 2, simplified]) - apply (rule order_less_le_trans [OF yv]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp_all add: msg_align_bits pageBits_def) - done - -lemma in_user_frame_eq: +lemma in_user_frame_eq[TcbAcc_R_2_assms]: assumes y: "y < unat max_ipc_words" and al: "is_aligned a msg_align_bits" - shows "in_user_frame (a + of_nat y * 4) s = in_user_frame a s" -proof - - have "\sz. (a + of_nat y * 4) && ~~ mask (pageBitsForSize sz) = - a && ~~ mask (pageBitsForSize sz)" - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (rule is_aligned_add_helper [OF al, THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 2, simplified]) - apply (rule order_less_le_trans [OF y]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp add: msg_align_bits pageBits_def) - apply (case_tac sz, simp_all add: msg_align_bits) - done - - thus ?thesis by (simp add: in_user_frame_def) -qed - -lemma loadWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + of_nat y * 4))" - unfolding loadWordUser_def - apply (rule corres_stateAssert_assume [rotated]) - apply (erule valid_ipc_buffer_ptr'D[OF y]) - apply (rule corres_guard_imp) - apply (simp add: load_word_offs_def word_size_def) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_pre) - apply wp - apply (simp add: word_size_bits_def) - apply (erule aligned_add_aligned) - apply (rule is_aligned_mult_triv2[where n = 2, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply (simp add: valid_ipc_buffer_ptr'_def msg_align_bits) - done - -lemma storeWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres dc (in_user_frame a) (valid_ipc_buffer_ptr' a) - (store_word_offs a y w) (storeWordUser (a + of_nat y * 4) w)" - apply (simp add: storeWordUser_def bind_assoc[symmetric] - store_word_offs_def word_size_def) - apply (rule corres_guard2_imp) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_guard1_imp) - apply (rule_tac r'=dc in corres_split) - apply (simp add: stateAssert_def) - apply (rule_tac r'=dc in corres_split) - apply (rule corres_trivial) - apply simp - apply (rule corres_assert) - apply wp+ - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl]) - apply simp - apply (rule no_fail_pre) - apply (wp no_fail_storeWord) - apply (erule_tac n=msg_align_bits in aligned_add_aligned) - apply (rule is_aligned_mult_triv2[where n = 2, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply wp+ - apply (simp add: in_user_frame_eq[OF y]) - apply simp - apply (rule conjI) - apply (frule (1) valid_ipc_buffer_ptr'D [OF y]) - apply (simp add: valid_ipc_buffer_ptr'_def) - done + shows "in_user_frame (a + of_nat y * word_size) s = in_user_frame a s" + using in_user_frame_eq_helper[OF y al] + by (simp add: in_user_frame_def) lemmas msgRegisters_unfold = ARM_HYP_H.msgRegisters_def @@ -719,55 +654,25 @@ lemma thread_get_registers: apply (clarsimp simp: map_upd_triv select_f_def image_def return_def) done -lemma getMRs_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) - (case_option \ valid_ipc_buffer_ptr' buf) - (get_mrs t buf mi) (getMRs t buf (message_info_map mi))" - proof - - have S: "get = gets id" - by (simp add: gets_def) - have T: "corres (\con regs. regs = map con msg_registers) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (thread_get (arch_tcb_get_registers o tcb_arch) t) - (asUser t (mapM getRegister ARM_HYP_H.msgRegisters))" - apply (subst thread_get_registers) - apply (rule asUser_corres') - apply (subst mapM_gets) - apply (simp add: getRegister_def) - apply (simp add: S ARM_HYP_H.msgRegisters_def msg_registers_def) - done - show ?thesis - apply (case_tac mi, simp add: get_mrs_def getMRs_def split del: if_split) - apply (case_tac buf) - apply (rule corres_guard_imp) - apply (rule corres_split [where R = "\_. \" and R' = "\_. \", OF T]) - apply simp - apply wp+ - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule corres_split[OF T]) - apply (simp only: option.simps return_bind fun_app_def - load_word_offs_def doMachineOp_mapM loadWord_empty_fail) - apply (rule corres_split_eqr) - apply (simp only: mapM_map_simp msgMaxLength_def msgLengthBits_def - msg_max_length_def o_def upto_enum_word) - apply (rule corres_mapM [where r'="(=)" and S="{a. fst a = snd a \ fst a < unat max_ipc_words}"]) - apply simp - apply simp - apply (simp add: word_size wordSize_def wordBits_def) - apply (rule loadWordUser_corres) - apply simp - apply wp+ - apply simp - apply (unfold msgRegisters_unfold)[1] - apply simp - apply (clarsimp simp: set_zip) - apply (simp add: msgRegisters_unfold max_ipc_words nth_append) - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift | simp add: valid_ipc_buffer_ptr'_def)+ +lemma msgRegisters_msg_registers[TcbAcc_R_2_assms]: + "msgRegisters = msg_registers" + by (simp add: msgRegisters_unfold) + +lemma suc_len_msg_registers_less_2p_word_bits[TcbAcc_R_2_assms]: + "Suc (length msg_registers) < 2 ^ word_bits" + by (simp add: msgRegisters_unfold word_bits_def) + +lemma asUser_mapM_getRegister_corres[TcbAcc_R_2_assms]: + "corres (\con regs. regs = map con msg_registers) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (arch_tcb_get_registers o tcb_arch) t) + (asUser t (mapM getRegister msgRegisters))" + apply (subst thread_get_registers) + apply (rule asUser_corres') + apply (subst mapM_gets) + apply (simp add: getRegister_def) + apply (simp add: msgRegisters_msg_registers) done -qed lemma thread_set_as_user_registers: "thread_set (\tcb. tcb \ tcb_arch := arch_tcb_set_registers (f (arch_tcb_get_registers (tcb_arch tcb))) @@ -791,154 +696,6 @@ lemma UserContext_fold: apply (clarsimp split: prod.splits) by (metis user_context.sel(1)) -lemma setMRs_corres: - assumes m: "mrs' = mrs" - shows - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) - (case_option \ valid_ipc_buffer_ptr' buf) - (set_mrs t buf mrs) (setMRs t buf mrs')" -proof - - have setRegister_def2: - "setRegister = (\r v. modify (\s. UserContext ((user_regs s)(r := v))))" - by ((rule ext)+, simp add: setRegister_def) - - have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" - by (simp add: zip_take_triv2 drop_take) - - note upt.simps[simp del] upt_rec_numeral[simp del] - - show ?thesis using m - unfolding setMRs_def set_mrs_def - apply (clarsimp cong: option.case_cong split del: if_split) - apply (subst bind_assoc[symmetric]) - apply (fold thread_set_def[simplified]) - apply (subst thread_set_as_user_registers) - apply (cases buf) - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold - modify_registers_def - cong: if_cong simp del: the_index.simps) - apply simp - apply (rule corres_trivial, simp) - apply ((wp |simp)+)[4] - \ \buf = Some a\ - using if_split[split del] - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute - msgMaxLength_def msgLengthBits_def) - apply (simp add: msg_max_length_def) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (simp only: msgRegisters_unfold cong: if_cong) - apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) - apply simp - apply (rule corres_split_nor) - apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * 4)) \ x < unat max_ipc_words}" - in zipWithM_x_corres) - apply (fastforce intro: storeWordUser_corres) - apply wp+ - apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) - apply (simp add: wordSize_def wordBits_def word_size max_ipc_words - upt_Suc_append[symmetric] upto_enum_word) - apply simp - apply (rule corres_trivial, clarsimp simp: min.commute) - apply wp+ - apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ - done -qed - -lemma copyMRs_corres: - "corres (=) (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct - and case_option \ in_user_frame sb - and case_option \ in_user_frame rb - and K (unat n \ msg_max_length)) - (case_option \ valid_ipc_buffer_ptr' sb - and case_option \ valid_ipc_buffer_ptr' rb) - (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" -proof - - have U: "unat n \ msg_max_length \ - map (toEnum :: nat \ machine_word) [7 ..< Suc (unat n)] = map of_nat [7 ..< Suc (unat n)]" - unfolding msg_max_length_def by auto - note R'=msgRegisters_unfold[THEN meta_eq_to_obj_eq, THEN arg_cong[where f=length]] - note R=R'[simplified] - - have as_user_bit: - "\v :: machine_word. - corres dc (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct) - \ - (mapM - (\ra. do v \ as_user s (getRegister ra); - as_user r (setRegister ra v) - od) - (take (unat n) msg_registers)) - (mapM - (\ra. do v \ asUser s (getRegister ra); - asUser r (setRegister ra v) - od) - (take (unat n) msgRegisters))" - apply (rule corres_guard_imp) - apply (rule_tac S=Id in corres_mapM, simp+) - apply (rule corres_split_eqr[OF asUser_getRegister_corres asUser_setRegister_corres]) - apply (wp | clarsimp simp: msg_registers_def msgRegisters_def)+ - done - - have wordSize[simp]: "of_nat wordSize = 4" - by (simp add: wordSize_def wordBits_def word_size) - - show ?thesis - apply (rule corres_assume_pre) - apply (simp add: copy_mrs_def copyMRs_def word_size - cong: option.case_cong - split del: if_split del: upt.simps) - apply (cases sb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (cases rb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (simp add: R del: upt.simps) - apply (rule corres_guard_imp) - apply (rename_tac sb_ptr rb_ptr) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_split_eqr) - apply (rule_tac S="{(x, y). y = of_nat x \ x < unat max_ipc_words}" - in corres_mapM, simp+) - apply (rule corres_split_eqr) - apply (rule loadWordUser_corres) - apply simp - apply (rule storeWordUser_corres) - apply simp - apply (wp hoare_vcg_all_lift | simp)+ - apply (clarsimp simp: upto_enum_def) - apply arith - apply (subst set_zip) - apply (simp add: upto_enum_def U del: upt.simps) - apply (clarsimp simp del: upt.simps) - apply (clarsimp simp: msg_max_length_def word_le_nat_alt nth_append - max_ipc_words) - apply (erule order_less_trans) - apply simp - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift mapM_wp' - | simp add: valid_ipc_buffer_ptr'_def)+ - done -qed - lemma cte_at_tcb_at_16': (* FIXME arch-split: can't be generic with this 16 *) "tcb_at' t s \ cte_at' (t + 16) s" by (simp add: cte_at'_obj_at' tcb_cte_cases_def cteSizeBits_def) @@ -1110,6 +867,9 @@ lemma tcbSchedAppend_pspace_in_kernel_mappings'[TcbAcc_R_2_assms]: "tcbSchedAppend t \pspace_in_kernel_mappings'\" by wpsimp +(* length_type is machine_word on all architectures *) +lemmas [TcbAcc_R_2_assms] = meta_eq_to_obj_eq[OF nat_to_len_def] + end (* Arch *) interpretation TcbAcc_R_2?: TcbAcc_R_2 @@ -1122,6 +882,67 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms +lemma setMRs_corres: + assumes m: "mrs' = mrs" + shows + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) + (case_option \ valid_ipc_buffer_ptr' buf) + (set_mrs t buf mrs) (setMRs t buf mrs')" +proof - + have setRegister_def2: + "setRegister = (\r v. modify (\s. UserContext ((user_regs s)(r := v))))" + by ((rule ext)+, simp add: setRegister_def) + + have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" + by (simp add: zip_take_triv2 drop_take) + + note upt.simps[simp del] upt_rec_numeral[simp del] + + show ?thesis using m + unfolding setMRs_def set_mrs_def + apply (clarsimp cong: option.case_cong split del: if_split) + apply (subst bind_assoc[symmetric]) + apply (fold thread_set_def[simplified]) + apply (subst thread_set_as_user_registers) + apply (cases buf) + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold + modify_registers_def + cong: if_cong simp del: the_index.simps) + apply simp + apply (rule corres_trivial, simp) + apply ((wp |simp)+)[4] + \ \buf = Some a\ + using if_split[split del] + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute + msgMaxLength_def msgLengthBits_def) + apply (simp add: msg_max_length_def) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (simp only: msgRegisters_unfold cong: if_cong) + apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) + apply simp + apply (rule corres_split_nor) + apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * word_size)) \ x < unat max_ipc_words}" + in zipWithM_x_corres) + apply (fastforce intro: storeWordUser_corres) + apply wp+ + apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) + apply (simp add: wordSize_word_size max_ipc_words + upt_Suc_append[symmetric] upto_enum_word) + apply simp + apply (rule corres_trivial, clarsimp simp: min.commute) + apply wp+ + apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ + done +qed + lemma sts_iflive'[TcbAcc_R_3_assms, wp]: "\\s. if_live_then_nonz_cap' s \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) @@ -1144,6 +965,10 @@ lemma asUser_invs[wp]: apply (wpsimp wp: threadSet_invs_trivial threadGet_wp) done +(* interface lemma, but can't be done via locale *) +crunch storeWordUser + for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -1161,9 +986,11 @@ arch_requalify_facts asUser_corres asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' lemmas [wp] = asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' end diff --git a/proof/refine/RISCV64/ArchTcbAcc_R.thy b/proof/refine/RISCV64/ArchTcbAcc_R.thy index 50d95e20b5..306c180d53 100644 --- a/proof/refine/RISCV64/ArchTcbAcc_R.thy +++ b/proof/refine/RISCV64/ArchTcbAcc_R.thy @@ -284,6 +284,24 @@ lemma pspace_dom_dom[TcbAcc_R_assms]: apply (simp add: pageBitsForSize_def bit_simps split: vmpage_size.split) done +lemma less_max_ipc_words_less_2p_msg_align_bits[TcbAcc_R_assms]: + assumes y: "y < unat max_ipc_words" + shows "word_of_nat y * (word_size :: machine_word) < 2 ^ msg_align_bits" + apply (simp add: word_size_def word_size_bits_def) + apply (rule word_less_power_trans_ofnat[where k = 3, simplified]) + apply (rule order_less_le_trans[OF y]) + apply (simp add: msg_align_bits max_ipc_words)+ + done + +lemma is_aligned_word_size_bits_less_max_ipc_words[TcbAcc_R_assms]: + "y < unat max_ipc_words \ is_aligned (word_of_nat y * word_size) word_size_bits" + by (simp add: word_size_def word_size_bits_def) + (rule is_aligned_mult_triv2[where n=3, simplified]) + +lemma msg_align_bits_le_pageBitsForSize[TcbAcc_R_assms]: + "msg_align_bits \ pageBitsForSize sz" + by (simp add: msg_align_bits pageBitsForSize_def bit_simps split: vmpage_size.split) + lemmas [TcbAcc_R_assms] = dmo_getirq_inv getActiveIRQ_masked @@ -560,95 +578,12 @@ lemma addToBitmap_valid_bitmapQ_except[TcbAcc_R_2_assms]: dest: prioToL1Index_bits_low_high_eq) done -lemma valid_ipc_buffer_ptr'D: - assumes yv: "y < unat max_ipc_words" - and buf: "valid_ipc_buffer_ptr' a s" - shows "pointerInUserData (a + of_nat y * 8) s" - using buf unfolding valid_ipc_buffer_ptr'_def pointerInUserData_def - apply clarsimp - apply (subgoal_tac - "(a + of_nat y * 8) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 3, simplified]) - apply (rule order_less_le_trans [OF yv]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp_all add: msg_align_bits pageBits_def) - done - -lemma in_user_frame_eq: +lemma in_user_frame_eq[TcbAcc_R_2_assms]: assumes y: "y < unat max_ipc_words" and al: "is_aligned a msg_align_bits" - shows "in_user_frame (a + of_nat y * 8) s = in_user_frame a s" -proof - - have "\sz. (a + of_nat y * 8) && ~~ mask (pageBitsForSize sz) = - a && ~~ mask (pageBitsForSize sz)" - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (rule is_aligned_add_helper [OF al, THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 3, simplified]) - apply (rule order_less_le_trans [OF y]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp add: msg_align_bits pageBits_def) - apply (case_tac sz, simp_all add: msg_align_bits bit_simps) - done - - thus ?thesis by (simp add: in_user_frame_def) -qed - -lemma loadWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + of_nat y * 8))" - unfolding loadWordUser_def - apply (rule corres_stateAssert_assume [rotated]) - apply (erule valid_ipc_buffer_ptr'D[OF y]) - apply (rule corres_guard_imp) - apply (simp add: load_word_offs_def word_size_def) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_pre) - apply wp - apply (simp add: word_size_bits_def) - apply (erule aligned_add_aligned) - apply (rule is_aligned_mult_triv2[where n = 3, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply (simp add: valid_ipc_buffer_ptr'_def msg_align_bits) - done - -lemma storeWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres dc (in_user_frame a) (valid_ipc_buffer_ptr' a) - (store_word_offs a y w) (storeWordUser (a + of_nat y * 8) w)" - apply (simp add: storeWordUser_def bind_assoc[symmetric] - store_word_offs_def word_size_def) - apply (rule corres_guard2_imp) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_guard1_imp) - apply (rule_tac r'=dc in corres_split) - apply (simp add: stateAssert_def) - apply (rule_tac r'=dc in corres_split) - apply (rule corres_trivial) - apply simp - apply (rule corres_assert) - apply wp+ - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl]) - apply simp - apply (rule no_fail_pre) - apply (wp no_fail_storeWord) - apply (erule_tac n=msg_align_bits in aligned_add_aligned) - apply (rule is_aligned_mult_triv2 [where n = 3, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply wp+ - apply (simp add: in_user_frame_eq[OF y]) - apply simp - apply (rule conjI) - apply (frule (1) valid_ipc_buffer_ptr'D [OF y]) - apply (simp add: valid_ipc_buffer_ptr'_def) - done + shows "in_user_frame (a + of_nat y * word_size) s = in_user_frame a s" + using in_user_frame_eq_helper[OF y al] + by (simp add: in_user_frame_def) lemmas msgRegisters_unfold = RISCV64_H.msgRegisters_def @@ -670,55 +605,25 @@ lemma thread_get_registers: apply (clarsimp simp: map_upd_triv select_f_def image_def return_def) done -lemma getMRs_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) - (case_option \ valid_ipc_buffer_ptr' buf) - (get_mrs t buf mi) (getMRs t buf (message_info_map mi))" - proof - - have S: "get = gets id" - by (simp add: gets_def) - have T: "corres (\con regs. regs = map con msg_registers) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (thread_get (arch_tcb_get_registers o tcb_arch) t) - (asUser t (mapM getRegister RISCV64_H.msgRegisters))" - apply (subst thread_get_registers) - apply (rule asUser_corres') - apply (subst mapM_gets) - apply (simp add: getRegister_def) - apply (simp add: S RISCV64_H.msgRegisters_def msg_registers_def) - done - show ?thesis - apply (case_tac mi, simp add: get_mrs_def getMRs_def split del: if_split) - apply (case_tac buf) - apply (rule corres_guard_imp) - apply (rule corres_split [where R = "\_. \" and R' = "\_. \", OF T]) - apply simp - apply wp+ - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule corres_split[OF T]) - apply (simp only: option.simps return_bind fun_app_def - load_word_offs_def doMachineOp_mapM loadWord_empty_fail) - apply (rule corres_split_eqr) - apply (simp only: mapM_map_simp msgMaxLength_def msgLengthBits_def - msg_max_length_def o_def upto_enum_word) - apply (rule corres_mapM [where r'="(=)" and S="{a. fst a = snd a \ fst a < unat max_ipc_words}"]) - apply simp - apply simp - apply (simp add: word_size wordSize_def wordBits_def) - apply (rule loadWordUser_corres) - apply simp - apply wp+ - apply simp - apply (unfold msgRegisters_unfold)[1] - apply simp - apply (clarsimp simp: set_zip) - apply (simp add: msgRegisters_unfold max_ipc_words nth_append) - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift | simp add: valid_ipc_buffer_ptr'_def)+ +lemma msgRegisters_msg_registers[TcbAcc_R_2_assms]: + "msgRegisters = msg_registers" + by (simp add: msgRegisters_unfold) + +lemma suc_len_msg_registers_less_2p_word_bits[TcbAcc_R_2_assms]: + "Suc (length msg_registers) < 2 ^ word_bits" + by (simp add: msgRegisters_unfold word_bits_def) + +lemma asUser_mapM_getRegister_corres[TcbAcc_R_2_assms]: + "corres (\con regs. regs = map con msg_registers) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (arch_tcb_get_registers o tcb_arch) t) + (asUser t (mapM getRegister msgRegisters))" + apply (subst thread_get_registers) + apply (rule asUser_corres') + apply (subst mapM_gets) + apply (simp add: getRegister_def) + apply (simp add: msgRegisters_msg_registers) done -qed lemma thread_set_as_user_registers: "thread_set (\tcb. tcb \ tcb_arch := arch_tcb_set_registers (f (arch_tcb_get_registers (tcb_arch tcb))) @@ -742,154 +647,6 @@ lemma UserContext_fold: apply (clarsimp split: prod.splits) by (metis user_context.sel(1)) -lemma setMRs_corres: - assumes m: "mrs' = mrs" - shows - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) - (case_option \ valid_ipc_buffer_ptr' buf) - (set_mrs t buf mrs) (setMRs t buf mrs')" -proof - - have setRegister_def2: - "setRegister = (\r v. modify (\s. UserContext ((user_regs s)(r := v))))" - by ((rule ext)+, simp add: setRegister_def) - - have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" - by (simp add: zip_take_triv2 drop_take) - - note upt.simps[simp del] upt_rec_numeral[simp del] - - show ?thesis using m - unfolding setMRs_def set_mrs_def - apply (clarsimp cong: option.case_cong split del: if_split) - apply (subst bind_assoc[symmetric]) - apply (fold thread_set_def[simplified]) - apply (subst thread_set_as_user_registers) - apply (cases buf) - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold - modify_registers_def - cong: if_cong simp del: the_index.simps) - apply simp - apply (rule corres_trivial, simp) - apply ((wp |simp)+)[4] - \ \buf = Some a\ - using if_split[split del] - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute - msgMaxLength_def msgLengthBits_def) - apply (simp add: msg_max_length_def) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (simp only: msgRegisters_unfold cong: if_cong) - apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) - apply simp - apply (rule corres_split_nor) - apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * 8)) \ x < unat max_ipc_words}" - in zipWithM_x_corres) - apply (fastforce intro: storeWordUser_corres) - apply wp+ - apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) - apply (simp add: wordSize_def wordBits_def word_size max_ipc_words - upt_Suc_append[symmetric] upto_enum_word) - apply simp - apply (rule corres_trivial, clarsimp simp: min.commute) - apply wp+ - apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ - done -qed - -lemma copyMRs_corres: - "corres (=) (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct - and case_option \ in_user_frame sb - and case_option \ in_user_frame rb - and K (unat n \ msg_max_length)) - (case_option \ valid_ipc_buffer_ptr' sb - and case_option \ valid_ipc_buffer_ptr' rb) - (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" -proof - - have U: "unat n \ msg_max_length \ - map (toEnum :: nat \ machine_word) [7 ..< Suc (unat n)] = map of_nat [7 ..< Suc (unat n)]" - unfolding msg_max_length_def by auto - note R'=msgRegisters_unfold[THEN meta_eq_to_obj_eq, THEN arg_cong[where f=length]] - note R=R'[simplified] - - have as_user_bit: - "\v :: machine_word. - corres dc (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct) - \ - (mapM - (\ra. do v \ as_user s (getRegister ra); - as_user r (setRegister ra v) - od) - (take (unat n) msg_registers)) - (mapM - (\ra. do v \ asUser s (getRegister ra); - asUser r (setRegister ra v) - od) - (take (unat n) msgRegisters))" - apply (rule corres_guard_imp) - apply (rule_tac S=Id in corres_mapM, simp+) - apply (rule corres_split_eqr[OF asUser_getRegister_corres asUser_setRegister_corres]) - apply (wp | clarsimp simp: msg_registers_def msgRegisters_def)+ - done - - have wordSize[simp]: "of_nat wordSize = 8" - by (simp add: wordSize_def wordBits_def word_size) - - show ?thesis - apply (rule corres_assume_pre) - apply (simp add: copy_mrs_def copyMRs_def word_size - cong: option.case_cong - split del: if_split del: upt.simps) - apply (cases sb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (cases rb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (simp add: R del: upt.simps) - apply (rule corres_guard_imp) - apply (rename_tac sb_ptr rb_ptr) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_split_eqr) - apply (rule_tac S="{(x, y). y = of_nat x \ x < unat max_ipc_words}" - in corres_mapM, simp+) - apply (rule corres_split_eqr) - apply (rule loadWordUser_corres) - apply simp - apply (rule storeWordUser_corres) - apply simp - apply (wp hoare_vcg_all_lift | simp)+ - apply (clarsimp simp: upto_enum_def) - apply arith - apply (subst set_zip) - apply (simp add: upto_enum_def U del: upt.simps) - apply (clarsimp simp del: upt.simps) - apply (clarsimp simp: msg_max_length_def word_le_nat_alt nth_append - max_ipc_words) - apply (erule order_less_trans) - apply simp - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift mapM_wp' - | simp add: valid_ipc_buffer_ptr'_def)+ - done -qed - lemma cte_at_tcb_at_32': (* FIXME arch-split: can't be generic with this 32 *) "tcb_at' t s \ cte_at' (t + 32) s" by (simp add: cte_at'_obj_at' tcb_cte_cases_def cteSizeBits_def) @@ -1062,6 +819,9 @@ crunch tcbSchedAppend lemmas [TcbAcc_R_2_assms] = tcbSchedAppend_pspace_in_kernel_mappings' +(* length_type is machine_word on all architectures *) +lemmas [TcbAcc_R_2_assms] = meta_eq_to_obj_eq[OF nat_to_len_def] + end (* Arch *) interpretation TcbAcc_R_2?: TcbAcc_R_2 @@ -1074,6 +834,67 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms +lemma setMRs_corres: + assumes m: "mrs' = mrs" + shows + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) + (case_option \ valid_ipc_buffer_ptr' buf) + (set_mrs t buf mrs) (setMRs t buf mrs')" +proof - + have setRegister_def2: + "setRegister = (\r v. modify (\s. UserContext ((user_regs s)(r := v))))" + by ((rule ext)+, simp add: setRegister_def) + + have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" + by (simp add: zip_take_triv2 drop_take) + + note upt.simps[simp del] upt_rec_numeral[simp del] + + show ?thesis using m + unfolding setMRs_def set_mrs_def + apply (clarsimp cong: option.case_cong split del: if_split) + apply (subst bind_assoc[symmetric]) + apply (fold thread_set_def[simplified]) + apply (subst thread_set_as_user_registers) + apply (cases buf) + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold + modify_registers_def + cong: if_cong simp del: the_index.simps) + apply simp + apply (rule corres_trivial, simp) + apply ((wp |simp)+)[4] + \ \buf = Some a\ + using if_split[split del] + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute + msgMaxLength_def msgLengthBits_def) + apply (simp add: msg_max_length_def) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (simp only: msgRegisters_unfold cong: if_cong) + apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) + apply simp + apply (rule corres_split_nor) + apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * word_size)) \ x < unat max_ipc_words}" + in zipWithM_x_corres) + apply (fastforce intro: storeWordUser_corres) + apply wp+ + apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) + apply (simp add: wordSize_word_size max_ipc_words + upt_Suc_append[symmetric] upto_enum_word) + apply simp + apply (rule corres_trivial, clarsimp simp: min.commute) + apply wp+ + apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ + done +qed + lemma sts_iflive'[TcbAcc_R_3_assms, wp]: "\\s. if_live_then_nonz_cap' s \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) @@ -1096,6 +917,10 @@ lemma asUser_invs[wp]: apply (wpsimp wp: threadSet_invs_trivial threadGet_wp) done +(* interface lemma, but can't be done via locale *) +crunch storeWordUser + for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -1113,9 +938,11 @@ arch_requalify_facts asUser_corres asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' lemmas [wp] = asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' end diff --git a/proof/refine/TcbAcc_R.thy b/proof/refine/TcbAcc_R.thy index 02c629926a..12b01b878d 100644 --- a/proof/refine/TcbAcc_R.thy +++ b/proof/refine/TcbAcc_R.thy @@ -10,6 +10,13 @@ theory TcbAcc_R imports ArchCSpace_R begin +(* FIXME arch-split: move up *) +arch_requalify_consts pageBitsForSize + +arch_requalify_facts mab_pb (* FIXME arch-split: from ArchTcbAcc_AI *) + +lemmas [simp] = mab_pb + (* Auxiliaries and basic properties of priority bitmap functions *) lemma countLeadingZeros_word_clz[simp]: @@ -109,6 +116,12 @@ locale TcbAcc_R = "\w. prioToL1Index w < l2BitmapSize" assumes pspace_dom_dom: "\ps. dom ps \ pspace_dom ps" + assumes less_max_ipc_words_less_2p_msg_align_bits: + "\y. y < unat max_ipc_words \ word_of_nat y * word_size < (2::machine_word) ^ msg_align_bits" + assumes is_aligned_word_size_bits_less_max_ipc_words: + "\y. y < unat max_ipc_words \ is_aligned (word_of_nat y * word_size :: machine_word) word_size_bits" + assumes msg_align_bits_le_pageBitsForSize: + "msg_align_bits \ pageBitsForSize sz" (* isHighestPrio_def' is a cleaner version of isHighestPrio_def *) lemma isHighestPrio_def': @@ -2122,6 +2135,23 @@ locale TcbAcc_R_2 = TcbAcc_R + \ (bound ntfn \ ex_nonz_cap_to' t s)\ setBoundNotification ntfn t \\_. if_live_then_nonz_cap'\" + assumes in_user_frame_eq: + "\y a (s::det_state). + \y < unat max_ipc_words; is_aligned a msg_align_bits\ + \ in_user_frame (a + word_of_nat y * word_size) s = in_user_frame a s" + assumes msgRegisters_msg_registers: + "msgRegisters = msg_registers" + assumes suc_len_msg_registers_less_2p_word_bits: + "Suc (length msg_registers) < 2 ^ word_bits" + (* FIXME arch-split: move to Bits_R? *) + assumes nat_to_len_of_nat: (* length_type is machine_word on all architectures *) + "nat_to_len = of_nat" + assumes asUser_mapM_getRegister_corres: + "\t. + corres (\con regs. regs = map con msg_registers) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (arch_tcb_get_registers \ tcb_arch) t) + (asUser t (mapM getRegister msgRegisters))" begin lemma setBoundNotification_state_refs_of'[wp]: @@ -2342,7 +2372,7 @@ end (* TcbAcc_R_2 *) definition weak_sch_act_wf :: "scheduler_action \ kernel_state \ bool" where "weak_sch_act_wf sa = (\s. \t. sa = SwitchToThread t \ st_tcb_at' runnable' t s \ tcb_in_cur_domain' t s)" -thm if_to_top_of_bind + lemma weak_sch_act_wf_updateDomainTime[simp]: "weak_sch_act_wf m (ksDomainTime_update f s) = weak_sch_act_wf m s" by (simp add:weak_sch_act_wf_def tcb_in_cur_domain'_def ) @@ -3350,6 +3380,18 @@ lemma addToBitmap_bitmapQ_no_L2_orphans[wp]: apply (fastforce simp: invertL1Index_eq_cancel prioToL1Index_bit_set) done +lemma in_user_frame_eq_helper: + fixes a :: machine_word + assumes y: "y < unat max_ipc_words" + and al: "is_aligned a msg_align_bits" + shows "(a + of_nat y * word_size) && ~~ mask (pageBitsForSize sz) + = a && ~~ mask (pageBitsForSize sz)" + apply (rule mask_out_first_mask_some [where n = msg_align_bits]) + apply (rule is_aligned_add_helper [OF al, THEN conjunct2]) + apply (rule less_max_ipc_words_less_2p_msg_align_bits[OF y]) + apply (simp add: msg_align_bits_le_pageBitsForSize) + done + end (* TcbAcc_R *) lemma (in TcbAcc_R_2) addToBitmap_valid_bitmapQ: @@ -4261,6 +4303,205 @@ lemma setThreadState_ksDomSchedule[wp]: unfolding setThreadState_def by (wpsimp wp: hoare_drop_imps) +lemma valid_ipc_buffer_ptr'D: + assumes y: "y < unat max_ipc_words" + and buf: "valid_ipc_buffer_ptr' a s" + shows "pointerInUserData (a + of_nat y * word_size) s" + using buf unfolding valid_ipc_buffer_ptr'_def pointerInUserData_def + apply clarsimp + apply (subgoal_tac + "(a + of_nat y * word_size) && ~~ mask pageBits = a && ~~ mask pageBits") + apply simp + apply (rule mask_out_first_mask_some [where n = msg_align_bits]) + apply (erule is_aligned_add_helper [THEN conjunct2]) + apply (rule less_max_ipc_words_less_2p_msg_align_bits[OF y]) + apply simp+ + done + +lemma loadWordUser_corres: + assumes y: "y < unat max_ipc_words" + shows "corres (=) \ (valid_ipc_buffer_ptr' a) + (load_word_offs a y) (loadWordUser (a + of_nat y * word_size))" + unfolding loadWordUser_def + apply (rule corres_stateAssert_assume [rotated]) + apply (erule valid_ipc_buffer_ptr'D[OF y]) + apply (rule corres_guard_imp) + apply (simp add: load_word_offs_def) + apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) + apply (rule corres_machine_op) + apply (rule corres_Id [OF refl refl]) + apply (rule no_fail_pre) + apply wp + apply (erule_tac n=msg_align_bits in aligned_add_aligned) + apply (rule is_aligned_word_size_bits_less_max_ipc_words[OF y]) + apply (simp add: msg_align_bits') + apply simp + apply (simp add: valid_ipc_buffer_ptr'_def) + done + +lemma storeWordUser_corres: + assumes y: "y < unat max_ipc_words" + shows "corres dc (in_user_frame a) (valid_ipc_buffer_ptr' a) + (store_word_offs a y w) (storeWordUser (a + of_nat y * word_size) w)" + apply (simp add: storeWordUser_def bind_assoc[symmetric] + store_word_offs_def) + apply (rule corres_guard2_imp) + apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) + apply (rule corres_guard1_imp) + apply (rule_tac r'=dc in corres_split) + apply (simp add: stateAssert_def) + apply (rule_tac r'=dc in corres_split) + apply (rule corres_trivial) + apply simp + apply (rule corres_assert) + apply wp+ + apply (rule corres_machine_op) + apply (rule corres_Id [OF refl]) + apply simp + apply (rule no_fail_pre) + apply (wp no_fail_storeWord_bits) + apply (erule_tac n=msg_align_bits in aligned_add_aligned) + apply (rule is_aligned_word_size_bits_less_max_ipc_words[OF y]) + apply (simp add: msg_align_bits') + apply wp+ + apply (simp add: in_user_frame_eq[OF y]) + apply simp + apply (rule conjI) + apply (frule (1) valid_ipc_buffer_ptr'D [OF y]) + apply (simp add: valid_ipc_buffer_ptr'_def) + done + +lemma getMRs_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) + (case_option \ valid_ipc_buffer_ptr' buf) + (get_mrs t buf mi) (getMRs t buf (message_info_map mi))" +proof - + have S: "get = gets id" + by (simp add: gets_def) + + have msg_registers_1: + "unat (1 + word_of_nat (length msg_registers) :: machine_word) = 1 + length msg_registers" + (* avoid exposing LENGTH *) + using suc_len_msg_registers_less_2p_word_bits + unat_of_nat_eq[where 'a=machine_word_len, folded word_bits_def, simp] + by (subst unat_add_lem'[where 'a=machine_word_len, folded word_bits_def]; clarsimp) + + show ?thesis + apply (case_tac mi, simp add: get_mrs_def getMRs_def split del: if_split) + apply (case_tac buf) + apply (rule corres_guard_imp) + apply (rule corres_split [where R = "\_. \" and R' = "\_. \", OF asUser_mapM_getRegister_corres]) + apply simp + apply wp+ + apply simp + apply simp + apply (rule corres_guard_imp) + apply (rule corres_split[OF asUser_mapM_getRegister_corres]) + apply (simp only: option.simps return_bind fun_app_def + load_word_offs_def doMachineOp_mapM loadWord_empty_fail) + apply (rule corres_split_eqr) + apply (simp only: mapM_map_simp msgMaxLength_def msgLengthBits_def + msg_max_length_def o_def upto_enum_word) + apply (rule corres_mapM [where r'="(=)" and S="{a. fst a = snd a \ fst a < unat max_ipc_words}"]) + apply simp + apply simp + apply (simp add: wordSize_word_size) + apply (rule loadWordUser_corres) + apply simp + apply wp+ + apply (simp add: msgRegisters_msg_registers msg_registers_1) + apply (clarsimp simp: set_zip) + apply (simp add: msgRegisters_msg_registers msg_registers_1 max_ipc_words nth_append) + apply (rule corres_trivial, simp) + apply (wp hoare_vcg_all_lift | simp add: valid_ipc_buffer_ptr'_def)+ + done +qed + +lemma copyMRs_corres: + "corres (=) (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct + and case_option \ in_user_frame sb + and case_option \ in_user_frame rb + and K (unat n \ msg_max_length)) + (case_option \ valid_ipc_buffer_ptr' sb + and case_option \ valid_ipc_buffer_ptr' rb) + (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" +proof - + have msg_registers_1: + "unat (1 + word_of_nat (length msg_registers) :: machine_word) = 1 + length msg_registers" + (* avoid exposing LENGTH *) + using suc_len_msg_registers_less_2p_word_bits + unat_of_nat_eq[where 'a=machine_word_len, folded word_bits_def, simp] + by (subst unat_add_lem'[where 'a=machine_word_len, folded word_bits_def]; clarsimp) + + have as_user_bit: + "\v :: machine_word. + corres dc (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct) + \ + (mapM + (\ra. do v \ as_user s (getRegister ra); + as_user r (setRegister ra v) + od) + (take (unat n) msg_registers)) + (mapM + (\ra. do v \ asUser s (getRegister ra); + asUser r (setRegister ra v) + od) + (take (unat n) msg_registers))" + apply (rule corres_guard_imp) + apply (rule_tac S=Id in corres_mapM, simp+) + apply (rule corres_split_eqr[OF asUser_getRegister_corres asUser_setRegister_corres]) + apply wpsimp+ + done + + show ?thesis + supply nat_to_len_of_nat[simp] + apply (rule corres_assume_pre) + apply (simp add: copy_mrs_def copyMRs_def word_size + cong: option.case_cong + split del: if_split del: upt.simps) + apply (cases sb) + apply (simp add: msgRegisters_msg_registers) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF as_user_bit]) + apply (rule corres_trivial, simp) + apply wp+ + apply simp + apply simp + apply (cases rb) + apply (simp add: msgRegisters_msg_registers) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF as_user_bit]) + apply (rule corres_trivial, simp) + apply wp+ + apply simp + apply simp + apply (simp add: msgRegisters_msg_registers del: upt.simps) + apply (rule corres_guard_imp) + apply (rename_tac sb_ptr rb_ptr) + apply (rule corres_split_nor[OF as_user_bit]) + apply (rule corres_split_eqr) + apply (rule_tac S="{(x, y). y = of_nat x \ x < unat max_ipc_words}" + in corres_mapM, simp+) + apply (simp add: wordSize_word_size) + apply (rule corres_split_eqr) + apply (rule loadWordUser_corres) + apply simp + apply (rule storeWordUser_corres) + apply simp + apply (wp hoare_vcg_all_lift | simp)+ + apply (clarsimp simp: upto_enum_def msg_registers_1) + apply arith + apply (subst set_zip) + apply (simp add: upto_enum_def del: upt.simps) + apply (clarsimp simp del: upt.simps) + apply (clarsimp simp: msg_max_length_def word_le_nat_alt nth_append + max_ipc_words msg_registers_1) + apply (simp add: field_simps) (* does not combine with previous simp *) + apply simp + apply (wpsimp wp: hoare_vcg_all_lift mapM_wp' simp: valid_ipc_buffer_ptr'_def)+ + done +qed + end (* TcbAcc_R_2 *) lemma setBoundNotification_ct_idle_or_in_cur_domain'[wp]: @@ -4864,7 +5105,7 @@ lemma sts_invs_minor': apply (frule tcb_in_valid_state', clarsimp+) by (cases st; simp add: valid_tcb_state'_def split: Structures_H.thread_state.split_asm) -end +end (* TcbAcc_R_3 *) declare hoare_in_monad_post[wp] declare trans_state_update'[symmetric,simp] diff --git a/proof/refine/X64/ArchTcbAcc_R.thy b/proof/refine/X64/ArchTcbAcc_R.thy index 2bfe9b889e..90cae65e03 100644 --- a/proof/refine/X64/ArchTcbAcc_R.thy +++ b/proof/refine/X64/ArchTcbAcc_R.thy @@ -274,6 +274,24 @@ lemma pspace_dom_dom[TcbAcc_R_assms]: apply (case_tac vmpage_size, simp_all add: bit_simps) done +lemma less_max_ipc_words_less_2p_msg_align_bits[TcbAcc_R_assms]: + assumes y: "y < unat max_ipc_words" + shows "word_of_nat y * (word_size :: machine_word) < 2 ^ msg_align_bits" + apply (simp add: word_size_def word_size_bits_def) + apply (rule word_less_power_trans_ofnat[where k = 3, simplified]) + apply (rule order_less_le_trans[OF y]) + apply (simp add: msg_align_bits max_ipc_words)+ + done + +lemma is_aligned_word_size_bits_less_max_ipc_words[TcbAcc_R_assms]: + "y < unat max_ipc_words \ is_aligned (word_of_nat y * word_size) word_size_bits" + by (simp add: word_size_def word_size_bits_def) + (rule is_aligned_mult_triv2[where n=3, simplified]) + +lemma msg_align_bits_le_pageBitsForSize[TcbAcc_R_assms]: + "msg_align_bits \ pageBitsForSize sz" + by (simp add: msg_align_bits pageBitsForSize_def bit_simps split: vmpage_size.split) + lemmas [TcbAcc_R_assms] = dmo_getirq_inv getActiveIRQ_masked @@ -550,95 +568,12 @@ lemma addToBitmap_valid_bitmapQ_except[TcbAcc_R_2_assms]: dest: prioToL1Index_bits_low_high_eq) done -lemma valid_ipc_buffer_ptr'D: - assumes yv: "y < unat max_ipc_words" - and buf: "valid_ipc_buffer_ptr' a s" - shows "pointerInUserData (a + of_nat y * 8) s" - using buf unfolding valid_ipc_buffer_ptr'_def pointerInUserData_def - apply clarsimp - apply (subgoal_tac - "(a + of_nat y * 8) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 3, simplified]) - apply (rule order_less_le_trans [OF yv]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp_all add: msg_align_bits pageBits_def) - done - -lemma in_user_frame_eq: +lemma in_user_frame_eq[TcbAcc_R_2_assms]: assumes y: "y < unat max_ipc_words" and al: "is_aligned a msg_align_bits" - shows "in_user_frame (a + of_nat y * 8) s = in_user_frame a s" -proof - - have "\sz. (a + of_nat y * 8) && ~~ mask (pageBitsForSize sz) = - a && ~~ mask (pageBitsForSize sz)" - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (rule is_aligned_add_helper [OF al, THEN conjunct2]) - apply (rule word_less_power_trans_ofnat [where k = 3, simplified]) - apply (rule order_less_le_trans [OF y]) - apply (simp add: msg_align_bits max_ipc_words) - apply (simp add: msg_align_bits) - apply (simp add: msg_align_bits pageBits_def) - apply (case_tac sz, simp_all add: msg_align_bits bit_simps) - done - - thus ?thesis by (simp add: in_user_frame_def) -qed - -lemma loadWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + of_nat y * 8))" - unfolding loadWordUser_def - apply (rule corres_stateAssert_assume [rotated]) - apply (erule valid_ipc_buffer_ptr'D[OF y]) - apply (rule corres_guard_imp) - apply (simp add: load_word_offs_def word_size_def) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_pre) - apply wp - apply (simp add: word_size_bits_def) - apply (erule aligned_add_aligned) - apply (rule is_aligned_mult_triv2[where n = 3, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply (simp add: valid_ipc_buffer_ptr'_def msg_align_bits) - done - -lemma storeWordUser_corres: - assumes y: "y < unat max_ipc_words" - shows "corres dc (in_user_frame a) (valid_ipc_buffer_ptr' a) - (store_word_offs a y w) (storeWordUser (a + of_nat y * 8) w)" - apply (simp add: storeWordUser_def bind_assoc[symmetric] - store_word_offs_def word_size_def) - apply (rule corres_guard2_imp) - apply (rule_tac F = "is_aligned a msg_align_bits" in corres_gen_asm2) - apply (rule corres_guard1_imp) - apply (rule_tac r'=dc in corres_split) - apply (simp add: stateAssert_def) - apply (rule_tac r'=dc in corres_split) - apply (rule corres_trivial) - apply simp - apply (rule corres_assert) - apply wp+ - apply (rule corres_machine_op) - apply (rule corres_Id [OF refl]) - apply simp - apply (rule no_fail_pre) - apply (wp no_fail_storeWord) - apply (erule_tac n=msg_align_bits in aligned_add_aligned) - apply (rule is_aligned_mult_triv2 [where n = 3, simplified]) - apply (simp add: word_bits_conv msg_align_bits)+ - apply wp+ - apply (simp add: in_user_frame_eq[OF y]) - apply simp - apply (rule conjI) - apply (frule (1) valid_ipc_buffer_ptr'D [OF y]) - apply (simp add: valid_ipc_buffer_ptr'_def) - done + shows "in_user_frame (a + of_nat y * word_size) s = in_user_frame a s" + using in_user_frame_eq_helper[OF y al] + by (simp add: in_user_frame_def) lemmas msgRegisters_unfold = X64_H.msgRegisters_def @@ -660,55 +595,25 @@ lemma thread_get_registers: apply (clarsimp simp: map_upd_triv select_f_def image_def return_def) done -lemma getMRs_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) - (case_option \ valid_ipc_buffer_ptr' buf) - (get_mrs t buf mi) (getMRs t buf (message_info_map mi))" - proof - - have S: "get = gets id" - by (simp add: gets_def) - have T: "corres (\con regs. regs = map con msg_registers) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (thread_get (arch_tcb_get_registers o tcb_arch) t) - (asUser t (mapM getRegister X64_H.msgRegisters))" - apply (subst thread_get_registers) - apply (rule asUser_corres') - apply (subst mapM_gets) - apply (simp add: getRegister_def) - apply (simp add: S X64_H.msgRegisters_def msg_registers_def) - done - show ?thesis - apply (case_tac mi, simp add: get_mrs_def getMRs_def split del: if_split) - apply (case_tac buf) - apply (rule corres_guard_imp) - apply (rule corres_split [where R = "\_. \" and R' = "\_. \", OF T]) - apply simp - apply wp+ - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule corres_split[OF T]) - apply (simp only: option.simps return_bind fun_app_def - load_word_offs_def doMachineOp_mapM loadWord_empty_fail) - apply (rule corres_split_eqr) - apply (simp only: mapM_map_simp msgMaxLength_def msgLengthBits_def - msg_max_length_def o_def upto_enum_word) - apply (rule corres_mapM [where r'="(=)" and S="{a. fst a = snd a \ fst a < unat max_ipc_words}"]) - apply simp - apply simp - apply (simp add: word_size wordSize_def wordBits_def) - apply (rule loadWordUser_corres) - apply simp - apply wp+ - apply simp - apply (unfold msgRegisters_unfold)[1] - apply simp - apply (clarsimp simp: set_zip) - apply (simp add: msgRegisters_unfold max_ipc_words nth_append) - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift | simp add: valid_ipc_buffer_ptr'_def)+ +lemma msgRegisters_msg_registers[TcbAcc_R_2_assms]: + "msgRegisters = msg_registers" + by (simp add: msgRegisters_unfold) + +lemma suc_len_msg_registers_less_2p_word_bits[TcbAcc_R_2_assms]: + "Suc (length msg_registers) < 2 ^ word_bits" + by (simp add: msgRegisters_unfold word_bits_def) + +lemma asUser_mapM_getRegister_corres[TcbAcc_R_2_assms]: + "corres (\con regs. regs = map con msg_registers) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get (arch_tcb_get_registers o tcb_arch) t) + (asUser t (mapM getRegister msgRegisters))" + apply (subst thread_get_registers) + apply (rule asUser_corres') + apply (subst mapM_gets) + apply (simp add: getRegister_def) + apply (simp add: msgRegisters_msg_registers) done -qed lemma thread_set_as_user_registers: "thread_set (\tcb. tcb \ tcb_arch := arch_tcb_set_registers (f (arch_tcb_get_registers (tcb_arch tcb))) @@ -733,154 +638,6 @@ lemma UserContext_fold: apply (metis user_context.sel) done -lemma setMRs_corres: - assumes m: "mrs' = mrs" - shows - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) - (case_option \ valid_ipc_buffer_ptr' buf) - (set_mrs t buf mrs) (setMRs t buf mrs')" -proof - - have setRegister_def2: - "setRegister = (\r v. modify (\s. UserContext (user_fpu_state s) ((user_regs s)(r := v))))" - by ((rule ext)+, simp add: setRegister_def) - - have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" - by (simp add: zip_take_triv2 drop_take) - - note upt.simps[simp del] upt_rec_numeral[simp del] - - show ?thesis using m - unfolding setMRs_def set_mrs_def - apply (clarsimp cong: option.case_cong split del: if_split) - apply (subst bind_assoc[symmetric]) - apply (fold thread_set_def[simplified]) - apply (subst thread_set_as_user_registers) - apply (cases buf) - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold - modify_registers_def - cong: if_cong simp del: the_index.simps) - apply simp - apply (rule corres_trivial, simp) - apply ((wp |simp)+)[4] - \ \buf = Some a\ - using if_split[split del] - apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify - take_min_len zip_take_triv2 min.commute - msgMaxLength_def msgLengthBits_def) - apply (simp add: msg_max_length_def) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF asUser_corres']) - apply (rule corres_modify') - apply (simp only: msgRegisters_unfold cong: if_cong) - apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) - apply simp - apply (rule corres_split_nor) - apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * 8)) \ x < unat max_ipc_words}" - in zipWithM_x_corres) - apply (fastforce intro: storeWordUser_corres) - apply wp+ - apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) - apply (simp add: wordSize_def wordBits_def word_size max_ipc_words - upt_Suc_append[symmetric] upto_enum_word) - apply simp - apply (rule corres_trivial, clarsimp simp: min.commute) - apply wp+ - apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ - done -qed - -lemma copyMRs_corres: - "corres (=) (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct - and case_option \ in_user_frame sb - and case_option \ in_user_frame rb - and K (unat n \ msg_max_length)) - (case_option \ valid_ipc_buffer_ptr' sb - and case_option \ valid_ipc_buffer_ptr' rb) - (copy_mrs s sb r rb n) (copyMRs s sb r rb n)" -proof - - have U: "unat n \ msg_max_length \ - map (toEnum :: nat \ machine_word) [7 ..< Suc (unat n)] = map of_nat [7 ..< Suc (unat n)]" - unfolding msg_max_length_def by auto - note R'=msgRegisters_unfold[THEN meta_eq_to_obj_eq, THEN arg_cong[where f=length]] - note R=R'[simplified] - - have as_user_bit: - "\v :: machine_word. - corres dc (tcb_at s and tcb_at r and pspace_aligned and pspace_distinct) - \ - (mapM - (\ra. do v \ as_user s (getRegister ra); - as_user r (setRegister ra v) - od) - (take (unat n) msg_registers)) - (mapM - (\ra. do v \ asUser s (getRegister ra); - asUser r (setRegister ra v) - od) - (take (unat n) msgRegisters))" - apply (rule corres_guard_imp) - apply (rule_tac S=Id in corres_mapM, simp+) - apply (rule corres_split_eqr[OF asUser_getRegister_corres asUser_setRegister_corres]) - apply (wp | clarsimp simp: msg_registers_def msgRegisters_def)+ - done - - have wordSize[simp]: "of_nat wordSize = 8" - by (simp add: wordSize_def wordBits_def word_size) - - show ?thesis - apply (rule corres_assume_pre) - apply (simp add: copy_mrs_def copyMRs_def word_size - cong: option.case_cong - split del: if_split del: upt.simps) - apply (cases sb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (cases rb) - apply (simp add: R) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_trivial, simp) - apply wp+ - apply simp - apply simp - apply (simp add: R del: upt.simps) - apply (rule corres_guard_imp) - apply (rename_tac sb_ptr rb_ptr) - apply (rule corres_split_nor[OF as_user_bit]) - apply (rule corres_split_eqr) - apply (rule_tac S="{(x, y). y = of_nat x \ x < unat max_ipc_words}" - in corres_mapM, simp+) - apply (rule corres_split_eqr) - apply (rule loadWordUser_corres) - apply simp - apply (rule storeWordUser_corres) - apply simp - apply (wp hoare_vcg_all_lift | simp)+ - apply (clarsimp simp: upto_enum_def) - apply arith - apply (subst set_zip) - apply (simp add: upto_enum_def U del: upt.simps) - apply (clarsimp simp del: upt.simps) - apply (clarsimp simp: msg_max_length_def word_le_nat_alt nth_append - max_ipc_words) - apply (erule order_less_trans) - apply simp - apply (rule corres_trivial, simp) - apply (wp hoare_vcg_all_lift mapM_wp' - | simp add: valid_ipc_buffer_ptr'_def)+ - done -qed - lemma cte_at_tcb_at_32': (* FIXME arch-split: can't be generic with this 32 *) "tcb_at' t s \ cte_at' (t + 32) s" by (simp add: cte_at'_obj_at' tcb_cte_cases_def cteSizeBits_def) @@ -1047,6 +804,9 @@ crunch tcbSchedAppend lemmas [TcbAcc_R_2_assms] = tcbSchedAppend_pspace_in_kernel_mappings' +(* length_type is machine_word on all architectures *) +lemmas [TcbAcc_R_2_assms] = meta_eq_to_obj_eq[OF nat_to_len_def] + end (* Arch *) interpretation TcbAcc_R_2?: TcbAcc_R_2 @@ -1059,6 +819,69 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms + +(* FIXME arch-split: investigate making this generic *) +lemma setMRs_corres: + assumes m: "mrs' = mrs" + shows + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) + (case_option \ valid_ipc_buffer_ptr' buf) + (set_mrs t buf mrs) (setMRs t buf mrs')" +proof - + have setRegister_def2: + "setRegister = (\r v. modify (\s. UserContext (user_fpu_state s) ((user_regs s)(r := v))))" + by ((rule ext)+, simp add: setRegister_def) + + have S: "\xs ys n m. m - n \ length xs \ (zip xs (drop n (take m ys))) = zip xs (drop n ys)" + by (simp add: zip_take_triv2 drop_take) + + note upt.simps[simp del] upt_rec_numeral[simp del] + + show ?thesis using m + unfolding setMRs_def set_mrs_def + apply (clarsimp cong: option.case_cong split del: if_split) + apply (subst bind_assoc[symmetric]) + apply (fold thread_set_def[simplified]) + apply (subst thread_set_as_user_registers) + apply (cases buf) + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (fastforce simp: fold_fun_upd[symmetric] msgRegisters_unfold UserContext_fold + modify_registers_def + cong: if_cong simp del: the_index.simps) + apply simp + apply (rule corres_trivial, simp) + apply ((wp |simp)+)[4] + \ \buf = Some a\ + using if_split[split del] + apply (clarsimp simp: msgRegisters_unfold setRegister_def2 zipWithM_x_modify + take_min_len zip_take_triv2 min.commute + msgMaxLength_def msgLengthBits_def) + apply (simp add: msg_max_length_def) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF asUser_corres']) + apply (rule corres_modify') + apply (simp only: msgRegisters_unfold cong: if_cong) + apply (fastforce simp: fold_fun_upd[symmetric] modify_registers_def UserContext_fold) + apply simp + apply (rule corres_split_nor) + apply (rule_tac S="{((x, y), (x', y')). y = y' \ x' = (a + (of_nat x * word_size)) \ x < unat max_ipc_words}" + in zipWithM_x_corres) + apply (fastforce intro: storeWordUser_corres) + apply wp+ + apply (clarsimp simp add: S msgMaxLength_def msg_max_length_def set_zip) + apply (simp add: wordSize_word_size max_ipc_words + upt_Suc_append[symmetric] upto_enum_word) + apply simp + apply (rule corres_trivial, clarsimp simp: min.commute) + apply wp+ + apply (wp | clarsimp simp: valid_ipc_buffer_ptr'_def)+ + done +qed + lemma sts_iflive'[TcbAcc_R_3_assms, wp]: "\\s. if_live_then_nonz_cap' s \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) @@ -1081,6 +904,10 @@ lemma asUser_invs[wp]: apply (wpsimp wp: threadSet_invs_trivial threadGet_wp) done +(* interface lemma, but can't be done via locale *) +crunch storeWordUser + for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -1098,9 +925,11 @@ arch_requalify_facts asUser_corres asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' lemmas [wp] = asUser_valid_objs asUser_invs + storeWordUser_pred_tcb_at' end From 8fce45da0a5efb3bf8aba9bef11d16ca2ebcb888 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 7 May 2026 15:28:32 +1000 Subject: [PATCH 2/7] refine: Ipc_R given arch prefix In preparation for arch-split. Create Ipc_R.thy and update import hierarchy. Signed-off-by: Rafal Kolanski --- proof/refine/AARCH64/{Ipc_R.thy => ArchIpc_R.thy} | 4 ++-- proof/refine/AARCH64/CNodeInv_R.thy | 2 +- proof/refine/AARCH64/Interrupt_R.thy | 2 +- proof/refine/ARM/{Ipc_R.thy => ArchIpc_R.thy} | 4 ++-- proof/refine/ARM/CNodeInv_R.thy | 2 +- proof/refine/ARM/Interrupt_R.thy | 2 +- proof/refine/ARM_HYP/{Ipc_R.thy => ArchIpc_R.thy} | 4 ++-- proof/refine/ARM_HYP/CNodeInv_R.thy | 2 +- proof/refine/ARM_HYP/Interrupt_R.thy | 2 +- proof/refine/Ipc_R.thy | 12 ++++++++++++ proof/refine/RISCV64/{Ipc_R.thy => ArchIpc_R.thy} | 4 ++-- proof/refine/RISCV64/CNodeInv_R.thy | 2 +- proof/refine/RISCV64/Interrupt_R.thy | 2 +- proof/refine/X64/{Ipc_R.thy => ArchIpc_R.thy} | 4 ++-- proof/refine/X64/CNodeInv_R.thy | 2 +- proof/refine/X64/Interrupt_R.thy | 2 +- 16 files changed, 32 insertions(+), 20 deletions(-) rename proof/refine/AARCH64/{Ipc_R.thy => ArchIpc_R.thy} (99%) rename proof/refine/ARM/{Ipc_R.thy => ArchIpc_R.thy} (99%) rename proof/refine/ARM_HYP/{Ipc_R.thy => ArchIpc_R.thy} (99%) create mode 100644 proof/refine/Ipc_R.thy rename proof/refine/RISCV64/{Ipc_R.thy => ArchIpc_R.thy} (99%) rename proof/refine/X64/{Ipc_R.thy => ArchIpc_R.thy} (99%) diff --git a/proof/refine/AARCH64/Ipc_R.thy b/proof/refine/AARCH64/ArchIpc_R.thy similarity index 99% rename from proof/refine/AARCH64/Ipc_R.thy rename to proof/refine/AARCH64/ArchIpc_R.thy index 415efc253b..74b1d77d59 100644 --- a/proof/refine/AARCH64/Ipc_R.thy +++ b/proof/refine/AARCH64/ArchIpc_R.thy @@ -5,8 +5,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory Ipc_R -imports ArchFinalise_R +theory ArchIpc_R +imports Ipc_R begin context begin interpretation Arch . (*FIXME: arch-split*) diff --git a/proof/refine/AARCH64/CNodeInv_R.thy b/proof/refine/AARCH64/CNodeInv_R.thy index 87801abd0b..6172b29446 100644 --- a/proof/refine/AARCH64/CNodeInv_R.thy +++ b/proof/refine/AARCH64/CNodeInv_R.thy @@ -11,7 +11,7 @@ *) theory CNodeInv_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin unbundle l4v_word_context diff --git a/proof/refine/AARCH64/Interrupt_R.thy b/proof/refine/AARCH64/Interrupt_R.thy index 5bee4f5111..9a95659a2c 100644 --- a/proof/refine/AARCH64/Interrupt_R.thy +++ b/proof/refine/AARCH64/Interrupt_R.thy @@ -10,7 +10,7 @@ *) theory Interrupt_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin context Arch begin diff --git a/proof/refine/ARM/Ipc_R.thy b/proof/refine/ARM/ArchIpc_R.thy similarity index 99% rename from proof/refine/ARM/Ipc_R.thy rename to proof/refine/ARM/ArchIpc_R.thy index bbd0bb17a5..675c171c96 100644 --- a/proof/refine/ARM/Ipc_R.thy +++ b/proof/refine/ARM/ArchIpc_R.thy @@ -4,8 +4,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory Ipc_R -imports ArchFinalise_R +theory ArchIpc_R +imports Ipc_R begin context begin interpretation Arch . (*FIXME: arch-split*) diff --git a/proof/refine/ARM/CNodeInv_R.thy b/proof/refine/ARM/CNodeInv_R.thy index b595cb8107..55afb93f4b 100644 --- a/proof/refine/ARM/CNodeInv_R.thy +++ b/proof/refine/ARM/CNodeInv_R.thy @@ -10,7 +10,7 @@ *) theory CNodeInv_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin unbundle l4v_word_context diff --git a/proof/refine/ARM/Interrupt_R.thy b/proof/refine/ARM/Interrupt_R.thy index 7e8b8206a3..92cad2df1e 100644 --- a/proof/refine/ARM/Interrupt_R.thy +++ b/proof/refine/ARM/Interrupt_R.thy @@ -9,7 +9,7 @@ *) theory Interrupt_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin context Arch begin diff --git a/proof/refine/ARM_HYP/Ipc_R.thy b/proof/refine/ARM_HYP/ArchIpc_R.thy similarity index 99% rename from proof/refine/ARM_HYP/Ipc_R.thy rename to proof/refine/ARM_HYP/ArchIpc_R.thy index 3e342a4b71..b65607a342 100644 --- a/proof/refine/ARM_HYP/Ipc_R.thy +++ b/proof/refine/ARM_HYP/ArchIpc_R.thy @@ -4,8 +4,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory Ipc_R -imports ArchFinalise_R +theory ArchIpc_R +imports Ipc_R begin context begin interpretation Arch . (*FIXME: arch-split*) diff --git a/proof/refine/ARM_HYP/CNodeInv_R.thy b/proof/refine/ARM_HYP/CNodeInv_R.thy index 513659b20f..357a5851b6 100644 --- a/proof/refine/ARM_HYP/CNodeInv_R.thy +++ b/proof/refine/ARM_HYP/CNodeInv_R.thy @@ -10,7 +10,7 @@ *) theory CNodeInv_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin unbundle l4v_word_context diff --git a/proof/refine/ARM_HYP/Interrupt_R.thy b/proof/refine/ARM_HYP/Interrupt_R.thy index 3ddf111808..966e20b31d 100644 --- a/proof/refine/ARM_HYP/Interrupt_R.thy +++ b/proof/refine/ARM_HYP/Interrupt_R.thy @@ -9,7 +9,7 @@ *) theory Interrupt_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin context Arch begin diff --git a/proof/refine/Ipc_R.thy b/proof/refine/Ipc_R.thy new file mode 100644 index 0000000000..f2c0e5efde --- /dev/null +++ b/proof/refine/Ipc_R.thy @@ -0,0 +1,12 @@ +(* + * Copyright 2014, General Dynamics C4 Systems + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * Copyright 2023, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) +theory Ipc_R +imports ArchFinalise_R +begin + +end diff --git a/proof/refine/RISCV64/Ipc_R.thy b/proof/refine/RISCV64/ArchIpc_R.thy similarity index 99% rename from proof/refine/RISCV64/Ipc_R.thy rename to proof/refine/RISCV64/ArchIpc_R.thy index b064df84fc..b34ad6a532 100644 --- a/proof/refine/RISCV64/Ipc_R.thy +++ b/proof/refine/RISCV64/ArchIpc_R.thy @@ -4,8 +4,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory Ipc_R -imports ArchFinalise_R +theory ArchIpc_R +imports Ipc_R begin context begin interpretation Arch . (*FIXME: arch-split*) diff --git a/proof/refine/RISCV64/CNodeInv_R.thy b/proof/refine/RISCV64/CNodeInv_R.thy index f960446050..770652d92c 100644 --- a/proof/refine/RISCV64/CNodeInv_R.thy +++ b/proof/refine/RISCV64/CNodeInv_R.thy @@ -10,7 +10,7 @@ *) theory CNodeInv_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin unbundle l4v_word_context diff --git a/proof/refine/RISCV64/Interrupt_R.thy b/proof/refine/RISCV64/Interrupt_R.thy index 58f753074e..98c3264a28 100644 --- a/proof/refine/RISCV64/Interrupt_R.thy +++ b/proof/refine/RISCV64/Interrupt_R.thy @@ -9,7 +9,7 @@ *) theory Interrupt_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin context Arch begin diff --git a/proof/refine/X64/Ipc_R.thy b/proof/refine/X64/ArchIpc_R.thy similarity index 99% rename from proof/refine/X64/Ipc_R.thy rename to proof/refine/X64/ArchIpc_R.thy index ace983b3ed..d76313672e 100644 --- a/proof/refine/X64/Ipc_R.thy +++ b/proof/refine/X64/ArchIpc_R.thy @@ -4,8 +4,8 @@ * SPDX-License-Identifier: GPL-2.0-only *) -theory Ipc_R -imports ArchFinalise_R +theory ArchIpc_R +imports Ipc_R begin context begin interpretation Arch . (*FIXME: arch-split*) diff --git a/proof/refine/X64/CNodeInv_R.thy b/proof/refine/X64/CNodeInv_R.thy index d9d85346ae..2323c96349 100644 --- a/proof/refine/X64/CNodeInv_R.thy +++ b/proof/refine/X64/CNodeInv_R.thy @@ -10,7 +10,7 @@ *) theory CNodeInv_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin unbundle l4v_word_context diff --git a/proof/refine/X64/Interrupt_R.thy b/proof/refine/X64/Interrupt_R.thy index 695e0fc967..f65340eec7 100644 --- a/proof/refine/X64/Interrupt_R.thy +++ b/proof/refine/X64/Interrupt_R.thy @@ -9,7 +9,7 @@ *) theory Interrupt_R -imports Ipc_R Invocations_R +imports ArchIpc_R Invocations_R begin context Arch begin From 0982e700007f34beb27cb45fedc2430951c48c18 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Thu, 7 May 2026 15:29:57 +1000 Subject: [PATCH 3/7] [wip] copy AARCH64 version of Ipc_R Decreases diff during PR review. Signed-off-by: Rafal Kolanski --- proof/refine/Ipc_R.thy | 4382 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 4382 insertions(+) diff --git a/proof/refine/Ipc_R.thy b/proof/refine/Ipc_R.thy index f2c0e5efde..19201b2f12 100644 --- a/proof/refine/Ipc_R.thy +++ b/proof/refine/Ipc_R.thy @@ -9,4 +9,4386 @@ theory Ipc_R imports ArchFinalise_R begin +context begin interpretation Arch . (*FIXME: arch-split*) + +lemmas lookup_slot_wrapper_defs'[simp] = + lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def + +lemma getMessageInfo_corres: "corres ((=) \ message_info_map) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_message_info t) (getMessageInfo t)" + apply (rule corres_guard_imp) + apply (unfold get_message_info_def getMessageInfo_def fun_app_def) + apply (simp add: AARCH64_H.msgInfoRegister_def + AARCH64.msgInfoRegister_def AARCH64_A.msg_info_register_def) + apply (rule corres_split_eqr[OF asUser_getRegister_corres]) + apply (rule corres_trivial, simp add: message_info_from_data_eqv) + apply (wp | simp)+ + done + + +lemma get_mi_inv'[wp]: "\I\ getMessageInfo a \\x. I\" + by (simp add: getMessageInfo_def, wp) + +definition + "get_send_cap_relation rv rv' \ + (case rv of Some (c, cptr) \ (\c' cptr'. rv' = Some (c', cptr') \ + cte_map cptr = cptr' \ + cap_relation c c') + | None \ rv' = None)" + +lemma cap_relation_mask: + "\ cap_relation c c'; msk' = rights_mask_map msk \ \ + cap_relation (mask_cap msk c) (maskCapRights msk' c')" + by simp + +lemma lsfco_cte_at': + "\valid_objs' and valid_cap' cap\ + lookupSlotForCNodeOp f cap idx depth + \\rv. cte_at' rv\, -" + apply (simp add: lookupSlotForCNodeOp_def) + apply (rule conjI) + prefer 2 + apply clarsimp + apply (wp) + apply (clarsimp simp: split_def unlessE_def + split del: if_split) + apply (wpsimp wp: hoare_drop_imps throwE_R) + done + +declare unifyFailure_wp [wp] + +(* FIXME: move *) +lemma unifyFailure_wp_E [wp]: + "\P\ f -, \\_. E\ \ \P\ unifyFailure f -, \\_. E\" + unfolding validE_E_def + by (erule unifyFailure_wp)+ + +(* FIXME: move *) +lemma unifyFailure_wp2 [wp]: + assumes x: "\P\ f \\_. Q\" + shows "\P\ unifyFailure f \\_. Q\" + by (wp x, simp) + +definition + ct_relation :: "captransfer \ cap_transfer \ bool" +where + "ct_relation ct ct' \ + ct_receive_root ct = to_bl (ctReceiveRoot ct') + \ ct_receive_index ct = to_bl (ctReceiveIndex ct') + \ ctReceiveDepth ct' = unat (ct_receive_depth ct)" + +(* MOVE *) +lemma valid_ipc_buffer_ptr_aligned_word_size_bits: + "\valid_ipc_buffer_ptr' a s; is_aligned y word_size_bits \ \ is_aligned (a + y) word_size_bits" + unfolding valid_ipc_buffer_ptr'_def + apply clarsimp + apply (erule (1) aligned_add_aligned) + apply (simp add: msg_align_bits word_size_bits_def) + done + +(* MOVE *) +lemma valid_ipc_buffer_ptr'D2: + "\valid_ipc_buffer_ptr' a s; y < max_ipc_words * word_size; is_aligned y word_size_bits\ \ typ_at' UserDataT (a + y && ~~ mask pageBits) s" + unfolding valid_ipc_buffer_ptr'_def + apply clarsimp + apply (subgoal_tac "(a + y) && ~~ mask pageBits = a && ~~ mask pageBits") + apply simp + apply (rule mask_out_first_mask_some [where n = msg_align_bits]) + apply (erule is_aligned_add_helper [THEN conjunct2]) + apply (erule order_less_le_trans) + apply (simp add: msg_align_bits max_ipc_words word_size_def) + apply simp + done + +lemma loadCapTransfer_corres: + notes msg_max_words_simps = max_ipc_words_def msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def + capTransferDataSize_def msgExtraCapBits_def + shows + "corres ct_relation \ (valid_ipc_buffer_ptr' buffer) (load_cap_transfer buffer) (loadCapTransfer buffer)" + apply (simp add: load_cap_transfer_def loadCapTransfer_def + captransfer_from_words_def + capTransferDataSize_def capTransferFromWords_def + msgExtraCapBits_def word_size add.commute add.left_commute + msg_max_length_def msg_max_extra_caps_def word_size_def + msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def wordSize_def wordBits_def + del: upt.simps) + apply (rule corres_guard_imp) + apply (rule corres_split[OF load_word_corres]) + apply (rule corres_split[OF load_word_corres]) + apply (rule corres_split[OF load_word_corres]) + apply (rule_tac P=\ and P'=\ in corres_inst) + apply (clarsimp simp: ct_relation_def) + apply (wp no_irq_loadWord)+ + apply simp + apply (simp add: conj_comms) + apply safe + apply (erule valid_ipc_buffer_ptr_aligned_word_size_bits, simp add: is_aligned_def word_size_bits_def)+ + apply (erule valid_ipc_buffer_ptr'D2, + simp add: msg_max_words_simps word_size_def word_size_bits_def, + simp add: word_size_bits_def is_aligned_def)+ + done + +lemma getReceiveSlots_corres: + "corres (\xs ys. ys = map cte_map xs) + (tcb_at receiver and valid_objs and pspace_aligned) + (tcb_at' receiver and valid_objs' and pspace_aligned' and pspace_distinct' and + case_option \ valid_ipc_buffer_ptr' recv_buf) + (get_receive_slots receiver recv_buf) + (getReceiveSlots receiver recv_buf)" + apply (cases recv_buf) + apply (simp add: getReceiveSlots_def) + apply (simp add: getReceiveSlots_def split_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF loadCapTransfer_corres]) + apply (rule corres_empty_on_failure) + apply (rule corres_splitEE) + apply (rule corres_unify_failure) + apply (rule lookup_cap_corres) + apply (simp add: ct_relation_def) + apply simp + apply (rule corres_splitEE) + apply (rule corres_unify_failure) + apply (simp add: ct_relation_def) + apply (erule lookupSlotForCNodeOp_corres [OF _ refl]) + apply simp + apply (simp add: split_def liftE_bindE unlessE_whenE) + apply (rule corres_split[OF get_cap_corres]) + apply (rule corres_split_norE) + apply (rule corres_whenE) + apply (case_tac cap, auto)[1] + apply (rule corres_trivial, simp) + apply simp + apply (rule corres_trivial, simp add: returnOk_def) + apply (wp lookup_cap_valid lookup_cap_valid' lsfco_cte_at | simp)+ + done + +lemma get_recv_slot_inv'[wp]: + "\ P \ getReceiveSlots receiver buf \\rv'. P \" + apply (case_tac buf) + apply (simp add: getReceiveSlots_def) + apply (simp add: getReceiveSlots_def + split_def unlessE_def) + apply (wp | simp)+ + done + +lemma get_rs_cte_at'[wp]: + "\\\ + getReceiveSlots receiver recv_buf + \\rv s. \x \ set rv. cte_wp_at' (\c. cteCap c = capability.NullCap) x s\" + apply (cases recv_buf) + apply (simp add: getReceiveSlots_def) + apply (wp,simp) + apply (clarsimp simp add: getReceiveSlots_def + split_def whenE_def unlessE_whenE) + apply wp + apply simp + apply (rule getCTE_wp) + apply (simp add: cte_wp_at_ctes_of cong: conj_cong) + apply wp+ + apply simp + done + +lemma get_rs_real_cte_at'[wp]: + "\valid_objs'\ + getReceiveSlots receiver recv_buf + \\rv s. \x \ set rv. real_cte_at' x s\" + apply (cases recv_buf) + apply (simp add: getReceiveSlots_def) + apply (wp,simp) + apply (clarsimp simp add: getReceiveSlots_def + split_def whenE_def unlessE_whenE) + apply wp + apply simp + apply (wp hoare_drop_imps)[1] + apply simp + apply (wp lookup_cap_valid')+ + apply simp + done + +declare word_div_1 [simp] +declare word_minus_one_le [simp] +declare word64_minus_one_le [simp] + +lemma loadWordUser_corres': + "\ y < unat max_ipc_words; y' = of_nat y * 8 \ \ + corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + y'))" + apply simp + apply (erule loadWordUser_corres) + done + +declare loadWordUser_inv [wp] + +lemma getExtraCptrs_inv[wp]: + "\P\ getExtraCPtrs buf mi \\rv. P\" + apply (cases mi, cases buf, simp_all add: getExtraCPtrs_def) + apply (wp dmo_inv' mapM_wp' loadWord_inv) + done + +lemma getSlotCap_cte_wp_at_rv: + "\cte_wp_at' (\cte. P (cteCap cte) cte) p\ + getSlotCap p + \\rv. cte_wp_at' (P rv) p\" + apply (simp add: getSlotCap_def) + apply (wp getCTE_ctes_wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +lemma badge_derived_mask [simp]: + "badge_derived' (maskCapRights R c) c' = badge_derived' c c'" + by (simp add: badge_derived'_def) + +declare derived'_not_Null [simp] + +lemma maskCapRights_vs_cap_ref'[simp]: + "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" + unfolding vs_cap_ref'_def + apply (cases cap, simp_all add: maskCapRights_def isCap_simps Let_def) + apply (rename_tac arch_capability) + apply (case_tac arch_capability; + simp add: maskCapRights_def AARCH64_H.maskCapRights_def isCap_simps Let_def) + done + +lemma corres_set_extra_badge: + "b' = b \ + corres dc (in_user_frame buffer) + (valid_ipc_buffer_ptr' buffer and + (\_. msg_max_length + 2 + n < unat max_ipc_words)) + (set_extra_badge buffer b n) (setExtraBadge buffer b' n)" + apply (rule corres_gen_asm2) + apply (drule storeWordUser_corres [where a=buffer and w=b]) + apply (simp add: set_extra_badge_def setExtraBadge_def buffer_cptr_index_def + bufferCPtrOffset_def Let_def) + apply (simp add: word_size word_size_def wordSize_def wordBits_def + bufferCPtrOffset_def buffer_cptr_index_def msgMaxLength_def + msg_max_length_def msgLengthBits_def store_word_offs_def + add.commute add.left_commute) + done + +crunch setExtraBadge + for typ_at': "\s. P (typ_at' T p s)" +lemmas setExtraBadge_typ_ats' [wp] = typ_at_lifts [OF setExtraBadge_typ_at'] +crunch setExtraBadge + for valid_pspace'[wp]: valid_pspace' +crunch setExtraBadge + for cte_wp_at'[wp]: "cte_wp_at' P p" +crunch setExtraBadge + for ipc_buffer'[wp]: "valid_ipc_buffer_ptr' buffer" + +crunch getExtraCPtr + for inv'[wp]: P (wp: dmo_inv' loadWord_inv) + +lemmas unifyFailure_discard2 + = corres_injection[OF id_injection unifyFailure_injection, simplified] + +lemma deriveCap_not_null: + "\\\ deriveCap slot cap \\rv. K (rv \ NullCap \ cap \ NullCap)\,-" + apply (simp add: deriveCap_def split del: if_split) + by (case_tac cap; wpsimp simp: isCap_simps) + +lemma deriveCap_derived_foo: + "\\s. \cap'. (cte_wp_at' (\cte. badge_derived' cap (cteCap cte) + \ capASID cap = capASID (cteCap cte) \ cap_asid_base' cap = cap_asid_base' (cteCap cte) + \ cap_vptr' cap = cap_vptr' (cteCap cte)) slot s + \ valid_objs' s \ cap' \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot cap' \ cteCap) slot s) + \ (cte_wp_at' (untyped_derived_eq cap \ cteCap) slot s + \ cte_wp_at' (untyped_derived_eq cap' \ cteCap) slot s) + \ (s \' cap \ s \' cap') \ (cap' \ NullCap \ cap \ NullCap) \ Q cap' s\ + deriveCap slot cap \Q\,-" + using deriveCap_derived[where slot=slot and c'=cap] deriveCap_valid[where slot=slot and c=cap] + deriveCap_untyped_derived[where slot=slot and c'=cap] deriveCap_not_null[where slot=slot and cap=cap] + apply (clarsimp simp: validE_R_def validE_def valid_def split: sum.split) + apply (frule in_inv_by_hoareD[OF deriveCap_inv]) + apply (clarsimp simp: o_def) + apply (drule spec, erule mp) + apply safe + apply fastforce + apply (drule spec, drule(1) mp) + apply fastforce + apply (drule spec, drule(1) mp) + apply fastforce + apply (drule spec, drule(1) bspec, simp) + done + +lemma valid_mdb_untyped_incD': + "valid_mdb' s \ untyped_inc' (ctes_of s)" + by (simp add: valid_mdb'_def valid_mdb_ctes_def) + +lemma cteInsert_cte_wp_at: + "\\s. cte_wp_at' (\c. is_derived' (ctes_of s) src cap (cteCap c)) src s + \ valid_mdb' s \ valid_objs' s + \ (if p = dest then P cap + else cte_wp_at' (\c. P (maskedAsFull (cteCap c) cap)) p s)\ + cteInsert cap src dest + \\uu. cte_wp_at' (\c. P (cteCap c)) p\" + apply (simp add: cteInsert_def) + apply (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp hoare_weak_lift_imp + | clarsimp simp: comp_def + | unfold setUntypedCapAsFull_def)+ + apply (drule cte_at_cte_wp_atD) + apply (elim exE) + apply (rule_tac x=cte in exI) + apply clarsimp + apply (drule cte_at_cte_wp_atD) + apply (elim exE) + apply (rule_tac x=ctea in exI) + apply clarsimp + apply (cases "p=dest") + apply (clarsimp simp: cte_wp_at'_def) + apply (cases "p=src") + apply clarsimp + apply (intro conjI impI) + apply ((clarsimp simp: cte_wp_at'_def maskedAsFull_def split: if_split_asm)+)[2] + apply clarsimp + apply (rule conjI) + apply (clarsimp simp: maskedAsFull_def cte_wp_at_ctes_of split:if_split_asm) + apply (erule disjE) prefer 2 apply simp + apply (clarsimp simp: is_derived'_def isCap_simps) + apply (drule valid_mdb_untyped_incD') + apply (case_tac cte, case_tac cteb, clarsimp) + apply (drule untyped_incD', (simp add: isCap_simps)+) + apply (frule(1) ctes_of_valid'[where p = p]) + apply (clarsimp simp:valid_cap'_def capAligned_def split:if_splits) + apply (drule_tac y ="of_nat fb" in word_plus_mono_right[OF _ is_aligned_no_overflow',rotated]) + apply simp+ + apply (rule word_of_nat_less) + apply simp + apply (simp add:p_assoc_help mask_def) + apply (simp add: max_free_index_def) + apply (clarsimp simp: maskedAsFull_def is_derived'_def badge_derived'_def + isCap_simps capMasterCap_def cte_wp_at_ctes_of + split: if_split_asm capability.splits) + done + +lemma cteInsert_weak_cte_wp_at3: + assumes imp:"\c. P c \ \ isUntypedCap c" + shows " \\s. if p = dest then P cap + else cte_wp_at' (\c. P (cteCap c)) p s\ + cteInsert cap src dest + \\uu. cte_wp_at' (\c. P (cteCap c)) p\" + by (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp' hoare_weak_lift_imp + | clarsimp simp: comp_def cteInsert_def + | unfold setUntypedCapAsFull_def + | auto simp: cte_wp_at'_def dest!: imp)+ + +lemma maskedAsFull_null_cap[simp]: + "(maskedAsFull x y = capability.NullCap) = (x = capability.NullCap)" + "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" + by (case_tac x, auto simp:maskedAsFull_def isCap_simps) + +lemma maskCapRights_eq_null: + "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = + (xa = capability.NullCap)" + apply (cases xa; simp add: maskCapRights_def isCap_simps) + apply (rename_tac arch_capability) + apply (case_tac arch_capability) + apply (simp_all add: AARCH64_H.maskCapRights_def isCap_simps) + done + +lemma cte_refs'_maskedAsFull[simp]: + "cte_refs' (maskedAsFull a b) = cte_refs' a" + apply (rule ext)+ + apply (case_tac a) + apply (clarsimp simp:maskedAsFull_def isCap_simps)+ + done + +lemma set_extra_badge_valid_arch_state[wp]: + "set_extra_badge buffer badge n \ valid_arch_state \" + unfolding set_extra_badge_def + by wp + +lemma transferCapsToSlots_corres: + "\ list_all2 (\(cap, slot) (cap', slot'). cap_relation cap cap' + \ slot' = cte_map slot) caps caps'; + mi' = message_info_map mi \ \ + corres ((=) \ message_info_map) + (\s. valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_mdb s + \ valid_list s \ valid_arch_state s + \ (case ep of Some x \ ep_at x s | _ \ True) + \ (\x \ set slots. cte_wp_at (\cap. cap = cap.NullCap) x s \ + real_cte_at x s) + \ (\(cap, slot) \ set caps. valid_cap cap s \ + cte_wp_at (\cp'. (cap \ cap.NullCap \ cp'\cap \ cp' = masked_as_full cap cap )) slot s ) + \ distinct slots + \ in_user_frame buffer s) + (\s. valid_pspace' s + \ (case ep of Some x \ ep_at' x s | _ \ True) + \ (\x \ set (map cte_map slots). + cte_wp_at' (\cte. cteCap cte = NullCap) x s + \ real_cte_at' x s) + \ distinct (map cte_map slots) + \ valid_ipc_buffer_ptr' buffer s + \ (\(cap, slot) \ set caps'. valid_cap' cap s \ + cte_wp_at' (\cte. cap \ NullCap \ cteCap cte \ cap \ cteCap cte = maskedAsFull cap cap) slot s) + \ 2 + msg_max_length + n + length caps' < unat max_ipc_words) + (transfer_caps_loop ep buffer n caps slots mi) + (transferCapsToSlots ep buffer n caps' + (map cte_map slots) mi')" + (is "\ list_all2 ?P caps caps'; ?v \ \ ?corres") +proof (induct caps caps' arbitrary: slots n mi mi' rule: list_all2_induct) + case Nil + show ?case using Nil.prems by (case_tac mi, simp) +next + case (Cons x xs y ys slots n mi mi') + note if_weak_cong[cong] if_cong [cong del] + assume P: "?P x y" + show ?case using Cons.prems P + apply (clarsimp split del: if_split) + apply (simp add: Let_def split_def word_size liftE_bindE + word_bits_conv[symmetric] split del: if_split) + apply (rule corres_const_on_failure) + apply (simp add: dc_def[symmetric] split del: if_split) + apply (rule corres_guard_imp) + apply (rule corres_if3) + apply (case_tac "fst x", auto simp add: isCap_simps)[1] + apply (rule corres_split[OF corres_set_extra_badge]) + apply (clarsimp simp: is_cap_simps) + apply (drule conjunct1) + apply simp + apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] + apply (case_tac mi, simp) + apply (simp add: split_def) + apply (wp hoare_vcg_const_Ball_lift) + apply (subgoal_tac "obj_ref_of (fst x) = capEPPtr (fst y)") + prefer 2 + apply (clarsimp simp: is_cap_simps) + apply (simp add: split_def) + apply (wp hoare_vcg_const_Ball_lift) + apply (rule_tac P="slots = []" and Q="slots \ []" in corres_disj_division) + apply simp + apply (rule corres_trivial, simp add: returnOk_def) + apply (case_tac mi, simp) + apply (simp add: list_case_If2 split del: if_split) + apply (rule corres_splitEE) + apply (rule unifyFailure_discard2) + apply (case_tac mi, clarsimp) + apply (rule deriveCap_corres) + apply (simp add: remove_rights_def) + apply clarsimp + apply (rule corres_split_norE) + apply (rule corres_whenE) + apply (case_tac cap', auto)[1] + apply (rule corres_trivial, simp) + apply (case_tac mi, simp) + apply simp + apply (simp add: liftE_bindE) + apply (rule corres_split_nor) + apply (rule cteInsert_corres, simp_all add: hd_map)[1] + apply (simp add: tl_map) + apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] + apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift + hoare_vcg_const_Ball_lift cap_insert_derived_valid_arch_state + cap_insert_weak_cte_wp_at) + apply (wp hoare_vcg_const_Ball_lift | simp add:split_def del: imp_disj1)+ + apply (wp cap_insert_cte_wp_at) + apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift + cteInsert_valid_pspace + | simp add: split_def)+ + apply (wp cteInsert_weak_cte_wp_at hoare_valid_ipc_buffer_ptr_typ_at')+ + apply (wpsimp wp: hoare_vcg_const_Ball_lift cteInsert_cte_wp_at valid_case_option_post_wp + simp: split_def) + apply (unfold whenE_def) + apply wp+ + apply (clarsimp simp: conj_comms ball_conj_distrib split del: if_split) + apply (rule_tac Q' ="\cap' s. (cap'\ cap.NullCap \ + cte_wp_at (is_derived (cdt s) (a, b) cap') (a, b) s + \ QM s cap')" for QM + in hoare_strengthen_postE_R) + prefer 2 + apply clarsimp + apply assumption + apply (subst imp_conjR) + apply (rule hoare_vcg_conj_liftE_R') + apply (rule derive_cap_is_derived) + apply (wp derive_cap_is_derived_foo)+ + apply (simp split del: if_split) + apply (rule_tac Q' ="\cap' s. (cap'\ capability.NullCap \ + cte_wp_at' (\c. is_derived' (ctes_of s) (cte_map (a, b)) cap' (cteCap c)) (cte_map (a, b)) s + \ QM s cap')" for QM + in hoare_strengthen_postE_R) + prefer 2 + apply clarsimp + apply assumption + apply (subst imp_conjR) + apply (rule hoare_vcg_conj_liftE_R') + apply (rule hoare_strengthen_postE_R[OF deriveCap_derived]) + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (wp deriveCap_derived_foo) + apply (clarsimp simp: cte_wp_at_caps_of_state remove_rights_def + real_cte_tcb_valid if_apply_def2 + split del: if_split) + apply (rule conjI, (clarsimp split del: if_split)+) + apply (clarsimp simp:conj_comms split del:if_split) + apply (intro conjI allI) + apply (clarsimp split:if_splits) + apply (case_tac "cap = fst x",simp+) + apply (clarsimp simp:masked_as_full_def is_cap_simps cap_master_cap_simps) + apply (clarsimp split del: if_split) + apply (intro conjI) + apply (clarsimp simp:neq_Nil_conv) + apply (drule hd_in_set) + apply (drule(1) bspec) + apply (clarsimp split:if_split_asm) + apply (fastforce simp:neq_Nil_conv) + apply (intro ballI conjI) + apply (clarsimp simp:neq_Nil_conv) + apply (intro impI) + apply (drule(1) bspec[OF _ subsetD[rotated]]) + apply (clarsimp simp:neq_Nil_conv) + apply (clarsimp split:if_splits) + apply clarsimp + apply (intro conjI) + apply (drule(1) bspec,clarsimp)+ + subgoal for \ aa _ _ capa + by (case_tac "capa = aa"; clarsimp split:if_splits simp:masked_as_full_def is_cap_simps) + apply (case_tac "isEndpointCap (fst y) \ capEPPtr (fst y) = the ep \ (\y. ep = Some y)") + apply (clarsimp simp:conj_comms split del:if_split) + apply (split if_split) + apply (rule conjI) + apply clarsimp + apply (clarsimp simp:valid_pspace'_def cte_wp_at_ctes_of split del:if_split) + apply (intro conjI) + apply (case_tac "cteCap cte = fst y",clarsimp simp: badge_derived'_def) + apply (clarsimp simp: maskCapRights_eq_null maskedAsFull_def badge_derived'_def isCap_simps + split: if_split_asm) + apply (clarsimp split del: if_split) + apply (case_tac "fst y = capability.NullCap") + apply (clarsimp simp: neq_Nil_conv split del: if_split)+ + apply (intro allI impI conjI) + apply (clarsimp split:if_splits) + apply (clarsimp simp:image_def)+ + apply (thin_tac "\x\set ys. Q x" for Q) + apply (drule(1) bspec)+ + apply clarsimp+ + apply (drule(1) bspec) + apply (rule conjI) + apply clarsimp+ + apply (case_tac "cteCap cteb = ab") + by (clarsimp simp: isCap_simps maskedAsFull_def split:if_splits)+ +qed + +declare constOnFailure_wp [wp] + +lemma transferCapsToSlots_pres1[crunch_rules]: + assumes x: "\cap src dest. \P\ cteInsert cap src dest \\rv. P\" + assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" + shows "\P\ transferCapsToSlots ep buffer n caps slots mi \\rv. P\" + apply (induct caps arbitrary: slots n mi) + apply simp + apply (simp add: Let_def split_def whenE_def + cong: if_cong list.case_cong + split del: if_split) + apply (rule hoare_pre) + apply (wp x eb | assumption | simp split del: if_split | wpc + | wp (once) hoare_drop_imps)+ + done + +lemma cteInsert_cte_cap_to': + "\ex_cte_cap_to' p and cte_wp_at' (\cte. cteCap cte = NullCap) dest\ + cteInsert cap src dest + \\rv. ex_cte_cap_to' p\" + apply (simp add: ex_cte_cap_to'_def) + apply (rule hoare_pre) + apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) + apply (clarsimp simp:cteInsert_def) + apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases + setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (rule_tac x = "cref" in exI) + apply (rule conjI) + apply clarsimp+ + done + +declare maskCapRights_eq_null[simp] + +crunch setExtraBadge + for ex_cte_cap_wp_to'[wp]: "ex_cte_cap_wp_to' P p" + (rule: ex_cte_cap_to'_pres) + +crunch setExtraBadge + for valid_objs'[wp]: valid_objs' +crunch setExtraBadge + for aligned'[wp]: pspace_aligned' +crunch setExtraBadge + for distinct'[wp]: pspace_distinct' + +lemma cteInsert_assume_Null: + "\P\ cteInsert cap src dest \Q\ \ + \\s. cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ P s\ + cteInsert cap src dest + \Q\" + apply (rule hoare_name_pre_state) + apply (erule impCE) + apply (simp add: cteInsert_def) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (rule bind_wp[OF _ getCTE_sp])+ + apply (rule hoare_name_pre_state) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (erule hoare_weaken_pre) + apply simp + done + +crunch setExtraBadge + for mdb'[wp]: valid_mdb' + +lemma cteInsert_weak_cte_wp_at2: + assumes weak:"\c cap. P (maskedAsFull c cap) = P c" + shows + "\\s. if p = dest then P cap else cte_wp_at' (\c. P (cteCap c)) p s\ + cteInsert cap src dest + \\uu. cte_wp_at' (\c. P (cteCap c)) p\" + supply if_cong[cong] + apply (rule hoare_pre) + apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) + apply (clarsimp simp:cteInsert_def) + apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases + setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) + apply (clarsimp simp:cte_wp_at_ctes_of weak) + apply auto + done + +lemma transferCapsToSlots_presM: + assumes x: "\cap src dest. \\s. P s \ (emx \ cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ ex_cte_cap_to' dest s) + \ (vo \ valid_objs' s \ valid_cap' cap s \ real_cte_at' dest s) + \ (drv \ cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s + \ cte_wp_at' (untyped_derived_eq cap o cteCap) src s + \ valid_mdb' s) + \ (pad \ pspace_aligned' s \ pspace_distinct' s)\ + cteInsert cap src dest \\rv. P\" + assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" + shows "\\s. P s + \ (emx \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) \ distinct slots) + \ (vo \ valid_objs' s \ (\x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) + \ (\x \ set caps. s \' fst x ) \ distinct slots) + \ (pad \ pspace_aligned' s \ pspace_distinct' s) + \ (drv \ vo \ pspace_aligned' s \ pspace_distinct' s \ valid_mdb' s + \ length slots \ 1 + \ (\x \ set caps. s \' fst x \ (slots \ [] + \ cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s)))\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. P\" + apply (induct caps arbitrary: slots n mi) + apply (simp, wp, simp) + apply (simp add: Let_def split_def whenE_def + cong: if_cong list.case_cong split del: if_split) + apply (rule hoare_pre) + apply (wp eb hoare_vcg_const_Ball_lift hoare_vcg_const_imp_lift + | assumption | wpc)+ + apply (rule cteInsert_assume_Null) + apply (wp x hoare_vcg_const_Ball_lift cteInsert_cte_cap_to' hoare_weak_lift_imp) + apply (rule cteInsert_weak_cte_wp_at2,clarsimp) + apply (wp hoare_vcg_const_Ball_lift hoare_weak_lift_imp)+ + apply (rule cteInsert_weak_cte_wp_at2,clarsimp) + apply (wp hoare_vcg_const_Ball_lift cteInsert_cte_wp_at hoare_weak_lift_imp + deriveCap_derived_foo)+ + apply (thin_tac "\slots. PROP P slots" for P) + apply (clarsimp simp: cte_wp_at_ctes_of remove_rights_def + real_cte_tcb_valid if_apply_def2 + split del: if_split) + apply (rule conjI) + apply (clarsimp simp:cte_wp_at_ctes_of untyped_derived_eq_def) + apply (intro conjI allI) + apply (clarsimp simp:Fun.comp_def cte_wp_at_ctes_of)+ + apply (clarsimp simp:valid_capAligned) + done + +lemmas transferCapsToSlots_pres2 + = transferCapsToSlots_presM[where vo=False and emx=True + and drv=False and pad=False, simplified] + +crunch transferCapsToSlots + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + and pspace_canonical'[wp]: pspace_canonical' + +lemma transferCapsToSlots_typ_at'[wp]: + "\\s. P (typ_at' T p s)\ + transferCapsToSlots ep buffer n caps slots mi + \\rv s. P (typ_at' T p s)\" + by (wp transferCapsToSlots_pres1 setExtraBadge_typ_at') + +lemma transferCapsToSlots_valid_objs[wp]: + "\valid_objs' and valid_mdb' and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) + and (\s. \x \ set caps. s \' fst x) and K(distinct slots)\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. valid_objs'\" + apply (rule hoare_pre) + apply (rule transferCapsToSlots_presM[where vo=True and emx=False and drv=False and pad=False]) + apply (wp | simp)+ + done + +abbreviation(input) + "transferCaps_srcs caps s \ \x\set caps. cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s" + +lemma transferCapsToSlots_mdb[wp]: + "\\s. valid_pspace' s \ distinct slots + \ length slots \ 1 + \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) + \ (\x \ set slots. real_cte_at' x s) + \ transferCaps_srcs caps s\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. valid_mdb'\" + apply (wpsimp wp: transferCapsToSlots_presM[where drv=True and vo=True and emx=True and pad=True]) + apply (frule valid_capAligned) + apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def badge_derived'_def) + apply wp + apply (clarsimp simp: valid_pspace'_def) + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (drule(1) bspec,clarify) + apply (case_tac cte) + apply (clarsimp dest!:ctes_of_valid_cap' split:if_splits) + apply (fastforce simp:valid_cap'_def) + done + +crunch setExtraBadge + for no_0'[wp]: no_0_obj' + +lemma transferCapsToSlots_no_0_obj' [wp]: + "\no_0_obj'\ transferCapsToSlots ep buffer n caps slots mi \\rv. no_0_obj'\" + by (wp transferCapsToSlots_pres1) + +lemma transferCapsToSlots_vp[wp]: + "\\s. valid_pspace' s \ distinct slots + \ length slots \ 1 + \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) + \ (\x \ set slots. real_cte_at' x s) + \ transferCaps_srcs caps s\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. valid_pspace'\" + apply (rule hoare_pre) + apply (simp add: valid_pspace'_def | wp)+ + apply (fastforce simp: cte_wp_at_ctes_of dest: ctes_of_valid') + done + +crunch setExtraBadge, doIPCTransfer + for sch_act [wp]: "\s. P (ksSchedulerAction s)" + (wp: crunch_wps mapME_wp' simp: zipWithM_x_mapM) +crunch setExtraBadge + for pred_tcb_at' [wp]: "\s. pred_tcb_at' proj P p s" + and ksCurThread[wp]: "\s. P (ksCurThread s)" + and ksCurDomain[wp]: "\s. P (ksCurDomain s)" + and obj_at' [wp]: "\s. P' (obj_at' P p s)" + and queues [wp]: "\s. P (ksReadyQueues s)" + and queuesL1 [wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and queuesL2 [wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (simp: storeWordUser_def) + + +lemma tcts_sch_act[wp]: + "\\s. sch_act_wf (ksSchedulerAction s) s\ + transferCapsToSlots ep buffer n caps slots mi + \\rv s. sch_act_wf (ksSchedulerAction s) s\" + by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) + +crunch setExtraBadge + for state_refs_of'[wp]: "\s. P (state_refs_of' s)" + and state_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" + +lemma tcts_state_refs_of'[wp]: + "\\s. P (state_refs_of' s)\ + transferCapsToSlots ep buffer n caps slots mi + \\rv s. P (state_refs_of' s)\" + by (wp transferCapsToSlots_pres1) + +lemma tcts_state_hyp_refs_of'[wp]: + "transferCapsToSlots ep buffer n caps slots mi \\s. P (state_hyp_refs_of' s)\" + by (wp transferCapsToSlots_pres1) + +crunch setExtraBadge + for if_live'[wp]: if_live_then_nonz_cap' + +lemma tcts_iflive[wp]: + "\\s. if_live_then_nonz_cap' s \ distinct slots \ + (\x\set slots. + ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s)\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. if_live_then_nonz_cap'\" + by (wp transferCapsToSlots_pres2 | simp)+ + +crunch setExtraBadge + for if_unsafe'[wp]: if_unsafe_then_cap' + +lemma tcts_ifunsafe[wp]: + "\\s. if_unsafe_then_cap' s \ distinct slots \ + (\x\set slots. cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s \ + ex_cte_cap_to' x s)\ transferCapsToSlots ep buffer n caps slots mi + \\rv. if_unsafe_then_cap'\" + by (wp transferCapsToSlots_pres2 | simp)+ + +crunch setExtraBadge + for valid_idle'[wp]: valid_idle' + +lemma tcts_idle'[wp]: + "\\s. valid_idle' s\ transferCapsToSlots ep buffer n caps slots mi + \\rv. valid_idle'\" + apply (rule hoare_pre) + apply (wp transferCapsToSlots_pres1) + apply simp + done + +lemma tcts_ct[wp]: + "\cur_tcb'\ transferCapsToSlots ep buffer n caps slots mi \\rv. cur_tcb'\" + by (wp transferCapsToSlots_pres1 cur_tcb_lift) + +crunch setExtraBadge + for valid_arch_state'[wp]: valid_arch_state' + +lemma transferCapsToSlots_valid_arch [wp]: + "\valid_arch_state'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_arch_state'\" + by (rule transferCapsToSlots_pres1; wp) + +crunch setExtraBadge + for valid_global_refs'[wp]: valid_global_refs' + +lemma transferCapsToSlots_valid_globals [wp]: + "\valid_global_refs' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' and K (distinct slots) + and K (length slots \ 1) + and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) + and transferCaps_srcs caps\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. valid_global_refs'\" + apply (wp transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=True] | clarsimp)+ + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (drule(1) bspec,clarsimp) + apply (case_tac cte,clarsimp) + apply (frule(1) CSpace_I.ctes_of_valid_cap') + apply (fastforce simp:valid_cap'_def) + done + +crunch setExtraBadge + for irq_node'[wp]: "\s. P (irq_node' s)" + +lemma transferCapsToSlots_irq_node'[wp]: + "\\s. P (irq_node' s)\ transferCapsToSlots ep buffer n caps slots mi \\rv s. P (irq_node' s)\" + by (wp transferCapsToSlots_pres1) + +lemma valid_irq_handlers_ctes_ofD: + "\ ctes_of s p = Some cte; cteCap cte = IRQHandlerCap irq; valid_irq_handlers' s \ + \ irq_issued' irq s" + by (auto simp: valid_irq_handlers'_def cteCaps_of_def ran_def) + +crunch setExtraBadge + for valid_irq_handlers'[wp]: valid_irq_handlers' + +lemma transferCapsToSlots_irq_handlers[wp]: + "\valid_irq_handlers' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' + and K(distinct slots \ length slots \ 1) + and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) + and transferCaps_srcs caps\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. valid_irq_handlers'\" + apply (wpsimp wp: transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=False]) + apply (clarsimp simp: is_derived'_def cte_wp_at_ctes_of badge_derived'_def) + apply (erule(2) valid_irq_handlers_ctes_ofD) + apply wp + apply (clarsimp simp:cte_wp_at_ctes_of | intro ballI conjI)+ + apply (drule(1) bspec,clarsimp) + apply (case_tac cte,clarsimp) + apply (frule(1) CSpace_I.ctes_of_valid_cap') + apply (fastforce simp:valid_cap'_def) + done + +crunch setExtraBadge + for irq_state'[wp]: "\s. P (ksInterruptState s)" + +lemma setExtraBadge_irq_states'[wp]: + "\valid_irq_states'\ setExtraBadge buffer b n \\_. valid_irq_states'\" + apply (wp valid_irq_states_lift') + apply (simp add: setExtraBadge_def storeWordUser_def) + apply (wpsimp wp: no_irq dmo_lift' no_irq_storeWord) + apply assumption + done + +lemma transferCapsToSlots_irq_states' [wp]: + "\valid_irq_states'\ transferCapsToSlots ep buffer n caps slots mi \\_. valid_irq_states'\" + by (wp transferCapsToSlots_pres1) + +lemma transferCapsToSlots_irqs_masked'[wp]: + "\irqs_masked'\ transferCapsToSlots ep buffer n caps slots mi \\rv. irqs_masked'\" + by (wp transferCapsToSlots_pres1 irqs_masked_lift) + +lemma storeWordUser_vms'[wp]: + "\valid_machine_state'\ storeWordUser a w \\_. valid_machine_state'\" +proof - + have aligned_offset_ignore: + "\(l::machine_word) (p::machine_word) sz. l<8 \ p && mask 3 = 0 \ + p+l && ~~ mask pageBits = p && ~~ mask pageBits" + proof - + fix l p sz + assume al: "(p::machine_word) && mask 3 = 0" + assume "(l::machine_word) < 8" hence less: "l<2^3" by simp + have le: "3 \ pageBits" by (simp add: pageBits_def) + show "?thesis l p sz" + by (rule is_aligned_add_helper[simplified is_aligned_mask, + THEN conjunct2, THEN mask_out_first_mask_some, + where n=3, OF al less le]) + qed + + show ?thesis + apply (simp add: valid_machine_state'_def storeWordUser_def + doMachineOp_def split_def) + apply wp + apply clarsimp + apply (drule use_valid) + apply (rule_tac x=p in storeWord_um_inv, simp+) + apply (drule_tac x=p in spec) + apply (erule disjE, simp_all) + apply (erule conjE) + apply (erule disjE, simp) + apply (simp add: pointerInUserData_def word_size) + apply (subgoal_tac "a && ~~ mask pageBits = p && ~~ mask pageBits", simp) + apply (simp only: is_aligned_mask[of _ 3]) + apply (elim disjE, simp_all) + apply (rule aligned_offset_ignore[symmetric], simp+)+ + done +qed + +lemma setExtraBadge_vms'[wp]: + "\valid_machine_state'\ setExtraBadge buffer b n \\_. valid_machine_state'\" +by (simp add: setExtraBadge_def) wp + +lemma transferCapsToSlots_vms[wp]: + "\\s. valid_machine_state' s\ + transferCapsToSlots ep buffer n caps slots mi + \\_ s. valid_machine_state' s\" + by (wp transferCapsToSlots_pres1) + +crunch setExtraBadge, transferCapsToSlots + for pspace_domain_valid[wp]: "pspace_domain_valid" + +crunch setExtraBadge + for ct_not_inQ[wp]: "ct_not_inQ" + +lemma tcts_ct_not_inQ[wp]: + "\ct_not_inQ\ + transferCapsToSlots ep buffer n caps slots mi + \\_. ct_not_inQ\" + by (wp transferCapsToSlots_pres1) + +crunch setExtraBadge + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" +crunch setExtraBadge + for ctes_of[wp]: "\s. P (ctes_of s)" + +lemma tcts_zero_ranges[wp]: + "\\s. untyped_ranges_zero' s \ valid_pspace' s \ distinct slots + \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) + \ (\x \ set slots. real_cte_at' x s) + \ length slots \ 1 + \ transferCaps_srcs caps s\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. untyped_ranges_zero'\" + apply (wpsimp wp: transferCapsToSlots_presM[where emx=True and vo=True + and drv=True and pad=True]) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (simp add: cteCaps_of_def) + apply (rule hoare_pre, wp untyped_ranges_zero_lift) + apply (simp add: o_def) + apply (clarsimp simp: valid_pspace'_def ball_conj_distrib[symmetric]) + apply (drule(1) bspec) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (case_tac cte, clarsimp) + apply (frule(1) ctes_of_valid_cap') + apply auto[1] + done + +crunch transferCapsToSlots, setExtraBadge + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" + +crunch transferCapsToSlots + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: sym_heap_sched_pointers_lift) + +lemma transferCapsToSlots_invs[wp]: + "\\s. invs' s \ distinct slots + \ (\x \ set slots. cte_wp_at' (\cte. cteCap cte = NullCap) x s) + \ (\x \ set slots. ex_cte_cap_to' x s) + \ (\x \ set slots. real_cte_at' x s) + \ length slots \ 1 + \ transferCaps_srcs caps s\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. invs'\" + apply (simp add: invs'_def valid_state'_def) + apply (wp valid_irq_node_lift valid_dom_schedule'_lift) + apply fastforce + done + +lemma grs_distinct'[wp]: + "\\\ getReceiveSlots t buf \\rv s. distinct rv\" + apply (cases buf, simp_all add: getReceiveSlots_def + split_def unlessE_def) + apply (wp, simp) + apply (wp | simp only: distinct.simps list.simps empty_iff)+ + apply simp + done + +(* FIXME arch-split: move *) +lemma invs_pspace_in_kernel_mappings'[elim!]: + "invs' s \ pspace_in_kernel_mappings' s" + by (fastforce dest!: invs_valid_pspace' simp: valid_pspace'_def) + +lemma transferCaps_corres: + "\ info' = message_info_map info; + list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x)) + caps caps' \ + \ + corres ((=) \ message_info_map) + (tcb_at receiver and valid_objs and + pspace_aligned and pspace_distinct and valid_mdb + and valid_list and valid_arch_state + and (\s. case ep of Some x \ ep_at x s | _ \ True) + and case_option \ in_user_frame recv_buf + and (\s. valid_message_info info) + and transfer_caps_srcs caps) + (tcb_at' receiver and valid_objs' and + pspace_aligned' and pspace_distinct' and pspace_canonical' and pspace_in_kernel_mappings' + and no_0_obj' and valid_mdb' + and (\s. case ep of Some x \ ep_at' x s | _ \ True) + and case_option \ valid_ipc_buffer_ptr' recv_buf + and transferCaps_srcs caps' + and (\s. length caps' \ msgMaxExtraCaps)) + (transfer_caps info caps ep receiver recv_buf) + (transferCaps info' caps' ep receiver recv_buf)" + apply (simp add: transfer_caps_def transferCaps_def + getThreadCSpaceRoot) + apply (rule corres_assume_pre) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getReceiveSlots_corres]) + apply (rule_tac x=recv_buf in option_corres) + apply (rule_tac P=\ and P'=\ in corres_inst) + apply (case_tac info, simp) + apply simp + apply (rule corres_rel_imp, rule transferCapsToSlots_corres, + simp_all add: split_def)[1] + apply (case_tac info, simp) + apply (wp hoare_vcg_all_lift get_rs_cte_at hoare_weak_lift_imp + | simp only: ball_conj_distrib)+ + apply (simp add: cte_map_def tcb_cnode_index_def split_def) + apply (clarsimp simp: valid_pspace'_def valid_ipc_buffer_ptr'_def2 + split_def + cong: option.case_cong) + apply (drule(1) bspec) + apply (clarsimp simp:cte_wp_at_caps_of_state) + apply (frule(1) Invariants_AI.caps_of_state_valid) + apply (fastforce simp:valid_cap_def) + apply (cases info) + apply (clarsimp simp: msg_max_extra_caps_def valid_message_info_def + max_ipc_words msg_max_length_def + msgMaxExtraCaps_def msgExtraCapBits_def + shiftL_nat valid_pspace'_def) + apply (drule(1) bspec) + apply (clarsimp simp:cte_wp_at_ctes_of) + apply (case_tac cte,clarsimp) + apply (frule(1) ctes_of_valid_cap') + apply (fastforce simp:valid_cap'_def) + done + +crunch transferCaps + for typ_at'[wp]: "\s. P (typ_at' T p s)" + +lemmas transferCaps_typ_ats[wp] = typ_at_lifts [OF transferCaps_typ_at'] + +lemma isIRQControlCap_mask [simp]: + "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" + apply (case_tac c) + apply (clarsimp simp: isCap_simps maskCapRights_def Let_def)+ + apply (rename_tac arch_capability) + apply (case_tac arch_capability) + apply (clarsimp simp: isCap_simps AARCH64_H.maskCapRights_def + maskCapRights_def Let_def)+ + done + +lemma isFrameCap_maskCapRights[simp]: +" isArchCap isFrameCap (RetypeDecls_H.maskCapRights R c) = isArchCap isFrameCap c" + apply (case_tac c; simp add: isCap_simps isArchCap_def maskCapRights_def) + apply (rename_tac arch_capability) + apply (case_tac arch_capability; simp add: isCap_simps AARCH64_H.maskCapRights_def) + done + +lemma capReplyMaster_mask[simp]: + "isReplyCap c \ capReplyMaster (maskCapRights R c) = capReplyMaster c" + by (clarsimp simp: isCap_simps maskCapRights_def) + +lemma is_derived_mask' [simp]: + "is_derived' m p (maskCapRights R c) = is_derived' m p c" + apply (rule ext) + apply (simp add: is_derived'_def badge_derived'_def) + done + +lemma arch_updateCapData_ordering: (* arch interface *) + "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ + \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" + apply (cases acap; simp add: AARCH64_H.updateCapData_def) + apply fastforce + done + +lemma updateCapData_ordering: + "\ (x, capBadge cap) \ capBadge_ordering P; updateCapData p d cap \ NullCap \ + \ (x, capBadge (updateCapData p d cap)) \ capBadge_ordering P" + apply (cases cap; simp) + apply (fastforce simp: updateCapData_def Let_def isCap_simps split: if_split_asm) + apply (fastforce simp: updateCapData_def Let_def isCap_simps split: if_split_asm) + apply (fastforce dest: arch_updateCapData_ordering simp: updateCapData_def isCap_simps) + done + +lemma updateCapData_capReplyMaster: + "isReplyCap cap \ capReplyMaster (updateCapData p d cap) = capReplyMaster cap" + by (clarsimp simp: isCap_simps updateCapData_def split del: if_split) + +lemma ArchUpdateCapData_noReply: (* arch interface *) + "Arch.updateCapData p d acap \ capability.ReplyCap x y z" + by (cases acap; simp add: AARCH64_H.updateCapData_def) + +lemma updateCapData_is_Reply[simp]: + "(updateCapData p d cap = ReplyCap x y z) = (cap = ReplyCap x y z)" + by (rule ccontr, + clarsimp simp: isCap_simps updateCapData_def Let_def ArchUpdateCapData_noReply + split del: if_split + split: if_split_asm) + +lemma ArchUpdateCapData_noIRQControl: (* arch interface *) + "Arch.updateCapData p d acap \ IRQControlCap" + by (cases acap; simp add: AARCH64_H.updateCapData_def) + +lemma updateCapDataIRQ: + "updateCapData p d cap \ NullCap \ + isIRQControlCap (updateCapData p d cap) = isIRQControlCap cap" + by (cases cap; simp add: updateCapData_def isCap_simps Let_def ArchUpdateCapData_noIRQControl) + +lemma updateCapData_vs_cap_ref'[simp]: + "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" + by (rule ccontr, + clarsimp simp: isCap_simps updateCapData_def Let_def + AARCH64_H.updateCapData_def + vs_cap_ref'_def + split del: if_split + split: if_split_asm arch_capability.splits) + +lemma isFrameCap_updateCapData[simp]: + "isArchCap isFrameCap (updateCapData pr D c) = isArchCap isFrameCap c" + apply (case_tac c; simp add:updateCapData_def isCap_simps isArchCap_def) + apply (rename_tac arch_capability) + apply (case_tac arch_capability; simp add: AARCH64_H.updateCapData_def isCap_simps isArchCap_def) + apply (clarsimp split:capability.splits simp:Let_def) + done + +lemma lookup_cap_to'[wp]: + "\\\ lookupCap t cref \\rv s. \r\cte_refs' rv (irq_node' s). ex_cte_cap_to' r s\,-" + by (simp add: lookupCap_def lookupCapAndSlot_def | wp)+ + +lemma grs_cap_to'[wp]: + "\\\ getReceiveSlots t buf \\rv s. \x \ set rv. ex_cte_cap_to' x s\" + apply (cases buf; simp add: getReceiveSlots_def split_def unlessE_def) + apply (wp, simp) + apply (wp | simp | rule hoare_drop_imps)+ + done + +lemma grs_length'[wp]: + "\\s. 1 \ n\ getReceiveSlots receiver recv_buf \\rv s. length rv \ n\" + apply (simp add: getReceiveSlots_def split_def unlessE_def) + apply (rule hoare_pre) + apply (wp | wpc | simp)+ + done + +lemma transferCaps_invs' [wp]: + "\invs' and transferCaps_srcs caps\ + transferCaps mi caps ep receiver recv_buf + \\rv. invs'\" + apply (simp add: transferCaps_def Let_def split_def) + apply (wp get_rs_cte_at' hoare_vcg_const_Ball_lift + | wpcw | clarsimp)+ + done + +lemma get_mrs_inv'[wp]: + "\P\ getMRs t buf info \\rv. P\" + by (simp add: getMRs_def load_word_offs_def getRegister_def + | wp dmo_inv' loadWord_inv mapM_wp' + asUser_inv det_mapM[where S=UNIV] | wpc)+ + + +lemma copyMRs_typ_at': + "\\s. P (typ_at' T p s)\ copyMRs s sb r rb n \\rv s. P (typ_at' T p s)\" + by (simp add: copyMRs_def | wp mapM_wp [where S=UNIV, simplified] | wpc)+ + +lemmas copyMRs_typ_at_lifts[wp] = typ_at_lifts [OF copyMRs_typ_at'] + +lemma copy_mrs_invs'[wp]: + "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" + including classic_wp_pre + apply (simp add: copyMRs_def) + apply (wp dmo_invs' no_irq_mapM no_irq_storeWord| + simp add: split_def) + apply (case_tac sb, simp_all)[1] + apply wp+ + apply (case_tac rb, simp_all)[1] + apply (wp mapM_wp dmo_invs' no_irq_mapM no_irq_storeWord no_irq_loadWord) + apply blast + apply (rule hoare_strengthen_post) + apply (rule mapM_wp) + apply (wp | simp | blast)+ + done + +crunch transferCaps, setMRs, copyMRs, setMessageInfo + for aligned'[wp]: pspace_aligned' + and distinct'[wp]: pspace_distinct' + and pspace_canonical'[wp]: pspace_canonical' + (wp: crunch_wps simp: crunch_simps) + +lemma set_mrs_valid_objs' [wp]: + "\valid_objs'\ setMRs t a msgs \\rv. valid_objs'\" + apply (simp add: setMRs_def zipWithM_x_mapM split_def) + apply (wp asUser_valid_objs crunch_wps) + done + +crunch copyMRs + for valid_objs'[wp]: valid_objs' + (wp: crunch_wps simp: crunch_simps) + +lemma setMRs_invs_bits[wp]: + "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" + "\\s. sch_act_wf (ksSchedulerAction s) s\ + setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" + "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ + setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" + "\P. setMRs t buf mrs \\s. P (state_refs_of' s)\" + "\P. setMRs t buf mrs \\s. P (state_hyp_refs_of' s)\" + "\if_live_then_nonz_cap'\ setMRs t buf mrs \\rv. if_live_then_nonz_cap'\" + "\ex_nonz_cap_to' p\ setMRs t buf mrs \\rv. ex_nonz_cap_to' p\" + "\cur_tcb'\ setMRs t buf mrs \\rv. cur_tcb'\" + "\if_unsafe_then_cap'\ setMRs t buf mrs \\rv. if_unsafe_then_cap'\" + by (simp add: setMRs_def zipWithM_x_mapM split_def storeWordUser_def | wp crunch_wps)+ + +crunch setMRs + for no_0_obj'[wp]: no_0_obj' + (wp: crunch_wps simp: crunch_simps) + +lemma copyMRs_invs_bits[wp]: + "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" + "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n + \\rv s. sch_act_wf (ksSchedulerAction s) s\" + "\P. copyMRs s sb r rb n \\s. P (state_refs_of' s)\" + "\P. copyMRs s sb r rb n \\s. P (state_hyp_refs_of' s)\" + "\if_live_then_nonz_cap'\ copyMRs s sb r rb n \\rv. if_live_then_nonz_cap'\" + "\ex_nonz_cap_to' p\ copyMRs s sb r rb n \\rv. ex_nonz_cap_to' p\" + "\cur_tcb'\ copyMRs s sb r rb n \\rv. cur_tcb'\" + "\if_unsafe_then_cap'\ copyMRs s sb r rb n \\rv. if_unsafe_then_cap'\" + by (simp add: copyMRs_def storeWordUser_def | wp mapM_wp' | wpc)+ + +crunch copyMRs + for no_0_obj'[wp]: no_0_obj' + (wp: crunch_wps simp: crunch_simps) + +lemma mi_map_length[simp]: "msgLength (message_info_map mi) = mi_length mi" + by (cases mi, simp) + +crunch copyMRs + for cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: crunch_wps) + +lemma lookupExtraCaps_srcs[wp]: + "\\\ lookupExtraCaps thread buf info \transferCaps_srcs\,-" + apply (simp add: lookupExtraCaps_def lookupCapAndSlot_def + split_def lookupSlotForThread_def + getSlotCap_def) + apply (wp mapME_set[where R=\] getCTE_wp') + apply (rule_tac P=\ in hoare_trivE_R) + apply (simp add: cte_wp_at_ctes_of) + apply (wp | simp)+ + done + +crunch lookupExtraCaps + for inv[wp]: "P" + (wp: crunch_wps mapME_wp' simp: crunch_simps) + +lemma invs_mdb_strengthen': + "invs' s \ valid_mdb' s" by auto + +lemma lookupExtraCaps_length: + "\\s. unat (msgExtraCaps mi) \ n\ lookupExtraCaps thread send_buf mi \\rv s. length rv \ n\,-" + apply (simp add: lookupExtraCaps_def getExtraCPtrs_def) + apply (rule hoare_pre) + apply (wp mapME_length | wpc)+ + apply (clarsimp simp: upto_enum_step_def Suc_unat_diff_1 word_le_sub1) + done + +lemma getMessageInfo_msgExtraCaps[wp]: + "\\\ getMessageInfo t \\rv s. unat (msgExtraCaps rv) \ msgMaxExtraCaps\" + apply (simp add: getMessageInfo_def) + apply wp + apply (simp add: messageInfoFromWord_def Let_def msgMaxExtraCaps_def + shiftL_nat) + apply (subst nat_le_Suc_less_imp) + apply (rule unat_less_power) + apply (simp add: word_bits_def msgExtraCapBits_def) + apply (rule and_mask_less'[unfolded mask_2pm1]) + apply (simp add: msgExtraCapBits_def) + apply wpsimp+ + done + +lemma lookupCapAndSlot_corres: + "cptr = to_bl cptr' \ + corres (lfr \ (\a b. cap_relation (fst a) (fst b) \ snd b = cte_map (snd a))) + (valid_objs and pspace_aligned and tcb_at thread) + (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread) + (lookup_cap_and_slot thread cptr) (lookupCapAndSlot thread cptr')" + unfolding lookup_cap_and_slot_def lookupCapAndSlot_def + apply (simp add: liftE_bindE split_def) + apply (rule corres_guard_imp) + apply (rule_tac r'="\rv rv'. rv' = cte_map (fst rv)" + in corres_splitEE) + apply (rule corres_rel_imp, rule lookupSlotForThread_corres) + apply (simp add: split_def) + apply (rule corres_split[OF getSlotCap_corres]) + apply simp + apply (rule corres_returnOkTT, simp) + apply wp+ + apply (wp | simp add: liftE_bindE[symmetric])+ + done + +lemma lookupExtraCaps_corres: + "\ info' = message_info_map info; buffer = buffer'\ \ + corres (fr \ list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))) + (valid_objs and pspace_aligned and tcb_at thread and (\_. valid_message_info info)) + (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread + and case_option \ valid_ipc_buffer_ptr' buffer') + (lookup_extra_caps thread buffer info) (lookupExtraCaps thread buffer' info')" + unfolding lookupExtraCaps_def lookup_extra_caps_def + apply (rule corres_gen_asm) + apply (cases "mi_extra_caps info = 0") + apply (cases info) + apply (simp add: Let_def returnOk_def getExtraCPtrs_def + liftE_bindE upto_enum_step_def mapM_def + sequence_def doMachineOp_return mapME_Nil + split: option.split) + apply (cases info) + apply (rename_tac w1 w2 w3 w4) + apply (simp add: Let_def liftE_bindE) + apply (cases buffer') + apply (simp add: getExtraCPtrs_def mapME_Nil) + apply (rule corres_returnOk) + apply simp + apply (simp add: msgLengthBits_def msgMaxLength_def word_size field_simps + getExtraCPtrs_def upto_enum_step_def upto_enum_word + word_size_def msg_max_length_def liftM_def + Suc_unat_diff_1 word_le_sub1 mapM_map_simp + upt_lhs_sub_map[where x=buffer_cptr_index] + wordSize_def wordBits_def + del: upt.simps) + apply (rule corres_guard_imp) + apply (rule corres_underlying_split) + + apply (rule_tac S = "\x y. x = y \ x < unat w2" + in corres_mapM_list_all2 + [where Q = "\_. valid_objs and pspace_aligned and tcb_at thread" and r = "(=)" + and Q' = "\_. valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' thread + and case_option \ valid_ipc_buffer_ptr' buffer'" and r'="(=)" ]) + apply simp + apply simp + apply simp + apply (rule corres_guard_imp) + apply (rule loadWordUser_corres') + apply (clarsimp simp: buffer_cptr_index_def msg_max_length_def + max_ipc_words valid_message_info_def + msg_max_extra_caps_def word_le_nat_alt) + apply (simp add: buffer_cptr_index_def msg_max_length_def) + apply simp + apply simp + apply (simp add: load_word_offs_word_def) + apply (wp | simp)+ + apply (subst list_all2_same) + apply (clarsimp simp: max_ipc_words field_simps) + apply (simp add: mapME_def, fold mapME_def)[1] + apply (rule corres_mapME [where S = Id and r'="(\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))"]) + apply simp + apply simp + apply simp + apply (rule corres_cap_fault [OF lookupCapAndSlot_corres]) + apply simp + apply simp + apply (wp | simp)+ + apply (simp add: set_zip_same Int_lower1) + apply (wp mapM_wp [OF _ subset_refl] | simp)+ + done + +crunch copyMRs + for ctes_of[wp]: "\s. P (ctes_of s)" + (ignore: threadSet + wp: threadSet_ctes_of crunch_wps) + +lemma copyMRs_valid_mdb[wp]: + "\valid_mdb'\ copyMRs t buf t' buf' n \\rv. valid_mdb'\" + by (simp add: valid_mdb'_def copyMRs_ctes_of) + +crunch copy_mrs + for valid_arch_state[wp]: valid_arch_state + (wp: crunch_wps) + +lemma doNormalTransfer_corres: + "corres dc + (tcb_at sender and tcb_at receiver and (pspace_aligned:: det_state \ bool) + and valid_objs and cur_tcb and valid_mdb and valid_list and valid_arch_state and pspace_distinct + and (\s. case ep of Some x \ ep_at x s | _ \ True) + and case_option \ in_user_frame send_buf + and case_option \ in_user_frame recv_buf) + (tcb_at' sender and tcb_at' receiver and valid_objs' + and pspace_aligned' and pspace_distinct' and pspace_canonical' and cur_tcb' + and valid_mdb' and no_0_obj' + and (\s. case ep of Some x \ ep_at' x s | _ \ True) + and case_option \ valid_ipc_buffer_ptr' send_buf + and case_option \ valid_ipc_buffer_ptr' recv_buf) + (do_normal_transfer sender send_buf ep badge can_grant receiver recv_buf) + (doNormalTransfer sender send_buf ep badge can_grant receiver recv_buf)" + supply if_cong[cong] + apply (simp add: do_normal_transfer_def doNormalTransfer_def) + apply (rule corres_guard_imp) + apply (rule corres_split_mapr[OF getMessageInfo_corres]) + apply (rule_tac F="valid_message_info mi" in corres_gen_asm) + apply (rule_tac r'="list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))" + in corres_split) + apply (rule corres_if[OF refl]) + apply (rule corres_split_catch) + apply (rule lookupExtraCaps_corres; simp) + apply (rule corres_trivial, simp) + apply wp+ + apply (rule corres_trivial, simp) + apply simp + apply (rule corres_split_eqr[OF copyMRs_corres]) + apply (rule corres_split) + apply (rule transferCaps_corres; simp) + apply (rename_tac mi' mi'') + apply (rule_tac F="mi_label mi' = mi_label mi" + in corres_gen_asm) + apply (rule corres_split_nor[OF setMessageInfo_corres]) + apply (case_tac mi', clarsimp) + apply (simp add: badge_register_def badgeRegister_def) + apply (fold dc_def) + apply (rule asUser_setRegister_corres) + apply wp + apply simp+ + apply ((wp valid_case_option_post_wp hoare_vcg_const_Ball_lift + hoare_case_option_wp + hoare_valid_ipc_buffer_ptr_typ_at' copyMRs_typ_at' + hoare_vcg_const_Ball_lift lookupExtraCaps_length + | simp add: if_apply_def2)+) + apply (wp hoare_weak_lift_imp | strengthen valid_msg_length_strengthen)+ + apply clarsimp + apply auto + done + +lemma corres_liftE_lift: + "corres r1 P P' m m' \ + corres (f1 \ r1) P P' (liftE m) (withoutFailure m')" + by simp + +lemmas corres_ipc_thread_helper = + corres_split_eqrE[OF corres_liftE_lift [OF getCurThread_corres]] + +lemmas corres_ipc_info_helper = + corres_split_maprE [where f = message_info_map, OF _ + corres_liftE_lift [OF getMessageInfo_corres]] + +crunch doNormalTransfer + for typ_at'[wp]: "\s. P (typ_at' T p s)" + +lemmas doNormal_lifts[wp] = typ_at_lifts [OF doNormalTransfer_typ_at'] + +lemma doNormal_invs'[wp]: + "\tcb_at' sender and tcb_at' receiver and invs'\ + doNormalTransfer sender send_buf ep badge + can_grant receiver recv_buf \\r. invs'\" + apply (simp add: doNormalTransfer_def) + apply (wp hoare_vcg_const_Ball_lift | simp)+ + done + +crunch doNormalTransfer + for aligned'[wp]: pspace_aligned' + (wp: crunch_wps) +crunch doNormalTransfer + for distinct'[wp]: pspace_distinct' + (wp: crunch_wps) + +lemma transferCaps_urz[wp]: + "\untyped_ranges_zero' and valid_pspace' + and (\s. (\x\set caps. cte_wp_at' (\cte. fst x \ capability.NullCap \ cteCap cte = fst x) (snd x) s))\ + transferCaps tag caps ep receiver recv_buf + \\r. untyped_ranges_zero'\" + apply (simp add: transferCaps_def) + apply (rule hoare_pre) + apply (wp hoare_vcg_all_lift hoare_vcg_const_imp_lift + | wpc + | simp add: ball_conj_distrib)+ + apply clarsimp + done + +crunch doNormalTransfer + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: crunch_wps transferCapsToSlots_pres1 ignore: constOnFailure) + +lemmas asUser_urz = untyped_ranges_zero_lift[OF asUser_gsUntypedZeroRanges] + +crunch doNormalTransfer + for urz[wp]: "untyped_ranges_zero'" + (ignore: asUser wp: crunch_wps asUser_urz hoare_vcg_const_Ball_lift) + +lemma msgFromLookupFailure_map[simp]: + "msgFromLookupFailure (lookup_failure_map lf) + = msg_from_lookup_failure lf" + by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) + +lemma asUser_getRestartPC_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (as_user t getRestartPC) (asUser t getRestartPC)" + apply (rule asUser_corres') + apply (rule corres_Id, simp, simp) + apply (rule no_fail_getRestartPC) + done + +lemma asUser_mapM_getRegister_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (as_user t (mapM getRegister regs)) + (asUser t (mapM getRegister regs))" + apply (rule asUser_corres') + apply (rule corres_Id [OF refl refl]) + apply (rule no_fail_mapM) + apply (simp add: getRegister_def) + done + +lemma makeArchFaultMessage_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (make_arch_fault_msg f t) + (makeArchFaultMessage (arch_fault_map f) t)" + apply (cases f; clarsimp simp: makeArchFaultMessage_def ucast_nat_def split: arch_fault.split) + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) + apply (rule corres_trivial, simp) + apply (wp+, auto) + done + +lemma makeFaultMessage_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (make_fault_msg ft t) + (makeFaultMessage (fault_map ft) t)" + apply (cases ft, simp_all add: makeFaultMessage_def split del: if_split) + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) + apply (rule corres_trivial, simp add: fromEnum_def enum_bool) + apply (wp | simp)+ + apply (simp add: AARCH64_H.syscallMessage_def) + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) + apply (rule corres_trivial, simp) + apply (wp | simp)+ + apply (simp add: AARCH64_H.exceptionMessage_def) + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) + apply (rule corres_trivial, simp) + apply (wp | simp)+ + apply (rule makeArchFaultMessage_corres) + done + +lemma makeFaultMessage_inv[wp]: + "\P\ makeFaultMessage ft t \\rv. P\" + apply (cases ft, simp_all add: makeFaultMessage_def) + apply (wp asUser_inv mapM_wp' det_mapM[where S=UNIV] + det_getRestartPC getRestartPC_inv + | clarsimp simp: getRegister_def makeArchFaultMessage_def + split: arch_fault.split)+ + done + +lemmas threadget_fault_corres = + threadGet_corres [where r = fault_rel_optionation + and f = tcb_fault and f' = tcbFault, + simplified tcb_relation_def, simplified] + +lemma doFaultTransfer_corres: + "corres dc + (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender + and tcb_at receiver and case_option \ in_user_frame recv_buf + and pspace_aligned and pspace_distinct) + (case_option \ valid_ipc_buffer_ptr' recv_buf) + (do_fault_transfer badge sender receiver recv_buf) + (doFaultTransfer badge sender receiver recv_buf)" + apply (clarsimp simp: do_fault_transfer_def doFaultTransfer_def split_def + AARCH64_H.badgeRegister_def badge_register_def) + apply (rule_tac Q="\fault. K (\f. fault = Some f) and + tcb_at sender and tcb_at receiver and + case_option \ in_user_frame recv_buf and + pspace_aligned and pspace_distinct" + and Q'="\fault'. case_option \ valid_ipc_buffer_ptr' recv_buf" + in corres_underlying_split) + apply (rule corres_guard_imp) + apply (rule threadget_fault_corres) + apply (clarsimp simp: obj_at_def is_tcb)+ + apply (rule corres_assume_pre) + apply (fold assert_opt_def | unfold haskell_fail_def)+ + apply (rule corres_assert_opt_assume) + apply (clarsimp split: option.splits + simp: fault_rel_optionation_def assert_opt_def + map_option_case) + defer + defer + apply (clarsimp simp: fault_rel_optionation_def) + apply (wp thread_get_wp) + apply (clarsimp simp: obj_at_def is_tcb) + apply wp + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF makeFaultMessage_corres]) + apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) + apply (rule corres_split_nor[OF setMessageInfo_corres]) + apply simp + apply (rule asUser_setRegister_corres) + apply (wp | simp)+ + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF makeFaultMessage_corres]) + apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) + apply (rule corres_split_nor[OF setMessageInfo_corres]) + apply simp + apply (rule asUser_setRegister_corres) + apply (wp | simp)+ + done + +lemma doFaultTransfer_invs[wp]: + "\invs' and tcb_at' receiver\ + doFaultTransfer badge sender receiver recv_buf + \\rv. invs'\" + by (simp add: doFaultTransfer_def split_def | wp + | clarsimp split: option.split)+ + +lemma lookupIPCBuffer_valid_ipc_buffer [wp]: + "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" + unfolding lookupIPCBuffer_def AARCH64_H.lookupIPCBuffer_def + supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) + apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def + locateSlot_conv threadGet_def comp_def) + apply (wp getCTE_wp getObject_tcb_wp | wpc)+ + apply (clarsimp simp del: imp_disjL) + apply (drule obj_at_ko_at') + apply (clarsimp simp del: imp_disjL) + apply (rule_tac x = ko in exI) + apply (frule ko_at_cte_ipcbuffer[simplified cteSizeBits_def]) + apply (clarsimp simp: cte_wp_at_ctes_of shiftl_t2n' simp del: imp_disjL) + apply (rename_tac ref rg sz d m) + apply (clarsimp simp: valid_ipc_buffer_ptr'_def) + apply (frule (1) ko_at_valid_objs') + apply (clarsimp simp: projectKO_opts_defs split: kernel_object.split_asm) + apply (clarsimp simp add: valid_obj'_def valid_tcb'_def + isCap_simps cte_level_bits_def field_simps) + apply (drule bspec [OF _ ranI [where a = "4 << cteSizeBits"]]) + apply (simp add: cteSizeBits_def) + apply (clarsimp simp add: valid_cap'_def frame_at'_def) + apply (rule conjI) + apply (rule aligned_add_aligned) + apply (clarsimp simp add: capAligned_def) + apply assumption + apply (erule is_aligned_andI1) + apply (rule order_trans[rotated]) + apply (rule pbfs_atleast_pageBits) + apply (simp add: bit_simps msg_align_bits) + apply (clarsimp simp: capAligned_def) + apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize sz)) >> pageBits" in spec) + apply (simp add: shiftr_shiftl1 ) + apply (subst (asm) mask_out_add_aligned) + apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) + apply (erule mp) + apply (rule shiftr_less_t2n) + apply (clarsimp simp: pbfs_atleast_pageBits) + apply (rule and_mask_less') + apply (simp add: word_bits_conv pbfs_less_wb'[unfolded word_bits_conv]) + done + +(* Used in CRefine *) +lemma lookupIPCBuffer_Some_0: + "\\\ lookupIPCBuffer w t \\rv s. rv \ Some 0\" + by (wpsimp simp: lookupIPCBuffer_def Let_def getThreadBufferSlot_def locateSlot_conv) + +(* Used in CRefine *) +lemma asUser_valid_ipc_buffer_ptr': + "asUser t m \\s. valid_ipc_buffer_ptr' p s\" + by (simp add: valid_ipc_buffer_ptr'_def, wp) + +lemma doIPCTransfer_corres: + "corres dc + (tcb_at s and tcb_at r and valid_objs and pspace_aligned + and valid_list and valid_arch_state + and pspace_distinct and valid_mdb and cur_tcb + and (\s. case ep of Some x \ ep_at x s | _ \ True)) + (tcb_at' s and tcb_at' r and valid_pspace' and cur_tcb' + and (\s. case ep of Some x \ ep_at' x s | _ \ True)) + (do_ipc_transfer s ep bg grt r) + (doIPCTransfer s ep bg grt r)" + apply (simp add: do_ipc_transfer_def doIPCTransfer_def) + apply (rule_tac Q="\receiveBuffer sa. tcb_at s sa \ valid_objs sa \ + pspace_aligned sa \ pspace_distinct sa \ tcb_at r sa \ + cur_tcb sa \ valid_mdb sa \ valid_list sa \ valid_arch_state sa \ + (case ep of None \ True | Some x \ ep_at x sa) \ + case_option (\_. True) in_user_frame receiveBuffer sa \ + obj_at (\ko. \tcb. ko = TCB tcb + \ \\ft. tcb_fault tcb = Some ft\) s sa" + in corres_underlying_split) + apply (rule corres_guard_imp) + apply (rule lookupIPCBuffer_corres') + apply auto[2] + apply (rule corres_underlying_split [OF _ _ thread_get_sp threadGet_inv]) + apply (rule corres_guard_imp) + apply (rule threadget_fault_corres) + apply simp + defer + apply (rule corres_guard_imp) + apply (subst case_option_If)+ + apply (rule corres_if2) + apply (simp add: fault_rel_optionation_def) + apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) + apply (simp add: dc_def[symmetric]) + apply (rule doNormalTransfer_corres) + apply (wp | simp add: valid_pspace'_def)+ + apply (simp add: dc_def[symmetric]) + apply (rule doFaultTransfer_corres) + apply (clarsimp simp: obj_at_def) + apply (rule conjI, clarsimp, assumption) + apply (wp|simp add: obj_at_def is_tcb valid_pspace'_def)+ + done + + +crunch doIPCTransfer + for ifunsafe[wp]: "if_unsafe_then_cap'" + (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots + simp: zipWithM_x_mapM ball_conj_distrib ) +crunch doIPCTransfer + for iflive[wp]: "if_live_then_nonz_cap'" + (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots + simp: zipWithM_x_mapM ball_conj_distrib ) +crunch doIPCTransfer + for vp[wp]: "valid_pspace'" + (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) +crunch doIPCTransfer + for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" + (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) +crunch doIPCTransfer + for state_refs_of[wp]: "\s. P (state_refs_of' s)" + (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) +crunch doIPCTransfer + for state_hyp_refs_of[wp]: "\s. P (state_hyp_refs_of' s)" + (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) +crunch doIPCTransfer + for ct[wp]: "cur_tcb'" + (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) +crunch doIPCTransfer + for idle'[wp]: "valid_idle'" + (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) + +crunch doIPCTransfer + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps simp: zipWithM_x_mapM) +lemmas dit'_typ_ats[wp] = typ_at_lifts [OF doIPCTransfer_typ_at'] + +crunch doIPCTransfer + for irq_node'[wp]: "\s. P (irq_node' s)" + (wp: crunch_wps simp: crunch_simps) + +lemmas dit_irq_node'[wp] + = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] + +crunch doIPCTransfer + for valid_arch_state'[wp]: "valid_arch_state'" + (wp: crunch_wps simp: crunch_simps) + +(* Levity: added (20090126 19:32:26) *) +declare asUser_global_refs' [wp] + +lemma lec_valid_cap' [wp]: + "\valid_objs'\ lookupExtraCaps thread xa mi \\rv s. (\x\set rv. s \' fst x)\, -" + apply (rule hoare_pre, rule hoare_strengthen_postE_R) + apply (rule hoare_vcg_conj_liftE_R[where P'=valid_objs' and Q'="\_. valid_objs'"]) + apply (rule lookupExtraCaps_srcs) + apply wp + apply (clarsimp simp: cte_wp_at_ctes_of) + apply fastforce + apply simp + done + +crunch doIPCTransfer + for objs'[wp]: "valid_objs'" + ( wp: crunch_wps hoare_vcg_const_Ball_lift + transferCapsToSlots_valid_objs + simp: zipWithM_x_mapM ball_conj_distrib ) + +crunch doIPCTransfer + for global_refs'[wp]: "valid_global_refs'" + (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_global_refsT + transferCapsToSlots_valid_globals + simp: zipWithM_x_mapM ball_conj_distrib) + +declare asUser_irq_handlers' [wp] + +crunch doIPCTransfer + for irq_handlers'[wp]: "valid_irq_handlers'" + (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_irq_handlers' + transferCapsToSlots_irq_handlers + simp: zipWithM_x_mapM ball_conj_distrib ) + +crunch doIPCTransfer + for irq_states'[wp]: "valid_irq_states'" + (wp: crunch_wps no_irq no_irq_mapM no_irq_storeWord no_irq_loadWord + no_irq_case_option simp: crunch_simps zipWithM_x_mapM) + +crunch doIPCTransfer + for irqs_masked'[wp]: "irqs_masked'" + (wp: crunch_wps simp: crunch_simps rule: irqs_masked_lift) + +lemma doIPCTransfer_invs[wp]: + "\invs' and tcb_at' s and tcb_at' r\ + doIPCTransfer s ep bg grt r + \\rv. invs'\" + apply (simp add: doIPCTransfer_def) + apply (wpsimp wp: hoare_drop_imp) + done + + +lemma arch_getSanitiseRegisterInfo_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (arch_get_sanitise_register_info t) + (getSanitiseRegisterInfo t)" + unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def + apply (fold archThreadGet_def) + apply corres + done + +crunch getSanitiseRegisterInfo + for tcb_at'[wp]: "tcb_at' t" + +crunch arch_get_sanitise_register_info + for pspace_distinct[wp]: pspace_distinct + and pspace_aligned[wp]: pspace_aligned + +lemma handle_fault_reply_registers_corres: + "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (do t' \ arch_get_sanitise_register_info t; + y \ as_user t + (zipWithM_x + (\r v. setRegister r + (sanitise_register t' r v)) + msg_template msg); + return (label = 0) + od) + (do t' \ getSanitiseRegisterInfo t; + y \ asUser t + (zipWithM_x + (\r v. setRegister r (sanitiseRegister t' r v)) + msg_template msg); + return (label = 0) + od)" + apply (rule corres_guard_imp) + apply (rule corres_split[OF arch_getSanitiseRegisterInfo_corres]) + apply (rule corres_split) + apply (rule asUser_corres') + apply(simp add: setRegister_def sanitise_register_def + sanitiseRegister_def syscallMessage_def Let_def cong: register.case_cong) + apply(subst zipWithM_x_modify)+ + apply(rule corres_modify') + apply (simp|wp)+ + done + +lemma handleFaultReply_corres: + "ft' = fault_map ft \ + corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (handle_fault_reply ft t label msg) + (handleFaultReply ft' t label msg)" + apply (cases ft) + apply(simp_all add: handleFaultReply_def + handle_arch_fault_reply_def handleArchFaultReply_def + syscallMessage_def exceptionMessage_def + split: arch_fault.split) + by (rule handle_fault_reply_registers_corres)+ + +crunch handleFaultReply + for typ_at'[wp]: "\s. P (typ_at' T p s)" + +lemmas hfr_typ_ats[wp] = typ_at_lifts [OF handleFaultReply_typ_at'] + +crunch handleFaultReply + for ct'[wp]: "\s. P (ksCurThread s)" + +lemma doIPCTransfer_sch_act_simple [wp]: + "\sch_act_simple\ doIPCTransfer sender endpoint badge grant receiver \\_. sch_act_simple\" + by (simp add: sch_act_simple_def, wp) + +lemma possibleSwitchTo_invs'[wp]: + "\invs' and st_tcb_at' runnable' t + and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + possibleSwitchTo t \\_. invs'\" + apply (simp add: possibleSwitchTo_def curDomain_def) + apply (wp tcbSchedEnqueue_invs' ssa_invs') + apply (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt]) + apply (wpsimp wp: ssa_invs' threadGet_wp)+ + apply (clarsimp dest!: obj_at_ko_at' simp: tcb_in_cur_domain'_def obj_at'_def) + done + +crunch isFinalCapability + for cur'[wp]: "\s. P (cur_tcb' s)" + (simp: crunch_simps unless_when + wp: crunch_wps getObject_inv loadObject_default_inv) + +crunch deleteCallerCap + for ct'[wp]: "\s. P (ksCurThread s)" + (simp: crunch_simps unless_when + wp: crunch_wps getObject_inv loadObject_default_inv) + +lemma getThreadCallerSlot_inv: + "\P\ getThreadCallerSlot t \\_. P\" + by (simp add: getThreadCallerSlot_def, wp) + +lemma finaliseCapTrue_standin_tcb_at' [wp]: + "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" + apply (simp add: finaliseCapTrue_standin_def Let_def) + apply (safe) + apply (wp getObject_ntfn_inv + | wpc + | simp)+ + done + +lemma finaliseCapTrue_standin_cur': + "\\s. cur_tcb' s\ finaliseCapTrue_standin cap v2 \\_ s'. cur_tcb' s'\" + apply (simp add: cur_tcb'_def) + apply (rule hoare_lift_Pf2 [OF _ finaliseCapTrue_standin_ct']) + apply (wp) + done + +lemma cteDeleteOne_cur' [wp]: + "\\s. cur_tcb' s\ cteDeleteOne slot \\_ s'. cur_tcb' s'\" + apply (simp add: cteDeleteOne_def unless_def when_def) + apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' + | simp add: split_def | wp (once) cur_tcb_lift)+ + done + +lemma handleFaultReply_cur' [wp]: + "\\s. cur_tcb' s\ handleFaultReply x0 thread label msg \\_ s'. cur_tcb' s'\" + apply (clarsimp simp add: cur_tcb'_def) + apply (rule hoare_lift_Pf2 [OF _ handleFaultReply_ct']) + apply (wp) + done + +lemma capClass_Reply: + "capClass cap = ReplyClass tcb \ isReplyCap cap \ capTCBPtr cap = tcb" + apply (cases cap, simp_all add: isCap_simps) + apply (rename_tac arch_capability) + apply (case_tac arch_capability, simp_all) + done + +lemma reply_cap_end_mdb_chain: + "\ cte_wp_at (is_reply_cap_to t) slot s; invs s; + invs' s'; + (s, s') \ state_relation; ctes_of s' (cte_map slot) = Some cte \ + \ (mdbPrev (cteMDBNode cte) \ nullPointer + \ mdbNext (cteMDBNode cte) = nullPointer) + \ cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) + (mdbPrev (cteMDBNode cte)) s'" + apply (clarsimp simp only: cte_wp_at_reply_cap_to_ex_rights) + apply (frule(1) pspace_relation_ctes_ofI[OF state_relation_pspace_relation], + clarsimp+) + apply (subgoal_tac "\slot' rights'. caps_of_state s slot' = Some (cap.ReplyCap t True rights') + \ descendants_of slot' (cdt s) = {slot}") + apply (elim state_relationE exE) + apply (clarsimp simp: cdt_relation_def + simp del: split_paired_All) + apply (drule spec, drule(1) mp[OF _ caps_of_state_cte_at]) + apply (frule(1) pspace_relation_cte_wp_at[OF _ caps_of_state_cteD], + clarsimp+) + apply (clarsimp simp: descendants_of'_def cte_wp_at_ctes_of) + apply (frule_tac f="\S. cte_map slot \ S" in arg_cong, simp(no_asm_use)) + apply (frule invs_mdb'[unfolded valid_mdb'_def]) + apply (rule context_conjI) + apply (clarsimp simp: nullPointer_def valid_mdb_ctes_def) + apply (erule(4) subtree_prev_0) + apply (rule conjI) + apply (rule ccontr) + apply (frule valid_mdb_no_loops, simp add: no_loops_def) + apply (drule_tac x="cte_map slot" in spec) + apply (erule notE, rule r_into_trancl, rule ccontr) + apply (clarsimp simp: mdb_next_unfold valid_mdb_ctes_def nullPointer_def) + apply (rule valid_dlistEn, assumption+) + apply (subgoal_tac "ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)") + apply (frule(3) class_linksD) + apply (clarsimp simp: isCap_simps dest!: capClass_Reply[OF sym]) + apply (drule_tac f="\S. mdbNext (cteMDBNode cte) \ S" in arg_cong) + apply (simp, erule notE, rule subtree.trans_parent, assumption+) + apply (case_tac ctea, case_tac cte') + apply (clarsimp simp add: parentOf_def isMDBParentOf_CTE) + apply (simp add: sameRegionAs_def2 isCap_simps) + apply (erule subtree.cases) + apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) + apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) + apply (simp add: mdb_next_unfold) + apply (erule subtree.cases) + apply (clarsimp simp: valid_mdb_ctes_def) + apply (erule_tac cte=ctea in valid_dlistEn, assumption) + apply (simp add: mdb_next_unfold) + apply (clarsimp simp: mdb_next_unfold isCap_simps) + apply (drule_tac f="\S. c' \ S" in arg_cong) + apply (clarsimp simp: no_loops_direct_simp valid_mdb_no_loops) + apply (frule invs_mdb) + apply (drule invs_valid_reply_caps) + apply (clarsimp simp: valid_mdb_def reply_mdb_def + valid_reply_caps_def reply_caps_mdb_def + cte_wp_at_caps_of_state + simp del: split_paired_All) + apply (erule_tac x=slot in allE, erule_tac x=t in allE, erule impE, fast) + apply (elim exEI) + apply clarsimp + apply (subgoal_tac "P" for P, rule sym, rule equalityI, assumption) + apply clarsimp + apply (erule(4) unique_reply_capsD) + apply (simp add: descendants_of_def) + apply (rule r_into_trancl) + apply (simp add: cdt_parent_rel_def is_cdt_parent_def) + done + +lemma unbindNotification_valid_objs'_strengthen: + "valid_tcb' tcb s \ valid_tcb' (tcbBoundNotification_update Map.empty tcb) s" + "valid_ntfn' ntfn s \ valid_ntfn' (ntfnBoundTCB_update Map.empty ntfn) s" + by (simp_all add: unbindNotification_valid_objs'_helper' unbindNotification_valid_objs'_helper) + +crunch cteDeleteOne + for valid_objs'[wp]: "valid_objs'" + (simp: crunch_simps unless_def + wp: crunch_wps getObject_inv loadObject_default_inv) + +crunch handleFaultReply + for nosch[wp]: "\s. P (ksSchedulerAction s)" + +lemma emptySlot_weak_sch_act[wp]: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ + emptySlot slot irq + \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" + by (wp weak_sch_act_wf_lift tcb_in_cur_domain'_lift) + +lemma cancelAllIPC_weak_sch_act_wf[wp]: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ + cancelAllIPC epptr + \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: cancelAllIPC_def) + apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ + done + +lemma cancelAllSignals_weak_sch_act_wf[wp]: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ + cancelAllSignals ntfnptr + \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: cancelAllSignals_def) + apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ + done + +crunch finaliseCapTrue_standin + for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" + (ignore: setThreadState + simp: crunch_simps + wp: crunch_wps getObject_inv loadObject_default_inv) + +lemma cteDeleteOne_weak_sch_act[wp]: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ + cteDeleteOne sl + \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: cteDeleteOne_def unless_def) + apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' + | simp add: split_def)+ + done + +crunch handleFaultReply + for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" +crunch handleFaultReply + for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" + +crunch unbindNotification + for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" +(wp: sbn_sch_act') + +crunch handleFaultReply + for valid_objs'[wp]: valid_objs' + +lemma cte_wp_at_is_reply_cap_toI: + "cte_wp_at ((=) (cap.ReplyCap t False rights)) ptr s + \ cte_wp_at (is_reply_cap_to t) ptr s" + by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) + +crunch handle_fault_reply + for pspace_alignedp[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + +crunch cteDeleteOne, doIPCTransfer, handleFaultReply + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + +lemma doReplyTransfer_corres: + "corres dc + (einvs and tcb_at receiver and tcb_at sender + and cte_wp_at ((=) (cap.ReplyCap receiver False rights)) slot) + (invs' and tcb_at' sender and tcb_at' receiver + and valid_pspace' and cte_at' (cte_map slot)) + (do_reply_transfer sender receiver slot grant) + (doReplyTransfer sender receiver (cte_map slot) grant)" + apply (simp add: do_reply_transfer_def doReplyTransfer_def cong: option.case_cong) + apply (rule corres_underlying_split [OF _ _ gts_sp gts_sp']) + apply (rule corres_guard_imp) + apply (rule getThreadState_corres, (clarsimp simp add: st_tcb_at_tcb_at invs_distinct invs_psp_aligned)+) + apply (rule_tac F = "awaiting_reply state" in corres_req) + apply (clarsimp simp add: st_tcb_at_def obj_at_def is_tcb) + apply (fastforce simp: invs_def valid_state_def intro: has_reply_cap_cte_wpD + dest: has_reply_cap_cte_wpD + dest!: valid_reply_caps_awaiting_reply cte_wp_at_is_reply_cap_toI) + apply (case_tac state, simp_all add: bind_assoc) + apply (simp add: isReply_def liftM_def) + apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) + apply (rule no_fail_pre, wp) + apply clarsimp + apply (rename_tac mdbnode) + apply (rule_tac P="Q" and Q="Q" and P'="Q'" and Q'="(\s. Q' s \ R' s)" for Q Q' R' + in stronger_corres_guard_imp[rotated]) + apply assumption + apply (rule conjI, assumption) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (drule cte_wp_at_is_reply_cap_toI) + apply (erule(4) reply_cap_end_mdb_chain) + apply (rule corres_assert_assume[rotated], simp) + apply (simp add: getSlotCap_def) + apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) + apply (rule no_fail_pre, wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (rule corres_assert_assume[rotated]) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (rule corres_guard_imp) + apply (rule corres_split[OF threadget_fault_corres]) + apply (case_tac rv, simp_all add: fault_rel_optionation_def bind_assoc)[1] + apply (rule corres_split[OF doIPCTransfer_corres]) + apply (rule corres_split[OF cap_delete_one_corres]) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule possibleSwitchTo_corres) + apply (wp set_thread_state_runnable_valid_sched + set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' + sts_valid_objs' delete_one_tcbDomain_obj_at' + | simp add: valid_tcb_state'_def + | strengthen valid_queues_in_correct_ready_q valid_sched_valid_queues + valid_queues_ready_qs_distinct)+ + apply (strengthen cte_wp_at_reply_cap_can_fast_finalise) + apply (wp hoare_vcg_conj_lift) + apply (rule hoare_strengthen_post [OF do_ipc_transfer_non_null_cte_wp_at]) + prefer 2 + apply (erule cte_wp_at_weakenE) + apply (fastforce) + apply (clarsimp simp:is_cap_simps) + apply (wp weak_valid_sched_action_lift)+ + apply (rule_tac Q'="\_ s. valid_objs' s \ cur_tcb' s \ tcb_at' receiver s + \ sch_act_wf (ksSchedulerAction s) s + \ sym_heap_sched_pointers s \ valid_sched_pointers s + \ pspace_aligned' s \ pspace_distinct' s" + in hoare_post_imp, simp add: sch_act_wf_weak) + apply (wp tcb_in_cur_domain'_lift) + defer + apply (simp) + apply (wp)+ + apply (clarsimp simp: invs_psp_aligned invs_distinct) + apply (rule conjI, erule invs_valid_objs) + apply (rule conjI, clarsimp)+ + apply (rule conjI) + apply (erule cte_wp_at_weakenE) + apply (clarsimp) + apply (rule conjI, rule refl) + apply (fastforce) + apply (clarsimp simp: invs_def valid_sched_def valid_sched_action_def invs_psp_aligned invs_distinct) + apply (simp) + apply (auto simp: invs'_def valid_state'_def)[1] + + apply (rule corres_guard_imp) + apply (rule corres_split[OF cap_delete_one_corres]) + apply (rule corres_split_mapr[OF getMessageInfo_corres]) + apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) + apply (rule corres_split_eqr[OF getMRs_corres]) + apply (simp(no_asm) del: dc_simp) + apply (rule corres_split_eqr[OF handleFaultReply_corres]) + apply simp + apply (rule corres_split) + apply (rule threadset_corresT; + clarsimp simp add: tcb_relation_def fault_rel_optionation_def cteSizeBits_def + tcb_cap_cases_def tcb_cte_cases_def inQ_def) + apply (rule_tac Q="valid_sched and cur_tcb and tcb_at receiver and pspace_aligned and pspace_distinct" + and Q'="tcb_at' receiver and cur_tcb' + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' + and sym_heap_sched_pointers and valid_sched_pointers + and pspace_aligned' and pspace_distinct'" + in corres_guard_imp) + apply (case_tac rvb, simp_all)[1] + apply (rule corres_guard_imp) + apply (rule corres_split[OF setThreadState_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (fold dc_def, rule possibleSwitchTo_corres) + apply simp + apply (wp hoare_weak_lift_imp hoare_weak_lift_imp_conj set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' + sts_st_tcb' sts_valid_objs' + | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ + apply (rule corres_guard_imp) + apply (rule setThreadState_corres) + apply (clarsimp simp: tcb_relation_def) + apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state + thread_set_not_state_valid_sched + threadSet_tcbDomain_triv threadSet_valid_objs' + threadSet_sched_pointers threadSet_valid_sched_pointers + | simp add: valid_tcb_state'_def)+ + apply (rule_tac Q'="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and + valid_objs and pspace_aligned and pspace_distinct" + in hoare_strengthen_post [rotated], clarsimp) + apply (wp) + apply (rule hoare_chain [OF cap_delete_one_invs]) + apply (assumption) + apply (rule conjI, clarsimp) + apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def) + apply (rule_tac Q'="\_. tcb_at' sender and tcb_at' receiver and invs'" + in hoare_strengthen_post [rotated]) + apply (solves\auto simp: invs'_def valid_state'_def\) + apply wp + apply clarsimp + apply (rule conjI) + apply (erule cte_wp_at_weakenE) + apply (clarsimp simp add: can_fast_finalise_def) + apply (erule(1) emptyable_cte_wp_atD) + apply (rule allI, rule impI) + apply (clarsimp simp add: is_master_reply_cap_def) + apply (clarsimp) + done + +(* when we cannot talk about reply cap rights explicitly (for instance, when a schematic ?rights + would be generated too early *) +lemma doReplyTransfer_corres': + "corres dc + (einvs and tcb_at receiver and tcb_at sender + and cte_wp_at (is_reply_cap_to receiver) slot) + (invs' and tcb_at' sender and tcb_at' receiver + and valid_pspace' and cte_at' (cte_map slot)) + (do_reply_transfer sender receiver slot grant) + (doReplyTransfer sender receiver (cte_map slot) grant)" + using doReplyTransfer_corres[of receiver sender _ slot] + by (fastforce simp add: cte_wp_at_reply_cap_to_ex_rights corres_underlying_def) + +lemma valid_pspace'_splits[elim!]: (* FIXME AARCH64: clean up duplicates *) + "valid_pspace' s \ valid_objs' s" + "valid_pspace' s \ pspace_aligned' s" + "valid_pspace' s \ pspace_distinct' s" + "valid_pspace' s \ valid_mdb' s" + "valid_pspace' s \ no_0_obj' s" + by (simp add: valid_pspace'_def)+ + +lemma sts_valid_pspace_hangers: + "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. valid_objs'\" + "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_distinct'\" + "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_aligned'\" + "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_canonical'\" + "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. valid_mdb'\" + "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. no_0_obj'\" + by (safe intro!: hoare_strengthen_post [OF sts'_valid_pspace'_inv]) + +declare no_fail_getSlotCap [wp] + +lemma setupCallerCap_corres: + "corres dc + (st_tcb_at (Not \ halted) sender and tcb_at receiver and + st_tcb_at (Not \ awaiting_reply) sender and valid_reply_caps and + valid_objs and pspace_distinct and pspace_aligned and valid_mdb + and valid_list and valid_arch_state and + valid_reply_masters and cte_wp_at (\c. c = cap.NullCap) (receiver, tcb_cnode_index 3)) + (tcb_at' sender and tcb_at' receiver and valid_pspace' + and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) + (setup_caller_cap sender receiver grant) + (setupCallerCap sender receiver grant)" + supply if_split[split del] + apply (simp add: setup_caller_cap_def setupCallerCap_def + getThreadReplySlot_def locateSlot_conv + getThreadCallerSlot_def) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split_nor) + apply (rule setThreadState_corres) + apply (simp split: option.split) + apply (rule corres_symb_exec_r) + apply (rule_tac F="\r. cteCap masterCTE = capability.ReplyCap sender True r + \ mdbNext (cteMDBNode masterCTE) = nullPointer" + in corres_gen_asm2, clarsimp simp add: isCap_simps) + apply (rule corres_symb_exec_r) + apply (rule_tac F="rv = capability.NullCap" + in corres_gen_asm2, simp) + apply (rule cteInsert_corres) + apply (simp split: if_splits) + apply (simp add: cte_map_def tcbReplySlot_def + tcb_cnode_index_def cte_level_bits_def) + apply (simp add: cte_map_def tcbCallerSlot_def + tcb_cnode_index_def cte_level_bits_def) + apply (rule_tac Q'="\rv. cte_at' (receiver + 2 ^ cte_level_bits * tcbCallerSlot)" + in hoare_post_add) + + apply (wp, (wp getSlotCap_wp)+) + apply blast + apply (rule no_fail_pre, wp) + apply (clarsimp simp: cte_wp_at'_def cte_at'_def) + apply (rule_tac Q'="\rv. cte_at' (sender + 2 ^ cte_level_bits * tcbReplySlot)" + in hoare_post_add) + apply (wp, (wp getCTE_wp')+) + apply blast + apply (rule no_fail_pre, wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (wp sts_valid_pspace_hangers + | simp add: cte_wp_at_ctes_of)+ + apply (clarsimp simp: valid_tcb_state_def st_tcb_at_reply_cap_valid + st_tcb_at_tcb_at st_tcb_at_caller_cap_null + split: option.split) + apply (clarsimp simp: valid_tcb_state'_def valid_cap'_def capAligned_reply_tcbI) + apply (frule(1) st_tcb_at_reply_cap_valid, simp, clarsimp) + apply (clarsimp simp: cte_wp_at_ctes_of cte_wp_at_caps_of_state) + apply (drule pspace_relation_cte_wp_at[rotated, OF caps_of_state_cteD], + erule valid_pspace'_splits, clarsimp+)+ + apply (clarsimp simp: cte_wp_at_ctes_of cte_map_def tcbReplySlot_def + tcbCallerSlot_def tcb_cnode_index_def + is_cap_simps) + apply (auto intro: reply_no_descendants_mdbNext_null[OF not_waiting_reply_slot_no_descendants] + simp: cte_level_bits_def) + done + +crunch getThreadCallerSlot + for tcb_at'[wp]: "tcb_at' t" + +lemma getThreadReplySlot_tcb_at'[wp]: + "\tcb_at' t\ getThreadReplySlot tcb \\_. tcb_at' t\" + by (simp add: getThreadReplySlot_def, wp) + +lemma setupCallerCap_tcb_at'[wp]: + "\tcb_at' t\ setupCallerCap sender receiver grant \\_. tcb_at' t\" + by (simp add: setupCallerCap_def, wp hoare_drop_imp) + +crunch setupCallerCap + for ct'[wp]: "\s. P (ksCurThread s)" + (wp: crunch_wps) + +lemma cteInsert_sch_act_wf[wp]: + "\\s. sch_act_wf (ksSchedulerAction s) s\ + cteInsert newCap srcSlot destSlot + \\_ s. sch_act_wf (ksSchedulerAction s) s\" +by (wp sch_act_wf_lift tcb_in_cur_domain'_lift) + +lemma setupCallerCap_sch_act [wp]: + "\\s. sch_act_not t s \ sch_act_wf (ksSchedulerAction s) s\ + setupCallerCap t r g \\_ s. sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: setupCallerCap_def getSlotCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv) + apply (wp getCTE_wp' sts_sch_act' hoare_drop_imps hoare_vcg_all_lift) + apply clarsimp + done + +lemma possibleSwitchTo_weak_sch_act_wf[wp]: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ + possibleSwitchTo t \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: possibleSwitchTo_def setSchedulerAction_def threadGet_def curDomain_def + bitmap_fun_defs) + apply (wp rescheduleRequired_weak_sch_act_wf + weak_sch_act_wf_lift_linear[where f="tcbSchedEnqueue t"] + getObject_tcb_wp hoare_weak_lift_imp + | wpc)+ + apply (clarsimp simp: obj_at'_def weak_sch_act_wf_def ps_clear_def tcb_in_cur_domain'_def) + done + +lemmas transferCapsToSlots_pred_tcb_at' = + transferCapsToSlots_pres1 [OF cteInsert_pred_tcb_at'] + +crunch doIPCTransfer, possibleSwitchTo + for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" + (wp: mapM_wp' crunch_wps simp: zipWithM_x_mapM) + +lemma setSchedulerAction_ct_in_domain: + "\\s. ct_idle_or_in_cur_domain' s + \ p \ ResumeCurrentThread \ setSchedulerAction p + \\_. ct_idle_or_in_cur_domain'\" + by (simp add:setSchedulerAction_def | wp)+ + +crunch setupCallerCap, doIPCTransfer, possibleSwitchTo + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' + (wp: crunch_wps setSchedulerAction_ct_in_domain simp: zipWithM_x_mapM) +crunch setupCallerCap, doIPCTransfer, possibleSwitchTo + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + (wp: crunch_wps simp: zipWithM_x_mapM) + +crunch doIPCTransfer + for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" + (wp: crunch_wps constOnFailure_wp simp: crunch_simps) + +crunch possibleSwitchTo + for tcb_at'[wp]: "tcb_at' t" + (wp: crunch_wps) + +crunch possibleSwitchTo + for valid_pspace'[wp]: valid_pspace' + (wp: crunch_wps) + +lemma sendIPC_corres: +(* call is only true if called in handleSyscall SysCall, which + is always blocking. *) + assumes "call \ bl" + shows + "corres dc (einvs and st_tcb_at active t and ep_at ep and ex_nonz_cap_to t) + (invs' and sch_act_not t and tcb_at' t and ep_at' ep) + (send_ipc bl call bg cg cgr t ep) (sendIPC bl call bg cg cgr t ep)" +proof - + show ?thesis + apply (insert assms) + apply (unfold send_ipc_def sendIPC_def Let_def) + apply (case_tac bl) + apply clarsimp + apply (rule corres_guard_imp) + apply (rule corres_split[OF getEndpoint_corres, + where + R="\rv. einvs and st_tcb_at active t and ep_at ep and + valid_ep rv and obj_at (\ob. ob = Endpoint rv) ep + and ex_nonz_cap_to t" + and + R'="\rv'. invs' and tcb_at' t and sch_act_not t + and ep_at' ep and valid_ep' rv'"]) + apply (case_tac rv) + apply (simp add: ep_relation_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setEndpoint_corres) + apply (simp add: ep_relation_def) + apply wp+ + apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) + apply clarsimp + \ \concludes IdleEP if bl branch\ + apply (simp add: ep_relation_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setEndpoint_corres) + apply (simp add: ep_relation_def) + apply wp+ + apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) + apply clarsimp + \ \concludes SendEP if bl branch\ + apply (simp add: ep_relation_def) + apply (rename_tac list) + apply (rule_tac F="list \ []" in corres_req) + apply (simp add: valid_ep_def) + apply (case_tac list) + apply simp + apply (clarsimp split del: if_split) + apply (rule corres_guard_imp) + apply (rule corres_split[OF setEndpoint_corres]) + apply (simp add: ep_relation_def split: list.split) + apply (simp add: isReceive_def split del:if_split) + apply (rule corres_split[OF getThreadState_corres]) + apply (rule_tac + F="\data. recv_state = Structures_A.BlockedOnReceive ep data" + in corres_gen_asm) + apply (clarsimp simp: case_bool_If case_option_If if3_fold + simp del: dc_simp split del: if_split cong: if_cong) + apply (rule corres_split[OF doIPCTransfer_corres]) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule corres_split[OF possibleSwitchTo_corres]) + apply (fold when_def)[1] + apply (rule_tac P="call" and P'="call" + in corres_symmetric_bool_cases, blast) + apply (simp add: when_def dc_def[symmetric] split del: if_split) + apply (rule corres_if2, simp) + apply (rule setupCallerCap_corres) + apply (rule setThreadState_corres, simp) + apply (rule corres_trivial) + apply (simp add: when_def dc_def[symmetric] split del: if_split) + apply (simp split del: if_split add: if_apply_def2) + apply (wp hoare_drop_imps)[1] + apply (simp split del: if_split add: if_apply_def2) + apply (wp hoare_drop_imps)[1] + apply (wp | simp)+ + apply (wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases) + apply (wp sts_weak_sch_act_wf sts_valid_objs' + sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases)[1] + apply (simp add: valid_tcb_state_def pred_conj_def) + apply (strengthen reply_cap_doesnt_exist_strg disjI2_strg + valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct + valid_sched_valid_queues)+ + apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift + do_ipc_transfer_valid_arch + | clarsimp simp: is_cap_simps)+)[1] + apply (simp add: pred_conj_def) + apply (strengthen sch_act_wf_weak) + apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift hoare_drop_imps)[1] + apply (wp gts_st_tcb_at)+ + apply (simp add: pred_conj_def cong: conj_cong) + apply (wp hoare_TrueI) + apply (simp) + apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb')+ + apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def ep_redux_simps + ep_redux_simps' st_tcb_at_tcb_at valid_ep_def + cong: list.case_cong) + apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) + apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid + st_tcb_def2 valid_sched_def valid_sched_action_def) + apply (force simp: st_tcb_def2 dest!: st_tcb_at_caller_cap_null[simplified,rotated]) + subgoal by (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split) + apply wp+ + apply (clarsimp simp: ep_at_def2)+ + apply (rule corres_guard_imp) + apply (rule corres_split[OF getEndpoint_corres, + where + R="\rv. einvs and st_tcb_at active t and ep_at ep and + valid_ep rv and obj_at (\k. k = Endpoint rv) ep" + and + R'="\rv'. invs' and tcb_at' t and sch_act_not t + and ep_at' ep and valid_ep' rv'"]) + apply (rename_tac rv rv') + apply (case_tac rv) + apply (simp add: ep_relation_def) + \ \concludes IdleEP branch if not bl and no ft\ + apply (simp add: ep_relation_def) + \ \concludes SendEP branch if not bl and no ft\ + apply (simp add: ep_relation_def) + apply (rename_tac list) + apply (rule_tac F="list \ []" in corres_req) + apply (simp add: valid_ep_def) + apply (case_tac list) + apply simp + apply (rule_tac F="a \ t" in corres_req) + apply (clarsimp simp: invs_def valid_state_def + valid_pspace_def) + apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) + apply (clarsimp simp: st_tcb_at_def obj_at_def tcb_bound_refs_def2) + apply fastforce + apply (clarsimp split del: if_split) + apply (rule corres_guard_imp) + apply (rule corres_split[OF setEndpoint_corres]) + apply (simp add: ep_relation_def split: list.split) + apply (rule corres_split[OF getThreadState_corres]) + apply (rule_tac + F="\data. recv_state = Structures_A.BlockedOnReceive ep data" + in corres_gen_asm) + apply (clarsimp simp: isReceive_def case_bool_If + split del: if_split cong: if_cong) + apply (rule corres_split[OF doIPCTransfer_corres]) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule possibleSwitchTo_corres) + apply (simp add: if_apply_def2) + apply ((wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases | + simp add: if_apply_def2 split del: if_split)+)[1] + apply (wp sts_weak_sch_act_wf sts_valid_objs' + sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases) + apply (simp add: valid_tcb_state_def pred_conj_def) + apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift + | clarsimp simp: is_cap_simps + | strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct + valid_sched_valid_queues )+)[1] + apply (simp add: valid_tcb_state'_def pred_conj_def) + apply (strengthen sch_act_wf_weak) + apply (wp weak_sch_act_wf_lift_linear hoare_drop_imps) + apply (wp gts_st_tcb_at)+ + apply (simp add: pred_conj_def cong: conj_cong) + apply (wp hoare_TrueI) + apply simp + apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb') + apply (clarsimp simp add: invs_def valid_state_def + valid_pspace_def ep_redux_simps ep_redux_simps' + st_tcb_at_tcb_at + cong: list.case_cong) + apply (clarsimp simp: valid_ep_def) + apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) + apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid + st_tcb_at_caller_cap_null) + apply (fastforce simp: st_tcb_def2 valid_sched_def valid_sched_action_def) + subgoal by (auto simp: valid_ep'_def + split: list.split; + clarsimp simp: invs'_def valid_state'_def) + apply wp+ + apply (clarsimp simp: ep_at_def2)+ + done +qed + +lemmas setMessageInfo_typ_ats[wp] = typ_at_lifts [OF setMessageInfo_typ_at'] + +(* Annotation added by Simon Winwood (Thu Jul 1 20:54:41 2010) using taint-mode *) +declare tl_drop_1[simp] + +crunch cancel_ipc + for cur[wp]: "cur_tcb" + (wp: crunch_wps simp: crunch_simps) + +lemma valid_sched_weak_strg: + "valid_sched s \ weak_valid_sched_action s" + by (simp add: valid_sched_def valid_sched_action_def) + +lemma sendSignal_corres: + "corres dc (einvs and ntfn_at ep) (invs' and ntfn_at' ep) + (send_signal ep bg) (sendSignal ep bg)" + supply if_cong[cong] + apply (simp add: send_signal_def sendSignal_def Let_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getNotification_corres, + where + R = "\rv. einvs and ntfn_at ep and valid_ntfn rv and + ko_at (Structures_A.Notification rv) ep" and + R' = "\rv'. invs' and ntfn_at' ep and + valid_ntfn' rv' and ko_at' rv' ep"]) + defer + apply (wp get_simple_ko_ko_at get_ntfn_ko')+ + apply (simp add: invs_valid_objs)+ + apply (case_tac "ntfn_obj ntfn") + \ \IdleNtfn\ + apply (clarsimp simp add: ntfn_relation_def) + apply (case_tac "ntfnBoundTCB nTFN") + apply clarsimp + apply (rule corres_guard_imp[OF setNotification_corres]) + apply (clarsimp simp add: ntfn_relation_def)+ + apply (rule corres_guard_imp) + apply (rule corres_split[OF getThreadState_corres]) + apply (rule corres_if) + apply (fastforce simp: receive_blocked_def receiveBlocked_def + thread_state_relation_def + split: Structures_A.thread_state.splits + Structures_H.thread_state.splits) + apply (rule corres_split[OF cancel_ipc_corres]) + apply (rule corres_split[OF setThreadState_corres]) + apply (clarsimp simp: thread_state_relation_def) + apply (simp add: badgeRegister_def badge_register_def) + apply (rule corres_split[OF asUser_setRegister_corres]) + apply (rule possibleSwitchTo_corres) + apply wp + apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' + sts_st_tcb' sts_valid_objs' hoare_disjI2 + cancel_ipc_cte_wp_at_not_reply_state + | strengthen invs_vobjs_strgs invs_psp_aligned_strg valid_sched_weak_strg + valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct + valid_sched_valid_queues + | simp add: valid_tcb_state_def)+ + apply (rule_tac Q'="\rv. invs' and tcb_at' a" in hoare_strengthen_post) + apply wp + apply (fastforce simp: invs'_def valid_state'_def sch_act_wf_weak valid_tcb_state'_def) + apply (rule setNotification_corres) + apply (clarsimp simp add: ntfn_relation_def) + apply (wp gts_wp gts_wp' | clarsimp)+ + apply (auto simp: valid_ntfn_def receive_blocked_def valid_sched_def invs_cur + elim: pred_tcb_weakenE + intro: st_tcb_at_reply_cap_valid + split: Structures_A.thread_state.splits)[1] + apply (clarsimp simp: valid_ntfn'_def invs'_def valid_state'_def valid_pspace'_def sch_act_wf_weak) + \ \WaitingNtfn\ + apply (clarsimp simp add: ntfn_relation_def Let_def) + apply (simp add: update_waiting_ntfn_def) + apply (rename_tac list) + apply (case_tac "tl list = []") + \ \tl list = []\ + apply (rule corres_guard_imp) + apply (rule_tac F="list \ []" in corres_gen_asm) + apply (simp add: list_case_helper split del: if_split) + apply (rule corres_split[OF setNotification_corres]) + apply (simp add: ntfn_relation_def) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (simp add: badgeRegister_def badge_register_def) + apply (rule corres_split[OF asUser_setRegister_corres]) + apply (rule possibleSwitchTo_corres) + apply ((wp | simp)+)[1] + apply (rule_tac Q'="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and + cur_tcb' and + st_tcb_at' runnable' (hd list) and valid_objs' and + sym_heap_sched_pointers and valid_sched_pointers and + pspace_aligned' and pspace_distinct'" + in hoare_post_imp, clarsimp simp: pred_tcb_at') + apply (wp | simp)+ + apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action + | simp)+ + apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb + | simp)+ + apply (wp set_simple_ko_valid_objs set_ntfn_aligned' set_ntfn_valid_objs' + hoare_vcg_disj_lift weak_sch_act_wf_lift_linear + | simp add: valid_tcb_state_def valid_tcb_state'_def)+ + apply (fastforce simp: invs_def valid_state_def valid_ntfn_def + valid_pspace_def ntfn_queued_st_tcb_at valid_sched_def + valid_sched_action_def) + apply (auto simp: valid_ntfn'_def )[1] + apply (clarsimp simp: invs'_def valid_state'_def) + + \ \tl list \ []\ + apply (rule corres_guard_imp) + apply (rule_tac F="list \ []" in corres_gen_asm) + apply (simp add: list_case_helper) + apply (rule corres_split[OF setNotification_corres]) + apply (simp add: ntfn_relation_def split:list.splits) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (simp add: badgeRegister_def badge_register_def) + apply (rule corres_split[OF asUser_setRegister_corres]) + apply (rule possibleSwitchTo_corres) + apply (wp cur_tcb_lift | simp)+ + apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action + | simp)+ + apply (wpsimp wp: sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb) + apply (wp set_ntfn_aligned' set_simple_ko_valid_objs set_ntfn_valid_objs' + hoare_vcg_disj_lift weak_sch_act_wf_lift_linear + | simp add: valid_tcb_state_def valid_tcb_state'_def)+ + apply (fastforce simp: invs_def valid_state_def valid_ntfn_def + valid_pspace_def neq_Nil_conv + ntfn_queued_st_tcb_at valid_sched_def valid_sched_action_def + split: option.splits) + apply (auto simp: valid_ntfn'_def neq_Nil_conv invs'_def valid_state'_def + weak_sch_act_wf_def + split: option.splits)[1] + \ \ActiveNtfn\ + apply (clarsimp simp add: ntfn_relation_def) + apply (rule corres_guard_imp) + apply (rule setNotification_corres) + apply (simp add: ntfn_relation_def combine_ntfn_badges_def + combine_ntfn_msgs_def) + apply (simp add: invs_def valid_state_def valid_ntfn_def) + apply (simp add: invs'_def valid_state'_def valid_ntfn'_def) + done + +lemma valid_Running'[simp]: + "valid_tcb_state' Running = \" + by (rule ext, simp add: valid_tcb_state'_def) + +crunch setMRs + for typ'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps simp: zipWithM_x_mapM) + +lemma possibleSwitchTo_sch_act[wp]: + "\\s. sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ + possibleSwitchTo t + \\rv s. sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) + apply (wp hoare_weak_lift_imp threadSet_sch_act setQueue_sch_act threadGet_wp + | simp add: unless_def | wpc)+ + apply (auto simp: obj_at'_def tcb_in_cur_domain'_def) + done + +crunch possibleSwitchTo + for st_refs_of'[wp]: "\s. P (state_refs_of' s)" + (wp: crunch_wps) +crunch possibleSwitchTo + for st_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" + (wp: crunch_wps) +crunch possibleSwitchTo + for cap_to'[wp]: "ex_nonz_cap_to' p" + (wp: crunch_wps) +crunch possibleSwitchTo + for objs'[wp]: valid_objs' + (wp: crunch_wps) +crunch possibleSwitchTo + for ct[wp]: cur_tcb' + (wp: cur_tcb_lift crunch_wps) + +lemma possibleSwitchTo_iflive[wp]: + "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) + and pspace_aligned' and pspace_distinct'\ + possibleSwitchTo t + \\rv. if_live_then_nonz_cap'\" + unfolding possibleSwitchTo_def curDomain_def + by (wpsimp wp: threadGet_wp) + +crunch possibleSwitchTo + for ifunsafe[wp]: if_unsafe_then_cap' + (wp: crunch_wps) +crunch possibleSwitchTo + for idle'[wp]: valid_idle' + (wp: crunch_wps) +crunch possibleSwitchTo + for global_refs'[wp]: valid_global_refs' + (wp: crunch_wps) +crunch possibleSwitchTo + for arch_state'[wp]: valid_arch_state' + (wp: crunch_wps) +crunch possibleSwitchTo + for irq_node'[wp]: "\s. P (irq_node' s)" + (wp: crunch_wps) +crunch possibleSwitchTo + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) +crunch possibleSwitchTo + for irq_handlers'[wp]: valid_irq_handlers' + (simp: unless_def tcb_cte_cases_def cteSizeBits_def wp: crunch_wps) +crunch possibleSwitchTo + for irq_states'[wp]: valid_irq_states' + (wp: crunch_wps) +crunch sendSignal + for ct'[wp]: "\s. P (ksCurThread s)" + (wp: crunch_wps simp: crunch_simps o_def) +crunch sendSignal + for it'[wp]: "\s. P (ksIdleThread s)" + (wp: crunch_wps simp: crunch_simps) + +crunch setBoundNotification + for irqs_masked'[wp]: "irqs_masked'" + (wp: irqs_masked_lift) + +crunch sendSignal + for irqs_masked'[wp]: "irqs_masked'" + (wp: crunch_wps getObject_inv loadObject_default_inv + simp: crunch_simps unless_def o_def + rule: irqs_masked_lift) + +lemma ct_in_state_activatable_imp_simple'[simp]: + "ct_in_state' activatable' s \ ct_in_state' simple' s" + apply (simp add: ct_in_state'_def) + apply (erule pred_tcb'_weakenE) + apply (case_tac st; simp) + done + +lemma setThreadState_nonqueued_state_update: + "\\s. invs' s \ st_tcb_at' simple' t s + \ st \ {Inactive, Running, Restart, IdleThreadState} + \ (st \ Inactive \ ex_nonz_cap_to' t s) + \ (t = ksIdleThread s \ idle' st) + \ (\ runnable' st \ sch_act_simple s)\ + setThreadState st t + \\_. invs'\" + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wp valid_irq_node_lift setThreadState_ct_not_inQ valid_dom_schedule'_lift) + apply (clarsimp simp: pred_tcb_at') + apply (rule conjI, fastforce simp: valid_tcb_state'_def) + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (rule conjI) + apply clarsimp + apply (erule delta_sym_refs) + apply (fastforce split: if_split_asm) + apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) + apply fastforce + done + +lemma cteDeleteOne_reply_cap_to'[wp]: + "\ex_nonz_cap_to' p and + cte_wp_at' (\c. isReplyCap (cteCap c)) slot\ + cteDeleteOne slot + \\rv. ex_nonz_cap_to' p\" + apply (simp add: cteDeleteOne_def ex_nonz_cap_to'_def unless_def) + apply (rule bind_wp [OF _ getCTE_sp]) + apply (rule hoare_assume_pre) + apply (subgoal_tac "isReplyCap (cteCap cte)") + apply (wp hoare_vcg_ex_lift emptySlot_cte_wp_cap_other isFinalCapability_inv + | clarsimp simp: finaliseCap_def isCap_simps + | wp (once) hoare_drop_imps)+ + apply (fastforce simp: cte_wp_at_ctes_of) + apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) + done + +crunch setupCallerCap, possibleSwitchTo, asUser, doIPCTransfer + for vms'[wp]: "valid_machine_state'" + (wp: crunch_wps simp: zipWithM_x_mapM_x) + +crunch cancelSignal + for nonz_cap_to'[wp]: "ex_nonz_cap_to' p" + (wp: crunch_wps simp: crunch_simps) + +lemma cancelIPC_nonz_cap_to'[wp]: + "\ex_nonz_cap_to' p\ cancelIPC t \\rv. ex_nonz_cap_to' p\" + apply (simp add: cancelIPC_def getThreadReplySlot_def Let_def + capHasProperty_def) + apply (wp threadSet_cap_to' + | wpc + | simp + | clarsimp elim!: cte_wp_at_weakenE' + | rule hoare_post_imp[where Q'="\rv. ex_nonz_cap_to' p"])+ + done + + +crunch activateIdleThread, getThreadReplySlot, isFinalCapability + for nosch[wp]: "\s. P (ksSchedulerAction s)" + (simp: Let_def) + +crunch setupCallerCap, asUser, setMRs, doIPCTransfer, possibleSwitchTo + for pspace_domain_valid[wp]: "pspace_domain_valid" + (wp: crunch_wps simp: zipWithM_x_mapM_x) + +crunch setupCallerCap, doIPCTransfer, possibleSwitchTo + for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" + (wp: crunch_wps simp: zipWithM_x_mapM) + +lemma setThreadState_not_rct[wp]: + "\\s. ksSchedulerAction s \ ResumeCurrentThread \ + setThreadState st t + \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" + unfolding setThreadState_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imps) + +lemma cancelAllIPC_not_rct[wp]: + "\\s. ksSchedulerAction s \ ResumeCurrentThread \ + cancelAllIPC epptr + \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" + apply (simp add: cancelAllIPC_def) + apply (wp | wpc)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wp)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ + done + +lemma cancelAllSignals_not_rct[wp]: + "\\s. ksSchedulerAction s \ ResumeCurrentThread \ + cancelAllSignals epptr + \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" + apply (simp add: cancelAllSignals_def) + apply (wp | wpc)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ + done + +crunch finaliseCapTrue_standin + for not_rct[wp]: "\s. ksSchedulerAction s \ ResumeCurrentThread" + (simp: Let_def) + +lemma cancelIPC_ResumeCurrentThread_imp_notct[wp]: + "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ + cancelIPC t + \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" + (is "\?PRE t'\ _ \_\") +proof - + have aipc: "\t t' ntfn. + \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ + cancelSignal t ntfn + \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" + apply (simp add: cancelSignal_def) + apply (wp)[1] + apply (wp hoare_convert_imp)+ + apply (rule_tac P="\s. ksSchedulerAction s \ ResumeCurrentThread" + in hoare_weaken_pre) + apply (wpc) + apply (wp | simp)+ + apply (wpc, wp+) + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply (wp) + apply simp + done + have cdo: "\t t' slot. + \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ + cteDeleteOne slot + \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" + apply (simp add: cteDeleteOne_def unless_def split_def) + apply (wp) + apply (wp hoare_convert_imp)[1] + apply (wp) + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply (wp hoare_convert_imp | simp)+ + done + show ?thesis + apply (simp add: cancelIPC_def Let_def) + apply (wp, wpc) + prefer 4 \ \state = Running\ + apply wp + prefer 7 \ \state = Restart\ + apply wp + apply (wp)+ + apply (wp hoare_convert_imp)[1] + apply (wpc, wp+) + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply (wp cdo)+ + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply ((wp aipc hoare_convert_imp)+)[6] + apply (wp) + apply (wp hoare_convert_imp)[1] + apply (wpc, wp+) + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply (wp) + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply (wp) + apply simp + done +qed + +lemma sai_invs'[wp]: + "\invs' and ex_nonz_cap_to' ntfnptr\ + sendSignal ntfnptr badge \\y. invs'\" + unfolding sendSignal_def + apply (rule bind_wp[OF _ get_ntfn_sp']) + apply (case_tac "ntfnObj nTFN", simp_all) + prefer 3 + apply (rename_tac list) + apply (case_tac list, + simp_all split del: if_split + add: setMessageInfo_def)[1] + apply (wp hoare_convert_imp [OF asUser_nosch] + hoare_convert_imp [OF setMRs_sch_act])+ + apply (clarsimp simp:conj_comms) + apply (simp add: invs'_def valid_state'_def) + apply (wp valid_irq_node_lift sts_valid_objs' setThreadState_ct_not_inQ + set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' valid_dom_schedule'_lift + hoare_convert_imp [OF setNotification_nosch] + | simp split del: if_split)+ + + apply (intro conjI[rotated]; + (solves \clarsimp simp: invs'_def valid_state'_def valid_pspace'_def\)?) + apply (clarsimp simp: invs'_def valid_state'_def split del: if_split) + apply (drule(1) ct_not_in_ntfnQueue, simp+) + apply clarsimp + apply (frule ko_at_valid_objs', clarsimp) + apply simp + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def + split: list.splits) + apply (clarsimp simp: invs'_def valid_state'_def) + apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_idle'_def pred_tcb_at'_def idle_tcb'_def + dest!: sym_refs_ko_atD' sym_refs_st_tcb_atD' sym_refs_obj_atD' + split: list.splits) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + apply (frule(1) ko_at_valid_objs') + apply simp + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def + split: list.splits option.splits) + apply (clarsimp elim!: if_live_then_nonz_capE' simp:invs'_def valid_state'_def) + apply (drule(1) sym_refs_ko_atD') + apply (clarsimp elim!: ko_wp_at'_weakenE + intro!: refs_of_live') + apply (clarsimp split del: if_split)+ + apply (frule ko_at_valid_objs', clarsimp) + apply simp + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) + apply (frule invs_sym') + apply (drule(1) sym_refs_obj_atD') + apply (clarsimp split del: if_split cong: if_cong + simp: st_tcb_at_refs_of_rev' ep_redux_simps' ntfn_bound_refs'_def) + apply (frule st_tcb_at_state_refs_ofD') + apply (erule delta_sym_refs) + apply (fastforce simp: split: if_split_asm) + apply (fastforce simp: tcb_bound_refs'_def set_eq_subset symreftype_inverse' + split: if_split_asm) + apply (clarsimp simp:invs'_def) + apply (frule ko_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def valid_state'_def) + apply simp + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) + apply (clarsimp simp:invs'_def valid_state'_def valid_pspace'_def) + apply (frule(1) ko_at_valid_objs') + apply simp + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def + split: list.splits option.splits) + apply (case_tac "ntfnBoundTCB nTFN", simp_all) + apply (wp set_ntfn_minor_invs') + apply (fastforce simp: valid_ntfn'_def invs'_def valid_state'_def + elim!: obj_at'_weakenE + dest!: global'_no_ex_cap) + apply (wp add: hoare_convert_imp [OF asUser_nosch] + hoare_convert_imp [OF setMRs_sch_act] + setThreadState_nonqueued_state_update sts_st_tcb' + del: cancelIPC_simple) + apply (clarsimp | wp cancelIPC_ct')+ + apply (wp set_ntfn_minor_invs' gts_wp' | clarsimp)+ + apply (frule pred_tcb_at') + by (wp set_ntfn_minor_invs' + | rule conjI + | clarsimp elim!: st_tcb_ex_cap'' + | fastforce simp: receiveBlocked_def pred_tcb_at'_def obj_at'_def + dest!: invs_rct_ct_activatable' + split: thread_state.splits + | fastforce simp: invs'_def valid_state'_def receiveBlocked_def + valid_obj'_def valid_ntfn'_def + split: thread_state.splits + dest!: global'_no_ex_cap st_tcb_ex_cap'' ko_at_valid_objs')+ + +lemma replyFromKernel_corres: + "corres dc (tcb_at t and invs) (invs') + (reply_from_kernel t r) (replyFromKernel t r)" + apply (case_tac r) + apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def + badge_register_def badgeRegister_def) + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF lookupIPCBuffer_corres]) + apply (rule corres_split[OF asUser_setRegister_corres]) + apply (rule corres_split_eqr[OF setMRs_corres]) + apply clarsimp + apply (rule setMessageInfo_corres) + apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' + | clarsimp simp: invs_distinct invs_psp_aligned)+ + apply fastforce + done + +lemma rfk_invs': + "\invs' and tcb_at' t\ replyFromKernel t r \\rv. invs'\" + apply (simp add: replyFromKernel_def) + apply (cases r) + apply (wp | clarsimp)+ + done + +crunch replyFromKernel + for nosch[wp]: "\s. P (ksSchedulerAction s)" + +lemma completeSignal_corres: + "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and valid_objs and pspace_distinct) + (ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' and obj_at' isActive ntfnptr) + (complete_signal ntfnptr tcb) (completeSignal ntfnptr tcb)" + apply (simp add: complete_signal_def completeSignal_def) + apply (rule corres_guard_imp) + apply (rule_tac R'="\ntfn. ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' + and valid_ntfn' ntfn and (\_. isActive ntfn)" + in corres_split[OF getNotification_corres]) + apply (rule corres_gen_asm2) + apply (case_tac "ntfn_obj rv") + apply (clarsimp simp: ntfn_relation_def isActive_def + split: ntfn.splits Structures_H.notification.splits)+ + apply (rule corres_guard2_imp) + apply (simp add: badgeRegister_def badge_register_def) + apply (rule corres_split[OF asUser_setRegister_corres setNotification_corres]) + apply (clarsimp simp: ntfn_relation_def) + apply (wp set_simple_ko_valid_objs get_simple_ko_wp getNotification_wp | clarsimp simp: valid_ntfn'_def)+ + apply (clarsimp simp: valid_pspace'_def) + apply (frule_tac P="(\k. k = ntfn)" in obj_at_valid_objs', assumption) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def obj_at'_def) + done + + +lemma doNBRecvFailedTransfer_corres: + "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ + (do_nbrecv_failed_transfer thread) + (doNBRecvFailedTransfer thread)" + unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def + by (simp add: badgeRegister_def badge_register_def, rule asUser_setRegister_corres) + +lemma receiveIPC_corres: + assumes "is_ep_cap cap" and "cap_relation cap cap'" + shows " + corres dc (einvs and valid_sched and tcb_at thread and valid_cap cap and ex_nonz_cap_to thread + and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3)) + (invs' and tcb_at' thread and valid_cap' cap') + (receive_ipc thread cap isBlocking) (receiveIPC thread cap' isBlocking)" + apply (insert assms) + apply (simp add: receive_ipc_def receiveIPC_def + split del: if_split) + apply (case_tac cap, simp_all add: isEndpointCap_def) + apply (rename_tac word1 word2 right) + apply clarsimp + apply (rule corres_guard_imp) + apply (rule corres_split[OF getEndpoint_corres]) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getBoundNotification_corres]) + apply (rule_tac r'="ntfn_relation" in corres_split) + apply (rule corres_option_split[rotated 2]) + apply (rule getNotification_corres) + apply clarsimp + apply (rule corres_trivial, simp add: ntfn_relation_def default_notification_def + default_ntfn_def) + apply (rule corres_if) + apply (clarsimp simp: ntfn_relation_def Ipc_A.isActive_def Endpoint_H.isActive_def + split: Structures_A.ntfn.splits Structures_H.notification.splits) + apply clarsimp + apply (rule completeSignal_corres) + apply (rule_tac P="einvs and valid_sched and tcb_at thread and + ep_at word1 and valid_ep ep and + obj_at (\k. k = Endpoint ep) word1 + and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3) + and ex_nonz_cap_to thread" and + P'="invs' and tcb_at' thread and ep_at' word1 and + valid_ep' epa" + in corres_inst) + apply (case_tac ep) + \ \IdleEP\ + apply (simp add: ep_relation_def) + apply (rule corres_guard_imp) + apply (case_tac isBlocking; simp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setEndpoint_corres) + apply (simp add: ep_relation_def) + apply wp+ + apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) + apply simp + apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def + valid_tcb_state_def st_tcb_at_tcb_at) + apply auto[1] + \ \SendEP\ + apply (simp add: ep_relation_def) + apply (rename_tac list) + apply (rule_tac F="list \ []" in corres_req) + apply (clarsimp simp: valid_ep_def) + apply (case_tac list, simp_all split del: if_split)[1] + apply (rule corres_guard_imp) + apply (rule corres_split[OF setEndpoint_corres]) + apply (case_tac lista, simp_all add: ep_relation_def)[1] + apply (rule corres_split[OF getThreadState_corres]) + apply (rule_tac + F="\data. + sender_state = + Structures_A.thread_state.BlockedOnSend word1 data" + in corres_gen_asm) + apply (clarsimp simp: isSend_def case_bool_If + case_option_If if3_fold + split del: if_split cong: if_cong) + apply (rule corres_split[OF doIPCTransfer_corres]) + apply (simp split del: if_split cong: if_cong) + apply (fold dc_def)[1] + apply (rule_tac P="valid_objs and valid_mdb and valid_list and valid_arch_state + and valid_sched + and cur_tcb + and valid_reply_caps + and pspace_aligned and pspace_distinct + and st_tcb_at (Not \ awaiting_reply) a + and st_tcb_at (Not \ halted) a + and tcb_at thread and valid_reply_masters + and cte_wp_at (\c. c = cap.NullCap) + (thread, tcb_cnode_index 3)" + and P'="tcb_at' a and tcb_at' thread and cur_tcb' + and valid_pspace' + and valid_objs' + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and sym_heap_sched_pointers and valid_sched_pointers + and pspace_aligned' and pspace_distinct'" + in corres_guard_imp [OF corres_if]) + apply (simp add: fault_rel_optionation_def) + apply (rule corres_if2 [OF _ setupCallerCap_corres setThreadState_corres]) + apply simp + apply simp + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule possibleSwitchTo_corres) + apply (wpsimp wp: sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action)+ + apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb + | simp)+ + apply (fastforce simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def + valid_sched_action_def) + apply (clarsimp split: if_split_asm) + apply (clarsimp | wp do_ipc_transfer_tcb_caps do_ipc_transfer_valid_arch)+ + apply (rule_tac Q'="\_ s. sch_act_wf (ksSchedulerAction s) s + \ sym_heap_sched_pointers s \ valid_sched_pointers s + \ pspace_aligned' s \ pspace_distinct' s" + in hoare_post_imp) + apply (fastforce elim: sch_act_wf_weak) + apply (wp sts_st_tcb' gts_st_tcb_at | simp)+ + apply (simp cong: list.case_cong) + apply wp + apply simp + apply (wp weak_sch_act_wf_lift_linear setEndpoint_valid_mdb' set_ep_valid_objs') + apply (clarsimp split: list.split) + apply (clarsimp simp add: invs_def valid_state_def st_tcb_at_tcb_at) + apply (clarsimp simp add: valid_ep_def valid_pspace_def) + apply (drule(1) sym_refs_obj_atD[where P="\ko. ko = Endpoint e" for e]) + apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) + apply (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split)[1] + \ \RecvEP\ + apply (simp add: ep_relation_def) + apply (rule_tac corres_guard_imp) + apply (case_tac isBlocking; simp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setEndpoint_corres) + apply (simp add: ep_relation_def) + apply wp+ + apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) + apply simp + apply (clarsimp simp: valid_tcb_state_def invs_distinct) + apply (clarsimp simp add: valid_tcb_state'_def) + apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' + hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift + | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ + apply (clarsimp simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def + valid_obj_def valid_tcb_def valid_bound_ntfn_def invs_distinct + dest!: invs_valid_objs + elim!: obj_at_valid_objsE + split: option.splits) + apply clarsimp + apply (auto simp: valid_cap'_def invs_valid_pspace' valid_obj'_def valid_tcb'_def + valid_bound_ntfn'_def obj_at'_def pred_tcb_at'_def + dest!: invs_valid_objs' obj_at_valid_objs' + split: option.splits)[1] + done + +lemma receiveSignal_corres: + "\ is_ntfn_cap cap; cap_relation cap cap' \ \ + corres dc (invs and st_tcb_at active thread and valid_cap cap and ex_nonz_cap_to thread) + (invs' and tcb_at' thread and valid_cap' cap') + (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" + apply (simp add: receive_signal_def receiveSignal_def) + apply (case_tac cap, simp_all add: isEndpointCap_def) + apply (rename_tac word1 word2 rights) + apply (rule corres_guard_imp) + apply (rule_tac R="\rv. invs and tcb_at thread and st_tcb_at active thread and + ntfn_at word1 and ex_nonz_cap_to thread and + valid_ntfn rv and + obj_at (\k. k = Notification rv) word1" and + R'="\rv'. invs' and tcb_at' thread and ntfn_at' word1 and + valid_ntfn' rv'" + in corres_split[OF getNotification_corres]) + apply clarsimp + apply (case_tac "ntfn_obj rv") + \ \IdleNtfn\ + apply (simp add: ntfn_relation_def) + apply (rule corres_guard_imp) + apply (case_tac isBlocking; simp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setNotification_corres) + apply (simp add: ntfn_relation_def) + apply wp+ + apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres; simp) + apply (clarsimp simp: invs_distinct) + apply simp + \ \WaitingNtfn\ + apply (simp add: ntfn_relation_def) + apply (rule corres_guard_imp) + apply (case_tac isBlocking; simp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setNotification_corres) + apply (simp add: ntfn_relation_def) + apply wp+ + apply (rule corres_guard_imp) + apply (rule doNBRecvFailedTransfer_corres; simp) + apply (clarsimp simp: invs_distinct)+ + \ \ActiveNtfn\ + apply (simp add: ntfn_relation_def) + apply (rule corres_guard_imp) + apply (simp add: badgeRegister_def badge_register_def) + apply (rule corres_split[OF asUser_setRegister_corres]) + apply (rule setNotification_corres) + apply (simp add: ntfn_relation_def) + apply wp+ + apply (fastforce simp: invs_def valid_state_def valid_pspace_def + elim!: st_tcb_weakenE) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + apply wp+ + apply (clarsimp simp add: ntfn_at_def2 valid_cap_def st_tcb_at_tcb_at) + apply (clarsimp simp add: valid_cap'_def) + done + +lemma tg_sp': + "\P\ threadGet f p \\t. obj_at' (\t'. f t' = t) p and P\" + including no_pre + apply (simp add: threadGet_def) + apply wp + apply (rule hoare_strengthen_post) + apply (rule getObject_tcb_sp) + apply clarsimp + apply (erule obj_at'_weakenE) + apply simp + done + +declare lookup_cap_valid' [wp] + +lemma sendFaultIPC_corres: + "valid_fault f \ fr f f' \ + corres (fr \ dc) + (einvs and st_tcb_at active thread and ex_nonz_cap_to thread) + (invs' and sch_act_not thread and tcb_at' thread) + (send_fault_ipc thread f) (sendFaultIPC thread f')" + apply (simp add: send_fault_ipc_def sendFaultIPC_def + liftE_bindE Let_def) + apply (rule corres_guard_imp) + apply (rule corres_split[where r'="\fh fh'. fh = to_bl fh'"]) + apply (rule threadGet_corres) + apply (simp add: tcb_relation_def) + apply simp + apply (rule corres_splitEE) + apply (rule corres_cap_fault) + apply (rule lookup_cap_corres, rule refl) + apply (rule_tac P="einvs and st_tcb_at active thread + and valid_cap handler_cap and ex_nonz_cap_to thread" + and P'="invs' and tcb_at' thread and sch_act_not thread + and valid_cap' handlerCap" + in corres_inst) + apply (case_tac handler_cap, + simp_all add: isCap_defs lookup_failure_map_def + case_bool_If If_rearrage + split del: if_split cong: if_cong)[1] + apply (rule corres_guard_imp) + apply (rule corres_if2 [OF refl]) + apply (simp add: dc_def[symmetric]) + apply (rule corres_split[OF threadset_corres sendIPC_corres], simp_all)[1] + apply (simp add: tcb_relation_def fault_rel_optionation_def inQ_def)+ + apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state + thread_set_typ_at ep_at_typ_at ex_nonz_cap_to_pres + thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched + | simp add: tcb_cap_cases_def)+ + apply ((wp threadSet_invs_trivial threadSet_tcb' + | simp add: tcb_cte_cases_def + | wp (once) sch_act_sane_lift)+)[1] + apply (rule corres_trivial, simp add: lookup_failure_map_def) + apply (clarsimp simp: st_tcb_at_tcb_at split: if_split) + apply (clarsimp simp: valid_cap_def invs_distinct) + apply (clarsimp simp: valid_cap'_def inQ_def) + apply auto[1] + apply (clarsimp simp: lookup_failure_map_def) + apply wp+ + apply (fastforce elim: st_tcb_at_tcb_at) + apply fastforce + done + +lemma gets_the_noop_corres: + assumes P: "\s. P s \ f s \ None" + shows "corres dc P P' (gets_the f) (return x)" + apply (clarsimp simp: corres_underlying_def gets_the_def + return_def gets_def bind_def get_def) + apply (clarsimp simp: assert_opt_def return_def dest!: P) + done + +lemma handleDoubleFault_corres: + "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) + \ + (handle_double_fault thread f ft) + (handleDoubleFault thread f' ft')" + apply (rule corres_cross_over_guard[where Q="tcb_at' thread"]) + apply (fastforce intro!: tcb_at_cross) + apply (simp add: handle_double_fault_def handleDoubleFault_def) + apply (rule corres_guard_imp) + apply (subst bind_return [symmetric], + rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule corres_noop2) + apply (simp add: exs_valid_def return_def) + apply (rule hoare_eq_P) + apply wp + apply (rule asUser_inv) + apply (rule getRestartPC_inv) + apply (wp no_fail_getRestartPC)+ + apply (wp|simp)+ + done + +crunch sendFaultIPC + for tcb'[wp]: "tcb_at' t" (wp: crunch_wps) + +crunch receiveIPC + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) + +lemmas receiveIPC_typ_ats[wp] = typ_at_lifts [OF receiveIPC_typ_at'] + +crunch receiveSignal + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) + +lemmas receiveAIPC_typ_ats[wp] = typ_at_lifts [OF receiveSignal_typ_at'] + +crunch setupCallerCap + for aligned'[wp]: "pspace_aligned'" + (wp: crunch_wps) +crunch setupCallerCap + for distinct'[wp]: "pspace_distinct'" + (wp: crunch_wps) +crunch setupCallerCap + for cur_tcb[wp]: "cur_tcb'" + (wp: crunch_wps) + +lemma setupCallerCap_state_refs_of[wp]: + "\\s. P ((state_refs_of' s) (sender := {r \ state_refs_of' s sender. snd r = TCBBound}))\ + setupCallerCap sender rcvr grant + \\rv s. P (state_refs_of' s)\" + apply (simp add: setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def) + apply (wp hoare_drop_imps) + apply (simp add: fun_upd_def cong: if_cong) + done + +lemma setupCallerCap_state_hyp_refs_of[wp]: + "setupCallerCap sender rcvr canGrant \\s. P (state_hyp_refs_of' s)\" + apply (simp add: setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def) + apply (wp hoare_drop_imps) + done + +lemma is_derived_ReplyCap' [simp]: + "\m p g. is_derived' m p (capability.ReplyCap t False g) = + (\c. \ g. c = capability.ReplyCap t True g)" + apply (subst fun_eq_iff) + apply clarsimp + apply (case_tac x, simp_all add: is_derived'_def isCap_simps + badge_derived'_def + vs_cap_ref'_def) + done + +lemma unique_master_reply_cap': + "\c t. isReplyCap c \ capReplyMaster c \ capTCBPtr c = t \ + (\g . c = capability.ReplyCap t True g)" + by (fastforce simp: isCap_simps conj_comms) + +lemma getSlotCap_cte_wp_at: + "\\\ getSlotCap sl \\rv. cte_wp_at' (\c. cteCap c = rv) sl\" + apply (simp add: getSlotCap_def) + apply (wp getCTE_wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +lemma setupCallerCap_vp[wp]: + "\valid_pspace' and tcb_at' sender and tcb_at' rcvr\ + setupCallerCap sender rcvr grant \\rv. valid_pspace'\" + apply (simp add: valid_pspace'_def setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv getSlotCap_def) + apply (wp getCTE_wp) + apply (rule_tac Q'="\_. valid_pspace' and + tcb_at' sender and tcb_at' rcvr" + in hoare_post_imp) + apply (clarsimp simp: valid_cap'_def o_def cte_wp_at_ctes_of isCap_simps + valid_pspace'_def) + apply (frule(1) ctes_of_valid', simp add: valid_cap'_def capAligned_def) + apply clarsimp + apply (wp | simp add: valid_pspace'_def valid_tcb_state'_def)+ + done + +declare haskell_assert_inv[wp del] + +lemma setupCallerCap_iflive[wp]: + "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender and pspace_aligned' and pspace_distinct'\ + setupCallerCap sender rcvr grant + \\rv. if_live_then_nonz_cap'\" + unfolding setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv + by (wp getSlotCap_cte_wp_at + | simp add: unique_master_reply_cap' + | strengthen eq_imp_strg + | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ + +lemma setupCallerCap_ifunsafe[wp]: + "\if_unsafe_then_cap' and valid_objs' and + ex_nonz_cap_to' rcvr and tcb_at' rcvr and pspace_aligned' and pspace_distinct'\ + setupCallerCap sender rcvr grant + \\rv. if_unsafe_then_cap'\" + unfolding setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv + supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) + apply (wp getSlotCap_cte_wp_at + | simp add: unique_master_reply_cap' | strengthen eq_imp_strg + | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ + apply (rule_tac Q'="\rv. valid_objs' and tcb_at' rcvr and ex_nonz_cap_to' rcvr" + in hoare_post_imp) + apply (clarsimp simp: ex_nonz_tcb_cte_caps' tcbCallerSlot_def + objBits_def objBitsKO_def dom_def cte_level_bits_def) + apply (wp sts_valid_objs' | simp)+ + apply (clarsimp simp: valid_tcb_state'_def)+ + done + +lemma setupCallerCap_global_refs'[wp]: + "\valid_global_refs'\ + setupCallerCap sender rcvr grant + \\rv. valid_global_refs'\" + unfolding setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv + by (wp + | simp add: o_def unique_master_reply_cap' + | strengthen eq_imp_strg + | wp (once) getCTE_wp + | wp (once) hoare_vcg_imp_lift' hoare_vcg_ex_lift | clarsimp simp: cte_wp_at_ctes_of)+ + +crunch setupCallerCap + for valid_arch'[wp]: "valid_arch_state'" + (wp: hoare_drop_imps) + +crunch setupCallerCap + for irq_node'[wp]: "\s. P (irq_node' s)" + (wp: hoare_drop_imps) + +lemma setupCallerCap_irq_handlers'[wp]: + "\valid_irq_handlers'\ + setupCallerCap sender rcvr grant + \\rv. valid_irq_handlers'\" + unfolding setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv + by (wp hoare_drop_imps | simp)+ + +lemma cteInsert_cap_to': + "\ex_nonz_cap_to' p and cte_wp_at' (\c. cteCap c = NullCap) dest\ + cteInsert cap src dest + \\rv. ex_nonz_cap_to' p\" + supply if_cong[cong] + apply (simp add: cteInsert_def ex_nonz_cap_to'_def updateCap_def setUntypedCapAsFull_def) + apply (wpsimp wp: updateMDB_weak_cte_wp_at setCTE_weak_cte_wp_at hoare_vcg_ex_lift + | rule hoare_drop_imps + | wp getCTE_wp)+ (* getCTE_wp is separate to apply it only to the last one *) + apply (rule_tac x=cref in exI) + apply (fastforce simp: cte_wp_at_ctes_of) + done + +crunch setExtraBadge + for cap_to'[wp]: "ex_nonz_cap_to' p" + +crunch doIPCTransfer + for cap_to'[wp]: "ex_nonz_cap_to' p" + (ignore: transferCapsToSlots + wp: crunch_wps transferCapsToSlots_pres2 cteInsert_cap_to' hoare_vcg_const_Ball_lift + simp: zipWithM_x_mapM ball_conj_distrib) + +lemma st_tcb_idle': + "\valid_idle' s; st_tcb_at' P t s\ \ + (t = ksIdleThread s) \ P IdleThreadState" + by (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) + +crunch getThreadCallerSlot + for idle'[wp]: "valid_idle'" +crunch getThreadReplySlot + for idle'[wp]: "valid_idle'" + +crunch setupCallerCap + for it[wp]: "\s. P (ksIdleThread s)" + (simp: updateObject_cte_inv wp: crunch_wps) + +lemma setupCallerCap_idle'[wp]: + "\valid_idle' and valid_pspace' and + (\s. st \ ksIdleThread s \ rt \ ksIdleThread s)\ + setupCallerCap st rt gr + \\_. valid_idle'\" + by (simp add: setupCallerCap_def capRange_def | wp hoare_drop_imps)+ + +crunch setExtraBadge + for it[wp]: "\s. P (ksIdleThread s)" +crunch receiveIPC + for it[wp]: "\s. P (ksIdleThread s)" + (ignore: transferCapsToSlots + wp: transferCapsToSlots_pres2 crunch_wps hoare_vcg_const_Ball_lift + simp: crunch_simps ball_conj_distrib) + +crunch setupCallerCap + for irq_states'[wp]: valid_irq_states' + (wp: crunch_wps) + +crunch receiveIPC + for irqs_masked'[wp]: "irqs_masked'" + (wp: crunch_wps rule: irqs_masked_lift) + +crunch getThreadCallerSlot + for ct_not_inQ[wp]: "ct_not_inQ" +crunch getThreadReplySlot + for ct_not_inQ[wp]: "ct_not_inQ" + +lemma setupCallerCap_ct_not_inQ[wp]: + "\ct_not_inQ\ setupCallerCap sender receiver grant \\_. ct_not_inQ\" + apply (simp add: setupCallerCap_def) + apply (wp hoare_drop_imp setThreadState_ct_not_inQ) + done + +crunch copyMRs + for ksQ'[wp]: "\s. P (ksReadyQueues s)" + (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) + +crunch doIPCTransfer + for ksQ[wp]: "\s. P (ksReadyQueues s)" + (wp: hoare_drop_imps hoare_vcg_split_case_option + mapM_wp' + simp: split_def zipWithM_x_mapM) + +crunch doIPCTransfer + for ct'[wp]: "\s. P (ksCurThread s)" + (wp: hoare_drop_imps hoare_vcg_split_case_option + mapM_wp' + simp: split_def zipWithM_x_mapM) + +lemma asUser_ct_not_inQ[wp]: + "\ct_not_inQ\ asUser t m \\rv. ct_not_inQ\" + apply (simp add: asUser_def split_def) + apply (wp hoare_drop_imps threadSet_not_inQ | simp)+ + done + +crunch copyMRs + for ct_not_inQ[wp]: "ct_not_inQ" + (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) + +crunch doIPCTransfer + for ct_not_inQ[wp]: "ct_not_inQ" + (ignore: transferCapsToSlots + wp: hoare_drop_imps hoare_vcg_split_case_option + mapM_wp' + simp: split_def zipWithM_x_mapM) + +lemma ntfn_q_refs_no_bound_refs': "rf : ntfn_q_refs_of' (ntfnObj ob) \ rf \ ntfn_bound_refs' (ntfnBoundTCB ob')" + by (auto simp add: ntfn_q_refs_of'_def ntfn_bound_refs'_def + split: Structures_H.ntfn.splits) + +lemma completeSignal_invs: + "\invs' and tcb_at' tcb\ + completeSignal ntfnptr tcb + \\_. invs'\" + apply (simp add: completeSignal_def) + apply (rule bind_wp[OF _ get_ntfn_sp']) + apply (rule hoare_pre) + apply (wp set_ntfn_minor_invs' | wpc | simp)+ + apply (rule_tac Q'="\_ s. (state_refs_of' s ntfnptr = ntfn_bound_refs' (ntfnBoundTCB ntfn)) + \ ntfn_at' ntfnptr s + \ valid_ntfn' (ntfnObj_update (\_. Structures_H.ntfn.IdleNtfn) ntfn) s + \ ((\y. ntfnBoundTCB ntfn = Some y) \ ex_nonz_cap_to' ntfnptr s) + \ ntfnptr \ ksIdleThread s" + in hoare_strengthen_post) + apply ((wp hoare_vcg_ex_lift hoare_weak_lift_imp | wpc | simp add: valid_ntfn'_def)+)[1] + apply (clarsimp simp: obj_at'_def state_refs_of'_def typ_at'_def ko_wp_at'_def live'_def + split: option.splits) + apply (blast dest: ntfn_q_refs_no_bound_refs') + apply wp + apply (subgoal_tac "valid_ntfn' ntfn s") + apply (subgoal_tac "ntfnptr \ ksIdleThread s") + apply (fastforce simp: valid_ntfn'_def valid_bound_tcb'_def ko_at_state_refs_ofD' live'_def + elim: obj_at'_weakenE + if_live_then_nonz_capD'[OF invs_iflive' + obj_at'_real_def[THEN meta_eq_to_obj_eq, + THEN iffD1]]) + apply (fastforce simp: valid_idle'_def pred_tcb_at'_def obj_at'_def dest!: invs_valid_idle') + apply (fastforce dest: invs_valid_objs' ko_at_valid_objs' simp: valid_obj'_def) + done + +lemma setupCallerCap_urz[wp]: + "\untyped_ranges_zero' and valid_pspace' and tcb_at' sender\ + setupCallerCap sender t g \\rv. untyped_ranges_zero'\" + apply (simp add: setupCallerCap_def getSlotCap_def + getThreadCallerSlot_def getThreadReplySlot_def + locateSlot_conv) + apply (wp getCTE_wp') + apply (rule_tac Q'="\_. untyped_ranges_zero' and valid_mdb' and valid_objs'" in hoare_post_imp) + apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def untyped_derived_eq_def + isCap_simps) + apply (wp sts_valid_pspace_hangers) + apply (clarsimp simp: valid_tcb_state'_def) + done + +lemmas threadSet_urz = untyped_ranges_zero_lift[where f="cteCaps_of", OF _ threadSet_cteCaps_of] + +crunch doIPCTransfer + for urz[wp]: "untyped_ranges_zero'" + (ignore: threadSet wp: threadSet_urz crunch_wps simp: zipWithM_x_mapM) + +crunch receiveIPC + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: crunch_wps transferCapsToSlots_pres1 simp: zipWithM_x_mapM ignore: constOnFailure) + +crunch possibleSwitchTo + for ctes_of[wp]: "\s. P (ctes_of s)" + (wp: crunch_wps ignore: constOnFailure) + +lemmas possibleSwitchToTo_cteCaps_of[wp] + = cteCaps_of_ctes_of_lift[OF possibleSwitchTo_ctes_of] + +crunch possibleSwitchTo + for ksArch[wp]: "\s. P (ksArchState s)" + (wp: possibleSwitchTo_ctes_of crunch_wps ignore: constOnFailure) + +crunch asUser + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift wp: crunch_wps) + +crunch setupCallerCap, possibleSwitchTo, doIPCTransfer + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) + +(* t = ksCurThread s *) +lemma ri_invs' [wp]: + "\invs' and sch_act_not t + and ct_in_state' simple' + and st_tcb_at' simple' t + and ex_nonz_cap_to' t + and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ + receiveIPC t cap isBlocking + \\_. invs'\" (is "\?pre\ _ \_\") + apply (clarsimp simp: receiveIPC_def) + apply (rule bind_wp [OF _ get_ep_sp']) + apply (rule bind_wp [OF _ gbn_sp']) + apply (rule bind_wp) + (* set up precondition for old proof *) + apply (rule_tac P''="ko_at' ep (capEPPtr cap) and ?pre" in hoare_vcg_if_split) + apply (wp completeSignal_invs) + apply (case_tac ep) + \ \endpoint = RecvEP\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) + apply (simp add: valid_ep'_def) + apply (wp sts_sch_act' hoare_vcg_const_Ball_lift valid_irq_node_lift valid_dom_schedule'_lift + setThreadState_ct_not_inQ + asUser_urz + | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ + apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' o_def) + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (frule obj_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def) + apply (drule(1) sym_refs_ko_atD') + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_ep'_def + valid_obj'_def tcb_bound_refs'_def + dest!: isCapDs) + apply (rule conjI, clarsimp) + apply (drule (1) bspec) + apply (clarsimp dest!: st_tcb_at_state_refs_ofD') + apply (clarsimp simp: set_eq_subset) + apply (rule conjI, erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply ((case_tac tp; fastforce elim: nonempty_cross_distinct_singleton_elim)+)[2] + apply (clarsimp split: if_split_asm) + apply (fastforce simp: valid_pspace'_def global'_no_ex_cap idle'_not_queued) + \ \endpoint = IdleEP\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) + apply (simp add: valid_ep'_def) + apply (wp sts_sch_act' valid_irq_node_lift valid_dom_schedule'_lift + setThreadState_ct_not_inQ + asUser_urz + | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ + apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def o_def) + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (subgoal_tac "t \ capEPPtr cap") + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule ko_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (clarsimp dest!: isCapDs) + apply (rule conjI, erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (clarsimp simp: tcb_bound_refs'_def + dest: symreftype_inverse' + split: if_split_asm) + apply (fastforce simp: global'_no_ex_cap) + apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) + \ \endpoint = SendEP\ + apply (simp add: invs'_def valid_state'_def) + apply (rename_tac list) + apply (case_tac list, simp_all split del: if_split) + apply (rename_tac sender queue) + apply (rule hoare_pre) + apply (wp valid_irq_node_lift hoare_drop_imps setEndpoint_valid_mdb' + set_ep_valid_objs' sts_st_tcb' sts_sch_act' valid_dom_schedule'_lift + setThreadState_ct_not_inQ + possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift + setEndpoint_ksQ + | simp add: valid_tcb_state'_def case_bool_If + case_option_If + split del: if_split cong: if_cong + | wp (once) sch_act_sane_lift hoare_vcg_conj_lift hoare_vcg_all_lift + untyped_ranges_zero_lift)+ + apply (clarsimp split del: if_split simp: pred_tcb_at') + apply (frule obj_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def) + apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) + apply (drule(1) sym_refs_ko_atD') + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (clarsimp simp: valid_obj'_def valid_ep'_def st_tcb_at_refs_of_rev' conj_ac + split del: if_split + cong: if_cong) + apply (subgoal_tac "sch_act_not sender s") + prefer 2 + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (drule st_tcb_at_state_refs_ofD') + apply (simp only: conj_ac(1, 2)[where Q="sym_refs R" for R]) + apply (subgoal_tac "distinct (ksIdleThread s # capEPPtr cap # t # sender # queue)") + apply (rule conjI) + apply (clarsimp simp: ep_redux_simps' cong: if_cong) + apply (erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (fastforce simp: tcb_bound_refs'_def + dest: symreftype_inverse' + split: if_split_asm) + apply (clarsimp simp: singleton_tuple_cartesian split: list.split + | rule conjI | drule(1) bspec + | drule st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' + | clarsimp elim!: if_live_state_refsE)+ + apply (case_tac cap, simp_all add: isEndpointCap_def) + apply (clarsimp simp: global'_no_ex_cap) + apply (rule conjI + | clarsimp simp: singleton_tuple_cartesian split: list.split + | clarsimp elim!: if_live_state_refsE + | clarsimp simp: global'_no_ex_cap idle'_not_queued' idle'_no_refs tcb_bound_refs'_def + | drule(1) bspec | drule st_tcb_at_state_refs_ofD' + | clarsimp simp: set_eq_subset dest!: bound_tcb_at_state_refs_ofD' )+ + apply (rule hoare_pre) + apply (wp getNotification_wp | wpc | clarsimp)+ + done + +(* t = ksCurThread s *) +lemma rai_invs'[wp]: + "\invs' and sch_act_not t + and st_tcb_at' simple' t + and ex_nonz_cap_to' t + and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) + and (\s. \ntfnptr. isNotificationCap cap + \ capNtfnPtr cap = ntfnptr + \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) + ntfnptr s)\ + receiveSignal t cap isBlocking + \\_. invs'\" + apply (simp add: receiveSignal_def) + apply (rule bind_wp [OF _ get_ntfn_sp']) + apply (rename_tac ep) + apply (case_tac "ntfnObj ep") + \ \ep = IdleNtfn\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts valid_dom_schedule'_lift + setThreadState_ct_not_inQ + asUser_urz + | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ + apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (subgoal_tac "capNtfnPtr cap \ t") + apply (frule valid_pspace_valid_objs') + apply (frule (1) ko_at_valid_objs') + apply clarsimp + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) + apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) + apply (drule simple_st_tcb_at_state_refs_ofD' + ko_at_state_refs_ofD' bound_tcb_at_state_refs_ofD')+ + apply (clarsimp dest!: isCapDs) + apply (rule conjI, erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' + split: if_split_asm) + apply (fastforce dest!: global'_no_ex_cap) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + \ \ep = ActiveNtfn\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp valid_irq_node_lift sts_valid_objs' typ_at_lifts hoare_weak_lift_imp + asUser_urz valid_dom_schedule'_lift + | simp add: valid_ntfn'_def)+ + apply (clarsimp simp: pred_tcb_at' valid_pspace'_def) + apply (frule (1) ko_at_valid_objs') + apply clarsimp + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def isCap_simps) + apply (drule simple_st_tcb_at_state_refs_ofD' + ko_at_state_refs_ofD')+ + apply (erule delta_sym_refs) + apply (clarsimp split: if_split_asm simp: global'_no_ex_cap)+ + \ \ep = WaitingNtfn\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' + setThreadState_ct_not_inQ typ_at_lifts valid_dom_schedule'_lift + asUser_urz + | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ + apply (clarsimp simp: valid_tcb_state'_def) + apply (frule_tac t=t in not_in_ntfnQueue) + apply (simp) + apply (simp) + apply (erule pred_tcb'_weakenE, clarsimp) + apply (frule ko_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def) + apply simp + apply (clarsimp simp: valid_obj'_def) + apply (clarsimp simp: valid_ntfn'_def pred_tcb_at') + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) + apply (drule(1) sym_refs_ko_atD') + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (clarsimp simp: st_tcb_at_refs_of_rev' + dest!: isCapDs) + apply (rule conjI, erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (rename_tac list one two three four five six seven eight nine) + apply (subgoal_tac "set list \ {NTFNSignal} \ {}") + apply safe[1] + apply (auto simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def)[5] + apply (fastforce simp: tcb_bound_refs'_def + split: if_split_asm) + apply (fastforce dest!: global'_no_ex_cap) + done + +lemma getCTE_cap_to_refs[wp]: + "\\\ getCTE p \\rv s. \r\zobj_refs' (cteCap rv). ex_nonz_cap_to' r s\" + apply (rule hoare_strengthen_post [OF getCTE_sp]) + apply (clarsimp simp: ex_nonz_cap_to'_def) + apply (fastforce elim: cte_wp_at_weakenE') + done + +lemma lookupCap_cap_to_refs[wp]: + "\\\ lookupCap t cref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" + apply (simp add: lookupCap_def lookupCapAndSlot_def split_def + getSlotCap_def) + apply (wp | simp)+ + done + +crunch setVMRoot + for valid_objs'[wp]: valid_objs' + (wp: getASID_wp crunch_wps findVSpaceForASID_vs_at_wp + simp: getPoolPtr_def getThreadVSpaceRoot_def if_distribR) + +lemma arch_stt_objs' [wp]: + "\valid_objs'\ Arch.switchToThread t \\rv. valid_objs'\" + apply (simp add: AARCH64_H.switchToThread_def) + apply wp + done + +lemma possibleSwitchTo_sch_act_not: + "\sch_act_not t' and K (t \ t')\ possibleSwitchTo t \\rv. sch_act_not t'\" + apply (simp add: possibleSwitchTo_def setSchedulerAction_def curDomain_def) + apply (wp hoare_drop_imps | wpc | simp)+ + done + +crunch possibleSwitchTo + for urz[wp]: "untyped_ranges_zero'" + (simp: crunch_simps unless_def wp: crunch_wps) + +declare zipWithM_x_mapM[simp] (* FIXME AARCH64: remove? *) + +crunch possibleSwitchTo + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + +lemma si_invs'[wp]: + "\invs' and st_tcb_at' simple' t + and sch_act_not t + and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ + sendIPC bl call ba cg cgr t ep + \\rv. invs'\" + supply if_split[split del] + supply if_cong[cong] + apply (simp add: sendIPC_def) + apply (rule bind_wp [OF _ get_ep_sp']) + apply (case_tac epa) + \ \epa = RecvEP\ + apply simp + apply (rename_tac list) + apply (case_tac list) + apply simp + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (rule_tac P="a\t" in hoare_gen_asm) + apply (wp valid_irq_node_lift + sts_valid_objs' set_ep_valid_objs' setEndpoint_valid_mdb' sts_st_tcb' sts_sch_act' + possibleSwitchTo_sch_act_not setThreadState_ct_not_inQ valid_dom_schedule'_lift + possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift + hoare_convert_imp [OF doIPCTransfer_sch_act doIPCTransfer_ct'] + hoare_convert_imp [OF setEndpoint_nosch setEndpoint_ksCurThread] + hoare_drop_imp [where f="threadGet tcbFault t"] + | rule_tac f="getThreadState a" in hoare_drop_imp + | wp (once) hoare_drop_imp[where Q'="\_ _. call"] + hoare_drop_imp[where Q'="\_ _. \ call"] + hoare_drop_imp[where Q'="\_ _. cg"] + | simp add: valid_tcb_state'_def case_bool_If + case_option_If + cong: if_cong + | wp (once) sch_act_sane_lift tcb_in_cur_domain'_lift hoare_vcg_const_imp_lift)+ + apply (clarsimp simp: pred_tcb_at' cong: conj_cong imp_cong) + apply (frule obj_at_valid_objs', clarsimp) + apply (frule(1) sym_refs_ko_atD') + apply (clarsimp simp: valid_obj'_def valid_ep'_def + st_tcb_at_refs_of_rev' pred_tcb_at' + conj_comms fun_upd_def[symmetric]) + apply (frule pred_tcb_at') + apply (drule simple_st_tcb_at_state_refs_ofD' st_tcb_at_state_refs_ofD')+ + apply (clarsimp simp: valid_pspace'_splits) + apply (subst fun_upd_idem[where x=t]) + apply (clarsimp split: if_split) + apply (rule conjI, clarsimp simp: obj_at'_def) + apply (drule bound_tcb_at_state_refs_ofD') + apply (fastforce simp: tcb_bound_refs'_def) + apply (subgoal_tac "ex_nonz_cap_to' a s") + prefer 2 + apply (clarsimp elim!: if_live_state_refsE) + apply clarsimp + apply (rule conjI) + apply (drule bound_tcb_at_state_refs_ofD') + apply (fastforce simp: tcb_bound_refs'_def set_eq_subset) + apply (clarsimp simp: conj_ac) + apply (rule conjI, clarsimp simp: idle'_no_refs) + apply (rule conjI, clarsimp simp: global'_no_ex_cap) + apply (rule conjI) + apply (rule impI) + apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) + apply (clarsimp) + apply (simp add: ep_redux_simps') + apply (rule conjI, clarsimp split: if_split) + apply (rule conjI, fastforce simp: tcb_bound_refs'_def set_eq_subset) + apply (clarsimp, erule delta_sym_refs; + solves\auto simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm\) + apply (solves\clarsimp split: list.splits\) + \ \epa = IdleEP\ + apply (cases bl) + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) + apply (simp add: valid_ep'_def) + apply (wp valid_irq_node_lift valid_dom_schedule'_lift sts_sch_act' setThreadState_ct_not_inQ) + apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (subgoal_tac "ep \ t") + apply (drule simple_st_tcb_at_state_refs_ofD' ko_at_state_refs_ofD' + bound_tcb_at_state_refs_ofD')+ + apply (rule conjI, erule delta_sym_refs) + apply (auto simp: tcb_bound_refs'_def symreftype_inverse' + split: if_split_asm)[2] + apply (fastforce simp: global'_no_ex_cap) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply simp + apply wp + apply simp + \ \epa = SendEP\ + apply (cases bl) + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) + apply (simp add: valid_ep'_def) + apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ + valid_dom_schedule'_lift) + apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (frule obj_at_valid_objs', clarsimp) + apply (frule(1) sym_refs_ko_atD') + apply (frule pred_tcb_at') + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (clarsimp simp: valid_obj'_def valid_ep'_def st_tcb_at_refs_of_rev') + apply (rule conjI, clarsimp) + apply (drule (1) bspec) + apply (clarsimp dest!: st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' + simp: tcb_bound_refs'_def) + apply (clarsimp simp: set_eq_subset) + apply (rule conjI, erule delta_sym_refs) + subgoal by (fastforce simp: obj_at'_def symreftype_inverse' + split: if_split_asm) + apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' + split: if_split_asm) + apply (fastforce simp: global'_no_ex_cap idle'_not_queued) + apply (simp | wp)+ + done + +lemma sfi_invs_plus': + "\invs' and st_tcb_at' simple' t + and sch_act_not t + and ex_nonz_cap_to' t\ + sendFaultIPC t f + \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" + apply (simp add: sendFaultIPC_def) + apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state + threadSet_cap_to' + | wpc | simp)+ + apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s + \ st_tcb_at' simple' t s + \ ex_nonz_cap_to' t s + \ t \ ksIdleThread s + \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" + in hoare_strengthen_postE_R) + apply wp + apply (clarsimp simp: inQ_def pred_tcb_at') + apply (wp | simp)+ + apply (clarsimp simp: eq_commute) + apply (subst(asm) global'_no_ex_cap, auto) + done + +crunch send_fault_ipc + for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" + and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" + (simp: crunch_simps wp: crunch_wps) + +lemma handleFault_corres: + "fr f f' \ + corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread + and (\_. valid_fault f)) + (invs' and sch_act_not thread + and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) + (handle_fault thread f) (handleFault thread f')" + apply (simp add: handle_fault_def handleFault_def) + apply (rule corres_guard_imp) + apply (subst return_bind [symmetric], + rule corres_split[where P="tcb_at thread", + OF gets_the_noop_corres [where x="()"]]) + apply (simp add: tcb_at_def) + apply (rule corres_split_catch) + apply (rule_tac F="valid_fault f" in corres_gen_asm) + apply (rule sendFaultIPC_corres, assumption) + apply simp + apply (rule handleDoubleFault_corres) + apply wpsimp+ + apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def valid_state_def valid_idle_def) + apply auto + done + +lemma sts_invs_minor'': + "\st_tcb_at' (\st'. tcb_st_refs_of' st' = tcb_st_refs_of' st + \ (st \ Inactive \ \ idle' st \ + st' \ Inactive \ \ idle' st')) t + and (\s. t = ksIdleThread s \ idle' st) + and (\s. \ runnable' st \ sch_act_not t s) + and invs'\ + setThreadState st t + \\rv. invs'\" + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ valid_dom_schedule'_lift) + apply clarsimp + apply (rule conjI) + apply fastforce + apply (rule conjI) + apply (clarsimp simp: pred_tcb_at'_def) + apply (drule obj_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def) + apply (clarsimp simp: valid_obj'_def valid_tcb'_def) + subgoal by (cases st, auto simp: valid_tcb_state'_def + split: Structures_H.thread_state.splits)[1] + apply (rule conjI) + apply (clarsimp dest!: st_tcb_at_state_refs_ofD' + elim!: rsubst[where P=sym_refs] + intro!: ext) + apply (fastforce elim!: st_tcb_ex_cap'') + done + +lemma hf_invs' [wp]: + "\invs' and sch_act_not t + and st_tcb_at' simple' t + and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ + handleFault t f \\r. invs'\" + apply (simp add: handleFault_def) + apply wp + apply (simp add: handleDoubleFault_def) + apply (wp sts_invs_minor'' dmo_invs')+ + apply (rule hoare_strengthen_postE, rule sfi_invs_plus', + simp_all) + apply (strengthen no_refs_simple_strg') + apply clarsimp + done + +declare zipWithM_x_mapM [simp del] + +lemma gts_st_tcb': + "\\\ getThreadState t \\r. st_tcb_at' (\st. st = r) t\" + apply (rule hoare_strengthen_post) + apply (rule gts_sp') + apply simp + done + +lemma setupCallerCap_pred_tcb_unchanged: + "\pred_tcb_at' proj P t and K (t \ t')\ + setupCallerCap t' t'' g + \\rv. pred_tcb_at' proj P t\" + apply (simp add: setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def) + apply (wp sts_pred_tcb_neq' hoare_drop_imps) + apply clarsimp + done + +lemma si_blk_makes_simple': + "\st_tcb_at' simple' t and K (t \ t')\ + sendIPC True call bdg x x' t' ep + \\rv. st_tcb_at' simple' t\" + apply (simp add: sendIPC_def) + apply (rule bind_wp [OF _ get_ep_inv']) + apply (case_tac rv, simp_all) + apply (rename_tac list) + apply (case_tac list, simp_all add: case_bool_If case_option_If + split del: if_split cong: if_cong) + apply (rule hoare_pre) + apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged + hoare_drop_imps) + apply (clarsimp simp: pred_tcb_at' del: disjCI) + apply (wp sts_st_tcb_at'_cases) + apply clarsimp + apply (wp sts_st_tcb_at'_cases) + apply clarsimp + done + +lemma si_blk_makes_runnable': + "\st_tcb_at' runnable' t and K (t \ t')\ + sendIPC True call bdg x x' t' ep + \\rv. st_tcb_at' runnable' t\" + apply (simp add: sendIPC_def) + apply (rule bind_wp [OF _ get_ep_inv']) + apply (case_tac rv, simp_all) + apply (rename_tac list) + apply (case_tac list, simp_all add: case_bool_If case_option_If + split del: if_split cong: if_cong) + apply (rule hoare_pre) + apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged + hoare_vcg_const_imp_lift hoare_drop_imps + | simp)+ + apply (clarsimp del: disjCI simp: pred_tcb_at' elim!: pred_tcb'_weakenE) + apply (wp sts_st_tcb_at'_cases) + apply clarsimp + apply (wp sts_st_tcb_at'_cases) + apply clarsimp + done + +lemma sfi_makes_simple': + "\st_tcb_at' simple' t and K (t \ t')\ + sendFaultIPC t' ft + \\rv. st_tcb_at' simple' t\" + apply (rule hoare_gen_asm) + apply (simp add: sendFaultIPC_def + cong: if_cong capability.case_cong bool.case_cong) + apply (wpsimp wp: si_blk_makes_simple' threadSet_pred_tcb_no_state hoare_drop_imps + hoare_vcg_all_liftE_R) + done + +lemma sfi_makes_runnable': + "\st_tcb_at' runnable' t and K (t \ t')\ + sendFaultIPC t' ft + \\rv. st_tcb_at' runnable' t\" + apply (rule hoare_gen_asm) + apply (simp add: sendFaultIPC_def + cong: if_cong capability.case_cong bool.case_cong) + apply (wpsimp wp: si_blk_makes_runnable' threadSet_pred_tcb_no_state hoare_drop_imps + hoare_vcg_all_liftE_R) + done + +lemma hf_makes_runnable_simple': + "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ + handleFault t ft + \\rv. st_tcb_at' P t'\" + apply (safe intro!: hoare_gen_asm) + apply (simp_all add: handleFault_def handleDoubleFault_def) + apply (wp sfi_makes_runnable' sfi_makes_simple' sts_st_tcb_at'_cases + | simp add: handleDoubleFault_def)+ + done + +crunch possibleSwitchTo, completeSignal + for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" + +lemma ri_makes_runnable_simple': + "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ + receiveIPC t cap isBlocking + \\rv. st_tcb_at' P t'\" + including no_pre + apply (rule hoare_gen_asm)+ + apply (simp add: receiveIPC_def) + apply (case_tac cap, simp_all add: isEndpointCap_def) + apply (rule bind_wp [OF _ get_ep_inv']) + apply (rule bind_wp [OF _ gbn_sp']) + apply wp + apply (rename_tac ep q r) + apply (case_tac ep, simp_all) + apply (wp sts_st_tcb_at'_cases | wpc | simp add: doNBRecvFailedTransfer_def)+ + apply (rename_tac list) + apply (case_tac list, simp_all add: case_bool_If case_option_If + split del: if_split cong: if_cong) + apply (rule hoare_pre) + apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged + hoare_vcg_const_imp_lift)+ + apply (simp, simp only: imp_conv_disj) + apply (wp hoare_vcg_disj_lift)+ + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (fastforce simp: pred_tcb_at'_def obj_at'_def isSend_def + split: Structures_H.thread_state.split_asm) + apply (rule hoare_pre) + apply wpsimp+ + done + +lemma rai_makes_runnable_simple': + "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ + receiveSignal t cap isBlocking + \\rv. st_tcb_at' P t'\" + apply (rule hoare_gen_asm) + apply (simp add: receiveSignal_def) + apply (rule hoare_pre) + by (wp sts_st_tcb_at'_cases getNotification_wp | wpc | simp add: doNBRecvFailedTransfer_def)+ + +lemma sendSignal_st_tcb'_Running: + "\st_tcb_at' (\st. st = Running \ P st) t\ + sendSignal ntfnptr bdg + \\_. st_tcb_at' (\st. st = Running \ P st) t\" + apply (simp add: sendSignal_def) + apply (wp sts_st_tcb_at'_cases cancelIPC_st_tcb_at' gts_wp' getNotification_wp hoare_weak_lift_imp + | wpc | clarsimp simp: pred_tcb_at')+ + done + +lemma sai_st_tcb': + "\st_tcb_at' P t and K (P Running)\ + sendSignal ntfn bdg + \\rv. st_tcb_at' P t\" + apply (rule hoare_gen_asm) + apply (subgoal_tac "\Q. P = (\st. st = Running \ Q st)") + apply (clarsimp intro!: sendSignal_st_tcb'_Running) + apply (fastforce intro!: exI[where x=P]) + done + +end + end From 7faa48cba925f24940e1c32ff302255d41e86f07 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Wed, 13 May 2026 05:56:32 +1000 Subject: [PATCH 4/7] refine: arch-split Ipc_R (AARCH64 ONLY) Signed-off-by: Rafal Kolanski --- proof/refine/AARCH64/ArchCSpace_I.thy | 2 +- proof/refine/AARCH64/ArchCSpace_R.thy | 28 +- proof/refine/AARCH64/ArchIpc_R.thy | 4366 +------------------------ proof/refine/AARCH64/ArchKHeap_R.thy | 5 + proof/refine/AARCH64/ArchTcbAcc_R.thy | 18 +- proof/refine/AARCH64/ArchVSpace_R.thy | 8 - proof/refine/Bits_R.thy | 17 +- proof/refine/CSpace_I.thy | 5 +- proof/refine/CSpace_R.thy | 36 +- proof/refine/Ipc_R.thy | 1233 ++++--- proof/refine/TcbAcc_R.thy | 17 +- 11 files changed, 807 insertions(+), 4928 deletions(-) diff --git a/proof/refine/AARCH64/ArchCSpace_I.thy b/proof/refine/AARCH64/ArchCSpace_I.thy index a93c25a0ae..23b2c3e2da 100644 --- a/proof/refine/AARCH64/ArchCSpace_I.thy +++ b/proof/refine/AARCH64/ArchCSpace_I.thy @@ -273,7 +273,7 @@ lemma capMasterCap_maskCapRights[simp, CSpace_I_2_assms]: apply (case_tac arch_capability; simp add: maskCapRights_def Let_def isCap_simps) done -lemma capBadge_maskCapRights[simp]: +lemma capBadge_maskCapRights[simp, CSpace_I_2_assms]: "capBadge (maskCapRights msk cap) = capBadge cap" apply (cases cap; simp add: global.maskCapRights_def Let_def gen_isCap_simps capBadge_def) apply (rename_tac arch_capability) diff --git a/proof/refine/AARCH64/ArchCSpace_R.thy b/proof/refine/AARCH64/ArchCSpace_R.thy index d6f2396ab8..82b22dbb20 100644 --- a/proof/refine/AARCH64/ArchCSpace_R.thy +++ b/proof/refine/AARCH64/ArchCSpace_R.thy @@ -318,12 +318,12 @@ context Arch begin arch_global_naming named_theorems CSpace_R_2_assms -lemma deriveCap_derived: +lemma deriveCap_derived[CSpace_R_2_assms]: "\\s. c'\ capability.NullCap \ cte_wp_at' (\cte. badge_derived' c' (cteCap cte) - \ capASID c' = capASID (cteCap cte) - \ cap_asid_base' c' = cap_asid_base' (cteCap cte) - \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s\ + \ capASID c' = capASID (cteCap cte) + \ cap_asid_base' c' = cap_asid_base' (cteCap cte) + \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s + \ valid_objs' s\ deriveCap slot c' \\rv s. rv \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot rv \ cteCap) slot s\, -" @@ -348,9 +348,9 @@ lemma deriveCap_derived: | clarsimp split: option.split_asm)+) done -lemma arch_deriveCap_untyped_derived[wp]: +lemma arch_deriveCap_untyped_derived[CSpace_R_2_assms, wp]: "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - AARCH64_H.deriveCap slot (capCap c') + AARCH64_H.deriveCap slot (capCap c') \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" apply (wpsimp simp: AARCH64_H.deriveCap_def Let_def untyped_derived_eq_ArchObjectCap split_del: if_split @@ -358,16 +358,6 @@ lemma arch_deriveCap_untyped_derived[wp]: apply(clarsimp simp: cte_wp_at_ctes_of isCap_simps untyped_derived_eq_def) by (case_tac "capCap c'"; fastforce) -lemma deriveCap_untyped_derived: - "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - deriveCap slot c' - \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" - apply (simp add: global.deriveCap_def split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp arch_deriveCap_inv | simp add: o_def untyped_derived_eq_ArchObjectCap)+ - apply (clarsimp simp: cte_wp_at_ctes_of gen_isCap_simps untyped_derived_eq_def) - done - lemma corres_caps_decomposition: assumes pspace_corres: "corres_underlying {(s, s'). pspace_relation (kheap s) (ksPSpace s')} False True r P P' f g" @@ -639,7 +629,7 @@ crunch setupReplyMaster for valid_arch'[wp]: "valid_arch_state'" (wp: crunch_wps simp: crunch_simps) -lemma ex_nonz_tcb_cte_caps': +lemma ex_nonz_tcb_cte_caps'[CSpace_R_2_assms]: "\ex_nonz_cap_to' t s; tcb_at' t s; valid_objs' s; sl \ dom tcb_cte_cases\ \ ex_cte_cap_to' (t + sl) s" apply (clarsimp simp: ex_nonz_cap_to'_def ex_cte_cap_to'_def cte_wp_at_ctes_of) @@ -1352,7 +1342,7 @@ lemmas [CSpace_R_3_assms] = updateCap_valid_arch_state' master_cap_relation -lemma derived'_not_Null: +lemma derived'_not_Null[CSpace_R_3_assms, simp]: "\ is_derived' m p c capability.NullCap" "\ is_derived' m p capability.NullCap c" by (clarsimp simp: is_derived'_def badge_derived'_def)+ diff --git a/proof/refine/AARCH64/ArchIpc_R.thy b/proof/refine/AARCH64/ArchIpc_R.thy index 74b1d77d59..b25eded24b 100644 --- a/proof/refine/AARCH64/ArchIpc_R.thy +++ b/proof/refine/AARCH64/ArchIpc_R.thy @@ -1,6 +1,6 @@ (* - * Copyright 2023, Proofcraft Pty Ltd * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -9,906 +9,84 @@ theory ArchIpc_R imports Ipc_R begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming -lemmas lookup_slot_wrapper_defs'[simp] = - lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def +named_theorems Ipc_R_assms -lemma getMessageInfo_corres: "corres ((=) \ message_info_map) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (get_message_info t) (getMessageInfo t)" - apply (rule corres_guard_imp) +declare word64_minus_one_le[simp] + +lemma getMessageInfo_corres[Ipc_R_assms]: + "corres ((=) \ message_info_map) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_message_info t) (getMessageInfo t)" apply (unfold get_message_info_def getMessageInfo_def fun_app_def) apply (simp add: AARCH64_H.msgInfoRegister_def - AARCH64.msgInfoRegister_def AARCH64_A.msg_info_register_def) - apply (rule corres_split_eqr[OF asUser_getRegister_corres]) + AARCH64.msgInfoRegister_def AARCH64_A.msg_info_register_def) + apply (corres corres: asUser_getRegister_corres) apply (rule corres_trivial, simp add: message_info_from_data_eqv) - apply (wp | simp)+ - done - - -lemma get_mi_inv'[wp]: "\I\ getMessageInfo a \\x. I\" - by (simp add: getMessageInfo_def, wp) - -definition - "get_send_cap_relation rv rv' \ - (case rv of Some (c, cptr) \ (\c' cptr'. rv' = Some (c', cptr') \ - cte_map cptr = cptr' \ - cap_relation c c') - | None \ rv' = None)" - -lemma cap_relation_mask: - "\ cap_relation c c'; msk' = rights_mask_map msk \ \ - cap_relation (mask_cap msk c) (maskCapRights msk' c')" - by simp - -lemma lsfco_cte_at': - "\valid_objs' and valid_cap' cap\ - lookupSlotForCNodeOp f cap idx depth - \\rv. cte_at' rv\, -" - apply (simp add: lookupSlotForCNodeOp_def) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (wp) - apply (clarsimp simp: split_def unlessE_def - split del: if_split) - apply (wpsimp wp: hoare_drop_imps throwE_R) - done - -declare unifyFailure_wp [wp] - -(* FIXME: move *) -lemma unifyFailure_wp_E [wp]: - "\P\ f -, \\_. E\ \ \P\ unifyFailure f -, \\_. E\" - unfolding validE_E_def - by (erule unifyFailure_wp)+ - -(* FIXME: move *) -lemma unifyFailure_wp2 [wp]: - assumes x: "\P\ f \\_. Q\" - shows "\P\ unifyFailure f \\_. Q\" - by (wp x, simp) - -definition - ct_relation :: "captransfer \ cap_transfer \ bool" -where - "ct_relation ct ct' \ - ct_receive_root ct = to_bl (ctReceiveRoot ct') - \ ct_receive_index ct = to_bl (ctReceiveIndex ct') - \ ctReceiveDepth ct' = unat (ct_receive_depth ct)" - -(* MOVE *) -lemma valid_ipc_buffer_ptr_aligned_word_size_bits: - "\valid_ipc_buffer_ptr' a s; is_aligned y word_size_bits \ \ is_aligned (a + y) word_size_bits" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (erule (1) aligned_add_aligned) - apply (simp add: msg_align_bits word_size_bits_def) - done - -(* MOVE *) -lemma valid_ipc_buffer_ptr'D2: - "\valid_ipc_buffer_ptr' a s; y < max_ipc_words * word_size; is_aligned y word_size_bits\ \ typ_at' UserDataT (a + y && ~~ mask pageBits) s" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (subgoal_tac "(a + y) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (erule order_less_le_trans) - apply (simp add: msg_align_bits max_ipc_words word_size_def) - apply simp - done - -lemma loadCapTransfer_corres: - notes msg_max_words_simps = max_ipc_words_def msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def - capTransferDataSize_def msgExtraCapBits_def - shows - "corres ct_relation \ (valid_ipc_buffer_ptr' buffer) (load_cap_transfer buffer) (loadCapTransfer buffer)" - apply (simp add: load_cap_transfer_def loadCapTransfer_def - captransfer_from_words_def - capTransferDataSize_def capTransferFromWords_def - msgExtraCapBits_def word_size add.commute add.left_commute - msg_max_length_def msg_max_extra_caps_def word_size_def - msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def wordSize_def wordBits_def - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (clarsimp simp: ct_relation_def) - apply (wp no_irq_loadWord)+ - apply simp - apply (simp add: conj_comms) - apply safe - apply (erule valid_ipc_buffer_ptr_aligned_word_size_bits, simp add: is_aligned_def word_size_bits_def)+ - apply (erule valid_ipc_buffer_ptr'D2, - simp add: msg_max_words_simps word_size_def word_size_bits_def, - simp add: word_size_bits_def is_aligned_def)+ - done - -lemma getReceiveSlots_corres: - "corres (\xs ys. ys = map cte_map xs) - (tcb_at receiver and valid_objs and pspace_aligned) - (tcb_at' receiver and valid_objs' and pspace_aligned' and pspace_distinct' and - case_option \ valid_ipc_buffer_ptr' recv_buf) - (get_receive_slots receiver recv_buf) - (getReceiveSlots receiver recv_buf)" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF loadCapTransfer_corres]) - apply (rule corres_empty_on_failure) - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (rule lookup_cap_corres) - apply (simp add: ct_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (simp add: ct_relation_def) - apply (erule lookupSlotForCNodeOp_corres [OF _ refl]) - apply simp - apply (simp add: split_def liftE_bindE unlessE_whenE) - apply (rule corres_split[OF get_cap_corres]) - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap, auto)[1] - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (wp lookup_cap_valid lookup_cap_valid' lsfco_cte_at | simp)+ - done - -lemma get_recv_slot_inv'[wp]: - "\ P \ getReceiveSlots receiver buf \\rv'. P \" - apply (case_tac buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def - split_def unlessE_def) - apply (wp | simp)+ - done - -lemma get_rs_cte_at'[wp]: - "\\\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. cte_wp_at' (\c. cteCap c = capability.NullCap) x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (rule getCTE_wp) - apply (simp add: cte_wp_at_ctes_of cong: conj_cong) - apply wp+ - apply simp - done - -lemma get_rs_real_cte_at'[wp]: - "\valid_objs'\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. real_cte_at' x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (wp hoare_drop_imps)[1] - apply simp - apply (wp lookup_cap_valid')+ - apply simp - done - -declare word_div_1 [simp] -declare word_minus_one_le [simp] -declare word64_minus_one_le [simp] - -lemma loadWordUser_corres': - "\ y < unat max_ipc_words; y' = of_nat y * 8 \ \ - corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + y'))" - apply simp - apply (erule loadWordUser_corres) - done - -declare loadWordUser_inv [wp] - -lemma getExtraCptrs_inv[wp]: - "\P\ getExtraCPtrs buf mi \\rv. P\" - apply (cases mi, cases buf, simp_all add: getExtraCPtrs_def) - apply (wp dmo_inv' mapM_wp' loadWord_inv) - done - -lemma getSlotCap_cte_wp_at_rv: - "\cte_wp_at' (\cte. P (cteCap cte) cte) p\ - getSlotCap p - \\rv. cte_wp_at' (P rv) p\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_ctes_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) + apply wpsimp+ done -lemma badge_derived_mask [simp]: - "badge_derived' (maskCapRights R c) c' = badge_derived' c c'" - by (simp add: badge_derived'_def) - -declare derived'_not_Null [simp] +lemma max_ipc_size_le_2_msg_align_bits[Ipc_R_assms]: + "max_ipc_words * word_size \ 2 ^ msg_align_bits" + by (simp add: max_ipc_words word_size_def msg_align_bits) lemma maskCapRights_vs_cap_ref'[simp]: "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" unfolding vs_cap_ref'_def - apply (cases cap, simp_all add: maskCapRights_def isCap_simps Let_def) + apply (cases cap, simp_all add: global.maskCapRights_def isCap_simps Let_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; - simp add: maskCapRights_def AARCH64_H.maskCapRights_def isCap_simps Let_def) - done - -lemma corres_set_extra_badge: - "b' = b \ - corres dc (in_user_frame buffer) - (valid_ipc_buffer_ptr' buffer and - (\_. msg_max_length + 2 + n < unat max_ipc_words)) - (set_extra_badge buffer b n) (setExtraBadge buffer b' n)" - apply (rule corres_gen_asm2) - apply (drule storeWordUser_corres [where a=buffer and w=b]) - apply (simp add: set_extra_badge_def setExtraBadge_def buffer_cptr_index_def - bufferCPtrOffset_def Let_def) - apply (simp add: word_size word_size_def wordSize_def wordBits_def - bufferCPtrOffset_def buffer_cptr_index_def msgMaxLength_def - msg_max_length_def msgLengthBits_def store_word_offs_def - add.commute add.left_commute) - done - -crunch setExtraBadge - for typ_at': "\s. P (typ_at' T p s)" -lemmas setExtraBadge_typ_ats' [wp] = typ_at_lifts [OF setExtraBadge_typ_at'] -crunch setExtraBadge - for valid_pspace'[wp]: valid_pspace' -crunch setExtraBadge - for cte_wp_at'[wp]: "cte_wp_at' P p" -crunch setExtraBadge - for ipc_buffer'[wp]: "valid_ipc_buffer_ptr' buffer" - -crunch getExtraCPtr - for inv'[wp]: P (wp: dmo_inv' loadWord_inv) - -lemmas unifyFailure_discard2 - = corres_injection[OF id_injection unifyFailure_injection, simplified] - -lemma deriveCap_not_null: - "\\\ deriveCap slot cap \\rv. K (rv \ NullCap \ cap \ NullCap)\,-" - apply (simp add: deriveCap_def split del: if_split) - by (case_tac cap; wpsimp simp: isCap_simps) - -lemma deriveCap_derived_foo: - "\\s. \cap'. (cte_wp_at' (\cte. badge_derived' cap (cteCap cte) - \ capASID cap = capASID (cteCap cte) \ cap_asid_base' cap = cap_asid_base' (cteCap cte) - \ cap_vptr' cap = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s \ cap' \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot cap' \ cteCap) slot s) - \ (cte_wp_at' (untyped_derived_eq cap \ cteCap) slot s - \ cte_wp_at' (untyped_derived_eq cap' \ cteCap) slot s) - \ (s \' cap \ s \' cap') \ (cap' \ NullCap \ cap \ NullCap) \ Q cap' s\ - deriveCap slot cap \Q\,-" - using deriveCap_derived[where slot=slot and c'=cap] deriveCap_valid[where slot=slot and c=cap] - deriveCap_untyped_derived[where slot=slot and c'=cap] deriveCap_not_null[where slot=slot and cap=cap] - apply (clarsimp simp: validE_R_def validE_def valid_def split: sum.split) - apply (frule in_inv_by_hoareD[OF deriveCap_inv]) - apply (clarsimp simp: o_def) - apply (drule spec, erule mp) - apply safe - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) bspec, simp) - done - -lemma valid_mdb_untyped_incD': - "valid_mdb' s \ untyped_inc' (ctes_of s)" - by (simp add: valid_mdb'_def valid_mdb_ctes_def) - -lemma cteInsert_cte_wp_at: - "\\s. cte_wp_at' (\c. is_derived' (ctes_of s) src cap (cteCap c)) src s - \ valid_mdb' s \ valid_objs' s - \ (if p = dest then P cap - else cte_wp_at' (\c. P (maskedAsFull (cteCap c) cap)) p s)\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - apply (simp add: cteInsert_def) - apply (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp hoare_weak_lift_imp - | clarsimp simp: comp_def - | unfold setUntypedCapAsFull_def)+ - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=cte in exI) - apply clarsimp - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=ctea in exI) - apply clarsimp - apply (cases "p=dest") - apply (clarsimp simp: cte_wp_at'_def) - apply (cases "p=src") - apply clarsimp - apply (intro conjI impI) - apply ((clarsimp simp: cte_wp_at'_def maskedAsFull_def split: if_split_asm)+)[2] - apply clarsimp - apply (rule conjI) - apply (clarsimp simp: maskedAsFull_def cte_wp_at_ctes_of split:if_split_asm) - apply (erule disjE) prefer 2 apply simp - apply (clarsimp simp: is_derived'_def isCap_simps) - apply (drule valid_mdb_untyped_incD') - apply (case_tac cte, case_tac cteb, clarsimp) - apply (drule untyped_incD', (simp add: isCap_simps)+) - apply (frule(1) ctes_of_valid'[where p = p]) - apply (clarsimp simp:valid_cap'_def capAligned_def split:if_splits) - apply (drule_tac y ="of_nat fb" in word_plus_mono_right[OF _ is_aligned_no_overflow',rotated]) - apply simp+ - apply (rule word_of_nat_less) - apply simp - apply (simp add:p_assoc_help mask_def) - apply (simp add: max_free_index_def) - apply (clarsimp simp: maskedAsFull_def is_derived'_def badge_derived'_def - isCap_simps capMasterCap_def cte_wp_at_ctes_of - split: if_split_asm capability.splits) - done - -lemma cteInsert_weak_cte_wp_at3: - assumes imp:"\c. P c \ \ isUntypedCap c" - shows " \\s. if p = dest then P cap - else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - by (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp' hoare_weak_lift_imp - | clarsimp simp: comp_def cteInsert_def - | unfold setUntypedCapAsFull_def - | auto simp: cte_wp_at'_def dest!: imp)+ - -lemma maskedAsFull_null_cap[simp]: - "(maskedAsFull x y = capability.NullCap) = (x = capability.NullCap)" - "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" - by (case_tac x, auto simp:maskedAsFull_def isCap_simps) - -lemma maskCapRights_eq_null: - "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = - (xa = capability.NullCap)" - apply (cases xa; simp add: maskCapRights_def isCap_simps) + simp add: AARCH64_H.maskCapRights_def isCap_simps Let_def) + done + +lemma is_derived'_Untyped[Ipc_R_assms]: + "\isUntypedCap cap'\ + \ is_derived' m src cap' cap + = (isUntypedCap cap \ badge_derived' cap' cap \ descendants_of' src m = {})" + by (clarsimp simp add: AARCH64.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma is_derived'_Reply[Ipc_R_assms]: + "\isReplyCap cap'\ + \ is_derived' m src cap' cap + = (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ capReplyMaster cap \ \ capReplyMaster cap')" + by (clarsimp simp add: AARCH64.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma maskCapRights_eq_null[Ipc_R_assms, simp]: + "(RetypeDecls_H.maskCapRights r cap = capability.NullCap) = (cap = capability.NullCap)" + apply (cases cap; simp add: global.maskCapRights_def isCap_simps) apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (simp_all add: AARCH64_H.maskCapRights_def isCap_simps) - done - -lemma cte_refs'_maskedAsFull[simp]: - "cte_refs' (maskedAsFull a b) = cte_refs' a" - apply (rule ext)+ - apply (case_tac a) - apply (clarsimp simp:maskedAsFull_def isCap_simps)+ - done - -lemma set_extra_badge_valid_arch_state[wp]: - "set_extra_badge buffer badge n \ valid_arch_state \" - unfolding set_extra_badge_def - by wp - -lemma transferCapsToSlots_corres: - "\ list_all2 (\(cap, slot) (cap', slot'). cap_relation cap cap' - \ slot' = cte_map slot) caps caps'; - mi' = message_info_map mi \ \ - corres ((=) \ message_info_map) - (\s. valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_mdb s - \ valid_list s \ valid_arch_state s - \ (case ep of Some x \ ep_at x s | _ \ True) - \ (\x \ set slots. cte_wp_at (\cap. cap = cap.NullCap) x s \ - real_cte_at x s) - \ (\(cap, slot) \ set caps. valid_cap cap s \ - cte_wp_at (\cp'. (cap \ cap.NullCap \ cp'\cap \ cp' = masked_as_full cap cap )) slot s ) - \ distinct slots - \ in_user_frame buffer s) - (\s. valid_pspace' s - \ (case ep of Some x \ ep_at' x s | _ \ True) - \ (\x \ set (map cte_map slots). - cte_wp_at' (\cte. cteCap cte = NullCap) x s - \ real_cte_at' x s) - \ distinct (map cte_map slots) - \ valid_ipc_buffer_ptr' buffer s - \ (\(cap, slot) \ set caps'. valid_cap' cap s \ - cte_wp_at' (\cte. cap \ NullCap \ cteCap cte \ cap \ cteCap cte = maskedAsFull cap cap) slot s) - \ 2 + msg_max_length + n + length caps' < unat max_ipc_words) - (transfer_caps_loop ep buffer n caps slots mi) - (transferCapsToSlots ep buffer n caps' - (map cte_map slots) mi')" - (is "\ list_all2 ?P caps caps'; ?v \ \ ?corres") -proof (induct caps caps' arbitrary: slots n mi mi' rule: list_all2_induct) - case Nil - show ?case using Nil.prems by (case_tac mi, simp) -next - case (Cons x xs y ys slots n mi mi') - note if_weak_cong[cong] if_cong [cong del] - assume P: "?P x y" - show ?case using Cons.prems P - apply (clarsimp split del: if_split) - apply (simp add: Let_def split_def word_size liftE_bindE - word_bits_conv[symmetric] split del: if_split) - apply (rule corres_const_on_failure) - apply (simp add: dc_def[symmetric] split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_if3) - apply (case_tac "fst x", auto simp add: isCap_simps)[1] - apply (rule corres_split[OF corres_set_extra_badge]) - apply (clarsimp simp: is_cap_simps) - apply (drule conjunct1) - apply simp - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (case_tac mi, simp) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (subgoal_tac "obj_ref_of (fst x) = capEPPtr (fst y)") - prefer 2 - apply (clarsimp simp: is_cap_simps) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (rule_tac P="slots = []" and Q="slots \ []" in corres_disj_division) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (case_tac mi, simp) - apply (simp add: list_case_If2 split del: if_split) - apply (rule corres_splitEE) - apply (rule unifyFailure_discard2) - apply (case_tac mi, clarsimp) - apply (rule deriveCap_corres) - apply (simp add: remove_rights_def) - apply clarsimp - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap', auto)[1] - apply (rule corres_trivial, simp) - apply (case_tac mi, simp) - apply simp - apply (simp add: liftE_bindE) - apply (rule corres_split_nor) - apply (rule cteInsert_corres, simp_all add: hd_map)[1] - apply (simp add: tl_map) - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_vcg_const_Ball_lift cap_insert_derived_valid_arch_state - cap_insert_weak_cte_wp_at) - apply (wp hoare_vcg_const_Ball_lift | simp add:split_def del: imp_disj1)+ - apply (wp cap_insert_cte_wp_at) - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - cteInsert_valid_pspace - | simp add: split_def)+ - apply (wp cteInsert_weak_cte_wp_at hoare_valid_ipc_buffer_ptr_typ_at')+ - apply (wpsimp wp: hoare_vcg_const_Ball_lift cteInsert_cte_wp_at valid_case_option_post_wp - simp: split_def) - apply (unfold whenE_def) - apply wp+ - apply (clarsimp simp: conj_comms ball_conj_distrib split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ cap.NullCap \ - cte_wp_at (is_derived (cdt s) (a, b) cap') (a, b) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule derive_cap_is_derived) - apply (wp derive_cap_is_derived_foo)+ - apply (simp split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ capability.NullCap \ - cte_wp_at' (\c. is_derived' (ctes_of s) (cte_map (a, b)) cap' (cteCap c)) (cte_map (a, b)) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule hoare_strengthen_postE_R[OF deriveCap_derived]) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (wp deriveCap_derived_foo) - apply (clarsimp simp: cte_wp_at_caps_of_state remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI, (clarsimp split del: if_split)+) - apply (clarsimp simp:conj_comms split del:if_split) - apply (intro conjI allI) - apply (clarsimp split:if_splits) - apply (case_tac "cap = fst x",simp+) - apply (clarsimp simp:masked_as_full_def is_cap_simps cap_master_cap_simps) - apply (clarsimp split del: if_split) - apply (intro conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (drule hd_in_set) - apply (drule(1) bspec) - apply (clarsimp split:if_split_asm) - apply (fastforce simp:neq_Nil_conv) - apply (intro ballI conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (intro impI) - apply (drule(1) bspec[OF _ subsetD[rotated]]) - apply (clarsimp simp:neq_Nil_conv) - apply (clarsimp split:if_splits) - apply clarsimp - apply (intro conjI) - apply (drule(1) bspec,clarsimp)+ - subgoal for \ aa _ _ capa - by (case_tac "capa = aa"; clarsimp split:if_splits simp:masked_as_full_def is_cap_simps) - apply (case_tac "isEndpointCap (fst y) \ capEPPtr (fst y) = the ep \ (\y. ep = Some y)") - apply (clarsimp simp:conj_comms split del:if_split) - apply (split if_split) - apply (rule conjI) - apply clarsimp - apply (clarsimp simp:valid_pspace'_def cte_wp_at_ctes_of split del:if_split) - apply (intro conjI) - apply (case_tac "cteCap cte = fst y",clarsimp simp: badge_derived'_def) - apply (clarsimp simp: maskCapRights_eq_null maskedAsFull_def badge_derived'_def isCap_simps - split: if_split_asm) - apply (clarsimp split del: if_split) - apply (case_tac "fst y = capability.NullCap") - apply (clarsimp simp: neq_Nil_conv split del: if_split)+ - apply (intro allI impI conjI) - apply (clarsimp split:if_splits) - apply (clarsimp simp:image_def)+ - apply (thin_tac "\x\set ys. Q x" for Q) - apply (drule(1) bspec)+ - apply clarsimp+ - apply (drule(1) bspec) - apply (rule conjI) - apply clarsimp+ - apply (case_tac "cteCap cteb = ab") - by (clarsimp simp: isCap_simps maskedAsFull_def split:if_splits)+ -qed - -declare constOnFailure_wp [wp] - -lemma transferCapsToSlots_pres1[crunch_rules]: - assumes x: "\cap src dest. \P\ cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\P\ transferCapsToSlots ep buffer n caps slots mi \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong - split del: if_split) - apply (rule hoare_pre) - apply (wp x eb | assumption | simp split del: if_split | wpc - | wp (once) hoare_drop_imps)+ - done - -lemma cteInsert_cte_cap_to': - "\ex_cte_cap_to' p and cte_wp_at' (\cte. cteCap cte = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_cte_cap_to' p\" - apply (simp add: ex_cte_cap_to'_def) - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (rule_tac x = "cref" in exI) - apply (rule conjI) - apply clarsimp+ - done - -declare maskCapRights_eq_null[simp] - -crunch setExtraBadge - for ex_cte_cap_wp_to'[wp]: "ex_cte_cap_wp_to' P p" - (rule: ex_cte_cap_to'_pres) - -crunch setExtraBadge - for valid_objs'[wp]: valid_objs' -crunch setExtraBadge - for aligned'[wp]: pspace_aligned' -crunch setExtraBadge - for distinct'[wp]: pspace_distinct' - -lemma cteInsert_assume_Null: - "\P\ cteInsert cap src dest \Q\ \ - \\s. cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ P s\ - cteInsert cap src dest - \Q\" - apply (rule hoare_name_pre_state) - apply (erule impCE) - apply (simp add: cteInsert_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ getCTE_sp])+ - apply (rule hoare_name_pre_state) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (erule hoare_weaken_pre) - apply simp - done - -crunch setExtraBadge - for mdb'[wp]: valid_mdb' - -lemma cteInsert_weak_cte_wp_at2: - assumes weak:"\c cap. P (maskedAsFull c cap) = P c" - shows - "\\s. if p = dest then P cap else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - supply if_cong[cong] - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of weak) - apply auto - done - -lemma transferCapsToSlots_presM: - assumes x: "\cap src dest. \\s. P s \ (emx \ cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ ex_cte_cap_to' dest s) - \ (vo \ valid_objs' s \ valid_cap' cap s \ real_cte_at' dest s) - \ (drv \ cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s - \ cte_wp_at' (untyped_derived_eq cap o cteCap) src s - \ valid_mdb' s) - \ (pad \ pspace_aligned' s \ pspace_distinct' s)\ - cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\\s. P s - \ (emx \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) \ distinct slots) - \ (vo \ valid_objs' s \ (\x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set caps. s \' fst x ) \ distinct slots) - \ (pad \ pspace_aligned' s \ pspace_distinct' s) - \ (drv \ vo \ pspace_aligned' s \ pspace_distinct' s \ valid_mdb' s - \ length slots \ 1 - \ (\x \ set caps. s \' fst x \ (slots \ [] - \ cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s)))\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply (simp, wp, simp) - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong split del: if_split) - apply (rule hoare_pre) - apply (wp eb hoare_vcg_const_Ball_lift hoare_vcg_const_imp_lift - | assumption | wpc)+ - apply (rule cteInsert_assume_Null) - apply (wp x hoare_vcg_const_Ball_lift cteInsert_cte_cap_to' hoare_weak_lift_imp) - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift hoare_weak_lift_imp)+ - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift cteInsert_cte_wp_at hoare_weak_lift_imp - deriveCap_derived_foo)+ - apply (thin_tac "\slots. PROP P slots" for P) - apply (clarsimp simp: cte_wp_at_ctes_of remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI) - apply (clarsimp simp:cte_wp_at_ctes_of untyped_derived_eq_def) - apply (intro conjI allI) - apply (clarsimp simp:Fun.comp_def cte_wp_at_ctes_of)+ - apply (clarsimp simp:valid_capAligned) - done - -lemmas transferCapsToSlots_pres2 - = transferCapsToSlots_presM[where vo=False and emx=True - and drv=False and pad=False, simplified] - -crunch transferCapsToSlots - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - and pspace_canonical'[wp]: pspace_canonical' - -lemma transferCapsToSlots_typ_at'[wp]: - "\\s. P (typ_at' T p s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (typ_at' T p s)\" - by (wp transferCapsToSlots_pres1 setExtraBadge_typ_at') - -lemma transferCapsToSlots_valid_objs[wp]: - "\valid_objs' and valid_mdb' and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and (\s. \x \ set caps. s \' fst x) and K(distinct slots)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_objs'\" - apply (rule hoare_pre) - apply (rule transferCapsToSlots_presM[where vo=True and emx=False and drv=False and pad=False]) - apply (wp | simp)+ - done - -abbreviation(input) - "transferCaps_srcs caps s \ \x\set caps. cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s" - -lemma transferCapsToSlots_mdb[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_mdb'\" - apply (wpsimp wp: transferCapsToSlots_presM[where drv=True and vo=True and emx=True and pad=True]) - apply (frule valid_capAligned) - apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def badge_derived'_def) - apply wp - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarify) - apply (case_tac cte) - apply (clarsimp dest!:ctes_of_valid_cap' split:if_splits) - apply (fastforce simp:valid_cap'_def) - done - -crunch setExtraBadge - for no_0'[wp]: no_0_obj' - -lemma transferCapsToSlots_no_0_obj' [wp]: - "\no_0_obj'\ transferCapsToSlots ep buffer n caps slots mi \\rv. no_0_obj'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_vp[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_pspace'\" - apply (rule hoare_pre) - apply (simp add: valid_pspace'_def | wp)+ - apply (fastforce simp: cte_wp_at_ctes_of dest: ctes_of_valid') - done - -crunch setExtraBadge, doIPCTransfer - for sch_act [wp]: "\s. P (ksSchedulerAction s)" - (wp: crunch_wps mapME_wp' simp: zipWithM_x_mapM) -crunch setExtraBadge - for pred_tcb_at' [wp]: "\s. pred_tcb_at' proj P p s" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and obj_at' [wp]: "\s. P' (obj_at' P p s)" - and queues [wp]: "\s. P (ksReadyQueues s)" - and queuesL1 [wp]: "\s. P (ksReadyQueuesL1Bitmap s)" - and queuesL2 [wp]: "\s. P (ksReadyQueuesL2Bitmap s)" - (simp: storeWordUser_def) - - -lemma tcts_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) - -crunch setExtraBadge - for state_refs_of'[wp]: "\s. P (state_refs_of' s)" - and state_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" - -lemma tcts_state_refs_of'[wp]: - "\\s. P (state_refs_of' s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (state_refs_of' s)\" - by (wp transferCapsToSlots_pres1) - -lemma tcts_state_hyp_refs_of'[wp]: - "transferCapsToSlots ep buffer n caps slots mi \\s. P (state_hyp_refs_of' s)\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for if_live'[wp]: if_live_then_nonz_cap' - -lemma tcts_iflive[wp]: - "\\s. if_live_then_nonz_cap' s \ distinct slots \ - (\x\set slots. - ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. if_live_then_nonz_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch setExtraBadge - for if_unsafe'[wp]: if_unsafe_then_cap' - -lemma tcts_ifunsafe[wp]: - "\\s. if_unsafe_then_cap' s \ distinct slots \ - (\x\set slots. cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s \ - ex_cte_cap_to' x s)\ transferCapsToSlots ep buffer n caps slots mi - \\rv. if_unsafe_then_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch setExtraBadge - for valid_idle'[wp]: valid_idle' - -lemma tcts_idle'[wp]: - "\\s. valid_idle' s\ transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_idle'\" - apply (rule hoare_pre) - apply (wp transferCapsToSlots_pres1) - apply simp - done - -lemma tcts_ct[wp]: - "\cur_tcb'\ transferCapsToSlots ep buffer n caps slots mi \\rv. cur_tcb'\" - by (wp transferCapsToSlots_pres1 cur_tcb_lift) - -crunch setExtraBadge - for valid_arch_state'[wp]: valid_arch_state' - -lemma transferCapsToSlots_valid_arch [wp]: - "\valid_arch_state'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_arch_state'\" - by (rule transferCapsToSlots_pres1; wp) - -crunch setExtraBadge - for valid_global_refs'[wp]: valid_global_refs' - -lemma transferCapsToSlots_valid_globals [wp]: - "\valid_global_refs' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' and K (distinct slots) - and K (length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_global_refs'\" - apply (wp transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=True] | clarsimp)+ - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) + apply (case_tac arch_capability; simp add: AARCH64_H.maskCapRights_def isCap_simps) done -crunch setExtraBadge - for irq_node'[wp]: "\s. P (irq_node' s)" - -lemma transferCapsToSlots_irq_node'[wp]: - "\\s. P (irq_node' s)\ transferCapsToSlots ep buffer n caps slots mi \\rv s. P (irq_node' s)\" - by (wp transferCapsToSlots_pres1) +lemma capASID_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ capASID cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemma valid_irq_handlers_ctes_ofD: - "\ ctes_of s p = Some cte; cteCap cte = IRQHandlerCap irq; valid_irq_handlers' s \ - \ irq_issued' irq s" - by (auto simp: valid_irq_handlers'_def cteCaps_of_def ran_def) - -crunch setExtraBadge - for valid_irq_handlers'[wp]: valid_irq_handlers' - -lemma transferCapsToSlots_irq_handlers[wp]: - "\valid_irq_handlers' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' - and K(distinct slots \ length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_irq_handlers'\" - apply (wpsimp wp: transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=False]) - apply (clarsimp simp: is_derived'_def cte_wp_at_ctes_of badge_derived'_def) - apply (erule(2) valid_irq_handlers_ctes_ofD) - apply wp - apply (clarsimp simp:cte_wp_at_ctes_of | intro ballI conjI)+ - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done +lemma cap_asid_base'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_asid_base' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -crunch setExtraBadge - for irq_state'[wp]: "\s. P (ksInterruptState s)" +lemma cap_vptr'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_vptr' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemma setExtraBadge_irq_states'[wp]: - "\valid_irq_states'\ setExtraBadge buffer b n \\_. valid_irq_states'\" - apply (wp valid_irq_states_lift') - apply (simp add: setExtraBadge_def storeWordUser_def) - apply (wpsimp wp: no_irq dmo_lift' no_irq_storeWord) - apply assumption - done +lemmas transferCapsToSlots_pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="transferCapsToSlots _ _ _ _ _ _"] -lemma transferCapsToSlots_irq_states' [wp]: - "\valid_irq_states'\ transferCapsToSlots ep buffer n caps slots mi \\_. valid_irq_states'\" - by (wp transferCapsToSlots_pres1) +crunch makeArchFaultMessage + for sch_act[Ipc_R_assms, wp]: "\s. P (ksSchedulerAction s)" -lemma transferCapsToSlots_irqs_masked'[wp]: - "\irqs_masked'\ transferCapsToSlots ep buffer n caps slots mi \\rv. irqs_masked'\" - by (wp transferCapsToSlots_pres1 irqs_masked_lift) +lemma is_derived'_IRQHandlerCap[Ipc_R_assms]: + "\isIRQHandlerCap cap'\ \ is_derived' (ctes_of (s::kernel_state)) src cap' cap = + (isIRQHandlerCap cap \ badge_derived' cap' cap)" + by (clarsimp simp add: AARCH64.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) -lemma storeWordUser_vms'[wp]: - "\valid_machine_state'\ storeWordUser a w \\_. valid_machine_state'\" +lemma storeWordUser_vms'[Ipc_R_assms, wp]: + "storeWordUser a w \valid_machine_state'\" proof - have aligned_offset_ignore: "\(l::machine_word) (p::machine_word) sz. l<8 \ p && mask 3 = 0 \ @@ -943,228 +121,35 @@ proof - done qed -lemma setExtraBadge_vms'[wp]: - "\valid_machine_state'\ setExtraBadge buffer b n \\_. valid_machine_state'\" -by (simp add: setExtraBadge_def) wp - -lemma transferCapsToSlots_vms[wp]: - "\\s. valid_machine_state' s\ - transferCapsToSlots ep buffer n caps slots mi - \\_ s. valid_machine_state' s\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge, transferCapsToSlots - for pspace_domain_valid[wp]: "pspace_domain_valid" - -crunch setExtraBadge - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma tcts_ct_not_inQ[wp]: - "\ct_not_inQ\ - transferCapsToSlots ep buffer n caps slots mi - \\_. ct_not_inQ\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" -crunch setExtraBadge - for ctes_of[wp]: "\s. P (ctes_of s)" - -lemma tcts_zero_ranges[wp]: - "\\s. untyped_ranges_zero' s \ valid_pspace' s \ distinct slots - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. untyped_ranges_zero'\" - apply (wpsimp wp: transferCapsToSlots_presM[where emx=True and vo=True - and drv=True and pad=True]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: cteCaps_of_def) - apply (rule hoare_pre, wp untyped_ranges_zero_lift) - apply (simp add: o_def) - apply (clarsimp simp: valid_pspace'_def ball_conj_distrib[symmetric]) - apply (drule(1) bspec) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (case_tac cte, clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply auto[1] - done - -crunch transferCapsToSlots, setExtraBadge - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - -crunch transferCapsToSlots - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift) - -lemma transferCapsToSlots_invs[wp]: - "\\s. invs' s \ distinct slots - \ (\x \ set slots. cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set slots. ex_cte_cap_to' x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (wp valid_irq_node_lift valid_dom_schedule'_lift) - apply fastforce - done - -lemma grs_distinct'[wp]: - "\\\ getReceiveSlots t buf \\rv s. distinct rv\" - apply (cases buf, simp_all add: getReceiveSlots_def - split_def unlessE_def) - apply (wp, simp) - apply (wp | simp only: distinct.simps list.simps empty_iff)+ - apply simp - done - -(* FIXME arch-split: move *) -lemma invs_pspace_in_kernel_mappings'[elim!]: - "invs' s \ pspace_in_kernel_mappings' s" - by (fastforce dest!: invs_valid_pspace' simp: valid_pspace'_def) - -lemma transferCaps_corres: - "\ info' = message_info_map info; - list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x)) - caps caps' \ - \ - corres ((=) \ message_info_map) - (tcb_at receiver and valid_objs and - pspace_aligned and pspace_distinct and valid_mdb - and valid_list and valid_arch_state - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame recv_buf - and (\s. valid_message_info info) - and transfer_caps_srcs caps) - (tcb_at' receiver and valid_objs' and - pspace_aligned' and pspace_distinct' and pspace_canonical' and pspace_in_kernel_mappings' - and no_0_obj' and valid_mdb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' recv_buf - and transferCaps_srcs caps' - and (\s. length caps' \ msgMaxExtraCaps)) - (transfer_caps info caps ep receiver recv_buf) - (transferCaps info' caps' ep receiver recv_buf)" - apply (simp add: transfer_caps_def transferCaps_def - getThreadCSpaceRoot) - apply (rule corres_assume_pre) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getReceiveSlots_corres]) - apply (rule_tac x=recv_buf in option_corres) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (case_tac info, simp) - apply simp - apply (rule corres_rel_imp, rule transferCapsToSlots_corres, - simp_all add: split_def)[1] - apply (case_tac info, simp) - apply (wp hoare_vcg_all_lift get_rs_cte_at hoare_weak_lift_imp - | simp only: ball_conj_distrib)+ - apply (simp add: cte_map_def tcb_cnode_index_def split_def) - apply (clarsimp simp: valid_pspace'_def valid_ipc_buffer_ptr'_def2 - split_def - cong: option.case_cong) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_caps_of_state) - apply (frule(1) Invariants_AI.caps_of_state_valid) - apply (fastforce simp:valid_cap_def) - apply (cases info) - apply (clarsimp simp: msg_max_extra_caps_def valid_message_info_def - max_ipc_words msg_max_length_def - msgMaxExtraCaps_def msgExtraCapBits_def - shiftL_nat valid_pspace'_def) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (case_tac cte,clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done - -crunch transferCaps - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas transferCaps_typ_ats[wp] = typ_at_lifts [OF transferCaps_typ_at'] - -lemma isIRQControlCap_mask [simp]: - "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" - apply (case_tac c) - apply (clarsimp simp: isCap_simps maskCapRights_def Let_def)+ - apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (clarsimp simp: isCap_simps AARCH64_H.maskCapRights_def - maskCapRights_def Let_def)+ - done +lemma isArchObjectCap_maskCapRights[Ipc_R_assms]: + "isArchObjectCap (Arch.maskCapRights R acap)" + by (cases acap; simp add: AARCH64_H.maskCapRights_def isCap_simps) lemma isFrameCap_maskCapRights[simp]: -" isArchCap isFrameCap (RetypeDecls_H.maskCapRights R c) = isArchCap isFrameCap c" - apply (case_tac c; simp add: isCap_simps isArchCap_def maskCapRights_def) + "isArchCap isFrameCap (global.maskCapRights R c) = isArchCap isFrameCap c" + apply (case_tac c; simp add: gen_isCap_simps isArchCap_def global.maskCapRights_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: isCap_simps AARCH64_H.maskCapRights_def) done -lemma capReplyMaster_mask[simp]: - "isReplyCap c \ capReplyMaster (maskCapRights R c) = capReplyMaster c" - by (clarsimp simp: isCap_simps maskCapRights_def) - -lemma is_derived_mask' [simp]: - "is_derived' m p (maskCapRights R c) = is_derived' m p c" - apply (rule ext) - apply (simp add: is_derived'_def badge_derived'_def) - done - -lemma arch_updateCapData_ordering: (* arch interface *) +lemma arch_updateCapData_ordering[Ipc_R_assms]: "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" - apply (cases acap; simp add: AARCH64_H.updateCapData_def) - apply fastforce - done - -lemma updateCapData_ordering: - "\ (x, capBadge cap) \ capBadge_ordering P; updateCapData p d cap \ NullCap \ - \ (x, capBadge (updateCapData p d cap)) \ capBadge_ordering P" - apply (cases cap; simp) - apply (fastforce simp: updateCapData_def Let_def isCap_simps split: if_split_asm) - apply (fastforce simp: updateCapData_def Let_def isCap_simps split: if_split_asm) - apply (fastforce dest: arch_updateCapData_ordering simp: updateCapData_def isCap_simps) - done - -lemma updateCapData_capReplyMaster: - "isReplyCap cap \ capReplyMaster (updateCapData p d cap) = capReplyMaster cap" - by (clarsimp simp: isCap_simps updateCapData_def split del: if_split) + by (cases acap; simp add: AARCH64_H.updateCapData_def) + fastforce -lemma ArchUpdateCapData_noReply: (* arch interface *) +lemma ArchUpdateCapData_noReply[Ipc_R_assms]: "Arch.updateCapData p d acap \ capability.ReplyCap x y z" by (cases acap; simp add: AARCH64_H.updateCapData_def) -lemma updateCapData_is_Reply[simp]: - "(updateCapData p d cap = ReplyCap x y z) = (cap = ReplyCap x y z)" - by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def ArchUpdateCapData_noReply - split del: if_split - split: if_split_asm) - -lemma ArchUpdateCapData_noIRQControl: (* arch interface *) +lemma ArchUpdateCapData_noIRQControl[Ipc_R_assms]: "Arch.updateCapData p d acap \ IRQControlCap" by (cases acap; simp add: AARCH64_H.updateCapData_def) -lemma updateCapDataIRQ: - "updateCapData p d cap \ NullCap \ - isIRQControlCap (updateCapData p d cap) = isIRQControlCap cap" - by (cases cap; simp add: updateCapData_def isCap_simps Let_def ArchUpdateCapData_noIRQControl) - lemma updateCapData_vs_cap_ref'[simp]: "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def + clarsimp simp: isCap_simps global.updateCapData_def Let_def AARCH64_H.updateCapData_def vs_cap_ref'_def split del: if_split @@ -1172,397 +157,28 @@ lemma updateCapData_vs_cap_ref'[simp]: lemma isFrameCap_updateCapData[simp]: "isArchCap isFrameCap (updateCapData pr D c) = isArchCap isFrameCap c" - apply (case_tac c; simp add:updateCapData_def isCap_simps isArchCap_def) + apply (case_tac c; simp add: global.updateCapData_def isCap_simps isArchCap_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: AARCH64_H.updateCapData_def isCap_simps isArchCap_def) apply (clarsimp split:capability.splits simp:Let_def) done -lemma lookup_cap_to'[wp]: - "\\\ lookupCap t cref \\rv s. \r\cte_refs' rv (irq_node' s). ex_cte_cap_to' r s\,-" - by (simp add: lookupCap_def lookupCapAndSlot_def | wp)+ - -lemma grs_cap_to'[wp]: - "\\\ getReceiveSlots t buf \\rv s. \x \ set rv. ex_cte_cap_to' x s\" - apply (cases buf; simp add: getReceiveSlots_def split_def unlessE_def) - apply (wp, simp) - apply (wp | simp | rule hoare_drop_imps)+ - done - -lemma grs_length'[wp]: - "\\s. 1 \ n\ getReceiveSlots receiver recv_buf \\rv s. length rv \ n\" - apply (simp add: getReceiveSlots_def split_def unlessE_def) - apply (rule hoare_pre) - apply (wp | wpc | simp)+ - done - -lemma transferCaps_invs' [wp]: - "\invs' and transferCaps_srcs caps\ - transferCaps mi caps ep receiver recv_buf - \\rv. invs'\" - apply (simp add: transferCaps_def Let_def split_def) - apply (wp get_rs_cte_at' hoare_vcg_const_Ball_lift - | wpcw | clarsimp)+ - done - -lemma get_mrs_inv'[wp]: - "\P\ getMRs t buf info \\rv. P\" - by (simp add: getMRs_def load_word_offs_def getRegister_def - | wp dmo_inv' loadWord_inv mapM_wp' - asUser_inv det_mapM[where S=UNIV] | wpc)+ - - -lemma copyMRs_typ_at': - "\\s. P (typ_at' T p s)\ copyMRs s sb r rb n \\rv s. P (typ_at' T p s)\" - by (simp add: copyMRs_def | wp mapM_wp [where S=UNIV, simplified] | wpc)+ - -lemmas copyMRs_typ_at_lifts[wp] = typ_at_lifts [OF copyMRs_typ_at'] - -lemma copy_mrs_invs'[wp]: - "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" - including classic_wp_pre - apply (simp add: copyMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord| - simp add: split_def) - apply (case_tac sb, simp_all)[1] - apply wp+ - apply (case_tac rb, simp_all)[1] - apply (wp mapM_wp dmo_invs' no_irq_mapM no_irq_storeWord no_irq_loadWord) - apply blast - apply (rule hoare_strengthen_post) - apply (rule mapM_wp) - apply (wp | simp | blast)+ - done - -crunch transferCaps, setMRs, copyMRs, setMessageInfo - for aligned'[wp]: pspace_aligned' - and distinct'[wp]: pspace_distinct' - and pspace_canonical'[wp]: pspace_canonical' - (wp: crunch_wps simp: crunch_simps) - -lemma set_mrs_valid_objs' [wp]: - "\valid_objs'\ setMRs t a msgs \\rv. valid_objs'\" - apply (simp add: setMRs_def zipWithM_x_mapM split_def) - apply (wp asUser_valid_objs crunch_wps) - done - -crunch copyMRs - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps simp: crunch_simps) - -lemma setMRs_invs_bits[wp]: - "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\P. setMRs t buf mrs \\s. P (state_refs_of' s)\" - "\P. setMRs t buf mrs \\s. P (state_hyp_refs_of' s)\" - "\if_live_then_nonz_cap'\ setMRs t buf mrs \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ setMRs t buf mrs \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ setMRs t buf mrs \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ setMRs t buf mrs \\rv. if_unsafe_then_cap'\" - by (simp add: setMRs_def zipWithM_x_mapM split_def storeWordUser_def | wp crunch_wps)+ - -crunch setMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma copyMRs_invs_bits[wp]: - "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\P. copyMRs s sb r rb n \\s. P (state_refs_of' s)\" - "\P. copyMRs s sb r rb n \\s. P (state_hyp_refs_of' s)\" - "\if_live_then_nonz_cap'\ copyMRs s sb r rb n \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ copyMRs s sb r rb n \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ copyMRs s sb r rb n \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ copyMRs s sb r rb n \\rv. if_unsafe_then_cap'\" - by (simp add: copyMRs_def storeWordUser_def | wp mapM_wp' | wpc)+ - -crunch copyMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma mi_map_length[simp]: "msgLength (message_info_map mi) = mi_length mi" - by (cases mi, simp) - -crunch copyMRs - for cte_wp_at'[wp]: "cte_wp_at' P p" - (wp: crunch_wps) - -lemma lookupExtraCaps_srcs[wp]: - "\\\ lookupExtraCaps thread buf info \transferCaps_srcs\,-" - apply (simp add: lookupExtraCaps_def lookupCapAndSlot_def - split_def lookupSlotForThread_def - getSlotCap_def) - apply (wp mapME_set[where R=\] getCTE_wp') - apply (rule_tac P=\ in hoare_trivE_R) - apply (simp add: cte_wp_at_ctes_of) - apply (wp | simp)+ - done - -crunch lookupExtraCaps - for inv[wp]: "P" - (wp: crunch_wps mapME_wp' simp: crunch_simps) - -lemma invs_mdb_strengthen': - "invs' s \ valid_mdb' s" by auto - -lemma lookupExtraCaps_length: - "\\s. unat (msgExtraCaps mi) \ n\ lookupExtraCaps thread send_buf mi \\rv s. length rv \ n\,-" - apply (simp add: lookupExtraCaps_def getExtraCPtrs_def) - apply (rule hoare_pre) - apply (wp mapME_length | wpc)+ - apply (clarsimp simp: upto_enum_step_def Suc_unat_diff_1 word_le_sub1) - done - -lemma getMessageInfo_msgExtraCaps[wp]: - "\\\ getMessageInfo t \\rv s. unat (msgExtraCaps rv) \ msgMaxExtraCaps\" - apply (simp add: getMessageInfo_def) - apply wp - apply (simp add: messageInfoFromWord_def Let_def msgMaxExtraCaps_def - shiftL_nat) - apply (subst nat_le_Suc_less_imp) - apply (rule unat_less_power) - apply (simp add: word_bits_def msgExtraCapBits_def) - apply (rule and_mask_less'[unfolded mask_2pm1]) - apply (simp add: msgExtraCapBits_def) - apply wpsimp+ - done - -lemma lookupCapAndSlot_corres: - "cptr = to_bl cptr' \ - corres (lfr \ (\a b. cap_relation (fst a) (fst b) \ snd b = cte_map (snd a))) - (valid_objs and pspace_aligned and tcb_at thread) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread) - (lookup_cap_and_slot thread cptr) (lookupCapAndSlot thread cptr')" - unfolding lookup_cap_and_slot_def lookupCapAndSlot_def - apply (simp add: liftE_bindE split_def) - apply (rule corres_guard_imp) - apply (rule_tac r'="\rv rv'. rv' = cte_map (fst rv)" - in corres_splitEE) - apply (rule corres_rel_imp, rule lookupSlotForThread_corres) - apply (simp add: split_def) - apply (rule corres_split[OF getSlotCap_corres]) - apply simp - apply (rule corres_returnOkTT, simp) - apply wp+ - apply (wp | simp add: liftE_bindE[symmetric])+ - done - -lemma lookupExtraCaps_corres: - "\ info' = message_info_map info; buffer = buffer'\ \ - corres (fr \ list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))) - (valid_objs and pspace_aligned and tcb_at thread and (\_. valid_message_info info)) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer') - (lookup_extra_caps thread buffer info) (lookupExtraCaps thread buffer' info')" - unfolding lookupExtraCaps_def lookup_extra_caps_def - apply (rule corres_gen_asm) - apply (cases "mi_extra_caps info = 0") - apply (cases info) - apply (simp add: Let_def returnOk_def getExtraCPtrs_def - liftE_bindE upto_enum_step_def mapM_def - sequence_def doMachineOp_return mapME_Nil - split: option.split) - apply (cases info) - apply (rename_tac w1 w2 w3 w4) - apply (simp add: Let_def liftE_bindE) - apply (cases buffer') - apply (simp add: getExtraCPtrs_def mapME_Nil) - apply (rule corres_returnOk) - apply simp - apply (simp add: msgLengthBits_def msgMaxLength_def word_size field_simps - getExtraCPtrs_def upto_enum_step_def upto_enum_word - word_size_def msg_max_length_def liftM_def - Suc_unat_diff_1 word_le_sub1 mapM_map_simp - upt_lhs_sub_map[where x=buffer_cptr_index] - wordSize_def wordBits_def - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_underlying_split) - - apply (rule_tac S = "\x y. x = y \ x < unat w2" - in corres_mapM_list_all2 - [where Q = "\_. valid_objs and pspace_aligned and tcb_at thread" and r = "(=)" - and Q' = "\_. valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer'" and r'="(=)" ]) - apply simp - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule loadWordUser_corres') - apply (clarsimp simp: buffer_cptr_index_def msg_max_length_def - max_ipc_words valid_message_info_def - msg_max_extra_caps_def word_le_nat_alt) - apply (simp add: buffer_cptr_index_def msg_max_length_def) - apply simp - apply simp - apply (simp add: load_word_offs_word_def) - apply (wp | simp)+ - apply (subst list_all2_same) - apply (clarsimp simp: max_ipc_words field_simps) - apply (simp add: mapME_def, fold mapME_def)[1] - apply (rule corres_mapME [where S = Id and r'="(\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))"]) - apply simp - apply simp - apply simp - apply (rule corres_cap_fault [OF lookupCapAndSlot_corres]) - apply simp - apply simp - apply (wp | simp)+ - apply (simp add: set_zip_same Int_lower1) - apply (wp mapM_wp [OF _ subset_refl] | simp)+ - done - -crunch copyMRs - for ctes_of[wp]: "\s. P (ctes_of s)" - (ignore: threadSet - wp: threadSet_ctes_of crunch_wps) - -lemma copyMRs_valid_mdb[wp]: - "\valid_mdb'\ copyMRs t buf t' buf' n \\rv. valid_mdb'\" - by (simp add: valid_mdb'_def copyMRs_ctes_of) - -crunch copy_mrs - for valid_arch_state[wp]: valid_arch_state - (wp: crunch_wps) - -lemma doNormalTransfer_corres: - "corres dc - (tcb_at sender and tcb_at receiver and (pspace_aligned:: det_state \ bool) - and valid_objs and cur_tcb and valid_mdb and valid_list and valid_arch_state and pspace_distinct - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame send_buf - and case_option \ in_user_frame recv_buf) - (tcb_at' sender and tcb_at' receiver and valid_objs' - and pspace_aligned' and pspace_distinct' and pspace_canonical' and cur_tcb' - and valid_mdb' and no_0_obj' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' send_buf - and case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_normal_transfer sender send_buf ep badge can_grant receiver recv_buf) - (doNormalTransfer sender send_buf ep badge can_grant receiver recv_buf)" - supply if_cong[cong] - apply (simp add: do_normal_transfer_def doNormalTransfer_def) - apply (rule corres_guard_imp) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule_tac F="valid_message_info mi" in corres_gen_asm) - apply (rule_tac r'="list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))" - in corres_split) - apply (rule corres_if[OF refl]) - apply (rule corres_split_catch) - apply (rule lookupExtraCaps_corres; simp) - apply (rule corres_trivial, simp) - apply wp+ - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_split_eqr[OF copyMRs_corres]) - apply (rule corres_split) - apply (rule transferCaps_corres; simp) - apply (rename_tac mi' mi'') - apply (rule_tac F="mi_label mi' = mi_label mi" - in corres_gen_asm) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply (case_tac mi', clarsimp) - apply (simp add: badge_register_def badgeRegister_def) - apply (fold dc_def) - apply (rule asUser_setRegister_corres) - apply wp - apply simp+ - apply ((wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_case_option_wp - hoare_valid_ipc_buffer_ptr_typ_at' copyMRs_typ_at' - hoare_vcg_const_Ball_lift lookupExtraCaps_length - | simp add: if_apply_def2)+) - apply (wp hoare_weak_lift_imp | strengthen valid_msg_length_strengthen)+ - apply clarsimp - apply auto - done - -lemma corres_liftE_lift: - "corres r1 P P' m m' \ - corres (f1 \ r1) P P' (liftE m) (withoutFailure m')" - by simp - -lemmas corres_ipc_thread_helper = - corres_split_eqrE[OF corres_liftE_lift [OF getCurThread_corres]] - -lemmas corres_ipc_info_helper = - corres_split_maprE [where f = message_info_map, OF _ - corres_liftE_lift [OF getMessageInfo_corres]] - -crunch doNormalTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas doNormal_lifts[wp] = typ_at_lifts [OF doNormalTransfer_typ_at'] - -lemma doNormal_invs'[wp]: - "\tcb_at' sender and tcb_at' receiver and invs'\ - doNormalTransfer sender send_buf ep badge - can_grant receiver recv_buf \\r. invs'\" - apply (simp add: doNormalTransfer_def) - apply (wp hoare_vcg_const_Ball_lift | simp)+ - done - -crunch doNormalTransfer - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps) -crunch doNormalTransfer - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps) - -lemma transferCaps_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' - and (\s. (\x\set caps. cte_wp_at' (\cte. fst x \ capability.NullCap \ cteCap cte = fst x) (snd x) s))\ - transferCaps tag caps ep receiver recv_buf - \\r. untyped_ranges_zero'\" - apply (simp add: transferCaps_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift hoare_vcg_const_imp_lift - | wpc - | simp add: ball_conj_distrib)+ - apply clarsimp - done - -crunch doNormalTransfer - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 ignore: constOnFailure) - -lemmas asUser_urz = untyped_ranges_zero_lift[OF asUser_gsUntypedZeroRanges] - -crunch doNormalTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: asUser wp: crunch_wps asUser_urz hoare_vcg_const_Ball_lift) - -lemma msgFromLookupFailure_map[simp]: - "msgFromLookupFailure (lookup_failure_map lf) - = msg_from_lookup_failure lf" - by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) +lemma get_mrs_inv'[Ipc_R_assms, wp]: + "getMRs t buf info \P\" + by (wpsimp wp: dmo_inv' loadWord_inv mapM_wp' asUser_inv det_mapM[where S=UNIV] + simp: getMRs_def load_word_offs_def getRegister_def) -lemma asUser_getRestartPC_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t getRestartPC) (asUser t getRestartPC)" - apply (rule asUser_corres') - apply (rule corres_Id, simp, simp) - apply (rule no_fail_getRestartPC) - done +lemma badgeRegister_badge_register[Ipc_R_assms]: + "badgeRegister = badge_register" + by (simp add: badge_register_def badgeRegister_def) -lemma asUser_mapM_getRegister_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t (mapM getRegister regs)) - (asUser t (mapM getRegister regs))" - apply (rule asUser_corres') - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_mapM) - apply (simp add: getRegister_def) - done +lemmas copyMRs__pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="copyMRs _ _ _ _ _"] -lemma makeArchFaultMessage_corres: +lemma makeArchFaultMessage_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_arch_fault_msg f t) - (makeArchFaultMessage (arch_fault_map f) t)" + (make_arch_fault_msg f t) + (makeArchFaultMessage (arch_fault_map f) t)" apply (cases f; clarsimp simp: makeArchFaultMessage_def ucast_nat_def split: arch_fault.split) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) @@ -1570,99 +186,22 @@ lemma makeArchFaultMessage_corres: apply (wp+, auto) done -lemma makeFaultMessage_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_fault_msg ft t) - (makeFaultMessage (fault_map ft) t)" - apply (cases ft, simp_all add: makeFaultMessage_def split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_trivial, simp add: fromEnum_def enum_bool) - apply (wp | simp)+ - apply (simp add: AARCH64_H.syscallMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (simp add: AARCH64_H.exceptionMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (rule makeArchFaultMessage_corres) - done - -lemma makeFaultMessage_inv[wp]: - "\P\ makeFaultMessage ft t \\rv. P\" - apply (cases ft, simp_all add: makeFaultMessage_def) - apply (wp asUser_inv mapM_wp' det_mapM[where S=UNIV] - det_getRestartPC getRestartPC_inv - | clarsimp simp: getRegister_def makeArchFaultMessage_def - split: arch_fault.split)+ - done +lemma syscallMessage_def'[Ipc_R_assms]: + "FaultHandler_H.syscallMessage \ MachineExports.syscallMessage" + by (simp add: syscallMessage_def) -lemmas threadget_fault_corres = - threadGet_corres [where r = fault_rel_optionation - and f = tcb_fault and f' = tcbFault, - simplified tcb_relation_def, simplified] - -lemma doFaultTransfer_corres: - "corres dc - (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender - and tcb_at receiver and case_option \ in_user_frame recv_buf - and pspace_aligned and pspace_distinct) - (case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_fault_transfer badge sender receiver recv_buf) - (doFaultTransfer badge sender receiver recv_buf)" - apply (clarsimp simp: do_fault_transfer_def doFaultTransfer_def split_def - AARCH64_H.badgeRegister_def badge_register_def) - apply (rule_tac Q="\fault. K (\f. fault = Some f) and - tcb_at sender and tcb_at receiver and - case_option \ in_user_frame recv_buf and - pspace_aligned and pspace_distinct" - and Q'="\fault'. case_option \ valid_ipc_buffer_ptr' recv_buf" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply (clarsimp simp: obj_at_def is_tcb)+ - apply (rule corres_assume_pre) - apply (fold assert_opt_def | unfold haskell_fail_def)+ - apply (rule corres_assert_opt_assume) - apply (clarsimp split: option.splits - simp: fault_rel_optionation_def assert_opt_def - map_option_case) - defer - defer - apply (clarsimp simp: fault_rel_optionation_def) - apply (wp thread_get_wp) - apply (clarsimp simp: obj_at_def is_tcb) - apply wp - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - done +lemma exceptionMessage_def'[Ipc_R_assms]: + "FaultHandler_H.exceptionMessage \ MachineExports.exceptionMessage" + by (simp add: exceptionMessage_def) -lemma doFaultTransfer_invs[wp]: - "\invs' and tcb_at' receiver\ - doFaultTransfer badge sender receiver recv_buf - \\rv. invs'\" - by (simp add: doFaultTransfer_def split_def | wp - | clarsimp split: option.split)+ +lemma makeArchFaultMessage_inv[Ipc_R_assms, wp]: + "makeArchFaultMessage ft t \P\" + unfolding makeArchFaultMessage_def + by (wpsimp wp: asUser_inv getRestartPC_inv split: arch_fault.split) -lemma lookupIPCBuffer_valid_ipc_buffer [wp]: +lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" - unfolding lookupIPCBuffer_def AARCH64_H.lookupIPCBuffer_def + unfolding lookupIPCBuffer_def supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def locateSlot_conv threadGet_def comp_def) @@ -1707,157 +246,12 @@ lemma lookupIPCBuffer_Some_0: "\\\ lookupIPCBuffer w t \\rv s. rv \ Some 0\" by (wpsimp simp: lookupIPCBuffer_def Let_def getThreadBufferSlot_def locateSlot_conv) -(* Used in CRefine *) -lemma asUser_valid_ipc_buffer_ptr': - "asUser t m \\s. valid_ipc_buffer_ptr' p s\" - by (simp add: valid_ipc_buffer_ptr'_def, wp) - -lemma doIPCTransfer_corres: - "corres dc - (tcb_at s and tcb_at r and valid_objs and pspace_aligned - and valid_list and valid_arch_state - and pspace_distinct and valid_mdb and cur_tcb - and (\s. case ep of Some x \ ep_at x s | _ \ True)) - (tcb_at' s and tcb_at' r and valid_pspace' and cur_tcb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True)) - (do_ipc_transfer s ep bg grt r) - (doIPCTransfer s ep bg grt r)" - apply (simp add: do_ipc_transfer_def doIPCTransfer_def) - apply (rule_tac Q="\receiveBuffer sa. tcb_at s sa \ valid_objs sa \ - pspace_aligned sa \ pspace_distinct sa \ tcb_at r sa \ - cur_tcb sa \ valid_mdb sa \ valid_list sa \ valid_arch_state sa \ - (case ep of None \ True | Some x \ ep_at x sa) \ - case_option (\_. True) in_user_frame receiveBuffer sa \ - obj_at (\ko. \tcb. ko = TCB tcb - \ \\ft. tcb_fault tcb = Some ft\) s sa" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule lookupIPCBuffer_corres') - apply auto[2] - apply (rule corres_underlying_split [OF _ _ thread_get_sp threadGet_inv]) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply simp - defer - apply (rule corres_guard_imp) - apply (subst case_option_If)+ - apply (rule corres_if2) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (simp add: dc_def[symmetric]) - apply (rule doNormalTransfer_corres) - apply (wp | simp add: valid_pspace'_def)+ - apply (simp add: dc_def[symmetric]) - apply (rule doFaultTransfer_corres) - apply (clarsimp simp: obj_at_def) - apply (rule conjI, clarsimp, assumption) - apply (wp|simp add: obj_at_def is_tcb valid_pspace'_def)+ - done - - -crunch doIPCTransfer - for ifunsafe[wp]: "if_unsafe_then_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -crunch doIPCTransfer - for iflive[wp]: "if_live_then_nonz_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -crunch doIPCTransfer - for vp[wp]: "valid_pspace'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) -crunch doIPCTransfer - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for state_refs_of[wp]: "\s. P (state_refs_of' s)" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for state_hyp_refs_of[wp]: "\s. P (state_hyp_refs_of' s)" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for ct[wp]: "cur_tcb'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for idle'[wp]: "valid_idle'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) -lemmas dit'_typ_ats[wp] = typ_at_lifts [OF doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: crunch_wps simp: crunch_simps) - -lemmas dit_irq_node'[wp] - = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for valid_arch_state'[wp]: "valid_arch_state'" - (wp: crunch_wps simp: crunch_simps) - -(* Levity: added (20090126 19:32:26) *) -declare asUser_global_refs' [wp] - -lemma lec_valid_cap' [wp]: - "\valid_objs'\ lookupExtraCaps thread xa mi \\rv s. (\x\set rv. s \' fst x)\, -" - apply (rule hoare_pre, rule hoare_strengthen_postE_R) - apply (rule hoare_vcg_conj_liftE_R[where P'=valid_objs' and Q'="\_. valid_objs'"]) - apply (rule lookupExtraCaps_srcs) - apply wp - apply (clarsimp simp: cte_wp_at_ctes_of) - apply fastforce - apply simp - done - -crunch doIPCTransfer - for objs'[wp]: "valid_objs'" - ( wp: crunch_wps hoare_vcg_const_Ball_lift - transferCapsToSlots_valid_objs - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for global_refs'[wp]: "valid_global_refs'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_global_refsT - transferCapsToSlots_valid_globals - simp: zipWithM_x_mapM ball_conj_distrib) - -declare asUser_irq_handlers' [wp] - -crunch doIPCTransfer - for irq_handlers'[wp]: "valid_irq_handlers'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_irq_handlers' - transferCapsToSlots_irq_handlers - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for irq_states'[wp]: "valid_irq_states'" - (wp: crunch_wps no_irq no_irq_mapM no_irq_storeWord no_irq_loadWord - no_irq_case_option simp: crunch_simps zipWithM_x_mapM) - -crunch doIPCTransfer - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps simp: crunch_simps rule: irqs_masked_lift) - -lemma doIPCTransfer_invs[wp]: - "\invs' and tcb_at' s and tcb_at' r\ - doIPCTransfer s ep bg grt r - \\rv. invs'\" - apply (simp add: doIPCTransfer_def) - apply (wpsimp wp: hoare_drop_imp) - done - - -lemma arch_getSanitiseRegisterInfo_corres: +lemma arch_getSanitiseRegisterInfo_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (arch_get_sanitise_register_info t) (getSanitiseRegisterInfo t)" unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def - apply (fold archThreadGet_def) - apply corres - done + by (fold archThreadGet_def, corres) crunch getSanitiseRegisterInfo for tcb_at'[wp]: "tcb_at' t" @@ -1866,2529 +260,59 @@ crunch arch_get_sanitise_register_info for pspace_distinct[wp]: pspace_distinct and pspace_aligned[wp]: pspace_aligned -lemma handle_fault_reply_registers_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (do t' \ arch_get_sanitise_register_info t; - y \ as_user t - (zipWithM_x - (\r v. setRegister r - (sanitise_register t' r v)) - msg_template msg); - return (label = 0) - od) - (do t' \ getSanitiseRegisterInfo t; - y \ asUser t - (zipWithM_x - (\r v. setRegister r (sanitiseRegister t' r v)) - msg_template msg); - return (label = 0) - od)" - apply (rule corres_guard_imp) - apply (rule corres_split[OF arch_getSanitiseRegisterInfo_corres]) - apply (rule corres_split) - apply (rule asUser_corres') - apply(simp add: setRegister_def sanitise_register_def - sanitiseRegister_def syscallMessage_def Let_def cong: register.case_cong) - apply(subst zipWithM_x_modify)+ - apply(rule corres_modify') - apply (simp|wp)+ - done - -lemma handleFaultReply_corres: - "ft' = fault_map ft \ - corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (handle_fault_reply ft t label msg) - (handleFaultReply ft' t label msg)" - apply (cases ft) - apply(simp_all add: handleFaultReply_def - handle_arch_fault_reply_def handleArchFaultReply_def - syscallMessage_def exceptionMessage_def - split: arch_fault.split) - by (rule handle_fault_reply_registers_corres)+ - -crunch handleFaultReply - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas hfr_typ_ats[wp] = typ_at_lifts [OF handleFaultReply_typ_at'] - -crunch handleFaultReply - for ct'[wp]: "\s. P (ksCurThread s)" - -lemma doIPCTransfer_sch_act_simple [wp]: - "\sch_act_simple\ doIPCTransfer sender endpoint badge grant receiver \\_. sch_act_simple\" - by (simp add: sch_act_simple_def, wp) - -lemma possibleSwitchTo_invs'[wp]: - "\invs' and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - possibleSwitchTo t \\_. invs'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp tcbSchedEnqueue_invs' ssa_invs') - apply (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt]) - apply (wpsimp wp: ssa_invs' threadGet_wp)+ - apply (clarsimp dest!: obj_at_ko_at' simp: tcb_in_cur_domain'_def obj_at'_def) - done - -crunch isFinalCapability - for cur'[wp]: "\s. P (cur_tcb' s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch deleteCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma getThreadCallerSlot_inv: - "\P\ getThreadCallerSlot t \\_. P\" - by (simp add: getThreadCallerSlot_def, wp) - -lemma finaliseCapTrue_standin_tcb_at' [wp]: - "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp getObject_ntfn_inv - | wpc - | simp)+ - done - -lemma finaliseCapTrue_standin_cur': - "\\s. cur_tcb' s\ finaliseCapTrue_standin cap v2 \\_ s'. cur_tcb' s'\" - apply (simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ finaliseCapTrue_standin_ct']) - apply (wp) - done - -lemma cteDeleteOne_cur' [wp]: - "\\s. cur_tcb' s\ cteDeleteOne slot \\_ s'. cur_tcb' s'\" - apply (simp add: cteDeleteOne_def unless_def when_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def | wp (once) cur_tcb_lift)+ - done - -lemma handleFaultReply_cur' [wp]: - "\\s. cur_tcb' s\ handleFaultReply x0 thread label msg \\_ s'. cur_tcb' s'\" - apply (clarsimp simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ handleFaultReply_ct']) - apply (wp) - done - -lemma capClass_Reply: - "capClass cap = ReplyClass tcb \ isReplyCap cap \ capTCBPtr cap = tcb" - apply (cases cap, simp_all add: isCap_simps) - apply (rename_tac arch_capability) - apply (case_tac arch_capability, simp_all) - done - -lemma reply_cap_end_mdb_chain: - "\ cte_wp_at (is_reply_cap_to t) slot s; invs s; - invs' s'; - (s, s') \ state_relation; ctes_of s' (cte_map slot) = Some cte \ - \ (mdbPrev (cteMDBNode cte) \ nullPointer - \ mdbNext (cteMDBNode cte) = nullPointer) - \ cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) - (mdbPrev (cteMDBNode cte)) s'" - apply (clarsimp simp only: cte_wp_at_reply_cap_to_ex_rights) - apply (frule(1) pspace_relation_ctes_ofI[OF state_relation_pspace_relation], - clarsimp+) - apply (subgoal_tac "\slot' rights'. caps_of_state s slot' = Some (cap.ReplyCap t True rights') - \ descendants_of slot' (cdt s) = {slot}") - apply (elim state_relationE exE) - apply (clarsimp simp: cdt_relation_def - simp del: split_paired_All) - apply (drule spec, drule(1) mp[OF _ caps_of_state_cte_at]) - apply (frule(1) pspace_relation_cte_wp_at[OF _ caps_of_state_cteD], - clarsimp+) - apply (clarsimp simp: descendants_of'_def cte_wp_at_ctes_of) - apply (frule_tac f="\S. cte_map slot \ S" in arg_cong, simp(no_asm_use)) - apply (frule invs_mdb'[unfolded valid_mdb'_def]) - apply (rule context_conjI) - apply (clarsimp simp: nullPointer_def valid_mdb_ctes_def) - apply (erule(4) subtree_prev_0) - apply (rule conjI) - apply (rule ccontr) - apply (frule valid_mdb_no_loops, simp add: no_loops_def) - apply (drule_tac x="cte_map slot" in spec) - apply (erule notE, rule r_into_trancl, rule ccontr) - apply (clarsimp simp: mdb_next_unfold valid_mdb_ctes_def nullPointer_def) - apply (rule valid_dlistEn, assumption+) - apply (subgoal_tac "ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)") - apply (frule(3) class_linksD) - apply (clarsimp simp: isCap_simps dest!: capClass_Reply[OF sym]) - apply (drule_tac f="\S. mdbNext (cteMDBNode cte) \ S" in arg_cong) - apply (simp, erule notE, rule subtree.trans_parent, assumption+) - apply (case_tac ctea, case_tac cte') - apply (clarsimp simp add: parentOf_def isMDBParentOf_CTE) - apply (simp add: sameRegionAs_def2 isCap_simps) - apply (erule subtree.cases) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (simp add: mdb_next_unfold) - apply (erule subtree.cases) - apply (clarsimp simp: valid_mdb_ctes_def) - apply (erule_tac cte=ctea in valid_dlistEn, assumption) - apply (simp add: mdb_next_unfold) - apply (clarsimp simp: mdb_next_unfold isCap_simps) - apply (drule_tac f="\S. c' \ S" in arg_cong) - apply (clarsimp simp: no_loops_direct_simp valid_mdb_no_loops) - apply (frule invs_mdb) - apply (drule invs_valid_reply_caps) - apply (clarsimp simp: valid_mdb_def reply_mdb_def - valid_reply_caps_def reply_caps_mdb_def - cte_wp_at_caps_of_state - simp del: split_paired_All) - apply (erule_tac x=slot in allE, erule_tac x=t in allE, erule impE, fast) - apply (elim exEI) - apply clarsimp - apply (subgoal_tac "P" for P, rule sym, rule equalityI, assumption) - apply clarsimp - apply (erule(4) unique_reply_capsD) - apply (simp add: descendants_of_def) - apply (rule r_into_trancl) - apply (simp add: cdt_parent_rel_def is_cdt_parent_def) - done - -lemma unbindNotification_valid_objs'_strengthen: - "valid_tcb' tcb s \ valid_tcb' (tcbBoundNotification_update Map.empty tcb) s" - "valid_ntfn' ntfn s \ valid_ntfn' (ntfnBoundTCB_update Map.empty ntfn) s" - by (simp_all add: unbindNotification_valid_objs'_helper' unbindNotification_valid_objs'_helper) - -crunch cteDeleteOne - for valid_objs'[wp]: "valid_objs'" - (simp: crunch_simps unless_def - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch handleFaultReply - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma emptySlot_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - emptySlot slot irq - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp weak_sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma cancelAllIPC_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllIPC epptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllIPC_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -lemma cancelAllSignals_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllSignals ntfnptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllSignals_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -crunch finaliseCapTrue_standin - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (ignore: setThreadState - simp: crunch_simps - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma cteDeleteOne_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cteDeleteOne sl - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def)+ - done - -crunch handleFaultReply - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" -crunch handleFaultReply - for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - -crunch unbindNotification - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" -(wp: sbn_sch_act') - -crunch handleFaultReply - for valid_objs'[wp]: valid_objs' - -lemma cte_wp_at_is_reply_cap_toI: - "cte_wp_at ((=) (cap.ReplyCap t False rights)) ptr s - \ cte_wp_at (is_reply_cap_to t) ptr s" - by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) - -crunch handle_fault_reply - for pspace_alignedp[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - -crunch cteDeleteOne, doIPCTransfer, handleFaultReply - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -lemma doReplyTransfer_corres: - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at ((=) (cap.ReplyCap receiver False rights)) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - apply (simp add: do_reply_transfer_def doReplyTransfer_def cong: option.case_cong) - apply (rule corres_underlying_split [OF _ _ gts_sp gts_sp']) - apply (rule corres_guard_imp) - apply (rule getThreadState_corres, (clarsimp simp add: st_tcb_at_tcb_at invs_distinct invs_psp_aligned)+) - apply (rule_tac F = "awaiting_reply state" in corres_req) - apply (clarsimp simp add: st_tcb_at_def obj_at_def is_tcb) - apply (fastforce simp: invs_def valid_state_def intro: has_reply_cap_cte_wpD - dest: has_reply_cap_cte_wpD - dest!: valid_reply_caps_awaiting_reply cte_wp_at_is_reply_cap_toI) - apply (case_tac state, simp_all add: bind_assoc) - apply (simp add: isReply_def liftM_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply clarsimp - apply (rename_tac mdbnode) - apply (rule_tac P="Q" and Q="Q" and P'="Q'" and Q'="(\s. Q' s \ R' s)" for Q Q' R' - in stronger_corres_guard_imp[rotated]) - apply assumption - apply (rule conjI, assumption) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (drule cte_wp_at_is_reply_cap_toI) - apply (erule(4) reply_cap_end_mdb_chain) - apply (rule corres_assert_assume[rotated], simp) - apply (simp add: getSlotCap_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_assert_assume[rotated]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_guard_imp) - apply (rule corres_split[OF threadget_fault_corres]) - apply (case_tac rv, simp_all add: fault_rel_optionation_def bind_assoc)[1] - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched - set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' - sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def - | strengthen valid_queues_in_correct_ready_q valid_sched_valid_queues - valid_queues_ready_qs_distinct)+ - apply (strengthen cte_wp_at_reply_cap_can_fast_finalise) - apply (wp hoare_vcg_conj_lift) - apply (rule hoare_strengthen_post [OF do_ipc_transfer_non_null_cte_wp_at]) - prefer 2 - apply (erule cte_wp_at_weakenE) - apply (fastforce) - apply (clarsimp simp:is_cap_simps) - apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q'="\_ s. valid_objs' s \ cur_tcb' s \ tcb_at' receiver s - \ sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp, simp add: sch_act_wf_weak) - apply (wp tcb_in_cur_domain'_lift) - defer - apply (simp) - apply (wp)+ - apply (clarsimp simp: invs_psp_aligned invs_distinct) - apply (rule conjI, erule invs_valid_objs) - apply (rule conjI, clarsimp)+ - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp) - apply (rule conjI, rule refl) - apply (fastforce) - apply (clarsimp simp: invs_def valid_sched_def valid_sched_action_def invs_psp_aligned invs_distinct) - apply (simp) - apply (auto simp: invs'_def valid_state'_def)[1] - - apply (rule corres_guard_imp) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (rule corres_split_eqr[OF getMRs_corres]) - apply (simp(no_asm) del: dc_simp) - apply (rule corres_split_eqr[OF handleFaultReply_corres]) - apply simp - apply (rule corres_split) - apply (rule threadset_corresT; - clarsimp simp add: tcb_relation_def fault_rel_optionation_def cteSizeBits_def - tcb_cap_cases_def tcb_cte_cases_def inQ_def) - apply (rule_tac Q="valid_sched and cur_tcb and tcb_at receiver and pspace_aligned and pspace_distinct" - and Q'="tcb_at' receiver and cur_tcb' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and valid_objs' - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_guard_imp) - apply (case_tac rvb, simp_all)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (fold dc_def, rule possibleSwitchTo_corres) - apply simp - apply (wp hoare_weak_lift_imp hoare_weak_lift_imp_conj set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' - | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ - apply (rule corres_guard_imp) - apply (rule setThreadState_corres) - apply (clarsimp simp: tcb_relation_def) - apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched - threadSet_tcbDomain_triv threadSet_valid_objs' - threadSet_sched_pointers threadSet_valid_sched_pointers - | simp add: valid_tcb_state'_def)+ - apply (rule_tac Q'="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and - valid_objs and pspace_aligned and pspace_distinct" - in hoare_strengthen_post [rotated], clarsimp) - apply (wp) - apply (rule hoare_chain [OF cap_delete_one_invs]) - apply (assumption) - apply (rule conjI, clarsimp) - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def) - apply (rule_tac Q'="\_. tcb_at' sender and tcb_at' receiver and invs'" - in hoare_strengthen_post [rotated]) - apply (solves\auto simp: invs'_def valid_state'_def\) - apply wp - apply clarsimp - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp simp add: can_fast_finalise_def) - apply (erule(1) emptyable_cte_wp_atD) - apply (rule allI, rule impI) - apply (clarsimp simp add: is_master_reply_cap_def) - apply (clarsimp) - done - -(* when we cannot talk about reply cap rights explicitly (for instance, when a schematic ?rights - would be generated too early *) -lemma doReplyTransfer_corres': - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at (is_reply_cap_to receiver) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - using doReplyTransfer_corres[of receiver sender _ slot] - by (fastforce simp add: cte_wp_at_reply_cap_to_ex_rights corres_underlying_def) - -lemma valid_pspace'_splits[elim!]: (* FIXME AARCH64: clean up duplicates *) - "valid_pspace' s \ valid_objs' s" - "valid_pspace' s \ pspace_aligned' s" - "valid_pspace' s \ pspace_distinct' s" - "valid_pspace' s \ valid_mdb' s" - "valid_pspace' s \ no_0_obj' s" - by (simp add: valid_pspace'_def)+ - -lemma sts_valid_pspace_hangers: - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. valid_objs'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_distinct'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_aligned'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_canonical'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. valid_mdb'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. no_0_obj'\" - by (safe intro!: hoare_strengthen_post [OF sts'_valid_pspace'_inv]) - -declare no_fail_getSlotCap [wp] - -lemma setupCallerCap_corres: - "corres dc - (st_tcb_at (Not \ halted) sender and tcb_at receiver and - st_tcb_at (Not \ awaiting_reply) sender and valid_reply_caps and - valid_objs and pspace_distinct and pspace_aligned and valid_mdb - and valid_list and valid_arch_state and - valid_reply_masters and cte_wp_at (\c. c = cap.NullCap) (receiver, tcb_cnode_index 3)) - (tcb_at' sender and tcb_at' receiver and valid_pspace' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) - (setup_caller_cap sender receiver grant) - (setupCallerCap sender receiver grant)" - supply if_split[split del] - apply (simp add: setup_caller_cap_def setupCallerCap_def - getThreadReplySlot_def locateSlot_conv - getThreadCallerSlot_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split_nor) - apply (rule setThreadState_corres) - apply (simp split: option.split) - apply (rule corres_symb_exec_r) - apply (rule_tac F="\r. cteCap masterCTE = capability.ReplyCap sender True r - \ mdbNext (cteMDBNode masterCTE) = nullPointer" - in corres_gen_asm2, clarsimp simp add: isCap_simps) - apply (rule corres_symb_exec_r) - apply (rule_tac F="rv = capability.NullCap" - in corres_gen_asm2, simp) - apply (rule cteInsert_corres) - apply (simp split: if_splits) - apply (simp add: cte_map_def tcbReplySlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (simp add: cte_map_def tcbCallerSlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (rule_tac Q'="\rv. cte_at' (receiver + 2 ^ cte_level_bits * tcbCallerSlot)" - in hoare_post_add) - - apply (wp, (wp getSlotCap_wp)+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at'_def cte_at'_def) - apply (rule_tac Q'="\rv. cte_at' (sender + 2 ^ cte_level_bits * tcbReplySlot)" - in hoare_post_add) - apply (wp, (wp getCTE_wp')+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (wp sts_valid_pspace_hangers - | simp add: cte_wp_at_ctes_of)+ - apply (clarsimp simp: valid_tcb_state_def st_tcb_at_reply_cap_valid - st_tcb_at_tcb_at st_tcb_at_caller_cap_null - split: option.split) - apply (clarsimp simp: valid_tcb_state'_def valid_cap'_def capAligned_reply_tcbI) - apply (frule(1) st_tcb_at_reply_cap_valid, simp, clarsimp) - apply (clarsimp simp: cte_wp_at_ctes_of cte_wp_at_caps_of_state) - apply (drule pspace_relation_cte_wp_at[rotated, OF caps_of_state_cteD], - erule valid_pspace'_splits, clarsimp+)+ - apply (clarsimp simp: cte_wp_at_ctes_of cte_map_def tcbReplySlot_def - tcbCallerSlot_def tcb_cnode_index_def - is_cap_simps) - apply (auto intro: reply_no_descendants_mdbNext_null[OF not_waiting_reply_slot_no_descendants] - simp: cte_level_bits_def) - done - -crunch getThreadCallerSlot - for tcb_at'[wp]: "tcb_at' t" - -lemma getThreadReplySlot_tcb_at'[wp]: - "\tcb_at' t\ getThreadReplySlot tcb \\_. tcb_at' t\" - by (simp add: getThreadReplySlot_def, wp) - -lemma setupCallerCap_tcb_at'[wp]: - "\tcb_at' t\ setupCallerCap sender receiver grant \\_. tcb_at' t\" - by (simp add: setupCallerCap_def, wp hoare_drop_imp) - -crunch setupCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps) - -lemma cteInsert_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert newCap srcSlot destSlot - \\_ s. sch_act_wf (ksSchedulerAction s) s\" -by (wp sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma setupCallerCap_sch_act [wp]: - "\\s. sch_act_not t s \ sch_act_wf (ksSchedulerAction s) s\ - setupCallerCap t r g \\_ s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: setupCallerCap_def getSlotCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv) - apply (wp getCTE_wp' sts_sch_act' hoare_drop_imps hoare_vcg_all_lift) - apply clarsimp - done - -lemma possibleSwitchTo_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def threadGet_def curDomain_def - bitmap_fun_defs) - apply (wp rescheduleRequired_weak_sch_act_wf - weak_sch_act_wf_lift_linear[where f="tcbSchedEnqueue t"] - getObject_tcb_wp hoare_weak_lift_imp - | wpc)+ - apply (clarsimp simp: obj_at'_def weak_sch_act_wf_def ps_clear_def tcb_in_cur_domain'_def) - done - -lemmas transferCapsToSlots_pred_tcb_at' = - transferCapsToSlots_pres1 [OF cteInsert_pred_tcb_at'] - -crunch doIPCTransfer, possibleSwitchTo - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - (wp: mapM_wp' crunch_wps simp: zipWithM_x_mapM) - -lemma setSchedulerAction_ct_in_domain: - "\\s. ct_idle_or_in_cur_domain' s - \ p \ ResumeCurrentThread \ setSchedulerAction p - \\_. ct_idle_or_in_cur_domain'\" - by (simp add:setSchedulerAction_def | wp)+ - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - (wp: crunch_wps setSchedulerAction_ct_in_domain simp: zipWithM_x_mapM) -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" - (wp: crunch_wps constOnFailure_wp simp: crunch_simps) - -crunch possibleSwitchTo - for tcb_at'[wp]: "tcb_at' t" - (wp: crunch_wps) - -crunch possibleSwitchTo - for valid_pspace'[wp]: valid_pspace' - (wp: crunch_wps) - -lemma sendIPC_corres: -(* call is only true if called in handleSyscall SysCall, which - is always blocking. *) - assumes "call \ bl" - shows - "corres dc (einvs and st_tcb_at active t and ep_at ep and ex_nonz_cap_to t) - (invs' and sch_act_not t and tcb_at' t and ep_at' ep) - (send_ipc bl call bg cg cgr t ep) (sendIPC bl call bg cg cgr t ep)" -proof - - show ?thesis - apply (insert assms) - apply (unfold send_ipc_def sendIPC_def Let_def) - apply (case_tac bl) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\ob. ob = Endpoint rv) ep - and ex_nonz_cap_to t" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (case_tac rv) - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) - apply clarsimp - \ \concludes IdleEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) - apply clarsimp - \ \concludes SendEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (simp add: isReceive_def split del:if_split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: case_bool_If case_option_If if3_fold - simp del: dc_simp split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_split[OF possibleSwitchTo_corres]) - apply (fold when_def)[1] - apply (rule_tac P="call" and P'="call" - in corres_symmetric_bool_cases, blast) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (rule corres_if2, simp) - apply (rule setupCallerCap_corres) - apply (rule setThreadState_corres, simp) - apply (rule corres_trivial) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (wp | simp)+ - apply (wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases) - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases)[1] - apply (simp add: valid_tcb_state_def pred_conj_def) - apply (strengthen reply_cap_doesnt_exist_strg disjI2_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues)+ - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - do_ipc_transfer_valid_arch - | clarsimp simp: is_cap_simps)+)[1] - apply (simp add: pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift hoare_drop_imps)[1] - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply (simp) - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb')+ - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def ep_redux_simps - ep_redux_simps' st_tcb_at_tcb_at valid_ep_def - cong: list.case_cong) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_def2 valid_sched_def valid_sched_action_def) - apply (force simp: st_tcb_def2 dest!: st_tcb_at_caller_cap_null[simplified,rotated]) - subgoal by (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\k. k = Endpoint rv) ep" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (rename_tac rv rv') - apply (case_tac rv) - apply (simp add: ep_relation_def) - \ \concludes IdleEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - \ \concludes SendEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (rule_tac F="a \ t" in corres_req) - apply (clarsimp simp: invs_def valid_state_def - valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_def obj_at_def tcb_bound_refs_def2) - apply fastforce - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: isReceive_def case_bool_If - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (simp add: if_apply_def2) - apply ((wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases | - simp add: if_apply_def2 split del: if_split)+)[1] - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases) - apply (simp add: valid_tcb_state_def pred_conj_def) - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - | clarsimp simp: is_cap_simps - | strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues )+)[1] - apply (simp add: valid_tcb_state'_def pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear hoare_drop_imps) - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply simp - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb') - apply (clarsimp simp add: invs_def valid_state_def - valid_pspace_def ep_redux_simps ep_redux_simps' - st_tcb_at_tcb_at - cong: list.case_cong) - apply (clarsimp simp: valid_ep_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_at_caller_cap_null) - apply (fastforce simp: st_tcb_def2 valid_sched_def valid_sched_action_def) - subgoal by (auto simp: valid_ep'_def - split: list.split; - clarsimp simp: invs'_def valid_state'_def) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - done -qed - -lemmas setMessageInfo_typ_ats[wp] = typ_at_lifts [OF setMessageInfo_typ_at'] - -(* Annotation added by Simon Winwood (Thu Jul 1 20:54:41 2010) using taint-mode *) -declare tl_drop_1[simp] - -crunch cancel_ipc - for cur[wp]: "cur_tcb" - (wp: crunch_wps simp: crunch_simps) - -lemma valid_sched_weak_strg: - "valid_sched s \ weak_valid_sched_action s" - by (simp add: valid_sched_def valid_sched_action_def) - -lemma sendSignal_corres: - "corres dc (einvs and ntfn_at ep) (invs' and ntfn_at' ep) - (send_signal ep bg) (sendSignal ep bg)" - supply if_cong[cong] - apply (simp add: send_signal_def sendSignal_def Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getNotification_corres, - where - R = "\rv. einvs and ntfn_at ep and valid_ntfn rv and - ko_at (Structures_A.Notification rv) ep" and - R' = "\rv'. invs' and ntfn_at' ep and - valid_ntfn' rv' and ko_at' rv' ep"]) - defer - apply (wp get_simple_ko_ko_at get_ntfn_ko')+ - apply (simp add: invs_valid_objs)+ - apply (case_tac "ntfn_obj ntfn") - \ \IdleNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (case_tac "ntfnBoundTCB nTFN") - apply clarsimp - apply (rule corres_guard_imp[OF setNotification_corres]) - apply (clarsimp simp add: ntfn_relation_def)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_if) - apply (fastforce simp: receive_blocked_def receiveBlocked_def - thread_state_relation_def - split: Structures_A.thread_state.splits - Structures_H.thread_state.splits) - apply (rule corres_split[OF cancel_ipc_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply (clarsimp simp: thread_state_relation_def) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply wp - apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' hoare_disjI2 - cancel_ipc_cte_wp_at_not_reply_state - | strengthen invs_vobjs_strgs invs_psp_aligned_strg valid_sched_weak_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues - | simp add: valid_tcb_state_def)+ - apply (rule_tac Q'="\rv. invs' and tcb_at' a" in hoare_strengthen_post) - apply wp - apply (fastforce simp: invs'_def valid_state'_def sch_act_wf_weak valid_tcb_state'_def) - apply (rule setNotification_corres) - apply (clarsimp simp add: ntfn_relation_def) - apply (wp gts_wp gts_wp' | clarsimp)+ - apply (auto simp: valid_ntfn_def receive_blocked_def valid_sched_def invs_cur - elim: pred_tcb_weakenE - intro: st_tcb_at_reply_cap_valid - split: Structures_A.thread_state.splits)[1] - apply (clarsimp simp: valid_ntfn'_def invs'_def valid_state'_def valid_pspace'_def sch_act_wf_weak) - \ \WaitingNtfn\ - apply (clarsimp simp add: ntfn_relation_def Let_def) - apply (simp add: update_waiting_ntfn_def) - apply (rename_tac list) - apply (case_tac "tl list = []") - \ \tl list = []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper split del: if_split) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply ((wp | simp)+)[1] - apply (rule_tac Q'="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and - cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs' and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct'" - in hoare_post_imp, clarsimp simp: pred_tcb_at') - apply (wp | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (wp set_simple_ko_valid_objs set_ntfn_aligned' set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def ntfn_queued_st_tcb_at valid_sched_def - valid_sched_action_def) - apply (auto simp: valid_ntfn'_def )[1] - apply (clarsimp simp: invs'_def valid_state'_def) - - \ \tl list \ []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def split:list.splits) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply (wp cur_tcb_lift | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wpsimp wp: sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb) - apply (wp set_ntfn_aligned' set_simple_ko_valid_objs set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def neq_Nil_conv - ntfn_queued_st_tcb_at valid_sched_def valid_sched_action_def - split: option.splits) - apply (auto simp: valid_ntfn'_def neq_Nil_conv invs'_def valid_state'_def - weak_sch_act_wf_def - split: option.splits)[1] - \ \ActiveNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def combine_ntfn_badges_def - combine_ntfn_msgs_def) - apply (simp add: invs_def valid_state_def valid_ntfn_def) - apply (simp add: invs'_def valid_state'_def valid_ntfn'_def) - done - -lemma valid_Running'[simp]: - "valid_tcb_state' Running = \" - by (rule ext, simp add: valid_tcb_state'_def) - -crunch setMRs - for typ'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma possibleSwitchTo_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp threadSet_sch_act setQueue_sch_act threadGet_wp - | simp add: unless_def | wpc)+ - apply (auto simp: obj_at'_def tcb_in_cur_domain'_def) - done - -crunch possibleSwitchTo - for st_refs_of'[wp]: "\s. P (state_refs_of' s)" - (wp: crunch_wps) -crunch possibleSwitchTo - for st_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" - (wp: crunch_wps) -crunch possibleSwitchTo - for cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps) -crunch possibleSwitchTo - for objs'[wp]: valid_objs' - (wp: crunch_wps) -crunch possibleSwitchTo - for ct[wp]: cur_tcb' - (wp: cur_tcb_lift crunch_wps) - -lemma possibleSwitchTo_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) - and pspace_aligned' and pspace_distinct'\ - possibleSwitchTo t - \\rv. if_live_then_nonz_cap'\" - unfolding possibleSwitchTo_def curDomain_def - by (wpsimp wp: threadGet_wp) - -crunch possibleSwitchTo - for ifunsafe[wp]: if_unsafe_then_cap' - (wp: crunch_wps) -crunch possibleSwitchTo - for idle'[wp]: valid_idle' - (wp: crunch_wps) -crunch possibleSwitchTo - for global_refs'[wp]: valid_global_refs' - (wp: crunch_wps) -crunch possibleSwitchTo - for arch_state'[wp]: valid_arch_state' - (wp: crunch_wps) -crunch possibleSwitchTo - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: crunch_wps) -crunch possibleSwitchTo - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) -crunch possibleSwitchTo - for irq_handlers'[wp]: valid_irq_handlers' - (simp: unless_def tcb_cte_cases_def cteSizeBits_def wp: crunch_wps) -crunch possibleSwitchTo - for irq_states'[wp]: valid_irq_states' - (wp: crunch_wps) -crunch sendSignal - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps simp: crunch_simps o_def) -crunch sendSignal - for it'[wp]: "\s. P (ksIdleThread s)" - (wp: crunch_wps simp: crunch_simps) - -crunch setBoundNotification - for irqs_masked'[wp]: "irqs_masked'" - (wp: irqs_masked_lift) - -crunch sendSignal - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps getObject_inv loadObject_default_inv - simp: crunch_simps unless_def o_def - rule: irqs_masked_lift) - -lemma ct_in_state_activatable_imp_simple'[simp]: - "ct_in_state' activatable' s \ ct_in_state' simple' s" - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply (case_tac st; simp) - done - -lemma setThreadState_nonqueued_state_update: - "\\s. invs' s \ st_tcb_at' simple' t s - \ st \ {Inactive, Running, Restart, IdleThreadState} - \ (st \ Inactive \ ex_nonz_cap_to' t s) - \ (t = ksIdleThread s \ idle' st) - \ (\ runnable' st \ sch_act_simple s)\ - setThreadState st t - \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply (clarsimp simp: pred_tcb_at') - apply (rule conjI, fastforce simp: valid_tcb_state'_def) - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI) - apply clarsimp - apply (erule delta_sym_refs) - apply (fastforce split: if_split_asm) - apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) - apply fastforce - done - -lemma cteDeleteOne_reply_cap_to'[wp]: - "\ex_nonz_cap_to' p and - cte_wp_at' (\c. isReplyCap (cteCap c)) slot\ - cteDeleteOne slot - \\rv. ex_nonz_cap_to' p\" - apply (simp add: cteDeleteOne_def ex_nonz_cap_to'_def unless_def) - apply (rule bind_wp [OF _ getCTE_sp]) - apply (rule hoare_assume_pre) - apply (subgoal_tac "isReplyCap (cteCap cte)") - apply (wp hoare_vcg_ex_lift emptySlot_cte_wp_cap_other isFinalCapability_inv - | clarsimp simp: finaliseCap_def isCap_simps - | wp (once) hoare_drop_imps)+ - apply (fastforce simp: cte_wp_at_ctes_of) - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) - done - -crunch setupCallerCap, possibleSwitchTo, asUser, doIPCTransfer - for vms'[wp]: "valid_machine_state'" - (wp: crunch_wps simp: zipWithM_x_mapM_x) - -crunch cancelSignal - for nonz_cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps simp: crunch_simps) - -lemma cancelIPC_nonz_cap_to'[wp]: - "\ex_nonz_cap_to' p\ cancelIPC t \\rv. ex_nonz_cap_to' p\" - apply (simp add: cancelIPC_def getThreadReplySlot_def Let_def - capHasProperty_def) - apply (wp threadSet_cap_to' - | wpc - | simp - | clarsimp elim!: cte_wp_at_weakenE' - | rule hoare_post_imp[where Q'="\rv. ex_nonz_cap_to' p"])+ - done - - -crunch activateIdleThread, getThreadReplySlot, isFinalCapability - for nosch[wp]: "\s. P (ksSchedulerAction s)" - (simp: Let_def) - -crunch setupCallerCap, asUser, setMRs, doIPCTransfer, possibleSwitchTo - for pspace_domain_valid[wp]: "pspace_domain_valid" - (wp: crunch_wps simp: zipWithM_x_mapM_x) - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma setThreadState_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - setThreadState st t - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - unfolding setThreadState_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imps) - -lemma cancelAllIPC_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllIPC epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllIPC_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -lemma cancelAllSignals_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllSignals epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllSignals_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -crunch finaliseCapTrue_standin - for not_rct[wp]: "\s. ksSchedulerAction s \ ResumeCurrentThread" - (simp: Let_def) - -lemma cancelIPC_ResumeCurrentThread_imp_notct[wp]: - "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelIPC t - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - (is "\?PRE t'\ _ \_\") -proof - - have aipc: "\t t' ntfn. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelSignal t ntfn - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cancelSignal_def) - apply (wp)[1] - apply (wp hoare_convert_imp)+ - apply (rule_tac P="\s. ksSchedulerAction s \ ResumeCurrentThread" - in hoare_weaken_pre) - apply (wpc) - apply (wp | simp)+ - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done - have cdo: "\t t' slot. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cteDeleteOne slot - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp hoare_convert_imp | simp)+ - done - show ?thesis - apply (simp add: cancelIPC_def Let_def) - apply (wp, wpc) - prefer 4 \ \state = Running\ - apply wp - prefer 7 \ \state = Restart\ - apply wp - apply (wp)+ - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp cdo)+ - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply ((wp aipc hoare_convert_imp)+)[6] - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done +lemma sanitiseRegister_sanitise_register[Ipc_R_assms]: + "sanitiseRegister = sanitise_register" + by (rule ext)+ + (clarsimp simp add: sanitiseRegister_def sanitise_register_def cong: register.case_cong) + +lemma handleArchFaultReply_corres[Ipc_R_assms]: + "corres (=) \ \ + (handle_arch_fault_reply ft t label msg) (handleArchFaultReply (arch_fault_map ft) t label msg)" + by (clarsimp simp: handle_arch_fault_reply_def handleArchFaultReply_def + split: arch_fault.split) + +crunch getSanitiseRegisterInfo, handleArchFaultReply, handle_arch_fault_reply + for inv[Ipc_R_assms, wp]: P + +lemma ctes_of_mdbNext_parentOf[Ipc_R_assms]: + "\ ctes_of s' \ cte_map cptr \ cte_map slot; + ctes_of s' (cte_map cptr) = Some (CTE (capability.ReplyCap t master rights) n); + ctes_of s' (mdbNext (cteMDBNode cte)) = Some (CTE (capability.ReplyCap t master' rights') n'); + ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)\ + \ ctes_of s' \ cte_map cptr parentOf mdbNext (cteMDBNode cte)" + by (clarsimp simp add: parentOf_def isMDBParentOf_CTE sameRegionAs_def2 isCap_simps) + (erule subtree.cases; clarsimp simp: parentOf_def isMDBParentOf_CTE) + +crunch debugPrint + for inv[Ipc_R_assms, wp]: P + and (no_fail) no_fail[Ipc_R_assms, intro!, wp, simp] + +(* this specifically refers to the 4 message registers *) +lemma max_message_size_less_max_ipc_words[Ipc_R_assms]: + "n \ 4 + \ word_size * (word_of_nat msg_max_extra_caps + (word_of_nat msg_max_length + n)) + < max_ipc_words * word_size" + apply (simp add: msg_max_extra_caps_def msg_max_length_def max_ipc_words word_size_def) + apply (rule_tac y="0x3D8 + 8 * 4" in order_le_less_trans) + apply (rule word_plus_mono_right) + apply (rule word_mult_le_mono1'; simp) + apply simp+ + done + +end (* Arch *) + +interpretation Ipc_R?: Ipc_R +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Ipc_R_assms)?)?) qed -lemma sai_invs'[wp]: - "\invs' and ex_nonz_cap_to' ntfnptr\ - sendSignal ntfnptr badge \\y. invs'\" - unfolding sendSignal_def - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj nTFN", simp_all) - prefer 3 - apply (rename_tac list) - apply (case_tac list, - simp_all split del: if_split - add: setMessageInfo_def)[1] - apply (wp hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act])+ - apply (clarsimp simp:conj_comms) - apply (simp add: invs'_def valid_state'_def) - apply (wp valid_irq_node_lift sts_valid_objs' setThreadState_ct_not_inQ - set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' valid_dom_schedule'_lift - hoare_convert_imp [OF setNotification_nosch] - | simp split del: if_split)+ - - apply (intro conjI[rotated]; - (solves \clarsimp simp: invs'_def valid_state'_def valid_pspace'_def\)?) - apply (clarsimp simp: invs'_def valid_state'_def split del: if_split) - apply (drule(1) ct_not_in_ntfnQueue, simp+) - apply clarsimp - apply (frule ko_at_valid_objs', clarsimp) - apply simp - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def) - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_idle'_def pred_tcb_at'_def idle_tcb'_def - dest!: sym_refs_ko_atD' sym_refs_st_tcb_atD' sym_refs_obj_atD' - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply simp - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (clarsimp elim!: if_live_then_nonz_capE' simp:invs'_def valid_state'_def) - apply (drule(1) sym_refs_ko_atD') - apply (clarsimp elim!: ko_wp_at'_weakenE - intro!: refs_of_live') - apply (clarsimp split del: if_split)+ - apply (frule ko_at_valid_objs', clarsimp) - apply simp - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (frule invs_sym') - apply (drule(1) sym_refs_obj_atD') - apply (clarsimp split del: if_split cong: if_cong - simp: st_tcb_at_refs_of_rev' ep_redux_simps' ntfn_bound_refs'_def) - apply (frule st_tcb_at_state_refs_ofD') - apply (erule delta_sym_refs) - apply (fastforce simp: split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset symreftype_inverse' - split: if_split_asm) - apply (clarsimp simp:invs'_def) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def valid_state'_def) - apply simp - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (clarsimp simp:invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply simp - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (case_tac "ntfnBoundTCB nTFN", simp_all) - apply (wp set_ntfn_minor_invs') - apply (fastforce simp: valid_ntfn'_def invs'_def valid_state'_def - elim!: obj_at'_weakenE - dest!: global'_no_ex_cap) - apply (wp add: hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act] - setThreadState_nonqueued_state_update sts_st_tcb' - del: cancelIPC_simple) - apply (clarsimp | wp cancelIPC_ct')+ - apply (wp set_ntfn_minor_invs' gts_wp' | clarsimp)+ - apply (frule pred_tcb_at') - by (wp set_ntfn_minor_invs' - | rule conjI - | clarsimp elim!: st_tcb_ex_cap'' - | fastforce simp: receiveBlocked_def pred_tcb_at'_def obj_at'_def - dest!: invs_rct_ct_activatable' - split: thread_state.splits - | fastforce simp: invs'_def valid_state'_def receiveBlocked_def - valid_obj'_def valid_ntfn'_def - split: thread_state.splits - dest!: global'_no_ex_cap st_tcb_ex_cap'' ko_at_valid_objs')+ - -lemma replyFromKernel_corres: - "corres dc (tcb_at t and invs) (invs') - (reply_from_kernel t r) (replyFromKernel t r)" - apply (case_tac r) - apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def - badge_register_def badgeRegister_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres]) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split_eqr[OF setMRs_corres]) - apply clarsimp - apply (rule setMessageInfo_corres) - apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' - | clarsimp simp: invs_distinct invs_psp_aligned)+ - apply fastforce - done - -lemma rfk_invs': - "\invs' and tcb_at' t\ replyFromKernel t r \\rv. invs'\" - apply (simp add: replyFromKernel_def) - apply (cases r) - apply (wp | clarsimp)+ - done - -crunch replyFromKernel - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma completeSignal_corres: - "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and valid_objs and pspace_distinct) - (ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' and obj_at' isActive ntfnptr) - (complete_signal ntfnptr tcb) (completeSignal ntfnptr tcb)" - apply (simp add: complete_signal_def completeSignal_def) - apply (rule corres_guard_imp) - apply (rule_tac R'="\ntfn. ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' - and valid_ntfn' ntfn and (\_. isActive ntfn)" - in corres_split[OF getNotification_corres]) - apply (rule corres_gen_asm2) - apply (case_tac "ntfn_obj rv") - apply (clarsimp simp: ntfn_relation_def isActive_def - split: ntfn.splits Structures_H.notification.splits)+ - apply (rule corres_guard2_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres setNotification_corres]) - apply (clarsimp simp: ntfn_relation_def) - apply (wp set_simple_ko_valid_objs get_simple_ko_wp getNotification_wp | clarsimp simp: valid_ntfn'_def)+ - apply (clarsimp simp: valid_pspace'_def) - apply (frule_tac P="(\k. k = ntfn)" in obj_at_valid_objs', assumption) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def obj_at'_def) - done - - -lemma doNBRecvFailedTransfer_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ - (do_nbrecv_failed_transfer thread) - (doNBRecvFailedTransfer thread)" - unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def - by (simp add: badgeRegister_def badge_register_def, rule asUser_setRegister_corres) - -lemma receiveIPC_corres: - assumes "is_ep_cap cap" and "cap_relation cap cap'" - shows " - corres dc (einvs and valid_sched and tcb_at thread and valid_cap cap and ex_nonz_cap_to thread - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3)) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_ipc thread cap isBlocking) (receiveIPC thread cap' isBlocking)" - apply (insert assms) - apply (simp add: receive_ipc_def receiveIPC_def - split del: if_split) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 right) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getBoundNotification_corres]) - apply (rule_tac r'="ntfn_relation" in corres_split) - apply (rule corres_option_split[rotated 2]) - apply (rule getNotification_corres) - apply clarsimp - apply (rule corres_trivial, simp add: ntfn_relation_def default_notification_def - default_ntfn_def) - apply (rule corres_if) - apply (clarsimp simp: ntfn_relation_def Ipc_A.isActive_def Endpoint_H.isActive_def - split: Structures_A.ntfn.splits Structures_H.notification.splits) - apply clarsimp - apply (rule completeSignal_corres) - apply (rule_tac P="einvs and valid_sched and tcb_at thread and - ep_at word1 and valid_ep ep and - obj_at (\k. k = Endpoint ep) word1 - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3) - and ex_nonz_cap_to thread" and - P'="invs' and tcb_at' thread and ep_at' word1 and - valid_ep' epa" - in corres_inst) - apply (case_tac ep) - \ \IdleEP\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def - valid_tcb_state_def st_tcb_at_tcb_at) - apply auto[1] - \ \SendEP\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (clarsimp simp: valid_ep_def) - apply (case_tac list, simp_all split del: if_split)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (case_tac lista, simp_all add: ep_relation_def)[1] - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. - sender_state = - Structures_A.thread_state.BlockedOnSend word1 data" - in corres_gen_asm) - apply (clarsimp simp: isSend_def case_bool_If - case_option_If if3_fold - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (simp split del: if_split cong: if_cong) - apply (fold dc_def)[1] - apply (rule_tac P="valid_objs and valid_mdb and valid_list and valid_arch_state - and valid_sched - and cur_tcb - and valid_reply_caps - and pspace_aligned and pspace_distinct - and st_tcb_at (Not \ awaiting_reply) a - and st_tcb_at (Not \ halted) a - and tcb_at thread and valid_reply_masters - and cte_wp_at (\c. c = cap.NullCap) - (thread, tcb_cnode_index 3)" - and P'="tcb_at' a and tcb_at' thread and cur_tcb' - and valid_pspace' - and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_guard_imp [OF corres_if]) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_if2 [OF _ setupCallerCap_corres setThreadState_corres]) - apply simp - apply simp - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wpsimp wp: sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (fastforce simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) - apply (clarsimp split: if_split_asm) - apply (clarsimp | wp do_ipc_transfer_tcb_caps do_ipc_transfer_valid_arch)+ - apply (rule_tac Q'="\_ s. sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp) - apply (fastforce elim: sch_act_wf_weak) - apply (wp sts_st_tcb' gts_st_tcb_at | simp)+ - apply (simp cong: list.case_cong) - apply wp - apply simp - apply (wp weak_sch_act_wf_lift_linear setEndpoint_valid_mdb' set_ep_valid_objs') - apply (clarsimp split: list.split) - apply (clarsimp simp add: invs_def valid_state_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_ep_def valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ko. ko = Endpoint e" for e]) - apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) - apply (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split)[1] - \ \RecvEP\ - apply (simp add: ep_relation_def) - apply (rule_tac corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (clarsimp simp: valid_tcb_state_def invs_distinct) - apply (clarsimp simp add: valid_tcb_state'_def) - apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' - hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift - | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ - apply (clarsimp simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def - valid_obj_def valid_tcb_def valid_bound_ntfn_def invs_distinct - dest!: invs_valid_objs - elim!: obj_at_valid_objsE - split: option.splits) - apply clarsimp - apply (auto simp: valid_cap'_def invs_valid_pspace' valid_obj'_def valid_tcb'_def - valid_bound_ntfn'_def obj_at'_def pred_tcb_at'_def - dest!: invs_valid_objs' obj_at_valid_objs' - split: option.splits)[1] - done - -lemma receiveSignal_corres: - "\ is_ntfn_cap cap; cap_relation cap cap' \ \ - corres dc (invs and st_tcb_at active thread and valid_cap cap and ex_nonz_cap_to thread) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" - apply (simp add: receive_signal_def receiveSignal_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 rights) - apply (rule corres_guard_imp) - apply (rule_tac R="\rv. invs and tcb_at thread and st_tcb_at active thread and - ntfn_at word1 and ex_nonz_cap_to thread and - valid_ntfn rv and - obj_at (\k. k = Notification rv) word1" and - R'="\rv'. invs' and tcb_at' thread and ntfn_at' word1 and - valid_ntfn' rv'" - in corres_split[OF getNotification_corres]) - apply clarsimp - apply (case_tac "ntfn_obj rv") - \ \IdleNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres; simp) - apply (clarsimp simp: invs_distinct) - apply simp - \ \WaitingNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp) - apply (rule doNBRecvFailedTransfer_corres; simp) - apply (clarsimp simp: invs_distinct)+ - \ \ActiveNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (fastforce simp: invs_def valid_state_def valid_pspace_def - elim!: st_tcb_weakenE) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply wp+ - apply (clarsimp simp add: ntfn_at_def2 valid_cap_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_cap'_def) - done - -lemma tg_sp': - "\P\ threadGet f p \\t. obj_at' (\t'. f t' = t) p and P\" - including no_pre - apply (simp add: threadGet_def) - apply wp - apply (rule hoare_strengthen_post) - apply (rule getObject_tcb_sp) - apply clarsimp - apply (erule obj_at'_weakenE) - apply simp - done +context Arch begin arch_global_naming -declare lookup_cap_valid' [wp] - -lemma sendFaultIPC_corres: - "valid_fault f \ fr f f' \ - corres (fr \ dc) - (einvs and st_tcb_at active thread and ex_nonz_cap_to thread) - (invs' and sch_act_not thread and tcb_at' thread) - (send_fault_ipc thread f) (sendFaultIPC thread f')" - apply (simp add: send_fault_ipc_def sendFaultIPC_def - liftE_bindE Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="\fh fh'. fh = to_bl fh'"]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_cap_fault) - apply (rule lookup_cap_corres, rule refl) - apply (rule_tac P="einvs and st_tcb_at active thread - and valid_cap handler_cap and ex_nonz_cap_to thread" - and P'="invs' and tcb_at' thread and sch_act_not thread - and valid_cap' handlerCap" - in corres_inst) - apply (case_tac handler_cap, - simp_all add: isCap_defs lookup_failure_map_def - case_bool_If If_rearrage - split del: if_split cong: if_cong)[1] - apply (rule corres_guard_imp) - apply (rule corres_if2 [OF refl]) - apply (simp add: dc_def[symmetric]) - apply (rule corres_split[OF threadset_corres sendIPC_corres], simp_all)[1] - apply (simp add: tcb_relation_def fault_rel_optionation_def inQ_def)+ - apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state - thread_set_typ_at ep_at_typ_at ex_nonz_cap_to_pres - thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched - | simp add: tcb_cap_cases_def)+ - apply ((wp threadSet_invs_trivial threadSet_tcb' - | simp add: tcb_cte_cases_def - | wp (once) sch_act_sane_lift)+)[1] - apply (rule corres_trivial, simp add: lookup_failure_map_def) - apply (clarsimp simp: st_tcb_at_tcb_at split: if_split) - apply (clarsimp simp: valid_cap_def invs_distinct) - apply (clarsimp simp: valid_cap'_def inQ_def) - apply auto[1] - apply (clarsimp simp: lookup_failure_map_def) - apply wp+ - apply (fastforce elim: st_tcb_at_tcb_at) - apply fastforce - done - -lemma gets_the_noop_corres: - assumes P: "\s. P s \ f s \ None" - shows "corres dc P P' (gets_the f) (return x)" - apply (clarsimp simp: corres_underlying_def gets_the_def - return_def gets_def bind_def get_def) - apply (clarsimp simp: assert_opt_def return_def dest!: P) - done - -lemma handleDoubleFault_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) - \ - (handle_double_fault thread f ft) - (handleDoubleFault thread f' ft')" - apply (rule corres_cross_over_guard[where Q="tcb_at' thread"]) - apply (fastforce intro!: tcb_at_cross) - apply (simp add: handle_double_fault_def handleDoubleFault_def) - apply (rule corres_guard_imp) - apply (subst bind_return [symmetric], - rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_noop2) - apply (simp add: exs_valid_def return_def) - apply (rule hoare_eq_P) - apply wp - apply (rule asUser_inv) - apply (rule getRestartPC_inv) - apply (wp no_fail_getRestartPC)+ - apply (wp|simp)+ - done - -crunch sendFaultIPC - for tcb'[wp]: "tcb_at' t" (wp: crunch_wps) - -crunch receiveIPC - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveIPC_typ_ats[wp] = typ_at_lifts [OF receiveIPC_typ_at'] - -crunch receiveSignal - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveAIPC_typ_ats[wp] = typ_at_lifts [OF receiveSignal_typ_at'] - -crunch setupCallerCap - for aligned'[wp]: "pspace_aligned'" - (wp: crunch_wps) -crunch setupCallerCap - for distinct'[wp]: "pspace_distinct'" - (wp: crunch_wps) -crunch setupCallerCap - for cur_tcb[wp]: "cur_tcb'" - (wp: crunch_wps) - -lemma setupCallerCap_state_refs_of[wp]: - "\\s. P ((state_refs_of' s) (sender := {r \ state_refs_of' s sender. snd r = TCBBound}))\ - setupCallerCap sender rcvr grant - \\rv s. P (state_refs_of' s)\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp hoare_drop_imps) - apply (simp add: fun_upd_def cong: if_cong) - done - -lemma setupCallerCap_state_hyp_refs_of[wp]: - "setupCallerCap sender rcvr canGrant \\s. P (state_hyp_refs_of' s)\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def) - apply (wp hoare_drop_imps) - done - -lemma is_derived_ReplyCap' [simp]: - "\m p g. is_derived' m p (capability.ReplyCap t False g) = - (\c. \ g. c = capability.ReplyCap t True g)" - apply (subst fun_eq_iff) - apply clarsimp - apply (case_tac x, simp_all add: is_derived'_def isCap_simps - badge_derived'_def - vs_cap_ref'_def) - done - -lemma unique_master_reply_cap': - "\c t. isReplyCap c \ capReplyMaster c \ capTCBPtr c = t \ - (\g . c = capability.ReplyCap t True g)" - by (fastforce simp: isCap_simps conj_comms) - -lemma getSlotCap_cte_wp_at: - "\\\ getSlotCap sl \\rv. cte_wp_at' (\c. cteCap c = rv) sl\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -lemma setupCallerCap_vp[wp]: - "\valid_pspace' and tcb_at' sender and tcb_at' rcvr\ - setupCallerCap sender rcvr grant \\rv. valid_pspace'\" - apply (simp add: valid_pspace'_def setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv getSlotCap_def) - apply (wp getCTE_wp) - apply (rule_tac Q'="\_. valid_pspace' and - tcb_at' sender and tcb_at' rcvr" - in hoare_post_imp) - apply (clarsimp simp: valid_cap'_def o_def cte_wp_at_ctes_of isCap_simps - valid_pspace'_def) - apply (frule(1) ctes_of_valid', simp add: valid_cap'_def capAligned_def) - apply clarsimp - apply (wp | simp add: valid_pspace'_def valid_tcb_state'_def)+ - done - -declare haskell_assert_inv[wp del] - -lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_live_then_nonz_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - -lemma setupCallerCap_ifunsafe[wp]: - "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_unsafe_then_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) - apply (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - apply (rule_tac Q'="\rv. valid_objs' and tcb_at' rcvr and ex_nonz_cap_to' rcvr" - in hoare_post_imp) - apply (clarsimp simp: ex_nonz_tcb_cte_caps' tcbCallerSlot_def - objBits_def objBitsKO_def dom_def cte_level_bits_def) - apply (wp sts_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb_state'_def)+ - done - -lemma setupCallerCap_global_refs'[wp]: - "\valid_global_refs'\ - setupCallerCap sender rcvr grant - \\rv. valid_global_refs'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp - | wp (once) hoare_vcg_imp_lift' hoare_vcg_ex_lift | clarsimp simp: cte_wp_at_ctes_of)+ - -crunch setupCallerCap - for valid_arch'[wp]: "valid_arch_state'" - (wp: hoare_drop_imps) - -crunch setupCallerCap - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: hoare_drop_imps) - -lemma setupCallerCap_irq_handlers'[wp]: - "\valid_irq_handlers'\ - setupCallerCap sender rcvr grant - \\rv. valid_irq_handlers'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp hoare_drop_imps | simp)+ - -lemma cteInsert_cap_to': - "\ex_nonz_cap_to' p and cte_wp_at' (\c. cteCap c = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_nonz_cap_to' p\" - supply if_cong[cong] - apply (simp add: cteInsert_def ex_nonz_cap_to'_def updateCap_def setUntypedCapAsFull_def) - apply (wpsimp wp: updateMDB_weak_cte_wp_at setCTE_weak_cte_wp_at hoare_vcg_ex_lift - | rule hoare_drop_imps - | wp getCTE_wp)+ (* getCTE_wp is separate to apply it only to the last one *) - apply (rule_tac x=cref in exI) - apply (fastforce simp: cte_wp_at_ctes_of) - done - -crunch setExtraBadge - for cap_to'[wp]: "ex_nonz_cap_to' p" - -crunch doIPCTransfer - for cap_to'[wp]: "ex_nonz_cap_to' p" - (ignore: transferCapsToSlots - wp: crunch_wps transferCapsToSlots_pres2 cteInsert_cap_to' hoare_vcg_const_Ball_lift - simp: zipWithM_x_mapM ball_conj_distrib) - -lemma st_tcb_idle': - "\valid_idle' s; st_tcb_at' P t s\ \ - (t = ksIdleThread s) \ P IdleThreadState" - by (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - -crunch getThreadCallerSlot - for idle'[wp]: "valid_idle'" -crunch getThreadReplySlot - for idle'[wp]: "valid_idle'" - -crunch setupCallerCap - for it[wp]: "\s. P (ksIdleThread s)" - (simp: updateObject_cte_inv wp: crunch_wps) - -lemma setupCallerCap_idle'[wp]: - "\valid_idle' and valid_pspace' and - (\s. st \ ksIdleThread s \ rt \ ksIdleThread s)\ - setupCallerCap st rt gr - \\_. valid_idle'\" - by (simp add: setupCallerCap_def capRange_def | wp hoare_drop_imps)+ - -crunch setExtraBadge - for it[wp]: "\s. P (ksIdleThread s)" -crunch receiveIPC - for it[wp]: "\s. P (ksIdleThread s)" - (ignore: transferCapsToSlots - wp: transferCapsToSlots_pres2 crunch_wps hoare_vcg_const_Ball_lift - simp: crunch_simps ball_conj_distrib) - -crunch setupCallerCap - for irq_states'[wp]: valid_irq_states' - (wp: crunch_wps) - -crunch receiveIPC - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps rule: irqs_masked_lift) - -crunch getThreadCallerSlot - for ct_not_inQ[wp]: "ct_not_inQ" -crunch getThreadReplySlot - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma setupCallerCap_ct_not_inQ[wp]: - "\ct_not_inQ\ setupCallerCap sender receiver grant \\_. ct_not_inQ\" - apply (simp add: setupCallerCap_def) - apply (wp hoare_drop_imp setThreadState_ct_not_inQ) - done - -crunch copyMRs - for ksQ'[wp]: "\s. P (ksReadyQueues s)" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ksQ[wp]: "\s. P (ksReadyQueues s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -crunch doIPCTransfer - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma asUser_ct_not_inQ[wp]: - "\ct_not_inQ\ asUser t m \\rv. ct_not_inQ\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps threadSet_not_inQ | simp)+ - done - -crunch copyMRs - for ct_not_inQ[wp]: "ct_not_inQ" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ct_not_inQ[wp]: "ct_not_inQ" - (ignore: transferCapsToSlots - wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma ntfn_q_refs_no_bound_refs': "rf : ntfn_q_refs_of' (ntfnObj ob) \ rf \ ntfn_bound_refs' (ntfnBoundTCB ob')" - by (auto simp add: ntfn_q_refs_of'_def ntfn_bound_refs'_def - split: Structures_H.ntfn.splits) - -lemma completeSignal_invs: - "\invs' and tcb_at' tcb\ - completeSignal ntfnptr tcb - \\_. invs'\" - apply (simp add: completeSignal_def) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule hoare_pre) - apply (wp set_ntfn_minor_invs' | wpc | simp)+ - apply (rule_tac Q'="\_ s. (state_refs_of' s ntfnptr = ntfn_bound_refs' (ntfnBoundTCB ntfn)) - \ ntfn_at' ntfnptr s - \ valid_ntfn' (ntfnObj_update (\_. Structures_H.ntfn.IdleNtfn) ntfn) s - \ ((\y. ntfnBoundTCB ntfn = Some y) \ ex_nonz_cap_to' ntfnptr s) - \ ntfnptr \ ksIdleThread s" - in hoare_strengthen_post) - apply ((wp hoare_vcg_ex_lift hoare_weak_lift_imp | wpc | simp add: valid_ntfn'_def)+)[1] - apply (clarsimp simp: obj_at'_def state_refs_of'_def typ_at'_def ko_wp_at'_def live'_def - split: option.splits) - apply (blast dest: ntfn_q_refs_no_bound_refs') - apply wp - apply (subgoal_tac "valid_ntfn' ntfn s") - apply (subgoal_tac "ntfnptr \ ksIdleThread s") - apply (fastforce simp: valid_ntfn'_def valid_bound_tcb'_def ko_at_state_refs_ofD' live'_def - elim: obj_at'_weakenE - if_live_then_nonz_capD'[OF invs_iflive' - obj_at'_real_def[THEN meta_eq_to_obj_eq, - THEN iffD1]]) - apply (fastforce simp: valid_idle'_def pred_tcb_at'_def obj_at'_def dest!: invs_valid_idle') - apply (fastforce dest: invs_valid_objs' ko_at_valid_objs' simp: valid_obj'_def) - done - -lemma setupCallerCap_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' and tcb_at' sender\ - setupCallerCap sender t g \\rv. untyped_ranges_zero'\" - apply (simp add: setupCallerCap_def getSlotCap_def - getThreadCallerSlot_def getThreadReplySlot_def - locateSlot_conv) - apply (wp getCTE_wp') - apply (rule_tac Q'="\_. untyped_ranges_zero' and valid_mdb' and valid_objs'" in hoare_post_imp) - apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def untyped_derived_eq_def - isCap_simps) - apply (wp sts_valid_pspace_hangers) - apply (clarsimp simp: valid_tcb_state'_def) - done - -lemmas threadSet_urz = untyped_ranges_zero_lift[where f="cteCaps_of", OF _ threadSet_cteCaps_of] - -crunch doIPCTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: threadSet wp: threadSet_urz crunch_wps simp: zipWithM_x_mapM) - -crunch receiveIPC - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 simp: zipWithM_x_mapM ignore: constOnFailure) - -crunch possibleSwitchTo - for ctes_of[wp]: "\s. P (ctes_of s)" - (wp: crunch_wps ignore: constOnFailure) - -lemmas possibleSwitchToTo_cteCaps_of[wp] - = cteCaps_of_ctes_of_lift[OF possibleSwitchTo_ctes_of] - -crunch possibleSwitchTo - for ksArch[wp]: "\s. P (ksArchState s)" - (wp: possibleSwitchTo_ctes_of crunch_wps ignore: constOnFailure) - -crunch asUser - for valid_bitmaps[wp]: valid_bitmaps - (rule: valid_bitmaps_lift wp: crunch_wps) - -crunch setupCallerCap, possibleSwitchTo, doIPCTransfer - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -(* t = ksCurThread s *) -lemma ri_invs' [wp]: - "\invs' and sch_act_not t - and ct_in_state' simple' - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ - receiveIPC t cap isBlocking - \\_. invs'\" (is "\?pre\ _ \_\") - apply (clarsimp simp: receiveIPC_def) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (rule bind_wp [OF _ gbn_sp']) - apply (rule bind_wp) - (* set up precondition for old proof *) - apply (rule_tac P''="ko_at' ep (capEPPtr cap) and ?pre" in hoare_vcg_if_split) - apply (wp completeSignal_invs) - apply (case_tac ep) - \ \endpoint = RecvEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp sts_sch_act' hoare_vcg_const_Ball_lift valid_irq_node_lift valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' o_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_ep'_def - valid_obj'_def tcb_bound_refs'_def - dest!: isCapDs) - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD') - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply ((case_tac tp; fastforce elim: nonempty_cross_distinct_singleton_elim)+)[2] - apply (clarsimp split: if_split_asm) - apply (fastforce simp: valid_pspace'_def global'_no_ex_cap idle'_not_queued) - \ \endpoint = IdleEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp sts_sch_act' valid_irq_node_lift valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def o_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "t \ capEPPtr cap") - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule ko_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (clarsimp simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) - \ \endpoint = SendEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rename_tac list) - apply (case_tac list, simp_all split del: if_split) - apply (rename_tac sender queue) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift hoare_drop_imps setEndpoint_valid_mdb' - set_ep_valid_objs' sts_st_tcb' sts_sch_act' valid_dom_schedule'_lift - setThreadState_ct_not_inQ - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - setEndpoint_ksQ - | simp add: valid_tcb_state'_def case_bool_If - case_option_If - split del: if_split cong: if_cong - | wp (once) sch_act_sane_lift hoare_vcg_conj_lift hoare_vcg_all_lift - untyped_ranges_zero_lift)+ - apply (clarsimp split del: if_split simp: pred_tcb_at') - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (clarsimp simp: valid_obj'_def valid_ep'_def st_tcb_at_refs_of_rev' conj_ac - split del: if_split - cong: if_cong) - apply (subgoal_tac "sch_act_not sender s") - prefer 2 - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (drule st_tcb_at_state_refs_ofD') - apply (simp only: conj_ac(1, 2)[where Q="sym_refs R" for R]) - apply (subgoal_tac "distinct (ksIdleThread s # capEPPtr cap # t # sender # queue)") - apply (rule conjI) - apply (clarsimp simp: ep_redux_simps' cong: if_cong) - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - apply (clarsimp simp: singleton_tuple_cartesian split: list.split - | rule conjI | drule(1) bspec - | drule st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - | clarsimp elim!: if_live_state_refsE)+ - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (clarsimp simp: global'_no_ex_cap) - apply (rule conjI - | clarsimp simp: singleton_tuple_cartesian split: list.split - | clarsimp elim!: if_live_state_refsE - | clarsimp simp: global'_no_ex_cap idle'_not_queued' idle'_no_refs tcb_bound_refs'_def - | drule(1) bspec | drule st_tcb_at_state_refs_ofD' - | clarsimp simp: set_eq_subset dest!: bound_tcb_at_state_refs_ofD' )+ - apply (rule hoare_pre) - apply (wp getNotification_wp | wpc | clarsimp)+ - done - -(* t = ksCurThread s *) -lemma rai_invs'[wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) - and (\s. \ntfnptr. isNotificationCap cap - \ capNtfnPtr cap = ntfnptr - \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) - ntfnptr s)\ - receiveSignal t cap isBlocking - \\_. invs'\" - apply (simp add: receiveSignal_def) - apply (rule bind_wp [OF _ get_ntfn_sp']) - apply (rename_tac ep) - apply (case_tac "ntfnObj ep") - \ \ep = IdleNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "capNtfnPtr cap \ t") - apply (frule valid_pspace_valid_objs') - apply (frule (1) ko_at_valid_objs') - apply clarsimp - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD' bound_tcb_at_state_refs_ofD')+ - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - \ \ep = ActiveNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_valid_objs' typ_at_lifts hoare_weak_lift_imp - asUser_urz valid_dom_schedule'_lift - | simp add: valid_ntfn'_def)+ - apply (clarsimp simp: pred_tcb_at' valid_pspace'_def) - apply (frule (1) ko_at_valid_objs') - apply clarsimp - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def isCap_simps) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD')+ - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm simp: global'_no_ex_cap)+ - \ \ep = WaitingNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - setThreadState_ct_not_inQ typ_at_lifts valid_dom_schedule'_lift - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: valid_tcb_state'_def) - apply (frule_tac t=t in not_in_ntfnQueue) - apply (simp) - apply (simp) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply simp - apply (clarsimp simp: valid_obj'_def) - apply (clarsimp simp: valid_ntfn'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' - dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (rename_tac list one two three four five six seven eight nine) - apply (subgoal_tac "set list \ {NTFNSignal} \ {}") - apply safe[1] - apply (auto simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def)[5] - apply (fastforce simp: tcb_bound_refs'_def - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - done - -lemma getCTE_cap_to_refs[wp]: - "\\\ getCTE p \\rv s. \r\zobj_refs' (cteCap rv). ex_nonz_cap_to' r s\" - apply (rule hoare_strengthen_post [OF getCTE_sp]) - apply (clarsimp simp: ex_nonz_cap_to'_def) - apply (fastforce elim: cte_wp_at_weakenE') - done - -lemma lookupCap_cap_to_refs[wp]: - "\\\ lookupCap t cref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" - apply (simp add: lookupCap_def lookupCapAndSlot_def split_def - getSlotCap_def) - apply (wp | simp)+ - done - -crunch setVMRoot - for valid_objs'[wp]: valid_objs' - (wp: getASID_wp crunch_wps findVSpaceForASID_vs_at_wp - simp: getPoolPtr_def getThreadVSpaceRoot_def if_distribR) - -lemma arch_stt_objs' [wp]: - "\valid_objs'\ Arch.switchToThread t \\rv. valid_objs'\" - apply (simp add: AARCH64_H.switchToThread_def) - apply wp - done - -lemma possibleSwitchTo_sch_act_not: - "\sch_act_not t' and K (t \ t')\ possibleSwitchTo t \\rv. sch_act_not t'\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def curDomain_def) - apply (wp hoare_drop_imps | wpc | simp)+ - done - -crunch possibleSwitchTo - for urz[wp]: "untyped_ranges_zero'" - (simp: crunch_simps unless_def wp: crunch_wps) - -declare zipWithM_x_mapM[simp] (* FIXME AARCH64: remove? *) - -crunch possibleSwitchTo - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - -lemma si_invs'[wp]: - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ - sendIPC bl call ba cg cgr t ep - \\rv. invs'\" - supply if_split[split del] - supply if_cong[cong] - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (case_tac epa) - \ \epa = RecvEP\ - apply simp - apply (rename_tac list) - apply (case_tac list) - apply simp - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (rule_tac P="a\t" in hoare_gen_asm) - apply (wp valid_irq_node_lift - sts_valid_objs' set_ep_valid_objs' setEndpoint_valid_mdb' sts_st_tcb' sts_sch_act' - possibleSwitchTo_sch_act_not setThreadState_ct_not_inQ valid_dom_schedule'_lift - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - hoare_convert_imp [OF doIPCTransfer_sch_act doIPCTransfer_ct'] - hoare_convert_imp [OF setEndpoint_nosch setEndpoint_ksCurThread] - hoare_drop_imp [where f="threadGet tcbFault t"] - | rule_tac f="getThreadState a" in hoare_drop_imp - | wp (once) hoare_drop_imp[where Q'="\_ _. call"] - hoare_drop_imp[where Q'="\_ _. \ call"] - hoare_drop_imp[where Q'="\_ _. cg"] - | simp add: valid_tcb_state'_def case_bool_If - case_option_If - cong: if_cong - | wp (once) sch_act_sane_lift tcb_in_cur_domain'_lift hoare_vcg_const_imp_lift)+ - apply (clarsimp simp: pred_tcb_at' cong: conj_cong imp_cong) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (clarsimp simp: valid_obj'_def valid_ep'_def - st_tcb_at_refs_of_rev' pred_tcb_at' - conj_comms fun_upd_def[symmetric]) - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD' st_tcb_at_state_refs_ofD')+ - apply (clarsimp simp: valid_pspace'_splits) - apply (subst fun_upd_idem[where x=t]) - apply (clarsimp split: if_split) - apply (rule conjI, clarsimp simp: obj_at'_def) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def) - apply (subgoal_tac "ex_nonz_cap_to' a s") - prefer 2 - apply (clarsimp elim!: if_live_state_refsE) - apply clarsimp - apply (rule conjI) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp simp: conj_ac) - apply (rule conjI, clarsimp simp: idle'_no_refs) - apply (rule conjI, clarsimp simp: global'_no_ex_cap) - apply (rule conjI) - apply (rule impI) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (clarsimp) - apply (simp add: ep_redux_simps') - apply (rule conjI, clarsimp split: if_split) - apply (rule conjI, fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp, erule delta_sym_refs; - solves\auto simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm\) - apply (solves\clarsimp split: list.splits\) - \ \epa = IdleEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp valid_irq_node_lift valid_dom_schedule'_lift sts_sch_act' setThreadState_ct_not_inQ) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "ep \ t") - apply (drule simple_st_tcb_at_state_refs_ofD' ko_at_state_refs_ofD' - bound_tcb_at_state_refs_ofD')+ - apply (rule conjI, erule delta_sym_refs) - apply (auto simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm)[2] - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply simp - apply wp - apply simp - \ \epa = SendEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ - valid_dom_schedule'_lift) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: valid_obj'_def valid_ep'_def st_tcb_at_refs_of_rev') - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - simp: tcb_bound_refs'_def) - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - subgoal by (fastforce simp: obj_at'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap idle'_not_queued) - apply (simp | wp)+ - done - -lemma sfi_invs_plus': - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" - apply (simp add: sendFaultIPC_def) - apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state - threadSet_cap_to' - | wpc | simp)+ - apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s - \ st_tcb_at' simple' t s - \ ex_nonz_cap_to' t s - \ t \ ksIdleThread s - \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" - in hoare_strengthen_postE_R) - apply wp - apply (clarsimp simp: inQ_def pred_tcb_at') - apply (wp | simp)+ - apply (clarsimp simp: eq_commute) - apply (subst(asm) global'_no_ex_cap, auto) - done - -crunch send_fault_ipc - for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" - and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" - (simp: crunch_simps wp: crunch_wps) - -lemma handleFault_corres: - "fr f f' \ - corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread - and (\_. valid_fault f)) - (invs' and sch_act_not thread - and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) - (handle_fault thread f) (handleFault thread f')" - apply (simp add: handle_fault_def handleFault_def) - apply (rule corres_guard_imp) - apply (subst return_bind [symmetric], - rule corres_split[where P="tcb_at thread", - OF gets_the_noop_corres [where x="()"]]) - apply (simp add: tcb_at_def) - apply (rule corres_split_catch) - apply (rule_tac F="valid_fault f" in corres_gen_asm) - apply (rule sendFaultIPC_corres, assumption) - apply simp - apply (rule handleDoubleFault_corres) - apply wpsimp+ - apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def valid_state_def valid_idle_def) - apply auto - done - -lemma sts_invs_minor'': - "\st_tcb_at' (\st'. tcb_st_refs_of' st' = tcb_st_refs_of' st - \ (st \ Inactive \ \ idle' st \ - st' \ Inactive \ \ idle' st')) t - and (\s. t = ksIdleThread s \ idle' st) - and (\s. \ runnable' st \ sch_act_not t s) - and invs'\ - setThreadState st t - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply clarsimp - apply (rule conjI) - apply fastforce - apply (rule conjI) - apply (clarsimp simp: pred_tcb_at'_def) - apply (drule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def) - subgoal by (cases st, auto simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits)[1] - apply (rule conjI) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce elim!: st_tcb_ex_cap'') - done - -lemma hf_invs' [wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ - handleFault t f \\r. invs'\" - apply (simp add: handleFault_def) - apply wp - apply (simp add: handleDoubleFault_def) - apply (wp sts_invs_minor'' dmo_invs')+ - apply (rule hoare_strengthen_postE, rule sfi_invs_plus', - simp_all) - apply (strengthen no_refs_simple_strg') - apply clarsimp - done - -declare zipWithM_x_mapM [simp del] - -lemma gts_st_tcb': - "\\\ getThreadState t \\r. st_tcb_at' (\st. st = r) t\" - apply (rule hoare_strengthen_post) - apply (rule gts_sp') - apply simp - done - -lemma setupCallerCap_pred_tcb_unchanged: - "\pred_tcb_at' proj P t and K (t \ t')\ - setupCallerCap t' t'' g - \\rv. pred_tcb_at' proj P t\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp sts_pred_tcb_neq' hoare_drop_imps) - apply clarsimp - done - -lemma si_blk_makes_simple': - "\st_tcb_at' simple' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' simple' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_drop_imps) - apply (clarsimp simp: pred_tcb_at' del: disjCI) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -lemma si_blk_makes_runnable': - "\st_tcb_at' runnable' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' runnable' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_vcg_const_imp_lift hoare_drop_imps - | simp)+ - apply (clarsimp del: disjCI simp: pred_tcb_at' elim!: pred_tcb'_weakenE) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -lemma sfi_makes_simple': - "\st_tcb_at' simple' t and K (t \ t')\ - sendFaultIPC t' ft - \\rv. st_tcb_at' simple' t\" - apply (rule hoare_gen_asm) - apply (simp add: sendFaultIPC_def - cong: if_cong capability.case_cong bool.case_cong) - apply (wpsimp wp: si_blk_makes_simple' threadSet_pred_tcb_no_state hoare_drop_imps - hoare_vcg_all_liftE_R) - done - -lemma sfi_makes_runnable': - "\st_tcb_at' runnable' t and K (t \ t')\ - sendFaultIPC t' ft - \\rv. st_tcb_at' runnable' t\" - apply (rule hoare_gen_asm) - apply (simp add: sendFaultIPC_def - cong: if_cong capability.case_cong bool.case_cong) - apply (wpsimp wp: si_blk_makes_runnable' threadSet_pred_tcb_no_state hoare_drop_imps - hoare_vcg_all_liftE_R) - done - -lemma hf_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - handleFault t ft - \\rv. st_tcb_at' P t'\" - apply (safe intro!: hoare_gen_asm) - apply (simp_all add: handleFault_def handleDoubleFault_def) - apply (wp sfi_makes_runnable' sfi_makes_simple' sts_st_tcb_at'_cases - | simp add: handleDoubleFault_def)+ - done - -crunch possibleSwitchTo, completeSignal - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - -lemma ri_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveIPC t cap isBlocking - \\rv. st_tcb_at' P t'\" - including no_pre - apply (rule hoare_gen_asm)+ - apply (simp add: receiveIPC_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (rule bind_wp [OF _ gbn_sp']) - apply wp - apply (rename_tac ep q r) - apply (case_tac ep, simp_all) - apply (wp sts_st_tcb_at'_cases | wpc | simp add: doNBRecvFailedTransfer_def)+ - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_vcg_const_imp_lift)+ - apply (simp, simp only: imp_conv_disj) - apply (wp hoare_vcg_disj_lift)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def isSend_def - split: Structures_H.thread_state.split_asm) - apply (rule hoare_pre) - apply wpsimp+ - done - -lemma rai_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveSignal t cap isBlocking - \\rv. st_tcb_at' P t'\" - apply (rule hoare_gen_asm) - apply (simp add: receiveSignal_def) - apply (rule hoare_pre) - by (wp sts_st_tcb_at'_cases getNotification_wp | wpc | simp add: doNBRecvFailedTransfer_def)+ - -lemma sendSignal_st_tcb'_Running: - "\st_tcb_at' (\st. st = Running \ P st) t\ - sendSignal ntfnptr bdg - \\_. st_tcb_at' (\st. st = Running \ P st) t\" - apply (simp add: sendSignal_def) - apply (wp sts_st_tcb_at'_cases cancelIPC_st_tcb_at' gts_wp' getNotification_wp hoare_weak_lift_imp - | wpc | clarsimp simp: pred_tcb_at')+ - done - -lemma sai_st_tcb': - "\st_tcb_at' P t and K (P Running)\ - sendSignal ntfn bdg - \\rv. st_tcb_at' P t\" - apply (rule hoare_gen_asm) - apply (subgoal_tac "\Q. P = (\st. st = Running \ Q st)") - apply (clarsimp intro!: sendSignal_st_tcb'_Running) - apply (fastforce intro!: exI[where x=P]) - done +lemma is_derived_mask'[simp]: + "is_derived' m p (maskCapRights R c) = is_derived' m p c" + by (rule ext, simp add: is_derived'_def badge_derived'_def) -end +end (* Arch *) end diff --git a/proof/refine/AARCH64/ArchKHeap_R.thy b/proof/refine/AARCH64/ArchKHeap_R.thy index 23193204a1..945b8a0d59 100644 --- a/proof/refine/AARCH64/ArchKHeap_R.thy +++ b/proof/refine/AARCH64/ArchKHeap_R.thy @@ -314,6 +314,11 @@ lemma pspace_in_kernel_mappings'_wp[wp]: unfolding pspace_in_kernel_mappings'_def by wp +(* only on arches without kernel mappings, used for arch interface assumptions *) +lemma pspace_in_kernel_mappings'_inv: + "f \pspace_in_kernel_mappings'\" + by wp + lemma setEndpoint_pspace_in_kernel_mappings'[KHeap_R_assms]: "setEndpoint p ko \pspace_in_kernel_mappings'\" by wp diff --git a/proof/refine/AARCH64/ArchTcbAcc_R.thy b/proof/refine/AARCH64/ArchTcbAcc_R.thy index 9d49188acc..94db3486bd 100644 --- a/proof/refine/AARCH64/ArchTcbAcc_R.thy +++ b/proof/refine/AARCH64/ArchTcbAcc_R.thy @@ -497,6 +497,7 @@ lemma asUser_valid_objs[wp]: simp: valid_tcb'_def tcb_cte_cases_def valid_arch_tcb'_def cteSizeBits_def atcbContextSet_def)+ +(* interface lemma, but can't be done via locale *) lemma asUser_valid_pspace'[wp]: "\valid_pspace'\ asUser t m \\rv. valid_pspace'\" apply (simp add: asUser_def) @@ -504,11 +505,13 @@ lemma asUser_valid_pspace'[wp]: simp: atcbContextSet_def valid_arch_tcb'_def)+ done +(* interface lemma, but can't be done via locale *) lemma asUser_st_hyp_refs_of'[wp]: "asUser t m \\s. P (state_hyp_refs_of' s)\" unfolding asUser_def by (wpsimp wp: threadSet_state_hyp_refs_of' hoare_drop_imps simp: atcbContextSet_def) +(* interface lemma, but can't be done via locale *) lemma asUser_iflive'[wp]: "asUser t m \if_live_then_nonz_cap'\ " unfolding asUser_def @@ -872,7 +875,7 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms -lemma setMRs_corres: +lemma setMRs_corres[TcbAcc_R_3_assms]: assumes m: "mrs' = mrs" shows "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) @@ -959,6 +962,13 @@ lemma asUser_invs[wp]: crunch storeWordUser for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" +lemma set_mrs_invs'[TcbAcc_R_3_assms, wp]: + "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" + apply (simp add: setMRs_def) + apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| + simp add: zipWithM_x_mapM split_def)+ + done + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -977,10 +987,16 @@ arch_requalify_facts asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' lemmas [wp] = asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' end diff --git a/proof/refine/AARCH64/ArchVSpace_R.thy b/proof/refine/AARCH64/ArchVSpace_R.thy index c0a37c62fd..78f2187194 100644 --- a/proof/refine/AARCH64/ArchVSpace_R.thy +++ b/proof/refine/AARCH64/ArchVSpace_R.thy @@ -1952,14 +1952,6 @@ definition lemmas setMRs_typ_at_lifts[wp] = typ_at_lifts[OF setMRs_typ_at'] -(* FIXME arch-split: interface? *) -lemma set_mrs_invs'[wp]: - "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" - apply (simp add: setMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| - simp add: zipWithM_x_mapM split_def)+ - done - crunch unmapPage for cte_at'[wp]: "cte_at' p" (wp: crunch_wps simp: crunch_simps) diff --git a/proof/refine/Bits_R.thy b/proof/refine/Bits_R.thy index 3d407545dc..299666dc69 100644 --- a/proof/refine/Bits_R.thy +++ b/proof/refine/Bits_R.thy @@ -16,13 +16,24 @@ crunch_ignore (add: emptyOnFailure unifyFailure maskInterrupt clearMemory clearMemoryVM assertDerived setObject getObject updateObject loadObject) +(* FIXME: move to WordLib *) +lemma word_of_nat_word_size[simp]: + "word_of_nat word_size = word_size" + by (simp add: word_size_def) + (* same derivation on all architectures *) lemma (in Arch) wordBits_word_bits: "wordBits = word_bits" by (simp add: wordBits_def' word_bits_def) - requalify_facts Arch.wordBits_word_bits +(* same derivation on all architectures *) +lemma (in Arch) wordSize_word_size: + "wordSize = word_size" + unfolding wordSize_def word_size_def wordBits_word_bits + by (simp add: word_bits_def) +requalify_facts Arch.wordSize_word_size + lemma throwE_R: "\\\ throw f \P\,-" by (simp add: validE_R_def) wp @@ -343,7 +354,7 @@ lemmas unifyFailure_injection_corres lemmas unifyFailure_discard = unifyFailure_injection_corres [OF id_injection, simplified] -lemmas unifyFailure_wp = injection_wp [OF unifyFailure_injection] +lemmas unifyFailure_wp[wp] = injection_wp[OF unifyFailure_injection] lemmas unifyFailure_wp_E[wp] = injection_wp_E [OF unifyFailure_injection] @@ -502,7 +513,7 @@ lemma corres_const_on_failure: apply simp+ done -lemma constOnFailure_wp : +lemma constOnFailure_wp[wp]: "\P\ m \Q\, \\rv. Q n\ \ \P\ constOnFailure n m \Q\" apply (simp add: constOnFailure_def const_def) apply (wp|simp)+ diff --git a/proof/refine/CSpace_I.thy b/proof/refine/CSpace_I.thy index 5e500af7ff..9cd70e5eff 100644 --- a/proof/refine/CSpace_I.thy +++ b/proof/refine/CSpace_I.thy @@ -796,8 +796,9 @@ locale CSpace_I_2 = CSpace_I + assumes cte_refs_capRange: "\s c x. \ s \' c; \irq. c \ IRQHandlerCap irq \ \ cte_refs' c x \ capRange c" - -context CSpace_I_2 begin + assumes capBadge_maskCapRights[simp]: + "\msk cap. capBadge (maskCapRights msk cap) = capBadge cap" +begin lemma isMDBParent_Null[simp]: "isMDBParentOf c (CTE NullCap m) = False" diff --git a/proof/refine/CSpace_R.thy b/proof/refine/CSpace_R.thy index 09e567f306..becbc5cbe0 100644 --- a/proof/refine/CSpace_R.thy +++ b/proof/refine/CSpace_R.thy @@ -3291,7 +3291,8 @@ lemma deriveCap_valid[wp]: end (* CSpace_R *) -lemma lookup_cap_valid': +(* FIXME: poor name, eliminate as wp argument *) +lemma lookup_cap_valid'[wp]: "\valid_objs'\ lookupCap t c \valid_cap'\, -" apply (simp add: lookupCap_def lookupCapAndSlot_def lookupSlotForThread_def split_def) @@ -3684,6 +3685,25 @@ locale CSpace_R_2 = CSpace_R + \is_simple_cap' c'; safe_parent_for' m p c'; m p = Some cte; cteCap cte = (maskedAsFull src_cap' a)\ \ isCapRevocable c' (maskedAsFull src_cap' a) = isCapRevocable c' src_cap'" + assumes deriveCap_derived: + "\c' slot. + \\s. c'\ capability.NullCap \ cte_wp_at' (\cte. badge_derived' c' (cteCap cte) + \ capASID c' = capASID (cteCap cte) + \ cap_asid_base' c' = cap_asid_base' (cteCap cte) + \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s + \ valid_objs' s\ + deriveCap slot c' + \\rv s. rv \ NullCap \ + cte_wp_at' (is_derived' (ctes_of s) slot rv \ cteCap) slot s\, -" + assumes arch_deriveCap_untyped_derived[wp]: + "\c' slot. + \\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ + Arch.deriveCap slot (capCap c') + \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" + assumes ex_nonz_tcb_cte_caps': + "\t s sl. + \ex_nonz_cap_to' t s; tcb_at' t s; valid_objs' s; sl \ dom tcb_cte_cases\ \ + ex_cte_cap_to' (t + sl) s" begin (* this locale should satisfy all the assumptions of mdb_insert_simple_gen, so we can treat it like @@ -3731,6 +3751,15 @@ lemma setupReplyMaster_corres: apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) done +lemma deriveCap_untyped_derived: + "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ + deriveCap slot c' + \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" + apply (simp add: global.deriveCap_def split del: if_split cong: if_cong) + apply (wpsimp wp: arch_deriveCap_inv simp: o_def untyped_derived_eq_ArchObjectCap) + apply (clarsimp simp: cte_wp_at_ctes_of gen_isCap_simps untyped_derived_eq_def) + done + end (* CSpace_R_2 *) crunch setupReplyMaster @@ -5063,7 +5092,7 @@ lemma updateFreeIndex_forward_valid_mdb': auto simp add: gen_isCap_simps valid_cap_simps' capAligned_def) done -lemma no_fail_getSlotCap: +lemma no_fail_getSlotCap[wp]: "no_fail (cte_at' p) (getSlotCap p)" apply (rule no_fail_pre) apply (simp add: getSlotCap_def | wp)+ @@ -5114,6 +5143,9 @@ locale CSpace_R_3 = CSpace_R_2 + \ (capMasterCap c' = capMasterCap d') = (cap_master_cap c = cap_master_cap d)" assumes updateMDB_pspace_in_kernel_mappings'[wp]: "\x f. updateMDB x f \pspace_in_kernel_mappings'\" + assumes derived'_not_Null[simp]: + "\m p c. \ is_derived' m p c capability.NullCap" + "\m p c. \ is_derived' m p capability.NullCap c" begin lemma cteInsert_simple_mdb': diff --git a/proof/refine/Ipc_R.thy b/proof/refine/Ipc_R.thy index 19201b2f12..7da74ace87 100644 --- a/proof/refine/Ipc_R.thy +++ b/proof/refine/Ipc_R.thy @@ -9,26 +9,103 @@ theory Ipc_R imports ArchFinalise_R begin -context begin interpretation Arch . (*FIXME: arch-split*) +(* FIXME arch-split: sendSignal_def already leaks that this is an OR *) +arch_requalify_facts (A) combine_ntfn_badges_def (* Machine_AI *) -lemmas lookup_slot_wrapper_defs'[simp] = - lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def +(* FIXME arch-split: this is return () on all architectures *) +arch_requalify_consts (H) activateIdleThread +arch_requalify_facts (H) activateIdleThread_def -lemma getMessageInfo_corres: "corres ((=) \ message_info_map) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (get_message_info t) (getMessageInfo t)" - apply (rule corres_guard_imp) - apply (unfold get_message_info_def getMessageInfo_def fun_app_def) - apply (simp add: AARCH64_H.msgInfoRegister_def - AARCH64.msgInfoRegister_def AARCH64_A.msg_info_register_def) - apply (rule corres_split_eqr[OF asUser_getRegister_corres]) - apply (rule corres_trivial, simp add: message_info_from_data_eqv) - apply (wp | simp)+ +(* FIXME arch-split: return () on all architectures *) +arch_requalify_facts debugPrint_def + +arch_requalify_facts (* FIXME arch-split: from Machine_AI *) + no_fail_getRestartPC + no_fail_getRegister + no_irq_mapM + no_irq_loadWord + getRestartPC_inv + +arch_requalify_facts (* FIXME arch-split: from ArchDeterministic_AI *) + copy_mrs_valid_list + do_ipc_transfer_valid_list + +lemmas [wp] = copy_mrs_valid_list do_ipc_transfer_valid_list + +(* FIXME arch-split: this should be made generic in Ipc_AI *) +lemma make_fault_msg_inv[wp]: + "make_fault_msg ft t \P\" + by (cases ft; wpsimp wp: as_user_inv getRestartPC_inv mapM_wp' getRegister_inv split_del: if_split) + +arch_requalify_facts (* FIXME arch-split: from ArchIpc_AI *) + arch_get_sanitise_register_info_inv handle_arch_fault_reply_inv + +lemmas [wp] = handle_arch_fault_reply_inv + +(* FIXME: move *) +declare word_div_1[simp] +declare word_minus_one_le[simp] + +(* FIXME: move to WordLib after word_mult_le_mono1 *) +lemma word_mult_le_mono1': + fixes i :: "'a :: len word" + assumes ij: "i \ j" "0 < k" + and lim: "unat k * unat j < 2 ^ len_of TYPE ('a)" + shows "k * i \ k * j" + using word_mult_le_mono1[OF ij] lim + by (simp add: mult.commute) + +(* FIXME arch-split: move, review for sanity *) +lemma no_fail_zipWithM_x: + assumes P: "\x y. no_fail P (f x y)" + assumes inv: "\x y. f x y \P\" + shows "no_fail P (zipWithM_x f xs ys)" + unfolding zipWithM_x_def zipWith_def sequence_x_def + apply (induct ys arbitrary: xs, wpsimp) + apply (case_tac xs, wpsimp) + apply (wpsimp wp: inv P | blast)+ + done + +(* FIXME arch-split: move *) +lemma det_no_fail: + "det f \ no_fail \ f" + by (metis det_def no_fail_def prod.sel(2)) + +lemma gets_the_noop_corres: + assumes P: "\s. P s \ f s \ None" + shows "corres dc P P' (gets_the f) (return x)" + apply (clarsimp simp: corres_underlying_def gets_the_def + return_def gets_def bind_def get_def) + apply (clarsimp simp: assert_opt_def return_def dest!: P) done +(* FIXME arch-split: move *) +lemma invs_pspace_in_kernel_mappings'[elim!]: + "invs' s \ pspace_in_kernel_mappings' s" + by (fastforce dest!: invs_valid_pspace' simp: valid_pspace'_def) + +(* FIXME: move *) +lemma unifyFailure_wp_E[wp]: + "\P\ f -, \\_. E\ \ \P\ unifyFailure f -, \\_. E\" + unfolding validE_E_def + by (erule unifyFailure_wp)+ + +(* FIXME: move *) +lemma unifyFailure_wp2[wp]: + assumes x: "\P\ f \\_. Q\" + shows "\P\ unifyFailure f \\_. Q\" + by (wp x, simp) -lemma get_mi_inv'[wp]: "\I\ getMessageInfo a \\x. I\" - by (simp add: getMessageInfo_def, wp) +lemmas lookup_slot_wrapper_defs'[simp] = + lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def + +lemma word_size_bits_le_msg_align_bits[simp]: + "word_size_bits \ msg_align_bits" + by (simp add: msg_align_bits_def) + +crunch getMessageInfo + for inv[wp]: P + (simp: getMessageInfo_def) definition "get_send_cap_relation rv rv' \ @@ -39,94 +116,167 @@ definition lemma cap_relation_mask: "\ cap_relation c c'; msk' = rights_mask_map msk \ \ - cap_relation (mask_cap msk c) (maskCapRights msk' c')" + cap_relation (mask_cap msk c) (maskCapRights msk' c')" by simp lemma lsfco_cte_at': "\valid_objs' and valid_cap' cap\ - lookupSlotForCNodeOp f cap idx depth - \\rv. cte_at' rv\, -" + lookupSlotForCNodeOp f cap idx depth + \\rv. cte_at' rv\, -" apply (simp add: lookupSlotForCNodeOp_def) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (wp) - apply (clarsimp simp: split_def unlessE_def - split del: if_split) + apply (rule conjI[rotated], solves wpsimp) + apply (clarsimp simp: split_def) apply (wpsimp wp: hoare_drop_imps throwE_R) done -declare unifyFailure_wp [wp] - -(* FIXME: move *) -lemma unifyFailure_wp_E [wp]: - "\P\ f -, \\_. E\ \ \P\ unifyFailure f -, \\_. E\" - unfolding validE_E_def - by (erule unifyFailure_wp)+ - -(* FIXME: move *) -lemma unifyFailure_wp2 [wp]: - assumes x: "\P\ f \\_. Q\" - shows "\P\ unifyFailure f \\_. Q\" - by (wp x, simp) - -definition - ct_relation :: "captransfer \ cap_transfer \ bool" -where - "ct_relation ct ct' \ - ct_receive_root ct = to_bl (ctReceiveRoot ct') - \ ct_receive_index ct = to_bl (ctReceiveIndex ct') - \ ctReceiveDepth ct' = unat (ct_receive_depth ct)" +definition ct_relation :: "captransfer \ cap_transfer \ bool" where + "ct_relation ct ct' \ + ct_receive_root ct = to_bl (ctReceiveRoot ct') + \ ct_receive_index ct = to_bl (ctReceiveIndex ct') + \ ctReceiveDepth ct' = unat (ct_receive_depth ct)" (* MOVE *) lemma valid_ipc_buffer_ptr_aligned_word_size_bits: "\valid_ipc_buffer_ptr' a s; is_aligned y word_size_bits \ \ is_aligned (a + y) word_size_bits" unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (erule (1) aligned_add_aligned) - apply (simp add: msg_align_bits word_size_bits_def) - done + by (clarsimp elim!: aligned_add_aligned) + +lemma msgMax_simps: + "msgMaxExtraCaps = word_of_nat msg_max_extra_caps" + "msgMaxLength = word_of_nat msg_max_length" + by (simp add: msg_max_extra_caps_def msg_max_length_def + msgMaxExtraCaps_def msgExtraCapBits_def msgMaxLength_def)+ + +locale Ipc_R = + assumes getMessageInfo_corres: + "\t. + corres ((=) \ message_info_map) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_message_info t) (getMessageInfo t)" + assumes max_ipc_size_le_2_msg_align_bits: + "max_ipc_words * word_size \ 2 ^ msg_align_bits" + assumes is_derived'_Untyped: + "\cap cap' m src. + \isUntypedCap cap'\ + \ is_derived' m src cap' cap + = (isUntypedCap cap \ badge_derived' cap' cap \ descendants_of' src m = {})" + assumes is_derived'_Reply: + "\cap cap' m src. + \isReplyCap cap'\ + \ is_derived' m src cap' cap + = (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ capReplyMaster cap \ \ capReplyMaster cap')" + assumes maskCapRights_eq_null[simp]: + "(RetypeDecls_H.maskCapRights r cap = capability.NullCap) = (cap = capability.NullCap)" + assumes capASID_gen_cap: + "\cap. \ isArchObjectCap cap \ capASID cap = None" + assumes cap_asid_base'_gen_cap: + "\cap. \ isArchObjectCap cap \ cap_asid_base' cap = None" + assumes cap_vptr'_gen_cap: + "\cap. \ isArchObjectCap cap \ cap_vptr' cap = None" + assumes transferCapsToSlots_pspace_in_kernel_mappings'[wp]: + "\ep buffer n caps slots mi. + transferCapsToSlots ep buffer n caps slots mi \pspace_in_kernel_mappings'\" + assumes makeArchFaultMessage_sch_act: + "\af t. makeArchFaultMessage af t \\s. P (ksSchedulerAction s)\" + assumes is_derived'_IRQHandlerCap: + "\cap cap' src (s::kernel_state). + \isIRQHandlerCap cap'\ \ is_derived' (ctes_of s) src cap' cap = + (isIRQHandlerCap cap \ badge_derived' cap' cap)" + assumes storeWordUser_vms'[wp]: + "\a w. storeWordUser a w \valid_machine_state'\" + assumes isArchObjectCap_maskCapRights: + "\R acap. isArchObjectCap (Arch.maskCapRights R acap)" + assumes arch_updateCapData_ordering: + "\x acap p d P. + \ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ + \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" + assumes ArchUpdateCapData_noReply: + "\p d acap x y z. Arch.updateCapData p d acap \ capability.ReplyCap x y z" + assumes ArchUpdateCapData_noIRQControl: + "\p d acap. Arch.updateCapData p d acap \ IRQControlCap" + assumes copyMRs_pspace_in_kernel_mappings'[wp]: + "\sender send_buf receiver recv_buf len. + copyMRs sender send_buf receiver recv_buf len \pspace_in_kernel_mappings'\" + assumes makeArchFaultMessage_corres: + "\f t. + corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (make_arch_fault_msg f t) + (makeArchFaultMessage (arch_fault_map f) t)" + assumes badgeRegister_badge_register: + "badgeRegister = badge_register" + assumes syscallMessage_def': + "FaultHandler_H.syscallMessage \ MachineExports.syscallMessage" + assumes exceptionMessage_def': + "FaultHandler_H.exceptionMessage \ MachineExports.exceptionMessage" + assumes sanitiseRegister_sanitise_register: + "sanitiseRegister = sanitise_register" + assumes makeArchFaultMessage_inv[wp]: + "\ft t P. makeArchFaultMessage ft t \P\" + assumes lookupIPCBuffer_valid_ipc_buffer[wp]: + "\b s. \valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" +assumes arch_getSanitiseRegisterInfo_corres: + "\t. + corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (arch_get_sanitise_register_info t) + (getSanitiseRegisterInfo t)" + assumes getSanitiseRegisterInfo_inv[wp]: + "\t P. getSanitiseRegisterInfo t \P\" + assumes handleArchFaultReply_inv[wp]: + "\x0 x1 x2 x3 P. handleArchFaultReply x0 x1 x2 x3 \P\" + assumes handleArchFaultReply_corres: + "\ft t label msg. + corres (=) \ \ + (handle_arch_fault_reply ft t label msg) + (handleArchFaultReply (arch_fault_map ft) t label msg)" + assumes ctes_of_mdbNext_parentOf: + "\(s'::kernel_state) cptr slot t master rights n master' rights' n' cte. + \ ctes_of s' \ cte_map cptr \ cte_map slot; + ctes_of s' (cte_map cptr) = Some (CTE (capability.ReplyCap t master rights) n); + ctes_of s' (mdbNext (cteMDBNode cte)) = Some (CTE (capability.ReplyCap t master' rights') n'); + ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)\ + \ ctes_of s' \ cte_map cptr parentOf mdbNext (cteMDBNode cte)" + assumes get_mrs_inv'[wp]: + "\t buf info P. getMRs t buf info \P\" + assumes debugPrint_inv[wp]: + "\msg P. debugPrint msg \P\" + assumes no_fail_debugPrint[intro!, wp, simp]: + "\msg. no_fail \ (debugPrint msg)" + (* this specifically refers to the 4 message registers *) + assumes max_message_size_less_max_ipc_words: + "n \ 4 + \ word_size * (word_of_nat msg_max_extra_caps + (word_of_nat msg_max_length + n)) + < max_ipc_words * word_size" +begin -(* MOVE *) +(* FIXME: MOVE *) lemma valid_ipc_buffer_ptr'D2: - "\valid_ipc_buffer_ptr' a s; y < max_ipc_words * word_size; is_aligned y word_size_bits\ \ typ_at' UserDataT (a + y && ~~ mask pageBits) s" + "\valid_ipc_buffer_ptr' a s; y < max_ipc_words * word_size; is_aligned y word_size_bits\ + \ typ_at' UserDataT (a + y && ~~ mask pageBits) s" unfolding valid_ipc_buffer_ptr'_def apply clarsimp apply (subgoal_tac "(a + y) && ~~ mask pageBits = a && ~~ mask pageBits") apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (erule order_less_le_trans) - apply (simp add: msg_align_bits max_ipc_words word_size_def) - apply simp + apply (rule mask_out_first_mask_some[where n = msg_align_bits]; simp?) + apply (erule is_aligned_add_helper[THEN conjunct2]) + apply (erule order_less_le_trans) + apply (rule max_ipc_size_le_2_msg_align_bits) done lemma loadCapTransfer_corres: - notes msg_max_words_simps = max_ipc_words_def msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def - capTransferDataSize_def msgExtraCapBits_def - shows "corres ct_relation \ (valid_ipc_buffer_ptr' buffer) (load_cap_transfer buffer) (loadCapTransfer buffer)" - apply (simp add: load_cap_transfer_def loadCapTransfer_def - captransfer_from_words_def - capTransferDataSize_def capTransferFromWords_def - msgExtraCapBits_def word_size add.commute add.left_commute - msg_max_length_def msg_max_extra_caps_def word_size_def - msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def wordSize_def wordBits_def + apply (simp add: load_cap_transfer_def loadCapTransfer_def captransfer_from_words_def + capTransferDataSize_def capTransferFromWords_def add.commute + wordSize_word_size msgMax_simps del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) + apply (corres corres: load_word_corres) apply (rule_tac P=\ and P'=\ in corres_inst) apply (clarsimp simp: ct_relation_def) - apply (wp no_irq_loadWord)+ - apply simp - apply (simp add: conj_comms) - apply safe - apply (erule valid_ipc_buffer_ptr_aligned_word_size_bits, simp add: is_aligned_def word_size_bits_def)+ - apply (erule valid_ipc_buffer_ptr'D2, - simp add: msg_max_words_simps word_size_def word_size_bits_def, - simp add: word_size_bits_def is_aligned_def)+ + apply wpsimp+ + apply (simp add: conj_comms field_simps) + apply (rule conjI + | erule valid_ipc_buffer_ptr'D2 valid_ipc_buffer_ptr_aligned_word_size_bits + | solves \simp add: word_size_word_size_bits is_aligned_add is_aligned_mult_triv1\ + | solves \simp flip: distrib_left add: max_message_size_less_max_ipc_words\)+ done lemma getReceiveSlots_corres: @@ -163,6 +313,8 @@ lemma getReceiveSlots_corres: apply (wp lookup_cap_valid lookup_cap_valid' lsfco_cte_at | simp)+ done +end (* Ipc_R *) + lemma get_recv_slot_inv'[wp]: "\ P \ getReceiveSlots receiver buf \\rv'. P \" apply (case_tac buf) @@ -206,18 +358,10 @@ lemma get_rs_real_cte_at'[wp]: apply simp done -declare word_div_1 [simp] -declare word_minus_one_le [simp] -declare word64_minus_one_le [simp] - lemma loadWordUser_corres': - "\ y < unat max_ipc_words; y' = of_nat y * 8 \ \ - corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + y'))" - apply simp - apply (erule loadWordUser_corres) - done - -declare loadWordUser_inv [wp] + "\ y < unat max_ipc_words; y' = of_nat y * word_size \ \ + corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + y'))" + by (clarsimp simp: loadWordUser_corres) lemma getExtraCptrs_inv[wp]: "\P\ getExtraCPtrs buf mi \\rv. P\" @@ -238,16 +382,6 @@ lemma badge_derived_mask [simp]: "badge_derived' (maskCapRights R c) c' = badge_derived' c c'" by (simp add: badge_derived'_def) -declare derived'_not_Null [simp] - -lemma maskCapRights_vs_cap_ref'[simp]: - "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" - unfolding vs_cap_ref'_def - apply (cases cap, simp_all add: maskCapRights_def isCap_simps Let_def) - apply (rename_tac arch_capability) - apply (case_tac arch_capability; - simp add: maskCapRights_def AARCH64_H.maskCapRights_def isCap_simps Let_def) - done lemma corres_set_extra_badge: "b' = b \ @@ -256,18 +390,17 @@ lemma corres_set_extra_badge: (\_. msg_max_length + 2 + n < unat max_ipc_words)) (set_extra_badge buffer b n) (setExtraBadge buffer b' n)" apply (rule corres_gen_asm2) - apply (drule storeWordUser_corres [where a=buffer and w=b]) + apply (drule storeWordUser_corres[where a=buffer and w=b]) apply (simp add: set_extra_badge_def setExtraBadge_def buffer_cptr_index_def bufferCPtrOffset_def Let_def) - apply (simp add: word_size word_size_def wordSize_def wordBits_def - bufferCPtrOffset_def buffer_cptr_index_def msgMaxLength_def - msg_max_length_def msgLengthBits_def store_word_offs_def - add.commute add.left_commute) + apply (simp add: wordSize_word_size msgMax_simps field_simps) done crunch setExtraBadge for typ_at': "\s. P (typ_at' T p s)" -lemmas setExtraBadge_typ_ats' [wp] = typ_at_lifts [OF setExtraBadge_typ_at'] + +lemmas setExtraBadge_gen_typ_ats' [wp] = gen_typ_at_lifts[OF setExtraBadge_typ_at'] + crunch setExtraBadge for valid_pspace'[wp]: valid_pspace' crunch setExtraBadge @@ -283,8 +416,8 @@ lemmas unifyFailure_discard2 lemma deriveCap_not_null: "\\\ deriveCap slot cap \\rv. K (rv \ NullCap \ cap \ NullCap)\,-" - apply (simp add: deriveCap_def split del: if_split) - by (case_tac cap; wpsimp simp: isCap_simps) + by (simp add: deriveCap_def split del: if_split) + (case_tac cap; wpsimp simp: gen_isCap_simps) lemma deriveCap_derived_foo: "\\s. \cap'. (cte_wp_at' (\cte. badge_derived' cap (cteCap cte) @@ -294,7 +427,8 @@ lemma deriveCap_derived_foo: \ (cte_wp_at' (untyped_derived_eq cap \ cteCap) slot s \ cte_wp_at' (untyped_derived_eq cap' \ cteCap) slot s) \ (s \' cap \ s \' cap') \ (cap' \ NullCap \ cap \ NullCap) \ Q cap' s\ - deriveCap slot cap \Q\,-" + deriveCap slot cap + \Q\,-" using deriveCap_derived[where slot=slot and c'=cap] deriveCap_valid[where slot=slot and c=cap] deriveCap_untyped_derived[where slot=slot and c'=cap] deriveCap_not_null[where slot=slot and cap=cap] apply (clarsimp simp: validE_R_def validE_def valid_def split: sum.split) @@ -314,6 +448,8 @@ lemma valid_mdb_untyped_incD': "valid_mdb' s \ untyped_inc' (ctes_of s)" by (simp add: valid_mdb'_def valid_mdb_ctes_def) +context Ipc_R begin + lemma cteInsert_cte_wp_at: "\\s. cte_wp_at' (\c. is_derived' (ctes_of s) src cap (cteCap c)) src s \ valid_mdb' s \ valid_objs' s @@ -340,13 +476,14 @@ lemma cteInsert_cte_wp_at: apply (intro conjI impI) apply ((clarsimp simp: cte_wp_at'_def maskedAsFull_def split: if_split_asm)+)[2] apply clarsimp + apply (clarsimp simp: gen_isCap_simps) apply (rule conjI) apply (clarsimp simp: maskedAsFull_def cte_wp_at_ctes_of split:if_split_asm) apply (erule disjE) prefer 2 apply simp - apply (clarsimp simp: is_derived'_def isCap_simps) + apply (clarsimp simp: is_derived'_Untyped) apply (drule valid_mdb_untyped_incD') apply (case_tac cte, case_tac cteb, clarsimp) - apply (drule untyped_incD', (simp add: isCap_simps)+) + apply (drule untyped_incD', (simp add: gen_isCap_simps)+) apply (frule(1) ctes_of_valid'[where p = p]) apply (clarsimp simp:valid_cap'_def capAligned_def split:if_splits) apply (drule_tac y ="of_nat fb" in word_plus_mono_right[OF _ is_aligned_no_overflow',rotated]) @@ -355,11 +492,14 @@ lemma cteInsert_cte_wp_at: apply simp apply (simp add:p_assoc_help mask_def) apply (simp add: max_free_index_def) - apply (clarsimp simp: maskedAsFull_def is_derived'_def badge_derived'_def - isCap_simps capMasterCap_def cte_wp_at_ctes_of + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (clarsimp simp: maskedAsFull_def badge_derived'_def is_derived'_Untyped + capMasterCap_def split: if_split_asm capability.splits) done +end (* Ipc_R *) + lemma cteInsert_weak_cte_wp_at3: assumes imp:"\c. P c \ \ isUntypedCap c" shows " \\s. if p = dest then P cap @@ -374,22 +514,13 @@ lemma cteInsert_weak_cte_wp_at3: lemma maskedAsFull_null_cap[simp]: "(maskedAsFull x y = capability.NullCap) = (x = capability.NullCap)" "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" - by (case_tac x, auto simp:maskedAsFull_def isCap_simps) - -lemma maskCapRights_eq_null: - "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = - (xa = capability.NullCap)" - apply (cases xa; simp add: maskCapRights_def isCap_simps) - apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (simp_all add: AARCH64_H.maskCapRights_def isCap_simps) - done + by (case_tac x, auto simp:maskedAsFull_def gen_isCap_simps) lemma cte_refs'_maskedAsFull[simp]: "cte_refs' (maskedAsFull a b) = cte_refs' a" apply (rule ext)+ apply (case_tac a) - apply (clarsimp simp:maskedAsFull_def isCap_simps)+ + apply (clarsimp simp:maskedAsFull_def gen_isCap_simps)+ done lemma set_extra_badge_valid_arch_state[wp]: @@ -397,7 +528,8 @@ lemma set_extra_badge_valid_arch_state[wp]: unfolding set_extra_badge_def by wp -lemma transferCapsToSlots_corres: + +lemma (in Ipc_R) transferCapsToSlots_corres: "\ list_all2 (\(cap, slot) (cap', slot'). cap_relation cap cap' \ slot' = cte_map slot) caps caps'; mi' = message_info_map mi \ \ @@ -440,7 +572,7 @@ next apply (simp add: dc_def[symmetric] split del: if_split) apply (rule corres_guard_imp) apply (rule corres_if3) - apply (case_tac "fst x", auto simp add: isCap_simps)[1] + apply (case_tac "fst x", auto simp add: gen_isCap_simps)[1] apply (rule corres_split[OF corres_set_extra_badge]) apply (clarsimp simp: is_cap_simps) apply (drule conjunct1) @@ -549,7 +681,8 @@ next apply (clarsimp simp:valid_pspace'_def cte_wp_at_ctes_of split del:if_split) apply (intro conjI) apply (case_tac "cteCap cte = fst y",clarsimp simp: badge_derived'_def) - apply (clarsimp simp: maskCapRights_eq_null maskedAsFull_def badge_derived'_def isCap_simps + apply (clarsimp simp: maskedAsFull_def badge_derived'_def gen_isCap_simps + capASID_gen_cap cap_asid_base'_gen_cap cap_vptr'_gen_cap split: if_split_asm) apply (clarsimp split del: if_split) apply (case_tac "fst y = capability.NullCap") @@ -564,11 +697,9 @@ next apply (rule conjI) apply clarsimp+ apply (case_tac "cteCap cteb = ab") - by (clarsimp simp: isCap_simps maskedAsFull_def split:if_splits)+ + by (clarsimp simp: gen_isCap_simps maskedAsFull_def split:if_splits)+ qed -declare constOnFailure_wp [wp] - lemma transferCapsToSlots_pres1[crunch_rules]: assumes x: "\cap src dest. \P\ cteInsert cap src dest \\rv. P\" assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" @@ -599,8 +730,6 @@ lemma cteInsert_cte_cap_to': apply clarsimp+ done -declare maskCapRights_eq_null[simp] - crunch setExtraBadge for ex_cte_cap_wp_to'[wp]: "ex_cte_cap_wp_to' P p" (rule: ex_cte_cap_to'_pres) @@ -647,6 +776,23 @@ lemma cteInsert_weak_cte_wp_at2: apply auto done + +crunch transferCapsToSlots + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + and pspace_canonical'[wp]: pspace_canonical' + +lemma transferCapsToSlots_typ_at'[wp]: + "\\s. P (typ_at' T p s)\ + transferCapsToSlots ep buffer n caps slots mi + \\rv s. P (typ_at' T p s)\" + by (wp transferCapsToSlots_pres1 setExtraBadge_typ_at') + +abbreviation(input) + "transferCaps_srcs caps s \ \x\set caps. cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s" + +context Ipc_R begin + lemma transferCapsToSlots_presM: assumes x: "\cap src dest. \\s. P s \ (emx \ cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ ex_cte_cap_to' dest s) \ (vo \ valid_objs' s \ valid_cap' cap s \ real_cte_at' dest s) @@ -696,17 +842,6 @@ lemmas transferCapsToSlots_pres2 = transferCapsToSlots_presM[where vo=False and emx=True and drv=False and pad=False, simplified] -crunch transferCapsToSlots - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - and pspace_canonical'[wp]: pspace_canonical' - -lemma transferCapsToSlots_typ_at'[wp]: - "\\s. P (typ_at' T p s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (typ_at' T p s)\" - by (wp transferCapsToSlots_pres1 setExtraBadge_typ_at') - lemma transferCapsToSlots_valid_objs[wp]: "\valid_objs' and valid_mdb' and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) and (\s. \x \ set caps. s \' fst x) and K(distinct slots)\ @@ -717,9 +852,6 @@ lemma transferCapsToSlots_valid_objs[wp]: apply (wp | simp)+ done -abbreviation(input) - "transferCaps_srcs caps s \ \x\set caps. cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s" - lemma transferCapsToSlots_mdb[wp]: "\\s. valid_pspace' s \ distinct slots \ length slots \ 1 @@ -730,7 +862,7 @@ lemma transferCapsToSlots_mdb[wp]: \\rv. valid_mdb'\" apply (wpsimp wp: transferCapsToSlots_presM[where drv=True and vo=True and emx=True and pad=True]) apply (frule valid_capAligned) - apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def badge_derived'_def) + apply (clarsimp simp: cte_wp_at_ctes_of badge_derived'_def) apply wp apply (clarsimp simp: valid_pspace'_def) apply (clarsimp simp:cte_wp_at_ctes_of) @@ -740,6 +872,8 @@ lemma transferCapsToSlots_mdb[wp]: apply (fastforce simp:valid_cap'_def) done +end (* Ipc_R *) + crunch setExtraBadge for no_0'[wp]: no_0_obj' @@ -747,25 +881,11 @@ lemma transferCapsToSlots_no_0_obj' [wp]: "\no_0_obj'\ transferCapsToSlots ep buffer n caps slots mi \\rv. no_0_obj'\" by (wp transferCapsToSlots_pres1) -lemma transferCapsToSlots_vp[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_pspace'\" - apply (rule hoare_pre) - apply (simp add: valid_pspace'_def | wp)+ - apply (fastforce simp: cte_wp_at_ctes_of dest: ctes_of_valid') - done +crunch setExtraBadge + for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" -crunch setExtraBadge, doIPCTransfer - for sch_act [wp]: "\s. P (ksSchedulerAction s)" - (wp: crunch_wps mapME_wp' simp: zipWithM_x_mapM) crunch setExtraBadge - for pred_tcb_at' [wp]: "\s. pred_tcb_at' proj P p s" - and ksCurThread[wp]: "\s. P (ksCurThread s)" + for ksCurThread[wp]: "\s. P (ksCurThread s)" and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and obj_at' [wp]: "\s. P' (obj_at' P p s)" and queues [wp]: "\s. P (ksReadyQueues s)" @@ -773,13 +893,6 @@ crunch setExtraBadge and queuesL2 [wp]: "\s. P (ksReadyQueuesL2Bitmap s)" (simp: storeWordUser_def) - -lemma tcts_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) - crunch setExtraBadge for state_refs_of'[wp]: "\s. P (state_refs_of' s)" and state_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" @@ -797,24 +910,6 @@ lemma tcts_state_hyp_refs_of'[wp]: crunch setExtraBadge for if_live'[wp]: if_live_then_nonz_cap' -lemma tcts_iflive[wp]: - "\\s. if_live_then_nonz_cap' s \ distinct slots \ - (\x\set slots. - ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. if_live_then_nonz_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch setExtraBadge - for if_unsafe'[wp]: if_unsafe_then_cap' - -lemma tcts_ifunsafe[wp]: - "\\s. if_unsafe_then_cap' s \ distinct slots \ - (\x\set slots. cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s \ - ex_cte_cap_to' x s)\ transferCapsToSlots ep buffer n caps slots mi - \\rv. if_unsafe_then_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - crunch setExtraBadge for valid_idle'[wp]: valid_idle' @@ -827,19 +922,62 @@ lemma tcts_idle'[wp]: done lemma tcts_ct[wp]: - "\cur_tcb'\ transferCapsToSlots ep buffer n caps slots mi \\rv. cur_tcb'\" + "transferCapsToSlots ep buffer n caps slots mi \cur_tcb'\" by (wp transferCapsToSlots_pres1 cur_tcb_lift) crunch setExtraBadge for valid_arch_state'[wp]: valid_arch_state' lemma transferCapsToSlots_valid_arch [wp]: - "\valid_arch_state'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_arch_state'\" + "transferCapsToSlots ep buffer n caps slots mi \valid_arch_state'\ " by (rule transferCapsToSlots_pres1; wp) crunch setExtraBadge for valid_global_refs'[wp]: valid_global_refs' +context Ipc_R begin + +lemma transferCapsToSlots_vp[wp]: + "\\s. valid_pspace' s \ distinct slots + \ length slots \ 1 + \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) + \ (\x \ set slots. real_cte_at' x s) + \ transferCaps_srcs caps s\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. valid_pspace'\" + apply (rule hoare_pre) + apply (simp add: valid_pspace'_def | wp)+ + apply (fastforce simp: cte_wp_at_ctes_of dest: ctes_of_valid') + done + +crunch setExtraBadge, doIPCTransfer + for sch_act [wp]: "\s. P (ksSchedulerAction s)" + (wp: crunch_wps mapME_wp' simp: zipWithM_x_mapM) + +lemma tcts_sch_act[wp]: + "\\s. sch_act_wf (ksSchedulerAction s) s\ + transferCapsToSlots ep buffer n caps slots mi + \\rv s. sch_act_wf (ksSchedulerAction s) s\" + by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) + +lemma tcts_iflive[wp]: + "\\s. if_live_then_nonz_cap' s \ distinct slots \ + (\x\set slots. + ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s)\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. if_live_then_nonz_cap'\" + by (wp transferCapsToSlots_pres2 | simp)+ + +crunch setExtraBadge + for if_unsafe'[wp]: if_unsafe_then_cap' + +lemma tcts_ifunsafe[wp]: + "\\s. if_unsafe_then_cap' s \ distinct slots \ + (\x\set slots. cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s \ + ex_cte_cap_to' x s)\ transferCapsToSlots ep buffer n caps slots mi + \\rv. if_unsafe_then_cap'\" + by (wp transferCapsToSlots_pres2 | simp)+ + lemma transferCapsToSlots_valid_globals [wp]: "\valid_global_refs' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' and K (distinct slots) and K (length slots \ 1) @@ -855,6 +993,8 @@ lemma transferCapsToSlots_valid_globals [wp]: apply (fastforce simp:valid_cap'_def) done +end (* Ipc_R *) + crunch setExtraBadge for irq_node'[wp]: "\s. P (irq_node' s)" @@ -870,6 +1010,8 @@ lemma valid_irq_handlers_ctes_ofD: crunch setExtraBadge for valid_irq_handlers'[wp]: valid_irq_handlers' +context Ipc_R begin + lemma transferCapsToSlots_irq_handlers[wp]: "\valid_irq_handlers' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' and K(distinct slots \ length slots \ 1) @@ -878,7 +1020,9 @@ lemma transferCapsToSlots_irq_handlers[wp]: transferCapsToSlots ep buffer n caps slots mi \\rv. valid_irq_handlers'\" apply (wpsimp wp: transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=False]) - apply (clarsimp simp: is_derived'_def cte_wp_at_ctes_of badge_derived'_def) +using [[show_types]] + apply (clarsimp simp: cte_wp_at_ctes_of badge_derived'_def is_derived'_IRQHandlerCap + gen_isCap_simps) apply (erule(2) valid_irq_handlers_ctes_ofD) apply wp apply (clarsimp simp:cte_wp_at_ctes_of | intro ballI conjI)+ @@ -888,6 +1032,8 @@ lemma transferCapsToSlots_irq_handlers[wp]: apply (fastforce simp:valid_cap'_def) done +end (* Ipc_R *) + crunch setExtraBadge for irq_state'[wp]: "\s. P (ksInterruptState s)" @@ -907,45 +1053,45 @@ lemma transferCapsToSlots_irqs_masked'[wp]: "\irqs_masked'\ transferCapsToSlots ep buffer n caps slots mi \\rv. irqs_masked'\" by (wp transferCapsToSlots_pres1 irqs_masked_lift) -lemma storeWordUser_vms'[wp]: - "\valid_machine_state'\ storeWordUser a w \\_. valid_machine_state'\" -proof - - have aligned_offset_ignore: - "\(l::machine_word) (p::machine_word) sz. l<8 \ p && mask 3 = 0 \ - p+l && ~~ mask pageBits = p && ~~ mask pageBits" - proof - - fix l p sz - assume al: "(p::machine_word) && mask 3 = 0" - assume "(l::machine_word) < 8" hence less: "l<2^3" by simp - have le: "3 \ pageBits" by (simp add: pageBits_def) - show "?thesis l p sz" - by (rule is_aligned_add_helper[simplified is_aligned_mask, - THEN conjunct2, THEN mask_out_first_mask_some, - where n=3, OF al less le]) - qed +crunch setExtraBadge, transferCapsToSlots + for pspace_domain_valid[wp]: "pspace_domain_valid" - show ?thesis - apply (simp add: valid_machine_state'_def storeWordUser_def - doMachineOp_def split_def) - apply wp - apply clarsimp - apply (drule use_valid) - apply (rule_tac x=p in storeWord_um_inv, simp+) - apply (drule_tac x=p in spec) - apply (erule disjE, simp_all) - apply (erule conjE) - apply (erule disjE, simp) - apply (simp add: pointerInUserData_def word_size) - apply (subgoal_tac "a && ~~ mask pageBits = p && ~~ mask pageBits", simp) - apply (simp only: is_aligned_mask[of _ 3]) - apply (elim disjE, simp_all) - apply (rule aligned_offset_ignore[symmetric], simp+)+ - done -qed +crunch setExtraBadge + for ct_not_inQ[wp]: "ct_not_inQ" + and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + and ctes_of[wp]: "\s. P (ctes_of s)" + +lemma tcts_ct_not_inQ[wp]: + "transferCapsToSlots ep buffer n caps slots mi \ct_not_inQ\" + by (wp transferCapsToSlots_pres1) + +crunch transferCapsToSlots, setExtraBadge + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" + +crunch transferCapsToSlots + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: sym_heap_sched_pointers_lift) + +lemma grs_distinct'[wp]: + "\\\ getReceiveSlots t buf \\rv s. distinct rv\" + apply (cases buf, simp_all add: getReceiveSlots_def + split_def unlessE_def) + apply (wp, simp) + apply (wp | simp only: distinct.simps list.simps empty_iff)+ + apply simp + done + +context Ipc_R begin lemma setExtraBadge_vms'[wp]: "\valid_machine_state'\ setExtraBadge buffer b n \\_. valid_machine_state'\" -by (simp add: setExtraBadge_def) wp + by (simp add: setExtraBadge_def) (wp storeWordUser_vms') lemma transferCapsToSlots_vms[wp]: "\\s. valid_machine_state' s\ @@ -953,23 +1099,6 @@ lemma transferCapsToSlots_vms[wp]: \\_ s. valid_machine_state' s\" by (wp transferCapsToSlots_pres1) -crunch setExtraBadge, transferCapsToSlots - for pspace_domain_valid[wp]: "pspace_domain_valid" - -crunch setExtraBadge - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma tcts_ct_not_inQ[wp]: - "\ct_not_inQ\ - transferCapsToSlots ep buffer n caps slots mi - \\_. ct_not_inQ\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" -crunch setExtraBadge - for ctes_of[wp]: "\s. P (ctes_of s)" - lemma tcts_zero_ranges[wp]: "\\s. untyped_ranges_zero' s \ valid_pspace' s \ distinct slots \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) @@ -992,19 +1121,6 @@ lemma tcts_zero_ranges[wp]: apply auto[1] done -crunch transferCapsToSlots, setExtraBadge - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - -crunch transferCapsToSlots - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift) - lemma transferCapsToSlots_invs[wp]: "\\s. invs' s \ distinct slots \ (\x \ set slots. cte_wp_at' (\cte. cteCap cte = NullCap) x s) @@ -1019,20 +1135,6 @@ lemma transferCapsToSlots_invs[wp]: apply fastforce done -lemma grs_distinct'[wp]: - "\\\ getReceiveSlots t buf \\rv s. distinct rv\" - apply (cases buf, simp_all add: getReceiveSlots_def - split_def unlessE_def) - apply (wp, simp) - apply (wp | simp only: distinct.simps list.simps empty_iff)+ - apply simp - done - -(* FIXME arch-split: move *) -lemma invs_pspace_in_kernel_mappings'[elim!]: - "invs' s \ pspace_in_kernel_mappings' s" - by (fastforce dest!: invs_valid_pspace' simp: valid_pspace'_def) - lemma transferCaps_corres: "\ info' = message_info_map info; list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x)) @@ -1089,94 +1191,51 @@ lemma transferCaps_corres: apply (fastforce simp:valid_cap'_def) done -crunch transferCaps - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas transferCaps_typ_ats[wp] = typ_at_lifts [OF transferCaps_typ_at'] +lemma non_arch_maskCapRights: + "\ isArchObjectCap cap \ (Arch.maskCapRights R acap = cap) = False" + using isArchObjectCap_maskCapRights + by fastforce lemma isIRQControlCap_mask [simp]: "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" - apply (case_tac c) - apply (clarsimp simp: isCap_simps maskCapRights_def Let_def)+ - apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (clarsimp simp: isCap_simps AARCH64_H.maskCapRights_def - maskCapRights_def Let_def)+ - done - -lemma isFrameCap_maskCapRights[simp]: -" isArchCap isFrameCap (RetypeDecls_H.maskCapRights R c) = isArchCap isFrameCap c" - apply (case_tac c; simp add: isCap_simps isArchCap_def maskCapRights_def) - apply (rename_tac arch_capability) - apply (case_tac arch_capability; simp add: isCap_simps AARCH64_H.maskCapRights_def) - done - -lemma capReplyMaster_mask[simp]: - "isReplyCap c \ capReplyMaster (maskCapRights R c) = capReplyMaster c" - by (clarsimp simp: isCap_simps maskCapRights_def) - -lemma is_derived_mask' [simp]: - "is_derived' m p (maskCapRights R c) = is_derived' m p c" - apply (rule ext) - apply (simp add: is_derived'_def badge_derived'_def) - done - -lemma arch_updateCapData_ordering: (* arch interface *) - "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ - \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" - apply (cases acap; simp add: AARCH64_H.updateCapData_def) - apply fastforce - done + by (case_tac c; + clarsimp simp: gen_isCap_simps maskCapRights_def non_arch_maskCapRights Let_def) lemma updateCapData_ordering: "\ (x, capBadge cap) \ capBadge_ordering P; updateCapData p d cap \ NullCap \ \ (x, capBadge (updateCapData p d cap)) \ capBadge_ordering P" apply (cases cap; simp) - apply (fastforce simp: updateCapData_def Let_def isCap_simps split: if_split_asm) - apply (fastforce simp: updateCapData_def Let_def isCap_simps split: if_split_asm) - apply (fastforce dest: arch_updateCapData_ordering simp: updateCapData_def isCap_simps) + apply (fastforce simp: updateCapData_def Let_def gen_isCap_simps split: if_split_asm) + apply (fastforce simp: updateCapData_def Let_def gen_isCap_simps split: if_split_asm) + apply (fastforce dest: arch_updateCapData_ordering simp: updateCapData_def gen_isCap_simps) done lemma updateCapData_capReplyMaster: "isReplyCap cap \ capReplyMaster (updateCapData p d cap) = capReplyMaster cap" - by (clarsimp simp: isCap_simps updateCapData_def split del: if_split) - -lemma ArchUpdateCapData_noReply: (* arch interface *) - "Arch.updateCapData p d acap \ capability.ReplyCap x y z" - by (cases acap; simp add: AARCH64_H.updateCapData_def) + by (clarsimp simp: gen_isCap_simps updateCapData_def split del: if_split) lemma updateCapData_is_Reply[simp]: "(updateCapData p d cap = ReplyCap x y z) = (cap = ReplyCap x y z)" by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def ArchUpdateCapData_noReply + clarsimp simp: gen_isCap_simps updateCapData_def Let_def ArchUpdateCapData_noReply split del: if_split split: if_split_asm) -lemma ArchUpdateCapData_noIRQControl: (* arch interface *) - "Arch.updateCapData p d acap \ IRQControlCap" - by (cases acap; simp add: AARCH64_H.updateCapData_def) - lemma updateCapDataIRQ: "updateCapData p d cap \ NullCap \ isIRQControlCap (updateCapData p d cap) = isIRQControlCap cap" - by (cases cap; simp add: updateCapData_def isCap_simps Let_def ArchUpdateCapData_noIRQControl) + by (cases cap; simp add: updateCapData_def gen_isCap_simps Let_def ArchUpdateCapData_noIRQControl) -lemma updateCapData_vs_cap_ref'[simp]: - "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" - by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def - AARCH64_H.updateCapData_def - vs_cap_ref'_def - split del: if_split - split: if_split_asm arch_capability.splits) - -lemma isFrameCap_updateCapData[simp]: - "isArchCap isFrameCap (updateCapData pr D c) = isArchCap isFrameCap c" - apply (case_tac c; simp add:updateCapData_def isCap_simps isArchCap_def) - apply (rename_tac arch_capability) - apply (case_tac arch_capability; simp add: AARCH64_H.updateCapData_def isCap_simps isArchCap_def) - apply (clarsimp split:capability.splits simp:Let_def) - done +end (* Ipc_R *) + +crunch transferCaps + for typ_at'[wp]: "\s. P (typ_at' T p s)" + +lemmas transferCaps_gen_typ_ats[wp] = gen_typ_at_lifts [OF transferCaps_typ_at'] + +lemma capReplyMaster_mask[simp]: + "isReplyCap c \ capReplyMaster (maskCapRights R c) = capReplyMaster c" + by (clarsimp simp: gen_isCap_simps maskCapRights_def) lemma lookup_cap_to'[wp]: "\\\ lookupCap t cref \\rv s. \r\cte_refs' rv (irq_node' s). ex_cte_cap_to' r s\,-" @@ -1196,7 +1255,7 @@ lemma grs_length'[wp]: apply (wp | wpc | simp)+ done -lemma transferCaps_invs' [wp]: +lemma (in Ipc_R) transferCaps_invs' [wp]: "\invs' and transferCaps_srcs caps\ transferCaps mi caps ep receiver recv_buf \\rv. invs'\" @@ -1205,18 +1264,11 @@ lemma transferCaps_invs' [wp]: | wpcw | clarsimp)+ done -lemma get_mrs_inv'[wp]: - "\P\ getMRs t buf info \\rv. P\" - by (simp add: getMRs_def load_word_offs_def getRegister_def - | wp dmo_inv' loadWord_inv mapM_wp' - asUser_inv det_mapM[where S=UNIV] | wpc)+ - - lemma copyMRs_typ_at': "\\s. P (typ_at' T p s)\ copyMRs s sb r rb n \\rv s. P (typ_at' T p s)\" by (simp add: copyMRs_def | wp mapM_wp [where S=UNIV, simplified] | wpc)+ -lemmas copyMRs_typ_at_lifts[wp] = typ_at_lifts [OF copyMRs_typ_at'] +lemmas copyMRs_gen_typ_at_lifts[wp] = gen_typ_at_lifts[OF copyMRs_typ_at'] lemma copy_mrs_invs'[wp]: "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" @@ -1373,30 +1425,27 @@ lemma lookupExtraCaps_corres: apply (simp add: getExtraCPtrs_def mapME_Nil) apply (rule corres_returnOk) apply simp - apply (simp add: msgLengthBits_def msgMaxLength_def word_size field_simps - getExtraCPtrs_def upto_enum_step_def upto_enum_word - word_size_def msg_max_length_def liftM_def - Suc_unat_diff_1 word_le_sub1 mapM_map_simp - upt_lhs_sub_map[where x=buffer_cptr_index] - wordSize_def wordBits_def - del: upt.simps) + apply (simp add: getExtraCPtrs_def mapM_map_simp liftM_def + upt_lhs_sub_map[where x=buffer_cptr_index] upto_enum_word + Suc_unat_diff_1 word_le_sub1 upto_enum_step_def) apply (rule corres_guard_imp) apply (rule corres_underlying_split) - + apply (simp add: msgMax_simps wordSize_word_size buffer_cptr_index_def) apply (rule_tac S = "\x y. x = y \ x < unat w2" - in corres_mapM_list_all2 - [where Q = "\_. valid_objs and pspace_aligned and tcb_at thread" and r = "(=)" - and Q' = "\_. valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer'" and r'="(=)" ]) + in corres_mapM_list_all2[ + where Q = "\_. valid_objs and pspace_aligned and tcb_at thread" and r = "(=)" + and Q' = "\_. valid_objs' and pspace_aligned' and pspace_distinct' + and tcb_at' thread + and case_option \ valid_ipc_buffer_ptr' buffer'" + and r'="(=)" ]) apply simp apply simp apply simp apply (rule corres_guard_imp) apply (rule loadWordUser_corres') - apply (clarsimp simp: buffer_cptr_index_def msg_max_length_def - max_ipc_words valid_message_info_def + apply (clarsimp simp: max_ipc_words valid_message_info_def msg_max_length_def msg_max_extra_caps_def word_le_nat_alt) - apply (simp add: buffer_cptr_index_def msg_max_length_def) + apply (simp add: msg_max_length_def) apply simp apply simp apply (simp add: load_word_offs_word_def) @@ -1429,6 +1478,32 @@ crunch copy_mrs for valid_arch_state[wp]: valid_arch_state (wp: crunch_wps) +lemma corres_liftE_lift: + "corres r1 P P' m m' \ + corres (f1 \ r1) P P' (liftE m) (withoutFailure m')" + by simp + +lemmas corres_ipc_thread_helper = + corres_split_eqrE[OF corres_liftE_lift [OF getCurThread_corres]] + +crunch doNormalTransfer + for typ_at'[wp]: "\s. P (typ_at' T p s)" + +lemmas doNormal_gen_typ_at_lifts[wp] = gen_typ_at_lifts[OF doNormalTransfer_typ_at'] + +crunch doNormalTransfer + for aligned'[wp]: pspace_aligned' + and distinct'[wp]: pspace_distinct' + (wp: crunch_wps) + +crunch doNormalTransfer + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: crunch_wps transferCapsToSlots_pres1 ignore: constOnFailure) + +lemmas asUser_urz = untyped_ranges_zero_lift[OF asUser_gsUntypedZeroRanges] + +context Ipc_R begin + lemma doNormalTransfer_corres: "corres dc (tcb_at sender and tcb_at receiver and (pspace_aligned:: det_state \ bool) @@ -1437,8 +1512,8 @@ lemma doNormalTransfer_corres: and case_option \ in_user_frame send_buf and case_option \ in_user_frame recv_buf) (tcb_at' sender and tcb_at' receiver and valid_objs' - and pspace_aligned' and pspace_distinct' and pspace_canonical' and cur_tcb' - and valid_mdb' and no_0_obj' + and pspace_aligned' and pspace_distinct' and pspace_canonical' and pspace_in_kernel_mappings' + and cur_tcb' and valid_mdb' and no_0_obj' and (\s. case ep of Some x \ ep_at' x s | _ \ True) and case_option \ valid_ipc_buffer_ptr' send_buf and case_option \ valid_ipc_buffer_ptr' recv_buf) @@ -1466,7 +1541,7 @@ lemma doNormalTransfer_corres: in corres_gen_asm) apply (rule corres_split_nor[OF setMessageInfo_corres]) apply (case_tac mi', clarsimp) - apply (simp add: badge_register_def badgeRegister_def) + apply (simp add: badgeRegister_badge_register) apply (fold dc_def) apply (rule asUser_setRegister_corres) apply wp @@ -1481,23 +1556,10 @@ lemma doNormalTransfer_corres: apply auto done -lemma corres_liftE_lift: - "corres r1 P P' m m' \ - corres (f1 \ r1) P P' (liftE m) (withoutFailure m')" - by simp - -lemmas corres_ipc_thread_helper = - corres_split_eqrE[OF corres_liftE_lift [OF getCurThread_corres]] - lemmas corres_ipc_info_helper = corres_split_maprE [where f = message_info_map, OF _ corres_liftE_lift [OF getMessageInfo_corres]] -crunch doNormalTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas doNormal_lifts[wp] = typ_at_lifts [OF doNormalTransfer_typ_at'] - lemma doNormal_invs'[wp]: "\tcb_at' sender and tcb_at' receiver and invs'\ doNormalTransfer sender send_buf ep badge @@ -1506,13 +1568,6 @@ lemma doNormal_invs'[wp]: apply (wp hoare_vcg_const_Ball_lift | simp)+ done -crunch doNormalTransfer - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps) -crunch doNormalTransfer - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps) - lemma transferCaps_urz[wp]: "\untyped_ranges_zero' and valid_pspace' and (\s. (\x\set caps. cte_wp_at' (\cte. fst x \ capability.NullCap \ cteCap cte = fst x) (snd x) s))\ @@ -1526,16 +1581,12 @@ lemma transferCaps_urz[wp]: apply clarsimp done -crunch doNormalTransfer - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 ignore: constOnFailure) - -lemmas asUser_urz = untyped_ranges_zero_lift[OF asUser_gsUntypedZeroRanges] - crunch doNormalTransfer for urz[wp]: "untyped_ranges_zero'" (ignore: asUser wp: crunch_wps asUser_urz hoare_vcg_const_Ball_lift) +end (* Ipc_R *) + lemma msgFromLookupFailure_map[simp]: "msgFromLookupFailure (lookup_failure_map lf) = msg_from_lookup_failure lf" @@ -1553,23 +1604,31 @@ lemma asUser_mapM_getRegister_corres: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t (mapM getRegister regs)) (asUser t (mapM getRegister regs))" - apply (rule asUser_corres') - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_mapM) - apply (simp add: getRegister_def) - done + by (corres corres: asUser_corres' wp: no_fail_mapM no_fail_getRegister) -lemma makeArchFaultMessage_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_arch_fault_msg f t) - (makeArchFaultMessage (arch_fault_map f) t)" - apply (cases f; clarsimp simp: makeArchFaultMessage_def ucast_nat_def split: arch_fault.split) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_trivial, simp) - apply (wp+, auto) +lemmas threadget_fault_corres = + threadGet_corres [where r = fault_rel_optionation + and f = tcb_fault and f' = tcbFault, + simplified tcb_relation_def, simplified] + +(* Used in CRefine *) +lemma asUser_valid_ipc_buffer_ptr'[wp]: + "asUser t m \\s. valid_ipc_buffer_ptr' p s\" + by (simp add: valid_ipc_buffer_ptr'_def, wp) + +lemma lec_valid_cap'[wp]: + "\valid_objs'\ lookupExtraCaps thread xa mi \\rv s. (\x\set rv. s \' fst x)\, -" + apply (rule hoare_pre, rule hoare_strengthen_postE_R) + apply (rule hoare_vcg_conj_liftE_R[where P'=valid_objs' and Q'="\_. valid_objs'"]) + apply (rule lookupExtraCaps_srcs) + apply wp + apply (clarsimp simp: cte_wp_at_ctes_of) + apply fastforce + apply simp done +context Ipc_R begin + lemma makeFaultMessage_corres: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (make_fault_msg ft t) @@ -1579,12 +1638,12 @@ lemma makeFaultMessage_corres: apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) apply (rule corres_trivial, simp add: fromEnum_def enum_bool) apply (wp | simp)+ - apply (simp add: AARCH64_H.syscallMessage_def) + apply (simp add: syscallMessage_def') apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) apply (rule corres_trivial, simp) apply (wp | simp)+ - apply (simp add: AARCH64_H.exceptionMessage_def) + apply (simp add: exceptionMessage_def') apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) apply (rule corres_trivial, simp) @@ -1594,17 +1653,8 @@ lemma makeFaultMessage_corres: lemma makeFaultMessage_inv[wp]: "\P\ makeFaultMessage ft t \\rv. P\" - apply (cases ft, simp_all add: makeFaultMessage_def) - apply (wp asUser_inv mapM_wp' det_mapM[where S=UNIV] - det_getRestartPC getRestartPC_inv - | clarsimp simp: getRegister_def makeArchFaultMessage_def - split: arch_fault.split)+ - done - -lemmas threadget_fault_corres = - threadGet_corres [where r = fault_rel_optionation - and f = tcb_fault and f' = tcbFault, - simplified tcb_relation_def, simplified] + by (cases ft; + wpsimp simp: makeFaultMessage_def wp: asUser_inv mapM_wp' getRestartPC_inv getRegister_inv) lemma doFaultTransfer_corres: "corres dc @@ -1615,7 +1665,7 @@ lemma doFaultTransfer_corres: (do_fault_transfer badge sender receiver recv_buf) (doFaultTransfer badge sender receiver recv_buf)" apply (clarsimp simp: do_fault_transfer_def doFaultTransfer_def split_def - AARCH64_H.badgeRegister_def badge_register_def) + badgeRegister_badge_register) apply (rule_tac Q="\fault. K (\f. fault = Some f) and tcb_at sender and tcb_at receiver and case_option \ in_user_frame recv_buf and @@ -1655,62 +1705,10 @@ lemma doFaultTransfer_corres: lemma doFaultTransfer_invs[wp]: "\invs' and tcb_at' receiver\ - doFaultTransfer badge sender receiver recv_buf + doFaultTransfer badge sender receiver recv_buf \\rv. invs'\" by (simp add: doFaultTransfer_def split_def | wp - | clarsimp split: option.split)+ - -lemma lookupIPCBuffer_valid_ipc_buffer [wp]: - "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" - unfolding lookupIPCBuffer_def AARCH64_H.lookupIPCBuffer_def - supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) - apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def - locateSlot_conv threadGet_def comp_def) - apply (wp getCTE_wp getObject_tcb_wp | wpc)+ - apply (clarsimp simp del: imp_disjL) - apply (drule obj_at_ko_at') - apply (clarsimp simp del: imp_disjL) - apply (rule_tac x = ko in exI) - apply (frule ko_at_cte_ipcbuffer[simplified cteSizeBits_def]) - apply (clarsimp simp: cte_wp_at_ctes_of shiftl_t2n' simp del: imp_disjL) - apply (rename_tac ref rg sz d m) - apply (clarsimp simp: valid_ipc_buffer_ptr'_def) - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKO_opts_defs split: kernel_object.split_asm) - apply (clarsimp simp add: valid_obj'_def valid_tcb'_def - isCap_simps cte_level_bits_def field_simps) - apply (drule bspec [OF _ ranI [where a = "4 << cteSizeBits"]]) - apply (simp add: cteSizeBits_def) - apply (clarsimp simp add: valid_cap'_def frame_at'_def) - apply (rule conjI) - apply (rule aligned_add_aligned) - apply (clarsimp simp add: capAligned_def) - apply assumption - apply (erule is_aligned_andI1) - apply (rule order_trans[rotated]) - apply (rule pbfs_atleast_pageBits) - apply (simp add: bit_simps msg_align_bits) - apply (clarsimp simp: capAligned_def) - apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize sz)) >> pageBits" in spec) - apply (simp add: shiftr_shiftl1 ) - apply (subst (asm) mask_out_add_aligned) - apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) - apply (erule mp) - apply (rule shiftr_less_t2n) - apply (clarsimp simp: pbfs_atleast_pageBits) - apply (rule and_mask_less') - apply (simp add: word_bits_conv pbfs_less_wb'[unfolded word_bits_conv]) - done - -(* Used in CRefine *) -lemma lookupIPCBuffer_Some_0: - "\\\ lookupIPCBuffer w t \\rv s. rv \ Some 0\" - by (wpsimp simp: lookupIPCBuffer_def Let_def getThreadBufferSlot_def locateSlot_conv) - -(* Used in CRefine *) -lemma asUser_valid_ipc_buffer_ptr': - "asUser t m \\s. valid_ipc_buffer_ptr' p s\" - by (simp add: valid_ipc_buffer_ptr'_def, wp) + | clarsimp split: option.split)+ lemma doIPCTransfer_corres: "corres dc @@ -1754,7 +1752,6 @@ lemma doIPCTransfer_corres: apply (wp|simp add: obj_at_def is_tcb valid_pspace'_def)+ done - crunch doIPCTransfer for ifunsafe[wp]: "if_unsafe_then_cap'" (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots @@ -1763,6 +1760,7 @@ crunch doIPCTransfer for iflive[wp]: "if_live_then_nonz_cap'" (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM ball_conj_distrib ) + crunch doIPCTransfer for vp[wp]: "valid_pspace'" (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) @@ -1785,7 +1783,8 @@ crunch doIPCTransfer crunch doIPCTransfer for typ_at'[wp]: "\s. P (typ_at' T p s)" (wp: crunch_wps simp: zipWithM_x_mapM) -lemmas dit'_typ_ats[wp] = typ_at_lifts [OF doIPCTransfer_typ_at'] + +lemmas dit'_gen_typ_at_lifts[wp] = gen_typ_at_lifts[OF doIPCTransfer_typ_at'] crunch doIPCTransfer for irq_node'[wp]: "\s. P (irq_node' s)" @@ -1798,20 +1797,6 @@ crunch doIPCTransfer for valid_arch_state'[wp]: "valid_arch_state'" (wp: crunch_wps simp: crunch_simps) -(* Levity: added (20090126 19:32:26) *) -declare asUser_global_refs' [wp] - -lemma lec_valid_cap' [wp]: - "\valid_objs'\ lookupExtraCaps thread xa mi \\rv s. (\x\set rv. s \' fst x)\, -" - apply (rule hoare_pre, rule hoare_strengthen_postE_R) - apply (rule hoare_vcg_conj_liftE_R[where P'=valid_objs' and Q'="\_. valid_objs'"]) - apply (rule lookupExtraCaps_srcs) - apply wp - apply (clarsimp simp: cte_wp_at_ctes_of) - apply fastforce - apply simp - done - crunch doIPCTransfer for objs'[wp]: "valid_objs'" ( wp: crunch_wps hoare_vcg_const_Ball_lift @@ -1824,8 +1809,6 @@ crunch doIPCTransfer transferCapsToSlots_valid_globals simp: zipWithM_x_mapM ball_conj_distrib) -declare asUser_irq_handlers' [wp] - crunch doIPCTransfer for irq_handlers'[wp]: "valid_irq_handlers'" (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_irq_handlers' @@ -1849,30 +1832,12 @@ lemma doIPCTransfer_invs[wp]: apply (wpsimp wp: hoare_drop_imp) done - -lemma arch_getSanitiseRegisterInfo_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (arch_get_sanitise_register_info t) - (getSanitiseRegisterInfo t)" - unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def - apply (fold archThreadGet_def) - apply corres - done - -crunch getSanitiseRegisterInfo - for tcb_at'[wp]: "tcb_at' t" - -crunch arch_get_sanitise_register_info - for pspace_distinct[wp]: pspace_distinct - and pspace_aligned[wp]: pspace_aligned - lemma handle_fault_reply_registers_corres: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (do t' \ arch_get_sanitise_register_info t; y \ as_user t (zipWithM_x - (\r v. setRegister r - (sanitise_register t' r v)) + (\r v. setRegister r (sanitise_register t' r v)) msg_template msg); return (label = 0) od) @@ -1883,36 +1848,35 @@ lemma handle_fault_reply_registers_corres: msg_template msg); return (label = 0) od)" - apply (rule corres_guard_imp) - apply (rule corres_split[OF arch_getSanitiseRegisterInfo_corres]) - apply (rule corres_split) - apply (rule asUser_corres') - apply(simp add: setRegister_def sanitise_register_def - sanitiseRegister_def syscallMessage_def Let_def cong: register.case_cong) - apply(subst zipWithM_x_modify)+ - apply(rule corres_modify') - apply (simp|wp)+ + apply (corres corres: arch_getSanitiseRegisterInfo_corres) + apply (simp add: sanitiseRegister_sanitise_register) + apply (corres corres: asUser_corres' wp: no_fail_zipWithM_x det_no_fail det_setRegister) + apply (wpsimp wp: arch_get_sanitise_register_info_inv)+ done +crunch handleFaultReply + for typ_at'[wp]: "\s. P (typ_at' T p s)" + and ct'[wp]: "\s. P (ksCurThread s)" + and nosch[wp]: "\s. P (ksSchedulerAction s)" + and tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" + and pred_tcb_at'[wp]: "pred_tcb_at' proj P t" + and valid_objs'[wp]: valid_objs' + +crunch handle_fault_reply + for pspace_alignedp[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + (wp: arch_get_sanitise_register_info_inv) + lemma handleFaultReply_corres: "ft' = fault_map ft \ corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (handle_fault_reply ft t label msg) (handleFaultReply ft' t label msg)" - apply (cases ft) - apply(simp_all add: handleFaultReply_def - handle_arch_fault_reply_def handleArchFaultReply_def - syscallMessage_def exceptionMessage_def - split: arch_fault.split) - by (rule handle_fault_reply_registers_corres)+ - -crunch handleFaultReply - for typ_at'[wp]: "\s. P (typ_at' T p s)" + by (cases ft; simp add: handleFaultReply_def syscallMessage_def' exceptionMessage_def' + handle_fault_reply_registers_corres) + (corres corres: handleArchFaultReply_corres) -lemmas hfr_typ_ats[wp] = typ_at_lifts [OF handleFaultReply_typ_at'] - -crunch handleFaultReply - for ct'[wp]: "\s. P (ksCurThread s)" +lemmas hfr_gen_typ_at_lifts[wp] = gen_typ_at_lifts[OF handleFaultReply_typ_at'] lemma doIPCTransfer_sch_act_simple [wp]: "\sch_act_simple\ doIPCTransfer sender endpoint badge grant receiver \\_. sch_act_simple\" @@ -1975,10 +1939,7 @@ lemma handleFaultReply_cur' [wp]: lemma capClass_Reply: "capClass cap = ReplyClass tcb \ isReplyCap cap \ capTCBPtr cap = tcb" - apply (cases cap, simp_all add: isCap_simps) - apply (rename_tac arch_capability) - apply (case_tac arch_capability, simp_all) - done + by (cases cap, simp_all add: gen_isCap_simps acapClass_not_ReplyClass) lemma reply_cap_end_mdb_chain: "\ cte_wp_at (is_reply_cap_to t) slot s; invs s; @@ -2014,21 +1975,17 @@ lemma reply_cap_end_mdb_chain: apply (rule valid_dlistEn, assumption+) apply (subgoal_tac "ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)") apply (frule(3) class_linksD) - apply (clarsimp simp: isCap_simps dest!: capClass_Reply[OF sym]) + apply (clarsimp simp: gen_isCap_simps dest!: capClass_Reply[OF sym]) apply (drule_tac f="\S. mdbNext (cteMDBNode cte) \ S" in arg_cong) apply (simp, erule notE, rule subtree.trans_parent, assumption+) apply (case_tac ctea, case_tac cte') - apply (clarsimp simp add: parentOf_def isMDBParentOf_CTE) - apply (simp add: sameRegionAs_def2 isCap_simps) - apply (erule subtree.cases) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) + apply (clarsimp simp: ctes_of_mdbNext_parentOf) apply (simp add: mdb_next_unfold) apply (erule subtree.cases) apply (clarsimp simp: valid_mdb_ctes_def) apply (erule_tac cte=ctea in valid_dlistEn, assumption) apply (simp add: mdb_next_unfold) - apply (clarsimp simp: mdb_next_unfold isCap_simps) + apply (clarsimp simp: mdb_next_unfold gen_isCap_simps) apply (drule_tac f="\S. c' \ S" in arg_cong) apply (clarsimp simp: no_loops_direct_simp valid_mdb_no_loops) apply (frule invs_mdb) @@ -2058,9 +2015,6 @@ crunch cteDeleteOne (simp: crunch_simps unless_def wp: crunch_wps getObject_inv loadObject_default_inv) -crunch handleFaultReply - for nosch[wp]: "\s. P (ksSchedulerAction s)" - lemma emptySlot_weak_sch_act[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ emptySlot slot irq @@ -2098,27 +2052,15 @@ lemma cteDeleteOne_weak_sch_act[wp]: | simp add: split_def)+ done -crunch handleFaultReply - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" -crunch handleFaultReply - for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - crunch unbindNotification for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" (wp: sbn_sch_act') -crunch handleFaultReply - for valid_objs'[wp]: valid_objs' - lemma cte_wp_at_is_reply_cap_toI: "cte_wp_at ((=) (cap.ReplyCap t False rights)) ptr s \ cte_wp_at (is_reply_cap_to t) ptr s" by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) -crunch handle_fault_reply - for pspace_alignedp[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - crunch cteDeleteOne, doIPCTransfer, handleFaultReply for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers and valid_sched_pointers[wp]: valid_sched_pointers @@ -2216,8 +2158,8 @@ lemma doReplyTransfer_corres: apply simp apply (rule corres_split) apply (rule threadset_corresT; - clarsimp simp add: tcb_relation_def fault_rel_optionation_def cteSizeBits_def - tcb_cap_cases_def tcb_cte_cases_def inQ_def) + clarsimp simp add: tcb_relation_def fault_rel_optionation_def inQ_def + tcb_cte_cases_neqs tcb_cap_cases_def tcb_cte_cases_def) apply (rule_tac Q="valid_sched and cur_tcb and tcb_at receiver and pspace_aligned and pspace_distinct" and Q'="tcb_at' receiver and cur_tcb' and (\s. weak_sch_act_wf (ksSchedulerAction s) s) @@ -2277,11 +2219,9 @@ lemma doReplyTransfer_corres': using doReplyTransfer_corres[of receiver sender _ slot] by (fastforce simp add: cte_wp_at_reply_cap_to_ex_rights corres_underlying_def) -lemma valid_pspace'_splits[elim!]: (* FIXME AARCH64: clean up duplicates *) - "valid_pspace' s \ valid_objs' s" +lemma valid_pspace'_splits[elim!]: "valid_pspace' s \ pspace_aligned' s" "valid_pspace' s \ pspace_distinct' s" - "valid_pspace' s \ valid_mdb' s" "valid_pspace' s \ no_0_obj' s" by (simp add: valid_pspace'_def)+ @@ -2294,8 +2234,6 @@ lemma sts_valid_pspace_hangers: "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. no_0_obj'\" by (safe intro!: hoare_strengthen_post [OF sts'_valid_pspace'_inv]) -declare no_fail_getSlotCap [wp] - lemma setupCallerCap_corres: "corres dc (st_tcb_at (Not \ halted) sender and tcb_at receiver and @@ -2318,7 +2256,7 @@ lemma setupCallerCap_corres: apply (rule corres_symb_exec_r) apply (rule_tac F="\r. cteCap masterCTE = capability.ReplyCap sender True r \ mdbNext (cteMDBNode masterCTE) = nullPointer" - in corres_gen_asm2, clarsimp simp add: isCap_simps) + in corres_gen_asm2, clarsimp simp add: gen_isCap_simps) apply (rule corres_symb_exec_r) apply (rule_tac F="rv = capability.NullCap" in corres_gen_asm2, simp) @@ -2375,7 +2313,7 @@ crunch setupCallerCap lemma cteInsert_sch_act_wf[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert newCap srcSlot destSlot + cteInsert newCap srcSlot destSlot \\_ s. sch_act_wf (ksSchedulerAction s) s\" by (wp sch_act_wf_lift tcb_in_cur_domain'_lift) @@ -2401,7 +2339,7 @@ lemma possibleSwitchTo_weak_sch_act_wf[wp]: done lemmas transferCapsToSlots_pred_tcb_at' = - transferCapsToSlots_pres1 [OF cteInsert_pred_tcb_at'] + transferCapsToSlots_pres1 [OF cteInsert_pred_tcb_at'] crunch doIPCTransfer, possibleSwitchTo for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" @@ -2537,6 +2475,7 @@ proof - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid st_tcb_def2 valid_sched_def valid_sched_action_def) apply (force simp: st_tcb_def2 dest!: st_tcb_at_caller_cap_null[simplified,rotated]) + (* FIXME: weak elimination rule warning *) subgoal by (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split) apply wp+ apply (clarsimp simp: ep_at_def2)+ @@ -2607,6 +2546,7 @@ proof - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid st_tcb_at_caller_cap_null) apply (fastforce simp: st_tcb_def2 valid_sched_def valid_sched_action_def) + (* FIXME: weak elimination rule warning *) subgoal by (auto simp: valid_ep'_def split: list.split; clarsimp simp: invs'_def valid_state'_def) @@ -2615,10 +2555,7 @@ proof - done qed -lemmas setMessageInfo_typ_ats[wp] = typ_at_lifts [OF setMessageInfo_typ_at'] - -(* Annotation added by Simon Winwood (Thu Jul 1 20:54:41 2010) using taint-mode *) -declare tl_drop_1[simp] +lemmas setMessageInfo_gen_typ_at_lifts[wp] = gen_typ_at_lifts[OF setMessageInfo_typ_at'] crunch cancel_ipc for cur[wp]: "cur_tcb" @@ -2660,7 +2597,7 @@ lemma sendSignal_corres: apply (rule corres_split[OF cancel_ipc_corres]) apply (rule corres_split[OF setThreadState_corres]) apply (clarsimp simp: thread_state_relation_def) - apply (simp add: badgeRegister_def badge_register_def) + apply (simp add: badgeRegister_badge_register) apply (rule corres_split[OF asUser_setRegister_corres]) apply (rule possibleSwitchTo_corres) apply wp @@ -2695,7 +2632,7 @@ lemma sendSignal_corres: apply (simp add: ntfn_relation_def) apply (rule corres_split[OF setThreadState_corres]) apply simp - apply (simp add: badgeRegister_def badge_register_def) + apply (simp add: badgeRegister_badge_register) apply (rule corres_split[OF asUser_setRegister_corres]) apply (rule possibleSwitchTo_corres) apply ((wp | simp)+)[1] @@ -2727,7 +2664,7 @@ lemma sendSignal_corres: apply (simp add: ntfn_relation_def split:list.splits) apply (rule corres_split[OF setThreadState_corres]) apply simp - apply (simp add: badgeRegister_def badge_register_def) + apply (simp add: badgeRegister_badge_register) apply (rule corres_split[OF asUser_setRegister_corres]) apply (rule possibleSwitchTo_corres) apply (wp cur_tcb_lift | simp)+ @@ -2741,6 +2678,7 @@ lemma sendSignal_corres: valid_pspace_def neq_Nil_conv ntfn_queued_st_tcb_at valid_sched_def valid_sched_action_def split: option.splits) + (* FIXME: weak elimination rule warning *) apply (auto simp: valid_ntfn'_def neq_Nil_conv invs'_def valid_state'_def weak_sch_act_wf_def split: option.splits)[1] @@ -2748,8 +2686,7 @@ lemma sendSignal_corres: apply (clarsimp simp add: ntfn_relation_def) apply (rule corres_guard_imp) apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def combine_ntfn_badges_def - combine_ntfn_msgs_def) + apply (simp add: ntfn_relation_def combine_ntfn_badges_def) apply (simp add: invs_def valid_state_def valid_ntfn_def) apply (simp add: invs'_def valid_state'_def valid_ntfn'_def) done @@ -2764,7 +2701,7 @@ crunch setMRs lemma possibleSwitchTo_sch_act[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t + possibleSwitchTo t \\rv s. sch_act_wf (ksSchedulerAction s) s\" apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) apply (wp hoare_weak_lift_imp threadSet_sch_act setQueue_sch_act threadGet_wp @@ -2816,7 +2753,7 @@ crunch possibleSwitchTo (wp: crunch_wps) crunch possibleSwitchTo for irq_handlers'[wp]: valid_irq_handlers' - (simp: unless_def tcb_cte_cases_def cteSizeBits_def wp: crunch_wps) + (simp: unless_def tcb_cte_cases_def tcb_cte_cases_neqs wp: crunch_wps) crunch possibleSwitchTo for irq_states'[wp]: valid_irq_states' (wp: crunch_wps) @@ -2876,10 +2813,10 @@ lemma cteDeleteOne_reply_cap_to'[wp]: apply (rule hoare_assume_pre) apply (subgoal_tac "isReplyCap (cteCap cte)") apply (wp hoare_vcg_ex_lift emptySlot_cte_wp_cap_other isFinalCapability_inv - | clarsimp simp: finaliseCap_def isCap_simps + | clarsimp simp: finaliseCap_def gen_isCap_simps | wp (once) hoare_drop_imps)+ apply (fastforce simp: cte_wp_at_ctes_of) - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) + apply (clarsimp simp: cte_wp_at_ctes_of gen_isCap_simps) done crunch setupCallerCap, possibleSwitchTo, asUser, doIPCTransfer @@ -2901,7 +2838,6 @@ lemma cancelIPC_nonz_cap_to'[wp]: | rule hoare_post_imp[where Q'="\rv. ex_nonz_cap_to' p"])+ done - crunch activateIdleThread, getThreadReplySlot, isFinalCapability for nosch[wp]: "\s. P (ksSchedulerAction s)" (simp: Let_def) @@ -3014,7 +2950,8 @@ qed lemma sai_invs'[wp]: "\invs' and ex_nonz_cap_to' ntfnptr\ - sendSignal ntfnptr badge \\y. invs'\" + sendSignal ntfnptr badge + \\y. invs'\" unfolding sendSignal_def apply (rule bind_wp[OF _ get_ntfn_sp']) apply (case_tac "ntfnObj nTFN", simp_all) @@ -3104,8 +3041,7 @@ lemma replyFromKernel_corres: "corres dc (tcb_at t and invs) (invs') (reply_from_kernel t r) (replyFromKernel t r)" apply (case_tac r) - apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def - badge_register_def badgeRegister_def) + apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def badgeRegister_badge_register) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF lookupIPCBuffer_corres]) apply (rule corres_split[OF asUser_setRegister_corres]) @@ -3141,7 +3077,7 @@ lemma completeSignal_corres: apply (clarsimp simp: ntfn_relation_def isActive_def split: ntfn.splits Structures_H.notification.splits)+ apply (rule corres_guard2_imp) - apply (simp add: badgeRegister_def badge_register_def) + apply (simp add: badgeRegister_badge_register) apply (rule corres_split[OF asUser_setRegister_corres setNotification_corres]) apply (clarsimp simp: ntfn_relation_def) apply (wp set_simple_ko_valid_objs get_simple_ko_wp getNotification_wp | clarsimp simp: valid_ntfn'_def)+ @@ -3150,13 +3086,12 @@ lemma completeSignal_corres: apply (clarsimp simp: valid_obj'_def valid_ntfn'_def obj_at'_def) done - lemma doNBRecvFailedTransfer_corres: "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ (do_nbrecv_failed_transfer thread) (doNBRecvFailedTransfer thread)" unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def - by (simp add: badgeRegister_def badge_register_def, rule asUser_setRegister_corres) + by (simp add: badgeRegister_badge_register, rule asUser_setRegister_corres) lemma receiveIPC_corres: assumes "is_ep_cap cap" and "cap_relation cap cap'" @@ -3265,7 +3200,7 @@ lemma receiveIPC_corres: \ sym_heap_sched_pointers s \ valid_sched_pointers s \ pspace_aligned' s \ pspace_distinct' s" in hoare_post_imp) - apply (fastforce elim: sch_act_wf_weak) + apply fastforce apply (wp sts_st_tcb' gts_st_tcb_at | simp)+ apply (simp cong: list.case_cong) apply wp @@ -3276,6 +3211,7 @@ lemma receiveIPC_corres: apply (clarsimp simp add: valid_ep_def valid_pspace_def) apply (drule(1) sym_refs_obj_atD[where P="\ko. ko = Endpoint e" for e]) apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) + (* FIXME weak elimination rule warning *) apply (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split)[1] \ \RecvEP\ apply (simp add: ep_relation_def) @@ -3350,7 +3286,7 @@ lemma receiveSignal_corres: \ \ActiveNtfn\ apply (simp add: ntfn_relation_def) apply (rule corres_guard_imp) - apply (simp add: badgeRegister_def badge_register_def) + apply (simp add: badgeRegister_badge_register) apply (rule corres_split[OF asUser_setRegister_corres]) apply (rule setNotification_corres) apply (simp add: ntfn_relation_def) @@ -3375,8 +3311,6 @@ lemma tg_sp': apply simp done -declare lookup_cap_valid' [wp] - lemma sendFaultIPC_corres: "valid_fault f \ fr f f' \ corres (fr \ dc) @@ -3399,7 +3333,7 @@ lemma sendFaultIPC_corres: and valid_cap' handlerCap" in corres_inst) apply (case_tac handler_cap, - simp_all add: isCap_defs lookup_failure_map_def + simp_all add: gen_isCap_defs lookup_failure_map_def case_bool_If If_rearrage split del: if_split cong: if_cong)[1] apply (rule corres_guard_imp) @@ -3425,14 +3359,6 @@ lemma sendFaultIPC_corres: apply fastforce done -lemma gets_the_noop_corres: - assumes P: "\s. P s \ f s \ None" - shows "corres dc P P' (gets_the f) (return x)" - apply (clarsimp simp: corres_underlying_def gets_the_def - return_def gets_def bind_def get_def) - apply (clarsimp simp: assert_opt_def return_def dest!: P) - done - lemma handleDoubleFault_corres: "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ @@ -3447,12 +3373,7 @@ lemma handleDoubleFault_corres: apply simp apply (rule corres_noop2) apply (simp add: exs_valid_def return_def) - apply (rule hoare_eq_P) - apply wp - apply (rule asUser_inv) - apply (rule getRestartPC_inv) - apply (wp no_fail_getRestartPC)+ - apply (wp|simp)+ + apply (wpsimp wp: asUser_inv getRestartPC_inv dmo_inv' no_fail_getRestartPC)+ done crunch sendFaultIPC @@ -3462,13 +3383,13 @@ crunch receiveIPC for typ_at'[wp]: "\s. P (typ_at' T p s)" (wp: crunch_wps) -lemmas receiveIPC_typ_ats[wp] = typ_at_lifts [OF receiveIPC_typ_at'] - crunch receiveSignal for typ_at'[wp]: "\s. P (typ_at' T p s)" (wp: crunch_wps) -lemmas receiveAIPC_typ_ats[wp] = typ_at_lifts [OF receiveSignal_typ_at'] +lemmas receiveIPC_gen_typ_at_lifts[wp] = gen_typ_at_lifts[OF receiveIPC_typ_at'] + +lemmas receiveAIPC_gen_typ_at_lifts[wp] = gen_typ_at_lifts[OF receiveSignal_typ_at'] crunch setupCallerCap for aligned'[wp]: "pspace_aligned'" @@ -3482,7 +3403,7 @@ crunch setupCallerCap lemma setupCallerCap_state_refs_of[wp]: "\\s. P ((state_refs_of' s) (sender := {r \ state_refs_of' s sender. snd r = TCBBound}))\ - setupCallerCap sender rcvr grant + setupCallerCap sender rcvr grant \\rv s. P (state_refs_of' s)\" apply (simp add: setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def) @@ -3497,19 +3418,14 @@ lemma setupCallerCap_state_hyp_refs_of[wp]: done lemma is_derived_ReplyCap' [simp]: - "\m p g. is_derived' m p (capability.ReplyCap t False g) = - (\c. \ g. c = capability.ReplyCap t True g)" - apply (subst fun_eq_iff) - apply clarsimp - apply (case_tac x, simp_all add: is_derived'_def isCap_simps - badge_derived'_def - vs_cap_ref'_def) - done + "is_derived' m p (capability.ReplyCap t False g) = + (\c. \ g. c = capability.ReplyCap t True g)" + by (auto simp: fun_eq_iff is_derived'_Reply gen_isCap_simps) lemma unique_master_reply_cap': "\c t. isReplyCap c \ capReplyMaster c \ capTCBPtr c = t \ (\g . c = capability.ReplyCap t True g)" - by (fastforce simp: isCap_simps conj_comms) + by (fastforce simp: gen_isCap_simps conj_comms) lemma getSlotCap_cte_wp_at: "\\\ getSlotCap sl \\rv. cte_wp_at' (\c. cteCap c = rv) sl\" @@ -3527,15 +3443,13 @@ lemma setupCallerCap_vp[wp]: apply (rule_tac Q'="\_. valid_pspace' and tcb_at' sender and tcb_at' rcvr" in hoare_post_imp) - apply (clarsimp simp: valid_cap'_def o_def cte_wp_at_ctes_of isCap_simps + apply (clarsimp simp: valid_cap'_def o_def cte_wp_at_ctes_of gen_isCap_simps valid_pspace'_def) apply (frule(1) ctes_of_valid', simp add: valid_cap'_def capAligned_def) apply clarsimp apply (wp | simp add: valid_pspace'_def valid_tcb_state'_def)+ done -declare haskell_assert_inv[wp del] - lemma setupCallerCap_iflive[wp]: "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender and pspace_aligned' and pspace_distinct'\ setupCallerCap sender rcvr grant @@ -3554,21 +3468,21 @@ lemma setupCallerCap_ifunsafe[wp]: \\rv. if_unsafe_then_cap'\" unfolding setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv - supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) - apply (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ + apply (wpsimp wp: getSlotCap_cte_wp_at simp: unique_master_reply_cap' + | strengthen eq_imp_strg + | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ apply (rule_tac Q'="\rv. valid_objs' and tcb_at' rcvr and ex_nonz_cap_to' rcvr" in hoare_post_imp) - apply (clarsimp simp: ex_nonz_tcb_cte_caps' tcbCallerSlot_def - objBits_def objBitsKO_def dom_def cte_level_bits_def) - apply (wp sts_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb_state'_def)+ + apply clarsimp + apply (erule (2) ex_nonz_tcb_cte_caps') + apply (clarsimp simp: tcb_cte_cases_def tcb_cte_cases_neqs tcbCallerSlot_def + simp flip: cteSizeBits_cte_level_bits shiftl_t2n) + apply (wpsimp wp: sts_valid_objs' simp: valid_tcb_state'_def)+ done lemma setupCallerCap_global_refs'[wp]: "\valid_global_refs'\ - setupCallerCap sender rcvr grant + setupCallerCap sender rcvr grant \\rv. valid_global_refs'\" unfolding setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def locateSlot_conv @@ -3596,7 +3510,7 @@ lemma setupCallerCap_irq_handlers'[wp]: lemma cteInsert_cap_to': "\ex_nonz_cap_to' p and cte_wp_at' (\c. cteCap c = NullCap) dest\ - cteInsert cap src dest + cteInsert cap src dest \\rv. ex_nonz_cap_to' p\" supply if_cong[cong] apply (simp add: cteInsert_def ex_nonz_cap_to'_def updateCap_def setUntypedCapAsFull_def) @@ -3703,7 +3617,7 @@ lemma ntfn_q_refs_no_bound_refs': "rf : ntfn_q_refs_of' (ntfnObj ob) \invs' and tcb_at' tcb\ - completeSignal ntfnptr tcb + completeSignal ntfnptr tcb \\_. invs'\" apply (simp add: completeSignal_def) apply (rule bind_wp[OF _ get_ntfn_sp']) @@ -3740,7 +3654,7 @@ lemma setupCallerCap_urz[wp]: apply (wp getCTE_wp') apply (rule_tac Q'="\_. untyped_ranges_zero' and valid_mdb' and valid_objs'" in hoare_post_imp) apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def untyped_derived_eq_def - isCap_simps) + gen_isCap_simps) apply (wp sts_valid_pspace_hangers) apply (clarsimp simp: valid_tcb_state'_def) done @@ -3906,7 +3820,7 @@ lemma rai_invs'[wp]: \ capNtfnPtr cap = ntfnptr \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) ntfnptr s)\ - receiveSignal t cap isBlocking + receiveSignal t cap isBlocking \\_. invs'\" apply (simp add: receiveSignal_def) apply (rule bind_wp [OF _ get_ntfn_sp']) @@ -3915,7 +3829,7 @@ lemma rai_invs'[wp]: \ \ep = IdleNtfn\ apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts valid_dom_schedule'_lift + apply (wp valid_irq_node_lift sts_sch_act' gen_typ_at_lifts valid_dom_schedule'_lift setThreadState_ct_not_inQ asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ @@ -3939,13 +3853,13 @@ lemma rai_invs'[wp]: \ \ep = ActiveNtfn\ apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_valid_objs' typ_at_lifts hoare_weak_lift_imp + apply (wp valid_irq_node_lift sts_valid_objs' gen_typ_at_lifts hoare_weak_lift_imp asUser_urz valid_dom_schedule'_lift | simp add: valid_ntfn'_def)+ apply (clarsimp simp: pred_tcb_at' valid_pspace'_def) apply (frule (1) ko_at_valid_objs') apply clarsimp - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def isCap_simps) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def gen_isCap_simps) apply (drule simple_st_tcb_at_state_refs_ofD' ko_at_state_refs_ofD')+ apply (erule delta_sym_refs) @@ -3954,7 +3868,7 @@ lemma rai_invs'[wp]: apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - setThreadState_ct_not_inQ typ_at_lifts valid_dom_schedule'_lift + setThreadState_ct_not_inQ gen_typ_at_lifts valid_dom_schedule'_lift asUser_urz | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ apply (clarsimp simp: valid_tcb_state'_def) @@ -3999,17 +3913,6 @@ lemma lookupCap_cap_to_refs[wp]: apply (wp | simp)+ done -crunch setVMRoot - for valid_objs'[wp]: valid_objs' - (wp: getASID_wp crunch_wps findVSpaceForASID_vs_at_wp - simp: getPoolPtr_def getThreadVSpaceRoot_def if_distribR) - -lemma arch_stt_objs' [wp]: - "\valid_objs'\ Arch.switchToThread t \\rv. valid_objs'\" - apply (simp add: AARCH64_H.switchToThread_def) - apply wp - done - lemma possibleSwitchTo_sch_act_not: "\sch_act_not t' and K (t \ t')\ possibleSwitchTo t \\rv. sch_act_not t'\" apply (simp add: possibleSwitchTo_def setSchedulerAction_def curDomain_def) @@ -4020,8 +3923,6 @@ crunch possibleSwitchTo for urz[wp]: "untyped_ranges_zero'" (simp: crunch_simps unless_def wp: crunch_wps) -declare zipWithM_x_mapM[simp] (* FIXME AARCH64: remove? *) - crunch possibleSwitchTo for pspace_aligned'[wp]: pspace_aligned' and pspace_distinct'[wp]: pspace_distinct' @@ -4068,7 +3969,7 @@ lemma si_invs'[wp]: conj_comms fun_upd_def[symmetric]) apply (frule pred_tcb_at') apply (drule simple_st_tcb_at_state_refs_ofD' st_tcb_at_state_refs_ofD')+ - apply (clarsimp simp: valid_pspace'_splits) + apply (clarsimp simp: valid_pspace'_splits valid_pspace_mdb' valid_pspace_valid_objs') apply (subst fun_upd_idem[where x=t]) apply (clarsimp split: if_split) apply (rule conjI, clarsimp simp: obj_at'_def) @@ -4081,7 +3982,7 @@ lemma si_invs'[wp]: apply (rule conjI) apply (drule bound_tcb_at_state_refs_ofD') apply (fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp simp: conj_ac) + apply (clarsimp simp: conj_left_commute conj.commute) apply (rule conjI, clarsimp simp: idle'_no_refs) apply (rule conjI, clarsimp simp: global'_no_ex_cap) apply (rule conjI) @@ -4200,7 +4101,7 @@ lemma sts_invs_minor'': and (\s. t = ksIdleThread s \ idle' st) and (\s. \ runnable' st \ sch_act_not t s) and invs'\ - setThreadState st t + setThreadState st t \\rv. invs'\" apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) @@ -4218,27 +4119,25 @@ lemma sts_invs_minor'': apply (rule conjI) apply (clarsimp dest!: st_tcb_at_state_refs_ofD' elim!: rsubst[where P=sym_refs] - intro!: ext) + del: ext intro!: ext) apply (fastforce elim!: st_tcb_ex_cap'') done -lemma hf_invs' [wp]: +lemma hf_invs'[wp]: "\invs' and sch_act_not t and st_tcb_at' simple' t and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ handleFault t f \\r. invs'\" apply (simp add: handleFault_def) apply wp - apply (simp add: handleDoubleFault_def) - apply (wp sts_invs_minor'' dmo_invs')+ + apply (simp add: handleDoubleFault_def debugPrint_def) + apply (wp sts_invs_minor'' dmo_invs' asUser_inv getRestartPC_inv) apply (rule hoare_strengthen_postE, rule sfi_invs_plus', simp_all) apply (strengthen no_refs_simple_strg') apply clarsimp done -declare zipWithM_x_mapM [simp del] - lemma gts_st_tcb': "\\\ getThreadState t \\r. st_tcb_at' (\st. st = r) t\" apply (rule hoare_strengthen_post) @@ -4248,7 +4147,7 @@ lemma gts_st_tcb': lemma setupCallerCap_pred_tcb_unchanged: "\pred_tcb_at' proj P t and K (t \ t')\ - setupCallerCap t' t'' g + setupCallerCap t' t'' g \\rv. pred_tcb_at' proj P t\" apply (simp add: setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def) @@ -4299,7 +4198,7 @@ lemma si_blk_makes_runnable': lemma sfi_makes_simple': "\st_tcb_at' simple' t and K (t \ t')\ - sendFaultIPC t' ft + sendFaultIPC t' ft \\rv. st_tcb_at' simple' t\" apply (rule hoare_gen_asm) apply (simp add: sendFaultIPC_def @@ -4310,7 +4209,7 @@ lemma sfi_makes_simple': lemma sfi_makes_runnable': "\st_tcb_at' runnable' t and K (t \ t')\ - sendFaultIPC t' ft + sendFaultIPC t' ft \\rv. st_tcb_at' runnable' t\" apply (rule hoare_gen_asm) apply (simp add: sendFaultIPC_def @@ -4321,7 +4220,7 @@ lemma sfi_makes_runnable': lemma hf_makes_runnable_simple': "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - handleFault t ft + handleFault t ft \\rv. st_tcb_at' P t'\" apply (safe intro!: hoare_gen_asm) apply (simp_all add: handleFault_def handleDoubleFault_def) @@ -4334,7 +4233,7 @@ crunch possibleSwitchTo, completeSignal lemma ri_makes_runnable_simple': "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveIPC t cap isBlocking + receiveIPC t cap isBlocking \\rv. st_tcb_at' P t'\" including no_pre apply (rule hoare_gen_asm)+ @@ -4363,7 +4262,7 @@ lemma ri_makes_runnable_simple': lemma rai_makes_runnable_simple': "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveSignal t cap isBlocking + receiveSignal t cap isBlocking \\rv. st_tcb_at' P t'\" apply (rule hoare_gen_asm) apply (simp add: receiveSignal_def) @@ -4372,7 +4271,7 @@ lemma rai_makes_runnable_simple': lemma sendSignal_st_tcb'_Running: "\st_tcb_at' (\st. st = Running \ P st) t\ - sendSignal ntfnptr bdg + sendSignal ntfnptr bdg \\_. st_tcb_at' (\st. st = Running \ P st) t\" apply (simp add: sendSignal_def) apply (wp sts_st_tcb_at'_cases cancelIPC_st_tcb_at' gts_wp' getNotification_wp hoare_weak_lift_imp @@ -4381,7 +4280,7 @@ lemma sendSignal_st_tcb'_Running: lemma sai_st_tcb': "\st_tcb_at' P t and K (P Running)\ - sendSignal ntfn bdg + sendSignal ntfn bdg \\rv. st_tcb_at' P t\" apply (rule hoare_gen_asm) apply (subgoal_tac "\Q. P = (\st. st = Running \ Q st)") @@ -4389,6 +4288,6 @@ lemma sai_st_tcb': apply (fastforce intro!: exI[where x=P]) done -end +end (* Ipc_R *) end diff --git a/proof/refine/TcbAcc_R.thy b/proof/refine/TcbAcc_R.thy index 12b01b878d..308ab6a62e 100644 --- a/proof/refine/TcbAcc_R.thy +++ b/proof/refine/TcbAcc_R.thy @@ -4996,8 +4996,8 @@ lemma (in TcbAcc_R_2) setThreadState_tcb_in_cur_domain'[wp]: apply (wpsimp wp: threadSet_ct_idle_or_in_cur_domain' hoare_drop_imps)+ done -lemma (in TcbAcc_R_2) asUser_global_refs': - "\valid_global_refs'\ asUser t f \\rv. valid_global_refs'\" +lemma (in TcbAcc_R_2) asUser_global_refs'[wp]: + "asUser t f \valid_global_refs'\" apply (simp add: asUser_def split_def) apply (wpsimp wp: threadSet_global_refs select_f_inv) done @@ -5057,8 +5057,8 @@ lemma get_cap_corres_all_rights_P: apply fastforce done -lemma asUser_irq_handlers': - "\valid_irq_handlers'\ asUser t f \\rv. valid_irq_handlers'\" +lemma asUser_irq_handlers'[wp]: + "asUser t f \valid_irq_handlers'\" apply (simp add: asUser_def split_def) apply (wpsimp wp: threadSet_irq_handlers' [OF all_tcbI, OF ball_tcb_cte_casesI] select_f_inv) done @@ -5074,6 +5074,15 @@ locale TcbAcc_R_3 = TcbAcc_R_2 + \ pspace_aligned' s \ pspace_distinct' s\ setThreadState st t \\rv. if_live_then_nonz_cap'\" + assumes set_mrs_invs'[wp]: + "\receiver recv_buf mrs. + \invs' and tcb_at' receiver\ setMRs receiver recv_buf mrs \\rv. invs'\" + assumes setMRs_corres: + "\mrs' mrs t buf. + mrs' = mrs \ + corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) + (case_option \ valid_ipc_buffer_ptr' buf) + (set_mrs t buf mrs) (setMRs t buf mrs')" begin lemma sts_invs_minor': From 390dd8f5289b9c8bbef32b44bf8eb63a1a204e00 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Wed, 13 May 2026 05:59:43 +1000 Subject: [PATCH 5/7] [wip][fake] copy AARCH64 version of ArchIpc_R To reduce diff during PR review. Signed-off-by: Rafal Kolanski --- proof/refine/ARM/ArchIpc_R.thy | 4388 ++------------------------ proof/refine/ARM_HYP/ArchIpc_R.thy | 4607 ++-------------------------- proof/refine/RISCV64/ArchIpc_R.thy | 4433 +------------------------- proof/refine/X64/ArchIpc_R.thy | 4480 ++------------------------- 4 files changed, 726 insertions(+), 17182 deletions(-) diff --git a/proof/refine/ARM/ArchIpc_R.thy b/proof/refine/ARM/ArchIpc_R.thy index 675c171c96..8d71d34350 100644 --- a/proof/refine/ARM/ArchIpc_R.thy +++ b/proof/refine/ARM/ArchIpc_R.thy @@ -8,917 +8,97 @@ theory ArchIpc_R imports Ipc_R begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming -lemmas lookup_slot_wrapper_defs'[simp] = - lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def +named_theorems Ipc_R_assms -lemma getMessageInfo_corres: "corres ((=) \ message_info_map) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (get_message_info t) (getMessageInfo t)" - apply (rule corres_guard_imp) +declare word64_minus_one_le[simp] + +lemma getMessageInfo_corres[Ipc_R_assms]: + "corres ((=) \ message_info_map) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_message_info t) (getMessageInfo t)" apply (unfold get_message_info_def getMessageInfo_def fun_app_def) apply (simp add: ARM_H.msgInfoRegister_def - ARM.msgInfoRegister_def ARM_A.msg_info_register_def) - apply (rule corres_split_eqr[OF asUser_getRegister_corres]) + ARM.msgInfoRegister_def ARM_A.msg_info_register_def) + apply (corres corres: asUser_getRegister_corres) apply (rule corres_trivial, simp add: message_info_from_data_eqv) - apply (wp | simp)+ - done - - -lemma get_mi_inv'[wp]: "\I\ getMessageInfo a \\x. I\" - by (simp add: getMessageInfo_def, wp) - -definition - "get_send_cap_relation rv rv' \ - (case rv of Some (c, cptr) \ (\c' cptr'. rv' = Some (c', cptr') \ - cte_map cptr = cptr' \ - cap_relation c c') - | None \ rv' = None)" - -lemma cap_relation_mask: - "\ cap_relation c c'; msk' = rights_mask_map msk \ \ - cap_relation (mask_cap msk c) (maskCapRights msk' c')" - by simp - -lemma lsfco_cte_at': - "\valid_objs' and valid_cap' cap\ - lookupSlotForCNodeOp f cap idx depth - \\rv. cte_at' rv\, -" - apply (simp add: lookupSlotForCNodeOp_def) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (wp) - apply (clarsimp simp: split_def unlessE_def - split del: if_split) - apply (wpsimp wp: hoare_drop_imps throwE_R) - done - -declare unifyFailure_wp [wp] - -(* FIXME: move *) -lemma unifyFailure_wp_E [wp]: - "\P\ f -, \\_. E\ \ \P\ unifyFailure f -, \\_. E\" - unfolding validE_E_def - by (erule unifyFailure_wp)+ - -(* FIXME: move *) -lemma unifyFailure_wp2 [wp]: - assumes x: "\P\ f \\_. Q\" - shows "\P\ unifyFailure f \\_. Q\" - by (wp x, simp) - -definition - ct_relation :: "captransfer \ cap_transfer \ bool" -where - "ct_relation ct ct' \ - ct_receive_root ct = to_bl (ctReceiveRoot ct') - \ ct_receive_index ct = to_bl (ctReceiveIndex ct') - \ ctReceiveDepth ct' = unat (ct_receive_depth ct)" - -(* MOVE *) -lemma valid_ipc_buffer_ptr_aligned_2: - "\valid_ipc_buffer_ptr' a s; is_aligned y 2 \ \ is_aligned (a + y) 2" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (erule (1) aligned_add_aligned) - apply (simp add: msg_align_bits) - done - -(* MOVE *) -lemma valid_ipc_buffer_ptr'D2: - "\valid_ipc_buffer_ptr' a s; y < max_ipc_words * 4; is_aligned y 2\ \ typ_at' UserDataT (a + y && ~~ mask pageBits) s" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (subgoal_tac "(a + y) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (erule order_less_le_trans) - apply (simp add: msg_align_bits max_ipc_words ) - apply simp - done - -lemma loadCapTransfer_corres: - "corres ct_relation \ (valid_ipc_buffer_ptr' buffer) (load_cap_transfer buffer) (loadCapTransfer buffer)" - apply (simp add: load_cap_transfer_def loadCapTransfer_def - captransfer_from_words_def - capTransferDataSize_def capTransferFromWords_def - msgExtraCapBits_def word_size add.commute add.left_commute - msg_max_length_def msg_max_extra_caps_def word_size_def - msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def wordSize_def wordBits_def - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (clarsimp simp: ct_relation_def) - apply (wp no_irq_loadWord)+ - apply simp - apply (simp add: conj_comms word_size_bits_def) - apply safe - apply (erule valid_ipc_buffer_ptr_aligned_2, simp add: is_aligned_def)+ - apply (erule valid_ipc_buffer_ptr'D2, simp add: max_ipc_words, simp add: is_aligned_def)+ - done - -lemma getReceiveSlots_corres: - "corres (\xs ys. ys = map cte_map xs) - (tcb_at receiver and valid_objs and pspace_aligned) - (tcb_at' receiver and valid_objs' and pspace_aligned' and pspace_distinct' and - case_option \ valid_ipc_buffer_ptr' recv_buf) - (get_receive_slots receiver recv_buf) - (getReceiveSlots receiver recv_buf)" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF loadCapTransfer_corres]) - apply (rule corres_empty_on_failure) - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (rule lookup_cap_corres) - apply (simp add: ct_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (simp add: ct_relation_def) - apply (erule lookupSlotForCNodeOp_corres [OF _ refl]) - apply simp - apply (simp add: split_def liftE_bindE unlessE_whenE) - apply (rule corres_split[OF get_cap_corres]) - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap, auto)[1] - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (wp lookup_cap_valid lookup_cap_valid' lsfco_cte_at | simp)+ - done - -lemma get_recv_slot_inv'[wp]: - "\ P \ getReceiveSlots receiver buf \\rv'. P \" - apply (case_tac buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def - split_def unlessE_def) - apply (wp | simp)+ - done - -lemma get_rs_cte_at'[wp]: - "\\\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. cte_wp_at' (\c. cteCap c = capability.NullCap) x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (rule getCTE_wp) - apply (simp add: cte_wp_at_ctes_of cong: conj_cong) - apply wp+ - apply simp - done - -lemma get_rs_real_cte_at'[wp]: - "\valid_objs'\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. real_cte_at' x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (wp hoare_drop_imps)[1] - apply simp - apply (wp lookup_cap_valid')+ - apply simp - done - -declare word_div_1 [simp] -declare word_minus_one_le [simp] -declare word32_minus_one_le [simp] - -lemma loadWordUser_corres': - "\ y < unat max_ipc_words; y' = of_nat y * 4 \ \ - corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + y'))" - apply simp - apply (erule loadWordUser_corres) - done - -declare loadWordUser_inv [wp] - -lemma getExtraCptrs_inv[wp]: - "\P\ getExtraCPtrs buf mi \\rv. P\" - apply (cases mi, cases buf, simp_all add: getExtraCPtrs_def) - apply (wp dmo_inv' mapM_wp' loadWord_inv) + apply wpsimp+ done -lemma badge_derived_mask [simp]: - "badge_derived' (maskCapRights R c) c' = badge_derived' c c'" - by (simp add: badge_derived'_def) +lemma max_ipc_size_le_2_msg_align_bits[Ipc_R_assms]: + "max_ipc_words * word_size \ 2 ^ msg_align_bits" + by (simp add: max_ipc_words word_size_def msg_align_bits) -declare derived'_not_Null [simp] - -lemma maskCapRights_vsCapRef[simp]: - "vsCapRef (maskCapRights msk cap) = vsCapRef cap" - unfolding vsCapRef_def - apply (cases cap, simp_all add: maskCapRights_def isCap_simps Let_def) +lemma maskCapRights_vs_cap_ref'[simp]: + "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" + unfolding vs_cap_ref'_def + apply (cases cap, simp_all add: global.maskCapRights_def isCap_simps Let_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; - simp add: maskCapRights_def ARM_H.maskCapRights_def isCap_simps Let_def) - done - -lemma corres_set_extra_badge: - "b' = b \ - corres dc (in_user_frame buffer) - (valid_ipc_buffer_ptr' buffer and - (\_. msg_max_length + 2 + n < unat max_ipc_words)) - (set_extra_badge buffer b n) (setExtraBadge buffer b' n)" - apply (rule corres_gen_asm2) - apply (drule storeWordUser_corres [where a=buffer and w=b]) - apply (simp add: set_extra_badge_def setExtraBadge_def buffer_cptr_index_def - bufferCPtrOffset_def Let_def) - apply (simp add: word_size word_size_def wordSize_def wordBits_def - bufferCPtrOffset_def buffer_cptr_index_def msgMaxLength_def - msg_max_length_def msgLengthBits_def store_word_offs_def - add.commute add.left_commute) - done - -crunch setExtraBadge - for typ_at': "\s. P (typ_at' T p s)" -lemmas setExtraBadge_typ_ats' [wp] = typ_at_lifts [OF setExtraBadge_typ_at'] -crunch setExtraBadge - for valid_pspace'[wp]: valid_pspace' -crunch setExtraBadge - for cte_wp_at'[wp]: "cte_wp_at' P p" -crunch setExtraBadge - for ipc_buffer'[wp]: "valid_ipc_buffer_ptr' buffer" - -crunch getExtraCPtr - for inv'[wp]: P (wp: dmo_inv' loadWord_inv) - -lemmas unifyFailure_discard2 - = corres_injection[OF id_injection unifyFailure_injection, simplified] - -lemma deriveCap_not_null: - "\\\ deriveCap slot cap \\rv. K (rv \ NullCap \ cap \ NullCap)\,-" - apply (simp add: deriveCap_def split del: if_split) - by (case_tac cap; wpsimp simp: isCap_simps) - -lemma deriveCap_derived_foo: - "\\s. \cap'. (cte_wp_at' (\cte. badge_derived' cap (cteCap cte) - \ capASID cap = capASID (cteCap cte) \ cap_asid_base' cap = cap_asid_base' (cteCap cte) - \ cap_vptr' cap = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s \ cap' \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot cap' \ cteCap) slot s) - \ (cte_wp_at' (untyped_derived_eq cap \ cteCap) slot s - \ cte_wp_at' (untyped_derived_eq cap' \ cteCap) slot s) - \ (s \' cap \ s \' cap') \ (cap' \ NullCap \ cap \ NullCap) \ Q cap' s\ - deriveCap slot cap \Q\,-" - using deriveCap_derived[where slot=slot and c'=cap] deriveCap_valid[where slot=slot and c=cap] - deriveCap_untyped_derived[where slot=slot and c'=cap] deriveCap_not_null[where slot=slot and cap=cap] - apply (clarsimp simp: validE_R_def validE_def valid_def split: sum.split) - apply (frule in_inv_by_hoareD[OF deriveCap_inv]) - apply (clarsimp simp: o_def) - apply (drule spec, erule mp) - apply safe - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) bspec, simp) - done - -lemma valid_mdb_untyped_incD': - "valid_mdb' s \ untyped_inc' (ctes_of s)" - by (simp add: valid_mdb'_def valid_mdb_ctes_def) - -lemma cteInsert_cte_wp_at: - "\\s. cte_wp_at' (\c. is_derived' (ctes_of s) src cap (cteCap c)) src s - \ valid_mdb' s \ valid_objs' s - \ (if p = dest then P cap - else cte_wp_at' (\c. P (maskedAsFull (cteCap c) cap)) p s)\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - apply (simp add: cteInsert_def) - apply (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp hoare_weak_lift_imp - | clarsimp simp: comp_def - | unfold setUntypedCapAsFull_def)+ - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=cte in exI) - apply clarsimp - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=ctea in exI) - apply clarsimp - apply (cases "p=dest") - apply (clarsimp simp: cte_wp_at'_def) - apply (cases "p=src") - apply clarsimp - apply (intro conjI impI) - apply ((clarsimp simp: cte_wp_at'_def maskedAsFull_def split: if_split_asm)+)[2] - apply clarsimp - apply (rule conjI) - apply (clarsimp simp: maskedAsFull_def cte_wp_at_ctes_of split:if_split_asm) - apply (erule disjE) prefer 2 apply simp - apply (clarsimp simp: is_derived'_def isCap_simps) - apply (drule valid_mdb_untyped_incD') - apply (case_tac cte, case_tac cteb, clarsimp) - apply (drule untyped_incD', (simp add: isCap_simps)+) - apply (frule(1) ctes_of_valid'[where p = p]) - apply (clarsimp simp:valid_cap'_def capAligned_def split:if_splits) - apply (drule_tac y ="of_nat fb" in word_plus_mono_right[OF _ is_aligned_no_overflow',rotated]) - apply simp+ - apply (rule word_of_nat_less) - apply simp - apply (simp add:p_assoc_help mask_def) - apply (simp add: max_free_index_def) - apply (clarsimp simp: maskedAsFull_def is_derived'_def badge_derived'_def - isCap_simps capMasterCap_def cte_wp_at_ctes_of - split: if_split_asm capability.splits) - done - -lemma cteInsert_weak_cte_wp_at3: - assumes imp:"\c. P c \ \ isUntypedCap c" - shows " \\s. if p = dest then P cap - else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - by (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp' hoare_weak_lift_imp - | clarsimp simp: comp_def cteInsert_def - | unfold setUntypedCapAsFull_def - | auto simp: cte_wp_at'_def dest!: imp)+ - -lemma maskedAsFull_null_cap[simp]: - "(maskedAsFull x y = capability.NullCap) = (x = capability.NullCap)" - "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" - by (case_tac x, auto simp:maskedAsFull_def isCap_simps) - -lemma maskCapRights_eq_null: - "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = - (xa = capability.NullCap)" - apply (cases xa; simp add: maskCapRights_def isCap_simps) + simp add: ARM_H.maskCapRights_def isCap_simps Let_def) + done + +lemma is_derived'_Untyped[Ipc_R_assms]: + "\isUntypedCap cap'\ + \ is_derived' m src cap' cap + = (isUntypedCap cap \ badge_derived' cap' cap \ descendants_of' src m = {})" + by (clarsimp simp add: ARM.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma is_derived'_Reply[Ipc_R_assms]: + "\isReplyCap cap'\ + \ is_derived' m src cap' cap + = (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ capReplyMaster cap \ \ capReplyMaster cap')" + by (clarsimp simp add: ARM.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma maskCapRights_eq_null[Ipc_R_assms, simp]: + "(RetypeDecls_H.maskCapRights r cap = capability.NullCap) = (cap = capability.NullCap)" + apply (cases cap; simp add: global.maskCapRights_def isCap_simps) apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (simp_all add: ARM_H.maskCapRights_def isCap_simps) - done - -lemma cte_refs'_maskedAsFull[simp]: - "cte_refs' (maskedAsFull a b) = cte_refs' a" - apply (rule ext)+ - apply (case_tac a) - apply (clarsimp simp:maskedAsFull_def isCap_simps)+ - done - -lemma set_extra_badge_valid_arch_state[wp]: - "set_extra_badge buffer badge n \ valid_arch_state \" - unfolding set_extra_badge_def - by wp - -lemma transferCapsToSlots_corres: - "\ list_all2 (\(cap, slot) (cap', slot'). cap_relation cap cap' - \ slot' = cte_map slot) caps caps'; - mi' = message_info_map mi \ \ - corres ((=) \ message_info_map) - (\s. valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_mdb s - \ valid_list s \ valid_arch_state s - \ (case ep of Some x \ ep_at x s | _ \ True) - \ (\x \ set slots. cte_wp_at (\cap. cap = cap.NullCap) x s \ - real_cte_at x s) - \ (\(cap, slot) \ set caps. valid_cap cap s \ - cte_wp_at (\cp'. (cap \ cap.NullCap \ cp'\cap \ cp' = masked_as_full cap cap )) slot s ) - \ distinct slots - \ in_user_frame buffer s) - (\s. valid_pspace' s - \ (case ep of Some x \ ep_at' x s | _ \ True) - \ (\x \ set (map cte_map slots). - cte_wp_at' (\cte. cteCap cte = NullCap) x s - \ real_cte_at' x s) - \ distinct (map cte_map slots) - \ valid_ipc_buffer_ptr' buffer s - \ (\(cap, slot) \ set caps'. valid_cap' cap s \ - cte_wp_at' (\cte. cap \ NullCap \ cteCap cte \ cap \ cteCap cte = maskedAsFull cap cap) slot s) - \ 2 + msg_max_length + n + length caps' < unat max_ipc_words) - (transfer_caps_loop ep buffer n caps slots mi) - (transferCapsToSlots ep buffer n caps' - (map cte_map slots) mi')" - (is "\ list_all2 ?P caps caps'; ?v \ \ ?corres") -proof (induct caps caps' arbitrary: slots n mi mi' rule: list_all2_induct) - case Nil - show ?case using Nil.prems by (case_tac mi, simp) -next - case (Cons x xs y ys slots n mi mi') - note if_weak_cong[cong] if_cong [cong del] - assume P: "?P x y" - show ?case using Cons.prems P - apply (clarsimp split del: if_split) - apply (simp add: Let_def split_def word_size liftE_bindE - word_bits_conv[symmetric] split del: if_split) - apply (rule corres_const_on_failure) - apply (simp add: dc_def[symmetric] split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_if3) - apply (case_tac "fst x", auto simp add: isCap_simps)[1] - apply (rule corres_split[OF corres_set_extra_badge]) - apply (clarsimp simp: is_cap_simps) - apply (drule conjunct1) - apply simp - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (case_tac mi, simp) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (subgoal_tac "obj_ref_of (fst x) = capEPPtr (fst y)") - prefer 2 - apply (clarsimp simp: is_cap_simps) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (rule_tac P="slots = []" and Q="slots \ []" in corres_disj_division) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (case_tac mi, simp) - apply (simp add: list_case_If2 split del: if_split) - apply (rule corres_splitEE) - apply (rule unifyFailure_discard2) - apply (case_tac mi, clarsimp) - apply (rule deriveCap_corres) - apply (simp add: remove_rights_def) - apply clarsimp - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap', auto)[1] - apply (rule corres_trivial, simp) - apply (case_tac mi, simp) - apply simp - apply (simp add: liftE_bindE) - apply (rule corres_split_nor) - apply (rule cteInsert_corres, simp_all add: hd_map)[1] - apply (simp add: tl_map) - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_vcg_const_Ball_lift cap_insert_derived_valid_arch_state - cap_insert_weak_cte_wp_at) - apply (wp hoare_vcg_const_Ball_lift | simp add:split_def del: imp_disj1)+ - apply (wp cap_insert_cte_wp_at) - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - cteInsert_valid_pspace - | simp add: split_def)+ - apply (wp cteInsert_weak_cte_wp_at hoare_valid_ipc_buffer_ptr_typ_at')+ - apply (wpsimp wp: hoare_vcg_const_Ball_lift cteInsert_cte_wp_at valid_case_option_post_wp - simp: split_def) - apply (unfold whenE_def) - apply wp+ - apply (clarsimp simp: conj_comms ball_conj_distrib split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ cap.NullCap \ - cte_wp_at (is_derived (cdt s) (a, b) cap') (a, b) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule derive_cap_is_derived) - apply (wp derive_cap_is_derived_foo)+ - apply (simp split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ capability.NullCap \ - cte_wp_at' (\c. is_derived' (ctes_of s) (cte_map (a, b)) cap' (cteCap c)) (cte_map (a, b)) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule hoare_strengthen_postE_R[OF deriveCap_derived]) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (wp deriveCap_derived_foo) - apply (clarsimp simp: cte_wp_at_caps_of_state remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI, (clarsimp split del: if_split)+) - apply (clarsimp simp:conj_comms split del:if_split) - apply (intro conjI allI) - apply (clarsimp split:if_splits) - apply (case_tac "cap = fst x",simp+) - apply (clarsimp simp:masked_as_full_def is_cap_simps cap_master_cap_simps) - apply (clarsimp split del: if_split) - apply (intro conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (drule hd_in_set) - apply (drule(1) bspec) - apply (clarsimp split:if_split_asm) - apply (fastforce simp:neq_Nil_conv) - apply (intro ballI conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (intro impI) - apply (drule(1) bspec[OF _ subsetD[rotated]]) - apply (clarsimp simp:neq_Nil_conv) - apply (clarsimp split:if_splits) - apply clarsimp - apply (intro conjI) - apply (drule(1) bspec,clarsimp)+ - subgoal for \ aa _ _ capa - by (case_tac "capa = aa"; clarsimp split:if_splits simp:masked_as_full_def is_cap_simps) - apply (case_tac "isEndpointCap (fst y) \ capEPPtr (fst y) = the ep \ (\y. ep = Some y)") - apply (clarsimp simp:conj_comms split del:if_split) - apply (subst if_not_P) - apply clarsimp - apply (clarsimp simp:valid_pspace'_def cte_wp_at_ctes_of split del:if_split) - apply (intro conjI) - apply (case_tac "cteCap cte = fst y",clarsimp simp: badge_derived'_def) - apply (clarsimp simp: maskCapRights_eq_null maskedAsFull_def badge_derived'_def isCap_simps - split: if_split_asm) - apply (clarsimp split del: if_split) - apply (case_tac "fst y = capability.NullCap") - apply (clarsimp simp: neq_Nil_conv split del: if_split)+ - apply (intro allI impI conjI) - apply (clarsimp split:if_splits) - apply (clarsimp simp:image_def)+ - apply (thin_tac "\x\set ys. Q x" for Q) - apply (drule(1) bspec)+ - apply clarsimp+ - apply (drule(1) bspec) - apply (rule conjI) - apply clarsimp+ - apply (case_tac "cteCap cteb = ab") - by (clarsimp simp: isCap_simps maskedAsFull_def split:if_splits)+ -qed - -declare constOnFailure_wp [wp] - -lemma transferCapsToSlots_pres1[crunch_rules]: - assumes x: "\cap src dest. \P\ cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\P\ transferCapsToSlots ep buffer n caps slots mi \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong - split del: if_split) - apply (rule hoare_pre) - apply (wp x eb | assumption | simp split del: if_split | wpc - | wp (once) hoare_drop_imps)+ - done - -lemma cteInsert_cte_cap_to': - "\ex_cte_cap_to' p and cte_wp_at' (\cte. cteCap cte = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_cte_cap_to' p\" - apply (simp add: ex_cte_cap_to'_def) - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (rule_tac x = "cref" in exI) - apply (rule conjI) - apply clarsimp+ - done - -declare maskCapRights_eq_null[simp] - -crunch setExtraBadge - for ex_cte_cap_wp_to'[wp]: "ex_cte_cap_wp_to' P p" - (rule: ex_cte_cap_to'_pres) - -crunch setExtraBadge - for valid_objs'[wp]: valid_objs' -crunch setExtraBadge - for aligned'[wp]: pspace_aligned' -crunch setExtraBadge - for distinct'[wp]: pspace_distinct' - -lemma cteInsert_assume_Null: - "\P\ cteInsert cap src dest \Q\ \ - \\s. cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ P s\ - cteInsert cap src dest - \Q\" - apply (rule hoare_name_pre_state) - apply (erule impCE) - apply (simp add: cteInsert_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ getCTE_sp])+ - apply (rule hoare_name_pre_state) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (erule hoare_weaken_pre) - apply simp - done - -crunch setExtraBadge - for mdb'[wp]: valid_mdb' - -lemma cteInsert_weak_cte_wp_at2: - assumes weak:"\c cap. P (maskedAsFull c cap) = P c" - shows - "\\s. if p = dest then P cap else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - supply if_cong[cong] - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of weak) - apply auto - done - -lemma transferCapsToSlots_presM: - assumes x: "\cap src dest. \\s. P s \ (emx \ cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ ex_cte_cap_to' dest s) - \ (vo \ valid_objs' s \ valid_cap' cap s \ real_cte_at' dest s) - \ (drv \ cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s - \ cte_wp_at' (untyped_derived_eq cap o cteCap) src s - \ valid_mdb' s) - \ (pad \ pspace_aligned' s \ pspace_distinct' s)\ - cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\\s. P s - \ (emx \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) \ distinct slots) - \ (vo \ valid_objs' s \ (\x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set caps. s \' fst x ) \ distinct slots) - \ (pad \ pspace_aligned' s \ pspace_distinct' s) - \ (drv \ vo \ pspace_aligned' s \ pspace_distinct' s \ valid_mdb' s - \ length slots \ 1 - \ (\x \ set caps. s \' fst x \ (slots \ [] - \ cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s)))\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply (simp, wp, simp) - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong split del: if_split) - apply (rule hoare_pre) - apply (wp eb hoare_vcg_const_Ball_lift hoare_vcg_const_imp_lift - | assumption | wpc)+ - apply (rule cteInsert_assume_Null) - apply (wp x hoare_vcg_const_Ball_lift cteInsert_cte_cap_to' hoare_weak_lift_imp) - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift hoare_weak_lift_imp)+ - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift cteInsert_cte_wp_at hoare_weak_lift_imp - deriveCap_derived_foo)+ - apply (thin_tac "\slots. PROP P slots" for P) - apply (clarsimp simp: cte_wp_at_ctes_of remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI) - apply (clarsimp simp:cte_wp_at_ctes_of untyped_derived_eq_def) - apply (intro conjI allI) - apply (clarsimp simp:Fun.comp_def cte_wp_at_ctes_of)+ - apply (clarsimp simp:valid_capAligned) - done - -lemmas transferCapsToSlots_pres2 - = transferCapsToSlots_presM[where vo=False and emx=True - and drv=False and pad=False, simplified] - -lemma transferCapsToSlots_aligned'[wp]: - "\pspace_aligned'\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. pspace_aligned'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_distinct'[wp]: - "\pspace_distinct'\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. pspace_distinct'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_typ_at'[wp]: - "\\s. P (typ_at' T p s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (typ_at' T p s)\" - by (wp transferCapsToSlots_pres1 setExtraBadge_typ_at') - -lemma transferCapsToSlots_valid_objs[wp]: - "\valid_objs' and valid_mdb' and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and (\s. \x \ set caps. s \' fst x) and K(distinct slots)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_objs'\" - apply (rule hoare_pre) - apply (rule transferCapsToSlots_presM[where vo=True and emx=False and drv=False and pad=False]) - apply (wp | simp)+ - done - -abbreviation(input) - "transferCaps_srcs caps s \ \x\set caps. cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s" - -lemma transferCapsToSlots_mdb[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_mdb'\" - apply (wpsimp wp: transferCapsToSlots_presM[where drv=True and vo=True and emx=True and pad=True]) - apply (frule valid_capAligned) - apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def badge_derived'_def) - apply wp - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarify) - apply (case_tac cte) - apply (clarsimp dest!:ctes_of_valid_cap' split:if_splits) - apply (fastforce simp:valid_cap'_def) - done - -crunch setExtraBadge - for no_0'[wp]: no_0_obj' - -lemma transferCapsToSlots_no_0_obj' [wp]: - "\no_0_obj'\ transferCapsToSlots ep buffer n caps slots mi \\rv. no_0_obj'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_vp[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_pspace'\" - apply (rule hoare_pre) - apply (simp add: valid_pspace'_def | wp)+ - apply (fastforce simp: cte_wp_at_ctes_of dest: ctes_of_valid') - done - -crunch setExtraBadge, doIPCTransfer - for sch_act [wp]: "\s. P (ksSchedulerAction s)" - (wp: crunch_wps mapME_wp' simp: zipWithM_x_mapM) -crunch setExtraBadge - for pred_tcb_at' [wp]: "\s. pred_tcb_at' proj P p s" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and obj_at' [wp]: "\s. P' (obj_at' P p s)" - and queues [wp]: "\s. P (ksReadyQueues s)" - and queuesL1 [wp]: "\s. P (ksReadyQueuesL1Bitmap s)" - and queuesL2 [wp]: "\s. P (ksReadyQueuesL2Bitmap s)" - -lemma tcts_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) - -crunch setExtraBadge - for state_refs_of'[wp]: "\s. P (state_refs_of' s)" - -lemma tcts_state_refs_of'[wp]: - "\\s. P (state_refs_of' s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (state_refs_of' s)\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for if_live'[wp]: if_live_then_nonz_cap' - -lemma tcts_iflive[wp]: - "\\s. if_live_then_nonz_cap' s \ distinct slots \ - (\x\set slots. - ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. if_live_then_nonz_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch setExtraBadge - for if_unsafe'[wp]: if_unsafe_then_cap' - -lemma tcts_ifunsafe[wp]: - "\\s. if_unsafe_then_cap' s \ distinct slots \ - (\x\set slots. cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s \ - ex_cte_cap_to' x s)\ transferCapsToSlots ep buffer n caps slots mi - \\rv. if_unsafe_then_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch ensureNoChildren - for it[wp]: "\s. P (ksIdleThread s)" - -crunch deriveCap - for idle'[wp]: "valid_idle'" - -crunch setExtraBadge - for valid_idle'[wp]: valid_idle' - -lemma tcts_idle'[wp]: - "\\s. valid_idle' s\ transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_idle'\" - apply (rule hoare_pre) - apply (wp transferCapsToSlots_pres1) - apply simp - done - -lemma tcts_ct[wp]: - "\cur_tcb'\ transferCapsToSlots ep buffer n caps slots mi \\rv. cur_tcb'\" - by (wp transferCapsToSlots_pres1 cur_tcb_lift) - -crunch setExtraBadge - for valid_arch_state'[wp]: valid_arch_state' - -lemma transferCapsToSlots_valid_arch [wp]: - "\valid_arch_state'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_arch_state'\" - by (rule transferCapsToSlots_pres1; wp) - -crunch setExtraBadge - for valid_global_refs'[wp]: valid_global_refs' - -lemma transferCapsToSlots_valid_globals [wp]: - "\valid_global_refs' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' and K (distinct slots) - and K (length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_global_refs'\" - apply (wp transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=True] | clarsimp)+ - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) + apply (case_tac arch_capability; simp add: ARM_H.maskCapRights_def isCap_simps) done -crunch setExtraBadge - for irq_node'[wp]: "\s. P (irq_node' s)" - -lemma transferCapsToSlots_irq_node'[wp]: - "\\s. P (irq_node' s)\ transferCapsToSlots ep buffer n caps slots mi \\rv s. P (irq_node' s)\" - by (wp transferCapsToSlots_pres1) +lemma capASID_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ capASID cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemma valid_irq_handlers_ctes_ofD: - "\ ctes_of s p = Some cte; cteCap cte = IRQHandlerCap irq; valid_irq_handlers' s \ - \ irq_issued' irq s" - by (auto simp: valid_irq_handlers'_def cteCaps_of_def ran_def) +lemma cap_asid_base'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_asid_base' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -crunch setExtraBadge - for valid_irq_handlers'[wp]: valid_irq_handlers' +lemma cap_vptr'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_vptr' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemma transferCapsToSlots_irq_handlers[wp]: - "\valid_irq_handlers' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' - and K(distinct slots \ length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_irq_handlers'\" - apply (wpsimp wp: transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=False]) - apply (clarsimp simp: is_derived'_def cte_wp_at_ctes_of badge_derived'_def) - apply (erule(2) valid_irq_handlers_ctes_ofD) - apply wp - apply (clarsimp simp:cte_wp_at_ctes_of | intro ballI conjI)+ - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done +lemmas transferCapsToSlots_pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="transferCapsToSlots _ _ _ _ _ _"] -crunch setExtraBadge - for irq_state'[wp]: "\s. P (ksInterruptState s)" - -lemma setExtraBadge_irq_states'[wp]: - "\valid_irq_states'\ setExtraBadge buffer b n \\_. valid_irq_states'\" - apply (wp valid_irq_states_lift') - apply (simp add: setExtraBadge_def storeWordUser_def) - apply (wpsimp wp: no_irq dmo_lift' no_irq_storeWord) - apply assumption - done +crunch makeArchFaultMessage + for sch_act[Ipc_R_assms, wp]: "\s. P (ksSchedulerAction s)" -lemma transferCapsToSlots_irq_states' [wp]: - "\valid_irq_states'\ transferCapsToSlots ep buffer n caps slots mi \\_. valid_irq_states'\" - by (wp transferCapsToSlots_pres1) +lemma is_derived'_IRQHandlerCap[Ipc_R_assms]: + "\isIRQHandlerCap cap'\ \ is_derived' (ctes_of (s::kernel_state)) src cap' cap = + (isIRQHandlerCap cap \ badge_derived' cap' cap)" + by (clarsimp simp add: ARM.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) -crunch setExtraBadge - for valid_pde_mappings'[wp]: valid_pde_mappings' - -lemma transferCapsToSlots_pde_mappings'[wp]: - "\valid_pde_mappings'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_pde_mappings'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_irqs_masked'[wp]: - "\irqs_masked'\ transferCapsToSlots ep buffer n caps slots mi \\rv. irqs_masked'\" - by (wp transferCapsToSlots_pres1 irqs_masked_lift) - -lemma storeWordUser_vms'[wp]: - "\valid_machine_state'\ storeWordUser a w \\_. valid_machine_state'\" +lemma storeWordUser_vms'[Ipc_R_assms, wp]: + "storeWordUser a w \valid_machine_state'\" proof - have aligned_offset_ignore: - "\(l::word32) (p::word32) sz. l<4 \ p && mask 2 = 0 \ + "\(l::machine_word) (p::machine_word) sz. l<8 \ p && mask 3 = 0 \ p+l && ~~ mask pageBits = p && ~~ mask pageBits" proof - fix l p sz - assume al: "(p::word32) && mask 2 = 0" - assume "(l::word32) < 4" hence less: "l<2^2" by simp - have le: "2 \ pageBits" by (simp add: pageBits_def) + assume al: "(p::machine_word) && mask 3 = 0" + assume "(l::machine_word) < 8" hence less: "l<2^3" by simp + have le: "3 \ pageBits" by (simp add: pageBits_def) show "?thesis l p sz" by (rule is_aligned_add_helper[simplified is_aligned_mask, THEN conjunct2, THEN mask_out_first_mask_some, - where n=2, OF al less le]) + where n=3, OF al less le]) qed show ?thesis @@ -934,706 +114,94 @@ proof - apply (erule disjE, simp) apply (simp add: pointerInUserData_def word_size) apply (subgoal_tac "a && ~~ mask pageBits = p && ~~ mask pageBits", simp) - apply (simp only: is_aligned_mask[of _ 2]) + apply (simp only: is_aligned_mask[of _ 3]) apply (elim disjE, simp_all) apply (rule aligned_offset_ignore[symmetric], simp+)+ done qed -lemma setExtraBadge_vms'[wp]: - "\valid_machine_state'\ setExtraBadge buffer b n \\_. valid_machine_state'\" -by (simp add: setExtraBadge_def) wp - -lemma transferCapsToSlots_vms[wp]: - "\\s. valid_machine_state' s\ - transferCapsToSlots ep buffer n caps slots mi - \\_ s. valid_machine_state' s\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge, transferCapsToSlots - for pspace_domain_valid[wp]: "pspace_domain_valid" - -crunch setExtraBadge - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma tcts_ct_not_inQ[wp]: - "\ct_not_inQ\ - transferCapsToSlots ep buffer n caps slots mi - \\_. ct_not_inQ\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" -crunch setExtraBadge - for ctes_of[wp]: "\s. P (ctes_of s)" +lemma isArchObjectCap_maskCapRights[Ipc_R_assms]: + "isArchObjectCap (Arch.maskCapRights R acap)" + by (cases acap; simp add: ARM_H.maskCapRights_def isCap_simps) -lemma tcts_zero_ranges[wp]: - "\\s. untyped_ranges_zero' s \ valid_pspace' s \ distinct slots - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. untyped_ranges_zero'\" - apply (wpsimp wp: transferCapsToSlots_presM[where emx=True and vo=True - and drv=True and pad=True]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: cteCaps_of_def) - apply (rule hoare_pre, wp untyped_ranges_zero_lift) - apply (simp add: o_def) - apply (clarsimp simp: valid_pspace'_def ball_conj_distrib[symmetric]) - apply (drule(1) bspec) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (case_tac cte, clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply auto[1] - done - -crunch transferCapsToSlots, setExtraBadge - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - -crunch transferCapsToSlots - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift) - -lemma transferCapsToSlots_invs[wp]: - "\\s. invs' s \ distinct slots - \ (\x \ set slots. cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set slots. ex_cte_cap_to' x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (wp valid_irq_node_lift valid_dom_schedule'_lift) - apply fastforce - done - -lemma grs_distinct'[wp]: - "\\\ getReceiveSlots t buf \\rv s. distinct rv\" - apply (cases buf, simp_all add: getReceiveSlots_def - split_def unlessE_def) - apply (wp, simp) - apply (wp | simp only: distinct.simps list.simps empty_iff)+ - apply simp - done - -lemma transferCaps_corres: - "\ info' = message_info_map info; - list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x)) - caps caps' \ - \ - corres ((=) \ message_info_map) - (tcb_at receiver and valid_objs and - pspace_aligned and pspace_distinct and valid_mdb - and valid_list and valid_arch_state - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame recv_buf - and (\s. valid_message_info info) - and transfer_caps_srcs caps) - (tcb_at' receiver and valid_objs' and - pspace_aligned' and pspace_distinct' and no_0_obj' and valid_mdb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' recv_buf - and transferCaps_srcs caps' - and (\s. length caps' \ msgMaxExtraCaps)) - (transfer_caps info caps ep receiver recv_buf) - (transferCaps info' caps' ep receiver recv_buf)" - apply (simp add: transfer_caps_def transferCaps_def - getThreadCSpaceRoot) - apply (rule corres_assume_pre) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getReceiveSlots_corres]) - apply (rule_tac x=recv_buf in option_corres) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (case_tac info, simp) - apply simp - apply (rule corres_rel_imp, rule transferCapsToSlots_corres, - simp_all add: split_def)[1] - apply (case_tac info, simp) - apply (wp hoare_vcg_all_lift get_rs_cte_at hoare_weak_lift_imp - | simp only: ball_conj_distrib)+ - apply (simp add: cte_map_def tcb_cnode_index_def split_def) - apply (clarsimp simp: valid_pspace'_def valid_ipc_buffer_ptr'_def2 - split_def - cong: option.case_cong) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_caps_of_state) - apply (frule(1) Invariants_AI.caps_of_state_valid) - apply (fastforce simp:valid_cap_def) - apply (cases info) - apply (clarsimp simp: msg_max_extra_caps_def valid_message_info_def - max_ipc_words msg_max_length_def - msgMaxExtraCaps_def msgExtraCapBits_def - shiftL_nat valid_pspace'_def) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (case_tac cte,clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done - -crunch transferCaps - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas transferCaps_typ_ats[wp] = typ_at_lifts [OF transferCaps_typ_at'] - -lemma isIRQControlCap_mask [simp]: - "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" - apply (case_tac c) - apply (clarsimp simp: isCap_simps maskCapRights_def Let_def)+ - apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (clarsimp simp: isCap_simps ARM_H.maskCapRights_def - maskCapRights_def Let_def)+ - done - -lemma isPageCap_maskCapRights[simp]: -" isArchCap isPageCap (RetypeDecls_H.maskCapRights R c) = isArchCap isPageCap c" - apply (case_tac c; simp add: isCap_simps isArchCap_def maskCapRights_def) +lemma isFrameCap_maskCapRights[simp]: + "isArchCap isFrameCap (global.maskCapRights R c) = isArchCap isFrameCap c" + apply (case_tac c; simp add: gen_isCap_simps isArchCap_def global.maskCapRights_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: isCap_simps ARM_H.maskCapRights_def) done -lemma capReplyMaster_mask[simp]: - "isReplyCap c \ capReplyMaster (maskCapRights R c) = capReplyMaster c" - by (clarsimp simp: isCap_simps maskCapRights_def) - -lemma is_derived_mask' [simp]: - "is_derived' m p (maskCapRights R c) = is_derived' m p c" - apply (rule ext) - apply (simp add: is_derived'_def badge_derived'_def) - done - -lemma updateCapData_ordering: - "\ (x, capBadge cap) \ capBadge_ordering P; updateCapData p d cap \ NullCap \ - \ (x, capBadge (updateCapData p d cap)) \ capBadge_ordering P" - apply (cases cap, simp_all add: updateCapData_def isCap_simps Let_def - capBadge_def ARM_H.updateCapData_def - split: if_split_asm) - apply fastforce+ - done - -lemma lookup_cap_to'[wp]: - "\\\ lookupCap t cref \\rv s. \r\cte_refs' rv (irq_node' s). ex_cte_cap_to' r s\,-" - by (simp add: lookupCap_def lookupCapAndSlot_def | wp)+ - -lemma grs_cap_to'[wp]: - "\\\ getReceiveSlots t buf \\rv s. \x \ set rv. ex_cte_cap_to' x s\" - apply (cases buf; simp add: getReceiveSlots_def split_def unlessE_def) - apply (wp, simp) - apply (wp | simp | rule hoare_drop_imps)+ - done - -lemma grs_length'[wp]: - "\\s. 1 \ n\ getReceiveSlots receiver recv_buf \\rv s. length rv \ n\" - apply (simp add: getReceiveSlots_def split_def unlessE_def) - apply (rule hoare_pre) - apply (wp | wpc | simp)+ - done - -lemma transferCaps_invs' [wp]: - "\invs' and transferCaps_srcs caps\ - transferCaps mi caps ep receiver recv_buf - \\rv. invs'\" - apply (simp add: transferCaps_def Let_def split_def) - apply (wp get_rs_cte_at' hoare_vcg_const_Ball_lift - | wpcw | clarsimp)+ - done - -lemma get_mrs_inv'[wp]: - "\P\ getMRs t buf info \\rv. P\" - by (simp add: getMRs_def load_word_offs_def getRegister_def - | wp dmo_inv' loadWord_inv mapM_wp' - asUser_inv det_mapM[where S=UNIV] | wpc)+ - - -lemma copyMRs_typ_at': - "\\s. P (typ_at' T p s)\ copyMRs s sb r rb n \\rv s. P (typ_at' T p s)\" - by (simp add: copyMRs_def | wp mapM_wp [where S=UNIV, simplified] | wpc)+ - -lemmas copyMRs_typ_at_lifts[wp] = typ_at_lifts [OF copyMRs_typ_at'] - -lemma copy_mrs_invs'[wp]: - "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" - including classic_wp_pre - apply (simp add: copyMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord| - simp add: split_def) - apply (case_tac sb, simp_all)[1] - apply wp+ - apply (case_tac rb, simp_all)[1] - apply (wp mapM_wp dmo_invs' no_irq_mapM no_irq_storeWord no_irq_loadWord) - apply blast - apply (rule hoare_strengthen_post) - apply (rule mapM_wp) - apply (wp | simp | blast)+ - done - -crunch transferCaps - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: zipWithM_x_mapM) -crunch transferCaps - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: zipWithM_x_mapM) - -crunch setMRs - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch setMRs - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps wp: crunch_wps) -crunch copyMRs - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps wp: crunch_wps) -crunch setMessageInfo - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch setMessageInfo - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) - -crunch storeWordUser - for valid_objs'[wp]: valid_objs' -crunch storeWordUser - for valid_pspace'[wp]: valid_pspace' - -lemma set_mrs_valid_objs' [wp]: - "\valid_objs'\ setMRs t a msgs \\rv. valid_objs'\" - apply (simp add: setMRs_def zipWithM_x_mapM split_def) - apply (wp asUser_valid_objs crunch_wps) - done - -crunch copyMRs - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps simp: crunch_simps) - -lemma setMRs_invs_bits[wp]: - "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\\s. P (state_refs_of' s)\ - setMRs t buf mrs - \\rv s. P (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ setMRs t buf mrs \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ setMRs t buf mrs \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ setMRs t buf mrs \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ setMRs t buf mrs \\rv. if_unsafe_then_cap'\" - by (simp add: setMRs_def zipWithM_x_mapM split_def storeWordUser_def | wp crunch_wps)+ - -crunch setMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma copyMRs_invs_bits[wp]: - "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. P (state_refs_of' s)\ - copyMRs s sb r rb n - \\rv s. P (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ copyMRs s sb r rb n \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ copyMRs s sb r rb n \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ copyMRs s sb r rb n \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ copyMRs s sb r rb n \\rv. if_unsafe_then_cap'\" - by (simp add: copyMRs_def storeWordUser_def | wp mapM_wp' | wpc)+ - -crunch copyMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma mi_map_length[simp]: "msgLength (message_info_map mi) = mi_length mi" - by (cases mi, simp) - -crunch copyMRs - for cte_wp_at'[wp]: "cte_wp_at' P p" - (wp: crunch_wps) - -lemma lookupExtraCaps_srcs[wp]: - "\\\ lookupExtraCaps thread buf info \transferCaps_srcs\,-" - apply (simp add: lookupExtraCaps_def lookupCapAndSlot_def - split_def lookupSlotForThread_def - getSlotCap_def) - apply (wp mapME_set[where R=\] getCTE_wp') - apply (rule_tac P=\ in hoare_trivE_R) - apply (simp add: cte_wp_at_ctes_of) - apply (wp | simp)+ - done - -crunch lookupExtraCaps - for inv[wp]: "P" - (wp: crunch_wps mapME_wp' simp: crunch_simps) +lemma arch_updateCapData_ordering[Ipc_R_assms]: + "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ + \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" + by (cases acap; simp add: ARM_H.updateCapData_def) + fastforce -lemma invs_mdb_strengthen': - "invs' s \ valid_mdb' s" by auto +lemma ArchUpdateCapData_noReply[Ipc_R_assms]: + "Arch.updateCapData p d acap \ capability.ReplyCap x y z" + by (cases acap; simp add: ARM_H.updateCapData_def) -lemma lookupExtraCaps_length: - "\\s. unat (msgExtraCaps mi) \ n\ lookupExtraCaps thread send_buf mi \\rv s. length rv \ n\,-" - apply (simp add: lookupExtraCaps_def getExtraCPtrs_def) - apply (rule hoare_pre) - apply (wp mapME_length | wpc)+ - apply (clarsimp simp: upto_enum_step_def Suc_unat_diff_1 word_le_sub1) - done +lemma ArchUpdateCapData_noIRQControl[Ipc_R_assms]: + "Arch.updateCapData p d acap \ IRQControlCap" + by (cases acap; simp add: ARM_H.updateCapData_def) -lemma getMessageInfo_msgExtraCaps[wp]: - "\\\ getMessageInfo t \\rv s. unat (msgExtraCaps rv) \ msgMaxExtraCaps\" - apply (simp add: getMessageInfo_def) - apply wp - apply (simp add: messageInfoFromWord_def Let_def msgMaxExtraCaps_def - shiftL_nat) - apply (subst nat_le_Suc_less_imp) - apply (rule unat_less_power) - apply (simp add: word_bits_def msgExtraCapBits_def) - apply (rule and_mask_less'[unfolded mask_2pm1]) - apply (simp add: msgExtraCapBits_def) - apply wpsimp+ - done +lemma updateCapData_vs_cap_ref'[simp]: + "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" + by (rule ccontr, + clarsimp simp: isCap_simps global.updateCapData_def Let_def + ARM_H.updateCapData_def + vs_cap_ref'_def + split del: if_split + split: if_split_asm arch_capability.splits) -lemma lookupCapAndSlot_corres: - "cptr = to_bl cptr' \ - corres (lfr \ (\a b. cap_relation (fst a) (fst b) \ snd b = cte_map (snd a))) - (valid_objs and pspace_aligned and tcb_at thread) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread) - (lookup_cap_and_slot thread cptr) (lookupCapAndSlot thread cptr')" - unfolding lookup_cap_and_slot_def lookupCapAndSlot_def - apply (simp add: liftE_bindE split_def) - apply (rule corres_guard_imp) - apply (rule_tac r'="\rv rv'. rv' = cte_map (fst rv)" - in corres_splitEE) - apply (rule corres_rel_imp, rule lookupSlotForThread_corres) - apply (simp add: split_def) - apply (rule corres_split[OF getSlotCap_corres]) - apply simp - apply (rule corres_returnOkTT, simp) - apply wp+ - apply (wp | simp add: liftE_bindE[symmetric])+ +lemma isFrameCap_updateCapData[simp]: + "isArchCap isFrameCap (updateCapData pr D c) = isArchCap isFrameCap c" + apply (case_tac c; simp add: global.updateCapData_def isCap_simps isArchCap_def) + apply (rename_tac arch_capability) + apply (case_tac arch_capability; simp add: ARM_H.updateCapData_def isCap_simps isArchCap_def) + apply (clarsimp split:capability.splits simp:Let_def) done -lemma lookupExtraCaps_corres: - "\ info' = message_info_map info; buffer = buffer'\ \ - corres (fr \ list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))) - (valid_objs and pspace_aligned and tcb_at thread and (\_. valid_message_info info)) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer') - (lookup_extra_caps thread buffer info) (lookupExtraCaps thread buffer' info')" - unfolding lookupExtraCaps_def lookup_extra_caps_def - apply (rule corres_gen_asm) - apply (cases "mi_extra_caps info = 0") - apply (cases info) - apply (simp add: Let_def returnOk_def getExtraCPtrs_def - liftE_bindE upto_enum_step_def mapM_def - sequence_def doMachineOp_return mapME_Nil - split: option.split) - apply (cases info) - apply (rename_tac w1 w2 w3 w4) - apply (simp add: Let_def liftE_bindE) - apply (cases buffer') - apply (simp add: getExtraCPtrs_def mapME_Nil) - apply (rule corres_returnOk) - apply simp - apply (simp add: msgLengthBits_def msgMaxLength_def word_size field_simps - getExtraCPtrs_def upto_enum_step_def upto_enum_word - word_size_def msg_max_length_def liftM_def - Suc_unat_diff_1 word_le_sub1 mapM_map_simp - upt_lhs_sub_map[where x=buffer_cptr_index] - wordSize_def wordBits_def - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_underlying_split) - - apply (rule_tac S = "\x y. x = y \ x < unat w2" - in corres_mapM_list_all2 - [where Q = "\_. valid_objs and pspace_aligned and tcb_at thread" and r = "(=)" - and Q' = "\_. valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer'" and r'="(=)" ]) - apply simp - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule loadWordUser_corres') - apply (clarsimp simp: buffer_cptr_index_def msg_max_length_def - max_ipc_words valid_message_info_def - msg_max_extra_caps_def word_le_nat_alt) - apply (simp add: buffer_cptr_index_def msg_max_length_def) - apply simp - apply simp - apply (simp add: load_word_offs_word_def) - apply (wp | simp)+ - apply (subst list_all2_same) - apply (clarsimp simp: max_ipc_words field_simps) - apply (simp add: mapME_def, fold mapME_def)[1] - apply (rule corres_mapME [where S = Id and r'="(\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))"]) - apply simp - apply simp - apply simp - apply (rule corres_cap_fault [OF lookupCapAndSlot_corres]) - apply simp - apply simp - apply (wp | simp)+ - apply (simp add: set_zip_same Int_lower1) - apply (wp mapM_wp [OF _ subset_refl] | simp)+ - done +lemma get_mrs_inv'[Ipc_R_assms, wp]: + "getMRs t buf info \P\" + by (wpsimp wp: dmo_inv' loadWord_inv mapM_wp' asUser_inv det_mapM[where S=UNIV] + simp: getMRs_def load_word_offs_def getRegister_def) -crunch copyMRs - for ctes_of[wp]: "\s. P (ctes_of s)" - (wp: threadSet_ctes_of crunch_wps) - -lemma copyMRs_valid_mdb[wp]: - "\valid_mdb'\ copyMRs t buf t' buf' n \\rv. valid_mdb'\" - by (simp add: valid_mdb'_def copyMRs_ctes_of) - -crunch copy_mrs - for valid_arch_state[wp]: valid_arch_state - (wp: crunch_wps) - -lemma doNormalTransfer_corres: - "corres dc - (tcb_at sender and tcb_at receiver and (pspace_aligned:: det_state \ bool) - and valid_objs and cur_tcb and valid_mdb and valid_list and valid_arch_state and pspace_distinct - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame send_buf - and case_option \ in_user_frame recv_buf) - (tcb_at' sender and tcb_at' receiver and valid_objs' - and pspace_aligned' and pspace_distinct' and cur_tcb' - and valid_mdb' and no_0_obj' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' send_buf - and case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_normal_transfer sender send_buf ep badge can_grant receiver recv_buf) - (doNormalTransfer sender send_buf ep badge can_grant receiver recv_buf)" - supply if_cong[cong] - apply (simp add: do_normal_transfer_def doNormalTransfer_def) - apply (rule corres_guard_imp) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule_tac F="valid_message_info mi" in corres_gen_asm) - apply (rule_tac r'="list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))" - in corres_split) - apply (rule corres_if[OF refl]) - apply (rule corres_split_catch) - apply (rule lookupExtraCaps_corres; simp) - apply (rule corres_trivial, simp) - apply wp+ - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_split_eqr[OF copyMRs_corres]) - apply (rule corres_split) - apply (rule transferCaps_corres; simp) - apply (rename_tac mi' mi'') - apply (rule_tac F="mi_label mi' = mi_label mi" - in corres_gen_asm) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply (case_tac mi', clarsimp) - apply (simp add: badge_register_def badgeRegister_def) - apply (fold dc_def) - apply (rule asUser_setRegister_corres) - apply wp - apply simp+ - apply ((wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_case_option_wp - hoare_valid_ipc_buffer_ptr_typ_at' copyMRs_typ_at' - hoare_vcg_const_Ball_lift lookupExtraCaps_length - | simp add: if_apply_def2)+) - apply (wp hoare_weak_lift_imp | strengthen valid_msg_length_strengthen)+ - apply clarsimp - apply auto - done - -lemma corres_liftE_lift: - "corres r1 P P' m m' \ - corres (f1 \ r1) P P' (liftE m) (withoutFailure m')" - by simp - -lemmas corres_ipc_thread_helper = - corres_split_eqrE[OF corres_liftE_lift [OF getCurThread_corres]] - -lemmas corres_ipc_info_helper = - corres_split_maprE [where f = message_info_map, OF _ - corres_liftE_lift [OF getMessageInfo_corres]] - -crunch doNormalTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas doNormal_lifts[wp] = typ_at_lifts [OF doNormalTransfer_typ_at'] - -lemma doNormal_invs'[wp]: - "\tcb_at' sender and tcb_at' receiver and invs'\ - doNormalTransfer sender send_buf ep badge - can_grant receiver recv_buf \\r. invs'\" - apply (simp add: doNormalTransfer_def) - apply (wp hoare_vcg_const_Ball_lift | simp)+ - done - -crunch doNormalTransfer - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps) -crunch doNormalTransfer - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps) - -lemma transferCaps_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' - and (\s. (\x\set caps. cte_wp_at' (\cte. fst x \ capability.NullCap \ cteCap cte = fst x) (snd x) s))\ - transferCaps tag caps ep receiver recv_buf - \\r. untyped_ranges_zero'\" - apply (simp add: transferCaps_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift hoare_vcg_const_imp_lift - | wpc - | simp add: ball_conj_distrib)+ - apply clarsimp - done +lemma badgeRegister_badge_register[Ipc_R_assms]: + "badgeRegister = badge_register" + by (simp add: badge_register_def badgeRegister_def) -crunch doNormalTransfer - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 ignore: constOnFailure) +lemmas copyMRs__pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="copyMRs _ _ _ _ _"] -lemmas asUser_urz = untyped_ranges_zero_lift[OF asUser_gsUntypedZeroRanges] - -crunch doNormalTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: asUser wp: crunch_wps asUser_urz hoare_vcg_const_Ball_lift) - -lemma msgFromLookupFailure_map[simp]: - "msgFromLookupFailure (lookup_failure_map lf) - = msg_from_lookup_failure lf" - by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) - -lemma asUser_getRestartPC_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t getRestartPC) (asUser t getRestartPC)" - apply (rule asUser_corres') - apply (rule corres_Id, simp, simp) - apply (rule no_fail_getRestartPC) - done - -lemma asUser_mapM_getRegister_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t (mapM getRegister regs)) - (asUser t (mapM getRegister regs))" - apply (rule asUser_corres') - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_mapM) - apply (simp add: getRegister_def) - done - -lemma makeArchFaultMessage_corres: +lemma makeArchFaultMessage_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_arch_fault_msg f t) - (makeArchFaultMessage (arch_fault_map f) t)" - apply (cases f, clarsimp simp: makeArchFaultMessage_def split: arch_fault.split) + (make_arch_fault_msg f t) + (makeArchFaultMessage (arch_fault_map f) t)" + apply (cases f; clarsimp simp: makeArchFaultMessage_def ucast_nat_def split: arch_fault.split) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_trivial, simp add: arch_fault_map_def) + apply (rule corres_trivial, simp) apply (wp+, auto) done -lemma makeFaultMessage_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_fault_msg ft t) - (makeFaultMessage (fault_map ft) t)" - apply (cases ft, simp_all add: makeFaultMessage_def split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_trivial, simp add: fromEnum_def enum_bool) - apply (wp | simp)+ - apply (simp add: ARM_H.syscallMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (simp add: ARM_H.exceptionMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (rule makeArchFaultMessage_corres) - done - -lemma makeFaultMessage_inv[wp]: - "\P\ makeFaultMessage ft t \\rv. P\" - apply (cases ft, simp_all add: makeFaultMessage_def) - apply (wp asUser_inv mapM_wp' det_mapM[where S=UNIV] - det_getRestartPC getRestartPC_inv - | clarsimp simp: getRegister_def makeArchFaultMessage_def - split: arch_fault.split)+ - done +lemma syscallMessage_def'[Ipc_R_assms]: + "FaultHandler_H.syscallMessage \ MachineExports.syscallMessage" + by (simp add: syscallMessage_def) -lemmas threadget_fault_corres = - threadGet_corres [where r = fault_rel_optionation - and f = tcb_fault and f' = tcbFault, - simplified tcb_relation_def, simplified] +lemma exceptionMessage_def'[Ipc_R_assms]: + "FaultHandler_H.exceptionMessage \ MachineExports.exceptionMessage" + by (simp add: exceptionMessage_def) -lemma doFaultTransfer_corres: - "corres dc - (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender - and tcb_at receiver and case_option \ in_user_frame recv_buf - and pspace_aligned and pspace_distinct) - (tcb_at' sender and tcb_at' receiver and - case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_fault_transfer badge sender receiver recv_buf) - (doFaultTransfer badge sender receiver recv_buf)" - apply (clarsimp simp: do_fault_transfer_def doFaultTransfer_def split_def - ARM_H.badgeRegister_def badge_register_def) - apply (rule_tac Q="\fault. K (\f. fault = Some f) and - tcb_at sender and tcb_at receiver and - case_option \ in_user_frame recv_buf and - pspace_aligned and pspace_distinct" - and Q'="\fault'. tcb_at' sender and tcb_at' receiver and - case_option \ valid_ipc_buffer_ptr' recv_buf" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply (clarsimp simp: obj_at_def is_tcb)+ - apply (rule corres_assume_pre) - apply (fold assert_opt_def | unfold haskell_fail_def)+ - apply (rule corres_assert_opt_assume) - apply (clarsimp split: option.splits - simp: fault_rel_optionation_def assert_opt_def - map_option_case) - defer - defer - apply (clarsimp simp: fault_rel_optionation_def) - apply (wp thread_get_wp) - apply (clarsimp simp: obj_at_def is_tcb) - apply wp - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - done +lemma makeArchFaultMessage_inv[Ipc_R_assms, wp]: + "makeArchFaultMessage ft t \P\" + unfolding makeArchFaultMessage_def + by (wpsimp wp: asUser_inv getRestartPC_inv split: arch_fault.split) -lemma doFaultTransfer_invs[wp]: - "\invs' and tcb_at' receiver\ - doFaultTransfer badge sender receiver recv_buf - \\rv. invs'\" - by (simp add: doFaultTransfer_def split_def | wp - | clarsimp split: option.split)+ - -lemma lookupIPCBuffer_valid_ipc_buffer [wp]: +lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" - unfolding lookupIPCBuffer_def ARM_H.lookupIPCBuffer_def + unfolding lookupIPCBuffer_def + supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def locateSlot_conv threadGet_def comp_def) apply (wp getCTE_wp getObject_tcb_wp | wpc)+ @@ -1643,2671 +211,107 @@ lemma lookupIPCBuffer_valid_ipc_buffer [wp]: apply (rule_tac x = ko in exI) apply (frule ko_at_cte_ipcbuffer[simplified cteSizeBits_def]) apply (clarsimp simp: cte_wp_at_ctes_of shiftl_t2n' simp del: imp_disjL) + apply (rename_tac ref rg sz d m) apply (clarsimp simp: valid_ipc_buffer_ptr'_def) apply (frule (1) ko_at_valid_objs') apply (clarsimp simp: projectKO_opts_defs split: kernel_object.split_asm) apply (clarsimp simp add: valid_obj'_def valid_tcb'_def isCap_simps cte_level_bits_def field_simps) apply (drule bspec [OF _ ranI [where a = "4 << cteSizeBits"]]) - apply simp - apply (clarsimp simp add: valid_cap'_def) + apply (simp add: cteSizeBits_def) + apply (clarsimp simp add: valid_cap'_def frame_at'_def) apply (rule conjI) apply (rule aligned_add_aligned) apply (clarsimp simp add: capAligned_def) apply assumption apply (erule is_aligned_andI1) - apply (case_tac xd, simp_all add: msg_align_bits)[1] + apply (rule order_trans[rotated]) + apply (rule pbfs_atleast_pageBits) + apply (simp add: bit_simps msg_align_bits) apply (clarsimp simp: capAligned_def) - apply (drule_tac x = - "(tcbIPCBuffer ko && mask (pageBitsForSize xd)) >> pageBits" in spec) - apply (subst(asm) mult.commute mult.left_commute, subst(asm) shiftl_t2n[symmetric]) - apply (simp add: shiftr_shiftl1) + apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize sz)) >> pageBits" in spec) + apply (simp add: shiftr_shiftl1 ) apply (subst (asm) mask_out_add_aligned) apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) apply (erule mp) apply (rule shiftr_less_t2n) apply (clarsimp simp: pbfs_atleast_pageBits) apply (rule and_mask_less') - apply (simp add: word_bits_conv) - done - -lemma doIPCTransfer_corres: - "corres dc - (tcb_at s and tcb_at r and valid_objs and pspace_aligned - and valid_list and valid_arch_state - and pspace_distinct and valid_mdb and cur_tcb - and (\s. case ep of Some x \ ep_at x s | _ \ True)) - (tcb_at' s and tcb_at' r and valid_pspace' and cur_tcb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True)) - (do_ipc_transfer s ep bg grt r) - (doIPCTransfer s ep bg grt r)" - apply (simp add: do_ipc_transfer_def doIPCTransfer_def) - apply (rule_tac Q="\receiveBuffer sa. tcb_at s sa \ valid_objs sa \ - pspace_aligned sa \ pspace_distinct sa \ tcb_at r sa \ - cur_tcb sa \ valid_mdb sa \ valid_list sa \ valid_arch_state sa \ - (case ep of None \ True | Some x \ ep_at x sa) \ - case_option (\_. True) in_user_frame receiveBuffer sa \ - obj_at (\ko. \tcb. ko = TCB tcb - \ \\ft. tcb_fault tcb = Some ft\) s sa" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule lookupIPCBuffer_corres') - apply auto[2] - apply (rule corres_underlying_split [OF _ _ thread_get_sp threadGet_inv]) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply simp - defer - apply (rule corres_guard_imp) - apply (subst case_option_If)+ - apply (rule corres_if3) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (simp add: dc_def[symmetric]) - apply (rule doNormalTransfer_corres) - apply (wp | simp add: valid_pspace'_def)+ - apply (simp add: dc_def[symmetric]) - apply (rule doFaultTransfer_corres) - apply (clarsimp simp: obj_at_def) - apply (erule ignore_if) - apply (wp|simp add: obj_at_def is_tcb valid_pspace'_def)+ + apply (simp add: word_bits_conv pbfs_less_wb'[unfolded word_bits_conv]) done +(* Used in CRefine *) +lemma lookupIPCBuffer_Some_0: + "\\\ lookupIPCBuffer w t \\rv s. rv \ Some 0\" + by (wpsimp simp: lookupIPCBuffer_def Let_def getThreadBufferSlot_def locateSlot_conv) -crunch doIPCTransfer - for ifunsafe[wp]: "if_unsafe_then_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -crunch doIPCTransfer - for iflive[wp]: "if_live_then_nonz_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -lemma valid_pspace_valid_objs'[elim!]: - "valid_pspace' s \ valid_objs' s" - by (simp add: valid_pspace'_def) -crunch doIPCTransfer - for vp[wp]: "valid_pspace'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) -crunch doIPCTransfer - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for state_refs_of[wp]: "\s. P (state_refs_of' s)" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for ct[wp]: "cur_tcb'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for idle'[wp]: "valid_idle'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) -lemmas dit'_typ_ats[wp] = typ_at_lifts [OF doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: crunch_wps simp: crunch_simps) - -lemmas dit_irq_node'[wp] - = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for valid_arch_state'[wp]: "valid_arch_state'" - (wp: crunch_wps simp: crunch_simps) - -(* Levity: added (20090126 19:32:26) *) -declare asUser_global_refs' [wp] - -lemma lec_valid_cap' [wp]: - "\valid_objs'\ lookupExtraCaps thread xa mi \\rv s. (\x\set rv. s \' fst x)\, -" - apply (rule hoare_pre, rule hoare_strengthen_postE_R) - apply (rule hoare_vcg_conj_liftE_R[where P'=valid_objs' and Q'="\_. valid_objs'"]) - apply (rule lookupExtraCaps_srcs) - apply wp - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (fastforce elim: ctes_of_valid') - apply simp - done - -crunch doIPCTransfer - for objs'[wp]: "valid_objs'" - ( wp: crunch_wps hoare_vcg_const_Ball_lift - transferCapsToSlots_valid_objs - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for global_refs'[wp]: "valid_global_refs'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_global_refsT - transferCapsToSlots_valid_globals - simp: zipWithM_x_mapM ball_conj_distrib) - -declare asUser_irq_handlers' [wp] - -crunch doIPCTransfer - for irq_handlers'[wp]: "valid_irq_handlers'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_irq_handlers' - transferCapsToSlots_irq_handlers - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for irq_states'[wp]: "valid_irq_states'" - (wp: crunch_wps no_irq no_irq_mapM no_irq_storeWord no_irq_loadWord - no_irq_case_option simp: crunch_simps zipWithM_x_mapM) - -crunch doIPCTransfer - for pde_mappings'[wp]: "valid_pde_mappings'" - (wp: crunch_wps simp: crunch_simps) - -crunch doIPCTransfer - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps simp: crunch_simps rule: irqs_masked_lift) - -lemma doIPCTransfer_invs[wp]: - "\invs' and tcb_at' s and tcb_at' r\ - doIPCTransfer s ep bg grt r - \\rv. invs'\" - apply (simp add: doIPCTransfer_def) - apply (wpsimp wp: hoare_drop_imp) - done - -crunch doIPCTransfer - for nosch[wp]: "\s. P (ksSchedulerAction s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma handle_fault_reply_registers_corres: +lemma arch_getSanitiseRegisterInfo_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (do t' \ arch_get_sanitise_register_info t; - y \ as_user t - (zipWithM_x - (\r v. setRegister r - (sanitise_register t' r v)) - msg_template msg); - return (label = 0) - od) - (do t' \ getSanitiseRegisterInfo t; - y \ asUser t - (zipWithM_x - (\r v. setRegister r (sanitiseRegister t' r v)) - msg_template msg); - return (label = 0) - od)" - apply (rule corres_guard_imp) - apply (clarsimp simp: arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def) - apply (rule corres_split) - apply (rule asUser_corres') - apply(simp add: setRegister_def sanitise_register_def - sanitiseRegister_def syscallMessage_def) - apply(subst zipWithM_x_modify)+ - apply(rule corres_modify') - apply (simp|wp)+ - done - -lemma handleFaultReply_corres: - "ft' = fault_map ft \ - corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (handle_fault_reply ft t label msg) - (handleFaultReply ft' t label msg)" - apply (cases ft) - apply(simp_all add: handleFaultReply_def - handle_arch_fault_reply_def handleArchFaultReply_def - syscallMessage_def exceptionMessage_def - split: arch_fault.split) - by (rule handle_fault_reply_registers_corres)+ - -crunch handleFaultReply - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas hfr_typ_ats[wp] = typ_at_lifts [OF handleFaultReply_typ_at'] - -crunch handleFaultReply - for ct'[wp]: "\s. P (ksCurThread s)" - -lemma doIPCTransfer_sch_act_simple [wp]: - "\sch_act_simple\ doIPCTransfer sender endpoint badge grant receiver \\_. sch_act_simple\" - by (simp add: sch_act_simple_def, wp) + (arch_get_sanitise_register_info t) + (getSanitiseRegisterInfo t)" + unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def + by (fold archThreadGet_def, corres) -lemma possibleSwitchTo_invs'[wp]: - "\invs' and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - possibleSwitchTo t \\_. invs'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp tcbSchedEnqueue_invs' ssa_invs') - apply (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt]) - apply (wpsimp wp: ssa_invs' threadGet_wp)+ - apply (clarsimp dest!: obj_at_ko_at' simp: tcb_in_cur_domain'_def obj_at'_def) - done - -crunch isFinalCapability - for cur'[wp]: "\s. P (cur_tcb' s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch deleteCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma getThreadCallerSlot_inv: - "\P\ getThreadCallerSlot t \\_. P\" - by (simp add: getThreadCallerSlot_def, wp) - -crunch unbindNotification - for tcb_at'[wp]: "tcb_at' x" - -lemma finaliseCapTrue_standin_tcb_at' [wp]: - "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp getObject_ntfn_inv - | wpc - | simp)+ - done - -lemma finaliseCapTrue_standin_cur': - "\\s. cur_tcb' s\ finaliseCapTrue_standin cap v2 \\_ s'. cur_tcb' s'\" - apply (simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ finaliseCapTrue_standin_ct']) - apply (wp) - done - -lemma cteDeleteOne_cur' [wp]: - "\\s. cur_tcb' s\ cteDeleteOne slot \\_ s'. cur_tcb' s'\" - apply (simp add: cteDeleteOne_def unless_def when_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def | wp (once) cur_tcb_lift)+ - done - -lemma handleFaultReply_cur' [wp]: - "\\s. cur_tcb' s\ handleFaultReply x0 thread label msg \\_ s'. cur_tcb' s'\" - apply (clarsimp simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ handleFaultReply_ct']) - apply (wp) - done - -lemma capClass_Reply: - "capClass cap = ReplyClass tcb \ isReplyCap cap \ capTCBPtr cap = tcb" - apply (cases cap, simp_all add: isCap_simps) - apply (rename_tac arch_capability) - apply (case_tac arch_capability, simp_all) - done - -lemma reply_cap_end_mdb_chain: - "\ cte_wp_at (is_reply_cap_to t) slot s; invs s; - invs' s'; - (s, s') \ state_relation; ctes_of s' (cte_map slot) = Some cte \ - \ (mdbPrev (cteMDBNode cte) \ nullPointer - \ mdbNext (cteMDBNode cte) = nullPointer) - \ cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) - (mdbPrev (cteMDBNode cte)) s'" - apply (clarsimp simp only: cte_wp_at_reply_cap_to_ex_rights) - apply (frule(1) pspace_relation_ctes_ofI[OF state_relation_pspace_relation], - clarsimp+) - apply (subgoal_tac "\slot' rights'. caps_of_state s slot' = Some (cap.ReplyCap t True rights') - \ descendants_of slot' (cdt s) = {slot}") - apply (elim state_relationE exE) - apply (clarsimp simp: cdt_relation_def - simp del: split_paired_All) - apply (drule spec, drule(1) mp[OF _ caps_of_state_cte_at]) - apply (frule(1) pspace_relation_cte_wp_at[OF _ caps_of_state_cteD], - clarsimp+) - apply (clarsimp simp: descendants_of'_def cte_wp_at_ctes_of) - apply (frule_tac f="\S. cte_map slot \ S" in arg_cong, simp(no_asm_use)) - apply (frule invs_mdb'[unfolded valid_mdb'_def]) - apply (rule context_conjI) - apply (clarsimp simp: nullPointer_def valid_mdb_ctes_def) - apply (erule(4) subtree_prev_0) - apply (rule conjI) - apply (rule ccontr) - apply (frule valid_mdb_no_loops, simp add: no_loops_def) - apply (drule_tac x="cte_map slot" in spec) - apply (erule notE, rule r_into_trancl, rule ccontr) - apply (clarsimp simp: mdb_next_unfold valid_mdb_ctes_def nullPointer_def) - apply (rule valid_dlistEn, assumption+) - apply (subgoal_tac "ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)") - apply (frule(3) class_linksD) - apply (clarsimp simp: isCap_simps dest!: capClass_Reply[OF sym]) - apply (drule_tac f="\S. mdbNext (cteMDBNode cte) \ S" in arg_cong) - apply (simp, erule notE, rule subtree.trans_parent, assumption+) - apply (case_tac ctea, case_tac cte') - apply (clarsimp simp add: parentOf_def isMDBParentOf_CTE) - apply (simp add: sameRegionAs_def2 isCap_simps) - apply (erule subtree.cases) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (simp add: mdb_next_unfold) - apply (erule subtree.cases) - apply (clarsimp simp: valid_mdb_ctes_def) - apply (erule_tac cte=ctea in valid_dlistEn, assumption) - apply (simp add: mdb_next_unfold) - apply (clarsimp simp: mdb_next_unfold isCap_simps) - apply (drule_tac f="\S. c' \ S" in arg_cong) - apply (clarsimp simp: no_loops_direct_simp valid_mdb_no_loops) - apply (frule invs_mdb) - apply (drule invs_valid_reply_caps) - apply (clarsimp simp: valid_mdb_def reply_mdb_def - valid_reply_caps_def reply_caps_mdb_def - cte_wp_at_caps_of_state - simp del: split_paired_All) - - apply (erule_tac x=slot in allE, erule_tac x=t in allE, erule impE, fast) - apply (elim exEI) - apply clarsimp - apply (subgoal_tac "P" for P, rule sym, rule equalityI, assumption) - apply clarsimp - apply (erule(4) unique_reply_capsD) - apply (simp add: descendants_of_def) - apply (rule r_into_trancl) - apply (simp add: cdt_parent_rel_def is_cdt_parent_def) - done - -crunch cteDeleteOne - for valid_objs'[wp]: "valid_objs'" - (simp: crunch_simps unless_def - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch handleFaultReply - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma emptySlot_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - emptySlot slot irq - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp weak_sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma cancelAllIPC_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllIPC epptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllIPC_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -lemma cancelAllSignals_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllSignals ntfnptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllSignals_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -crunch finaliseCapTrue_standin - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (ignore: setThreadState - simp: crunch_simps - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma cteDeleteOne_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cteDeleteOne sl - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def)+ - done - -crunch emptySlot - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - -crunch handleFaultReply - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" -crunch handleFaultReply - for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - -crunch unbindNotification - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" -(wp: sbn_sch_act') - -crunch handleFaultReply - for valid_objs'[wp]: valid_objs' - -lemma cte_wp_at_is_reply_cap_toI: - "cte_wp_at ((=) (cap.ReplyCap t False rights)) ptr s - \ cte_wp_at (is_reply_cap_to t) ptr s" - by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) - -crunch handle_fault_reply - for pspace_alignedp[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - -crunch cteDeleteOne, doIPCTransfer, handleFaultReply - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -lemma doReplyTransfer_corres: - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at ((=) (cap.ReplyCap receiver False rights)) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - apply (simp add: do_reply_transfer_def doReplyTransfer_def cong: option.case_cong) - apply (rule corres_underlying_split [OF _ _ gts_sp gts_sp']) - apply (rule corres_guard_imp) - apply (rule getThreadState_corres, (clarsimp simp add: st_tcb_at_tcb_at invs_distinct invs_psp_aligned)+) - apply (rule_tac F = "awaiting_reply state" in corres_req) - apply (clarsimp simp add: st_tcb_at_def obj_at_def is_tcb) - apply (fastforce simp: invs_def valid_state_def intro: has_reply_cap_cte_wpD - dest: has_reply_cap_cte_wpD - dest!: valid_reply_caps_awaiting_reply cte_wp_at_is_reply_cap_toI) - apply (case_tac state, simp_all add: bind_assoc) - apply (simp add: isReply_def liftM_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply clarsimp - apply (rename_tac mdbnode) - apply (rule_tac P="Q" and Q="Q" and P'="Q'" and Q'="(\s. Q' s \ R' s)" for Q Q' R' - in stronger_corres_guard_imp[rotated]) - apply assumption - apply (rule conjI, assumption) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (drule cte_wp_at_is_reply_cap_toI) - apply (erule(4) reply_cap_end_mdb_chain) - apply (rule corres_assert_assume[rotated], simp) - apply (simp add: getSlotCap_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_assert_assume[rotated]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_guard_imp) - apply (rule corres_split[OF threadget_fault_corres]) - apply (case_tac rv, simp_all add: fault_rel_optionation_def bind_assoc)[1] - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched - set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' - sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def - | strengthen valid_queues_in_correct_ready_q valid_sched_valid_queues - valid_queues_ready_qs_distinct)+ - apply (strengthen cte_wp_at_reply_cap_can_fast_finalise) - apply (wp hoare_vcg_conj_lift) - apply (rule hoare_strengthen_post [OF do_ipc_transfer_non_null_cte_wp_at]) - prefer 2 - apply (erule cte_wp_at_weakenE) - apply (fastforce) - apply (clarsimp simp:is_cap_simps) - apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q'="\_ s. valid_objs' s \ cur_tcb' s \ tcb_at' receiver s - \ sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp, simp add: sch_act_wf_weak) - apply (wp tcb_in_cur_domain'_lift) - defer - apply (simp) - apply (wp)+ - apply (clarsimp simp: invs_psp_aligned invs_distinct) - apply (rule conjI, erule invs_valid_objs) - apply (rule conjI, clarsimp)+ - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp) - apply (rule conjI, rule refl) - apply (fastforce) - apply (clarsimp simp: invs_def valid_sched_def valid_sched_action_def) - apply (simp) - apply (auto simp: invs'_def valid_state'_def)[1] - - apply (rule corres_guard_imp) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (rule corres_split_eqr[OF getMRs_corres]) - apply (simp(no_asm) del: dc_simp) - apply (rule corres_split_eqr[OF handleFaultReply_corres]) - apply simp - apply (rule corres_split) - apply (rule threadset_corresT; - clarsimp simp add: tcb_relation_def fault_rel_optionation_def cteSizeBits_def - tcb_cap_cases_def tcb_cte_cases_def inQ_def) - apply (rule_tac Q="valid_sched and cur_tcb and tcb_at receiver and pspace_aligned and pspace_distinct" - and Q'="tcb_at' receiver and cur_tcb' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and valid_objs' - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_guard_imp) - apply (case_tac rvb, simp_all)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (fold dc_def, rule possibleSwitchTo_corres) - apply simp - apply (wp hoare_weak_lift_imp hoare_weak_lift_imp_conj set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' - | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ - apply (rule corres_guard_imp) - apply (rule setThreadState_corres) - apply clarsimp+ - apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched - threadSet_tcbDomain_triv threadSet_valid_objs' - threadSet_sched_pointers threadSet_valid_sched_pointers - | simp add: valid_tcb_state'_def)+ - apply (rule_tac Q'="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and - valid_objs and pspace_aligned and pspace_distinct" - in hoare_strengthen_post [rotated], clarsimp) - apply (wp) - apply (rule hoare_chain [OF cap_delete_one_invs]) - apply (assumption) - apply (rule conjI, clarsimp) - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def) - apply (rule_tac Q'="\_. tcb_at' sender and tcb_at' receiver and invs'" - in hoare_strengthen_post [rotated]) - apply (solves\auto simp: invs'_def valid_state'_def\) - apply wp - apply clarsimp - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp simp add: can_fast_finalise_def) - apply (erule(1) emptyable_cte_wp_atD) - apply (rule allI, rule impI) - apply (clarsimp simp add: is_master_reply_cap_def) - apply (clarsimp) - done - -(* when we cannot talk about reply cap rights explicitly (for instance, when a schematic ?rights - would be generated too early *) -lemma doReplyTransfer_corres': - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at (is_reply_cap_to receiver) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - using doReplyTransfer_corres[of receiver sender _ slot] - by (fastforce simp add: cte_wp_at_reply_cap_to_ex_rights corres_underlying_def) - -lemma valid_pspace'_splits[elim!]: - "valid_pspace' s \ valid_objs' s" - "valid_pspace' s \ pspace_aligned' s" - "valid_pspace' s \ pspace_distinct' s" - "valid_pspace' s \ valid_mdb' s" - "valid_pspace' s \ no_0_obj' s" - by (simp add: valid_pspace'_def)+ - -lemma sts_valid_pspace_hangers: - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. valid_objs'\" - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. pspace_distinct'\" - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. pspace_aligned'\" - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. valid_mdb'\" - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. no_0_obj'\" - by (safe intro!: hoare_strengthen_post [OF sts'_valid_pspace'_inv]) - -declare no_fail_getSlotCap [wp] - -lemma setupCallerCap_corres: - "corres dc - (st_tcb_at (Not \ halted) sender and tcb_at receiver and - st_tcb_at (Not \ awaiting_reply) sender and valid_reply_caps and - valid_objs and pspace_distinct and pspace_aligned and valid_mdb - and valid_list and valid_arch_state and - valid_reply_masters and cte_wp_at (\c. c = cap.NullCap) (receiver, tcb_cnode_index 3)) - (tcb_at' sender and tcb_at' receiver and valid_pspace' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) - (setup_caller_cap sender receiver grant) - (setupCallerCap sender receiver grant)" - supply if_split[split del] - apply (simp add: setup_caller_cap_def setupCallerCap_def - getThreadReplySlot_def locateSlot_conv - getThreadCallerSlot_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split_nor) - apply (rule setThreadState_corres) - apply (simp split: option.split) - apply (rule corres_symb_exec_r) - apply (rule_tac F="\r. cteCap masterCTE = capability.ReplyCap sender True r - \ mdbNext (cteMDBNode masterCTE) = nullPointer" - in corres_gen_asm2, clarsimp simp add: isCap_simps) - apply (rule corres_symb_exec_r) - apply (rule_tac F="rv = capability.NullCap" - in corres_gen_asm2, simp) - apply (rule cteInsert_corres) - apply (simp split: if_splits) - apply (simp add: cte_map_def tcbReplySlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (simp add: cte_map_def tcbCallerSlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (rule_tac Q'="\rv. cte_at' (receiver + 2 ^ cte_level_bits * tcbCallerSlot)" - in hoare_post_add) - - apply (wp, (wp getSlotCap_wp)+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at'_def cte_at'_def) - apply (rule_tac Q'="\rv. cte_at' (sender + 2 ^ cte_level_bits * tcbReplySlot)" - in hoare_post_add) - apply (wp, (wp getCTE_wp')+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (wp sts_valid_pspace_hangers - | simp add: cte_wp_at_ctes_of)+ - apply (clarsimp simp: valid_tcb_state_def st_tcb_at_reply_cap_valid - st_tcb_at_tcb_at st_tcb_at_caller_cap_null - split: option.split) - apply (clarsimp simp: valid_tcb_state'_def valid_cap'_def capAligned_reply_tcbI) - apply (frule(1) st_tcb_at_reply_cap_valid, simp, clarsimp) - apply (clarsimp simp: cte_wp_at_ctes_of cte_wp_at_caps_of_state) - apply (drule pspace_relation_cte_wp_at[rotated, OF caps_of_state_cteD], - erule valid_pspace'_splits, clarsimp+)+ - apply (clarsimp simp: cte_wp_at_ctes_of cte_map_def tcbReplySlot_def - tcbCallerSlot_def tcb_cnode_index_def - is_cap_simps) - apply (auto intro: reply_no_descendants_mdbNext_null[OF not_waiting_reply_slot_no_descendants] - simp: cte_index_repair shiftl_t2n') - done - -crunch getThreadCallerSlot +crunch getSanitiseRegisterInfo for tcb_at'[wp]: "tcb_at' t" -lemma getThreadReplySlot_tcb_at'[wp]: - "\tcb_at' t\ getThreadReplySlot tcb \\_. tcb_at' t\" - by (simp add: getThreadReplySlot_def, wp) - -lemma setupCallerCap_tcb_at'[wp]: - "\tcb_at' t\ setupCallerCap sender receiver grant \\_. tcb_at' t\" - by (simp add: setupCallerCap_def, wp hoare_drop_imp) - -crunch setupCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps) - -lemma cteInsert_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert newCap srcSlot destSlot - \\_ s. sch_act_wf (ksSchedulerAction s) s\" -by (wp sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma setupCallerCap_sch_act [wp]: - "\\s. sch_act_not t s \ sch_act_wf (ksSchedulerAction s) s\ - setupCallerCap t r g \\_ s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: setupCallerCap_def getSlotCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv) - apply (wp getCTE_wp' sts_sch_act' hoare_drop_imps hoare_vcg_all_lift) - apply clarsimp - done - -lemma possibleSwitchTo_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def threadGet_def curDomain_def - bitmap_fun_defs) - apply (wp rescheduleRequired_weak_sch_act_wf - weak_sch_act_wf_lift_linear[where f="tcbSchedEnqueue t"] - getObject_tcb_wp hoare_weak_lift_imp - | wpc)+ - apply (clarsimp simp: obj_at'_def projectKOs weak_sch_act_wf_def ps_clear_def tcb_in_cur_domain'_def) - done - -lemmas transferCapsToSlots_pred_tcb_at' = - transferCapsToSlots_pres1 [OF cteInsert_pred_tcb_at'] - -crunch doIPCTransfer, possibleSwitchTo - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - (wp: mapM_wp' crunch_wps simp: zipWithM_x_mapM) - -lemma setSchedulerAction_ct_in_domain: - "\\s. ct_idle_or_in_cur_domain' s - \ p \ ResumeCurrentThread \ setSchedulerAction p - \\_. ct_idle_or_in_cur_domain'\" - by (simp add:setSchedulerAction_def | wp)+ - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - (wp: crunch_wps setSchedulerAction_ct_in_domain simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" - (wp: crunch_wps constOnFailure_wp simp: crunch_simps) - -crunch possibleSwitchTo - for tcb_at'[wp]: "tcb_at' t" - and valid_pspace'[wp]: valid_pspace' - (wp: crunch_wps) - -lemma sendIPC_corres: -(* call is only true if called in handleSyscall SysCall, which - is always blocking. *) - assumes "call \ bl" - shows - "corres dc (einvs and st_tcb_at active t and ep_at ep and ex_nonz_cap_to t) - (invs' and sch_act_not t and tcb_at' t and ep_at' ep) - (send_ipc bl call bg cg cgr t ep) (sendIPC bl call bg cg cgr t ep)" -proof - - show ?thesis - apply (insert assms) - apply (unfold send_ipc_def sendIPC_def Let_def) - apply (case_tac bl) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\ob. ob = Endpoint rv) ep - and ex_nonz_cap_to t" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (case_tac rv) - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) - apply clarsimp - \ \concludes IdleEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) - apply clarsimp - \ \concludes SendEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (simp add: isReceive_def split del:if_split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: case_bool_If case_option_If if3_fold - simp del: dc_simp split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_split[OF possibleSwitchTo_corres]) - apply (fold when_def)[1] - apply (rule_tac P="call" and P'="call" - in corres_symmetric_bool_cases, blast) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (rule corres_if2, simp) - apply (rule setupCallerCap_corres) - apply (rule setThreadState_corres, simp) - apply (rule corres_trivial) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (wp | simp)+ - apply (wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases) - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases)[1] - apply (simp add: valid_tcb_state_def pred_conj_def) - apply (strengthen reply_cap_doesnt_exist_strg disjI2_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues)+ - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - do_ipc_transfer_valid_arch - | clarsimp simp: is_cap_simps)+)[1] - apply (simp add: pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift hoare_drop_imps)[1] - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply (simp) - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb')+ - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def ep_redux_simps - ep_redux_simps' st_tcb_at_tcb_at valid_ep_def - cong: list.case_cong) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_def2 valid_sched_def valid_sched_action_def) - apply (force simp: st_tcb_def2 dest!: st_tcb_at_caller_cap_null[simplified,rotated]) - subgoal by (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\k. k = Endpoint rv) ep" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (rename_tac rv rv') - apply (case_tac rv) - apply (simp add: ep_relation_def) - \ \concludes IdleEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - \ \concludes SendEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (rule_tac F="a \ t" in corres_req) - apply (clarsimp simp: invs_def valid_state_def - valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_def obj_at_def tcb_bound_refs_def2) - apply fastforce - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: isReceive_def case_bool_If - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (simp add: if_apply_def2) - apply ((wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases | - simp add: if_apply_def2 split del: if_split)+)[1] - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases) - apply (simp add: valid_tcb_state_def pred_conj_def) - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - | clarsimp simp: is_cap_simps - | strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues )+)[1] - apply (simp add: valid_tcb_state'_def pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear hoare_drop_imps) - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply simp - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb') - apply (clarsimp simp add: invs_def valid_state_def - valid_pspace_def ep_redux_simps ep_redux_simps' - st_tcb_at_tcb_at - cong: list.case_cong) - apply (clarsimp simp: valid_ep_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_at_caller_cap_null) - apply (fastforce simp: st_tcb_def2 valid_sched_def valid_sched_action_def) - subgoal by (auto simp: valid_ep'_def - split: list.split; - clarsimp simp: invs'_def valid_state'_def) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - done +crunch arch_get_sanitise_register_info + for pspace_distinct[wp]: pspace_distinct + and pspace_aligned[wp]: pspace_aligned + +lemma sanitiseRegister_sanitise_register[Ipc_R_assms]: + "sanitiseRegister = sanitise_register" + by (rule ext)+ + (clarsimp simp add: sanitiseRegister_def sanitise_register_def cong: register.case_cong) + +lemma handleArchFaultReply_corres[Ipc_R_assms]: + "corres (=) \ \ + (handle_arch_fault_reply ft t label msg) (handleArchFaultReply (arch_fault_map ft) t label msg)" + by (clarsimp simp: handle_arch_fault_reply_def handleArchFaultReply_def + split: arch_fault.split) + +crunch getSanitiseRegisterInfo, handleArchFaultReply, handle_arch_fault_reply + for inv[Ipc_R_assms, wp]: P + +lemma ctes_of_mdbNext_parentOf[Ipc_R_assms]: + "\ ctes_of s' \ cte_map cptr \ cte_map slot; + ctes_of s' (cte_map cptr) = Some (CTE (capability.ReplyCap t master rights) n); + ctes_of s' (mdbNext (cteMDBNode cte)) = Some (CTE (capability.ReplyCap t master' rights') n'); + ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)\ + \ ctes_of s' \ cte_map cptr parentOf mdbNext (cteMDBNode cte)" + by (clarsimp simp add: parentOf_def isMDBParentOf_CTE sameRegionAs_def2 isCap_simps) + (erule subtree.cases; clarsimp simp: parentOf_def isMDBParentOf_CTE) + +crunch debugPrint + for inv[Ipc_R_assms, wp]: P + and (no_fail) no_fail[Ipc_R_assms, intro!, wp, simp] + +(* this specifically refers to the 4 message registers *) +lemma max_message_size_less_max_ipc_words[Ipc_R_assms]: + "n \ 4 + \ word_size * (word_of_nat msg_max_extra_caps + (word_of_nat msg_max_length + n)) + < max_ipc_words * word_size" + apply (simp add: msg_max_extra_caps_def msg_max_length_def max_ipc_words word_size_def) + apply (rule_tac y="0x3D8 + 8 * 4" in order_le_less_trans) + apply (rule word_plus_mono_right) + apply (rule word_mult_le_mono1'; simp) + apply simp+ + done + +end (* Arch *) + +interpretation Ipc_R?: Ipc_R +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Ipc_R_assms)?)?) qed -crunch setMessageInfo - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas setMessageInfo_typ_ats[wp] = typ_at_lifts [OF setMessageInfo_typ_at'] - -(* Annotation added by Simon Winwood (Thu Jul 1 20:54:41 2010) using taint-mode *) -declare tl_drop_1[simp] - -crunch cancel_ipc - for cur[wp]: "cur_tcb" - (wp: crunch_wps simp: crunch_simps) - -crunch asUser - for valid_objs'[wp]: "valid_objs'" - -lemma valid_sched_weak_strg: - "valid_sched s \ weak_valid_sched_action s" - by (simp add: valid_sched_def valid_sched_action_def) - -crunch as_user - for weak_valid_sched_action[wp]: weak_valid_sched_action - (wp: weak_valid_sched_action_lift) - -lemma sendSignal_corres: - "corres dc (einvs and ntfn_at ep) (invs' and ntfn_at' ep) - (send_signal ep bg) (sendSignal ep bg)" - supply if_cong[cong] - apply (simp add: send_signal_def sendSignal_def Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getNotification_corres, - where - R = "\rv. einvs and ntfn_at ep and valid_ntfn rv and - ko_at (Structures_A.Notification rv) ep" and - R' = "\rv'. invs' and ntfn_at' ep and - valid_ntfn' rv' and ko_at' rv' ep"]) - defer - apply (wp get_simple_ko_ko_at get_ntfn_ko')+ - apply (simp add: invs_valid_objs)+ - apply (case_tac "ntfn_obj ntfn") - \ \IdleNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (case_tac "ntfnBoundTCB nTFN") - apply clarsimp - apply (rule corres_guard_imp[OF setNotification_corres]) - apply (clarsimp simp add: ntfn_relation_def)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_if) - apply (fastforce simp: receive_blocked_def receiveBlocked_def - thread_state_relation_def - split: Structures_A.thread_state.splits - Structures_H.thread_state.splits) - apply (rule corres_split[OF cancel_ipc_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply (clarsimp simp: thread_state_relation_def) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply wp - apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' hoare_disjI2 - cancel_ipc_cte_wp_at_not_reply_state - | strengthen invs_vobjs_strgs invs_psp_aligned_strg valid_sched_weak_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues - | simp add: valid_tcb_state_def)+ - apply (rule_tac Q'="\rv. invs' and tcb_at' a" in hoare_strengthen_post) - apply wp - apply (fastforce simp: invs'_def valid_state'_def sch_act_wf_weak valid_tcb_state'_def) - apply (rule setNotification_corres) - apply (clarsimp simp add: ntfn_relation_def) - apply (wp gts_wp gts_wp' | clarsimp)+ - apply (auto simp: valid_ntfn_def receive_blocked_def valid_sched_def invs_cur - elim: pred_tcb_weakenE - intro: st_tcb_at_reply_cap_valid - split: Structures_A.thread_state.splits)[1] - apply (clarsimp simp: valid_ntfn'_def invs'_def valid_state'_def valid_pspace'_def sch_act_wf_weak) - \ \WaitingNtfn\ - apply (clarsimp simp add: ntfn_relation_def Let_def) - apply (simp add: update_waiting_ntfn_def) - apply (rename_tac list) - apply (case_tac "tl list = []") - \ \tl list = []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper split del: if_split) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply ((wp | simp)+)[1] - apply (rule_tac Q'="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and - cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs' and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct'" - in hoare_post_imp, clarsimp simp: pred_tcb_at' elim!: sch_act_wf_weak) - apply (wp | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (wp set_simple_ko_valid_objs set_ntfn_aligned' set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def ntfn_queued_st_tcb_at valid_sched_def - valid_sched_action_def) - apply (auto simp: valid_ntfn'_def )[1] - apply (clarsimp simp: invs'_def valid_state'_def) - - \ \tl list \ []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def split:list.splits) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply (wp cur_tcb_lift | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wpsimp wp: sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb) - apply (wp set_ntfn_aligned' set_simple_ko_valid_objs set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def neq_Nil_conv - ntfn_queued_st_tcb_at valid_sched_def valid_sched_action_def - split: option.splits) - apply (auto simp: valid_ntfn'_def neq_Nil_conv invs'_def valid_state'_def - weak_sch_act_wf_def - split: option.splits)[1] - \ \ActiveNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def combine_ntfn_badges_def - combine_ntfn_msgs_def) - apply (simp add: invs_def valid_state_def valid_ntfn_def) - apply (simp add: invs'_def valid_state'_def valid_ntfn'_def) - done - -lemma valid_Running'[simp]: - "valid_tcb_state' Running = \" - by (rule ext, simp add: valid_tcb_state'_def) - -crunch setMRs - for typ'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma possibleSwitchTo_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp threadSet_sch_act setQueue_sch_act threadGet_wp - | simp add: unless_def | wpc)+ - apply (auto simp: obj_at'_def projectKOs tcb_in_cur_domain'_def) - done - -crunch possibleSwitchTo - for st_refs_of'[wp]: "\s. P (state_refs_of' s)" - (wp: crunch_wps) - -crunch possibleSwitchTo - for cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps) -crunch possibleSwitchTo - for objs'[wp]: valid_objs' - (wp: crunch_wps) -crunch possibleSwitchTo - for ct[wp]: cur_tcb' - (wp: cur_tcb_lift crunch_wps) - -lemma possibleSwitchTo_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) - and pspace_aligned' and pspace_distinct'\ - possibleSwitchTo t - \\_. if_live_then_nonz_cap'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp | wpc | simp)+ - apply (simp only: imp_conv_disj, wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (wp threadGet_wp)+ - apply (auto simp: obj_at'_def) - done - -crunch possibleSwitchTo - for ifunsafe[wp]: if_unsafe_then_cap' - and idle'[wp]: valid_idle' - and global_refs'[wp]: valid_global_refs' - and arch_state'[wp]: valid_arch_state' - and irq_node'[wp]: "\s. P (irq_node' s)" - and typ_at'[wp]: "\s. P (typ_at' T p s)" - and irq_handlers'[wp]: valid_irq_handlers' - and irq_states'[wp]: valid_irq_states' - and pde_mappigns'[wp]: valid_pde_mappings' - (wp: crunch_wps simp: unless_def tcb_cte_cases_def cteSizeBits_def) - -crunch sendSignal - for ct'[wp]: "\s. P (ksCurThread s)" - and it'[wp]: "\s. P (ksIdleThread s)" - (wp: crunch_wps simp: crunch_simps o_def) - -context -notes option.case_cong_weak[cong] -begin -crunch sendSignal, setBoundNotification - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps getObject_inv loadObject_default_inv - simp: crunch_simps unless_def o_def - rule: irqs_masked_lift) -end - -lemma ct_in_state_activatable_imp_simple'[simp]: - "ct_in_state' activatable' s \ ct_in_state' simple' s" - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply (case_tac st; simp) - done - -lemma setThreadState_nonqueued_state_update: - "\\s. invs' s \ st_tcb_at' simple' t s - \ st \ {Inactive, Running, Restart, IdleThreadState} - \ (st \ Inactive \ ex_nonz_cap_to' t s) - \ (t = ksIdleThread s \ idle' st) - \ (\ runnable' st \ sch_act_simple s)\ - setThreadState st t - \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply (clarsimp simp: pred_tcb_at') - apply (rule conjI, fastforce simp: valid_tcb_state'_def) - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI) - apply clarsimp - apply (erule delta_sym_refs) - apply (fastforce split: if_split_asm) - apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) - apply fastforce - done - -lemma cteDeleteOne_reply_cap_to'[wp]: - "\ex_nonz_cap_to' p and - cte_wp_at' (\c. isReplyCap (cteCap c)) slot\ - cteDeleteOne slot - \\rv. ex_nonz_cap_to' p\" - apply (simp add: cteDeleteOne_def ex_nonz_cap_to'_def unless_def) - apply (rule bind_wp [OF _ getCTE_sp]) - apply (rule hoare_assume_pre) - apply (subgoal_tac "isReplyCap (cteCap cte)") - apply (wp hoare_vcg_ex_lift emptySlot_cte_wp_cap_other isFinalCapability_inv - | clarsimp simp: finaliseCap_def isCap_simps | simp - | wp (once) hoare_drop_imps)+ - apply (fastforce simp: cte_wp_at_ctes_of) - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) - done - -crunch setupCallerCap, possibleSwitchTo, asUser, doIPCTransfer - for vms'[wp]: "valid_machine_state'" - (wp: crunch_wps simp: zipWithM_x_mapM_x) - -crunch cancelSignal - for nonz_cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps simp: crunch_simps) - -lemma cancelIPC_nonz_cap_to'[wp]: - "\ex_nonz_cap_to' p\ cancelIPC t \\rv. ex_nonz_cap_to' p\" - apply (simp add: cancelIPC_def getThreadReplySlot_def Let_def - capHasProperty_def) - apply (wp threadSet_cap_to' - | wpc - | simp - | clarsimp elim!: cte_wp_at_weakenE' - | rule hoare_post_imp[where Q'="\rv. ex_nonz_cap_to' p"])+ - done - - -crunch activateIdleThread, getThreadReplySlot, isFinalCapability - for nosch[wp]: "\s. P (ksSchedulerAction s)" - (ignore: setNextPC simp: Let_def) - -crunch setupCallerCap, asUser, setMRs, doIPCTransfer, possibleSwitchTo - for pspace_domain_valid[wp]: "pspace_domain_valid" - (wp: crunch_wps simp: zipWithM_x_mapM_x) - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma setThreadState_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - setThreadState st t - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - unfolding setThreadState_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imps) - -lemma cancelAllIPC_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllIPC epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllIPC_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -lemma cancelAllSignals_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllSignals epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllSignals_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -crunch finaliseCapTrue_standin - for not_rct[wp]: "\s. ksSchedulerAction s \ ResumeCurrentThread" - (simp: Let_def) - -lemma cancelIPC_ResumeCurrentThread_imp_notct[wp]: - "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelIPC t - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - (is "\?PRE t'\ _ \_\") -proof - - have aipc: "\t t' ntfn. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelSignal t ntfn - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cancelSignal_def) - apply (wp)[1] - apply (wp hoare_convert_imp)+ - apply (rule_tac P="\s. ksSchedulerAction s \ ResumeCurrentThread" - in hoare_weaken_pre) - apply (wpc) - apply (wp | simp)+ - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done - have cdo: "\t t' slot. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cteDeleteOne slot - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp hoare_convert_imp | simp)+ - done - show ?thesis - apply (simp add: cancelIPC_def Let_def) - apply (wp, wpc) - prefer 4 \ \state = Running\ - apply wp - prefer 7 \ \state = Restart\ - apply wp - apply (wp)+ - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp cdo)+ - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply ((wp aipc hoare_convert_imp)+)[6] - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done -qed - -crunch setMRs - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma sai_invs'[wp]: - "\invs' and ex_nonz_cap_to' ntfnptr\ - sendSignal ntfnptr badge \\y. invs'\" - unfolding sendSignal_def - including classic_wp_pre - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj nTFN", simp_all) - prefer 3 - apply (rename_tac list) - apply (case_tac list, - simp_all split del: if_split - add: setMessageInfo_def)[1] - apply (rule hoare_pre) - apply (wp hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act])+ - apply (clarsimp simp:conj_comms) - apply (simp add: invs'_def valid_state'_def) - apply ((wp valid_irq_node_lift sts_valid_objs' setThreadState_ct_not_inQ - set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' valid_dom_schedule'_lift - hoare_convert_imp [OF setNotification_nosch] - | simp split del: if_split)+)[3] - - apply (intro conjI[rotated]; - (solves \clarsimp simp: invs'_def valid_state'_def valid_pspace'_def\)?) - apply clarsimp - apply (clarsimp simp: invs'_def valid_state'_def split del: if_split) - apply (drule(1) ct_not_in_ntfnQueue, simp+) - apply clarsimp - apply (frule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def) - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_idle'_def pred_tcb_at'_def idle_tcb'_def - dest!: sym_refs_ko_atD' sym_refs_st_tcb_atD' sym_refs_obj_atD' - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (clarsimp elim!: if_live_then_nonz_capE' simp:invs'_def valid_state'_def) - apply (drule(1) sym_refs_ko_atD') - apply (clarsimp elim!: ko_wp_at'_weakenE - intro!: refs_of_live') - apply (clarsimp split del: if_split)+ - apply (frule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (frule invs_sym') - apply (drule(1) sym_refs_obj_atD') - apply (clarsimp split del: if_split cong: if_cong - simp: st_tcb_at_refs_of_rev' ep_redux_simps' ntfn_bound_refs'_def) - apply (frule st_tcb_at_state_refs_ofD') - apply (erule delta_sym_refs) - apply (fastforce simp: split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset symreftype_inverse' - split: if_split_asm) - apply (clarsimp simp:invs'_def) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def valid_state'_def) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (clarsimp simp:invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (case_tac "ntfnBoundTCB nTFN", simp_all) - apply (wp set_ntfn_minor_invs') - apply (fastforce simp: valid_ntfn'_def invs'_def valid_state'_def - elim!: obj_at'_weakenE - dest!: global'_no_ex_cap) - apply (wp add: hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act] - setThreadState_nonqueued_state_update sts_st_tcb' - del: cancelIPC_simple) - apply (clarsimp | wp cancelIPC_ct')+ - apply (wp set_ntfn_minor_invs' gts_wp' | clarsimp)+ - apply (frule pred_tcb_at') - by (wp set_ntfn_minor_invs' - | rule conjI - | clarsimp elim!: st_tcb_ex_cap'' - | fastforce simp: receiveBlocked_def projectKOs pred_tcb_at'_def obj_at'_def - dest!: invs_rct_ct_activatable' - split: thread_state.splits - | fastforce simp: invs'_def valid_state'_def receiveBlocked_def projectKOs - valid_obj'_def valid_ntfn'_def - split: thread_state.splits - dest!: global'_no_ex_cap st_tcb_ex_cap'' ko_at_valid_objs')+ - -lemma replyFromKernel_corres: - "corres dc (tcb_at t and invs) invs' - (reply_from_kernel t r) (replyFromKernel t r)" - apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) - apply (fastforce intro!: tcb_at_cross) - apply (case_tac r) - apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def - badge_register_def badgeRegister_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres]) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split_eqr[OF setMRs_corres]) - apply simp - apply (rule setMessageInfo_corres) - apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' - | fastforce)+ - done - -lemma rfk_invs': - "\invs' and tcb_at' t\ replyFromKernel t r \\rv. invs'\" - apply (simp add: replyFromKernel_def) - apply (cases r) - apply wpsimp - done - -crunch replyFromKernel - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma completeSignal_corres: - "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and pspace_distinct and valid_objs - \ \and obj_at (\ko. ko = Notification ntfn \ Ipc_A.isActive ntfn) ntfnptr*\ ) - (ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' and obj_at' isActive ntfnptr) - (complete_signal ntfnptr tcb) (completeSignal ntfnptr tcb)" - apply (simp add: complete_signal_def completeSignal_def) - apply (rule corres_guard_imp) - apply (rule_tac R'="\ntfn. ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' - and valid_ntfn' ntfn and (\_. isActive ntfn)" - in corres_split[OF getNotification_corres]) - apply (rule corres_gen_asm2) - apply (case_tac "ntfn_obj rv") - apply (clarsimp simp: ntfn_relation_def isActive_def - split: ntfn.splits Structures_H.notification.splits)+ - apply (rule corres_guard2_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres setNotification_corres]) - apply (clarsimp simp: ntfn_relation_def) - apply (wp set_simple_ko_valid_objs get_simple_ko_wp getNotification_wp | clarsimp simp: valid_ntfn'_def)+ - apply (clarsimp simp: valid_pspace'_def) - apply (frule_tac P="(\k. k = ntfn)" in obj_at_valid_objs', assumption) - apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def obj_at'_def) - done - - -lemma doNBRecvFailedTransfer_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ - (do_nbrecv_failed_transfer thread) - (doNBRecvFailedTransfer thread)" - unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def - by (corres corres: asUser_setRegister_corres - simp: badgeRegister_def badge_register_def)+ - -lemma receiveIPC_corres: - assumes "is_ep_cap cap" and "cap_relation cap cap'" - shows " - corres dc (einvs and valid_sched and tcb_at thread and valid_cap cap and ex_nonz_cap_to thread - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3)) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_ipc thread cap isBlocking) (receiveIPC thread cap' isBlocking)" - apply (insert assms) - apply (simp add: receive_ipc_def receiveIPC_def - split del: if_split) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 right) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getBoundNotification_corres]) - apply (rule_tac r'="ntfn_relation" in corres_split) - apply (rule corres_option_split[rotated 2]) - apply (rule getNotification_corres) - apply clarsimp - apply (rule corres_trivial, simp add: ntfn_relation_def default_notification_def - default_ntfn_def) - apply (rule corres_if) - apply (clarsimp simp: ntfn_relation_def Ipc_A.isActive_def Endpoint_H.isActive_def - split: Structures_A.ntfn.splits Structures_H.notification.splits) - apply clarsimp - apply (rule completeSignal_corres) - apply (rule_tac P="einvs and valid_sched and tcb_at thread and - ep_at word1 and valid_ep ep and - obj_at (\k. k = Endpoint ep) word1 - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3) - and ex_nonz_cap_to thread" and - P'="invs' and tcb_at' thread and ep_at' word1 and - valid_ep' epa" - in corres_inst) - apply (case_tac ep) - \ \IdleEP\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def - valid_tcb_state_def st_tcb_at_tcb_at) - apply auto[1] - \ \SendEP\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (clarsimp simp: valid_ep_def) - apply (case_tac list, simp_all split del: if_split)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (case_tac lista, simp_all add: ep_relation_def)[1] - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. - sender_state = - Structures_A.thread_state.BlockedOnSend word1 data" - in corres_gen_asm) - apply (clarsimp simp: isSend_def case_bool_If - case_option_If if3_fold - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (simp split del: if_split cong: if_cong) - apply (fold dc_def)[1] - apply (rule_tac P="valid_objs and valid_mdb and valid_list and valid_arch_state - and valid_sched - and cur_tcb - and valid_reply_caps - and pspace_aligned and pspace_distinct - and st_tcb_at (Not \ awaiting_reply) a - and st_tcb_at (Not \ halted) a - and tcb_at thread and valid_reply_masters - and cte_wp_at (\c. c = cap.NullCap) - (thread, tcb_cnode_index 3)" - and P'="tcb_at' a and tcb_at' thread and cur_tcb' - and valid_pspace' - and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_guard_imp [OF corres_if]) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_if2 [OF _ setupCallerCap_corres setThreadState_corres]) - apply simp - apply simp - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wpsimp wp: sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (fastforce simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) - apply (clarsimp split: if_split_asm) - apply (clarsimp | wp do_ipc_transfer_tcb_caps do_ipc_transfer_valid_arch)+ - apply (rule_tac Q'="\_ s. sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp) - apply (fastforce elim: sch_act_wf_weak) - apply (wp sts_st_tcb' gts_st_tcb_at | simp)+ - apply (simp cong: list.case_cong) - apply wp - apply simp - apply (wp weak_sch_act_wf_lift_linear setEndpoint_valid_mdb' set_ep_valid_objs') - apply (clarsimp split: list.split) - apply (clarsimp simp add: invs_def valid_state_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_ep_def valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ko. ko = Endpoint e" for e]) - apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) - apply (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split)[1] - \ \RecvEP\ - apply (simp add: ep_relation_def) - apply (rule_tac corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (fastforce simp: valid_tcb_state_def) - apply (clarsimp simp add: valid_tcb_state'_def) - apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' - hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift - | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ - apply (fastforce simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def - valid_obj_def valid_tcb_def valid_bound_ntfn_def - elim!: obj_at_valid_objsE - split: option.splits) - apply clarsimp - apply (auto simp: valid_cap'_def invs_valid_pspace' valid_obj'_def valid_tcb'_def - valid_bound_ntfn'_def obj_at'_def projectKOs pred_tcb_at'_def - dest!: invs_valid_objs' obj_at_valid_objs' - split: option.splits) - done - -lemma receiveSignal_corres: - "\ is_ntfn_cap cap; cap_relation cap cap' \ \ - corres dc (invs and st_tcb_at active thread and valid_cap cap and ex_nonz_cap_to thread) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" - apply (simp add: receive_signal_def receiveSignal_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 rights) - apply (rule corres_guard_imp) - apply (rule_tac R="\rv. invs and tcb_at thread and st_tcb_at active thread and - ntfn_at word1 and ex_nonz_cap_to thread and - valid_ntfn rv and - obj_at (\k. k = Notification rv) word1" and - R'="\rv'. invs' and tcb_at' thread and ntfn_at' word1 and - valid_ntfn' rv'" - in corres_split[OF getNotification_corres]) - apply clarsimp - apply (case_tac "ntfn_obj rv") - \ \IdleNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, fastforce+) - \ \WaitingNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp) - apply (rule doNBRecvFailedTransfer_corres, fastforce+) - \ \ActiveNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (fastforce simp: invs_def valid_state_def valid_pspace_def - elim!: st_tcb_weakenE) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply wp+ - apply (clarsimp simp add: ntfn_at_def2 valid_cap_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_cap'_def) - done - -lemma tg_sp': - "\P\ threadGet f p \\t. obj_at' (\t'. f t' = t) p and P\" - including no_pre - apply (simp add: threadGet_def) - apply wp - apply (rule hoare_strengthen_post) - apply (rule getObject_tcb_sp) - apply clarsimp - apply (erule obj_at'_weakenE) - apply simp - done - -declare lookup_cap_valid' [wp] - -lemma sendFaultIPC_corres: - "valid_fault f \ fr f f' \ - corres (fr \ dc) - (einvs and st_tcb_at active thread and ex_nonz_cap_to thread) - (invs' and sch_act_not thread and tcb_at' thread) - (send_fault_ipc thread f) (sendFaultIPC thread f')" - apply (simp add: send_fault_ipc_def sendFaultIPC_def - liftE_bindE Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split [where r'="\fh fh'. fh = to_bl fh'"]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_cap_fault) - apply (rule lookup_cap_corres, rule refl) - apply (rule_tac P="einvs and st_tcb_at active thread - and valid_cap handler_cap and ex_nonz_cap_to thread" - and P'="invs' and tcb_at' thread and sch_act_not thread - and valid_cap' handlerCap" - in corres_inst) - apply (case_tac handler_cap, - simp_all add: isCap_defs lookup_failure_map_def - case_bool_If If_rearrage - split del: if_split cong: if_cong)[1] - apply (rule corres_guard_imp) - apply (rule corres_if2 [OF refl]) - apply (simp add: dc_def[symmetric]) - apply (rule corres_split[OF threadset_corres sendIPC_corres], simp_all)[1] - apply (simp add: tcb_relation_def fault_rel_optionation_def inQ_def)+ - apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state - thread_set_typ_at ep_at_typ_at ex_nonz_cap_to_pres - thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched - | simp add: tcb_cap_cases_def)+ - apply ((wp threadSet_invs_trivial threadSet_tcb' - | simp add: tcb_cte_cases_def - | wp (once) sch_act_sane_lift)+)[1] - apply (rule corres_trivial, simp add: lookup_failure_map_def) - apply (clarsimp simp: st_tcb_at_tcb_at split: if_split) - apply (fastforce simp: valid_cap_def) - apply (clarsimp simp: valid_cap'_def inQ_def) - apply auto[1] - apply (clarsimp simp: lookup_failure_map_def) - apply wp+ - apply (fastforce elim: st_tcb_at_tcb_at) - apply fastforce - done - -lemma gets_the_noop_corres: - assumes P: "\s. P s \ f s \ None" - shows "corres dc P P' (gets_the f) (return x)" - apply (clarsimp simp: corres_underlying_def gets_the_def - return_def gets_def bind_def get_def) - apply (clarsimp simp: assert_opt_def return_def dest!: P) - done - -lemma handleDoubleFault_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) - \ - (handle_double_fault thread f ft) - (handleDoubleFault thread f' ft')" - apply (rule corres_cross_over_guard[where Q="tcb_at' thread"]) - apply (fastforce intro!: tcb_at_cross) - apply (simp add: handle_double_fault_def handleDoubleFault_def) - apply (rule corres_guard_imp) - apply (subst bind_return [symmetric], - rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_noop2) - apply (simp add: exs_valid_def return_def) - apply (rule hoare_eq_P) - apply wp - apply (rule asUser_inv) - apply (rule getRestartPC_inv) - apply (wp no_fail_getRestartPC)+ - apply (wp|simp)+ - done - -crunch sendFaultIPC - for tcb'[wp]: "tcb_at' t" (wp: crunch_wps) - -crunch receiveIPC - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveIPC_typ_ats[wp] = typ_at_lifts [OF receiveIPC_typ_at'] - -crunch receiveSignal - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveAIPC_typ_ats[wp] = typ_at_lifts [OF receiveSignal_typ_at'] - -declare cart_singleton_empty[simp] - -declare cart_singleton_empty2[simp] - -crunch setupCallerCap - for aligned'[wp]: "pspace_aligned'" - (wp: crunch_wps) -crunch setupCallerCap - for distinct'[wp]: "pspace_distinct'" - (wp: crunch_wps) -crunch setupCallerCap - for cur_tcb[wp]: "cur_tcb'" - (wp: crunch_wps) - -lemma setupCallerCap_state_refs_of[wp]: - "\\s. P ((state_refs_of' s) (sender := {r \ state_refs_of' s sender. snd r = TCBBound}))\ - setupCallerCap sender rcvr grant - \\rv s. P (state_refs_of' s)\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp hoare_drop_imps) - apply (simp add: fun_upd_def cong: if_cong) - done - -crunch setupCallerCap - for sch_act_wf: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps ssa_sch_act sts_sch_act rule: sch_act_wf_lift) - -lemma is_derived_ReplyCap' [simp]: - "\m p g. is_derived' m p (capability.ReplyCap t False g) = - (\c. \ g. c = capability.ReplyCap t True g)" - apply (subst fun_eq_iff) - apply clarsimp - apply (case_tac x, simp_all add: is_derived'_def isCap_simps - badge_derived'_def - vsCapRef_def) - done - -lemma unique_master_reply_cap': - "\c t. isReplyCap c \ capReplyMaster c \ capTCBPtr c = t \ - (\g . c = capability.ReplyCap t True g)" - by (fastforce simp: isCap_simps conj_comms) - -lemma getSlotCap_cte_wp_at: - "\\\ getSlotCap sl \\rv. cte_wp_at' (\c. cteCap c = rv) sl\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -crunch setThreadState - for no_0_obj'[wp]: no_0_obj' - -lemma setupCallerCap_vp[wp]: - "\valid_pspace' and tcb_at' sender and tcb_at' rcvr\ - setupCallerCap sender rcvr grant \\rv. valid_pspace'\" - apply (simp add: valid_pspace'_def setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv getSlotCap_def) - apply (wp getCTE_wp) - apply (rule_tac Q'="\_. valid_pspace' and - tcb_at' sender and tcb_at' rcvr" - in hoare_post_imp) - apply (clarsimp simp: valid_cap'_def o_def cte_wp_at_ctes_of isCap_simps - valid_pspace'_def) - apply (frule(1) ctes_of_valid', simp add: valid_cap'_def capAligned_def) - apply clarsimp - apply (wp | simp add: valid_pspace'_def valid_tcb_state'_def)+ - done - -declare haskell_assert_inv[wp del] - -lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_live_then_nonz_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - -lemma setupCallerCap_ifunsafe[wp]: - "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_unsafe_then_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) - apply (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - apply (rule_tac Q'="\rv. valid_objs' and tcb_at' rcvr and ex_nonz_cap_to' rcvr" - in hoare_post_imp) - apply (clarsimp simp: ex_nonz_tcb_cte_caps' tcbCallerSlot_def - objBits_def objBitsKO_def dom_def cte_level_bits_def) - apply (wp sts_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb_state'_def)+ - done - -lemma setupCallerCap_global_refs'[wp]: - "\valid_global_refs'\ - setupCallerCap sender rcvr grant - \\rv. valid_global_refs'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp - | wp (once) hoare_vcg_imp_lift' hoare_vcg_ex_lift | clarsimp simp: cte_wp_at_ctes_of)+ - -crunch setupCallerCap - for valid_arch'[wp]: "valid_arch_state'" - (wp: hoare_drop_imps) - -crunch setupCallerCap - for typ'[wp]: "\s. P (typ_at' T p s)" - -crunch setupCallerCap - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: hoare_drop_imps) - -lemma setupCallerCap_irq_handlers'[wp]: - "\valid_irq_handlers'\ - setupCallerCap sender rcvr grant - \\rv. valid_irq_handlers'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp hoare_drop_imps | simp)+ - -lemma cteInsert_cap_to': - "\ex_nonz_cap_to' p and cte_wp_at' (\c. cteCap c = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_nonz_cap_to' p\" - supply if_cong[cong] - apply (simp add: cteInsert_def ex_nonz_cap_to'_def updateCap_def setUntypedCapAsFull_def) - apply (wpsimp wp: updateMDB_weak_cte_wp_at setCTE_weak_cte_wp_at hoare_vcg_ex_lift - | rule hoare_drop_imps - | wp getCTE_wp)+ (* getCTE_wp is separate to apply it only to the last one *) - apply (rule_tac x=cref in exI) - apply (fastforce simp: cte_wp_at_ctes_of) - done - -crunch setExtraBadge - for cap_to'[wp]: "ex_nonz_cap_to' p" - -crunch doIPCTransfer - for cap_to'[wp]: "ex_nonz_cap_to' p" - (ignore: transferCapsToSlots - wp: crunch_wps transferCapsToSlots_pres2 cteInsert_cap_to' hoare_vcg_const_Ball_lift - simp: zipWithM_x_mapM ball_conj_distrib) - -lemma st_tcb_idle': - "\valid_idle' s; st_tcb_at' P t s\ \ - (t = ksIdleThread s) \ P IdleThreadState" - by (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) +context Arch begin arch_global_naming -crunch getThreadCallerSlot - for idle'[wp]: "valid_idle'" -crunch getThreadReplySlot - for idle'[wp]: "valid_idle'" - -crunch setupCallerCap - for it[wp]: "\s. P (ksIdleThread s)" - (simp: updateObject_cte_inv wp: crunch_wps) - -lemma setupCallerCap_idle'[wp]: - "\valid_idle' and valid_pspace' and - (\s. st \ ksIdleThread s \ rt \ ksIdleThread s)\ - setupCallerCap st rt gr - \\_. valid_idle'\" - by (simp add: setupCallerCap_def capRange_def | wp hoare_drop_imps)+ - -crunch doIPCTransfer - for idle'[wp]: "valid_idle'" - (wp: crunch_wps simp: crunch_simps ignore: transferCapsToSlots) - -crunch setExtraBadge - for it[wp]: "\s. P (ksIdleThread s)" -crunch receiveIPC - for it[wp]: "\s. P (ksIdleThread s)" - (ignore: transferCapsToSlots - wp: transferCapsToSlots_pres2 crunch_wps hoare_vcg_const_Ball_lift - simp: crunch_simps ball_conj_distrib) - -crunch setupCallerCap - for irq_states'[wp]: valid_irq_states' - (wp: crunch_wps) - -crunch setupCallerCap - for pde_mappings'[wp]: valid_pde_mappings' - (wp: crunch_wps cong: if_cong) - -crunch receiveIPC - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps rule: irqs_masked_lift) - -crunch getThreadCallerSlot - for ct_not_inQ[wp]: "ct_not_inQ" -crunch getThreadReplySlot - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma setupCallerCap_ct_not_inQ[wp]: - "\ct_not_inQ\ setupCallerCap sender receiver grant \\_. ct_not_inQ\" - apply (simp add: setupCallerCap_def) - apply (wp hoare_drop_imp setThreadState_ct_not_inQ) - done - -crunch copyMRs - for ksQ'[wp]: "\s. P (ksReadyQueues s)" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ksQ[wp]: "\s. P (ksReadyQueues s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -crunch doIPCTransfer - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma asUser_ct_not_inQ[wp]: - "\ct_not_inQ\ asUser t m \\rv. ct_not_inQ\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps threadSet_not_inQ | simp)+ - done - -crunch copyMRs - for ct_not_inQ[wp]: "ct_not_inQ" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ct_not_inQ[wp]: "ct_not_inQ" - (ignore: getRestartPC setRegister transferCapsToSlots - wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma ntfn_q_refs_no_bound_refs': "rf : ntfn_q_refs_of' (ntfnObj ob) \ rf ~: ntfn_bound_refs' (ntfnBoundTCB ob')" - by (auto simp add: ntfn_q_refs_of'_def ntfn_bound_refs'_def - split: Structures_H.ntfn.splits) - -lemma completeSignal_invs: - "\invs' and tcb_at' tcb\ - completeSignal ntfnptr tcb - \\_. invs'\" - supply projectKOs[simp] - apply (simp add: completeSignal_def) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule hoare_pre) - apply (wp set_ntfn_minor_invs' | wpc | simp)+ - apply (rule_tac Q'="\_ s. (state_refs_of' s ntfnptr = ntfn_bound_refs' (ntfnBoundTCB ntfn)) - \ ntfn_at' ntfnptr s - \ valid_ntfn' (ntfnObj_update (\_. Structures_H.ntfn.IdleNtfn) ntfn) s - \ ((\y. ntfnBoundTCB ntfn = Some y) \ ex_nonz_cap_to' ntfnptr s) - \ ntfnptr \ ksIdleThread s" - in hoare_strengthen_post) - apply ((wp hoare_vcg_ex_lift hoare_weak_lift_imp | wpc | simp add: valid_ntfn'_def)+)[1] - apply (clarsimp simp: obj_at'_def state_refs_of'_def typ_at'_def ko_wp_at'_def live'_def - split: option.splits) - apply (blast dest: ntfn_q_refs_no_bound_refs') - apply wp - apply (subgoal_tac "valid_ntfn' ntfn s") - apply (subgoal_tac "ntfnptr \ ksIdleThread s") - apply (fastforce simp: valid_ntfn'_def valid_bound_tcb'_def ko_at_state_refs_ofD' live'_def - elim: obj_at'_weakenE - if_live_then_nonz_capD'[OF invs_iflive' - obj_at'_real_def[THEN meta_eq_to_obj_eq, - THEN iffD1]]) - apply (fastforce simp: valid_idle'_def pred_tcb_at'_def obj_at'_def - dest!: invs_valid_idle') - apply (fastforce dest: invs_valid_objs' ko_at_valid_objs' - simp: valid_obj'_def)[1] - done - -lemma setupCallerCap_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' and tcb_at' sender\ - setupCallerCap sender t g \\rv. untyped_ranges_zero'\" - apply (simp add: setupCallerCap_def getSlotCap_def - getThreadCallerSlot_def getThreadReplySlot_def - locateSlot_conv) - apply (wp getCTE_wp') - apply (rule_tac Q'="\_. untyped_ranges_zero' and valid_mdb' and valid_objs'" in hoare_post_imp) - apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def untyped_derived_eq_def - isCap_simps) - apply (wp sts_valid_pspace_hangers) - apply (clarsimp simp: valid_tcb_state'_def) - done - -lemmas threadSet_urz = untyped_ranges_zero_lift[where f="cteCaps_of", OF _ threadSet_cteCaps_of] - -crunch doIPCTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: threadSet wp: threadSet_urz crunch_wps simp: zipWithM_x_mapM) - -crunch receiveIPC - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 simp: zipWithM_x_mapM ignore: constOnFailure) - -crunch possibleSwitchTo - for ctes_of[wp]: "\s. P (ctes_of s)" - (wp: crunch_wps ignore: constOnFailure) -lemmas possibleSwitchToTo_cteCaps_of[wp] - = cteCaps_of_ctes_of_lift[OF possibleSwitchTo_ctes_of] - -crunch asUser - for valid_bitmaps[wp]: valid_bitmaps - (rule: valid_bitmaps_lift wp: crunch_wps) - -crunch setupCallerCap, possibleSwitchTo, doIPCTransfer - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -(* t = ksCurThread s *) -lemma ri_invs' [wp]: - "\invs' and sch_act_not t - and ct_in_state' simple' - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ - receiveIPC t cap isBlocking - \\_. invs'\" (is "\?pre\ _ \_\") - apply (clarsimp simp: receiveIPC_def) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (rule bind_wp [OF _ gbn_sp']) - apply (rule bind_wp) - (* set up precondition for old proof *) - apply (rule_tac P''="ko_at' ep (capEPPtr cap) and ?pre" in hoare_vcg_if_split) - apply (wp completeSignal_invs) - apply (case_tac ep) - \ \endpoint = RecvEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp sts_sch_act' hoare_vcg_const_Ball_lift valid_irq_node_lift valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' o_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_ep'_def - valid_obj'_def projectKOs tcb_bound_refs'_def - dest!: isCapDs) - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD') - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (rename_tac list one two three fur five six seven eight nine ten eleven) - apply (subgoal_tac "set list \ {EPRecv} \ {}") - apply (safe ; solves \auto\) - apply fastforce - apply fastforce - apply (clarsimp split: if_split_asm) - apply (fastforce simp: valid_pspace'_def global'_no_ex_cap idle'_not_queued) - \ \endpoint = IdleEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp sts_sch_act' valid_irq_node_lift valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def o_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "t \ capEPPtr cap") - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule ko_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (clarsimp simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def projectKOs) - \ \endpoint = SendEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rename_tac list) - apply (case_tac list, simp_all split del: if_split) - apply (rename_tac sender queue) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift hoare_drop_imps setEndpoint_valid_mdb' - set_ep_valid_objs' sts_st_tcb' sts_sch_act' valid_dom_schedule'_lift - setThreadState_ct_not_inQ - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - setEndpoint_ksQ - | simp add: valid_tcb_state'_def case_bool_If - case_option_If - split del: if_split cong: if_cong - | wp (once) sch_act_sane_lift hoare_vcg_conj_lift hoare_vcg_all_lift - untyped_ranges_zero_lift)+ - apply (clarsimp split del: if_split simp: pred_tcb_at') - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def - st_tcb_at_refs_of_rev' conj_ac - split del: if_split - cong: if_cong) - apply (subgoal_tac "sch_act_not sender s") - prefer 2 - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (drule st_tcb_at_state_refs_ofD') - apply (simp only: conj_ac(1, 2)[where Q="sym_refs R" for R]) - apply (subgoal_tac "distinct (ksIdleThread s # capEPPtr cap # t # sender # queue)") - apply (rule conjI) - apply (clarsimp simp: ep_redux_simps' cong: if_cong) - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - apply (clarsimp simp: singleton_tuple_cartesian split: list.split - | rule conjI | drule(1) bspec - | drule st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - | clarsimp elim!: if_live_state_refsE)+ - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (clarsimp simp: global'_no_ex_cap) - apply (rule conjI - | clarsimp simp: singleton_tuple_cartesian split: list.split - | clarsimp elim!: if_live_state_refsE - | clarsimp simp: global'_no_ex_cap idle'_not_queued' idle'_no_refs tcb_bound_refs'_def - | drule(1) bspec | drule st_tcb_at_state_refs_ofD' - | clarsimp simp: set_eq_subset dest!: bound_tcb_at_state_refs_ofD' )+ - apply (rule hoare_pre) - apply (wp getNotification_wp | wpc | clarsimp)+ - done - -(* t = ksCurThread s *) -lemma rai_invs'[wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) - and (\s. \ntfnptr. isNotificationCap cap - \ capNtfnPtr cap = ntfnptr - \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) - ntfnptr s)\ - receiveSignal t cap isBlocking - \\_. invs'\" - apply (simp add: receiveSignal_def) - apply (rule bind_wp [OF _ get_ntfn_sp']) - apply (rename_tac ep) - apply (case_tac "ntfnObj ep") - \ \ep = IdleNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "capNtfnPtr cap \ t") - apply (frule valid_pspace_valid_objs') - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD' bound_tcb_at_state_refs_ofD')+ - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - \ \ep = ActiveNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_valid_objs' typ_at_lifts hoare_weak_lift_imp - asUser_urz valid_dom_schedule'_lift - | simp add: valid_ntfn'_def)+ - apply (clarsimp simp: pred_tcb_at' valid_pspace'_def) - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def isCap_simps) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD')+ - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm simp: global'_no_ex_cap)+ - \ \ep = WaitingNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - setThreadState_ct_not_inQ typ_at_lifts valid_dom_schedule'_lift - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: valid_tcb_state'_def) - apply (frule_tac t=t in not_in_ntfnQueue) - apply (simp) - apply (simp) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def) - apply (clarsimp simp: valid_ntfn'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' - dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (rename_tac list one two three four five six seven eight nine) - apply (subgoal_tac "set list \ {NTFNSignal} \ {}") - apply safe[1] - apply (auto simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def)[5] - apply (fastforce simp: tcb_bound_refs'_def - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - done - -lemma getCTE_cap_to_refs[wp]: - "\\\ getCTE p \\rv s. \r\zobj_refs' (cteCap rv). ex_nonz_cap_to' r s\" - apply (rule hoare_strengthen_post [OF getCTE_sp]) - apply (clarsimp simp: ex_nonz_cap_to'_def) - apply (fastforce elim: cte_wp_at_weakenE') - done - -lemma lookupCap_cap_to_refs[wp]: - "\\\ lookupCap t cref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" - apply (simp add: lookupCap_def lookupCapAndSlot_def split_def - getSlotCap_def) - apply (wp | simp)+ - done - -lemma arch_stt_objs' [wp]: - "\valid_objs'\ Arch.switchToThread t \\rv. valid_objs'\" - apply (simp add: ARM_H.switchToThread_def) - apply wp - done - -declare zipWithM_x_mapM [simp] - -lemma cteInsert_invs_bits[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert a b c - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" - "\\s. P (state_refs_of' s)\ - cteInsert a b c - \\rv s. P (state_refs_of' s)\" -apply (wp sch_act_wf_lift valid_queues_lift - cur_tcb_lift tcb_in_cur_domain'_lift)+ -done - -lemma possibleSwitchTo_sch_act_not: - "\sch_act_not t' and K (t \ t')\ possibleSwitchTo t \\rv. sch_act_not t'\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def curDomain_def) - apply (wp hoare_drop_imps | wpc | simp)+ - done - -crunch possibleSwitchTo - for vms'[wp]: valid_machine_state' -crunch possibleSwitchTo - for pspace_domain_valid[wp]: pspace_domain_valid -crunch possibleSwitchTo - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - -crunch possibleSwitchTo - for ct'[wp]: "\s. P (ksCurThread s)" -crunch possibleSwitchTo - for it[wp]: "\s. P (ksIdleThread s)" -crunch possibleSwitchTo - for irqs_masked'[wp]: "irqs_masked'" -crunch possibleSwitchTo - for urz[wp]: "untyped_ranges_zero'" - (simp: crunch_simps unless_def wp: crunch_wps) - -crunch possibleSwitchTo - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - -lemma si_invs'[wp]: - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ - sendIPC bl call ba cg cgr t ep - \\rv. invs'\" - supply if_split[split del] - supply if_cong[cong] - apply (simp add: sendIPC_def split del: if_split) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (case_tac epa) - \ \epa = RecvEP\ - apply simp - apply (rename_tac list) - apply (case_tac list) - apply simp - apply (simp split del: if_split add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (rule_tac P="a\t" in hoare_gen_asm) - apply (wp valid_irq_node_lift - sts_valid_objs' set_ep_valid_objs' setEndpoint_valid_mdb' sts_st_tcb' sts_sch_act' - possibleSwitchTo_sch_act_not setThreadState_ct_not_inQ valid_dom_schedule'_lift - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - hoare_convert_imp [OF doIPCTransfer_sch_act doIPCTransfer_ct'] - hoare_convert_imp [OF setEndpoint_nosch setEndpoint_ksCurThread] - hoare_drop_imp [where f="threadGet tcbFault t"] - | rule_tac f="getThreadState a" in hoare_drop_imp - | wp (once) hoare_drop_imp[where Q'="\_ _. call"] - hoare_drop_imp[where Q'="\_ _. \ call"] - hoare_drop_imp[where Q'="\_ _. cg"] - | simp add: valid_tcb_state'_def case_bool_If - case_option_If - cong: if_cong - split del: if_split - | wp (once) sch_act_sane_lift tcb_in_cur_domain'_lift hoare_vcg_const_imp_lift)+ - apply (clarsimp simp: pred_tcb_at' cong: conj_cong imp_cong - split del: if_split) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def - st_tcb_at_refs_of_rev' pred_tcb_at' - conj_comms fun_upd_def[symmetric] - split del: if_split) - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD' st_tcb_at_state_refs_ofD')+ - apply (clarsimp simp: valid_pspace'_splits) - apply (subst fun_upd_idem[where x=t]) - apply (clarsimp split: if_split) - apply (rule conjI, clarsimp simp: obj_at'_def projectKOs) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def) - apply (subgoal_tac "ex_nonz_cap_to' a s") - prefer 2 - apply (clarsimp elim!: if_live_state_refsE) - apply clarsimp - apply (rule conjI) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp simp: conj_ac) - apply (rule conjI, clarsimp simp: idle'_no_refs) - apply (rule conjI, clarsimp simp: global'_no_ex_cap) - apply (rule conjI) - apply (rule impI) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (clarsimp) - apply (simp add: ep_redux_simps') - apply (rule conjI, clarsimp split: if_split) - apply (rule conjI, fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp, erule delta_sym_refs; - solves\auto simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm\) - apply (solves\clarsimp split: list.splits\) - \ \epa = IdleEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp valid_irq_node_lift valid_dom_schedule'_lift sts_sch_act' setThreadState_ct_not_inQ) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "ep \ t") - apply (drule simple_st_tcb_at_state_refs_ofD' ko_at_state_refs_ofD' - bound_tcb_at_state_refs_ofD')+ - apply (rule conjI, erule delta_sym_refs) - apply (auto simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm)[2] - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply simp - apply wp - apply simp - \ \epa = SendEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ - valid_dom_schedule'_lift) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: valid_obj'_def valid_ep'_def - projectKOs st_tcb_at_refs_of_rev') - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - simp: tcb_bound_refs'_def) - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - subgoal by (fastforce simp: obj_at'_def projectKOs symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap idle'_not_queued) - apply (simp | wp)+ - done - -lemma sfi_invs_plus': - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" - apply (simp add: sendFaultIPC_def) - apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state - threadSet_cap_to' - | wpc | simp)+ - apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s - \ st_tcb_at' simple' t s - \ ex_nonz_cap_to' t s - \ t \ ksIdleThread s - \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" - in hoare_strengthen_postE_R) - apply wp - apply (clarsimp simp: inQ_def pred_tcb_at') - apply (wp | simp)+ - apply (clarsimp simp: eq_commute) - apply (subst(asm) global'_no_ex_cap, auto) - done - -crunch send_fault_ipc - for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" - and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" - (simp: crunch_simps wp: crunch_wps) - -lemma handleFault_corres: - "fr f f' \ - corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread - and (%_. valid_fault f)) - (invs' and sch_act_not thread - and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) - (handle_fault thread f) (handleFault thread f')" - apply (simp add: handle_fault_def handleFault_def) - apply (rule corres_guard_imp) - apply (subst return_bind [symmetric], - rule corres_split[where P="tcb_at thread", - OF gets_the_noop_corres [where x="()"]]) - apply (simp add: tcb_at_def) - apply (rule corres_split_catch) - apply (rule_tac F="valid_fault f" in corres_gen_asm) - apply (rule sendFaultIPC_corres, assumption) - apply simp - apply (rule handleDoubleFault_corres) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def - valid_state_def valid_idle_def) - apply auto - done - -lemma sts_invs_minor'': - "\st_tcb_at' (\st'. tcb_st_refs_of' st' = tcb_st_refs_of' st - \ (st \ Inactive \ \ idle' st \ - st' \ Inactive \ \ idle' st')) t - and (\s. t = ksIdleThread s \ idle' st) - and (\s. \ runnable' st \ sch_act_not t s) - and invs'\ - setThreadState st t - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply clarsimp - apply (rule conjI) - apply fastforce - apply (rule conjI) - apply (clarsimp simp: pred_tcb_at'_def) - apply (drule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def projectKOs) - subgoal by (cases st, auto simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits)[1] - apply (rule conjI) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce elim!: st_tcb_ex_cap'') - done - -lemma hf_invs' [wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ - handleFault t f \\r. invs'\" - apply (simp add: handleFault_def) - apply wp - apply (simp add: handleDoubleFault_def) - apply (wp sts_invs_minor'' dmo_invs')+ - apply (rule hoare_strengthen_postE, rule sfi_invs_plus', - simp_all) - apply (strengthen no_refs_simple_strg') - apply clarsimp - done - -declare zipWithM_x_mapM [simp del] - -lemma gts_st_tcb': - "\\\ getThreadState t \\r. st_tcb_at' (\st. st = r) t\" - apply (rule hoare_strengthen_post) - apply (rule gts_sp') - apply simp - done - -lemma setupCallerCap_pred_tcb_unchanged: - "\pred_tcb_at' proj P t and K (t \ t')\ - setupCallerCap t' t'' g - \\rv. pred_tcb_at' proj P t\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp sts_pred_tcb_neq' hoare_drop_imps) - apply clarsimp - done - -lemma si_blk_makes_simple': - "\st_tcb_at' simple' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' simple' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_drop_imps) - apply (clarsimp simp: pred_tcb_at' del: disjCI) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -lemma si_blk_makes_runnable': - "\st_tcb_at' runnable' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' runnable' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_vcg_const_imp_lift hoare_drop_imps - | simp)+ - apply (clarsimp del: disjCI simp: pred_tcb_at' elim!: pred_tcb'_weakenE) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -crunch possibleSwitchTo, completeSignal - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - -lemma sendSignal_st_tcb'_Running: - "\st_tcb_at' (\st. st = Running \ P st) t\ - sendSignal ntfnptr bdg - \\_. st_tcb_at' (\st. st = Running \ P st) t\" - apply (simp add: sendSignal_def) - apply (wp sts_st_tcb_at'_cases cancelIPC_st_tcb_at' gts_wp' getNotification_wp hoare_weak_lift_imp - | wpc | clarsimp simp: pred_tcb_at')+ - done +lemma is_derived_mask'[simp]: + "is_derived' m p (maskCapRights R c) = is_derived' m p c" + by (rule ext, simp add: is_derived'_def badge_derived'_def) -end +end (* Arch *) end diff --git a/proof/refine/ARM_HYP/ArchIpc_R.thy b/proof/refine/ARM_HYP/ArchIpc_R.thy index b65607a342..706d79aa4d 100644 --- a/proof/refine/ARM_HYP/ArchIpc_R.thy +++ b/proof/refine/ARM_HYP/ArchIpc_R.thy @@ -8,936 +8,97 @@ theory ArchIpc_R imports Ipc_R begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming -lemmas lookup_slot_wrapper_defs'[simp] = - lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def +named_theorems Ipc_R_assms -lemma getMessageInfo_corres: - "corres ((=) \ message_info_map) (tcb_at t and pspace_aligned and pspace_distinct) \ - (get_message_info t) (getMessageInfo t)" - apply (rule corres_guard_imp) +declare word64_minus_one_le[simp] + +lemma getMessageInfo_corres[Ipc_R_assms]: + "corres ((=) \ message_info_map) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_message_info t) (getMessageInfo t)" apply (unfold get_message_info_def getMessageInfo_def fun_app_def) apply (simp add: ARM_HYP_H.msgInfoRegister_def - ARM_HYP.msgInfoRegister_def ARM_HYP_A.msg_info_register_def) - apply (rule corres_split_eqr[OF asUser_getRegister_corres]) + ARM_HYP.msgInfoRegister_def ARM_HYP_A.msg_info_register_def) + apply (corres corres: asUser_getRegister_corres) apply (rule corres_trivial, simp add: message_info_from_data_eqv) - apply (wp | simp)+ - done - - -lemma get_mi_inv'[wp]: "\I\ getMessageInfo a \\x. I\" - by (simp add: getMessageInfo_def, wp) - -definition - "get_send_cap_relation rv rv' \ - (case rv of Some (c, cptr) \ (\c' cptr'. rv' = Some (c', cptr') \ - cte_map cptr = cptr' \ - cap_relation c c') - | None \ rv' = None)" - -lemma cap_relation_mask: - "\ cap_relation c c'; msk' = rights_mask_map msk \ \ - cap_relation (mask_cap msk c) (maskCapRights msk' c')" - by simp - -lemma lsfco_cte_at': - "\valid_objs' and valid_cap' cap\ - lookupSlotForCNodeOp f cap idx depth - \\rv. cte_at' rv\, -" - apply (simp add: lookupSlotForCNodeOp_def) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (wp) - apply (clarsimp simp: split_def unlessE_def - split del: if_split) - apply (wpsimp wp: hoare_drop_imps) - done - -declare unifyFailure_wp [wp] - -(* FIXME: move *) -lemma unifyFailure_wp_E [wp]: - "\P\ f -, \\_. E\ \ \P\ unifyFailure f -, \\_. E\" - unfolding validE_E_def - by (erule unifyFailure_wp)+ - -(* FIXME: move *) -lemma unifyFailure_wp2 [wp]: - assumes x: "\P\ f \\_. Q\" - shows "\P\ unifyFailure f \\_. Q\" - by (wp x, simp) - -definition - ct_relation :: "captransfer \ cap_transfer \ bool" -where - "ct_relation ct ct' \ - ct_receive_root ct = to_bl (ctReceiveRoot ct') - \ ct_receive_index ct = to_bl (ctReceiveIndex ct') - \ ctReceiveDepth ct' = unat (ct_receive_depth ct)" - -(* MOVE *) -lemma valid_ipc_buffer_ptr_aligned_2: - "\valid_ipc_buffer_ptr' a s; is_aligned y 2 \ \ is_aligned (a + y) 2" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (erule (1) aligned_add_aligned) - apply (simp add: msg_align_bits) - done - -(* MOVE *) -lemma valid_ipc_buffer_ptr'D2: - "\valid_ipc_buffer_ptr' a s; y < max_ipc_words * 4; is_aligned y 2\ \ typ_at' UserDataT (a + y && ~~ mask pageBits) s" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (subgoal_tac "(a + y) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (erule order_less_le_trans) - apply (simp add: msg_align_bits max_ipc_words ) - apply simp - done - -lemma loadCapTransfer_corres: - "corres ct_relation \ (valid_ipc_buffer_ptr' buffer) (load_cap_transfer buffer) (loadCapTransfer buffer)" - apply (simp add: load_cap_transfer_def loadCapTransfer_def - captransfer_from_words_def - capTransferDataSize_def capTransferFromWords_def - msgExtraCapBits_def add.commute add.left_commute - msg_max_length_def msg_max_extra_caps_def word_size_def - msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def - wordSize_def wordBits_def word_bits_size word_bits_def[simplified] - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (clarsimp simp: ct_relation_def) - apply (wp no_irq_loadWord)+ - apply simp - apply (simp add: conj_comms word_size_bits_def) - apply safe - apply (erule valid_ipc_buffer_ptr_aligned_2, simp add: is_aligned_def)+ - apply (erule valid_ipc_buffer_ptr'D2, simp add: max_ipc_words, simp add: is_aligned_def)+ - done - -lemma getReceiveSlots_corres: - "corres (\xs ys. ys = map cte_map xs) - (tcb_at receiver and valid_objs and pspace_aligned) - (tcb_at' receiver and valid_objs' and pspace_aligned' and pspace_distinct' and - case_option \ valid_ipc_buffer_ptr' recv_buf) - (get_receive_slots receiver recv_buf) - (getReceiveSlots receiver recv_buf)" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF loadCapTransfer_corres]) - apply (rule corres_empty_on_failure) - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (rule lookup_cap_corres) - apply (simp add: ct_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (simp add: ct_relation_def) - apply (erule lookupSlotForCNodeOp_corres [OF _ refl]) - apply simp - apply (simp add: split_def liftE_bindE unlessE_whenE) - apply (rule corres_split[OF get_cap_corres]) - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap, auto)[1] - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (wp lookup_cap_valid lookup_cap_valid' lsfco_cte_at | simp)+ - done - -lemma get_recv_slot_inv'[wp]: - "\ P \ getReceiveSlots receiver buf \\rv'. P \" - apply (case_tac buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def - split_def unlessE_def) - apply (wp | simp)+ - done - -lemma get_rs_cte_at'[wp]: - "\\\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. cte_wp_at' (\c. cteCap c = capability.NullCap) x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (rule getCTE_wp) - apply (simp add: cte_wp_at_ctes_of cong: conj_cong) - apply wp+ - apply simp - done - -lemma get_rs_real_cte_at'[wp]: - "\valid_objs'\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. real_cte_at' x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (wp hoare_drop_imps)[1] - apply simp - apply (wp lookup_cap_valid')+ - apply simp - done - -declare word_div_1 [simp] -declare word_minus_one_le [simp] -declare word32_minus_one_le [simp] - -lemma loadWordUser_corres': - "\ y < unat max_ipc_words; y' = of_nat y * 4 \ \ - corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + y'))" - apply simp - apply (erule loadWordUser_corres) + apply wpsimp+ done -declare loadWordUser_inv [wp] +lemma max_ipc_size_le_2_msg_align_bits[Ipc_R_assms]: + "max_ipc_words * word_size \ 2 ^ msg_align_bits" + by (simp add: max_ipc_words word_size_def msg_align_bits) -lemma getExtraCptrs_inv[wp]: - "\P\ getExtraCPtrs buf mi \\rv. P\" - apply (cases mi, cases buf, simp_all add: getExtraCPtrs_def) - apply (wp dmo_inv' mapM_wp' loadWord_inv) - done - -lemma getSlotCap_cte_wp_at_rv: - "\cte_wp_at' (\cte. P (cteCap cte) cte) p\ - getSlotCap p - \\rv. cte_wp_at' (P rv) p\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_ctes_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -lemma badge_derived_mask [simp]: - "badge_derived' (maskCapRights R c) c' = badge_derived' c c'" - by (simp add: badge_derived'_def) - -declare derived'_not_Null [simp] - -lemma maskCapRights_vsCapRef[simp]: - "vsCapRef (maskCapRights msk cap) = vsCapRef cap" - unfolding vsCapRef_def - apply (cases cap, simp_all add: maskCapRights_def isCap_simps Let_def) +lemma maskCapRights_vs_cap_ref'[simp]: + "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" + unfolding vs_cap_ref'_def + apply (cases cap, simp_all add: global.maskCapRights_def isCap_simps Let_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; - simp add: maskCapRights_def ARM_HYP_H.maskCapRights_def isCap_simps Let_def) - done - -lemma corres_set_extra_badge: - "b' = b \ - corres dc (in_user_frame buffer) - (valid_ipc_buffer_ptr' buffer and - (\_. msg_max_length + 2 + n < unat max_ipc_words)) - (set_extra_badge buffer b n) (setExtraBadge buffer b' n)" - apply (rule corres_gen_asm2) - apply (drule storeWordUser_corres [where a=buffer and w=b]) - apply (simp add: set_extra_badge_def setExtraBadge_def buffer_cptr_index_def - bufferCPtrOffset_def Let_def) - apply (simp add: word_size_def wordSize_def wordBits_def - bufferCPtrOffset_def buffer_cptr_index_def msgMaxLength_def - msg_max_length_def msgLengthBits_def store_word_offs_def - add.commute add.left_commute wordBits_def - word_bits_size word_bits_def[simplified]) - done - -crunch setExtraBadge - for typ_at': "\s. P (typ_at' T p s)" -lemmas setExtraBadge_typ_ats' [wp] = typ_at_lifts [OF setExtraBadge_typ_at'] -crunch setExtraBadge - for valid_pspace'[wp]: valid_pspace' -crunch setExtraBadge - for cte_wp_at'[wp]: "cte_wp_at' P p" -crunch setExtraBadge - for ipc_buffer'[wp]: "valid_ipc_buffer_ptr' buffer" - -crunch getExtraCPtr - for inv'[wp]: P (wp: dmo_inv' loadWord_inv) - -lemmas unifyFailure_discard2 - = corres_injection[OF id_injection unifyFailure_injection, simplified] - -lemma deriveCap_not_null: - "\\\ deriveCap slot cap \\rv. K (rv \ NullCap \ cap \ NullCap)\,-" - apply (simp add: deriveCap_def split del: if_split) - by (case_tac cap; wpsimp simp: isCap_simps) - -lemma deriveCap_derived_foo: - "\\s. \cap'. (cte_wp_at' (\cte. badge_derived' cap (cteCap cte) - \ capASID cap = capASID (cteCap cte) \ cap_asid_base' cap = cap_asid_base' (cteCap cte) - \ cap_vptr' cap = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s \ cap' \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot cap' \ cteCap) slot s) - \ (cte_wp_at' (untyped_derived_eq cap \ cteCap) slot s - \ cte_wp_at' (untyped_derived_eq cap' \ cteCap) slot s) - \ (s \' cap \ s \' cap') \ (cap' \ NullCap \ cap \ NullCap) \ Q cap' s\ - deriveCap slot cap \Q\,-" - using deriveCap_derived[where slot=slot and c'=cap] deriveCap_valid[where slot=slot and c=cap] - deriveCap_untyped_derived[where slot=slot and c'=cap] deriveCap_not_null[where slot=slot and cap=cap] - apply (clarsimp simp: validE_R_def validE_def valid_def split: sum.split) - apply (frule in_inv_by_hoareD[OF deriveCap_inv]) - apply (clarsimp simp: o_def) - apply (drule spec, erule mp) - apply safe - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) bspec, simp) - done - -lemma valid_mdb_untyped_incD': - "valid_mdb' s \ untyped_inc' (ctes_of s)" - by (simp add: valid_mdb'_def valid_mdb_ctes_def) - -lemma cteInsert_cte_wp_at: - "\\s. cte_wp_at' (\c. is_derived' (ctes_of s) src cap (cteCap c)) src s - \ valid_mdb' s \ valid_objs' s - \ (if p = dest then P cap - else cte_wp_at' (\c. P (maskedAsFull (cteCap c) cap)) p s)\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - apply (simp add: cteInsert_def) - apply (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp hoare_weak_lift_imp - | clarsimp simp: comp_def - | unfold setUntypedCapAsFull_def)+ - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=cte in exI) - apply clarsimp - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=ctea in exI) - apply clarsimp - apply (cases "p=dest") - apply (clarsimp simp: cte_wp_at'_def) - apply (cases "p=src") - apply clarsimp - apply (intro conjI impI) - apply ((clarsimp simp: cte_wp_at'_def maskedAsFull_def split: if_split_asm)+)[2] - apply clarsimp - apply (rule conjI) - apply (clarsimp simp: maskedAsFull_def cte_wp_at_ctes_of split:if_split_asm) - apply (erule disjE) prefer 2 apply simp - apply (clarsimp simp: is_derived'_def isCap_simps) - apply (drule valid_mdb_untyped_incD') - apply (case_tac cte, case_tac cteb, clarsimp) - apply (drule untyped_incD', (simp add: isCap_simps)+) - apply (frule(1) ctes_of_valid'[where p = p]) - apply (clarsimp simp:valid_cap'_def capAligned_def split:if_splits) - apply (drule_tac y ="of_nat fb" in word_plus_mono_right[OF _ is_aligned_no_overflow',rotated]) - apply simp+ - apply (rule word_of_nat_less) - apply simp - apply (simp add:p_assoc_help mask_def) - apply (simp add: max_free_index_def) - apply (clarsimp simp: maskedAsFull_def is_derived'_def badge_derived'_def - isCap_simps capMasterCap_def cte_wp_at_ctes_of - split: if_split_asm capability.splits) - done - -lemma cteInsert_weak_cte_wp_at3: - assumes imp:"\c. P c \ \ isUntypedCap c" - shows " \\s. if p = dest then P cap - else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - by (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp' hoare_weak_lift_imp - | clarsimp simp: comp_def cteInsert_def - | unfold setUntypedCapAsFull_def - | auto simp: cte_wp_at'_def dest!: imp)+ - -lemma maskedAsFull_null_cap[simp]: - "(maskedAsFull x y = capability.NullCap) = (x = capability.NullCap)" - "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" - by (case_tac x, auto simp:maskedAsFull_def isCap_simps) - -lemma maskCapRights_eq_null: - "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = - (xa = capability.NullCap)" - apply (cases xa; simp add: maskCapRights_def isCap_simps) + simp add: ARM_HYP_H.maskCapRights_def isCap_simps Let_def) + done + +lemma is_derived'_Untyped[Ipc_R_assms]: + "\isUntypedCap cap'\ + \ is_derived' m src cap' cap + = (isUntypedCap cap \ badge_derived' cap' cap \ descendants_of' src m = {})" + by (clarsimp simp add: ARM_HYP.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma is_derived'_Reply[Ipc_R_assms]: + "\isReplyCap cap'\ + \ is_derived' m src cap' cap + = (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ capReplyMaster cap \ \ capReplyMaster cap')" + by (clarsimp simp add: ARM_HYP.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma maskCapRights_eq_null[Ipc_R_assms, simp]: + "(RetypeDecls_H.maskCapRights r cap = capability.NullCap) = (cap = capability.NullCap)" + apply (cases cap; simp add: global.maskCapRights_def isCap_simps) apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (simp_all add: ARM_HYP_H.maskCapRights_def isCap_simps) - done - -lemma cte_refs'_maskedAsFull[simp]: - "cte_refs' (maskedAsFull a b) = cte_refs' a" - apply (rule ext)+ - apply (case_tac a) - apply (clarsimp simp:maskedAsFull_def isCap_simps)+ - done - -lemma set_extra_badge_valid_arch_state[wp]: - "set_extra_badge buffer badge n \ valid_arch_state \" - unfolding set_extra_badge_def - by wp - -lemma transferCapsToSlots_corres: - "\ list_all2 (\(cap, slot) (cap', slot'). cap_relation cap cap' - \ slot' = cte_map slot) caps caps'; - mi' = message_info_map mi \ \ - corres ((=) \ message_info_map) - (\s. valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_mdb s - \ valid_list s \ valid_arch_state s - \ (case ep of Some x \ ep_at x s | _ \ True) - \ (\x \ set slots. cte_wp_at (\cap. cap = cap.NullCap) x s \ - real_cte_at x s) - \ (\(cap, slot) \ set caps. valid_cap cap s \ - cte_wp_at (\cp'. (cap \ cap.NullCap \ cp'\cap \ cp' = masked_as_full cap cap )) slot s ) - \ distinct slots - \ in_user_frame buffer s) - (\s. valid_pspace' s - \ (case ep of Some x \ ep_at' x s | _ \ True) - \ (\x \ set (map cte_map slots). - cte_wp_at' (\cte. cteCap cte = NullCap) x s - \ real_cte_at' x s) - \ distinct (map cte_map slots) - \ valid_ipc_buffer_ptr' buffer s - \ (\(cap, slot) \ set caps'. valid_cap' cap s \ - cte_wp_at' (\cte. cap \ NullCap \ cteCap cte \ cap \ cteCap cte = maskedAsFull cap cap) slot s) - \ 2 + msg_max_length + n + length caps' < unat max_ipc_words) - (transfer_caps_loop ep buffer n caps slots mi) - (transferCapsToSlots ep buffer n caps' - (map cte_map slots) mi')" - (is "\ list_all2 ?P caps caps'; ?v \ \ ?corres") -proof (induct caps caps' arbitrary: slots n mi mi' rule: list_all2_induct) - case Nil - show ?case using Nil.prems by (case_tac mi, simp) -next - case (Cons x xs y ys slots n mi mi') - note if_weak_cong[cong] if_cong [cong del] - assume P: "?P x y" - show ?case using Cons.prems P - apply (clarsimp split del: if_split) - apply (simp add: Let_def split_def word_size liftE_bindE - word_bits_conv[symmetric] split del: if_split) - apply (rule corres_const_on_failure) - apply (simp add: dc_def[symmetric] split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_if3) - apply (case_tac "fst x", auto simp add: isCap_simps)[1] - apply (rule corres_split[OF corres_set_extra_badge]) - apply (clarsimp simp: is_cap_simps) - apply (drule conjunct1) - apply simp - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (case_tac mi, simp) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (subgoal_tac "obj_ref_of (fst x) = capEPPtr (fst y)") - prefer 2 - apply (clarsimp simp: is_cap_simps) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (rule_tac P="slots = []" and Q="slots \ []" in corres_disj_division) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (case_tac mi, simp) - apply (simp add: list_case_If2 split del: if_split) - apply (rule corres_splitEE) - apply (rule unifyFailure_discard2) - apply (case_tac mi, clarsimp) - apply (rule deriveCap_corres) - apply (simp add: remove_rights_def) - apply clarsimp - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap', auto)[1] - apply (rule corres_trivial, simp) - apply (case_tac mi, simp) - apply simp - apply (simp add: liftE_bindE) - apply (rule corres_split_nor) - apply (rule cteInsert_corres, simp_all add: hd_map)[1] - apply (simp add: tl_map) - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_vcg_const_Ball_lift cap_insert_derived_valid_arch_state - cap_insert_weak_cte_wp_at) - apply (wp hoare_vcg_const_Ball_lift | simp add:split_def del: imp_disj1)+ - apply (wp cap_insert_cte_wp_at) - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - cteInsert_valid_pspace - | simp add: split_def)+ - apply (wp cteInsert_weak_cte_wp_at hoare_valid_ipc_buffer_ptr_typ_at')+ - apply (wpsimp wp: hoare_vcg_const_Ball_lift cteInsert_cte_wp_at valid_case_option_post_wp - simp: split_def) - apply (unfold whenE_def) - apply wp+ - apply (clarsimp simp: conj_comms ball_conj_distrib split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ cap.NullCap \ - cte_wp_at (is_derived (cdt s) (a, b) cap') (a, b) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule derive_cap_is_derived) - apply (wp derive_cap_is_derived_foo)+ - apply (simp split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ capability.NullCap \ - cte_wp_at' (\c. is_derived' (ctes_of s) (cte_map (a, b)) cap' (cteCap c)) (cte_map (a, b)) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule hoare_strengthen_postE_R[OF deriveCap_derived]) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (wp deriveCap_derived_foo) - apply (clarsimp simp: cte_wp_at_caps_of_state remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI, (clarsimp split del: if_split)+) - apply (clarsimp simp:conj_comms split del:if_split) - apply (intro conjI allI) - apply (clarsimp split:if_splits) - apply (case_tac "cap = fst x",simp+) - apply (clarsimp simp:masked_as_full_def is_cap_simps cap_master_cap_simps) - apply (clarsimp split del: if_split) - apply (intro conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (drule hd_in_set) - apply (drule(1) bspec) - apply (clarsimp split:if_split_asm) - apply (fastforce simp:neq_Nil_conv) - apply (intro ballI conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (intro impI) - apply (drule(1) bspec[OF _ subsetD[rotated]]) - apply (clarsimp simp:neq_Nil_conv) - apply (clarsimp split:if_splits) - apply clarsimp - apply (intro conjI) - apply (drule(1) bspec,clarsimp)+ - subgoal for \ aa _ _ capa - by (case_tac "capa = aa"; clarsimp split:if_splits simp:masked_as_full_def is_cap_simps) - apply (case_tac "isEndpointCap (fst y) \ capEPPtr (fst y) = the ep \ (\y. ep = Some y)") - apply (clarsimp simp:conj_comms split del:if_split) - apply (split if_split) - apply (rule conjI) - apply clarsimp - apply (clarsimp simp:valid_pspace'_def cte_wp_at_ctes_of split del:if_split) - apply (intro conjI) - apply (case_tac "cteCap cte = fst y",clarsimp simp: badge_derived'_def) - apply (clarsimp simp: maskCapRights_eq_null maskedAsFull_def badge_derived'_def isCap_simps - split: if_split_asm) - apply (clarsimp split del: if_split) - apply (case_tac "fst y = capability.NullCap") - apply (clarsimp simp: neq_Nil_conv split del: if_split)+ - apply (intro allI impI conjI) - apply (clarsimp split:if_splits) - apply (clarsimp simp:image_def)+ - apply (thin_tac "\x\set ys. Q x" for Q) - apply (drule(1) bspec)+ - apply clarsimp+ - apply (drule(1) bspec) - apply (rule conjI) - apply clarsimp+ - apply (case_tac "cteCap cteb = ab") - by (clarsimp simp: isCap_simps maskedAsFull_def split:if_splits)+ -qed - -declare constOnFailure_wp [wp] - -lemma transferCapsToSlots_pres1[crunch_rules]: - assumes x: "\cap src dest. \P\ cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\P\ transferCapsToSlots ep buffer n caps slots mi \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong - split del: if_split) - apply (rule hoare_pre) - apply (wp x eb | assumption | simp split del: if_split | wpc - | wp (once) hoare_drop_imps)+ - done - -lemma cteInsert_cte_cap_to': - "\ex_cte_cap_to' p and cte_wp_at' (\cte. cteCap cte = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_cte_cap_to' p\" - apply (simp add: ex_cte_cap_to'_def) - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (rule_tac x = "cref" in exI) - apply (rule conjI) - apply clarsimp+ - done - -declare maskCapRights_eq_null[simp] - -crunch setExtraBadge - for ex_cte_cap_wp_to'[wp]: "ex_cte_cap_wp_to' P p" - (rule: ex_cte_cap_to'_pres) - -crunch setExtraBadge - for valid_objs'[wp]: valid_objs' -crunch setExtraBadge - for aligned'[wp]: pspace_aligned' -crunch setExtraBadge - for distinct'[wp]: pspace_distinct' - -lemma cteInsert_assume_Null: - "\P\ cteInsert cap src dest \Q\ \ - \\s. cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ P s\ - cteInsert cap src dest - \Q\" - apply (rule hoare_name_pre_state) - apply (erule impCE) - apply (simp add: cteInsert_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ getCTE_sp])+ - apply (rule hoare_name_pre_state) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (erule hoare_weaken_pre) - apply simp - done - -crunch setExtraBadge - for mdb'[wp]: valid_mdb' - -lemma cteInsert_weak_cte_wp_at2: - assumes weak:"\c cap. P (maskedAsFull c cap) = P c" - shows - "\\s. if p = dest then P cap else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - supply if_cong[cong] - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of weak) - apply auto - done - -lemma transferCapsToSlots_presM: - assumes x: "\cap src dest. \\s. P s \ (emx \ cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ ex_cte_cap_to' dest s) - \ (vo \ valid_objs' s \ valid_cap' cap s \ real_cte_at' dest s) - \ (drv \ cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s - \ cte_wp_at' (untyped_derived_eq cap o cteCap) src s - \ valid_mdb' s) - \ (pad \ pspace_aligned' s \ pspace_distinct' s)\ - cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\\s. P s - \ (emx \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) \ distinct slots) - \ (vo \ valid_objs' s \ (\x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set caps. s \' fst x ) \ distinct slots) - \ (pad \ pspace_aligned' s \ pspace_distinct' s) - \ (drv \ vo \ pspace_aligned' s \ pspace_distinct' s \ valid_mdb' s - \ length slots \ 1 - \ (\x \ set caps. s \' fst x \ (slots \ [] - \ cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s)))\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply (simp, wp, simp) - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong split del: if_split) - apply (rule hoare_pre) - apply (wp eb hoare_vcg_const_Ball_lift hoare_vcg_const_imp_lift - | assumption | wpc)+ - apply (rule cteInsert_assume_Null) - apply (wp x hoare_vcg_const_Ball_lift cteInsert_cte_cap_to' hoare_weak_lift_imp) - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift hoare_weak_lift_imp)+ - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift cteInsert_cte_wp_at hoare_weak_lift_imp - deriveCap_derived_foo)+ - apply (thin_tac "\slots. PROP P slots" for P) - apply (clarsimp simp: cte_wp_at_ctes_of remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI) - apply (clarsimp simp:cte_wp_at_ctes_of untyped_derived_eq_def) - apply (intro conjI allI) - apply (clarsimp simp:Fun.comp_def cte_wp_at_ctes_of)+ - apply (clarsimp simp:valid_capAligned) - done - -lemmas transferCapsToSlots_pres2 - = transferCapsToSlots_presM[where vo=False and emx=True - and drv=False and pad=False, simplified] - -lemma transferCapsToSlots_aligned'[wp]: - "\pspace_aligned'\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. pspace_aligned'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_distinct'[wp]: - "\pspace_distinct'\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. pspace_distinct'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_typ_at'[wp]: - "\\s. P (typ_at' T p s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (typ_at' T p s)\" - by (wp transferCapsToSlots_pres1 setExtraBadge_typ_at') - -lemma transferCapsToSlots_valid_objs[wp]: - "\valid_objs' and valid_mdb' and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and (\s. \x \ set caps. s \' fst x) and K(distinct slots)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_objs'\" - apply (rule hoare_pre) - apply (rule transferCapsToSlots_presM[where vo=True and emx=False and drv=False and pad=False]) - apply (wp | simp)+ - done - -abbreviation(input) - "transferCaps_srcs caps s \ \x\set caps. cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s" - -lemma transferCapsToSlots_mdb[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_mdb'\" - apply (wpsimp wp: transferCapsToSlots_presM[where drv=True and vo=True and emx=True and pad=True]) - apply (frule valid_capAligned) - apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def badge_derived'_def) - apply wp - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarify) - apply (case_tac cte) - apply (clarsimp dest!:ctes_of_valid_cap' split:if_splits) - apply (fastforce simp:valid_cap'_def) - done - -crunch setExtraBadge - for no_0'[wp]: no_0_obj' - -lemma transferCapsToSlots_no_0_obj' [wp]: - "\no_0_obj'\ transferCapsToSlots ep buffer n caps slots mi \\rv. no_0_obj'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_vp[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_pspace'\" - apply (rule hoare_pre) - apply (simp add: valid_pspace'_def | wp)+ - apply (fastforce simp: cte_wp_at_ctes_of dest: ctes_of_valid') - done - -crunch setExtraBadge, doIPCTransfer - for sch_act [wp]: "\s. P (ksSchedulerAction s)" - (wp: crunch_wps mapME_wp' simp: zipWithM_x_mapM) -crunch setExtraBadge - for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and obj_at'[wp]: "\s. P' (obj_at' P p s)" - and queues [wp]: "\s. P (ksReadyQueues s)" - and queuesL1 [wp]: "\s. P (ksReadyQueuesL1Bitmap s)" - and queuesL2 [wp]: "\s. P (ksReadyQueuesL2Bitmap s)" - -lemma tcts_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) - -crunch setExtraBadge - for state_refs_of'[wp]: "\s. P (state_refs_of' s)" - and state_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" - -lemma tcts_state_refs_of'[wp]: - "\\s. P (state_refs_of' s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (state_refs_of' s)\" - by (wp transferCapsToSlots_pres1) - -lemma tcts_state_hyp_refs_of'[wp]: - "\\s. P (state_hyp_refs_of' s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (state_hyp_refs_of' s)\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for if_live'[wp]: if_live_then_nonz_cap' - -lemma tcts_iflive[wp]: - "\\s. if_live_then_nonz_cap' s \ distinct slots \ - (\x\set slots. - ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. if_live_then_nonz_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch setExtraBadge - for if_unsafe'[wp]: if_unsafe_then_cap' - -lemma tcts_ifunsafe[wp]: - "\\s. if_unsafe_then_cap' s \ distinct slots \ - (\x\set slots. cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s \ - ex_cte_cap_to' x s)\ transferCapsToSlots ep buffer n caps slots mi - \\rv. if_unsafe_then_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch ensureNoChildren - for it[wp]: "\s. P (ksIdleThread s)" - -crunch deriveCap - for idle'[wp]: "valid_idle'" - -crunch setExtraBadge - for valid_idle'[wp]: valid_idle' - -lemma tcts_idle'[wp]: - "\\s. valid_idle' s\ transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_idle'\" - apply (rule hoare_pre) - apply (wp transferCapsToSlots_pres1) - apply simp - done - -lemma tcts_ct[wp]: - "\cur_tcb'\ transferCapsToSlots ep buffer n caps slots mi \\rv. cur_tcb'\" - by (wp transferCapsToSlots_pres1 cur_tcb_lift) - -crunch setExtraBadge - for valid_arch_state'[wp]: valid_arch_state' - -lemma transferCapsToSlots_valid_arch [wp]: - "\valid_arch_state'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_arch_state'\" - by (rule transferCapsToSlots_pres1; wp) - -crunch setExtraBadge - for valid_global_refs'[wp]: valid_global_refs' - -lemma transferCapsToSlots_valid_globals [wp]: - "\valid_global_refs' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' and K (distinct slots) - and K (length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_global_refs'\" - apply (wp transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=True] | clarsimp)+ - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done - -crunch setExtraBadge - for irq_node'[wp]: "\s. P (irq_node' s)" - -lemma transferCapsToSlots_irq_node'[wp]: - "\\s. P (irq_node' s)\ transferCapsToSlots ep buffer n caps slots mi \\rv s. P (irq_node' s)\" - by (wp transferCapsToSlots_pres1) - -lemma valid_irq_handlers_ctes_ofD: - "\ ctes_of s p = Some cte; cteCap cte = IRQHandlerCap irq; valid_irq_handlers' s \ - \ irq_issued' irq s" - by (auto simp: valid_irq_handlers'_def cteCaps_of_def ran_def) - -crunch setExtraBadge - for valid_irq_handlers'[wp]: valid_irq_handlers' - -lemma transferCapsToSlots_irq_handlers[wp]: - "\valid_irq_handlers' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' - and K(distinct slots \ length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_irq_handlers'\" - apply (wpsimp wp: transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=False]) - apply (clarsimp simp: is_derived'_def cte_wp_at_ctes_of badge_derived'_def) - apply (erule(2) valid_irq_handlers_ctes_ofD) - apply wp - apply (clarsimp simp:cte_wp_at_ctes_of | intro ballI conjI)+ - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) + apply (case_tac arch_capability; simp add: ARM_HYP_H.maskCapRights_def isCap_simps) done -crunch setExtraBadge - for irq_state'[wp]: "\s. P (ksInterruptState s)" +lemma capASID_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ capASID cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemma setExtraBadge_irq_states'[wp]: - "\valid_irq_states'\ setExtraBadge buffer b n \\_. valid_irq_states'\" - apply (wp valid_irq_states_lift') - apply (simp add: setExtraBadge_def storeWordUser_def) - apply (wpsimp wp: no_irq dmo_lift' no_irq_storeWord) - apply assumption - done +lemma cap_asid_base'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_asid_base' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemma transferCapsToSlots_irq_states' [wp]: - "\valid_irq_states'\ transferCapsToSlots ep buffer n caps slots mi \\_. valid_irq_states'\" - by (wp transferCapsToSlots_pres1) +lemma cap_vptr'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_vptr' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -crunch setExtraBadge - for valid_pde_mappings'[wp]: valid_pde_mappings' +lemmas transferCapsToSlots_pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="transferCapsToSlots _ _ _ _ _ _"] -lemma transferCapsToSlots_pde_mappings'[wp]: - "\valid_pde_mappings'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_pde_mappings'\" - by (wp transferCapsToSlots_pres1) +crunch makeArchFaultMessage + for sch_act[Ipc_R_assms, wp]: "\s. P (ksSchedulerAction s)" -lemma transferCapsToSlots_irqs_masked'[wp]: - "\irqs_masked'\ transferCapsToSlots ep buffer n caps slots mi \\rv. irqs_masked'\" - by (wp transferCapsToSlots_pres1 irqs_masked_lift) +lemma is_derived'_IRQHandlerCap[Ipc_R_assms]: + "\isIRQHandlerCap cap'\ \ is_derived' (ctes_of (s::kernel_state)) src cap' cap = + (isIRQHandlerCap cap \ badge_derived' cap' cap)" + by (clarsimp simp add: ARM_HYP.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) -lemma storeWordUser_vms'[wp]: - "\valid_machine_state'\ storeWordUser a w \\_. valid_machine_state'\" +lemma storeWordUser_vms'[Ipc_R_assms, wp]: + "storeWordUser a w \valid_machine_state'\" proof - have aligned_offset_ignore: - "\(l::word32) (p::word32) sz. l<4 \ p && mask 2 = 0 \ + "\(l::machine_word) (p::machine_word) sz. l<8 \ p && mask 3 = 0 \ p+l && ~~ mask pageBits = p && ~~ mask pageBits" proof - fix l p sz - assume al: "(p::word32) && mask 2 = 0" - assume "(l::word32) < 4" hence less: "l<2^2" by simp - have le: "2 \ pageBits" by (simp add: pageBits_def) + assume al: "(p::machine_word) && mask 3 = 0" + assume "(l::machine_word) < 8" hence less: "l<2^3" by simp + have le: "3 \ pageBits" by (simp add: pageBits_def) show "?thesis l p sz" by (rule is_aligned_add_helper[simplified is_aligned_mask, THEN conjunct2, THEN mask_out_first_mask_some, - where n=2, OF al less le]) + where n=3, OF al less le]) qed show ?thesis @@ -953,648 +114,70 @@ proof - apply (erule disjE, simp) apply (simp add: pointerInUserData_def word_size) apply (subgoal_tac "a && ~~ mask pageBits = p && ~~ mask pageBits", simp) - apply (simp only: is_aligned_mask[of _ 2]) + apply (simp only: is_aligned_mask[of _ 3]) apply (elim disjE, simp_all) apply (rule aligned_offset_ignore[symmetric], simp+)+ done qed -lemma setExtraBadge_vms'[wp]: - "\valid_machine_state'\ setExtraBadge buffer b n \\_. valid_machine_state'\" -by (simp add: setExtraBadge_def) wp - -lemma transferCapsToSlots_vms[wp]: - "\\s. valid_machine_state' s\ - transferCapsToSlots ep buffer n caps slots mi - \\_ s. valid_machine_state' s\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge, transferCapsToSlots - for pspace_domain_valid[wp]: "pspace_domain_valid" - -crunch setExtraBadge - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma tcts_ct_not_inQ[wp]: - "\ct_not_inQ\ - transferCapsToSlots ep buffer n caps slots mi - \\_. ct_not_inQ\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" -crunch setExtraBadge - for ctes_of[wp]: "\s. P (ctes_of s)" - -lemma tcts_zero_ranges[wp]: - "\\s. untyped_ranges_zero' s \ valid_pspace' s \ distinct slots - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. untyped_ranges_zero'\" - apply (wpsimp wp: transferCapsToSlots_presM[where emx=True and vo=True - and drv=True and pad=True]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: cteCaps_of_def) - apply (rule hoare_pre, wp untyped_ranges_zero_lift) - apply (simp add: o_def) - apply (clarsimp simp: valid_pspace'_def ball_conj_distrib[symmetric]) - apply (drule(1) bspec) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (case_tac cte, clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply auto[1] - done - -crunch transferCapsToSlots, setExtraBadge - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - -crunch transferCapsToSlots - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift) - -lemma transferCapsToSlots_invs[wp]: - "\\s. invs' s \ distinct slots - \ (\x \ set slots. cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set slots. ex_cte_cap_to' x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (wp valid_irq_node_lift valid_dom_schedule'_lift) - apply fastforce - done - -lemma grs_distinct'[wp]: - "\\\ getReceiveSlots t buf \\rv s. distinct rv\" - apply (cases buf, simp_all add: getReceiveSlots_def - split_def unlessE_def) - apply (wp, simp) - apply (wp | simp only: distinct.simps list.simps empty_iff)+ - apply simp - done - -lemma transferCaps_corres: - "\ info' = message_info_map info; - list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x)) - caps caps' \ - \ - corres ((=) \ message_info_map) - (tcb_at receiver and valid_objs and - pspace_aligned and pspace_distinct and valid_mdb - and valid_list and valid_arch_state - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame recv_buf - and (\s. valid_message_info info) - and transfer_caps_srcs caps) - (tcb_at' receiver and valid_objs' and - pspace_aligned' and pspace_distinct' and no_0_obj' and valid_mdb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' recv_buf - and transferCaps_srcs caps' - and (\s. length caps' \ msgMaxExtraCaps)) - (transfer_caps info caps ep receiver recv_buf) - (transferCaps info' caps' ep receiver recv_buf)" - apply (simp add: transfer_caps_def transferCaps_def - getThreadCSpaceRoot) - apply (rule corres_assume_pre) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getReceiveSlots_corres]) - apply (rule_tac x=recv_buf in option_corres) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (case_tac info, simp) - apply simp - apply (rule corres_rel_imp, rule transferCapsToSlots_corres, - simp_all add: split_def)[1] - apply (case_tac info, simp) - apply (wp hoare_vcg_all_lift get_rs_cte_at hoare_weak_lift_imp - | simp only: ball_conj_distrib)+ - apply (simp add: cte_map_def tcb_cnode_index_def split_def) - apply (clarsimp simp: valid_pspace'_def valid_ipc_buffer_ptr'_def2 - split_def - cong: option.case_cong) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_caps_of_state) - apply (frule(1) Invariants_AI.caps_of_state_valid) - apply (fastforce simp:valid_cap_def) - apply (cases info) - apply (clarsimp simp: msg_max_extra_caps_def valid_message_info_def - max_ipc_words msg_max_length_def - msgMaxExtraCaps_def msgExtraCapBits_def - shiftL_nat valid_pspace'_def) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (case_tac cte,clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done - -crunch transferCaps - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas transferCaps_typ_ats[wp] = typ_at_lifts [OF transferCaps_typ_at'] - -lemma isIRQControlCap_mask [simp]: - "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" - apply (case_tac c) - apply (clarsimp simp: isCap_simps maskCapRights_def Let_def)+ - apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (clarsimp simp: isCap_simps ARM_HYP_H.maskCapRights_def - maskCapRights_def Let_def)+ - done +lemma isArchObjectCap_maskCapRights[Ipc_R_assms]: + "isArchObjectCap (Arch.maskCapRights R acap)" + by (cases acap; simp add: ARM_HYP_H.maskCapRights_def isCap_simps) -lemma isPageCap_maskCapRights[simp]: -" isArchCap isPageCap (RetypeDecls_H.maskCapRights R c) = isArchCap isPageCap c" - apply (case_tac c; simp add: isCap_simps isArchCap_def maskCapRights_def) +lemma isFrameCap_maskCapRights[simp]: + "isArchCap isFrameCap (global.maskCapRights R c) = isArchCap isFrameCap c" + apply (case_tac c; simp add: gen_isCap_simps isArchCap_def global.maskCapRights_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: isCap_simps ARM_HYP_H.maskCapRights_def) done -lemma capReplyMaster_mask[simp]: - "isReplyCap c \ capReplyMaster (maskCapRights R c) = capReplyMaster c" - by (clarsimp simp: isCap_simps maskCapRights_def) +lemma arch_updateCapData_ordering[Ipc_R_assms]: + "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ + \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" + by (cases acap; simp add: ARM_HYP_H.updateCapData_def) + fastforce -lemma is_derived_mask' [simp]: - "is_derived' m p (maskCapRights R c) = is_derived' m p c" - apply (rule ext) - apply (simp add: is_derived'_def badge_derived'_def) - done - -lemma updateCapData_ordering: - "\ (x, capBadge cap) \ capBadge_ordering P; updateCapData p d cap \ NullCap \ - \ (x, capBadge (updateCapData p d cap)) \ capBadge_ordering P" - apply (cases cap, simp_all add: updateCapData_def isCap_simps Let_def - capBadge_def ARM_HYP_H.updateCapData_def - split: if_split_asm) - apply fastforce+ - done - -lemma updateCapData_capReplyMaster: - "isReplyCap cap \ capReplyMaster (updateCapData p d cap) = capReplyMaster cap" - by (clarsimp simp: isCap_simps updateCapData_def split del: if_split) - -lemma updateCapData_is_Reply[simp]: - "(updateCapData p d cap = ReplyCap x y z) = (cap = ReplyCap x y z)" - by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def - ARM_HYP_H.updateCapData_def - split del: if_split - split: if_split_asm) +lemma ArchUpdateCapData_noReply[Ipc_R_assms]: + "Arch.updateCapData p d acap \ capability.ReplyCap x y z" + by (cases acap; simp add: ARM_HYP_H.updateCapData_def) -lemma updateCapDataIRQ: - "updateCapData p d cap \ NullCap \ - isIRQControlCap (updateCapData p d cap) = isIRQControlCap cap" - apply (cases cap, simp_all add: updateCapData_def isCap_simps Let_def - ARM_HYP_H.updateCapData_def - split: if_split_asm) - done +lemma ArchUpdateCapData_noIRQControl[Ipc_R_assms]: + "Arch.updateCapData p d acap \ IRQControlCap" + by (cases acap; simp add: ARM_HYP_H.updateCapData_def) -lemma updateCapData_vsCapRef[simp]: - "vsCapRef (updateCapData pr D c) = vsCapRef c" +lemma updateCapData_vs_cap_ref'[simp]: + "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def + clarsimp simp: isCap_simps global.updateCapData_def Let_def ARM_HYP_H.updateCapData_def - vsCapRef_def + vs_cap_ref'_def split del: if_split - split: if_split_asm) + split: if_split_asm arch_capability.splits) -lemma isPageCap_updateCapData[simp]: -"isArchCap isPageCap (updateCapData pr D c) = isArchCap isPageCap c" - apply (case_tac c; simp add:updateCapData_def isCap_simps isArchCap_def) +lemma isFrameCap_updateCapData[simp]: + "isArchCap isFrameCap (updateCapData pr D c) = isArchCap isFrameCap c" + apply (case_tac c; simp add: global.updateCapData_def isCap_simps isArchCap_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: ARM_HYP_H.updateCapData_def isCap_simps isArchCap_def) apply (clarsimp split:capability.splits simp:Let_def) done -lemma lookup_cap_to'[wp]: - "\\\ lookupCap t cref \\rv s. \r\cte_refs' rv (irq_node' s). ex_cte_cap_to' r s\,-" - by (simp add: lookupCap_def lookupCapAndSlot_def | wp)+ - -lemma grs_cap_to'[wp]: - "\\\ getReceiveSlots t buf \\rv s. \x \ set rv. ex_cte_cap_to' x s\" - apply (cases buf; simp add: getReceiveSlots_def split_def unlessE_def) - apply (wp, simp) - apply (wp | simp | rule hoare_drop_imps)+ - done - -lemma grs_length'[wp]: - "\\s. 1 \ n\ getReceiveSlots receiver recv_buf \\rv s. length rv \ n\" - apply (simp add: getReceiveSlots_def split_def unlessE_def) - apply (rule hoare_pre) - apply (wp | wpc | simp)+ - done - -lemma transferCaps_invs' [wp]: - "\invs' and transferCaps_srcs caps\ - transferCaps mi caps ep receiver recv_buf - \\rv. invs'\" - apply (simp add: transferCaps_def Let_def split_def) - apply (wp get_rs_cte_at' hoare_vcg_const_Ball_lift - | wpcw | clarsimp)+ - done - -lemma get_mrs_inv'[wp]: - "\P\ getMRs t buf info \\rv. P\" - by (simp add: getMRs_def load_word_offs_def getRegister_def - | wp dmo_inv' loadWord_inv mapM_wp' - asUser_inv det_mapM[where S=UNIV] | wpc)+ - - -lemma copyMRs_typ_at': - "\\s. P (typ_at' T p s)\ copyMRs s sb r rb n \\rv s. P (typ_at' T p s)\" - by (simp add: copyMRs_def | wp mapM_wp [where S=UNIV, simplified] | wpc)+ - -lemmas copyMRs_typ_at_lifts[wp] = typ_at_lifts [OF copyMRs_typ_at'] - -lemma copy_mrs_invs'[wp]: - "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" - including classic_wp_pre - apply (simp add: copyMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord| - simp add: split_def) - apply (case_tac sb, simp_all)[1] - apply wp+ - apply (case_tac rb, simp_all)[1] - apply (wp mapM_wp dmo_invs' no_irq_mapM no_irq_storeWord no_irq_loadWord) - apply blast - apply (rule hoare_strengthen_post) - apply (rule mapM_wp) - apply (wp | simp | blast)+ - done - -crunch transferCaps - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: zipWithM_x_mapM) -crunch transferCaps - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: zipWithM_x_mapM) - -crunch setMRs - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch setMRs - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) -crunch setMessageInfo - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch setMessageInfo - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) - -crunch storeWordUser - for valid_objs'[wp]: valid_objs' -crunch storeWordUser - for valid_pspace'[wp]: valid_pspace' - -lemma set_mrs_valid_objs' [wp]: - "\valid_objs'\ setMRs t a msgs \\rv. valid_objs'\" - apply (simp add: setMRs_def zipWithM_x_mapM split_def) - apply (wp asUser_valid_objs crunch_wps) - done - -crunch copyMRs - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps simp: crunch_simps) - -lemma setMRs_invs_bits[wp]: - "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\\s. P (state_refs_of' s)\ - setMRs t buf mrs - \\rv s. P (state_refs_of' s)\" - "\\s. P (state_hyp_refs_of' s)\ - setMRs t buf mrs - \\rv s. P (state_hyp_refs_of' s)\" - "\if_live_then_nonz_cap'\ setMRs t buf mrs \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ setMRs t buf mrs \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ setMRs t buf mrs \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ setMRs t buf mrs \\rv. if_unsafe_then_cap'\" - by (simp add: setMRs_def zipWithM_x_mapM split_def storeWordUser_def | wp crunch_wps)+ - -crunch setMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma copyMRs_invs_bits[wp]: - "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. P (state_refs_of' s)\ - copyMRs s sb r rb n - \\rv s. P (state_refs_of' s)\" - "\\s. P (state_hyp_refs_of' s)\ - copyMRs s sb r rb n - \\rv s. P (state_hyp_refs_of' s)\" - "\if_live_then_nonz_cap'\ copyMRs s sb r rb n \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ copyMRs s sb r rb n \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ copyMRs s sb r rb n \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ copyMRs s sb r rb n \\rv. if_unsafe_then_cap'\" - by (simp add: copyMRs_def storeWordUser_def | wp mapM_wp' | wpc)+ - -crunch copyMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma mi_map_length[simp]: "msgLength (message_info_map mi) = mi_length mi" - by (cases mi, simp) - -crunch copyMRs - for cte_wp_at'[wp]: "cte_wp_at' P p" - (wp: crunch_wps) - -lemma lookupExtraCaps_srcs[wp]: - "\\\ lookupExtraCaps thread buf info \transferCaps_srcs\,-" - apply (simp add: lookupExtraCaps_def lookupCapAndSlot_def - split_def lookupSlotForThread_def - getSlotCap_def) - apply (wp mapME_set[where R=\] getCTE_wp') - apply (rule_tac P=\ in hoare_trivE_R) - apply (simp add: cte_wp_at_ctes_of) - apply (wp | simp)+ - done - -crunch lookupExtraCaps - for inv[wp]: "P" - (wp: crunch_wps mapME_wp' simp: crunch_simps) - -lemma invs_mdb_strengthen': - "invs' s \ valid_mdb' s" by auto - -lemma lookupExtraCaps_length: - "\\s. unat (msgExtraCaps mi) \ n\ lookupExtraCaps thread send_buf mi \\rv s. length rv \ n\,-" - apply (simp add: lookupExtraCaps_def getExtraCPtrs_def) - apply (rule hoare_pre) - apply (wp mapME_length | wpc)+ - apply (clarsimp simp: upto_enum_step_def Suc_unat_diff_1 word_le_sub1) - done - -lemma getMessageInfo_msgExtraCaps[wp]: - "\\\ getMessageInfo t \\rv s. unat (msgExtraCaps rv) \ msgMaxExtraCaps\" - apply (simp add: getMessageInfo_def) - apply wp - apply (simp add: messageInfoFromWord_def Let_def msgMaxExtraCaps_def - shiftL_nat) - apply (subst nat_le_Suc_less_imp) - apply (rule unat_less_power) - apply (simp add: word_bits_def msgExtraCapBits_def) - apply (rule and_mask_less'[unfolded mask_2pm1]) - apply (simp add: msgExtraCapBits_def) - apply wpsimp+ - done - -lemma lookupCapAndSlot_corres: - "cptr = to_bl cptr' \ - corres (lfr \ (\a b. cap_relation (fst a) (fst b) \ snd b = cte_map (snd a))) - (valid_objs and pspace_aligned and tcb_at thread) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread) - (lookup_cap_and_slot thread cptr) (lookupCapAndSlot thread cptr')" - unfolding lookup_cap_and_slot_def lookupCapAndSlot_def - apply (simp add: liftE_bindE split_def) - apply (rule corres_guard_imp) - apply (rule_tac r'="\rv rv'. rv' = cte_map (fst rv)" - in corres_splitEE) - apply (rule corres_rel_imp, rule lookupSlotForThread_corres) - apply (simp add: split_def) - apply (rule corres_split[OF getSlotCap_corres]) - apply simp - apply (rule corres_returnOkTT, simp) - apply wp+ - apply (wp | simp add: liftE_bindE[symmetric])+ - done - -lemma lookupExtraCaps_corres: - "\ info' = message_info_map info; buffer = buffer'\ \ - corres (fr \ list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))) - (valid_objs and pspace_aligned and tcb_at thread and (\_. valid_message_info info)) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer') - (lookup_extra_caps thread buffer info) (lookupExtraCaps thread buffer' info')" - unfolding lookupExtraCaps_def lookup_extra_caps_def - apply (rule corres_gen_asm) - apply (cases "mi_extra_caps info = 0") - apply (cases info) - apply (simp add: Let_def returnOk_def getExtraCPtrs_def - liftE_bindE upto_enum_step_def mapM_def - sequence_def doMachineOp_return mapME_Nil - split: option.split) - apply (cases info) - apply (rename_tac w1 w2 w3 w4) - apply (simp add: Let_def liftE_bindE) - apply (cases buffer') - apply (simp add: getExtraCPtrs_def mapME_Nil) - apply (rule corres_returnOk) - apply simp - apply (simp add: msgLengthBits_def msgMaxLength_def field_simps - getExtraCPtrs_def upto_enum_step_def upto_enum_word - word_size_def msg_max_length_def liftM_def - Suc_unat_diff_1 word_le_sub1 mapM_map_simp - upt_lhs_sub_map[where x=buffer_cptr_index] - wordSize_def wordBits_def - word_bits_size word_bits_def[simplified] - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_underlying_split) - - apply (rule_tac S = "\x y. x = y \ x < unat w2" - in corres_mapM_list_all2 - [where Q = "\_. valid_objs and pspace_aligned and tcb_at thread" and r = "(=)" - and Q' = "\_. valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer'" and r'="(=)" ]) - apply simp - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule loadWordUser_corres') - apply (clarsimp simp: buffer_cptr_index_def msg_max_length_def - max_ipc_words valid_message_info_def - msg_max_extra_caps_def word_le_nat_alt) - apply (simp add: buffer_cptr_index_def msg_max_length_def) - apply simp - apply simp - apply (simp add: load_word_offs_word_def) - apply (wp | simp)+ - apply (subst list_all2_same) - apply (clarsimp simp: max_ipc_words field_simps) - apply (simp add: mapME_def, fold mapME_def)[1] - apply (rule corres_mapME [where S = Id and r'="(\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))"]) - apply simp - apply simp - apply simp - apply (rule corres_cap_fault [OF lookupCapAndSlot_corres]) - apply simp - apply simp - apply (wp | simp)+ - apply (simp add: set_zip_same Int_lower1) - apply (wp mapM_wp [OF _ subset_refl] | simp)+ - done - -crunch copyMRs - for ctes_of[wp]: "\s. P (ctes_of s)" - (ignore: threadSet - wp: threadSet_ctes_of crunch_wps) - -lemma copyMRs_valid_mdb[wp]: - "\valid_mdb'\ copyMRs t buf t' buf' n \\rv. valid_mdb'\" - by (simp add: valid_mdb'_def copyMRs_ctes_of) - -crunch copy_mrs - for valid_arch_state[wp]: valid_arch_state - (wp: crunch_wps) - -lemma doNormalTransfer_corres: - "corres dc - (tcb_at sender and tcb_at receiver and (pspace_aligned:: det_state \ bool) - and valid_objs and cur_tcb and valid_mdb and valid_list and valid_arch_state and pspace_distinct - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame send_buf - and case_option \ in_user_frame recv_buf) - (tcb_at' sender and tcb_at' receiver and valid_objs' - and pspace_aligned' and pspace_distinct' and cur_tcb' - and valid_mdb' and no_0_obj' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' send_buf - and case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_normal_transfer sender send_buf ep badge can_grant receiver recv_buf) - (doNormalTransfer sender send_buf ep badge can_grant receiver recv_buf)" - supply if_cong[cong] - apply (simp add: do_normal_transfer_def doNormalTransfer_def) - apply (rule corres_guard_imp) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule_tac F="valid_message_info mi" in corres_gen_asm) - apply (rule_tac r'="list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))" - in corres_split) - apply (rule corres_if[OF refl]) - apply (rule corres_split_catch) - apply (rule lookupExtraCaps_corres; simp) - apply (rule corres_trivial, simp) - apply wp+ - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_split_eqr[OF copyMRs_corres]) - apply (rule corres_split) - apply (rule transferCaps_corres; simp) - apply (rename_tac mi' mi'') - apply (rule_tac F="mi_label mi' = mi_label mi" - in corres_gen_asm) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply (case_tac mi', clarsimp) - apply (simp add: badge_register_def badgeRegister_def) - apply (fold dc_def) - apply (rule asUser_setRegister_corres) - apply wp - apply simp+ - apply ((wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_case_option_wp - hoare_valid_ipc_buffer_ptr_typ_at' copyMRs_typ_at' - hoare_vcg_const_Ball_lift lookupExtraCaps_length - | simp add: if_apply_def2)+) - apply (wp hoare_weak_lift_imp | strengthen valid_msg_length_strengthen)+ - apply clarsimp - apply auto - done - -lemma corres_liftE_lift: - "corres r1 P P' m m' \ - corres (f1 \ r1) P P' (liftE m) (withoutFailure m')" - by simp +lemma get_mrs_inv'[Ipc_R_assms, wp]: + "getMRs t buf info \P\" + by (wpsimp wp: dmo_inv' loadWord_inv mapM_wp' asUser_inv det_mapM[where S=UNIV] + simp: getMRs_def load_word_offs_def getRegister_def) -lemmas corres_ipc_thread_helper = - corres_split_eqrE[OF corres_liftE_lift [OF getCurThread_corres]] +lemma badgeRegister_badge_register[Ipc_R_assms]: + "badgeRegister = badge_register" + by (simp add: badge_register_def badgeRegister_def) -lemmas corres_ipc_info_helper = - corres_split_maprE [where f = message_info_map, OF _ - corres_liftE_lift [OF getMessageInfo_corres]] +lemmas copyMRs__pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="copyMRs _ _ _ _ _"] -crunch doNormalTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas doNormal_lifts[wp] = typ_at_lifts [OF doNormalTransfer_typ_at'] - -lemma doNormal_invs'[wp]: - "\tcb_at' sender and tcb_at' receiver and invs'\ - doNormalTransfer sender send_buf ep badge - can_grant receiver recv_buf \\r. invs'\" - apply (simp add: doNormalTransfer_def) - apply (wp hoare_vcg_const_Ball_lift | simp)+ - done - -crunch doNormalTransfer - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps) -crunch doNormalTransfer - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps) - -lemma transferCaps_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' - and (\s. (\x\set caps. cte_wp_at' (\cte. fst x \ capability.NullCap \ cteCap cte = fst x) (snd x) s))\ - transferCaps tag caps ep receiver recv_buf - \\r. untyped_ranges_zero'\" - apply (simp add: transferCaps_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift hoare_vcg_const_imp_lift - | wpc - | simp add: ball_conj_distrib)+ - apply clarsimp - done - -crunch doNormalTransfer - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 ignore: constOnFailure) - -lemmas asUser_urz = untyped_ranges_zero_lift[OF asUser_gsUntypedZeroRanges] - -crunch doNormalTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: asUser wp: crunch_wps asUser_urz hoare_vcg_const_Ball_lift) - -lemma msgFromLookupFailure_map[simp]: - "msgFromLookupFailure (lookup_failure_map lf) - = msg_from_lookup_failure lf" - by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) - -lemma asUser_getRestartPC_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t getRestartPC) (asUser t getRestartPC)" - apply (rule asUser_corres') - apply (rule corres_Id, simp, simp) - apply (rule no_fail_getRestartPC) - done - -lemma asUser_mapM_getRegister_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t (mapM getRegister regs)) - (asUser t (mapM getRegister regs))" - apply (rule asUser_corres') - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_mapM) - apply (simp add: getRegister_def) - done - -lemma makeArchFaultMessage_corres: +lemma makeArchFaultMessage_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_arch_fault_msg f t) (makeArchFaultMessage (arch_fault_map f) t)" + (make_arch_fault_msg f t) + (makeArchFaultMessage (arch_fault_map f) t)" apply (cases f; clarsimp simp: makeArchFaultMessage_def ucast_nat_def split: arch_fault.split) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) @@ -1602,134 +185,23 @@ lemma makeArchFaultMessage_corres: apply (wp+, auto) done -lemma makeFaultMessage_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_fault_msg ft t) - (makeFaultMessage (fault_map ft) t)" - apply (cases ft, simp_all add: makeFaultMessage_def split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_trivial, simp add: fromEnum_def enum_bool) - apply (wp | simp)+ - apply (simp add: ARM_HYP_H.syscallMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (simp add: ARM_HYP_H.exceptionMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (rule makeArchFaultMessage_corres) - done - -lemma dmo_addressTranslateS1_invs'[wp]: - "doMachineOp (addressTranslateS1 pc) \invs'\" - apply (wp dmo_invs' no_irq_addressTranslateS1 no_irq) - apply clarsimp - apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" - in use_valid) - apply (clarsimp simp: addressTranslateS1_def machine_op_lift_def - machine_rest_lift_def split_def | wp)+ - done - -lemma dmo_addressTranslateS1_valid_ipc_buffer_ptr'[wp]: - "doMachineOp (addressTranslateS1 pc) \valid_ipc_buffer_ptr' p\" - by (wpsimp wp: hoare_valid_ipc_buffer_ptr_typ_at') - -crunch makeArchFaultMessage - for inv[wp]: invs' - (wp: mapM_wp' det_getRestartPC getRestartPC_inv ignore: doMachineOp) - -lemma makeFaultMessage_inv[wp]: - "\invs'\ makeFaultMessage ft t \\rv. invs'\" - apply (cases ft, simp_all add: makeFaultMessage_def) - apply (wpsimp wp: asUser_inv mapM_wp' det_mapM[where S=UNIV] - det_getRestartPC getRestartPC_inv - simp: getRegister_def makeArchFaultMessage_def)+ - done - -lemma makeFaultMessage_tcb_at'[wp]: - "makeFaultMessage ft t \tcb_at' p\" - apply (cases ft, simp_all add: makeFaultMessage_def) - apply (wpsimp wp: asUser_inv mapM_wp' det_mapM[where S=UNIV] - det_getRestartPC getRestartPC_inv - simp: getRegister_def makeArchFaultMessage_def)+ - done - -lemma makeFaultMessage_valid_ipc_buffer_ptr'[wp]: - "makeFaultMessage ft t \valid_ipc_buffer_ptr' p\" - apply (cases ft, simp_all add: makeFaultMessage_def) - apply (wpsimp wp: asUser_inv mapM_wp' det_mapM[where S=UNIV] - det_getRestartPC getRestartPC_inv - simp: getRegister_def makeArchFaultMessage_def)+ - done - -lemmas threadget_fault_corres = - threadGet_corres [where r = fault_rel_optionation - and f = tcb_fault and f' = tcbFault, - simplified tcb_relation_def, simplified] +lemma syscallMessage_def'[Ipc_R_assms]: + "FaultHandler_H.syscallMessage \ MachineExports.syscallMessage" + by (simp add: syscallMessage_def) -lemma doFaultTransfer_corres: - "corres dc - (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender - and tcb_at receiver and case_option \ in_user_frame recv_buf - and pspace_aligned and pspace_distinct) - (tcb_at' sender and tcb_at' receiver and - case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_fault_transfer badge sender receiver recv_buf) - (doFaultTransfer badge sender receiver recv_buf)" - apply (clarsimp simp: do_fault_transfer_def doFaultTransfer_def split_def - ARM_HYP_H.badgeRegister_def badge_register_def) - apply (rule_tac Q="\fault. K (\f. fault = Some f) and - tcb_at sender and tcb_at receiver and - case_option \ in_user_frame recv_buf and - pspace_aligned and pspace_distinct" - and Q'="\fault'. tcb_at' sender and tcb_at' receiver and - case_option \ valid_ipc_buffer_ptr' recv_buf" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply (clarsimp simp: obj_at_def is_tcb)+ - apply (rule corres_assume_pre) - apply (fold assert_opt_def | unfold haskell_fail_def)+ - apply (rule corres_assert_opt_assume) - apply (clarsimp split: option.splits - simp: fault_rel_optionation_def assert_opt_def - map_option_case) - defer - defer - apply (clarsimp simp: fault_rel_optionation_def) - apply (wp thread_get_wp) - apply (clarsimp simp: obj_at_def is_tcb) - apply wp - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - done +lemma exceptionMessage_def'[Ipc_R_assms]: + "FaultHandler_H.exceptionMessage \ MachineExports.exceptionMessage" + by (simp add: exceptionMessage_def) -lemma doFaultTransfer_invs[wp]: - "\invs' and tcb_at' receiver\ - doFaultTransfer badge sender receiver recv_buf - \\rv. invs'\" - by (simp add: doFaultTransfer_def split_def | wp - | clarsimp split: option.split)+ +lemma makeArchFaultMessage_inv[Ipc_R_assms, wp]: + "makeArchFaultMessage ft t \P\" + unfolding makeArchFaultMessage_def + by (wpsimp wp: asUser_inv getRestartPC_inv split: arch_fault.split) -lemma lookupIPCBuffer_valid_ipc_buffer [wp]: +lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" - unfolding lookupIPCBuffer_def ARM_HYP_H.lookupIPCBuffer_def + unfolding lookupIPCBuffer_def + supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def locateSlot_conv threadGet_def comp_def) apply (wp getCTE_wp getObject_tcb_wp | wpc)+ @@ -1739,2812 +211,107 @@ lemma lookupIPCBuffer_valid_ipc_buffer [wp]: apply (rule_tac x = ko in exI) apply (frule ko_at_cte_ipcbuffer[simplified cteSizeBits_def]) apply (clarsimp simp: cte_wp_at_ctes_of shiftl_t2n' simp del: imp_disjL) + apply (rename_tac ref rg sz d m) apply (clarsimp simp: valid_ipc_buffer_ptr'_def) apply (frule (1) ko_at_valid_objs') apply (clarsimp simp: projectKO_opts_defs split: kernel_object.split_asm) apply (clarsimp simp add: valid_obj'_def valid_tcb'_def isCap_simps cte_level_bits_def field_simps) apply (drule bspec [OF _ ranI [where a = "4 << cteSizeBits"]]) - apply simp - apply (clarsimp simp add: valid_cap'_def) + apply (simp add: cteSizeBits_def) + apply (clarsimp simp add: valid_cap'_def frame_at'_def) apply (rule conjI) apply (rule aligned_add_aligned) apply (clarsimp simp add: capAligned_def) apply assumption apply (erule is_aligned_andI1) - apply (case_tac xd, simp_all add: msg_align_bits)[1] + apply (rule order_trans[rotated]) + apply (rule pbfs_atleast_pageBits) + apply (simp add: bit_simps msg_align_bits) apply (clarsimp simp: capAligned_def) - apply (drule_tac x = - "(tcbIPCBuffer ko && mask (pageBitsForSize xd)) >> pageBits" in spec) - apply (subst(asm) mult.commute mult.left_commute, subst(asm) shiftl_t2n[symmetric]) - apply (simp add: shiftr_shiftl1) + apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize sz)) >> pageBits" in spec) + apply (simp add: shiftr_shiftl1 ) apply (subst (asm) mask_out_add_aligned) apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) apply (erule mp) apply (rule shiftr_less_t2n) apply (clarsimp simp: pbfs_atleast_pageBits) apply (rule and_mask_less') - apply (simp add: word_bits_conv) - done - -lemma doIPCTransfer_corres: - "corres dc - (tcb_at s and tcb_at r and valid_objs and pspace_aligned - and valid_list and valid_arch_state - and pspace_distinct and valid_mdb and cur_tcb - and (\s. case ep of Some x \ ep_at x s | _ \ True)) - (tcb_at' s and tcb_at' r and valid_pspace' and cur_tcb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True)) - (do_ipc_transfer s ep bg grt r) - (doIPCTransfer s ep bg grt r)" - apply (simp add: do_ipc_transfer_def doIPCTransfer_def) - apply (rule_tac Q="\receiveBuffer sa. tcb_at s sa \ valid_objs sa \ - pspace_aligned sa \ pspace_distinct sa \ tcb_at r sa \ - cur_tcb sa \ valid_mdb sa \ valid_list sa \ valid_arch_state sa \ - (case ep of None \ True | Some x \ ep_at x sa) \ - case_option (\_. True) in_user_frame receiveBuffer sa \ - obj_at (\ko. \tcb. ko = TCB tcb - \ \\ft. tcb_fault tcb = Some ft\) s sa" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule lookupIPCBuffer_corres') - apply auto[2] - apply (rule corres_underlying_split [OF _ _ thread_get_sp threadGet_inv]) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply simp - defer - apply (rule corres_guard_imp) - apply (subst case_option_If)+ - apply (rule corres_if2) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (simp add: dc_def[symmetric]) - apply (rule doNormalTransfer_corres) - apply (wp | simp add: valid_pspace'_def)+ - apply (simp add: dc_def[symmetric]) - apply (rule doFaultTransfer_corres) - apply (clarsimp simp: obj_at_def) - apply (rule conjI, clarsimp, assumption) - apply (wp|simp add: obj_at_def is_tcb valid_pspace'_def)+ - done - - -crunch doIPCTransfer - for ifunsafe[wp]: "if_unsafe_then_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -crunch doIPCTransfer - for iflive[wp]: "if_live_then_nonz_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -lemma valid_pspace_valid_objs'[elim!]: - "valid_pspace' s \ valid_objs' s" - by (simp add: valid_pspace'_def) -crunch doIPCTransfer - for vp[wp]: "valid_pspace'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) -crunch doIPCTransfer - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for state_refs_of[wp]: "\s. P (state_refs_of' s)" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for state_hyp_refs_of[wp]: "\s. P (state_hyp_refs_of' s)" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for ct[wp]: "cur_tcb'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for idle'[wp]: "valid_idle'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) -lemmas dit'_typ_ats[wp] = typ_at_lifts [OF doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: crunch_wps simp: crunch_simps) - -lemmas dit_irq_node'[wp] - = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for valid_arch_state'[wp]: "valid_arch_state'" - (wp: crunch_wps simp: crunch_simps) - -(* Levity: added (20090126 19:32:26) *) -declare asUser_global_refs' [wp] - -lemma lec_valid_cap' [wp]: - "\valid_objs'\ lookupExtraCaps thread xa mi \\rv s. (\x\set rv. s \' fst x)\, -" - apply (rule hoare_pre, rule hoare_strengthen_postE_R) - apply (rule hoare_vcg_conj_liftE_R[where P'=valid_objs' and Q'="\_. valid_objs'"]) - apply (rule lookupExtraCaps_srcs) - apply wp - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (fastforce elim: ctes_of_valid') - apply simp - done - -crunch doIPCTransfer - for objs'[wp]: "valid_objs'" - ( wp: crunch_wps hoare_vcg_const_Ball_lift - transferCapsToSlots_valid_objs - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for global_refs'[wp]: "valid_global_refs'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_global_refsT - transferCapsToSlots_valid_globals - simp: zipWithM_x_mapM ball_conj_distrib) - -declare asUser_irq_handlers' [wp] - -crunch doIPCTransfer - for irq_handlers'[wp]: "valid_irq_handlers'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_irq_handlers' - transferCapsToSlots_irq_handlers - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for irq_states'[wp]: "valid_irq_states'" - (wp: crunch_wps no_irq no_irq_mapM no_irq_storeWord no_irq_loadWord - no_irq_case_option no_irq_addressTranslateS1 - simp: crunch_simps zipWithM_x_mapM) - -crunch doIPCTransfer - for pde_mappings'[wp]: "valid_pde_mappings'" - (wp: crunch_wps simp: crunch_simps) - -crunch doIPCTransfer - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps simp: crunch_simps rule: irqs_masked_lift) - -lemma doIPCTransfer_invs[wp]: - "\invs' and tcb_at' s and tcb_at' r\ - doIPCTransfer s ep bg grt r - \\rv. invs'\" - apply (simp add: doIPCTransfer_def) - apply (wpsimp wp: hoare_drop_imp) + apply (simp add: word_bits_conv pbfs_less_wb'[unfolded word_bits_conv]) done -crunch doIPCTransfer - for nosch[wp]: "\s. P (ksSchedulerAction s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option mapM_wp' - simp: split_def zipWithM_x_mapM) +(* Used in CRefine *) +lemma lookupIPCBuffer_Some_0: + "\\\ lookupIPCBuffer w t \\rv s. rv \ Some 0\" + by (wpsimp simp: lookupIPCBuffer_def Let_def getThreadBufferSlot_def locateSlot_conv) -lemma arch_getSanitiseRegisterInfo_corres: +lemma arch_getSanitiseRegisterInfo_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (arch_get_sanitise_register_info t) - (getSanitiseRegisterInfo t)" + (arch_get_sanitise_register_info t) + (getSanitiseRegisterInfo t)" unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def - apply (fold archThreadGet_def) - by (corresKsimp corres: archThreadGet_VCPU_corres) - -crunch arch_get_sanitise_register_info - for pspace_aligned[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct + by (fold archThreadGet_def, corres) crunch getSanitiseRegisterInfo for tcb_at'[wp]: "tcb_at' t" -lemma handle_fault_reply_registers_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (do t' \ arch_get_sanitise_register_info t; - y \ as_user t - (zipWithM_x - (\r v. setRegister r - (sanitise_register t' r v)) - msg_template msg); - return (label = 0) - od) - (do t' \ getSanitiseRegisterInfo t; - y \ asUser t - (zipWithM_x - (\r v. setRegister r (sanitiseRegister t' r v)) - msg_template msg); - return (label = 0) - od)" - apply (rule corres_guard_imp) - apply (rule corres_split[OF arch_getSanitiseRegisterInfo_corres]) - apply (rule corres_split) - apply (rule asUser_corres') - apply(simp add: setRegister_def sanitise_register_def - sanitiseRegister_def syscallMessage_def Let_def cong: register.case_cong) - apply(subst zipWithM_x_modify)+ - apply(rule corres_modify') - apply (simp|wp)+ - done +crunch arch_get_sanitise_register_info + for pspace_distinct[wp]: pspace_distinct + and pspace_aligned[wp]: pspace_aligned + +lemma sanitiseRegister_sanitise_register[Ipc_R_assms]: + "sanitiseRegister = sanitise_register" + by (rule ext)+ + (clarsimp simp add: sanitiseRegister_def sanitise_register_def cong: register.case_cong) + +lemma handleArchFaultReply_corres[Ipc_R_assms]: + "corres (=) \ \ + (handle_arch_fault_reply ft t label msg) (handleArchFaultReply (arch_fault_map ft) t label msg)" + by (clarsimp simp: handle_arch_fault_reply_def handleArchFaultReply_def + split: arch_fault.split) + +crunch getSanitiseRegisterInfo, handleArchFaultReply, handle_arch_fault_reply + for inv[Ipc_R_assms, wp]: P + +lemma ctes_of_mdbNext_parentOf[Ipc_R_assms]: + "\ ctes_of s' \ cte_map cptr \ cte_map slot; + ctes_of s' (cte_map cptr) = Some (CTE (capability.ReplyCap t master rights) n); + ctes_of s' (mdbNext (cteMDBNode cte)) = Some (CTE (capability.ReplyCap t master' rights') n'); + ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)\ + \ ctes_of s' \ cte_map cptr parentOf mdbNext (cteMDBNode cte)" + by (clarsimp simp add: parentOf_def isMDBParentOf_CTE sameRegionAs_def2 isCap_simps) + (erule subtree.cases; clarsimp simp: parentOf_def isMDBParentOf_CTE) + +crunch debugPrint + for inv[Ipc_R_assms, wp]: P + and (no_fail) no_fail[Ipc_R_assms, intro!, wp, simp] + +(* this specifically refers to the 4 message registers *) +lemma max_message_size_less_max_ipc_words[Ipc_R_assms]: + "n \ 4 + \ word_size * (word_of_nat msg_max_extra_caps + (word_of_nat msg_max_length + n)) + < max_ipc_words * word_size" + apply (simp add: msg_max_extra_caps_def msg_max_length_def max_ipc_words word_size_def) + apply (rule_tac y="0x3D8 + 8 * 4" in order_le_less_trans) + apply (rule word_plus_mono_right) + apply (rule word_mult_le_mono1'; simp) + apply simp+ + done + +end (* Arch *) + +interpretation Ipc_R?: Ipc_R +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Ipc_R_assms)?)?) +qed -lemma handleFaultReply_corres: - "ft' = fault_map ft \ - corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (handle_fault_reply ft t label msg) - (handleFaultReply ft' t label msg)" - apply (cases ft) - apply(simp_all add: handleFaultReply_def - handle_arch_fault_reply_def handleArchFaultReply_def - syscallMessage_def exceptionMessage_def - split: arch_fault.split) - by (rule handle_fault_reply_registers_corres)+ +context Arch begin arch_global_naming -crunch handleFaultReply - for typ_at'[wp]: "\s. P (typ_at' T p s)" +lemma is_derived_mask'[simp]: + "is_derived' m p (maskCapRights R c) = is_derived' m p c" + by (rule ext, simp add: is_derived'_def badge_derived'_def) -lemmas hfr_typ_ats[wp] = typ_at_lifts [OF handleFaultReply_typ_at'] - -lemmas getSanitiseRegisterInfo_def2 = getSanitiseRegisterInfo_def[folded archThreadGet_def] - -lemma getSanitiseRegisterInfo_ct'[wp]: - "\\s. P (ksCurThread s)\ getSanitiseRegisterInfo t \\rv s. P (ksCurThread s)\" - apply (simp add: getSanitiseRegisterInfo_def) - by (wpsimp simp: setObject_ct_inv) - -crunch handleFaultReply - for ct'[wp]: "\s. P (ksCurThread s)" - -lemma doIPCTransfer_sch_act_simple [wp]: - "\sch_act_simple\ doIPCTransfer sender endpoint badge grant receiver \\_. sch_act_simple\" - by (simp add: sch_act_simple_def, wp) - -lemma possibleSwitchTo_invs'[wp]: - "\invs' and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - possibleSwitchTo t \\_. invs'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp tcbSchedEnqueue_invs' ssa_invs') - apply (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt]) - apply (wpsimp wp: ssa_invs' threadGet_wp)+ - apply (clarsimp dest!: obj_at_ko_at' simp: tcb_in_cur_domain'_def obj_at'_def) - done - -crunch isFinalCapability - for cur'[wp]: "\s. P (cur_tcb' s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch deleteCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma getThreadCallerSlot_inv: - "\P\ getThreadCallerSlot t \\_. P\" - by (simp add: getThreadCallerSlot_def, wp) - -crunch unbindNotification - for tcb_at'[wp]: "tcb_at' x" - -lemma finaliseCapTrue_standin_tcb_at' [wp]: - "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp getObject_ntfn_inv - | wpc - | simp)+ - done - -lemma finaliseCapTrue_standin_cur': - "\\s. cur_tcb' s\ finaliseCapTrue_standin cap v2 \\_ s'. cur_tcb' s'\" - apply (simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ finaliseCapTrue_standin_ct']) - apply (wp) - done - -lemma cteDeleteOne_cur' [wp]: - "\\s. cur_tcb' s\ cteDeleteOne slot \\_ s'. cur_tcb' s'\" - apply (simp add: cteDeleteOne_def unless_def when_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def | wp (once) cur_tcb_lift)+ - done - -lemma handleFaultReply_cur' [wp]: - "\\s. cur_tcb' s\ handleFaultReply x0 thread label msg \\_ s'. cur_tcb' s'\" - apply (clarsimp simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ handleFaultReply_ct']) - apply (wp) - done - -lemma capClass_Reply: - "capClass cap = ReplyClass tcb \ isReplyCap cap \ capTCBPtr cap = tcb" - apply (cases cap, simp_all add: isCap_simps) - apply (rename_tac arch_capability) - apply (case_tac arch_capability, simp_all) - done - -lemma reply_cap_end_mdb_chain: - "\ cte_wp_at (is_reply_cap_to t) slot s; invs s; - invs' s'; - (s, s') \ state_relation; ctes_of s' (cte_map slot) = Some cte \ - \ (mdbPrev (cteMDBNode cte) \ nullPointer - \ mdbNext (cteMDBNode cte) = nullPointer) - \ cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) - (mdbPrev (cteMDBNode cte)) s'" - apply (clarsimp simp only: cte_wp_at_reply_cap_to_ex_rights) - apply (frule(1) pspace_relation_ctes_ofI[OF state_relation_pspace_relation], - clarsimp+) - apply (subgoal_tac "\slot' rights'. caps_of_state s slot' = Some (cap.ReplyCap t True rights') - \ descendants_of slot' (cdt s) = {slot}") - apply (elim state_relationE exE) - apply (clarsimp simp: cdt_relation_def - simp del: split_paired_All) - apply (drule spec, drule(1) mp[OF _ caps_of_state_cte_at]) - apply (frule(1) pspace_relation_cte_wp_at[OF _ caps_of_state_cteD], - clarsimp+) - apply (clarsimp simp: descendants_of'_def cte_wp_at_ctes_of) - apply (frule_tac f="\S. cte_map slot \ S" in arg_cong, simp(no_asm_use)) - apply (frule invs_mdb'[unfolded valid_mdb'_def]) - apply (rule context_conjI) - apply (clarsimp simp: nullPointer_def valid_mdb_ctes_def) - apply (erule(4) subtree_prev_0) - apply (rule conjI) - apply (rule ccontr) - apply (frule valid_mdb_no_loops, simp add: no_loops_def) - apply (drule_tac x="cte_map slot" in spec) - apply (erule notE, rule r_into_trancl, rule ccontr) - apply (clarsimp simp: mdb_next_unfold valid_mdb_ctes_def nullPointer_def) - apply (rule valid_dlistEn, assumption+) - apply (subgoal_tac "ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)") - apply (frule(3) class_linksD) - apply (clarsimp simp: isCap_simps dest!: capClass_Reply[OF sym]) - apply (drule_tac f="\S. mdbNext (cteMDBNode cte) \ S" in arg_cong) - apply (simp, erule notE, rule subtree.trans_parent, assumption+) - apply (case_tac ctea, case_tac cte') - apply (clarsimp simp add: parentOf_def isMDBParentOf_CTE) - apply (simp add: sameRegionAs_def2 isCap_simps) - apply (erule subtree.cases) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (simp add: mdb_next_unfold) - apply (erule subtree.cases) - apply (clarsimp simp: valid_mdb_ctes_def) - apply (erule_tac cte=ctea in valid_dlistEn, assumption) - apply (simp add: mdb_next_unfold) - apply (clarsimp simp: mdb_next_unfold isCap_simps) - apply (drule_tac f="\S. c' \ S" in arg_cong) - apply (clarsimp simp: no_loops_direct_simp valid_mdb_no_loops) - apply (frule invs_mdb) - apply (drule invs_valid_reply_caps) - apply (clarsimp simp: valid_mdb_def reply_mdb_def - valid_reply_caps_def reply_caps_mdb_def - cte_wp_at_caps_of_state - simp del: split_paired_All) - - apply (erule_tac x=slot in allE, erule_tac x=t in allE, erule impE, fast) - apply (elim exEI) - apply clarsimp - apply (subgoal_tac "P" for P, rule sym, rule equalityI, assumption) - apply clarsimp - apply (erule(4) unique_reply_capsD) - apply (simp add: descendants_of_def) - apply (rule r_into_trancl) - apply (simp add: cdt_parent_rel_def is_cdt_parent_def) - done - -lemma unbindNotification_valid_objs'_strengthen: - "valid_tcb' tcb s \ valid_tcb' (tcbBoundNotification_update Map.empty tcb) s" - "valid_ntfn' ntfn s \ valid_ntfn' (ntfnBoundTCB_update Map.empty ntfn) s" - by (simp_all add: valid_tcb'_def valid_ntfn'_def valid_bound_tcb'_def valid_tcb_state'_def - tcb_cte_cases_def tcb_cte_cases_neqs - split: ntfn.splits) - -crunch cteDeleteOne - for valid_objs'[wp]: "valid_objs'" - (simp: crunch_simps unless_def - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch handleFaultReply - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma emptySlot_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - emptySlot slot irq - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp weak_sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma cancelAllIPC_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllIPC epptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllIPC_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -lemma cancelAllSignals_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllSignals ntfnptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllSignals_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -crunch finaliseCapTrue_standin - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (ignore: setThreadState - simp: crunch_simps - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma cteDeleteOne_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cteDeleteOne sl - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def)+ - done - -crunch emptySlot - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - -crunch archThreadGet, handleFaultReply - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - and tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - -crunch unbindNotification - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" -(wp: sbn_sch_act') - -crunch archThreadGet, handleFaultReply - for valid_objs'[wp]: valid_objs' - -lemma cte_wp_at_is_reply_cap_toI: - "cte_wp_at ((=) (cap.ReplyCap t False rights)) ptr s - \ cte_wp_at (is_reply_cap_to t) ptr s" - by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) - -crunch handle_fault_reply - for pspace_alignedp[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - -crunch cteDeleteOne, doIPCTransfer, handleFaultReply - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -lemma doReplyTransfer_corres: - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at ((=) (cap.ReplyCap receiver False rights)) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - apply (simp add: do_reply_transfer_def doReplyTransfer_def cong: option.case_cong) - apply (rule corres_underlying_split [OF _ _ gts_sp gts_sp']) - apply (rule corres_guard_imp) - apply (rule getThreadState_corres, - (clarsimp simp add: st_tcb_at_tcb_at invs_distinct invs_psp_aligned)+) - apply (rule_tac F = "awaiting_reply state" in corres_req) - apply (clarsimp simp add: st_tcb_at_def obj_at_def is_tcb) - apply (fastforce simp: invs_def valid_state_def intro: has_reply_cap_cte_wpD - dest: has_reply_cap_cte_wpD - dest!: valid_reply_caps_awaiting_reply cte_wp_at_is_reply_cap_toI) - apply (case_tac state, simp_all add: bind_assoc) - apply (simp add: isReply_def liftM_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply clarsimp - apply (rename_tac mdbnode) - apply (rule_tac P="Q" and Q="Q" and P'="Q'" and Q'="(\s. Q' s \ R' s)" for Q Q' R' - in stronger_corres_guard_imp[rotated]) - apply assumption - apply (rule conjI, assumption) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (drule cte_wp_at_is_reply_cap_toI) - apply (erule(4) reply_cap_end_mdb_chain) - apply (rule corres_assert_assume[rotated], simp) - apply (simp add: getSlotCap_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_assert_assume[rotated]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_guard_imp) - apply (rule corres_split[OF threadget_fault_corres]) - apply (case_tac rv, simp_all add: fault_rel_optionation_def bind_assoc)[1] - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched - set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' - sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def - | strengthen valid_queues_in_correct_ready_q valid_sched_valid_queues - valid_queues_ready_qs_distinct)+ - apply (strengthen cte_wp_at_reply_cap_can_fast_finalise) - apply (wp hoare_vcg_conj_lift) - apply (rule hoare_strengthen_post [OF do_ipc_transfer_non_null_cte_wp_at]) - prefer 2 - apply (erule cte_wp_at_weakenE) - apply (fastforce) - apply (clarsimp simp:is_cap_simps) - apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q'="\_ s. valid_objs' s \ cur_tcb' s \ tcb_at' receiver s - \ sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp, simp add: sch_act_wf_weak) - apply (wp tcb_in_cur_domain'_lift) - defer - apply (simp) - apply (wp)+ - apply (clarsimp simp: invs_psp_aligned invs_distinct) - apply (rule conjI, erule invs_valid_objs) - apply (rule conjI, clarsimp)+ - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp) - apply (rule conjI, rule refl) - apply (fastforce) - apply (clarsimp simp: invs_def valid_sched_def valid_sched_action_def) - apply (simp) - apply (auto simp: invs'_def valid_state'_def)[1] - - apply (rule corres_guard_imp) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (rule corres_split_eqr[OF getMRs_corres]) - apply (simp(no_asm) del: dc_simp) - apply (rule corres_split_eqr[OF handleFaultReply_corres]) - apply simp - apply (rule corres_split) - apply (rule threadset_corresT; - clarsimp simp add: tcb_relation_def fault_rel_optionation_def cteSizeBits_def - tcb_cap_cases_def tcb_cte_cases_def inQ_def) - apply (rule_tac Q="valid_sched and cur_tcb and tcb_at receiver and pspace_aligned and pspace_distinct" - and Q'="tcb_at' receiver and cur_tcb' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and valid_objs' - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_guard_imp) - apply (case_tac rvb, simp_all)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (fold dc_def, rule possibleSwitchTo_corres) - apply simp - apply (wp hoare_weak_lift_imp hoare_weak_lift_imp_conj set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' - | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ - apply (rule corres_guard_imp) - apply (rule setThreadState_corres) - apply clarsimp+ - apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched - threadSet_tcbDomain_triv threadSet_valid_objs' - threadSet_sched_pointers threadSet_valid_sched_pointers - | simp add: valid_tcb_state'_def)+ - apply (rule_tac Q'="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and - valid_objs and pspace_aligned and pspace_distinct" - in hoare_strengthen_post [rotated], clarsimp) - apply (wp) - apply (rule hoare_chain [OF cap_delete_one_invs]) - apply (assumption) - apply (rule conjI, clarsimp) - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def) - apply (rule_tac Q'="\_. tcb_at' sender and tcb_at' receiver and invs'" - in hoare_strengthen_post [rotated]) - apply (solves\auto simp: invs'_def valid_state'_def\) - apply wp - apply clarsimp - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp simp add: can_fast_finalise_def) - apply (erule(1) emptyable_cte_wp_atD) - apply (rule allI, rule impI) - apply (clarsimp simp add: is_master_reply_cap_def) - apply (clarsimp) - done - -(* when we cannot talk about reply cap rights explicitly (for instance, when a schematic ?rights - would be generated too early *) -lemma doReplyTransfer_corres': - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at (is_reply_cap_to receiver) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - using doReplyTransfer_corres[of receiver sender _ slot] - by (fastforce simp add: cte_wp_at_reply_cap_to_ex_rights corres_underlying_def) - -lemma valid_pspace'_splits[elim!]: - "valid_pspace' s \ valid_objs' s" - "valid_pspace' s \ pspace_aligned' s" - "valid_pspace' s \ pspace_distinct' s" - "valid_pspace' s \ valid_mdb' s" - "valid_pspace' s \ no_0_obj' s" - by (simp add: valid_pspace'_def)+ - -lemma sts_valid_pspace_hangers: - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. valid_objs'\" - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. pspace_distinct'\" - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. pspace_aligned'\" - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. valid_mdb'\" - "\valid_pspace' and tcb_at' t and - valid_tcb_state' st\ setThreadState st t \\rv. no_0_obj'\" - by (safe intro!: hoare_strengthen_post [OF sts'_valid_pspace'_inv]) - -declare no_fail_getSlotCap [wp] - -lemma setupCallerCap_corres: - "corres dc - (st_tcb_at (Not \ halted) sender and tcb_at receiver and - st_tcb_at (Not \ awaiting_reply) sender and valid_reply_caps and - valid_objs and pspace_distinct and pspace_aligned and valid_mdb - and valid_list and valid_arch_state and - valid_reply_masters and cte_wp_at (\c. c = cap.NullCap) (receiver, tcb_cnode_index 3)) - (tcb_at' sender and tcb_at' receiver and valid_pspace' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) - (setup_caller_cap sender receiver grant) - (setupCallerCap sender receiver grant)" - supply if_split[split del] - apply (simp add: setup_caller_cap_def setupCallerCap_def - getThreadReplySlot_def locateSlot_conv - getThreadCallerSlot_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split_nor) - apply (rule setThreadState_corres) - apply (simp split: option.split) - apply (rule corres_symb_exec_r) - apply (rule_tac F="\r. cteCap masterCTE = capability.ReplyCap sender True r - \ mdbNext (cteMDBNode masterCTE) = nullPointer" - in corres_gen_asm2, clarsimp simp add: isCap_simps) - apply (rule corres_symb_exec_r) - apply (rule_tac F="rv = capability.NullCap" - in corres_gen_asm2, simp) - apply (rule cteInsert_corres) - apply (simp split: if_splits) - apply (simp add: cte_map_def tcbReplySlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (simp add: cte_map_def tcbCallerSlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (rule_tac Q'="\rv. cte_at' (receiver + 2 ^ cte_level_bits * tcbCallerSlot)" - in hoare_post_add) - - apply (wp, (wp getSlotCap_wp)+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at'_def cte_at'_def) - apply (rule_tac Q'="\rv. cte_at' (sender + 2 ^ cte_level_bits * tcbReplySlot)" - in hoare_post_add) - apply (wp, (wp getCTE_wp')+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (wp sts_valid_pspace_hangers - | simp add: cte_wp_at_ctes_of)+ - apply (clarsimp simp: valid_tcb_state_def st_tcb_at_reply_cap_valid - st_tcb_at_tcb_at st_tcb_at_caller_cap_null - split: option.split) - apply (clarsimp simp: valid_tcb_state'_def valid_cap'_def capAligned_reply_tcbI) - apply (frule(1) st_tcb_at_reply_cap_valid, simp, clarsimp) - apply (clarsimp simp: cte_wp_at_ctes_of cte_wp_at_caps_of_state) - apply (drule pspace_relation_cte_wp_at[rotated, OF caps_of_state_cteD], - erule valid_pspace'_splits, clarsimp+)+ - apply (clarsimp simp: cte_wp_at_ctes_of cte_map_def tcbReplySlot_def - tcbCallerSlot_def tcb_cnode_index_def - is_cap_simps) - apply (auto intro: reply_no_descendants_mdbNext_null[OF not_waiting_reply_slot_no_descendants] - simp: cte_index_repair shiftl_t2n') - done - -crunch getThreadCallerSlot - for tcb_at'[wp]: "tcb_at' t" - -lemma getThreadReplySlot_tcb_at'[wp]: - "\tcb_at' t\ getThreadReplySlot tcb \\_. tcb_at' t\" - by (simp add: getThreadReplySlot_def, wp) - -lemma setupCallerCap_tcb_at'[wp]: - "\tcb_at' t\ setupCallerCap sender receiver grant \\_. tcb_at' t\" - by (simp add: setupCallerCap_def, wp hoare_drop_imp) - -crunch setupCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps) - -lemma cteInsert_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert newCap srcSlot destSlot - \\_ s. sch_act_wf (ksSchedulerAction s) s\" -by (wp sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma setupCallerCap_sch_act [wp]: - "\\s. sch_act_not t s \ sch_act_wf (ksSchedulerAction s) s\ - setupCallerCap t r g \\_ s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: setupCallerCap_def getSlotCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv) - apply (wp getCTE_wp' sts_sch_act' hoare_drop_imps hoare_vcg_all_lift) - apply clarsimp - done - -lemma possibleSwitchTo_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def threadGet_def curDomain_def - bitmap_fun_defs) - apply (wp rescheduleRequired_weak_sch_act_wf - weak_sch_act_wf_lift_linear[where f="tcbSchedEnqueue t"] - getObject_tcb_wp hoare_weak_lift_imp - | wpc)+ - apply (clarsimp simp: obj_at'_def projectKOs weak_sch_act_wf_def ps_clear_def tcb_in_cur_domain'_def) - done - -lemmas transferCapsToSlots_pred_tcb_at' = - transferCapsToSlots_pres1 [OF cteInsert_pred_tcb_at'] - -crunch doIPCTransfer, possibleSwitchTo - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - (wp: mapM_wp' crunch_wps simp: zipWithM_x_mapM) - -lemma setSchedulerAction_ct_in_domain: - "\\s. ct_idle_or_in_cur_domain' s - \ p \ ResumeCurrentThread \ setSchedulerAction p - \\_. ct_idle_or_in_cur_domain'\" - by (simp add:setSchedulerAction_def | wp)+ - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" - (wp: crunch_wps constOnFailure_wp simp: crunch_simps) - -crunch possibleSwitchTo - for tcb_at'[wp]: "tcb_at' t" - (wp: crunch_wps) - -crunch possibleSwitchTo - for valid_pspace'[wp]: valid_pspace' - (wp: crunch_wps) - -lemma sendIPC_corres: -(* call is only true if called in handleSyscall SysCall, which - is always blocking. *) - assumes "call \ bl" - shows - "corres dc (einvs and st_tcb_at active t and ep_at ep and ex_nonz_cap_to t) - (invs' and sch_act_not t and tcb_at' t and ep_at' ep) - (send_ipc bl call bg cg cgr t ep) (sendIPC bl call bg cg cgr t ep)" -proof - - show ?thesis - apply (insert assms) - apply (unfold send_ipc_def sendIPC_def Let_def) - apply (case_tac bl) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\ob. ob = Endpoint rv) ep - and ex_nonz_cap_to t" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (case_tac rv) - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) - apply clarsimp - \ \concludes IdleEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) - apply clarsimp - \ \concludes SendEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (simp add: isReceive_def split del:if_split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: case_bool_If case_option_If if3_fold - simp del: dc_simp split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_split[OF possibleSwitchTo_corres]) - apply (fold when_def)[1] - apply (rule_tac P="call" and P'="call" - in corres_symmetric_bool_cases, blast) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (rule corres_if2, simp) - apply (rule setupCallerCap_corres) - apply (rule setThreadState_corres, simp) - apply (rule corres_trivial) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (wp | simp)+ - apply (wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases) - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases)[1] - apply (simp add: valid_tcb_state_def pred_conj_def) - apply (strengthen reply_cap_doesnt_exist_strg disjI2_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues)+ - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - do_ipc_transfer_valid_arch - | clarsimp simp: is_cap_simps)+)[1] - apply (simp add: pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift hoare_drop_imps)[1] - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply (simp) - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb')+ - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def ep_redux_simps - ep_redux_simps' st_tcb_at_tcb_at valid_ep_def - cong: list.case_cong) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_def2 valid_sched_def valid_sched_action_def) - apply (force simp: st_tcb_def2 dest!: st_tcb_at_caller_cap_null[simplified,rotated]) - subgoal by (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\k. k = Endpoint rv) ep" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (rename_tac rv rv') - apply (case_tac rv) - apply (simp add: ep_relation_def) - \ \concludes IdleEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - \ \concludes SendEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (rule_tac F="a \ t" in corres_req) - apply (clarsimp simp: invs_def valid_state_def - valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_def obj_at_def tcb_bound_refs_def2) - apply fastforce - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: isReceive_def case_bool_If - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (simp add: if_apply_def2) - apply ((wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases | - simp add: if_apply_def2 split del: if_split)+)[1] - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases) - apply (simp add: valid_tcb_state_def pred_conj_def) - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - | clarsimp simp: is_cap_simps - | strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues )+)[1] - apply (simp add: valid_tcb_state'_def pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear hoare_drop_imps) - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply simp - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb') - apply (clarsimp simp add: invs_def valid_state_def - valid_pspace_def ep_redux_simps ep_redux_simps' - st_tcb_at_tcb_at - cong: list.case_cong) - apply (clarsimp simp: valid_ep_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_at_caller_cap_null) - apply (fastforce simp: st_tcb_def2 valid_sched_def valid_sched_action_def) - subgoal by (auto simp: valid_ep'_def - split: list.split; - clarsimp simp: invs'_def valid_state'_def) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - done -qed - -crunch setMessageInfo - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas setMessageInfo_typ_ats[wp] = typ_at_lifts [OF setMessageInfo_typ_at'] - -(* Annotation added by Simon Winwood (Thu Jul 1 20:54:41 2010) using taint-mode *) -declare tl_drop_1[simp] - -crunch cancel_ipc - for cur[wp]: "cur_tcb" - (wp: crunch_wps simp: crunch_simps) - -crunch asUser - for valid_objs'[wp]: "valid_objs'" - -lemma valid_sched_weak_strg: - "valid_sched s \ weak_valid_sched_action s" - by (simp add: valid_sched_def valid_sched_action_def) - -crunch as_user - for weak_valid_sched_action[wp]: weak_valid_sched_action - (wp: weak_valid_sched_action_lift) - -lemma sendSignal_corres: - "corres dc (einvs and ntfn_at ep) (invs' and ntfn_at' ep) - (send_signal ep bg) (sendSignal ep bg)" - supply if_cong[cong] - apply (simp add: send_signal_def sendSignal_def Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getNotification_corres, - where - R = "\rv. einvs and ntfn_at ep and valid_ntfn rv and - ko_at (Structures_A.Notification rv) ep" and - R' = "\rv'. invs' and ntfn_at' ep and - valid_ntfn' rv' and ko_at' rv' ep"]) - defer - apply (wp get_simple_ko_ko_at get_ntfn_ko')+ - apply (simp add: invs_valid_objs)+ - apply (case_tac "ntfn_obj ntfn") - \ \IdleNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (case_tac "ntfnBoundTCB nTFN") - apply clarsimp - apply (rule corres_guard_imp[OF setNotification_corres]) - apply (clarsimp simp add: ntfn_relation_def)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_if) - apply (fastforce simp: receive_blocked_def receiveBlocked_def - thread_state_relation_def - split: Structures_A.thread_state.splits - Structures_H.thread_state.splits) - apply (rule corres_split[OF cancel_ipc_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply (clarsimp simp: thread_state_relation_def) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply wp - apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' hoare_disjI2 - cancel_ipc_cte_wp_at_not_reply_state - | strengthen invs_vobjs_strgs invs_psp_aligned_strg valid_sched_weak_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues - | simp add: valid_tcb_state_def)+ - apply (rule_tac Q'="\rv. invs' and tcb_at' a" in hoare_strengthen_post) - apply wp - apply (fastforce simp: invs'_def valid_state'_def sch_act_wf_weak valid_tcb_state'_def) - apply (rule setNotification_corres) - apply (clarsimp simp add: ntfn_relation_def) - apply (wp gts_wp gts_wp' | clarsimp)+ - apply (auto simp: valid_ntfn_def receive_blocked_def valid_sched_def invs_cur - elim: pred_tcb_weakenE - intro: st_tcb_at_reply_cap_valid - split: Structures_A.thread_state.splits)[1] - apply (clarsimp simp: valid_ntfn'_def invs'_def valid_state'_def valid_pspace'_def sch_act_wf_weak) - \ \WaitingNtfn\ - apply (clarsimp simp add: ntfn_relation_def Let_def) - apply (simp add: update_waiting_ntfn_def) - apply (rename_tac list) - apply (case_tac "tl list = []") - \ \tl list = []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper split del: if_split) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply ((wp | simp)+)[1] - apply (rule_tac Q'="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and - cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs' and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct'" - in hoare_post_imp, clarsimp simp: pred_tcb_at') - apply (wp | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (wp set_simple_ko_valid_objs set_ntfn_aligned' set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def ntfn_queued_st_tcb_at valid_sched_def - valid_sched_action_def) - apply (auto simp: valid_ntfn'_def )[1] - apply (clarsimp simp: invs'_def valid_state'_def) - - \ \tl list \ []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def split:list.splits) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply (wp cur_tcb_lift | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wpsimp wp: sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb) - apply (wp set_ntfn_aligned' set_simple_ko_valid_objs set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def neq_Nil_conv - ntfn_queued_st_tcb_at valid_sched_def valid_sched_action_def - split: option.splits) - apply (auto simp: valid_ntfn'_def neq_Nil_conv invs'_def valid_state'_def - weak_sch_act_wf_def - split: option.splits)[1] - \ \ActiveNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def combine_ntfn_badges_def - combine_ntfn_msgs_def) - apply (simp add: invs_def valid_state_def valid_ntfn_def) - apply (simp add: invs'_def valid_state'_def valid_ntfn'_def) - done - -lemma valid_Running'[simp]: - "valid_tcb_state' Running = \" - by (rule ext, simp add: valid_tcb_state'_def) - -crunch setMRs - for typ'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma possibleSwitchTo_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp threadSet_sch_act setQueue_sch_act threadGet_wp - | simp add: unless_def | wpc)+ - apply (auto simp: obj_at'_def projectKOs tcb_in_cur_domain'_def) - done - -crunch possibleSwitchTo - for st_refs_of'[wp]: "\s. P (state_refs_of' s)" - (wp: crunch_wps) - -crunch possibleSwitchTo - for cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps) -crunch possibleSwitchTo - for objs'[wp]: valid_objs' - (wp: crunch_wps) -crunch possibleSwitchTo - for ct[wp]: cur_tcb' - (wp: cur_tcb_lift crunch_wps) - -crunch possibleSwitchTo - for st_hyp_refs_of'[wp]: "\s. P (state_hyp_refs_of' s)" - (wp: crunch_wps) - -lemma possibleSwitchTo_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) - and pspace_aligned' and pspace_distinct'\ - possibleSwitchTo t - \\rv. if_live_then_nonz_cap'\" - unfolding possibleSwitchTo_def curDomain_def - by (wpsimp wp: threadGet_wp) - -crunch possibleSwitchTo - for ifunsafe[wp]: if_unsafe_then_cap' - and idle'[wp]: valid_idle' - and global_refs'[wp]: valid_global_refs' - and arch_state'[wp]: valid_arch_state' - and irq_node'[wp]: "\s. P (irq_node' s)" - and typ_at'[wp]: "\s. P (typ_at' T p s)" - and irq_handlers'[wp]: valid_irq_handlers' - and irq_states'[wp]: valid_irq_states' - and pde_mappigns'[wp]: valid_pde_mappings' - (simp: unless_def tcb_cte_cases_def cteSizeBits_def wp: crunch_wps) -crunch sendSignal - for ct'[wp]: "\s. P (ksCurThread s)" - and it'[wp]: "\s. P (ksIdleThread s)" - (wp: crunch_wps simp: crunch_simps) - -context -notes option.case_cong_weak[cong] -begin -crunch sendSignal, setBoundNotification - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps getObject_inv loadObject_default_inv - simp: crunch_simps unless_def o_def - rule: irqs_masked_lift) -end - -lemma ct_in_state_activatable_imp_simple'[simp]: - "ct_in_state' activatable' s \ ct_in_state' simple' s" - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply (case_tac st; simp) - done - -lemma setThreadState_nonqueued_state_update: - "\\s. invs' s \ st_tcb_at' simple' t s - \ st \ {Inactive, Running, Restart, IdleThreadState} - \ (st \ Inactive \ ex_nonz_cap_to' t s) - \ (t = ksIdleThread s \ idle' st) - \ (\ runnable' st \ sch_act_simple s)\ - setThreadState st t - \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply (clarsimp simp: pred_tcb_at') - apply (rule conjI, fastforce simp: valid_tcb_state'_def) - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI) - apply clarsimp - apply (erule delta_sym_refs) - apply (fastforce split: if_split_asm) - apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) - apply fastforce - done - -lemma cteDeleteOne_reply_cap_to'[wp]: - "\ex_nonz_cap_to' p and - cte_wp_at' (\c. isReplyCap (cteCap c)) slot\ - cteDeleteOne slot - \\rv. ex_nonz_cap_to' p\" - apply (simp add: cteDeleteOne_def ex_nonz_cap_to'_def unless_def) - apply (rule bind_wp [OF _ getCTE_sp]) - apply (rule hoare_assume_pre) - apply (subgoal_tac "isReplyCap (cteCap cte)") - apply (wp hoare_vcg_ex_lift emptySlot_cte_wp_cap_other isFinalCapability_inv - | clarsimp simp: finaliseCap_def isCap_simps | simp - | wp (once) hoare_drop_imps)+ - apply (fastforce simp: cte_wp_at_ctes_of) - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) - done - -lemma dmo_addressTranslateS1_valid_machine_state'[wp]: - "doMachineOp (addressTranslateS1 pc) \valid_machine_state'\" - by (wpsimp simp: valid_machine_state'_def - pointerInUserData_def - pointerInDeviceData_def - wp: dmo_lift' hoare_vcg_all_lift - addressTranslateS1_underlying_memory - hoare_vcg_disj_lift) - -crunch setupCallerCap, possibleSwitchTo, asUser, doIPCTransfer - for vms'[wp]: "valid_machine_state'" - (wp: crunch_wps simp: zipWithM_x_mapM_x ignore: doMachineOp) - -crunch cancelSignal - for nonz_cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps simp: crunch_simps) - -lemma cancelIPC_nonz_cap_to'[wp]: - "\ex_nonz_cap_to' p\ cancelIPC t \\rv. ex_nonz_cap_to' p\" - apply (simp add: cancelIPC_def getThreadReplySlot_def Let_def - capHasProperty_def) - apply (wp threadSet_cap_to' - | wpc - | simp - | clarsimp elim!: cte_wp_at_weakenE' - | rule hoare_post_imp[where Q'="\rv. ex_nonz_cap_to' p"])+ - done - - -crunch activateIdleThread, getThreadReplySlot, isFinalCapability - for nosch[wp]: "\s. P (ksSchedulerAction s)" - (ignore: setNextPC simp: Let_def) - -crunch setupCallerCap, asUser, setMRs, doIPCTransfer, possibleSwitchTo - for pspace_domain_valid[wp]: "pspace_domain_valid" - (wp: crunch_wps simp: zipWithM_x_mapM_x) - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma setThreadState_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - setThreadState st t - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - unfolding setThreadState_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imps) - -lemma cancelAllIPC_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllIPC epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllIPC_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -lemma cancelAllSignals_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllSignals epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllSignals_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -crunch finaliseCapTrue_standin - for not_rct[wp]: "\s. ksSchedulerAction s \ ResumeCurrentThread" - (simp: Let_def) - -lemma cancelIPC_ResumeCurrentThread_imp_notct[wp]: - "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelIPC t - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - (is "\?PRE t'\ _ \_\") -proof - - have aipc: "\t t' ntfn. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelSignal t ntfn - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cancelSignal_def) - apply (wp)[1] - apply (wp hoare_convert_imp)+ - apply (rule_tac P="\s. ksSchedulerAction s \ ResumeCurrentThread" - in hoare_weaken_pre) - apply (wpc) - apply (wp | simp)+ - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done - have cdo: "\t t' slot. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cteDeleteOne slot - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp hoare_convert_imp | simp)+ - done - show ?thesis - apply (simp add: cancelIPC_def Let_def) - apply (wp, wpc) - prefer 4 \ \state = Running\ - apply wp - prefer 7 \ \state = Restart\ - apply wp - apply (wp)+ - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp cdo)+ - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply ((wp aipc hoare_convert_imp)+)[6] - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done -qed - -crunch setMRs - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma sai_invs'[wp]: - "\invs' and ex_nonz_cap_to' ntfnptr\ - sendSignal ntfnptr badge \\y. invs'\" - unfolding sendSignal_def - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj nTFN", simp_all) - prefer 3 - apply (rename_tac list) - apply (case_tac list, - simp_all split del: if_split - add: setMessageInfo_def)[1] - apply (rule hoare_pre) - apply (wp hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act])+ - apply (clarsimp simp:conj_comms) - apply (simp add: invs'_def valid_state'_def) - apply (wp valid_irq_node_lift sts_valid_objs' setThreadState_ct_not_inQ - set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' valid_dom_schedule'_lift - hoare_convert_imp [OF setNotification_nosch] - | simp split del: if_split)+ - - apply (intro conjI[rotated]; - (solves \clarsimp simp: invs'_def valid_state'_def valid_pspace'_def\)?) - apply clarsimp - apply (clarsimp simp: invs'_def valid_state'_def split del: if_split) - apply (drule(1) ct_not_in_ntfnQueue, simp+) - apply clarsimp - apply (frule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def) - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_idle'_def pred_tcb_at'_def idle_tcb'_def - dest!: sym_refs_ko_atD' sym_refs_st_tcb_atD' sym_refs_obj_atD' - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (clarsimp elim!: if_live_then_nonz_capE' simp:invs'_def valid_state'_def) - apply (drule(1) sym_refs_ko_atD') - apply (clarsimp elim!: ko_wp_at'_weakenE - intro!: refs_of_live') - apply (clarsimp split del: if_split)+ - apply (frule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (frule invs_sym') - apply (drule(1) sym_refs_obj_atD') - apply (clarsimp split del: if_split cong: if_cong - simp: st_tcb_at_refs_of_rev' ep_redux_simps' ntfn_bound_refs'_def) - apply (frule st_tcb_at_state_refs_ofD') - apply (erule delta_sym_refs) - apply (fastforce split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset symreftype_inverse' - split: if_split_asm) - apply (clarsimp simp:invs'_def) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def valid_state'_def) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (clarsimp simp:invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (case_tac "ntfnBoundTCB nTFN", simp_all) - apply (wp set_ntfn_minor_invs') - apply (fastforce simp: valid_ntfn'_def invs'_def valid_state'_def - elim!: obj_at'_weakenE - dest!: global'_no_ex_cap) - apply (wp add: hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act] - setThreadState_nonqueued_state_update sts_st_tcb' - del: cancelIPC_simple) - apply (clarsimp | wp cancelIPC_ct')+ - apply (wp set_ntfn_minor_invs' gts_wp' | clarsimp)+ - apply (frule pred_tcb_at') - by (wp set_ntfn_minor_invs' - | rule conjI - | clarsimp elim!: st_tcb_ex_cap'' - | fastforce simp: receiveBlocked_def projectKOs pred_tcb_at'_def obj_at'_def - dest!: invs_rct_ct_activatable' - split: thread_state.splits - | fastforce simp: invs'_def valid_state'_def receiveBlocked_def projectKOs - valid_obj'_def valid_ntfn'_def - split: thread_state.splits - dest!: global'_no_ex_cap st_tcb_ex_cap'' ko_at_valid_objs')+ - -lemma replyFromKernel_corres: - "corres dc (tcb_at t and invs) (tcb_at' t and invs') - (reply_from_kernel t r) (replyFromKernel t r)" - apply (case_tac r) - apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def - badge_register_def badgeRegister_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres]) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split_eqr[OF setMRs_corres]) - apply simp - apply (rule setMessageInfo_corres) - apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' - | fastforce)+ - done - -lemma rfk_invs': - "\invs' and tcb_at' t\ replyFromKernel t r \\rv. invs'\" - apply (simp add: replyFromKernel_def) - apply (cases r) - apply wpsimp+ - done - -crunch replyFromKernel - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma completeSignal_corres: - "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and pspace_distinct and valid_objs - \ \and obj_at (\ko. ko = Notification ntfn \ Ipc_A.isActive ntfn) ntfnptr\) - (ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' and obj_at' isActive ntfnptr) - (complete_signal ntfnptr tcb) (completeSignal ntfnptr tcb)" - apply (simp add: complete_signal_def completeSignal_def) - apply (rule corres_guard_imp) - apply (rule_tac R'="\ntfn. ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' - and valid_ntfn' ntfn and (\_. isActive ntfn)" - in corres_split[OF getNotification_corres]) - apply (rule corres_gen_asm2) - apply (case_tac "ntfn_obj rv") - apply (clarsimp simp: ntfn_relation_def isActive_def - split: ntfn.splits Structures_H.notification.splits)+ - apply (rule corres_guard2_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres setNotification_corres]) - apply (clarsimp simp: ntfn_relation_def) - apply (wp set_simple_ko_valid_objs get_simple_ko_wp getNotification_wp | clarsimp simp: valid_ntfn'_def)+ - apply (clarsimp simp: valid_pspace'_def) - apply (frule_tac P="(\k. k = ntfn)" in obj_at_valid_objs', assumption) - apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def obj_at'_def) - done - - -lemma doNBRecvFailedTransfer_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ - (do_nbrecv_failed_transfer thread) (doNBRecvFailedTransfer thread)" - unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def - by (simp add: badgeRegister_def badge_register_def, rule asUser_setRegister_corres) - -lemma receiveIPC_corres: - assumes "is_ep_cap cap" and "cap_relation cap cap'" - shows " - corres dc (einvs and valid_sched and tcb_at thread and valid_cap cap and ex_nonz_cap_to thread - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3)) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_ipc thread cap isBlocking) (receiveIPC thread cap' isBlocking)" - apply (insert assms) - apply (simp add: receive_ipc_def receiveIPC_def - split del: if_split) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 right) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getBoundNotification_corres]) - apply (rule_tac r'="ntfn_relation" in corres_split) - apply (rule corres_option_split[rotated 2]) - apply (rule getNotification_corres) - apply clarsimp - apply (rule corres_trivial, simp add: ntfn_relation_def default_notification_def - default_ntfn_def) - apply (rule corres_if) - apply (clarsimp simp: ntfn_relation_def Ipc_A.isActive_def Endpoint_H.isActive_def - split: Structures_A.ntfn.splits Structures_H.notification.splits) - apply clarsimp - apply (rule completeSignal_corres) - apply (rule_tac P="einvs and valid_sched and tcb_at thread and - ep_at word1 and valid_ep ep and - obj_at (\k. k = Endpoint ep) word1 - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3) - and ex_nonz_cap_to thread" and - P'="invs' and tcb_at' thread and ep_at' word1 and - valid_ep' epa" - in corres_inst) - apply (case_tac ep) - \ \IdleEP\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def - valid_tcb_state_def st_tcb_at_tcb_at) - apply auto[1] - \ \SendEP\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (clarsimp simp: valid_ep_def) - apply (case_tac list, simp_all split del: if_split)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (case_tac lista, simp_all add: ep_relation_def)[1] - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. - sender_state = - Structures_A.thread_state.BlockedOnSend word1 data" - in corres_gen_asm) - apply (clarsimp simp: isSend_def case_bool_If - case_option_If if3_fold - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (simp split del: if_split cong: if_cong) - apply (fold dc_def)[1] - apply (rule_tac P="valid_objs and valid_mdb and valid_list and valid_arch_state - and valid_sched - and cur_tcb - and valid_reply_caps - and pspace_aligned and pspace_distinct - and st_tcb_at (Not \ awaiting_reply) a - and st_tcb_at (Not \ halted) a - and tcb_at thread and valid_reply_masters - and cte_wp_at (\c. c = cap.NullCap) - (thread, tcb_cnode_index 3)" - and P'="tcb_at' a and tcb_at' thread and cur_tcb' - and valid_pspace' - and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_guard_imp [OF corres_if]) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_if2 [OF _ setupCallerCap_corres setThreadState_corres]) - apply simp - apply simp - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wpsimp wp: sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (fastforce simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) - apply (clarsimp split: if_split_asm) - apply (clarsimp | wp do_ipc_transfer_tcb_caps do_ipc_transfer_valid_arch)+ - apply (rule_tac Q'="\_ s. sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp) - apply (fastforce elim: sch_act_wf_weak) - apply (wp sts_st_tcb' gts_st_tcb_at | simp)+ - apply (simp cong: list.case_cong) - apply wp - apply simp - apply (wp weak_sch_act_wf_lift_linear setEndpoint_valid_mdb' set_ep_valid_objs') - apply (clarsimp split: list.split) - apply (clarsimp simp add: invs_def valid_state_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_ep_def valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ko. ko = Endpoint e" for e]) - apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) - apply (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split)[1] - \ \RecvEP\ - apply (simp add: ep_relation_def) - apply (rule_tac corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (clarsimp simp: valid_tcb_state_def invs_distinct) - apply (clarsimp simp add: valid_tcb_state'_def) - apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' - hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift - | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ - apply (clarsimp simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def - valid_obj_def valid_tcb_def valid_bound_ntfn_def invs_distinct - dest!: invs_valid_objs - elim!: obj_at_valid_objsE - split: option.splits) - apply clarsimp - apply (auto simp: valid_cap'_def invs_valid_pspace' valid_obj'_def valid_tcb'_def - valid_bound_ntfn'_def obj_at'_def projectKOs pred_tcb_at'_def - dest!: invs_valid_objs' obj_at_valid_objs' - split: option.splits) - done - -lemma receiveSignal_corres: - "\ is_ntfn_cap cap; cap_relation cap cap' \ \ - corres dc (invs and st_tcb_at active thread and valid_cap cap and ex_nonz_cap_to thread) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" - apply (simp add: receive_signal_def receiveSignal_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 rights) - apply (rule corres_guard_imp) - apply (rule_tac R="\rv. invs and tcb_at thread and st_tcb_at active thread and - ntfn_at word1 and ex_nonz_cap_to thread and - valid_ntfn rv and - obj_at (\k. k = Notification rv) word1" and - R'="\rv'. invs' and tcb_at' thread and ntfn_at' word1 and - valid_ntfn' rv'" - in corres_split[OF getNotification_corres]) - apply clarsimp - apply (case_tac "ntfn_obj rv") - \ \IdleNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp+) - apply (clarsimp simp: invs_distinct) - apply simp - \ \WaitingNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp) - apply (rule doNBRecvFailedTransfer_corres; simp) - apply (clarsimp simp: invs_distinct)+ - \ \ActiveNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (fastforce simp: invs_def valid_state_def valid_pspace_def - elim!: st_tcb_weakenE) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply wp+ - apply (clarsimp simp add: ntfn_at_def2 valid_cap_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_cap'_def) - done - -lemma tg_sp': - "\P\ threadGet f p \\t. obj_at' (\t'. f t' = t) p and P\" - including no_pre - apply (simp add: threadGet_def) - apply wp - apply (rule hoare_strengthen_post) - apply (rule getObject_tcb_sp) - apply clarsimp - apply (erule obj_at'_weakenE) - apply simp - done - -declare lookup_cap_valid' [wp] - -lemma sendFaultIPC_corres: - "valid_fault f \ fr f f' \ - corres (fr \ dc) - (einvs and st_tcb_at active thread and ex_nonz_cap_to thread) - (invs' and sch_act_not thread and tcb_at' thread) - (send_fault_ipc thread f) (sendFaultIPC thread f')" - apply (simp add: send_fault_ipc_def sendFaultIPC_def - liftE_bindE Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split [where r'="\fh fh'. fh = to_bl fh'"]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_cap_fault) - apply (rule lookup_cap_corres, rule refl) - apply (rule_tac P="einvs and st_tcb_at active thread - and valid_cap handler_cap and ex_nonz_cap_to thread" - and P'="invs' and tcb_at' thread and sch_act_not thread - and valid_cap' handlerCap" - in corres_inst) - apply (case_tac handler_cap, - simp_all add: isCap_defs lookup_failure_map_def - case_bool_If If_rearrage - split del: if_split cong: if_cong)[1] - apply (rule corres_guard_imp) - apply (rule corres_if2 [OF refl]) - apply (simp add: dc_def[symmetric]) - apply (rule corres_split[OF threadset_corres sendIPC_corres], simp_all)[1] - apply (simp add: tcb_relation_def fault_rel_optionation_def inQ_def)+ - apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state - thread_set_typ_at ep_at_typ_at ex_nonz_cap_to_pres - thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched - | simp add: tcb_cap_cases_def)+ - apply ((wp threadSet_invs_trivial threadSet_tcb' - | simp add: tcb_cte_cases_def - | wp (once) sch_act_sane_lift)+)[1] - apply (rule corres_trivial, simp add: lookup_failure_map_def) - apply (clarsimp simp: st_tcb_at_tcb_at split: if_split) - apply (clarsimp simp: valid_cap_def invs_distinct) - apply (clarsimp simp: valid_cap'_def inQ_def) - apply auto[1] - apply (clarsimp simp: lookup_failure_map_def) - apply wp+ - apply (fastforce elim: st_tcb_at_tcb_at) - apply fastforce - done - -lemma gets_the_noop_corres: - assumes P: "\s. P s \ f s \ None" - shows "corres dc P P' (gets_the f) (return x)" - apply (clarsimp simp: corres_underlying_def gets_the_def - return_def gets_def bind_def get_def) - apply (clarsimp simp: assert_opt_def return_def dest!: P) - done - -lemma handleDoubleFault_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) - \ - (handle_double_fault thread f ft) - (handleDoubleFault thread f' ft')" - apply (rule corres_cross_over_guard[where Q="tcb_at' thread"]) - apply (fastforce intro!: tcb_at_cross) - apply (simp add: handle_double_fault_def handleDoubleFault_def) - apply (rule corres_guard_imp) - apply (subst bind_return [symmetric], - rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_noop2) - apply (simp add: exs_valid_def return_def) - apply (rule hoare_eq_P) - apply wp - apply (rule asUser_inv) - apply (rule getRestartPC_inv) - apply (wp no_fail_getRestartPC)+ - apply (wp|simp)+ - done - -crunch sendFaultIPC - for tcb'[wp]: "tcb_at' t" (wp: crunch_wps) - -crunch receiveIPC - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveIPC_typ_ats[wp] = typ_at_lifts [OF receiveIPC_typ_at'] - -crunch receiveSignal - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveAIPC_typ_ats[wp] = typ_at_lifts [OF receiveSignal_typ_at'] - -declare cart_singleton_empty[simp] - -declare cart_singleton_empty2[simp] - -crunch setupCallerCap - for aligned'[wp]: "pspace_aligned'" - (wp: crunch_wps) -crunch setupCallerCap - for distinct'[wp]: "pspace_distinct'" - (wp: crunch_wps) -crunch setupCallerCap - for cur_tcb[wp]: "cur_tcb'" - (wp: crunch_wps) - -lemma setupCallerCap_state_refs_of[wp]: - "\\s. P ((state_refs_of' s) (sender := {r \ state_refs_of' s sender. snd r = TCBBound}))\ - setupCallerCap sender rcvr grant - \\rv s. P (state_refs_of' s)\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp hoare_drop_imps) - apply (simp add: fun_upd_def cong: if_cong) - done - -lemma setupCallerCap_state_hyp_refs_of[wp]: - "\\s. P ((state_hyp_refs_of' s) \ \sender := {r \ state_hyp_refs_of' s sender. snd r = TCBBound}\)\ - setupCallerCap sender rcvr canGrant - \\rv s. P (state_hyp_refs_of' s)\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp hoare_drop_imps) - done - -crunch setupCallerCap - for sch_act_wf: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps ssa_sch_act sts_sch_act rule: sch_act_wf_lift) - -lemma is_derived_ReplyCap' [simp]: - "\m p g. is_derived' m p (capability.ReplyCap t False g) = - (\c. \ g. c = capability.ReplyCap t True g)" - apply (subst fun_eq_iff) - apply clarsimp - apply (case_tac x, simp_all add: is_derived'_def isCap_simps - badge_derived'_def - vsCapRef_def) - done - -lemma unique_master_reply_cap': - "\c t. isReplyCap c \ capReplyMaster c \ capTCBPtr c = t \ - (\g . c = capability.ReplyCap t True g)" - by (fastforce simp: isCap_simps conj_comms) - -lemma getSlotCap_cte_wp_at: - "\\\ getSlotCap sl \\rv. cte_wp_at' (\c. cteCap c = rv) sl\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -crunch setThreadState - for no_0_obj'[wp]: no_0_obj' - -lemma setupCallerCap_vp[wp]: - "\valid_pspace' and tcb_at' sender and tcb_at' rcvr\ - setupCallerCap sender rcvr grant \\rv. valid_pspace'\" - apply (simp add: valid_pspace'_def setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv getSlotCap_def) - apply (wp getCTE_wp) - apply (rule_tac Q'="\_. valid_pspace' and - tcb_at' sender and tcb_at' rcvr" - in hoare_post_imp) - apply (clarsimp simp: valid_cap'_def o_def cte_wp_at_ctes_of isCap_simps - valid_pspace'_def) - apply (frule(1) ctes_of_valid', simp add: valid_cap'_def capAligned_def) - apply clarsimp - apply (wp | simp add: valid_pspace'_def valid_tcb_state'_def)+ - done - -declare haskell_assert_inv[wp del] - -lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_live_then_nonz_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - -lemma setupCallerCap_ifunsafe[wp]: - "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_unsafe_then_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) - apply (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - apply (rule_tac Q'="\rv. valid_objs' and tcb_at' rcvr and ex_nonz_cap_to' rcvr" - in hoare_post_imp) - apply (clarsimp simp: ex_nonz_tcb_cte_caps' tcbCallerSlot_def - objBits_def objBitsKO_def dom_def cte_level_bits_def) - apply (wp sts_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb_state'_def)+ - done - -lemma setupCallerCap_global_refs'[wp]: - "\valid_global_refs'\ - setupCallerCap sender rcvr grant - \\rv. valid_global_refs'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp - | wp (once) hoare_vcg_imp_lift' hoare_vcg_ex_lift | clarsimp simp: cte_wp_at_ctes_of)+ - -crunch setupCallerCap - for valid_arch'[wp]: "valid_arch_state'" - (wp: hoare_drop_imps) - -crunch setupCallerCap - for typ'[wp]: "\s. P (typ_at' T p s)" - -crunch setupCallerCap - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: hoare_drop_imps) - -lemma setupCallerCap_irq_handlers'[wp]: - "\valid_irq_handlers'\ - setupCallerCap sender rcvr grant - \\rv. valid_irq_handlers'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp hoare_drop_imps | simp)+ - -lemma cteInsert_cap_to': - "\ex_nonz_cap_to' p and cte_wp_at' (\c. cteCap c = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_nonz_cap_to' p\" - supply if_cong[cong] - apply (simp add: cteInsert_def ex_nonz_cap_to'_def updateCap_def setUntypedCapAsFull_def) - apply (wpsimp wp: updateMDB_weak_cte_wp_at setCTE_weak_cte_wp_at hoare_vcg_ex_lift - | rule hoare_drop_imps - | wp getCTE_wp)+ (* getCTE_wp is separate to apply it only to the last one *) - apply (rule_tac x=cref in exI) - apply (fastforce simp: cte_wp_at_ctes_of) - done - -crunch setExtraBadge - for cap_to'[wp]: "ex_nonz_cap_to' p" - -crunch doIPCTransfer - for cap_to'[wp]: "ex_nonz_cap_to' p" - (ignore: transferCapsToSlots - wp: crunch_wps transferCapsToSlots_pres2 cteInsert_cap_to' hoare_vcg_const_Ball_lift - simp: zipWithM_x_mapM ball_conj_distrib) - -lemma st_tcb_idle': - "\valid_idle' s; st_tcb_at' P t s\ \ - (t = ksIdleThread s) \ P IdleThreadState" - by (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - -crunch getThreadCallerSlot - for idle'[wp]: "valid_idle'" -crunch getThreadReplySlot - for idle'[wp]: "valid_idle'" - -crunch setupCallerCap - for it[wp]: "\s. P (ksIdleThread s)" - (simp: updateObject_cte_inv wp: crunch_wps) - -lemma setupCallerCap_idle'[wp]: - "\valid_idle' and valid_pspace' and - (\s. st \ ksIdleThread s \ rt \ ksIdleThread s)\ - setupCallerCap st rt gr - \\_. valid_idle'\" - by (simp add: setupCallerCap_def capRange_def | wp hoare_drop_imps)+ - -crunch doIPCTransfer - for idle'[wp]: "valid_idle'" - (wp: crunch_wps simp: crunch_simps ignore: transferCapsToSlots) - -crunch setExtraBadge - for it[wp]: "\s. P (ksIdleThread s)" -crunch receiveIPC - for it[wp]: "\s. P (ksIdleThread s)" - (ignore: transferCapsToSlots - wp: transferCapsToSlots_pres2 crunch_wps hoare_vcg_const_Ball_lift - simp: crunch_simps ball_conj_distrib) - -crunch setupCallerCap - for irq_states'[wp]: valid_irq_states' - (wp: crunch_wps) - -crunch setupCallerCap - for pde_mappings'[wp]: valid_pde_mappings' - (wp: crunch_wps cong: if_cong) - -crunch receiveIPC - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps rule: irqs_masked_lift) - -crunch getThreadCallerSlot - for ct_not_inQ[wp]: "ct_not_inQ" -crunch getThreadReplySlot - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma setupCallerCap_ct_not_inQ[wp]: - "\ct_not_inQ\ setupCallerCap sender receiver grant \\_. ct_not_inQ\" - apply (simp add: setupCallerCap_def) - apply (wp hoare_drop_imp setThreadState_ct_not_inQ) - done - -crunch copyMRs - for ksQ'[wp]: "\s. P (ksReadyQueues s)" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ksQ[wp]: "\s. P (ksReadyQueues s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -crunch doIPCTransfer - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma asUser_ct_not_inQ[wp]: - "\ct_not_inQ\ asUser t m \\rv. ct_not_inQ\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps threadSet_not_inQ | simp)+ - done - -crunch copyMRs - for ct_not_inQ[wp]: "ct_not_inQ" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ct_not_inQ[wp]: "ct_not_inQ" - (ignore: getRestartPC setRegister transferCapsToSlots - wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma ntfn_q_refs_no_bound_refs': "rf : ntfn_q_refs_of' (ntfnObj ob) \ rf ~: ntfn_bound_refs' (ntfnBoundTCB ob')" - by (auto simp add: ntfn_q_refs_of'_def ntfn_bound_refs'_def - split: Structures_H.ntfn.splits) - -lemma completeSignal_invs: - "\invs' and tcb_at' tcb\ - completeSignal ntfnptr tcb - \\_. invs'\" - apply (simp add: completeSignal_def) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule hoare_pre) - apply (wp set_ntfn_minor_invs' | wpc | simp)+ - apply (rule_tac Q'="\_ s. (state_refs_of' s ntfnptr = ntfn_bound_refs' (ntfnBoundTCB ntfn)) - \ ntfn_at' ntfnptr s - \ valid_ntfn' (ntfnObj_update (\_. Structures_H.ntfn.IdleNtfn) ntfn) s - \ ((\y. ntfnBoundTCB ntfn = Some y) \ ex_nonz_cap_to' ntfnptr s) - \ ntfnptr \ ksIdleThread s" - in hoare_strengthen_post) - apply ((wp hoare_vcg_ex_lift hoare_weak_lift_imp | wpc | simp add: valid_ntfn'_def)+)[1] - apply (clarsimp simp: obj_at'_def state_refs_of'_def typ_at'_def ko_wp_at'_def live'_def projectKOs split: option.splits) - apply (blast dest: ntfn_q_refs_no_bound_refs') - apply wp - apply (subgoal_tac "valid_ntfn' ntfn s") - apply (subgoal_tac "ntfnptr \ ksIdleThread s") - apply (fastforce simp: valid_ntfn'_def valid_bound_tcb'_def projectKOs ko_at_state_refs_ofD' live'_def - elim: obj_at'_weakenE - if_live_then_nonz_capD'[OF invs_iflive' - obj_at'_real_def[THEN meta_eq_to_obj_eq, - THEN iffD1]]) - apply (fastforce simp: valid_idle'_def pred_tcb_at'_def obj_at'_def projectKOs - dest!: invs_valid_idle') - apply (fastforce dest: invs_valid_objs' ko_at_valid_objs' - simp: valid_obj'_def projectKOs)[1] - done - -lemma setupCallerCap_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' and tcb_at' sender\ - setupCallerCap sender t g \\rv. untyped_ranges_zero'\" - apply (simp add: setupCallerCap_def getSlotCap_def - getThreadCallerSlot_def getThreadReplySlot_def - locateSlot_conv) - apply (wp getCTE_wp') - apply (rule_tac Q'="\_. untyped_ranges_zero' and valid_mdb' and valid_objs'" in hoare_post_imp) - apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def untyped_derived_eq_def - isCap_simps) - apply (wp sts_valid_pspace_hangers) - apply (clarsimp simp: valid_tcb_state'_def) - done - -lemmas threadSet_urz = untyped_ranges_zero_lift[where f="cteCaps_of", OF _ threadSet_cteCaps_of] - -crunch doIPCTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: threadSet wp: threadSet_urz crunch_wps simp: zipWithM_x_mapM) - -crunch receiveIPC - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 simp: zipWithM_x_mapM ignore: constOnFailure) - -crunch possibleSwitchTo - for ctes_of[wp]: "\s. P (ctes_of s)" - (wp: crunch_wps ignore: constOnFailure) -lemmas possibleSwitchToTo_cteCaps_of[wp] - = cteCaps_of_ctes_of_lift[OF possibleSwitchTo_ctes_of] - -crunch possibleSwitchTo - for hyp_refs'[wp]: "\s. P (state_hyp_refs_of' s)" - -crunch asUser - for valid_bitmaps[wp]: valid_bitmaps - (rule: valid_bitmaps_lift wp: crunch_wps) - -crunch setupCallerCap, possibleSwitchTo, doIPCTransfer - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -(* t = ksCurThread s *) -lemma ri_invs' [wp]: - "\invs' and sch_act_not t - and ct_in_state' simple' - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ - receiveIPC t cap isBlocking - \\_. invs'\" (is "\?pre\ _ \_\") - apply (clarsimp simp: receiveIPC_def) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (rule bind_wp [OF _ gbn_sp']) - apply (rule bind_wp) - (* set up precondition for old proof *) - apply (rule_tac P''="ko_at' ep (capEPPtr cap) and ?pre" in hoare_vcg_if_split) - apply (wp completeSignal_invs) - apply (case_tac ep) - \ \endpoint = RecvEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def del: fun_upd_apply) - apply (wp sts_sch_act' hoare_vcg_const_Ball_lift valid_irq_node_lift - setThreadState_ct_not_inQ valid_dom_schedule'_lift - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def del: fun_upd_apply)+ - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' o_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (frule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_ep'_def state_hyp_refs_of'_ep - valid_obj'_def projectKOs tcb_bound_refs'_def - dest!: isCapDs) - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD') - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (rename_tac list one two three fur five six seven eight nine ten eleven) - apply (subgoal_tac "set list \ {EPRecv} \ {}") - apply (safe ; solves \auto\) - apply fastforce - apply fastforce - apply (clarsimp split: if_split_asm) - apply (fastforce simp: valid_pspace'_def global'_no_ex_cap idle'_not_queued) - \ \endpoint = IdleEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def del: fun_upd_apply) - apply (wp sts_sch_act' valid_irq_node_lift valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def del: fun_upd_apply)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def o_def state_hyp_refs_of'_ep) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "t \ capEPPtr cap") - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule ko_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (clarsimp simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def projectKOs) - \ \endpoint = SendEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rename_tac list) - apply (case_tac list, simp_all split del: if_split) - apply (rename_tac sender queue) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift hoare_drop_imps setEndpoint_valid_mdb' - set_ep_valid_objs' sts_st_tcb' sts_sch_act' valid_dom_schedule'_lift - setThreadState_ct_not_inQ - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - setEndpoint_ksQ - | simp add: valid_tcb_state'_def case_bool_If - case_option_If del: fun_upd_apply - split del: if_split cong: if_cong - | wp (once) sch_act_sane_lift hoare_vcg_conj_lift hoare_vcg_all_lift - untyped_ranges_zero_lift)+ - apply (clarsimp split del: if_split simp: pred_tcb_at' state_hyp_refs_of'_ep) - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def - st_tcb_at_refs_of_rev' conj_ac - split del: if_split - cong: if_cong) - apply (subgoal_tac "sch_act_not sender s") - prefer 2 - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (drule st_tcb_at_state_refs_ofD') - apply (simp only: conj_ac(1, 2)[where Q="sym_refs R" for R]) - apply (subgoal_tac "distinct (ksIdleThread s # capEPPtr cap # t # sender # queue)") - apply (rule conjI) - apply (clarsimp simp: ep_redux_simps' cong: if_cong) - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - subgoal by (fastforce simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - subgoal - by (clarsimp simp: singleton_tuple_cartesian split: list.split - | rule conjI | drule(1) bspec - | drule st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - | clarsimp elim!: if_live_state_refsE)+ - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (clarsimp simp: global'_no_ex_cap) - subgoal - by (rule conjI - | clarsimp simp: singleton_tuple_cartesian split: list.split - | clarsimp elim!: if_live_state_refsE - | clarsimp simp: global'_no_ex_cap idle'_not_queued' idle'_no_refs tcb_bound_refs'_def - | drule(1) bspec | drule st_tcb_at_state_refs_ofD' - | clarsimp simp: set_eq_subset dest!: bound_tcb_at_state_refs_ofD' )+ - apply (wp getNotification_wp | wpc | clarsimp)+ - done - -(* t = ksCurThread s *) -lemma rai_invs'[wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) - and (\s. \ntfnptr. isNotificationCap cap - \ capNtfnPtr cap = ntfnptr - \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) - ntfnptr s)\ - receiveSignal t cap isBlocking - \\_. invs'\" - apply (simp add: receiveSignal_def) - apply (rule bind_wp [OF _ get_ntfn_sp']) - apply (rename_tac ep) - apply (case_tac "ntfnObj ep") - \ \ep = IdleNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "capNtfnPtr cap \ t") - apply (frule valid_pspace_valid_objs') - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD' bound_tcb_at_state_refs_ofD')+ - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - \ \ep = ActiveNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_valid_objs' typ_at_lifts hoare_weak_lift_imp - asUser_urz valid_dom_schedule'_lift - | simp add: valid_ntfn'_def)+ - apply (clarsimp simp: pred_tcb_at' valid_pspace'_def) - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def isCap_simps) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD')+ - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm simp: global'_no_ex_cap)+ - \ \ep = WaitingNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - setThreadState_ct_not_inQ typ_at_lifts valid_dom_schedule'_lift - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: valid_tcb_state'_def) - apply (frule_tac t=t in not_in_ntfnQueue) - apply (simp) - apply (simp) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def) - apply (clarsimp simp: valid_ntfn'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' - dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (rename_tac list one two three four five six seven eight nine) - apply (subgoal_tac "set list \ {NTFNSignal} \ {}") - apply safe[1] - apply (auto simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def)[5] - apply (fastforce simp: tcb_bound_refs'_def - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - done - -lemma getCTE_cap_to_refs[wp]: - "\\\ getCTE p \\rv s. \r\zobj_refs' (cteCap rv). ex_nonz_cap_to' r s\" - apply (rule hoare_strengthen_post [OF getCTE_sp]) - apply (clarsimp simp: ex_nonz_cap_to'_def) - apply (fastforce elim: cte_wp_at_weakenE') - done - -lemma lookupCap_cap_to_refs[wp]: - "\\\ lookupCap t cref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" - apply (simp add: lookupCap_def lookupCapAndSlot_def split_def - getSlotCap_def) - apply (wp | simp)+ - done - -lemma arch_stt_objs' [wp]: - "\valid_objs'\ Arch.switchToThread t \\rv. valid_objs'\" - apply (simp add: ARM_HYP_H.switchToThread_def) - apply wp - done - -declare zipWithM_x_mapM [simp] - -lemma cteInsert_invs_bits[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert a b c - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" - "\\s. P (state_refs_of' s)\ - cteInsert a b c - \\rv s. P (state_refs_of' s)\" - "\\s. P (state_hyp_refs_of' s)\ - cteInsert a b c - \\rv s. P (state_hyp_refs_of' s)\" -apply (wp sch_act_wf_lift valid_queues_lift - cur_tcb_lift tcb_in_cur_domain'_lift)+ -done - -lemma setupCallerCap_cap_to' [wp]: - "\ex_nonz_cap_to' p\ setupCallerCap a b c \\rv. ex_nonz_cap_to' p\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def) - apply (wp cteInsert_cap_to') - apply (rule_tac Q'="\rv. ex_nonz_cap_to' p - and cte_wp_at' (\c. (cteCap c) = rv) callerSlot" - in hoare_post_imp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (wp getSlotCap_cte_wp_at hoare_drop_imps)+ - apply simp - done - -lemma possibleSwitchTo_sch_act_not: - "\sch_act_not t' and K (t \ t')\ possibleSwitchTo t \\rv. sch_act_not t'\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def curDomain_def) - apply (wp hoare_drop_imps | wpc | simp)+ - done - -crunch possibleSwitchTo - for vms'[wp]: valid_machine_state' -crunch possibleSwitchTo - for pspace_domain_valid[wp]: pspace_domain_valid -crunch possibleSwitchTo - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - -crunch possibleSwitchTo - for ct'[wp]: "\s. P (ksCurThread s)" -crunch possibleSwitchTo - for it[wp]: "\s. P (ksIdleThread s)" -crunch possibleSwitchTo - for irqs_masked'[wp]: "irqs_masked'" -crunch possibleSwitchTo - for urz[wp]: "untyped_ranges_zero'" - (simp: crunch_simps unless_def wp: crunch_wps) - -crunch possibleSwitchTo - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - -lemma si_invs'[wp]: - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ - sendIPC bl call ba cg cgr t ep - \\rv. invs'\" - supply if_split[split del] - supply if_cong[cong] - apply (simp add: sendIPC_def split del: if_split) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (case_tac epa) - \ \epa = RecvEP\ - apply simp - apply (rename_tac list) - apply (case_tac list) - apply simp - apply (simp split del: if_split add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (rule_tac P="a\t" in hoare_gen_asm) - apply (wp valid_irq_node_lift - sts_valid_objs' set_ep_valid_objs' setEndpoint_valid_mdb' sts_st_tcb' sts_sch_act' - possibleSwitchTo_sch_act_not setThreadState_ct_not_inQ valid_dom_schedule'_lift - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - hoare_convert_imp [OF doIPCTransfer_sch_act doIPCTransfer_ct'] - hoare_convert_imp [OF setEndpoint_nosch setEndpoint_ksCurThread] - hoare_drop_imp [where f="threadGet tcbFault t"] - | rule_tac f="getThreadState a" in hoare_drop_imp - | wp (once) hoare_drop_imp[where Q'="\_ _. call"] - hoare_drop_imp[where Q'="\_ _. \ call"] - hoare_drop_imp[where Q'="\_ _. cg"] - | simp add: valid_tcb_state'_def case_bool_If - case_option_If - cong: if_cong - del: fun_upd_apply - split del: if_split - | wp (once) sch_act_sane_lift tcb_in_cur_domain'_lift hoare_vcg_const_imp_lift)+ - apply (clarsimp simp: pred_tcb_at' state_hyp_refs_of'_ep cong: conj_cong imp_cong - split del: if_split) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def - st_tcb_at_refs_of_rev' pred_tcb_at' - conj_comms fun_upd_def[symmetric] - split del: if_split) - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD' st_tcb_at_state_refs_ofD')+ - apply (clarsimp simp: valid_pspace'_splits) - apply (subst fun_upd_idem[where x=t]) - apply (clarsimp split: if_split) - apply (rule conjI, clarsimp simp: obj_at'_def projectKOs) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def) - apply (subgoal_tac "ex_nonz_cap_to' a s") - prefer 2 - apply (clarsimp elim!: if_live_state_refsE) - apply clarsimp - apply (rule conjI) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp simp: conj_ac) - apply (rule conjI, clarsimp simp: idle'_no_refs) - apply (rule conjI, clarsimp simp: global'_no_ex_cap) - apply (rule conjI) - apply (rule impI) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (clarsimp) - apply (simp add: ep_redux_simps') - apply (rule conjI, clarsimp split: if_split) - apply (rule conjI, fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp, erule delta_sym_refs; - solves\auto simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm\) - apply (solves\clarsimp split: list.splits\) - \ \epa = IdleEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def del: fun_upd_apply) - apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' state_hyp_refs_of'_ep - simp del: fun_upd_apply) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "ep \ t") - apply (drule simple_st_tcb_at_state_refs_ofD' ko_at_state_refs_ofD' - bound_tcb_at_state_refs_ofD')+ - apply (rule conjI, erule delta_sym_refs) - apply (auto simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm)[2] - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply simp - apply wp - apply simp - \ \epa = SendEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def del: fun_upd_apply) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ - valid_dom_schedule'_lift) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' state_hyp_refs_of'_ep - simp del: fun_upd_apply) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: valid_obj'_def valid_ep'_def - projectKOs st_tcb_at_refs_of_rev') - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - simp: tcb_bound_refs'_def) - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - subgoal by (fastforce simp: obj_at'_def projectKOs symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap idle'_not_queued) - apply (simp | wp)+ - done - -lemma sfi_invs_plus': - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" - apply (simp add: sendFaultIPC_def) - apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state - threadSet_cap_to' - | wpc | simp)+ - apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s - \ st_tcb_at' simple' t s - \ ex_nonz_cap_to' t s - \ t \ ksIdleThread s - \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" - in hoare_strengthen_postE_R) - apply wp - apply (clarsimp simp: inQ_def pred_tcb_at') - apply (wp | simp)+ - apply (clarsimp simp: eq_commute) - apply (subst(asm) global'_no_ex_cap, auto) - done - -crunch send_fault_ipc - for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" - and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" - (simp: crunch_simps wp: crunch_wps) - -lemma handleFault_corres: - "fr f f' \ - corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread - and (\_. valid_fault f)) - (invs' and sch_act_not thread - and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) - (handle_fault thread f) (handleFault thread f')" - apply (simp add: handle_fault_def handleFault_def) - apply (rule corres_guard_imp) - apply (subst return_bind [symmetric], - rule corres_split[where P="tcb_at thread", - OF gets_the_noop_corres [where x="()"]]) - apply (simp add: tcb_at_def) - apply (rule corres_split_catch) - apply (rule_tac F="valid_fault f" in corres_gen_asm) - apply (rule sendFaultIPC_corres, assumption) - apply simp - apply (rule handleDoubleFault_corres) - apply wpsimp+ - apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def valid_state_def valid_idle_def) - apply auto - done - -lemma sts_invs_minor'': - "\st_tcb_at' (\st'. tcb_st_refs_of' st' = tcb_st_refs_of' st - \ (st \ Inactive \ \ idle' st \ - st' \ Inactive \ \ idle' st')) t - and (\s. t = ksIdleThread s \ idle' st) - and (\s. \ runnable' st \ sch_act_not t s) - and invs'\ - setThreadState st t - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply clarsimp - apply (rule conjI) - apply fastforce - apply (rule conjI) - apply (clarsimp simp: pred_tcb_at'_def) - apply (drule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def projectKOs) - subgoal by (cases st, auto simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits)[1] - apply (rule conjI) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce elim!: st_tcb_ex_cap'') - done - -lemma hf_invs' [wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ - handleFault t f \\r. invs'\" - apply (simp add: handleFault_def) - apply wp - apply (simp add: handleDoubleFault_def) - apply (wp sts_invs_minor'' dmo_invs')+ - apply (rule hoare_strengthen_postE, rule sfi_invs_plus', - simp_all) - apply (strengthen no_refs_simple_strg') - apply clarsimp - done - -declare zipWithM_x_mapM [simp del] - -lemma gts_st_tcb': - "\\\ getThreadState t \\r. st_tcb_at' (\st. st = r) t\" - apply (rule hoare_strengthen_post) - apply (rule gts_sp') - apply simp - done - -lemma setupCallerCap_pred_tcb_unchanged: - "\pred_tcb_at' proj P t and K (t \ t')\ - setupCallerCap t' t'' g - \\rv. pred_tcb_at' proj P t\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp sts_pred_tcb_neq' hoare_drop_imps) - apply clarsimp - done - -lemma si_blk_makes_simple': - "\st_tcb_at' simple' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' simple' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_drop_imps) - apply (clarsimp simp: pred_tcb_at' del: disjCI) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -lemma si_blk_makes_runnable': - "\st_tcb_at' runnable' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' runnable' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_vcg_const_imp_lift hoare_drop_imps - | simp)+ - apply (clarsimp del: disjCI simp: pred_tcb_at' elim!: pred_tcb'_weakenE) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -lemma sfi_makes_simple': - "\st_tcb_at' simple' t and K (t \ t')\ - sendFaultIPC t' ft - \\rv. st_tcb_at' simple' t\" - apply (rule hoare_gen_asm) - apply (simp add: sendFaultIPC_def - cong: if_cong capability.case_cong bool.case_cong) - apply (wpsimp wp: si_blk_makes_simple' threadSet_pred_tcb_no_state hoare_drop_imps - hoare_vcg_all_liftE_R) - done - -lemma sfi_makes_runnable': - "\st_tcb_at' runnable' t and K (t \ t')\ - sendFaultIPC t' ft - \\rv. st_tcb_at' runnable' t\" - apply (rule hoare_gen_asm) - apply (simp add: sendFaultIPC_def - cong: if_cong capability.case_cong bool.case_cong) - apply (wpsimp wp: si_blk_makes_runnable' threadSet_pred_tcb_no_state hoare_drop_imps - hoare_vcg_all_liftE_R) - done - -lemma hf_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - handleFault t ft - \\rv. st_tcb_at' P t'\" - apply (safe intro!: hoare_gen_asm) - apply (simp_all add: handleFault_def handleDoubleFault_def) - apply (wp sfi_makes_runnable' sfi_makes_simple' sts_st_tcb_at'_cases - | simp add: handleDoubleFault_def)+ - done - -crunch possibleSwitchTo, completeSignal - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - -lemma ri_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveIPC t cap isBlocking - \\rv. st_tcb_at' P t'\" - including no_pre - apply (rule hoare_gen_asm)+ - apply (simp add: receiveIPC_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (rule bind_wp [OF _ gbn_sp']) - apply wp - apply (rename_tac ep q r) - apply (case_tac ep, simp_all) - apply (wp sts_st_tcb_at'_cases | wpc | simp add: doNBRecvFailedTransfer_def)+ - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_vcg_const_imp_lift)+ - apply (simp, simp only: imp_conv_disj) - apply (wp hoare_vcg_disj_lift)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def isSend_def - split: Structures_H.thread_state.split_asm) - apply (rule hoare_pre) - apply wpsimp+ - done - -lemma rai_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveSignal t cap isBlocking - \\rv. st_tcb_at' P t'\" - apply (rule hoare_gen_asm) - apply (simp add: receiveSignal_def) - apply (rule hoare_pre) - by (wp sts_st_tcb_at'_cases getNotification_wp | wpc | simp add: doNBRecvFailedTransfer_def)+ - -lemma sendSignal_st_tcb'_Running: - "\st_tcb_at' (\st. st = Running \ P st) t\ - sendSignal ntfnptr bdg - \\_. st_tcb_at' (\st. st = Running \ P st) t\" - apply (simp add: sendSignal_def) - apply (wp sts_st_tcb_at'_cases cancelIPC_st_tcb_at' gts_wp' getNotification_wp hoare_weak_lift_imp - | wpc | clarsimp simp: pred_tcb_at')+ - done - -end +end (* Arch *) end diff --git a/proof/refine/RISCV64/ArchIpc_R.thy b/proof/refine/RISCV64/ArchIpc_R.thy index b34ad6a532..25a783b391 100644 --- a/proof/refine/RISCV64/ArchIpc_R.thy +++ b/proof/refine/RISCV64/ArchIpc_R.thy @@ -8,910 +8,84 @@ theory ArchIpc_R imports Ipc_R begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming -lemmas lookup_slot_wrapper_defs'[simp] = - lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def +named_theorems Ipc_R_assms -lemma getMessageInfo_corres: "corres ((=) \ message_info_map) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (get_message_info t) (getMessageInfo t)" - apply (rule corres_guard_imp) +declare word64_minus_one_le[simp] + +lemma getMessageInfo_corres[Ipc_R_assms]: + "corres ((=) \ message_info_map) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_message_info t) (getMessageInfo t)" apply (unfold get_message_info_def getMessageInfo_def fun_app_def) apply (simp add: RISCV64_H.msgInfoRegister_def - RISCV64.msgInfoRegister_def RISCV64_A.msg_info_register_def) - apply (rule corres_split_eqr[OF asUser_getRegister_corres]) + RISCV64.msgInfoRegister_def RISCV64_A.msg_info_register_def) + apply (corres corres: asUser_getRegister_corres) apply (rule corres_trivial, simp add: message_info_from_data_eqv) - apply (wp | simp)+ - done - - -lemma get_mi_inv'[wp]: "\I\ getMessageInfo a \\x. I\" - by (simp add: getMessageInfo_def, wp) - -definition - "get_send_cap_relation rv rv' \ - (case rv of Some (c, cptr) \ (\c' cptr'. rv' = Some (c', cptr') \ - cte_map cptr = cptr' \ - cap_relation c c') - | None \ rv' = None)" - -lemma cap_relation_mask: - "\ cap_relation c c'; msk' = rights_mask_map msk \ \ - cap_relation (mask_cap msk c) (maskCapRights msk' c')" - by simp - -lemma lsfco_cte_at': - "\valid_objs' and valid_cap' cap\ - lookupSlotForCNodeOp f cap idx depth - \\rv. cte_at' rv\, -" - apply (simp add: lookupSlotForCNodeOp_def) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (wp) - apply (clarsimp simp: split_def unlessE_def - split del: if_split) - apply (wpsimp wp: hoare_drop_imps throwE_R) - done - -declare unifyFailure_wp [wp] - -(* FIXME: move *) -lemma unifyFailure_wp_E [wp]: - "\P\ f -, \\_. E\ \ \P\ unifyFailure f -, \\_. E\" - unfolding validE_E_def - by (erule unifyFailure_wp)+ - -(* FIXME: move *) -lemma unifyFailure_wp2 [wp]: - assumes x: "\P\ f \\_. Q\" - shows "\P\ unifyFailure f \\_. Q\" - by (wp x, simp) - -definition - ct_relation :: "captransfer \ cap_transfer \ bool" -where - "ct_relation ct ct' \ - ct_receive_root ct = to_bl (ctReceiveRoot ct') - \ ct_receive_index ct = to_bl (ctReceiveIndex ct') - \ ctReceiveDepth ct' = unat (ct_receive_depth ct)" - -(* MOVE *) -lemma valid_ipc_buffer_ptr_aligned_word_size_bits: - "\valid_ipc_buffer_ptr' a s; is_aligned y word_size_bits \ \ is_aligned (a + y) word_size_bits" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (erule (1) aligned_add_aligned) - apply (simp add: msg_align_bits word_size_bits_def) - done - -(* MOVE *) -lemma valid_ipc_buffer_ptr'D2: - "\valid_ipc_buffer_ptr' a s; y < max_ipc_words * word_size; is_aligned y word_size_bits\ \ typ_at' UserDataT (a + y && ~~ mask pageBits) s" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (subgoal_tac "(a + y) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (erule order_less_le_trans) - apply (simp add: msg_align_bits max_ipc_words word_size_def) - apply simp - done - -lemma loadCapTransfer_corres: - notes msg_max_words_simps = max_ipc_words_def msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def - capTransferDataSize_def msgExtraCapBits_def - shows - "corres ct_relation \ (valid_ipc_buffer_ptr' buffer) (load_cap_transfer buffer) (loadCapTransfer buffer)" - apply (simp add: load_cap_transfer_def loadCapTransfer_def - captransfer_from_words_def - capTransferDataSize_def capTransferFromWords_def - msgExtraCapBits_def word_size add.commute add.left_commute - msg_max_length_def msg_max_extra_caps_def word_size_def - msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def wordSize_def wordBits_def - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (clarsimp simp: ct_relation_def) - apply (wp no_irq_loadWord)+ - apply simp - apply (simp add: conj_comms) - apply safe - apply (erule valid_ipc_buffer_ptr_aligned_word_size_bits, simp add: is_aligned_def word_size_bits_def)+ - apply (erule valid_ipc_buffer_ptr'D2, - simp add: msg_max_words_simps word_size_def word_size_bits_def, - simp add: word_size_bits_def is_aligned_def)+ - done - -lemma getReceiveSlots_corres: - "corres (\xs ys. ys = map cte_map xs) - (tcb_at receiver and valid_objs and pspace_aligned) - (tcb_at' receiver and valid_objs' and pspace_aligned' and pspace_distinct' and - case_option \ valid_ipc_buffer_ptr' recv_buf) - (get_receive_slots receiver recv_buf) - (getReceiveSlots receiver recv_buf)" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF loadCapTransfer_corres]) - apply (rule corres_empty_on_failure) - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (rule lookup_cap_corres) - apply (simp add: ct_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (simp add: ct_relation_def) - apply (erule lookupSlotForCNodeOp_corres [OF _ refl]) - apply simp - apply (simp add: split_def liftE_bindE unlessE_whenE) - apply (rule corres_split[OF get_cap_corres]) - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap, auto)[1] - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (wp lookup_cap_valid lookup_cap_valid' lsfco_cte_at | simp)+ - done - -lemma get_recv_slot_inv'[wp]: - "\ P \ getReceiveSlots receiver buf \\rv'. P \" - apply (case_tac buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def - split_def unlessE_def) - apply (wp | simp)+ - done - -lemma get_rs_cte_at'[wp]: - "\\\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. cte_wp_at' (\c. cteCap c = capability.NullCap) x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (rule getCTE_wp) - apply (simp add: cte_wp_at_ctes_of cong: conj_cong) - apply wp+ - apply simp - done - -lemma get_rs_real_cte_at'[wp]: - "\valid_objs'\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. real_cte_at' x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (wp hoare_drop_imps)[1] - apply simp - apply (wp lookup_cap_valid')+ - apply simp - done - -declare word_div_1 [simp] -declare word_minus_one_le [simp] -declare word64_minus_one_le [simp] - -lemma loadWordUser_corres': - "\ y < unat max_ipc_words; y' = of_nat y * 8 \ \ - corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + y'))" - apply simp - apply (erule loadWordUser_corres) + apply wpsimp+ done -declare loadWordUser_inv [wp] - -lemma getExtraCptrs_inv[wp]: - "\P\ getExtraCPtrs buf mi \\rv. P\" - apply (cases mi, cases buf, simp_all add: getExtraCPtrs_def) - apply (wp dmo_inv' mapM_wp' loadWord_inv) - done - -lemma getSlotCap_cte_wp_at_rv: - "\cte_wp_at' (\cte. P (cteCap cte) cte) p\ - getSlotCap p - \\rv. cte_wp_at' (P rv) p\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_ctes_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -lemma badge_derived_mask [simp]: - "badge_derived' (maskCapRights R c) c' = badge_derived' c c'" - by (simp add: badge_derived'_def) - -declare derived'_not_Null [simp] +lemma max_ipc_size_le_2_msg_align_bits[Ipc_R_assms]: + "max_ipc_words * word_size \ 2 ^ msg_align_bits" + by (simp add: max_ipc_words word_size_def msg_align_bits) lemma maskCapRights_vs_cap_ref'[simp]: "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" unfolding vs_cap_ref'_def - apply (cases cap, simp_all add: maskCapRights_def isCap_simps Let_def) + apply (cases cap, simp_all add: global.maskCapRights_def isCap_simps Let_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; - simp add: maskCapRights_def RISCV64_H.maskCapRights_def isCap_simps Let_def) - done - -lemma corres_set_extra_badge: - "b' = b \ - corres dc (in_user_frame buffer) - (valid_ipc_buffer_ptr' buffer and - (\_. msg_max_length + 2 + n < unat max_ipc_words)) - (set_extra_badge buffer b n) (setExtraBadge buffer b' n)" - apply (rule corres_gen_asm2) - apply (drule storeWordUser_corres [where a=buffer and w=b]) - apply (simp add: set_extra_badge_def setExtraBadge_def buffer_cptr_index_def - bufferCPtrOffset_def Let_def) - apply (simp add: word_size word_size_def wordSize_def wordBits_def - bufferCPtrOffset_def buffer_cptr_index_def msgMaxLength_def - msg_max_length_def msgLengthBits_def store_word_offs_def - add.commute add.left_commute) - done - -crunch setExtraBadge - for typ_at': "\s. P (typ_at' T p s)" -lemmas setExtraBadge_typ_ats' [wp] = typ_at_lifts [OF setExtraBadge_typ_at'] -crunch setExtraBadge - for valid_pspace'[wp]: valid_pspace' -crunch setExtraBadge - for cte_wp_at'[wp]: "cte_wp_at' P p" -crunch setExtraBadge - for ipc_buffer'[wp]: "valid_ipc_buffer_ptr' buffer" - -crunch getExtraCPtr - for inv'[wp]: P (wp: dmo_inv' loadWord_inv) - -lemmas unifyFailure_discard2 - = corres_injection[OF id_injection unifyFailure_injection, simplified] - -lemma deriveCap_not_null: - "\\\ deriveCap slot cap \\rv. K (rv \ NullCap \ cap \ NullCap)\,-" - apply (simp add: deriveCap_def split del: if_split) - by (case_tac cap; wpsimp simp: isCap_simps) - -lemma deriveCap_derived_foo: - "\\s. \cap'. (cte_wp_at' (\cte. badge_derived' cap (cteCap cte) - \ capASID cap = capASID (cteCap cte) \ cap_asid_base' cap = cap_asid_base' (cteCap cte) - \ cap_vptr' cap = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s \ cap' \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot cap' \ cteCap) slot s) - \ (cte_wp_at' (untyped_derived_eq cap \ cteCap) slot s - \ cte_wp_at' (untyped_derived_eq cap' \ cteCap) slot s) - \ (s \' cap \ s \' cap') \ (cap' \ NullCap \ cap \ NullCap) \ Q cap' s\ - deriveCap slot cap \Q\,-" - using deriveCap_derived[where slot=slot and c'=cap] deriveCap_valid[where slot=slot and c=cap] - deriveCap_untyped_derived[where slot=slot and c'=cap] deriveCap_not_null[where slot=slot and cap=cap] - apply (clarsimp simp: validE_R_def validE_def valid_def split: sum.split) - apply (frule in_inv_by_hoareD[OF deriveCap_inv]) - apply (clarsimp simp: o_def) - apply (drule spec, erule mp) - apply safe - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) bspec, simp) - done - -lemma valid_mdb_untyped_incD': - "valid_mdb' s \ untyped_inc' (ctes_of s)" - by (simp add: valid_mdb'_def valid_mdb_ctes_def) - -lemma cteInsert_cte_wp_at: - "\\s. cte_wp_at' (\c. is_derived' (ctes_of s) src cap (cteCap c)) src s - \ valid_mdb' s \ valid_objs' s - \ (if p = dest then P cap - else cte_wp_at' (\c. P (maskedAsFull (cteCap c) cap)) p s)\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - apply (simp add: cteInsert_def) - apply (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp hoare_weak_lift_imp - | clarsimp simp: comp_def - | unfold setUntypedCapAsFull_def)+ - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=cte in exI) - apply clarsimp - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=ctea in exI) - apply clarsimp - apply (cases "p=dest") - apply (clarsimp simp: cte_wp_at'_def) - apply (cases "p=src") - apply clarsimp - apply (intro conjI impI) - apply ((clarsimp simp: cte_wp_at'_def maskedAsFull_def split: if_split_asm)+)[2] - apply clarsimp - apply (rule conjI) - apply (clarsimp simp: maskedAsFull_def cte_wp_at_ctes_of split:if_split_asm) - apply (erule disjE) prefer 2 apply simp - apply (clarsimp simp: is_derived'_def isCap_simps) - apply (drule valid_mdb_untyped_incD') - apply (case_tac cte, case_tac cteb, clarsimp) - apply (drule untyped_incD', (simp add: isCap_simps)+) - apply (frule(1) ctes_of_valid'[where p = p]) - apply (clarsimp simp:valid_cap'_def capAligned_def split:if_splits) - apply (drule_tac y ="of_nat fb" in word_plus_mono_right[OF _ is_aligned_no_overflow',rotated]) - apply simp+ - apply (rule word_of_nat_less) - apply simp - apply (simp add:p_assoc_help mask_def) - apply (simp add: max_free_index_def) - apply (clarsimp simp: maskedAsFull_def is_derived'_def badge_derived'_def - isCap_simps capMasterCap_def cte_wp_at_ctes_of - split: if_split_asm capability.splits) - done - -lemma cteInsert_weak_cte_wp_at3: - assumes imp:"\c. P c \ \ isUntypedCap c" - shows " \\s. if p = dest then P cap - else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - by (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp' hoare_weak_lift_imp - | clarsimp simp: comp_def cteInsert_def - | unfold setUntypedCapAsFull_def - | auto simp: cte_wp_at'_def dest!: imp)+ - -lemma maskedAsFull_null_cap[simp]: - "(maskedAsFull x y = capability.NullCap) = (x = capability.NullCap)" - "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" - by (case_tac x, auto simp:maskedAsFull_def isCap_simps) - -lemma maskCapRights_eq_null: - "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = - (xa = capability.NullCap)" - apply (cases xa; simp add: maskCapRights_def isCap_simps) + simp add: RISCV64_H.maskCapRights_def isCap_simps Let_def) + done + +lemma is_derived'_Untyped[Ipc_R_assms]: + "\isUntypedCap cap'\ + \ is_derived' m src cap' cap + = (isUntypedCap cap \ badge_derived' cap' cap \ descendants_of' src m = {})" + by (clarsimp simp add: RISCV64.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma is_derived'_Reply[Ipc_R_assms]: + "\isReplyCap cap'\ + \ is_derived' m src cap' cap + = (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ capReplyMaster cap \ \ capReplyMaster cap')" + by (clarsimp simp add: RISCV64.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma maskCapRights_eq_null[Ipc_R_assms, simp]: + "(RetypeDecls_H.maskCapRights r cap = capability.NullCap) = (cap = capability.NullCap)" + apply (cases cap; simp add: global.maskCapRights_def isCap_simps) apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (simp_all add: RISCV64_H.maskCapRights_def isCap_simps) - done - -lemma cte_refs'_maskedAsFull[simp]: - "cte_refs' (maskedAsFull a b) = cte_refs' a" - apply (rule ext)+ - apply (case_tac a) - apply (clarsimp simp:maskedAsFull_def isCap_simps)+ - done - -lemma set_extra_badge_valid_arch_state[wp]: - "set_extra_badge buffer badge n \ valid_arch_state \" - unfolding set_extra_badge_def - by wp - -lemma transferCapsToSlots_corres: - "\ list_all2 (\(cap, slot) (cap', slot'). cap_relation cap cap' - \ slot' = cte_map slot) caps caps'; - mi' = message_info_map mi \ \ - corres ((=) \ message_info_map) - (\s. valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_mdb s - \ valid_list s \ valid_arch_state s - \ (case ep of Some x \ ep_at x s | _ \ True) - \ (\x \ set slots. cte_wp_at (\cap. cap = cap.NullCap) x s \ - real_cte_at x s) - \ (\(cap, slot) \ set caps. valid_cap cap s \ - cte_wp_at (\cp'. (cap \ cap.NullCap \ cp'\cap \ cp' = masked_as_full cap cap )) slot s ) - \ distinct slots - \ in_user_frame buffer s) - (\s. valid_pspace' s - \ (case ep of Some x \ ep_at' x s | _ \ True) - \ (\x \ set (map cte_map slots). - cte_wp_at' (\cte. cteCap cte = NullCap) x s - \ real_cte_at' x s) - \ distinct (map cte_map slots) - \ valid_ipc_buffer_ptr' buffer s - \ (\(cap, slot) \ set caps'. valid_cap' cap s \ - cte_wp_at' (\cte. cap \ NullCap \ cteCap cte \ cap \ cteCap cte = maskedAsFull cap cap) slot s) - \ 2 + msg_max_length + n + length caps' < unat max_ipc_words) - (transfer_caps_loop ep buffer n caps slots mi) - (transferCapsToSlots ep buffer n caps' - (map cte_map slots) mi')" - (is "\ list_all2 ?P caps caps'; ?v \ \ ?corres") -proof (induct caps caps' arbitrary: slots n mi mi' rule: list_all2_induct) - case Nil - show ?case using Nil.prems by (case_tac mi, simp) -next - case (Cons x xs y ys slots n mi mi') - note if_weak_cong[cong] if_cong [cong del] - assume P: "?P x y" - show ?case using Cons.prems P - apply (clarsimp split del: if_split) - apply (simp add: Let_def split_def word_size liftE_bindE - word_bits_conv[symmetric] split del: if_split) - apply (rule corres_const_on_failure) - apply (simp add: dc_def[symmetric] split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_if3) - apply (case_tac "fst x", auto simp add: isCap_simps)[1] - apply (rule corres_split[OF corres_set_extra_badge]) - apply (clarsimp simp: is_cap_simps) - apply (drule conjunct1) - apply simp - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (case_tac mi, simp) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (subgoal_tac "obj_ref_of (fst x) = capEPPtr (fst y)") - prefer 2 - apply (clarsimp simp: is_cap_simps) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (rule_tac P="slots = []" and Q="slots \ []" in corres_disj_division) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (case_tac mi, simp) - apply (simp add: list_case_If2 split del: if_split) - apply (rule corres_splitEE) - apply (rule unifyFailure_discard2) - apply (case_tac mi, clarsimp) - apply (rule deriveCap_corres) - apply (simp add: remove_rights_def) - apply clarsimp - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap', auto)[1] - apply (rule corres_trivial, simp) - apply (case_tac mi, simp) - apply simp - apply (simp add: liftE_bindE) - apply (rule corres_split_nor) - apply (rule cteInsert_corres, simp_all add: hd_map)[1] - apply (simp add: tl_map) - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_vcg_const_Ball_lift cap_insert_derived_valid_arch_state - cap_insert_weak_cte_wp_at) - apply (wp hoare_vcg_const_Ball_lift | simp add:split_def del: imp_disj1)+ - apply (wp cap_insert_cte_wp_at) - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - cteInsert_valid_pspace - | simp add: split_def)+ - apply (wp cteInsert_weak_cte_wp_at hoare_valid_ipc_buffer_ptr_typ_at')+ - apply (wpsimp wp: hoare_vcg_const_Ball_lift cteInsert_cte_wp_at valid_case_option_post_wp - simp: split_def) - apply (unfold whenE_def) - apply wp+ - apply (clarsimp simp: conj_comms ball_conj_distrib split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ cap.NullCap \ - cte_wp_at (is_derived (cdt s) (a, b) cap') (a, b) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule derive_cap_is_derived) - apply (wp derive_cap_is_derived_foo)+ - apply (simp split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ capability.NullCap \ - cte_wp_at' (\c. is_derived' (ctes_of s) (cte_map (a, b)) cap' (cteCap c)) (cte_map (a, b)) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule hoare_strengthen_postE_R[OF deriveCap_derived]) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (wp deriveCap_derived_foo) - apply (clarsimp simp: cte_wp_at_caps_of_state remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI, (clarsimp split del: if_split)+) - apply (clarsimp simp:conj_comms split del:if_split) - apply (intro conjI allI) - apply (clarsimp split:if_splits) - apply (case_tac "cap = fst x",simp+) - apply (clarsimp simp:masked_as_full_def is_cap_simps cap_master_cap_simps) - apply (clarsimp split del: if_split) - apply (intro conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (drule hd_in_set) - apply (drule(1) bspec) - apply (clarsimp split:if_split_asm) - apply (fastforce simp:neq_Nil_conv) - apply (intro ballI conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (intro impI) - apply (drule(1) bspec[OF _ subsetD[rotated]]) - apply (clarsimp simp:neq_Nil_conv) - apply (clarsimp split:if_splits) - apply clarsimp - apply (intro conjI) - apply (drule(1) bspec,clarsimp)+ - subgoal for \ aa _ _ capa - by (case_tac "capa = aa"; clarsimp split:if_splits simp:masked_as_full_def is_cap_simps) - apply (case_tac "isEndpointCap (fst y) \ capEPPtr (fst y) = the ep \ (\y. ep = Some y)") - apply (clarsimp simp:conj_comms split del:if_split) - apply (subst if_not_P) - apply clarsimp - apply (clarsimp simp:valid_pspace'_def cte_wp_at_ctes_of split del:if_split) - apply (intro conjI) - apply (case_tac "cteCap cte = fst y",clarsimp simp: badge_derived'_def) - apply (clarsimp simp: maskCapRights_eq_null maskedAsFull_def badge_derived'_def isCap_simps - split: if_split_asm) - apply (clarsimp split del: if_split) - apply (case_tac "fst y = capability.NullCap") - apply (clarsimp simp: neq_Nil_conv split del: if_split)+ - apply (intro allI impI conjI) - apply (clarsimp split:if_splits) - apply (clarsimp simp:image_def)+ - apply (thin_tac "\x\set ys. Q x" for Q) - apply (drule(1) bspec)+ - apply clarsimp+ - apply (drule(1) bspec) - apply (rule conjI) - apply clarsimp+ - apply (case_tac "cteCap cteb = ab") - by (clarsimp simp: isCap_simps maskedAsFull_def split:if_splits)+ -qed - -declare constOnFailure_wp [wp] - -lemma transferCapsToSlots_pres1[crunch_rules]: - assumes x: "\cap src dest. \P\ cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\P\ transferCapsToSlots ep buffer n caps slots mi \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong - split del: if_split) - apply (rule hoare_pre) - apply (wp x eb | assumption | simp split del: if_split | wpc - | wp (once) hoare_drop_imps)+ - done - -lemma cteInsert_cte_cap_to': - "\ex_cte_cap_to' p and cte_wp_at' (\cte. cteCap cte = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_cte_cap_to' p\" - apply (simp add: ex_cte_cap_to'_def) - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (rule_tac x = "cref" in exI) - apply (rule conjI) - apply clarsimp+ + apply (case_tac arch_capability; simp add: RISCV64_H.maskCapRights_def isCap_simps) done -declare maskCapRights_eq_null[simp] +lemma capASID_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ capASID cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -crunch setExtraBadge - for ex_cte_cap_wp_to'[wp]: "ex_cte_cap_wp_to' P p" - (rule: ex_cte_cap_to'_pres) +lemma cap_asid_base'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_asid_base' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -crunch setExtraBadge - for valid_objs'[wp]: valid_objs' -crunch setExtraBadge - for aligned'[wp]: pspace_aligned' -crunch setExtraBadge - for distinct'[wp]: pspace_distinct' +lemma cap_vptr'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_vptr' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemma cteInsert_assume_Null: - "\P\ cteInsert cap src dest \Q\ \ - \\s. cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ P s\ - cteInsert cap src dest - \Q\" - apply (rule hoare_name_pre_state) - apply (erule impCE) - apply (simp add: cteInsert_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ getCTE_sp])+ - apply (rule hoare_name_pre_state) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (erule hoare_weaken_pre) - apply simp - done - -crunch setExtraBadge - for mdb'[wp]: valid_mdb' - -lemma cteInsert_weak_cte_wp_at2: - assumes weak:"\c cap. P (maskedAsFull c cap) = P c" - shows - "\\s. if p = dest then P cap else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - supply if_cong[cong] - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of weak) - apply auto - done - -lemma transferCapsToSlots_presM: - assumes x: "\cap src dest. \\s. P s \ (emx \ cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ ex_cte_cap_to' dest s) - \ (vo \ valid_objs' s \ valid_cap' cap s \ real_cte_at' dest s) - \ (drv \ cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s - \ cte_wp_at' (untyped_derived_eq cap o cteCap) src s - \ valid_mdb' s) - \ (pad \ pspace_aligned' s \ pspace_distinct' s)\ - cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\\s. P s - \ (emx \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) \ distinct slots) - \ (vo \ valid_objs' s \ (\x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set caps. s \' fst x ) \ distinct slots) - \ (pad \ pspace_aligned' s \ pspace_distinct' s) - \ (drv \ vo \ pspace_aligned' s \ pspace_distinct' s \ valid_mdb' s - \ length slots \ 1 - \ (\x \ set caps. s \' fst x \ (slots \ [] - \ cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s)))\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply (simp, wp, simp) - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong split del: if_split) - apply (rule hoare_pre) - apply (wp eb hoare_vcg_const_Ball_lift hoare_vcg_const_imp_lift - | assumption | wpc)+ - apply (rule cteInsert_assume_Null) - apply (wp x hoare_vcg_const_Ball_lift cteInsert_cte_cap_to' hoare_weak_lift_imp) - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift hoare_weak_lift_imp)+ - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift cteInsert_cte_wp_at hoare_weak_lift_imp - deriveCap_derived_foo)+ - apply (thin_tac "\slots. PROP P slots" for P) - apply (clarsimp simp: cte_wp_at_ctes_of remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI) - apply (clarsimp simp:cte_wp_at_ctes_of untyped_derived_eq_def) - apply (intro conjI allI) - apply (clarsimp simp:Fun.comp_def cte_wp_at_ctes_of)+ - apply (clarsimp simp:valid_capAligned) - done - -lemmas transferCapsToSlots_pres2 - = transferCapsToSlots_presM[where vo=False and emx=True - and drv=False and pad=False, simplified] - -crunch transferCapsToSlots - for pspace_aligned'[wp]: pspace_aligned' -crunch transferCapsToSlots - for pspace_canonical'[wp]: pspace_canonical' -crunch transferCapsToSlots - for pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' -crunch transferCapsToSlots - for pspace_distinct'[wp]: pspace_distinct' - -lemma transferCapsToSlots_typ_at'[wp]: - "\\s. P (typ_at' T p s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (typ_at' T p s)\" - by (wp transferCapsToSlots_pres1 setExtraBadge_typ_at') - -lemma transferCapsToSlots_valid_objs[wp]: - "\valid_objs' and valid_mdb' and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and (\s. \x \ set caps. s \' fst x) and K(distinct slots)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_objs'\" - apply (rule hoare_pre) - apply (rule transferCapsToSlots_presM[where vo=True and emx=False and drv=False and pad=False]) - apply (wp | simp)+ - done - -abbreviation(input) - "transferCaps_srcs caps s \ \x\set caps. cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s" - -lemma transferCapsToSlots_mdb[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_mdb'\" - apply (wpsimp wp: transferCapsToSlots_presM[where drv=True and vo=True and emx=True and pad=True]) - apply (frule valid_capAligned) - apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def badge_derived'_def) - apply wp - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarify) - apply (case_tac cte) - apply (clarsimp dest!:ctes_of_valid_cap' split:if_splits) - apply (fastforce simp:valid_cap'_def) - done - -crunch setExtraBadge - for no_0'[wp]: no_0_obj' +lemmas transferCapsToSlots_pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="transferCapsToSlots _ _ _ _ _ _"] -lemma transferCapsToSlots_no_0_obj' [wp]: - "\no_0_obj'\ transferCapsToSlots ep buffer n caps slots mi \\rv. no_0_obj'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_vp[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_pspace'\" - apply (rule hoare_pre) - apply (simp add: valid_pspace'_def | wp)+ - apply (fastforce simp: cte_wp_at_ctes_of dest: ctes_of_valid') - done - -crunch setExtraBadge, doIPCTransfer - for sch_act [wp]: "\s. P (ksSchedulerAction s)" - (wp: crunch_wps mapME_wp' simp: zipWithM_x_mapM) -crunch setExtraBadge - for pred_tcb_at' [wp]: "\s. pred_tcb_at' proj P p s" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and obj_at' [wp]: "\s. P' (obj_at' P p s)" - and queues [wp]: "\s. P (ksReadyQueues s)" - and queuesL1 [wp]: "\s. P (ksReadyQueuesL1Bitmap s)" - and queuesL2 [wp]: "\s. P (ksReadyQueuesL2Bitmap s)" - (simp: storeWordUser_def) - - -lemma tcts_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) - -crunch setExtraBadge - for state_refs_of'[wp]: "\s. P (state_refs_of' s)" - -lemma tcts_state_refs_of'[wp]: - "\\s. P (state_refs_of' s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (state_refs_of' s)\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for if_live'[wp]: if_live_then_nonz_cap' - -lemma tcts_iflive[wp]: - "\\s. if_live_then_nonz_cap' s \ distinct slots \ - (\x\set slots. - ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. if_live_then_nonz_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch setExtraBadge - for if_unsafe'[wp]: if_unsafe_then_cap' - -lemma tcts_ifunsafe[wp]: - "\\s. if_unsafe_then_cap' s \ distinct slots \ - (\x\set slots. cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s \ - ex_cte_cap_to' x s)\ transferCapsToSlots ep buffer n caps slots mi - \\rv. if_unsafe_then_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch ensureNoChildren - for it[wp]: "\s. P (ksIdleThread s)" - -crunch deriveCap - for idle'[wp]: "valid_idle'" - -crunch setExtraBadge - for valid_idle'[wp]: valid_idle' - -lemma tcts_idle'[wp]: - "\\s. valid_idle' s\ transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_idle'\" - apply (rule hoare_pre) - apply (wp transferCapsToSlots_pres1) - apply simp - done +crunch makeArchFaultMessage + for sch_act[Ipc_R_assms, wp]: "\s. P (ksSchedulerAction s)" -lemma tcts_ct[wp]: - "\cur_tcb'\ transferCapsToSlots ep buffer n caps slots mi \\rv. cur_tcb'\" - by (wp transferCapsToSlots_pres1 cur_tcb_lift) +lemma is_derived'_IRQHandlerCap[Ipc_R_assms]: + "\isIRQHandlerCap cap'\ \ is_derived' (ctes_of (s::kernel_state)) src cap' cap = + (isIRQHandlerCap cap \ badge_derived' cap' cap)" + by (clarsimp simp add: RISCV64.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) -crunch setExtraBadge - for valid_arch_state'[wp]: valid_arch_state' - -lemma transferCapsToSlots_valid_arch [wp]: - "\valid_arch_state'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_arch_state'\" - by (rule transferCapsToSlots_pres1; wp) - -crunch setExtraBadge - for valid_global_refs'[wp]: valid_global_refs' - -lemma transferCapsToSlots_valid_globals [wp]: - "\valid_global_refs' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' and K (distinct slots) - and K (length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_global_refs'\" - apply (wp transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=True] | clarsimp)+ - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done - -crunch setExtraBadge - for irq_node'[wp]: "\s. P (irq_node' s)" - -lemma transferCapsToSlots_irq_node'[wp]: - "\\s. P (irq_node' s)\ transferCapsToSlots ep buffer n caps slots mi \\rv s. P (irq_node' s)\" - by (wp transferCapsToSlots_pres1) - -lemma valid_irq_handlers_ctes_ofD: - "\ ctes_of s p = Some cte; cteCap cte = IRQHandlerCap irq; valid_irq_handlers' s \ - \ irq_issued' irq s" - by (auto simp: valid_irq_handlers'_def cteCaps_of_def ran_def) - -crunch setExtraBadge - for valid_irq_handlers'[wp]: valid_irq_handlers' - -lemma transferCapsToSlots_irq_handlers[wp]: - "\valid_irq_handlers' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' - and K(distinct slots \ length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_irq_handlers'\" - apply (wpsimp wp: transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=False]) - apply (clarsimp simp: is_derived'_def cte_wp_at_ctes_of badge_derived'_def) - apply (erule(2) valid_irq_handlers_ctes_ofD) - apply wp - apply (clarsimp simp:cte_wp_at_ctes_of | intro ballI conjI)+ - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done - -crunch setExtraBadge - for irq_state'[wp]: "\s. P (ksInterruptState s)" - -lemma setExtraBadge_irq_states'[wp]: - "\valid_irq_states'\ setExtraBadge buffer b n \\_. valid_irq_states'\" - apply (wp valid_irq_states_lift') - apply (simp add: setExtraBadge_def storeWordUser_def) - apply (wpsimp wp: no_irq dmo_lift' no_irq_storeWord) - apply assumption - done - -lemma transferCapsToSlots_irq_states' [wp]: - "\valid_irq_states'\ transferCapsToSlots ep buffer n caps slots mi \\_. valid_irq_states'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_irqs_masked'[wp]: - "\irqs_masked'\ transferCapsToSlots ep buffer n caps slots mi \\rv. irqs_masked'\" - by (wp transferCapsToSlots_pres1 irqs_masked_lift) - -lemma storeWordUser_vms'[wp]: - "\valid_machine_state'\ storeWordUser a w \\_. valid_machine_state'\" +lemma storeWordUser_vms'[Ipc_R_assms, wp]: + "storeWordUser a w \valid_machine_state'\" proof - have aligned_offset_ignore: "\(l::machine_word) (p::machine_word) sz. l<8 \ p && mask 3 = 0 \ @@ -946,743 +120,87 @@ proof - done qed -lemma setExtraBadge_vms'[wp]: - "\valid_machine_state'\ setExtraBadge buffer b n \\_. valid_machine_state'\" -by (simp add: setExtraBadge_def) wp - -lemma transferCapsToSlots_vms[wp]: - "\\s. valid_machine_state' s\ - transferCapsToSlots ep buffer n caps slots mi - \\_ s. valid_machine_state' s\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge, transferCapsToSlots - for pspace_domain_valid[wp]: "pspace_domain_valid" - -crunch setExtraBadge - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma tcts_ct_not_inQ[wp]: - "\ct_not_inQ\ - transferCapsToSlots ep buffer n caps slots mi - \\_. ct_not_inQ\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" -crunch setExtraBadge - for ctes_of[wp]: "\s. P (ctes_of s)" - -lemma tcts_zero_ranges[wp]: - "\\s. untyped_ranges_zero' s \ valid_pspace' s \ distinct slots - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. untyped_ranges_zero'\" - apply (wpsimp wp: transferCapsToSlots_presM[where emx=True and vo=True - and drv=True and pad=True]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: cteCaps_of_def) - apply (rule hoare_pre, wp untyped_ranges_zero_lift) - apply (simp add: o_def) - apply (clarsimp simp: valid_pspace'_def ball_conj_distrib[symmetric]) - apply (drule(1) bspec) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (case_tac cte, clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply auto[1] - done - -crunch transferCapsToSlots, setExtraBadge - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - -crunch transferCapsToSlots - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift) - -lemma transferCapsToSlots_invs[wp]: - "\\s. invs' s \ distinct slots - \ (\x \ set slots. cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set slots. ex_cte_cap_to' x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (wp valid_irq_node_lift valid_dom_schedule'_lift) - apply fastforce - done - -lemma grs_distinct'[wp]: - "\\\ getReceiveSlots t buf \\rv s. distinct rv\" - apply (cases buf, simp_all add: getReceiveSlots_def - split_def unlessE_def) - apply (wp, simp) - apply (wp | simp only: distinct.simps list.simps empty_iff)+ - apply simp - done - -lemma transferCaps_corres: - "\ info' = message_info_map info; - list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x)) - caps caps' \ - \ - corres ((=) \ message_info_map) - (tcb_at receiver and valid_objs and - pspace_aligned and pspace_distinct and valid_mdb - and valid_list and valid_arch_state - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame recv_buf - and (\s. valid_message_info info) - and transfer_caps_srcs caps) - (tcb_at' receiver and valid_objs' and - pspace_aligned' and pspace_distinct' and pspace_canonical' and pspace_in_kernel_mappings' - and no_0_obj' and valid_mdb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' recv_buf - and transferCaps_srcs caps' - and (\s. length caps' \ msgMaxExtraCaps)) - (transfer_caps info caps ep receiver recv_buf) - (transferCaps info' caps' ep receiver recv_buf)" - apply (simp add: transfer_caps_def transferCaps_def - getThreadCSpaceRoot) - apply (rule corres_assume_pre) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getReceiveSlots_corres]) - apply (rule_tac x=recv_buf in option_corres) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (case_tac info, simp) - apply simp - apply (rule corres_rel_imp, rule transferCapsToSlots_corres, - simp_all add: split_def)[1] - apply (case_tac info, simp) - apply (wp hoare_vcg_all_lift get_rs_cte_at hoare_weak_lift_imp - | simp only: ball_conj_distrib)+ - apply (simp add: cte_map_def tcb_cnode_index_def split_def) - apply (clarsimp simp: valid_pspace'_def valid_ipc_buffer_ptr'_def2 - split_def - cong: option.case_cong) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_caps_of_state) - apply (frule(1) Invariants_AI.caps_of_state_valid) - apply (fastforce simp:valid_cap_def) - apply (cases info) - apply (clarsimp simp: msg_max_extra_caps_def valid_message_info_def - max_ipc_words msg_max_length_def - msgMaxExtraCaps_def msgExtraCapBits_def - shiftL_nat valid_pspace'_def) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (case_tac cte,clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done - -crunch transferCaps - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas transferCaps_typ_ats[wp] = typ_at_lifts [OF transferCaps_typ_at'] - -lemma isIRQControlCap_mask [simp]: - "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" - apply (case_tac c) - apply (clarsimp simp: isCap_simps maskCapRights_def Let_def)+ - apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (clarsimp simp: isCap_simps RISCV64_H.maskCapRights_def - maskCapRights_def Let_def)+ - done +lemma isArchObjectCap_maskCapRights[Ipc_R_assms]: + "isArchObjectCap (Arch.maskCapRights R acap)" + by (cases acap; simp add: RISCV64_H.maskCapRights_def isCap_simps) lemma isFrameCap_maskCapRights[simp]: -" isArchCap isFrameCap (RetypeDecls_H.maskCapRights R c) = isArchCap isFrameCap c" - apply (case_tac c; simp add: isCap_simps isArchCap_def maskCapRights_def) + "isArchCap isFrameCap (global.maskCapRights R c) = isArchCap isFrameCap c" + apply (case_tac c; simp add: gen_isCap_simps isArchCap_def global.maskCapRights_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: isCap_simps RISCV64_H.maskCapRights_def) done -lemma capReplyMaster_mask[simp]: - "isReplyCap c \ capReplyMaster (maskCapRights R c) = capReplyMaster c" - by (clarsimp simp: isCap_simps maskCapRights_def) - -lemma is_derived_mask' [simp]: - "is_derived' m p (maskCapRights R c) = is_derived' m p c" - apply (rule ext) - apply (simp add: is_derived'_def badge_derived'_def) - done - -lemma updateCapData_ordering: - "\ (x, capBadge cap) \ capBadge_ordering P; updateCapData p d cap \ NullCap \ - \ (x, capBadge (updateCapData p d cap)) \ capBadge_ordering P" - apply (cases cap, simp_all add: updateCapData_def isCap_simps Let_def - capBadge_def RISCV64_H.updateCapData_def - split: if_split_asm) - apply fastforce+ - done - -lemma updateCapData_capReplyMaster: - "isReplyCap cap \ capReplyMaster (updateCapData p d cap) = capReplyMaster cap" - by (clarsimp simp: isCap_simps updateCapData_def split del: if_split) +lemma arch_updateCapData_ordering[Ipc_R_assms]: + "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ + \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" + by (cases acap; simp add: RISCV64_H.updateCapData_def) + fastforce -lemma updateCapData_is_Reply[simp]: - "(updateCapData p d cap = ReplyCap x y z) = (cap = ReplyCap x y z)" - by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def - RISCV64_H.updateCapData_def - split del: if_split - split: if_split_asm) +lemma ArchUpdateCapData_noReply[Ipc_R_assms]: + "Arch.updateCapData p d acap \ capability.ReplyCap x y z" + by (cases acap; simp add: RISCV64_H.updateCapData_def) -lemma updateCapDataIRQ: - "updateCapData p d cap \ NullCap \ - isIRQControlCap (updateCapData p d cap) = isIRQControlCap cap" - apply (cases cap, simp_all add: updateCapData_def isCap_simps Let_def - RISCV64_H.updateCapData_def - split: if_split_asm) - done +lemma ArchUpdateCapData_noIRQControl[Ipc_R_assms]: + "Arch.updateCapData p d acap \ IRQControlCap" + by (cases acap; simp add: RISCV64_H.updateCapData_def) lemma updateCapData_vs_cap_ref'[simp]: "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def + clarsimp simp: isCap_simps global.updateCapData_def Let_def RISCV64_H.updateCapData_def vs_cap_ref'_def split del: if_split - split: if_split_asm) + split: if_split_asm arch_capability.splits) lemma isFrameCap_updateCapData[simp]: "isArchCap isFrameCap (updateCapData pr D c) = isArchCap isFrameCap c" - apply (case_tac c; simp add:updateCapData_def isCap_simps isArchCap_def) + apply (case_tac c; simp add: global.updateCapData_def isCap_simps isArchCap_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: RISCV64_H.updateCapData_def isCap_simps isArchCap_def) apply (clarsimp split:capability.splits simp:Let_def) done -lemma lookup_cap_to'[wp]: - "\\\ lookupCap t cref \\rv s. \r\cte_refs' rv (irq_node' s). ex_cte_cap_to' r s\,-" - by (simp add: lookupCap_def lookupCapAndSlot_def | wp)+ - -lemma grs_cap_to'[wp]: - "\\\ getReceiveSlots t buf \\rv s. \x \ set rv. ex_cte_cap_to' x s\" - apply (cases buf; simp add: getReceiveSlots_def split_def unlessE_def) - apply (wp, simp) - apply (wp | simp | rule hoare_drop_imps)+ - done - -lemma grs_length'[wp]: - "\\s. 1 \ n\ getReceiveSlots receiver recv_buf \\rv s. length rv \ n\" - apply (simp add: getReceiveSlots_def split_def unlessE_def) - apply (rule hoare_pre) - apply (wp | wpc | simp)+ - done - -lemma transferCaps_invs' [wp]: - "\invs' and transferCaps_srcs caps\ - transferCaps mi caps ep receiver recv_buf - \\rv. invs'\" - apply (simp add: transferCaps_def Let_def split_def) - apply (wp get_rs_cte_at' hoare_vcg_const_Ball_lift - | wpcw | clarsimp)+ - done - -lemma get_mrs_inv'[wp]: - "\P\ getMRs t buf info \\rv. P\" - by (simp add: getMRs_def load_word_offs_def getRegister_def - | wp dmo_inv' loadWord_inv mapM_wp' - asUser_inv det_mapM[where S=UNIV] | wpc)+ - - -lemma copyMRs_typ_at': - "\\s. P (typ_at' T p s)\ copyMRs s sb r rb n \\rv s. P (typ_at' T p s)\" - by (simp add: copyMRs_def | wp mapM_wp [where S=UNIV, simplified] | wpc)+ - -lemmas copyMRs_typ_at_lifts[wp] = typ_at_lifts [OF copyMRs_typ_at'] - -lemma copy_mrs_invs'[wp]: - "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" - including classic_wp_pre - apply (simp add: copyMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord| - simp add: split_def) - apply (case_tac sb, simp_all)[1] - apply wp+ - apply (case_tac rb, simp_all)[1] - apply (wp mapM_wp dmo_invs' no_irq_mapM no_irq_storeWord no_irq_loadWord) - apply blast - apply (rule hoare_strengthen_post) - apply (rule mapM_wp) - apply (wp | simp | blast)+ - done - -crunch transferCaps - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: zipWithM_x_mapM) -crunch transferCaps - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: zipWithM_x_mapM) - -crunch setMRs - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch setMRs - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for pspace_canonical'[wp]: pspace_canonical' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) -crunch setMessageInfo - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch setMessageInfo - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) - -crunch storeWordUser - for valid_objs'[wp]: valid_objs' -crunch storeWordUser - for valid_pspace'[wp]: valid_pspace' - -lemma set_mrs_valid_objs' [wp]: - "\valid_objs'\ setMRs t a msgs \\rv. valid_objs'\" - apply (simp add: setMRs_def zipWithM_x_mapM split_def) - apply (wp asUser_valid_objs crunch_wps) - done - -crunch copyMRs - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps simp: crunch_simps) - -lemma setMRs_invs_bits[wp]: - "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\\s. P (state_refs_of' s)\ - setMRs t buf mrs - \\rv s. P (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ setMRs t buf mrs \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ setMRs t buf mrs \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ setMRs t buf mrs \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ setMRs t buf mrs \\rv. if_unsafe_then_cap'\" - by (simp add: setMRs_def zipWithM_x_mapM split_def storeWordUser_def | wp crunch_wps)+ - -crunch setMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma copyMRs_invs_bits[wp]: - "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. P (state_refs_of' s)\ - copyMRs s sb r rb n - \\rv s. P (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ copyMRs s sb r rb n \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ copyMRs s sb r rb n \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ copyMRs s sb r rb n \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ copyMRs s sb r rb n \\rv. if_unsafe_then_cap'\" - by (simp add: copyMRs_def storeWordUser_def | wp mapM_wp' | wpc)+ - -crunch copyMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma mi_map_length[simp]: "msgLength (message_info_map mi) = mi_length mi" - by (cases mi, simp) - -crunch copyMRs - for cte_wp_at'[wp]: "cte_wp_at' P p" - (wp: crunch_wps) - -lemma lookupExtraCaps_srcs[wp]: - "\\\ lookupExtraCaps thread buf info \transferCaps_srcs\,-" - apply (simp add: lookupExtraCaps_def lookupCapAndSlot_def - split_def lookupSlotForThread_def - getSlotCap_def) - apply (wp mapME_set[where R=\] getCTE_wp') - apply (rule_tac P=\ in hoare_trivE_R) - apply (simp add: cte_wp_at_ctes_of) - apply (wp | simp)+ - done - -crunch lookupExtraCaps - for inv[wp]: "P" - (wp: crunch_wps mapME_wp' simp: crunch_simps) - -lemma invs_mdb_strengthen': - "invs' s \ valid_mdb' s" by auto - -lemma lookupExtraCaps_length: - "\\s. unat (msgExtraCaps mi) \ n\ lookupExtraCaps thread send_buf mi \\rv s. length rv \ n\,-" - apply (simp add: lookupExtraCaps_def getExtraCPtrs_def) - apply (rule hoare_pre) - apply (wp mapME_length | wpc)+ - apply (clarsimp simp: upto_enum_step_def Suc_unat_diff_1 word_le_sub1) - done - -lemma getMessageInfo_msgExtraCaps[wp]: - "\\\ getMessageInfo t \\rv s. unat (msgExtraCaps rv) \ msgMaxExtraCaps\" - apply (simp add: getMessageInfo_def) - apply wp - apply (simp add: messageInfoFromWord_def Let_def msgMaxExtraCaps_def - shiftL_nat) - apply (subst nat_le_Suc_less_imp) - apply (rule unat_less_power) - apply (simp add: word_bits_def msgExtraCapBits_def) - apply (rule and_mask_less'[unfolded mask_2pm1]) - apply (simp add: msgExtraCapBits_def) - apply wpsimp+ - done - -lemma lookupCapAndSlot_corres: - "cptr = to_bl cptr' \ - corres (lfr \ (\a b. cap_relation (fst a) (fst b) \ snd b = cte_map (snd a))) - (valid_objs and pspace_aligned and tcb_at thread) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread) - (lookup_cap_and_slot thread cptr) (lookupCapAndSlot thread cptr')" - unfolding lookup_cap_and_slot_def lookupCapAndSlot_def - apply (simp add: liftE_bindE split_def) - apply (rule corres_guard_imp) - apply (rule_tac r'="\rv rv'. rv' = cte_map (fst rv)" - in corres_splitEE) - apply (rule corres_rel_imp, rule lookupSlotForThread_corres) - apply (simp add: split_def) - apply (rule corres_split[OF getSlotCap_corres]) - apply simp - apply (rule corres_returnOkTT, simp) - apply wp+ - apply (wp | simp add: liftE_bindE[symmetric])+ - done - -lemma lookupExtraCaps_corres: - "\ info' = message_info_map info; buffer = buffer'\ \ - corres (fr \ list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))) - (valid_objs and pspace_aligned and tcb_at thread and (\_. valid_message_info info)) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer') - (lookup_extra_caps thread buffer info) (lookupExtraCaps thread buffer' info')" - unfolding lookupExtraCaps_def lookup_extra_caps_def - apply (rule corres_gen_asm) - apply (cases "mi_extra_caps info = 0") - apply (cases info) - apply (simp add: Let_def returnOk_def getExtraCPtrs_def - liftE_bindE upto_enum_step_def mapM_def - sequence_def doMachineOp_return mapME_Nil - split: option.split) - apply (cases info) - apply (rename_tac w1 w2 w3 w4) - apply (simp add: Let_def liftE_bindE) - apply (cases buffer') - apply (simp add: getExtraCPtrs_def mapME_Nil) - apply (rule corres_returnOk) - apply simp - apply (simp add: msgLengthBits_def msgMaxLength_def word_size field_simps - getExtraCPtrs_def upto_enum_step_def upto_enum_word - word_size_def msg_max_length_def liftM_def - Suc_unat_diff_1 word_le_sub1 mapM_map_simp - upt_lhs_sub_map[where x=buffer_cptr_index] - wordSize_def wordBits_def - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_underlying_split) - - apply (rule_tac S = "\x y. x = y \ x < unat w2" - in corres_mapM_list_all2 - [where Q = "\_. valid_objs and pspace_aligned and tcb_at thread" and r = "(=)" - and Q' = "\_. valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer'" and r'="(=)" ]) - apply simp - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule loadWordUser_corres') - apply (clarsimp simp: buffer_cptr_index_def msg_max_length_def - max_ipc_words valid_message_info_def - msg_max_extra_caps_def word_le_nat_alt) - apply (simp add: buffer_cptr_index_def msg_max_length_def) - apply simp - apply simp - apply (simp add: load_word_offs_word_def) - apply (wp | simp)+ - apply (subst list_all2_same) - apply (clarsimp simp: max_ipc_words field_simps) - apply (simp add: mapME_def, fold mapME_def)[1] - apply (rule corres_mapME [where S = Id and r'="(\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))"]) - apply simp - apply simp - apply simp - apply (rule corres_cap_fault [OF lookupCapAndSlot_corres]) - apply simp - apply simp - apply (wp | simp)+ - apply (simp add: set_zip_same Int_lower1) - apply (wp mapM_wp [OF _ subset_refl] | simp)+ - done - -crunch copyMRs - for ctes_of[wp]: "\s. P (ctes_of s)" - (ignore: threadSet - wp: threadSet_ctes_of crunch_wps) - -lemma copyMRs_valid_mdb[wp]: - "\valid_mdb'\ copyMRs t buf t' buf' n \\rv. valid_mdb'\" - by (simp add: valid_mdb'_def copyMRs_ctes_of) - -crunch copy_mrs - for valid_arch_state[wp]: valid_arch_state - (wp: crunch_wps) - -lemma doNormalTransfer_corres: - "corres dc - (tcb_at sender and tcb_at receiver and (pspace_aligned:: det_state \ bool) - and valid_objs and cur_tcb and valid_mdb and valid_list and valid_arch_state and pspace_distinct - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame send_buf - and case_option \ in_user_frame recv_buf) - (tcb_at' sender and tcb_at' receiver and valid_objs' - and pspace_aligned' and pspace_distinct' and pspace_canonical' and cur_tcb' - and valid_mdb' and no_0_obj' and pspace_in_kernel_mappings' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' send_buf - and case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_normal_transfer sender send_buf ep badge can_grant receiver recv_buf) - (doNormalTransfer sender send_buf ep badge can_grant receiver recv_buf)" - supply if_cong[cong] - apply (simp add: do_normal_transfer_def doNormalTransfer_def) - apply (rule corres_guard_imp) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule_tac F="valid_message_info mi" in corres_gen_asm) - apply (rule_tac r'="list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))" - in corres_split) - apply (rule corres_if[OF refl]) - apply (rule corres_split_catch) - apply (rule lookupExtraCaps_corres; simp) - apply (rule corres_trivial, simp) - apply wp+ - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_split_eqr[OF copyMRs_corres]) - apply (rule corres_split) - apply (rule transferCaps_corres; simp) - apply (rename_tac mi' mi'') - apply (rule_tac F="mi_label mi' = mi_label mi" - in corres_gen_asm) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply (case_tac mi', clarsimp) - apply (simp add: badge_register_def badgeRegister_def) - apply (fold dc_def) - apply (rule asUser_setRegister_corres) - apply wp - apply simp+ - apply ((wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_case_option_wp - hoare_valid_ipc_buffer_ptr_typ_at' copyMRs_typ_at' - hoare_vcg_const_Ball_lift lookupExtraCaps_length - | simp add: if_apply_def2)+) - apply (wp hoare_weak_lift_imp | strengthen valid_msg_length_strengthen)+ - apply clarsimp - apply auto - done - -lemma corres_liftE_lift: - "corres r1 P P' m m' \ - corres (f1 \ r1) P P' (liftE m) (withoutFailure m')" - by simp - -lemmas corres_ipc_thread_helper = - corres_split_eqrE[OF corres_liftE_lift [OF getCurThread_corres]] - -lemmas corres_ipc_info_helper = - corres_split_maprE [where f = message_info_map, OF _ - corres_liftE_lift [OF getMessageInfo_corres]] - -crunch doNormalTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas doNormal_lifts[wp] = typ_at_lifts [OF doNormalTransfer_typ_at'] - -lemma doNormal_invs'[wp]: - "\tcb_at' sender and tcb_at' receiver and invs'\ - doNormalTransfer sender send_buf ep badge - can_grant receiver recv_buf \\r. invs'\" - apply (simp add: doNormalTransfer_def) - apply (wp hoare_vcg_const_Ball_lift | simp)+ - done - -crunch doNormalTransfer - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps) -crunch doNormalTransfer - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps) - -lemma transferCaps_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' - and (\s. (\x\set caps. cte_wp_at' (\cte. fst x \ capability.NullCap \ cteCap cte = fst x) (snd x) s))\ - transferCaps tag caps ep receiver recv_buf - \\r. untyped_ranges_zero'\" - apply (simp add: transferCaps_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift hoare_vcg_const_imp_lift - | wpc - | simp add: ball_conj_distrib)+ - apply clarsimp - done - -crunch doNormalTransfer - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 ignore: constOnFailure) - -lemmas asUser_urz = untyped_ranges_zero_lift[OF asUser_gsUntypedZeroRanges] - -crunch doNormalTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: asUser wp: crunch_wps asUser_urz hoare_vcg_const_Ball_lift) - -lemma msgFromLookupFailure_map[simp]: - "msgFromLookupFailure (lookup_failure_map lf) - = msg_from_lookup_failure lf" - by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) +lemma get_mrs_inv'[Ipc_R_assms, wp]: + "getMRs t buf info \P\" + by (wpsimp wp: dmo_inv' loadWord_inv mapM_wp' asUser_inv det_mapM[where S=UNIV] + simp: getMRs_def load_word_offs_def getRegister_def) -lemma asUser_getRestartPC_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t getRestartPC) (asUser t getRestartPC)" - apply (rule asUser_corres') - apply (rule corres_Id, simp, simp) - apply (rule no_fail_getRestartPC) - done +lemma badgeRegister_badge_register[Ipc_R_assms]: + "badgeRegister = badge_register" + by (simp add: badge_register_def badgeRegister_def) -lemma asUser_mapM_getRegister_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t (mapM getRegister regs)) - (asUser t (mapM getRegister regs))" - apply (rule asUser_corres') - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_mapM) - apply (simp add: getRegister_def) - done +lemmas copyMRs__pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="copyMRs _ _ _ _ _"] -lemma makeArchFaultMessage_corres: +lemma makeArchFaultMessage_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_arch_fault_msg f t) - (makeArchFaultMessage (arch_fault_map f) t)" - apply (cases f, clarsimp simp: makeArchFaultMessage_def split: arch_fault.split) + (make_arch_fault_msg f t) + (makeArchFaultMessage (arch_fault_map f) t)" + apply (cases f; clarsimp simp: makeArchFaultMessage_def ucast_nat_def split: arch_fault.split) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_trivial, simp add: arch_fault_map_def) + apply (rule corres_trivial, simp) apply (wp+, auto) done -lemma makeFaultMessage_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_fault_msg ft t) - (makeFaultMessage (fault_map ft) t)" - apply (cases ft, simp_all add: makeFaultMessage_def split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_trivial, simp add: fromEnum_def enum_bool) - apply (wp | simp)+ - apply (simp add: RISCV64_H.syscallMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (simp add: RISCV64_H.exceptionMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (rule makeArchFaultMessage_corres) - done - -lemma makeFaultMessage_inv[wp]: - "\P\ makeFaultMessage ft t \\rv. P\" - apply (cases ft, simp_all add: makeFaultMessage_def) - apply (wp asUser_inv mapM_wp' det_mapM[where S=UNIV] - det_getRestartPC getRestartPC_inv - | clarsimp simp: getRegister_def makeArchFaultMessage_def - split: arch_fault.split)+ - done +lemma syscallMessage_def'[Ipc_R_assms]: + "FaultHandler_H.syscallMessage \ MachineExports.syscallMessage" + by (simp add: syscallMessage_def) -lemmas threadget_fault_corres = - threadGet_corres [where r = fault_rel_optionation - and f = tcb_fault and f' = tcbFault, - simplified tcb_relation_def, simplified] - -lemma doFaultTransfer_corres: - "corres dc - (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender - and tcb_at receiver and case_option \ in_user_frame recv_buf - and pspace_aligned and pspace_distinct) - (case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_fault_transfer badge sender receiver recv_buf) - (doFaultTransfer badge sender receiver recv_buf)" - apply (clarsimp simp: do_fault_transfer_def doFaultTransfer_def split_def - RISCV64_H.badgeRegister_def badge_register_def) - apply (rule_tac Q="\fault. K (\f. fault = Some f) and - tcb_at sender and tcb_at receiver and - case_option \ in_user_frame recv_buf and - pspace_aligned and pspace_distinct" - and Q'="\fault'. case_option \ valid_ipc_buffer_ptr' recv_buf" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply (clarsimp simp: obj_at_def is_tcb)+ - apply (rule corres_assume_pre) - apply (fold assert_opt_def | unfold haskell_fail_def)+ - apply (rule corres_assert_opt_assume) - apply (clarsimp split: option.splits - simp: fault_rel_optionation_def assert_opt_def - map_option_case) - defer - defer - apply (clarsimp simp: fault_rel_optionation_def) - apply (wp thread_get_wp) - apply (clarsimp simp: obj_at_def is_tcb) - apply wp - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - done +lemma exceptionMessage_def'[Ipc_R_assms]: + "FaultHandler_H.exceptionMessage \ MachineExports.exceptionMessage" + by (simp add: exceptionMessage_def) -lemma doFaultTransfer_invs[wp]: - "\invs' and tcb_at' receiver\ - doFaultTransfer badge sender receiver recv_buf - \\rv. invs'\" - by (simp add: doFaultTransfer_def split_def | wp - | clarsimp split: option.split)+ +lemma makeArchFaultMessage_inv[Ipc_R_assms, wp]: + "makeArchFaultMessage ft t \P\" + unfolding makeArchFaultMessage_def + by (wpsimp wp: asUser_inv getRestartPC_inv split: arch_fault.split) -lemma lookupIPCBuffer_valid_ipc_buffer [wp]: +lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" - unfolding lookupIPCBuffer_def RISCV64_H.lookupIPCBuffer_def + unfolding lookupIPCBuffer_def supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def locateSlot_conv threadGet_def comp_def) @@ -1722,2699 +240,78 @@ lemma lookupIPCBuffer_valid_ipc_buffer [wp]: apply (simp add: word_bits_conv pbfs_less_wb'[unfolded word_bits_conv]) done -lemma doIPCTransfer_corres: - "corres dc - (tcb_at s and tcb_at r and valid_objs and pspace_aligned - and valid_list and valid_arch_state - and pspace_distinct and valid_mdb and cur_tcb - and (\s. case ep of Some x \ ep_at x s | _ \ True)) - (tcb_at' s and tcb_at' r and valid_pspace' and cur_tcb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True)) - (do_ipc_transfer s ep bg grt r) - (doIPCTransfer s ep bg grt r)" - apply (simp add: do_ipc_transfer_def doIPCTransfer_def) - apply (rule_tac Q="\receiveBuffer sa. tcb_at s sa \ valid_objs sa \ - pspace_aligned sa \ pspace_distinct sa \ tcb_at r sa \ - cur_tcb sa \ valid_mdb sa \ valid_list sa \ valid_arch_state sa \ - (case ep of None \ True | Some x \ ep_at x sa) \ - case_option (\_. True) in_user_frame receiveBuffer sa \ - obj_at (\ko. \tcb. ko = TCB tcb - \ \\ft. tcb_fault tcb = Some ft\) s sa" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule lookupIPCBuffer_corres') - apply auto[2] - apply (rule corres_underlying_split [OF _ _ thread_get_sp threadGet_inv]) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply simp - defer - apply (rule corres_guard_imp) - apply (subst case_option_If)+ - apply (rule corres_if3) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (simp add: dc_def[symmetric]) - apply (rule doNormalTransfer_corres) - apply (wp | simp add: valid_pspace'_def)+ - apply (simp add: dc_def[symmetric]) - apply (rule doFaultTransfer_corres) - apply (clarsimp simp: obj_at_def) - apply (erule ignore_if) - apply (wp|simp add: obj_at_def is_tcb valid_pspace'_def)+ - done - - -crunch doIPCTransfer - for ifunsafe[wp]: "if_unsafe_then_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -crunch doIPCTransfer - for iflive[wp]: "if_live_then_nonz_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -lemma valid_pspace_valid_objs'[elim!]: - "valid_pspace' s \ valid_objs' s" - by (simp add: valid_pspace'_def) -crunch doIPCTransfer - for vp[wp]: "valid_pspace'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) -crunch doIPCTransfer - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for state_refs_of[wp]: "\s. P (state_refs_of' s)" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for ct[wp]: "cur_tcb'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for idle'[wp]: "valid_idle'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) -lemmas dit'_typ_ats[wp] = typ_at_lifts [OF doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: crunch_wps simp: crunch_simps) - -lemmas dit_irq_node'[wp] - = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for valid_arch_state'[wp]: "valid_arch_state'" - (wp: crunch_wps simp: crunch_simps) - -(* Levity: added (20090126 19:32:26) *) -declare asUser_global_refs' [wp] +(* Used in CRefine *) +lemma lookupIPCBuffer_Some_0: + "\\\ lookupIPCBuffer w t \\rv s. rv \ Some 0\" + by (wpsimp simp: lookupIPCBuffer_def Let_def getThreadBufferSlot_def locateSlot_conv) -lemma lec_valid_cap' [wp]: - "\valid_objs'\ lookupExtraCaps thread xa mi \\rv s. (\x\set rv. s \' fst x)\, -" - apply (rule hoare_pre, rule hoare_strengthen_postE_R) - apply (rule hoare_vcg_conj_liftE_R[where P'=valid_objs' and Q'="\_. valid_objs'"]) - apply (rule lookupExtraCaps_srcs) - apply wp - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (fastforce elim: ctes_of_valid') - apply simp - done - -crunch doIPCTransfer - for objs'[wp]: "valid_objs'" - ( wp: crunch_wps hoare_vcg_const_Ball_lift - transferCapsToSlots_valid_objs - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for global_refs'[wp]: "valid_global_refs'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_global_refsT - transferCapsToSlots_valid_globals - simp: zipWithM_x_mapM ball_conj_distrib) - -declare asUser_irq_handlers' [wp] - -crunch doIPCTransfer - for irq_handlers'[wp]: "valid_irq_handlers'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_irq_handlers' - transferCapsToSlots_irq_handlers - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for irq_states'[wp]: "valid_irq_states'" - (wp: crunch_wps no_irq no_irq_mapM no_irq_storeWord no_irq_loadWord - no_irq_case_option simp: crunch_simps zipWithM_x_mapM) - -crunch doIPCTransfer - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps simp: crunch_simps rule: irqs_masked_lift) - -lemma doIPCTransfer_invs[wp]: - "\invs' and tcb_at' s and tcb_at' r\ - doIPCTransfer s ep bg grt r - \\rv. invs'\" - apply (simp add: doIPCTransfer_def) - apply (wpsimp wp: hoare_drop_imp) - done - -lemma sanitise_register_corres: - "foldl (\s (a, b). UserContext ((user_regs s)(a := sanitise_register x a b))) s - (zip msg_template msg) = - foldl (\s (a, b). UserContext ((user_regs s)(a := sanitiseRegister y a b))) s - (zip msg_template msg)" - apply (rule foldl_cong) - apply simp - apply simp - apply (clarsimp) - apply (rule arg_cong) - apply (clarsimp simp: sanitise_register_def sanitiseRegister_def) - done - -lemma handle_fault_reply_registers_corres: +lemma arch_getSanitiseRegisterInfo_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (do t' \ arch_get_sanitise_register_info t; - y \ as_user t - (zipWithM_x - (\r v. setRegister r - (sanitise_register t' r v)) - msg_template msg); - return (label = 0) - od) - (do t' \ getSanitiseRegisterInfo t; - y \ asUser t - (zipWithM_x - (\r v. setRegister r (sanitiseRegister t' r v)) - msg_template msg); - return (label = 0) - od)" - apply (rule corres_guard_imp) - apply (clarsimp simp: arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def) - apply (rule corres_split) - apply (rule asUser_corres') - apply(simp add: setRegister_def syscallMessage_def) - apply(subst zipWithM_x_modify)+ - apply(rule corres_modify') - apply (clarsimp simp: sanitise_register_corres|wp)+ - done - -lemma handleFaultReply_corres: - "ft' = fault_map ft \ - corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (handle_fault_reply ft t label msg) - (handleFaultReply ft' t label msg)" - apply (cases ft) - apply(simp_all add: handleFaultReply_def - handle_arch_fault_reply_def handleArchFaultReply_def - syscallMessage_def exceptionMessage_def - split: arch_fault.split) - by (rule handle_fault_reply_registers_corres)+ - -crunch handleFaultReply - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas hfr_typ_ats[wp] = typ_at_lifts [OF handleFaultReply_typ_at'] - -crunch handleFaultReply - for ct'[wp]: "\s. P (ksCurThread s)" - -lemma doIPCTransfer_sch_act_simple [wp]: - "\sch_act_simple\ doIPCTransfer sender endpoint badge grant receiver \\_. sch_act_simple\" - by (simp add: sch_act_simple_def, wp) - -lemma possibleSwitchTo_invs'[wp]: - "\invs' and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - possibleSwitchTo t \\_. invs'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp tcbSchedEnqueue_invs' ssa_invs') - apply (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt]) - apply (wpsimp wp: ssa_invs' threadGet_wp)+ - apply (clarsimp dest!: obj_at_ko_at' simp: tcb_in_cur_domain'_def obj_at'_def) - done - -crunch isFinalCapability - for cur'[wp]: "\s. P (cur_tcb' s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch deleteCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma getThreadCallerSlot_inv: - "\P\ getThreadCallerSlot t \\_. P\" - by (simp add: getThreadCallerSlot_def, wp) - -lemma finaliseCapTrue_standin_tcb_at' [wp]: - "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp getObject_ntfn_inv - | wpc - | simp)+ - done - -lemma finaliseCapTrue_standin_cur': - "\\s. cur_tcb' s\ finaliseCapTrue_standin cap v2 \\_ s'. cur_tcb' s'\" - apply (simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ finaliseCapTrue_standin_ct']) - apply (wp) - done - -lemma cteDeleteOne_cur' [wp]: - "\\s. cur_tcb' s\ cteDeleteOne slot \\_ s'. cur_tcb' s'\" - apply (simp add: cteDeleteOne_def unless_def when_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def | wp (once) cur_tcb_lift)+ - done + (arch_get_sanitise_register_info t) + (getSanitiseRegisterInfo t)" + unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def + by (fold archThreadGet_def, corres) -lemma handleFaultReply_cur' [wp]: - "\\s. cur_tcb' s\ handleFaultReply x0 thread label msg \\_ s'. cur_tcb' s'\" - apply (clarsimp simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ handleFaultReply_ct']) - apply (wp) - done - -lemma capClass_Reply: - "capClass cap = ReplyClass tcb \ isReplyCap cap \ capTCBPtr cap = tcb" - apply (cases cap, simp_all add: isCap_simps) - apply (rename_tac arch_capability) - apply (case_tac arch_capability, simp_all) - done - -lemma reply_cap_end_mdb_chain: - "\ cte_wp_at (is_reply_cap_to t) slot s; invs s; - invs' s'; - (s, s') \ state_relation; ctes_of s' (cte_map slot) = Some cte \ - \ (mdbPrev (cteMDBNode cte) \ nullPointer - \ mdbNext (cteMDBNode cte) = nullPointer) - \ cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) - (mdbPrev (cteMDBNode cte)) s'" - apply (clarsimp simp only: cte_wp_at_reply_cap_to_ex_rights) - apply (frule(1) pspace_relation_ctes_ofI[OF state_relation_pspace_relation], - clarsimp+) - apply (subgoal_tac "\slot' rights'. caps_of_state s slot' = Some (cap.ReplyCap t True rights') - \ descendants_of slot' (cdt s) = {slot}") - apply (elim state_relationE exE) - apply (clarsimp simp: cdt_relation_def - simp del: split_paired_All) - apply (drule spec, drule(1) mp[OF _ caps_of_state_cte_at]) - apply (frule(1) pspace_relation_cte_wp_at[OF _ caps_of_state_cteD], - clarsimp+) - apply (clarsimp simp: descendants_of'_def cte_wp_at_ctes_of) - apply (frule_tac f="\S. cte_map slot \ S" in arg_cong, simp(no_asm_use)) - apply (frule invs_mdb'[unfolded valid_mdb'_def]) - apply (rule context_conjI) - apply (clarsimp simp: nullPointer_def valid_mdb_ctes_def) - apply (erule(4) subtree_prev_0) - apply (rule conjI) - apply (rule ccontr) - apply (frule valid_mdb_no_loops, simp add: no_loops_def) - apply (drule_tac x="cte_map slot" in spec) - apply (erule notE, rule r_into_trancl, rule ccontr) - apply (clarsimp simp: mdb_next_unfold valid_mdb_ctes_def nullPointer_def) - apply (rule valid_dlistEn, assumption+) - apply (subgoal_tac "ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)") - apply (frule(3) class_linksD) - apply (clarsimp simp: isCap_simps dest!: capClass_Reply[OF sym]) - apply (drule_tac f="\S. mdbNext (cteMDBNode cte) \ S" in arg_cong) - apply (simp, erule notE, rule subtree.trans_parent, assumption+) - apply (case_tac ctea, case_tac cte') - apply (clarsimp simp add: parentOf_def isMDBParentOf_CTE) - apply (simp add: sameRegionAs_def2 isCap_simps) - apply (erule subtree.cases) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (simp add: mdb_next_unfold) - apply (erule subtree.cases) - apply (clarsimp simp: valid_mdb_ctes_def) - apply (erule_tac cte=ctea in valid_dlistEn, assumption) - apply (simp add: mdb_next_unfold) - apply (clarsimp simp: mdb_next_unfold isCap_simps) - apply (drule_tac f="\S. c' \ S" in arg_cong) - apply (clarsimp simp: no_loops_direct_simp valid_mdb_no_loops) - apply (frule invs_mdb) - apply (drule invs_valid_reply_caps) - apply (clarsimp simp: valid_mdb_def reply_mdb_def - valid_reply_caps_def reply_caps_mdb_def - cte_wp_at_caps_of_state - simp del: split_paired_All) - apply (erule_tac x=slot in allE, erule_tac x=t in allE, erule impE, fast) - apply (elim exEI) - apply clarsimp - apply (subgoal_tac "P" for P, rule sym, rule equalityI, assumption) - apply clarsimp - apply (erule(4) unique_reply_capsD) - apply (simp add: descendants_of_def) - apply (rule r_into_trancl) - apply (simp add: cdt_parent_rel_def is_cdt_parent_def) - done - -lemma unbindNotification_valid_objs'_strengthen: - "valid_tcb' tcb s \ valid_tcb' (tcbBoundNotification_update Map.empty tcb) s" - "valid_ntfn' ntfn s \ valid_ntfn' (ntfnBoundTCB_update Map.empty ntfn) s" - by (simp_all add: unbindNotification_valid_objs'_helper' unbindNotification_valid_objs'_helper) - -crunch cteDeleteOne - for valid_objs'[wp]: "valid_objs'" - (simp: crunch_simps unless_def - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch handleFaultReply - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma emptySlot_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - emptySlot slot irq - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp weak_sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma cancelAllIPC_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllIPC epptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllIPC_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -lemma cancelAllSignals_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllSignals ntfnptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllSignals_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -crunch finaliseCapTrue_standin - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (ignore: setThreadState - simp: crunch_simps - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma cteDeleteOne_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cteDeleteOne sl - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def)+ - done - -crunch emptySlot - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - -crunch handleFaultReply - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" -crunch handleFaultReply - for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - -crunch unbindNotification - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" -(wp: sbn_sch_act') - -crunch handleFaultReply - for valid_objs'[wp]: valid_objs' - -lemma cte_wp_at_is_reply_cap_toI: - "cte_wp_at ((=) (cap.ReplyCap t False rights)) ptr s - \ cte_wp_at (is_reply_cap_to t) ptr s" - by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) - -crunch handle_fault_reply - for pspace_alignedp[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - -crunch cteDeleteOne, doIPCTransfer, handleFaultReply - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -lemma doReplyTransfer_corres: - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at ((=) (cap.ReplyCap receiver False rights)) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - apply (simp add: do_reply_transfer_def doReplyTransfer_def cong: option.case_cong) - apply (rule corres_underlying_split [OF _ _ gts_sp gts_sp']) - apply (rule corres_guard_imp) - apply (rule getThreadState_corres, (clarsimp simp add: st_tcb_at_tcb_at invs_distinct invs_psp_aligned)+) - apply (rule_tac F = "awaiting_reply state" in corres_req) - apply (clarsimp simp add: st_tcb_at_def obj_at_def is_tcb) - apply (fastforce simp: invs_def valid_state_def intro: has_reply_cap_cte_wpD - dest: has_reply_cap_cte_wpD - dest!: valid_reply_caps_awaiting_reply cte_wp_at_is_reply_cap_toI) - apply (case_tac state, simp_all add: bind_assoc) - apply (simp add: isReply_def liftM_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply clarsimp - apply (rename_tac mdbnode) - apply (rule_tac P="Q" and Q="Q" and P'="Q'" and Q'="(\s. Q' s \ R' s)" for Q Q' R' - in stronger_corres_guard_imp[rotated]) - apply assumption - apply (rule conjI, assumption) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (drule cte_wp_at_is_reply_cap_toI) - apply (erule(4) reply_cap_end_mdb_chain) - apply (rule corres_assert_assume[rotated], simp) - apply (simp add: getSlotCap_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_assert_assume[rotated]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_guard_imp) - apply (rule corres_split[OF threadget_fault_corres]) - apply (case_tac rv, simp_all add: fault_rel_optionation_def bind_assoc)[1] - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched - set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' - sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def - | strengthen valid_queues_in_correct_ready_q valid_sched_valid_queues - valid_queues_ready_qs_distinct)+ - apply (strengthen cte_wp_at_reply_cap_can_fast_finalise) - apply (wp hoare_vcg_conj_lift) - apply (rule hoare_strengthen_post [OF do_ipc_transfer_non_null_cte_wp_at]) - prefer 2 - apply (erule cte_wp_at_weakenE) - apply (fastforce) - apply (clarsimp simp:is_cap_simps) - apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q'="\_ s. valid_objs' s \ cur_tcb' s \ tcb_at' receiver s - \ sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp, simp add: sch_act_wf_weak) - apply (wp tcb_in_cur_domain'_lift) - defer - apply (simp) - apply (wp)+ - apply (clarsimp simp: invs_psp_aligned invs_distinct) - apply (rule conjI, erule invs_valid_objs) - apply (rule conjI, clarsimp)+ - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp) - apply (rule conjI, rule refl) - apply (fastforce) - apply (clarsimp simp: invs_def valid_sched_def valid_sched_action_def invs_psp_aligned invs_distinct) - apply (simp) - apply (auto simp: invs'_def valid_state'_def)[1] - - apply (rule corres_guard_imp) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (rule corres_split_eqr[OF getMRs_corres]) - apply (simp(no_asm) del: dc_simp) - apply (rule corres_split_eqr[OF handleFaultReply_corres]) - apply simp - apply (rule corres_split) - apply (rule threadset_corresT; - clarsimp simp add: tcb_relation_def fault_rel_optionation_def cteSizeBits_def - tcb_cap_cases_def tcb_cte_cases_def inQ_def) - apply (rule_tac Q="valid_sched and cur_tcb and tcb_at receiver and pspace_aligned and pspace_distinct" - and Q'="tcb_at' receiver and cur_tcb' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and valid_objs' - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_guard_imp) - apply (case_tac rvb, simp_all)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (fold dc_def, rule possibleSwitchTo_corres) - apply simp - apply (wp hoare_weak_lift_imp hoare_weak_lift_imp_conj set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' - | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ - apply (rule corres_guard_imp) - apply (rule setThreadState_corres) - apply (clarsimp simp: tcb_relation_def) - apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched - threadSet_tcbDomain_triv threadSet_valid_objs' - threadSet_sched_pointers threadSet_valid_sched_pointers - | simp add: valid_tcb_state'_def)+ - apply (rule_tac Q'="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and - valid_objs and pspace_aligned and pspace_distinct" - in hoare_strengthen_post [rotated], clarsimp) - apply (wp) - apply (rule hoare_chain [OF cap_delete_one_invs]) - apply (assumption) - apply (rule conjI, clarsimp) - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def) - apply (rule_tac Q'="\_. tcb_at' sender and tcb_at' receiver and invs'" - in hoare_strengthen_post [rotated]) - apply (solves\auto simp: invs'_def valid_state'_def\) - apply wp - apply clarsimp - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp simp add: can_fast_finalise_def) - apply (erule(1) emptyable_cte_wp_atD) - apply (rule allI, rule impI) - apply (clarsimp simp add: is_master_reply_cap_def) - apply (clarsimp) - done - -(* when we cannot talk about reply cap rights explicitly (for instance, when a schematic ?rights - would be generated too early *) -lemma doReplyTransfer_corres': - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at (is_reply_cap_to receiver) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - using doReplyTransfer_corres[of receiver sender _ slot] - by (fastforce simp add: cte_wp_at_reply_cap_to_ex_rights corres_underlying_def) - -lemma valid_pspace'_splits[elim!]: - "valid_pspace' s \ valid_objs' s" - "valid_pspace' s \ pspace_aligned' s" - "valid_pspace' s \ pspace_canonical' s" - "valid_pspace' s \ pspace_in_kernel_mappings' s" - "valid_pspace' s \ pspace_distinct' s" - "valid_pspace' s \ valid_mdb' s" - "valid_pspace' s \ no_0_obj' s" - by (simp add: valid_pspace'_def)+ - -lemma sts_valid_pspace_hangers: - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. valid_objs'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_distinct'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_aligned'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_canonical'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_in_kernel_mappings'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. valid_mdb'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. no_0_obj'\" - by (safe intro!: hoare_strengthen_post [OF sts'_valid_pspace'_inv]) - -declare no_fail_getSlotCap [wp] - -lemma setupCallerCap_corres: - "corres dc - (st_tcb_at (Not \ halted) sender and tcb_at receiver and - st_tcb_at (Not \ awaiting_reply) sender and valid_reply_caps and - valid_objs and pspace_distinct and pspace_aligned and valid_mdb - and valid_list and valid_arch_state and - valid_reply_masters and cte_wp_at (\c. c = cap.NullCap) (receiver, tcb_cnode_index 3)) - (tcb_at' sender and tcb_at' receiver and valid_pspace' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) - (setup_caller_cap sender receiver grant) - (setupCallerCap sender receiver grant)" - supply if_split[split del] - apply (simp add: setup_caller_cap_def setupCallerCap_def - getThreadReplySlot_def locateSlot_conv - getThreadCallerSlot_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split_nor) - apply (rule setThreadState_corres) - apply (simp split: option.split) - apply (rule corres_symb_exec_r) - apply (rule_tac F="\r. cteCap masterCTE = capability.ReplyCap sender True r - \ mdbNext (cteMDBNode masterCTE) = nullPointer" - in corres_gen_asm2, clarsimp simp add: isCap_simps) - apply (rule corres_symb_exec_r) - apply (rule_tac F="rv = capability.NullCap" - in corres_gen_asm2, simp) - apply (rule cteInsert_corres) - apply (simp split: if_splits) - apply (simp add: cte_map_def tcbReplySlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (simp add: cte_map_def tcbCallerSlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (rule_tac Q'="\rv. cte_at' (receiver + 2 ^ cte_level_bits * tcbCallerSlot)" - in hoare_post_add) - - apply (wp, (wp getSlotCap_wp)+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at'_def cte_at'_def) - apply (rule_tac Q'="\rv. cte_at' (sender + 2 ^ cte_level_bits * tcbReplySlot)" - in hoare_post_add) - apply (wp, (wp getCTE_wp')+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (wp sts_valid_pspace_hangers - | simp add: cte_wp_at_ctes_of)+ - apply (clarsimp simp: valid_tcb_state_def st_tcb_at_reply_cap_valid - st_tcb_at_tcb_at st_tcb_at_caller_cap_null - split: option.split) - apply (clarsimp simp: valid_tcb_state'_def valid_cap'_def capAligned_reply_tcbI) - apply (frule(1) st_tcb_at_reply_cap_valid, simp, clarsimp) - apply (clarsimp simp: cte_wp_at_ctes_of cte_wp_at_caps_of_state) - apply (drule pspace_relation_cte_wp_at[rotated, OF caps_of_state_cteD], - erule valid_pspace'_splits, clarsimp+)+ - apply (clarsimp simp: cte_wp_at_ctes_of cte_map_def tcbReplySlot_def - tcbCallerSlot_def tcb_cnode_index_def - is_cap_simps) - apply (auto intro: reply_no_descendants_mdbNext_null[OF not_waiting_reply_slot_no_descendants] - simp: cte_level_bits_def) - done - -crunch getThreadCallerSlot +crunch getSanitiseRegisterInfo for tcb_at'[wp]: "tcb_at' t" -lemma getThreadReplySlot_tcb_at'[wp]: - "\tcb_at' t\ getThreadReplySlot tcb \\_. tcb_at' t\" - by (simp add: getThreadReplySlot_def, wp) - -lemma setupCallerCap_tcb_at'[wp]: - "\tcb_at' t\ setupCallerCap sender receiver grant \\_. tcb_at' t\" - by (simp add: setupCallerCap_def, wp hoare_drop_imp) - -crunch setupCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps) - -lemma cteInsert_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert newCap srcSlot destSlot - \\_ s. sch_act_wf (ksSchedulerAction s) s\" -by (wp sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma setupCallerCap_sch_act [wp]: - "\\s. sch_act_not t s \ sch_act_wf (ksSchedulerAction s) s\ - setupCallerCap t r g \\_ s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: setupCallerCap_def getSlotCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv) - apply (wp getCTE_wp' sts_sch_act' hoare_drop_imps hoare_vcg_all_lift) - apply clarsimp - done - -lemma possibleSwitchTo_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def threadGet_def curDomain_def - bitmap_fun_defs) - apply (wp rescheduleRequired_weak_sch_act_wf - weak_sch_act_wf_lift_linear[where f="tcbSchedEnqueue t"] - getObject_tcb_wp hoare_weak_lift_imp - | wpc)+ - apply (clarsimp simp: obj_at'_def projectKOs weak_sch_act_wf_def ps_clear_def tcb_in_cur_domain'_def) - done - -lemmas transferCapsToSlots_pred_tcb_at' = - transferCapsToSlots_pres1 [OF cteInsert_pred_tcb_at'] - -crunch doIPCTransfer, possibleSwitchTo - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - (wp: mapM_wp' crunch_wps simp: zipWithM_x_mapM) - -lemma setSchedulerAction_ct_in_domain: - "\\s. ct_idle_or_in_cur_domain' s - \ p \ ResumeCurrentThread \ setSchedulerAction p - \\_. ct_idle_or_in_cur_domain'\" - by (simp add:setSchedulerAction_def | wp)+ - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - (wp: crunch_wps setSchedulerAction_ct_in_domain simp: zipWithM_x_mapM) -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" - (wp: crunch_wps constOnFailure_wp simp: crunch_simps) - -crunch possibleSwitchTo - for tcb_at'[wp]: "tcb_at' t" - (wp: crunch_wps) - -crunch possibleSwitchTo - for valid_pspace'[wp]: valid_pspace' - (wp: crunch_wps) - -lemma sendIPC_corres: -(* call is only true if called in handleSyscall SysCall, which - is always blocking. *) - assumes "call \ bl" - shows - "corres dc (einvs and st_tcb_at active t and ep_at ep and ex_nonz_cap_to t) - (invs' and sch_act_not t and tcb_at' t and ep_at' ep) - (send_ipc bl call bg cg cgr t ep) (sendIPC bl call bg cg cgr t ep)" -proof - - show ?thesis - apply (insert assms) - apply (unfold send_ipc_def sendIPC_def Let_def) - apply (case_tac bl) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\ob. ob = Endpoint rv) ep - and ex_nonz_cap_to t" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (case_tac rv) - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) - apply clarsimp - \ \concludes IdleEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) - apply clarsimp - \ \concludes SendEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (simp add: isReceive_def split del:if_split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: case_bool_If case_option_If if3_fold - simp del: dc_simp split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_split[OF possibleSwitchTo_corres]) - apply (fold when_def)[1] - apply (rule_tac P="call" and P'="call" - in corres_symmetric_bool_cases, blast) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (rule corres_if2, simp) - apply (rule setupCallerCap_corres) - apply (rule setThreadState_corres, simp) - apply (rule corres_trivial) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (wp | simp)+ - apply (wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases) - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases)[1] - apply (simp add: valid_tcb_state_def pred_conj_def) - apply (strengthen reply_cap_doesnt_exist_strg disjI2_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues)+ - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - do_ipc_transfer_valid_arch - | clarsimp simp: is_cap_simps)+)[1] - apply (simp add: pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift hoare_drop_imps)[1] - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply (simp) - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb')+ - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def ep_redux_simps - ep_redux_simps' st_tcb_at_tcb_at valid_ep_def - cong: list.case_cong) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_def2 valid_sched_def valid_sched_action_def) - apply (force simp: st_tcb_def2 dest!: st_tcb_at_caller_cap_null[simplified,rotated]) - subgoal by (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\k. k = Endpoint rv) ep" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (rename_tac rv rv') - apply (case_tac rv) - apply (simp add: ep_relation_def) - \ \concludes IdleEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - \ \concludes SendEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (rule_tac F="a \ t" in corres_req) - apply (clarsimp simp: invs_def valid_state_def - valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_def obj_at_def tcb_bound_refs_def2) - apply fastforce - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: isReceive_def case_bool_If - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (simp add: if_apply_def2) - apply ((wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases | - simp add: if_apply_def2 split del: if_split)+)[1] - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases) - apply (simp add: valid_tcb_state_def pred_conj_def) - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - | clarsimp simp: is_cap_simps - | strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues )+)[1] - apply (simp add: valid_tcb_state'_def pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear hoare_drop_imps) - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply simp - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb') - apply (clarsimp simp add: invs_def valid_state_def - valid_pspace_def ep_redux_simps ep_redux_simps' - st_tcb_at_tcb_at - cong: list.case_cong) - apply (clarsimp simp: valid_ep_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_at_caller_cap_null) - apply (fastforce simp: st_tcb_def2 valid_sched_def valid_sched_action_def) - subgoal by (auto simp: valid_ep'_def - split: list.split; - clarsimp simp: invs'_def valid_state'_def) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - done -qed - -lemmas setMessageInfo_typ_ats[wp] = typ_at_lifts [OF setMessageInfo_typ_at'] - -(* Annotation added by Simon Winwood (Thu Jul 1 20:54:41 2010) using taint-mode *) -declare tl_drop_1[simp] - -crunch cancel_ipc - for cur[wp]: "cur_tcb" - (wp: crunch_wps simp: crunch_simps) - -lemma valid_sched_weak_strg: - "valid_sched s \ weak_valid_sched_action s" - by (simp add: valid_sched_def valid_sched_action_def) - -lemma sendSignal_corres: - "corres dc (einvs and ntfn_at ep) (invs' and ntfn_at' ep) - (send_signal ep bg) (sendSignal ep bg)" - supply if_cong[cong] - apply (simp add: send_signal_def sendSignal_def Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getNotification_corres, - where - R = "\rv. einvs and ntfn_at ep and valid_ntfn rv and - ko_at (Structures_A.Notification rv) ep" and - R' = "\rv'. invs' and ntfn_at' ep and - valid_ntfn' rv' and ko_at' rv' ep"]) - defer - apply (wp get_simple_ko_ko_at get_ntfn_ko')+ - apply (simp add: invs_valid_objs)+ - apply (case_tac "ntfn_obj ntfn") - \ \IdleNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (case_tac "ntfnBoundTCB nTFN") - apply clarsimp - apply (rule corres_guard_imp[OF setNotification_corres]) - apply (clarsimp simp add: ntfn_relation_def)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_if) - apply (fastforce simp: receive_blocked_def receiveBlocked_def - thread_state_relation_def - split: Structures_A.thread_state.splits - Structures_H.thread_state.splits) - apply (rule corres_split[OF cancel_ipc_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply (clarsimp simp: thread_state_relation_def) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply wp - apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' hoare_disjI2 - cancel_ipc_cte_wp_at_not_reply_state - | strengthen invs_vobjs_strgs invs_psp_aligned_strg valid_sched_weak_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues - | simp add: valid_tcb_state_def)+ - apply (rule_tac Q'="\rv. invs' and tcb_at' a" in hoare_strengthen_post) - apply wp - apply (fastforce simp: invs'_def valid_state'_def sch_act_wf_weak valid_tcb_state'_def) - apply (rule setNotification_corres) - apply (clarsimp simp add: ntfn_relation_def) - apply (wp gts_wp gts_wp' | clarsimp)+ - apply (auto simp: valid_ntfn_def receive_blocked_def valid_sched_def invs_cur - elim: pred_tcb_weakenE - intro: st_tcb_at_reply_cap_valid - split: Structures_A.thread_state.splits)[1] - apply (clarsimp simp: valid_ntfn'_def invs'_def valid_state'_def valid_pspace'_def sch_act_wf_weak) - \ \WaitingNtfn\ - apply (clarsimp simp add: ntfn_relation_def Let_def) - apply (simp add: update_waiting_ntfn_def) - apply (rename_tac list) - apply (case_tac "tl list = []") - \ \tl list = []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper split del: if_split) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply ((wp | simp)+)[1] - apply (rule_tac Q'="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and - cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs' and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct'" - in hoare_post_imp, clarsimp simp: pred_tcb_at' elim!: sch_act_wf_weak) - apply (wp | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (wp set_simple_ko_valid_objs set_ntfn_aligned' set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def ntfn_queued_st_tcb_at valid_sched_def - valid_sched_action_def) - apply (auto simp: valid_ntfn'_def )[1] - apply (clarsimp simp: invs'_def valid_state'_def) - - \ \tl list \ []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def split:list.splits) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply (wp cur_tcb_lift | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wpsimp wp: sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb) - apply (wp set_ntfn_aligned' set_simple_ko_valid_objs set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def neq_Nil_conv - ntfn_queued_st_tcb_at valid_sched_def valid_sched_action_def - split: option.splits) - apply (auto simp: valid_ntfn'_def neq_Nil_conv invs'_def valid_state'_def - weak_sch_act_wf_def - split: option.splits)[1] - \ \ActiveNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def combine_ntfn_badges_def - combine_ntfn_msgs_def) - apply (simp add: invs_def valid_state_def valid_ntfn_def) - apply (simp add: invs'_def valid_state'_def valid_ntfn'_def) - done - -lemma valid_Running'[simp]: - "valid_tcb_state' Running = \" - by (rule ext, simp add: valid_tcb_state'_def) - -crunch setMRs - for typ'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma possibleSwitchTo_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp threadSet_sch_act setQueue_sch_act threadGet_wp - | simp add: unless_def | wpc)+ - apply (auto simp: obj_at'_def projectKOs tcb_in_cur_domain'_def) - done - -crunch possibleSwitchTo - for st_refs_of'[wp]: "\s. P (state_refs_of' s)" - (wp: crunch_wps) - -crunch possibleSwitchTo - for cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps) -crunch possibleSwitchTo - for objs'[wp]: valid_objs' - (wp: crunch_wps) -crunch possibleSwitchTo - for ct[wp]: cur_tcb' - (wp: cur_tcb_lift crunch_wps) - -lemma possibleSwitchTo_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) - and pspace_aligned' and pspace_distinct'\ - possibleSwitchTo t - \\_. if_live_then_nonz_cap'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp | wpc | simp)+ - apply (simp only: imp_conv_disj, wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (wp threadGet_wp)+ - apply (auto simp: obj_at'_def) - done - -crunch possibleSwitchTo - for ifunsafe[wp]: if_unsafe_then_cap' - (wp: crunch_wps) -crunch possibleSwitchTo - for idle'[wp]: valid_idle' - (wp: crunch_wps) -crunch possibleSwitchTo - for global_refs'[wp]: valid_global_refs' - (wp: crunch_wps) -crunch possibleSwitchTo - for arch_state'[wp]: valid_arch_state' - (wp: crunch_wps) -crunch possibleSwitchTo - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: crunch_wps) -crunch possibleSwitchTo - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) -crunch possibleSwitchTo - for irq_handlers'[wp]: valid_irq_handlers' - (simp: unless_def tcb_cte_cases_def cteSizeBits_def wp: crunch_wps) -crunch possibleSwitchTo - for irq_states'[wp]: valid_irq_states' - (wp: crunch_wps) -crunch sendSignal - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps simp: crunch_simps o_def) -crunch sendSignal - for it'[wp]: "\s. P (ksIdleThread s)" - (wp: crunch_wps simp: crunch_simps) - -crunch setBoundNotification - for irqs_masked'[wp]: "irqs_masked'" - (wp: irqs_masked_lift) - -crunch sendSignal - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps getObject_inv loadObject_default_inv - simp: crunch_simps unless_def o_def - rule: irqs_masked_lift) - -lemma ct_in_state_activatable_imp_simple'[simp]: - "ct_in_state' activatable' s \ ct_in_state' simple' s" - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply (case_tac st; simp) - done - -lemma setThreadState_nonqueued_state_update: - "\\s. invs' s \ st_tcb_at' simple' t s - \ st \ {Inactive, Running, Restart, IdleThreadState} - \ (st \ Inactive \ ex_nonz_cap_to' t s) - \ (t = ksIdleThread s \ idle' st) - \ (\ runnable' st \ sch_act_simple s)\ - setThreadState st t - \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply (clarsimp simp: pred_tcb_at') - apply (rule conjI, fastforce simp: valid_tcb_state'_def) - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI) - apply clarsimp - apply (erule delta_sym_refs) - apply (fastforce split: if_split_asm) - apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) - apply fastforce - done - -lemma cteDeleteOne_reply_cap_to'[wp]: - "\ex_nonz_cap_to' p and - cte_wp_at' (\c. isReplyCap (cteCap c)) slot\ - cteDeleteOne slot - \\rv. ex_nonz_cap_to' p\" - apply (simp add: cteDeleteOne_def ex_nonz_cap_to'_def unless_def) - apply (rule bind_wp [OF _ getCTE_sp]) - apply (rule hoare_assume_pre) - apply (subgoal_tac "isReplyCap (cteCap cte)") - apply (wp hoare_vcg_ex_lift emptySlot_cte_wp_cap_other isFinalCapability_inv - | clarsimp simp: finaliseCap_def isCap_simps - | wp (once) hoare_drop_imps)+ - apply (fastforce simp: cte_wp_at_ctes_of) - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) - done - -crunch setupCallerCap, possibleSwitchTo, asUser, doIPCTransfer - for vms'[wp]: "valid_machine_state'" - (wp: crunch_wps simp: zipWithM_x_mapM_x) - -crunch cancelSignal - for nonz_cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps simp: crunch_simps) - -lemma cancelIPC_nonz_cap_to'[wp]: - "\ex_nonz_cap_to' p\ cancelIPC t \\rv. ex_nonz_cap_to' p\" - apply (simp add: cancelIPC_def getThreadReplySlot_def Let_def - capHasProperty_def) - apply (wp threadSet_cap_to' - | wpc - | simp - | clarsimp elim!: cte_wp_at_weakenE' - | rule hoare_post_imp[where Q'="\rv. ex_nonz_cap_to' p"])+ - done - - -crunch activateIdleThread, getThreadReplySlot, isFinalCapability - for nosch[wp]: "\s. P (ksSchedulerAction s)" - (simp: Let_def) - -crunch setupCallerCap, asUser, setMRs, doIPCTransfer, possibleSwitchTo - for pspace_domain_valid[wp]: "pspace_domain_valid" - (wp: crunch_wps simp: zipWithM_x_mapM_x) - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma setThreadState_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - setThreadState st t - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - unfolding setThreadState_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imps) - -lemma cancelAllIPC_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllIPC epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllIPC_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -lemma cancelAllSignals_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllSignals epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllSignals_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -crunch finaliseCapTrue_standin - for not_rct[wp]: "\s. ksSchedulerAction s \ ResumeCurrentThread" - (simp: Let_def) - -lemma cancelIPC_ResumeCurrentThread_imp_notct[wp]: - "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelIPC t - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - (is "\?PRE t'\ _ \_\") -proof - - have aipc: "\t t' ntfn. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelSignal t ntfn - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cancelSignal_def) - apply (wp)[1] - apply (wp hoare_convert_imp)+ - apply (rule_tac P="\s. ksSchedulerAction s \ ResumeCurrentThread" - in hoare_weaken_pre) - apply (wpc) - apply (wp | simp)+ - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done - have cdo: "\t t' slot. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cteDeleteOne slot - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp hoare_convert_imp | simp)+ - done - show ?thesis - apply (simp add: cancelIPC_def Let_def) - apply (wp, wpc) - prefer 4 \ \state = Running\ - apply wp - prefer 7 \ \state = Restart\ - apply wp - apply (wp)+ - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp cdo)+ - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply ((wp aipc hoare_convert_imp)+)[6] - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done +crunch arch_get_sanitise_register_info + for pspace_distinct[wp]: pspace_distinct + and pspace_aligned[wp]: pspace_aligned + +lemma sanitiseRegister_sanitise_register[Ipc_R_assms]: + "sanitiseRegister = sanitise_register" + by (rule ext)+ + (clarsimp simp add: sanitiseRegister_def sanitise_register_def cong: register.case_cong) + +lemma handleArchFaultReply_corres[Ipc_R_assms]: + "corres (=) \ \ + (handle_arch_fault_reply ft t label msg) (handleArchFaultReply (arch_fault_map ft) t label msg)" + by (clarsimp simp: handle_arch_fault_reply_def handleArchFaultReply_def + split: arch_fault.split) + +crunch getSanitiseRegisterInfo, handleArchFaultReply, handle_arch_fault_reply + for inv[Ipc_R_assms, wp]: P + +lemma ctes_of_mdbNext_parentOf[Ipc_R_assms]: + "\ ctes_of s' \ cte_map cptr \ cte_map slot; + ctes_of s' (cte_map cptr) = Some (CTE (capability.ReplyCap t master rights) n); + ctes_of s' (mdbNext (cteMDBNode cte)) = Some (CTE (capability.ReplyCap t master' rights') n'); + ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)\ + \ ctes_of s' \ cte_map cptr parentOf mdbNext (cteMDBNode cte)" + by (clarsimp simp add: parentOf_def isMDBParentOf_CTE sameRegionAs_def2 isCap_simps) + (erule subtree.cases; clarsimp simp: parentOf_def isMDBParentOf_CTE) + +crunch debugPrint + for inv[Ipc_R_assms, wp]: P + and (no_fail) no_fail[Ipc_R_assms, intro!, wp, simp] + +(* this specifically refers to the 4 message registers *) +lemma max_message_size_less_max_ipc_words[Ipc_R_assms]: + "n \ 4 + \ word_size * (word_of_nat msg_max_extra_caps + (word_of_nat msg_max_length + n)) + < max_ipc_words * word_size" + apply (simp add: msg_max_extra_caps_def msg_max_length_def max_ipc_words word_size_def) + apply (rule_tac y="0x3D8 + 8 * 4" in order_le_less_trans) + apply (rule word_plus_mono_right) + apply (rule word_mult_le_mono1'; simp) + apply simp+ + done + +end (* Arch *) + +interpretation Ipc_R?: Ipc_R +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Ipc_R_assms)?)?) qed -crunch setMRs - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma sai_invs'[wp]: - "\invs' and ex_nonz_cap_to' ntfnptr\ - sendSignal ntfnptr badge \\y. invs'\" - unfolding sendSignal_def - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj nTFN", simp_all) - prefer 3 - apply (rename_tac list) - apply (case_tac list, - simp_all split del: if_split - add: setMessageInfo_def)[1] - apply (wp hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act])+ - apply (clarsimp simp:conj_comms) - apply (simp add: invs'_def valid_state'_def) - apply (wp valid_irq_node_lift sts_valid_objs' setThreadState_ct_not_inQ - set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' valid_dom_schedule'_lift - hoare_convert_imp [OF setNotification_nosch] - | simp split del: if_split)+ - - apply (intro conjI[rotated]; - (solves \clarsimp simp: invs'_def valid_state'_def valid_pspace'_def\)?) - apply (clarsimp simp: invs'_def valid_state'_def split del: if_split) - apply (drule(1) ct_not_in_ntfnQueue, simp+) - apply clarsimp - apply (frule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def) - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_idle'_def pred_tcb_at'_def idle_tcb'_def - dest!: sym_refs_ko_atD' sym_refs_st_tcb_atD' sym_refs_obj_atD' - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (clarsimp elim!: if_live_then_nonz_capE' simp:invs'_def valid_state'_def) - apply (drule(1) sym_refs_ko_atD') - apply (clarsimp elim!: ko_wp_at'_weakenE - intro!: refs_of_live') - apply (clarsimp split del: if_split)+ - apply (frule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (frule invs_sym') - apply (drule(1) sym_refs_obj_atD') - apply (clarsimp split del: if_split cong: if_cong - simp: st_tcb_at_refs_of_rev' ep_redux_simps' ntfn_bound_refs'_def) - apply (frule st_tcb_at_state_refs_ofD') - apply (erule delta_sym_refs) - apply (fastforce simp: split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset symreftype_inverse' - split: if_split_asm) - apply (clarsimp simp:invs'_def) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def valid_state'_def) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (clarsimp simp:invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (case_tac "ntfnBoundTCB nTFN", simp_all) - apply (wp set_ntfn_minor_invs') - apply (fastforce simp: valid_ntfn'_def invs'_def valid_state'_def - elim!: obj_at'_weakenE - dest!: global'_no_ex_cap) - apply (wp add: hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act] - setThreadState_nonqueued_state_update sts_st_tcb' - del: cancelIPC_simple) - apply (clarsimp | wp cancelIPC_ct')+ - apply (wp set_ntfn_minor_invs' gts_wp' | clarsimp)+ - apply (frule pred_tcb_at') - by (wp set_ntfn_minor_invs' - | rule conjI - | clarsimp elim!: st_tcb_ex_cap'' - | fastforce simp: receiveBlocked_def projectKOs pred_tcb_at'_def obj_at'_def - dest!: invs_rct_ct_activatable' - split: thread_state.splits - | fastforce simp: invs'_def valid_state'_def receiveBlocked_def projectKOs - valid_obj'_def valid_ntfn'_def - split: thread_state.splits - dest!: global'_no_ex_cap st_tcb_ex_cap'' ko_at_valid_objs')+ - -lemma replyFromKernel_corres: - "corres dc (tcb_at t and invs) (invs') - (reply_from_kernel t r) (replyFromKernel t r)" - apply (case_tac r) - apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def - badge_register_def badgeRegister_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres]) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split_eqr[OF setMRs_corres]) - apply clarsimp - apply (rule setMessageInfo_corres) - apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' - | clarsimp simp: invs_distinct invs_psp_aligned)+ - apply fastforce - done - -lemma rfk_invs': - "\invs' and tcb_at' t\ replyFromKernel t r \\rv. invs'\" - apply (simp add: replyFromKernel_def) - apply (cases r) - apply (wp | clarsimp)+ - done - -crunch replyFromKernel - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma completeSignal_corres: - "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and valid_objs and pspace_distinct) - (ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' and obj_at' isActive ntfnptr) - (complete_signal ntfnptr tcb) (completeSignal ntfnptr tcb)" - apply (simp add: complete_signal_def completeSignal_def) - apply (rule corres_guard_imp) - apply (rule_tac R'="\ntfn. ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' - and valid_ntfn' ntfn and (\_. isActive ntfn)" - in corres_split[OF getNotification_corres]) - apply (rule corres_gen_asm2) - apply (case_tac "ntfn_obj rv") - apply (clarsimp simp: ntfn_relation_def isActive_def - split: ntfn.splits Structures_H.notification.splits)+ - apply (rule corres_guard2_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres setNotification_corres]) - apply (clarsimp simp: ntfn_relation_def) - apply (wp set_simple_ko_valid_objs get_simple_ko_wp getNotification_wp | clarsimp simp: valid_ntfn'_def)+ - apply (clarsimp simp: valid_pspace'_def) - apply (frule_tac P="(\k. k = ntfn)" in obj_at_valid_objs', assumption) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def obj_at'_def) - done - - -lemma doNBRecvFailedTransfer_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ - (do_nbrecv_failed_transfer thread) - (doNBRecvFailedTransfer thread)" - unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def - by (simp add: badgeRegister_def badge_register_def, rule asUser_setRegister_corres) - -lemma receiveIPC_corres: - assumes "is_ep_cap cap" and "cap_relation cap cap'" - shows " - corres dc (einvs and valid_sched and tcb_at thread and valid_cap cap and ex_nonz_cap_to thread - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3)) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_ipc thread cap isBlocking) (receiveIPC thread cap' isBlocking)" - apply (insert assms) - apply (simp add: receive_ipc_def receiveIPC_def - split del: if_split) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 right) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getBoundNotification_corres]) - apply (rule_tac r'="ntfn_relation" in corres_split) - apply (rule corres_option_split[rotated 2]) - apply (rule getNotification_corres) - apply clarsimp - apply (rule corres_trivial, simp add: ntfn_relation_def default_notification_def - default_ntfn_def) - apply (rule corres_if) - apply (clarsimp simp: ntfn_relation_def Ipc_A.isActive_def Endpoint_H.isActive_def - split: Structures_A.ntfn.splits Structures_H.notification.splits) - apply clarsimp - apply (rule completeSignal_corres) - apply (rule_tac P="einvs and valid_sched and tcb_at thread and - ep_at word1 and valid_ep ep and - obj_at (\k. k = Endpoint ep) word1 - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3) - and ex_nonz_cap_to thread" and - P'="invs' and tcb_at' thread and ep_at' word1 and - valid_ep' epa" - in corres_inst) - apply (case_tac ep) - \ \IdleEP\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def - valid_tcb_state_def st_tcb_at_tcb_at) - apply auto[1] - \ \SendEP\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (clarsimp simp: valid_ep_def) - apply (case_tac list, simp_all split del: if_split)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (case_tac lista, simp_all add: ep_relation_def)[1] - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. - sender_state = - Structures_A.thread_state.BlockedOnSend word1 data" - in corres_gen_asm) - apply (clarsimp simp: isSend_def case_bool_If - case_option_If if3_fold - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (simp split del: if_split cong: if_cong) - apply (fold dc_def)[1] - apply (rule_tac P="valid_objs and valid_mdb and valid_list and valid_arch_state - and valid_sched - and cur_tcb - and valid_reply_caps - and pspace_aligned and pspace_distinct - and st_tcb_at (Not \ awaiting_reply) a - and st_tcb_at (Not \ halted) a - and tcb_at thread and valid_reply_masters - and cte_wp_at (\c. c = cap.NullCap) - (thread, tcb_cnode_index 3)" - and P'="tcb_at' a and tcb_at' thread and cur_tcb' - and valid_pspace' - and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_guard_imp [OF corres_if]) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_if2 [OF _ setupCallerCap_corres setThreadState_corres]) - apply simp - apply simp - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wpsimp wp: sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (fastforce simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) - apply (clarsimp split: if_split_asm) - apply (clarsimp | wp do_ipc_transfer_tcb_caps do_ipc_transfer_valid_arch)+ - apply (rule_tac Q'="\_ s. sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp) - apply (fastforce elim: sch_act_wf_weak) - apply (wp sts_st_tcb' gts_st_tcb_at | simp)+ - apply (simp cong: list.case_cong) - apply wp - apply simp - apply (wp weak_sch_act_wf_lift_linear setEndpoint_valid_mdb' set_ep_valid_objs') - apply (clarsimp split: list.split) - apply (clarsimp simp add: invs_def valid_state_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_ep_def valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ko. ko = Endpoint e" for e]) - apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) - apply (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split)[1] - \ \RecvEP\ - apply (simp add: ep_relation_def) - apply (rule_tac corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (clarsimp simp: valid_tcb_state_def invs_distinct) - apply (clarsimp simp add: valid_tcb_state'_def) - apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' - hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift - | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ - apply (clarsimp simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def - valid_obj_def valid_tcb_def valid_bound_ntfn_def invs_distinct - dest!: invs_valid_objs - elim!: obj_at_valid_objsE - split: option.splits) - apply clarsimp - apply (auto simp: valid_cap'_def invs_valid_pspace' valid_obj'_def valid_tcb'_def - valid_bound_ntfn'_def obj_at'_def pred_tcb_at'_def - dest!: invs_valid_objs' obj_at_valid_objs' - split: option.splits)[1] - done - -lemma receiveSignal_corres: - "\ is_ntfn_cap cap; cap_relation cap cap' \ \ - corres dc (invs and st_tcb_at active thread and valid_cap cap and ex_nonz_cap_to thread) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" - apply (simp add: receive_signal_def receiveSignal_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 rights) - apply (rule corres_guard_imp) - apply (rule_tac R="\rv. invs and tcb_at thread and st_tcb_at active thread and - ntfn_at word1 and ex_nonz_cap_to thread and - valid_ntfn rv and - obj_at (\k. k = Notification rv) word1" and - R'="\rv'. invs' and tcb_at' thread and ntfn_at' word1 and - valid_ntfn' rv'" - in corres_split[OF getNotification_corres]) - apply clarsimp - apply (case_tac "ntfn_obj rv") - \ \IdleNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres; simp) - apply (clarsimp simp: invs_distinct) - apply simp - \ \WaitingNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp) - apply (rule doNBRecvFailedTransfer_corres; simp) - apply (clarsimp simp: invs_distinct)+ - \ \ActiveNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (fastforce simp: invs_def valid_state_def valid_pspace_def - elim!: st_tcb_weakenE) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply wp+ - apply (clarsimp simp add: ntfn_at_def2 valid_cap_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_cap'_def) - done - -lemma tg_sp': - "\P\ threadGet f p \\t. obj_at' (\t'. f t' = t) p and P\" - including no_pre - apply (simp add: threadGet_def) - apply wp - apply (rule hoare_strengthen_post) - apply (rule getObject_tcb_sp) - apply clarsimp - apply (erule obj_at'_weakenE) - apply simp - done +context Arch begin arch_global_naming -declare lookup_cap_valid' [wp] - -lemma sendFaultIPC_corres: - "valid_fault f \ fr f f' \ - corres (fr \ dc) - (einvs and st_tcb_at active thread and ex_nonz_cap_to thread) - (invs' and sch_act_not thread and tcb_at' thread) - (send_fault_ipc thread f) (sendFaultIPC thread f')" - apply (simp add: send_fault_ipc_def sendFaultIPC_def - liftE_bindE Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'="\fh fh'. fh = to_bl fh'"]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_cap_fault) - apply (rule lookup_cap_corres, rule refl) - apply (rule_tac P="einvs and st_tcb_at active thread - and valid_cap handler_cap and ex_nonz_cap_to thread" - and P'="invs' and tcb_at' thread and sch_act_not thread - and valid_cap' handlerCap" - in corres_inst) - apply (case_tac handler_cap, - simp_all add: isCap_defs lookup_failure_map_def - case_bool_If If_rearrage - split del: if_split cong: if_cong)[1] - apply (rule corres_guard_imp) - apply (rule corres_if2 [OF refl]) - apply (simp add: dc_def[symmetric]) - apply (rule corres_split[OF threadset_corres sendIPC_corres], simp_all)[1] - apply (simp add: tcb_relation_def fault_rel_optionation_def inQ_def)+ - apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state - thread_set_typ_at ep_at_typ_at ex_nonz_cap_to_pres - thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched - | simp add: tcb_cap_cases_def)+ - apply ((wp threadSet_invs_trivial threadSet_tcb' - | simp add: tcb_cte_cases_def - | wp (once) sch_act_sane_lift)+)[1] - apply (rule corres_trivial, simp add: lookup_failure_map_def) - apply (clarsimp simp: st_tcb_at_tcb_at split: if_split) - apply (clarsimp simp: valid_cap_def invs_distinct) - apply (clarsimp simp: valid_cap'_def inQ_def) - apply auto[1] - apply (clarsimp simp: lookup_failure_map_def) - apply wp+ - apply (fastforce elim: st_tcb_at_tcb_at) - apply fastforce - done - -lemma gets_the_noop_corres: - assumes P: "\s. P s \ f s \ None" - shows "corres dc P P' (gets_the f) (return x)" - apply (clarsimp simp: corres_underlying_def gets_the_def - return_def gets_def bind_def get_def) - apply (clarsimp simp: assert_opt_def return_def dest!: P) - done - -lemma handleDoubleFault_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) - \ - (handle_double_fault thread f ft) - (handleDoubleFault thread f' ft')" - apply (rule corres_cross_over_guard[where Q="tcb_at' thread"]) - apply (fastforce intro!: tcb_at_cross) - apply (simp add: handle_double_fault_def handleDoubleFault_def) - apply (rule corres_guard_imp) - apply (subst bind_return [symmetric], - rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_noop2) - apply (simp add: exs_valid_def return_def) - apply (rule hoare_eq_P) - apply wp - apply (rule asUser_inv) - apply (rule getRestartPC_inv) - apply (wp no_fail_getRestartPC)+ - apply (wp|simp)+ - done - -crunch sendFaultIPC - for tcb'[wp]: "tcb_at' t" (wp: crunch_wps) - -crunch receiveIPC - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveIPC_typ_ats[wp] = typ_at_lifts [OF receiveIPC_typ_at'] - -crunch receiveSignal - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveAIPC_typ_ats[wp] = typ_at_lifts [OF receiveSignal_typ_at'] - -crunch setupCallerCap - for aligned'[wp]: "pspace_aligned'" - (wp: crunch_wps) -crunch setupCallerCap - for distinct'[wp]: "pspace_distinct'" - (wp: crunch_wps) -crunch setupCallerCap - for cur_tcb[wp]: "cur_tcb'" - (wp: crunch_wps) - -lemma setupCallerCap_state_refs_of[wp]: - "\\s. P ((state_refs_of' s) (sender := {r \ state_refs_of' s sender. snd r = TCBBound}))\ - setupCallerCap sender rcvr grant - \\rv s. P (state_refs_of' s)\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp hoare_drop_imps) - apply (simp add: fun_upd_def cong: if_cong) - done - -lemma is_derived_ReplyCap' [simp]: - "\m p g. is_derived' m p (capability.ReplyCap t False g) = - (\c. \ g. c = capability.ReplyCap t True g)" - apply (subst fun_eq_iff) - apply clarsimp - apply (case_tac x, simp_all add: is_derived'_def isCap_simps - badge_derived'_def - vs_cap_ref'_def) - done - -lemma unique_master_reply_cap': - "\c t. isReplyCap c \ capReplyMaster c \ capTCBPtr c = t \ - (\g . c = capability.ReplyCap t True g)" - by (fastforce simp: isCap_simps conj_comms) - -lemma getSlotCap_cte_wp_at: - "\\\ getSlotCap sl \\rv. cte_wp_at' (\c. cteCap c = rv) sl\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -crunch setThreadState - for no_0_obj'[wp]: no_0_obj' - -lemma setupCallerCap_vp[wp]: - "\valid_pspace' and tcb_at' sender and tcb_at' rcvr\ - setupCallerCap sender rcvr grant \\rv. valid_pspace'\" - apply (simp add: valid_pspace'_def setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv getSlotCap_def) - apply (wp getCTE_wp) - apply (rule_tac Q'="\_. valid_pspace' and - tcb_at' sender and tcb_at' rcvr" - in hoare_post_imp) - apply (clarsimp simp: valid_cap'_def o_def cte_wp_at_ctes_of isCap_simps - valid_pspace'_def) - apply (frule(1) ctes_of_valid', simp add: valid_cap'_def capAligned_def) - apply clarsimp - apply (wp | simp add: valid_pspace'_def valid_tcb_state'_def)+ - done - -lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_live_then_nonz_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - -lemma setupCallerCap_ifunsafe[wp]: - "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_unsafe_then_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) - apply (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - apply (rule_tac Q'="\rv. valid_objs' and tcb_at' rcvr and ex_nonz_cap_to' rcvr" - in hoare_post_imp) - apply (clarsimp simp: ex_nonz_tcb_cte_caps' tcbCallerSlot_def - objBits_def objBitsKO_def dom_def cte_level_bits_def) - apply (wp sts_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb_state'_def)+ - done - -lemma setupCallerCap_global_refs'[wp]: - "\valid_global_refs'\ - setupCallerCap sender rcvr grant - \\rv. valid_global_refs'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp - | wp (once) hoare_vcg_imp_lift' hoare_vcg_ex_lift | clarsimp simp: cte_wp_at_ctes_of)+ - -crunch setupCallerCap - for valid_arch'[wp]: "valid_arch_state'" - (wp: hoare_drop_imps) - -crunch setupCallerCap - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: hoare_drop_imps) - -lemma setupCallerCap_irq_handlers'[wp]: - "\valid_irq_handlers'\ - setupCallerCap sender rcvr grant - \\rv. valid_irq_handlers'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp hoare_drop_imps | simp)+ - -lemma cteInsert_cap_to': - "\ex_nonz_cap_to' p and cte_wp_at' (\c. cteCap c = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_nonz_cap_to' p\" - supply if_cong[cong] - apply (simp add: cteInsert_def ex_nonz_cap_to'_def updateCap_def setUntypedCapAsFull_def) - apply (wpsimp wp: updateMDB_weak_cte_wp_at setCTE_weak_cte_wp_at hoare_vcg_ex_lift - | rule hoare_drop_imps - | wp getCTE_wp)+ (* getCTE_wp is separate to apply it only to the last one *) - apply (rule_tac x=cref in exI) - apply (fastforce simp: cte_wp_at_ctes_of) - done - -crunch setExtraBadge - for cap_to'[wp]: "ex_nonz_cap_to' p" - -crunch doIPCTransfer - for cap_to'[wp]: "ex_nonz_cap_to' p" - (ignore: transferCapsToSlots - wp: crunch_wps transferCapsToSlots_pres2 cteInsert_cap_to' hoare_vcg_const_Ball_lift - simp: zipWithM_x_mapM ball_conj_distrib) - -lemma st_tcb_idle': - "\valid_idle' s; st_tcb_at' P t s\ \ - (t = ksIdleThread s) \ P IdleThreadState" - by (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - -crunch getThreadCallerSlot - for idle'[wp]: "valid_idle'" -crunch getThreadReplySlot - for idle'[wp]: "valid_idle'" - -crunch setupCallerCap - for it[wp]: "\s. P (ksIdleThread s)" - (simp: updateObject_cte_inv wp: crunch_wps) - -lemma setupCallerCap_idle'[wp]: - "\valid_idle' and valid_pspace' and - (\s. st \ ksIdleThread s \ rt \ ksIdleThread s)\ - setupCallerCap st rt gr - \\_. valid_idle'\" - by (simp add: setupCallerCap_def capRange_def | wp hoare_drop_imps)+ - -crunch setExtraBadge - for it[wp]: "\s. P (ksIdleThread s)" -crunch receiveIPC - for it[wp]: "\s. P (ksIdleThread s)" - (ignore: transferCapsToSlots - wp: transferCapsToSlots_pres2 crunch_wps hoare_vcg_const_Ball_lift - simp: crunch_simps ball_conj_distrib) - -crunch setupCallerCap - for irq_states'[wp]: valid_irq_states' - (wp: crunch_wps) - -crunch receiveIPC - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps rule: irqs_masked_lift) - -crunch getThreadCallerSlot - for ct_not_inQ[wp]: "ct_not_inQ" -crunch getThreadReplySlot - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma setupCallerCap_ct_not_inQ[wp]: - "\ct_not_inQ\ setupCallerCap sender receiver grant \\_. ct_not_inQ\" - apply (simp add: setupCallerCap_def) - apply (wp hoare_drop_imp setThreadState_ct_not_inQ) - done - -crunch copyMRs - for ksQ'[wp]: "\s. P (ksReadyQueues s)" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ksQ[wp]: "\s. P (ksReadyQueues s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -crunch doIPCTransfer - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma asUser_ct_not_inQ[wp]: - "\ct_not_inQ\ asUser t m \\rv. ct_not_inQ\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps threadSet_not_inQ | simp)+ - done - -crunch copyMRs - for ct_not_inQ[wp]: "ct_not_inQ" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ct_not_inQ[wp]: "ct_not_inQ" - (ignore: transferCapsToSlots - wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma ntfn_q_refs_no_bound_refs': "rf : ntfn_q_refs_of' (ntfnObj ob) \ rf ~: ntfn_bound_refs' (ntfnBoundTCB ob')" - by (auto simp add: ntfn_q_refs_of'_def ntfn_bound_refs'_def - split: Structures_H.ntfn.splits) - -lemma completeSignal_invs: - "\invs' and tcb_at' tcb\ - completeSignal ntfnptr tcb - \\_. invs'\" - apply (simp add: completeSignal_def) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule hoare_pre) - apply (wp set_ntfn_minor_invs' | wpc | simp)+ - apply (rule_tac Q'="\_ s. (state_refs_of' s ntfnptr = ntfn_bound_refs' (ntfnBoundTCB ntfn)) - \ ntfn_at' ntfnptr s - \ valid_ntfn' (ntfnObj_update (\_. Structures_H.ntfn.IdleNtfn) ntfn) s - \ ((\y. ntfnBoundTCB ntfn = Some y) \ ex_nonz_cap_to' ntfnptr s) - \ ntfnptr \ ksIdleThread s" - in hoare_strengthen_post) - apply ((wp hoare_vcg_ex_lift hoare_weak_lift_imp | wpc | simp add: valid_ntfn'_def)+)[1] - apply (clarsimp simp: obj_at'_def state_refs_of'_def typ_at'_def ko_wp_at'_def live'_def - split: option.splits) - apply (blast dest: ntfn_q_refs_no_bound_refs') - apply wp - apply (subgoal_tac "valid_ntfn' ntfn s") - apply (subgoal_tac "ntfnptr \ ksIdleThread s") - apply (fastforce simp: valid_ntfn'_def valid_bound_tcb'_def ko_at_state_refs_ofD' live'_def - elim: obj_at'_weakenE - if_live_then_nonz_capD'[OF invs_iflive' - obj_at'_real_def[THEN meta_eq_to_obj_eq, - THEN iffD1]]) - apply (fastforce simp: valid_idle'_def pred_tcb_at'_def obj_at'_def - dest!: invs_valid_idle') - apply (fastforce dest: invs_valid_objs' ko_at_valid_objs' - simp: valid_obj'_def)[1] - done - -lemma setupCallerCap_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' and tcb_at' sender\ - setupCallerCap sender t g \\rv. untyped_ranges_zero'\" - apply (simp add: setupCallerCap_def getSlotCap_def - getThreadCallerSlot_def getThreadReplySlot_def - locateSlot_conv) - apply (wp getCTE_wp') - apply (rule_tac Q'="\_. untyped_ranges_zero' and valid_mdb' and valid_objs'" in hoare_post_imp) - apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def untyped_derived_eq_def - isCap_simps) - apply (wp sts_valid_pspace_hangers) - apply (clarsimp simp: valid_tcb_state'_def) - done - -lemmas threadSet_urz = untyped_ranges_zero_lift[where f="cteCaps_of", OF _ threadSet_cteCaps_of] - -crunch doIPCTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: threadSet wp: threadSet_urz crunch_wps simp: zipWithM_x_mapM) - -crunch receiveIPC - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 simp: zipWithM_x_mapM ignore: constOnFailure) - -crunch possibleSwitchTo - for ctes_of[wp]: "\s. P (ctes_of s)" - (wp: crunch_wps ignore: constOnFailure) - -lemmas possibleSwitchToTo_cteCaps_of[wp] - = cteCaps_of_ctes_of_lift[OF possibleSwitchTo_ctes_of] - -crunch possibleSwitchTo - for ksArch[wp]: "\s. P (ksArchState s)" - (wp: possibleSwitchTo_ctes_of crunch_wps ignore: constOnFailure) - -crunch asUser - for valid_bitmaps[wp]: valid_bitmaps - (rule: valid_bitmaps_lift wp: crunch_wps) - -crunch setupCallerCap, possibleSwitchTo, doIPCTransfer - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -(* t = ksCurThread s *) -lemma ri_invs' [wp]: - "\invs' and sch_act_not t - and ct_in_state' simple' - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ - receiveIPC t cap isBlocking - \\_. invs'\" (is "\?pre\ _ \_\") - apply (clarsimp simp: receiveIPC_def) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (rule bind_wp [OF _ gbn_sp']) - apply (rule bind_wp) - (* set up precondition for old proof *) - apply (rule_tac P''="ko_at' ep (capEPPtr cap) and ?pre" in hoare_vcg_if_split) - apply (wp completeSignal_invs) - apply (case_tac ep) - \ \endpoint = RecvEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp sts_sch_act' hoare_vcg_const_Ball_lift valid_irq_node_lift valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' o_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_ep'_def - valid_obj'_def tcb_bound_refs'_def - dest!: isCapDs) - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD') - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply ((case_tac tp; fastforce elim: nonempty_cross_distinct_singleton_elim)+)[2] - apply (clarsimp split: if_split_asm) - apply (fastforce simp: valid_pspace'_def global'_no_ex_cap idle'_not_queued) - \ \endpoint = IdleEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp sts_sch_act' valid_irq_node_lift valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def o_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "t \ capEPPtr cap") - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule ko_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (clarsimp simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) - \ \endpoint = SendEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rename_tac list) - apply (case_tac list, simp_all split del: if_split) - apply (rename_tac sender queue) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift hoare_drop_imps setEndpoint_valid_mdb' - set_ep_valid_objs' sts_st_tcb' sts_sch_act' valid_dom_schedule'_lift - setThreadState_ct_not_inQ - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - setEndpoint_ksQ - | simp add: valid_tcb_state'_def case_bool_If - case_option_If - split del: if_split cong: if_cong - | wp (once) sch_act_sane_lift hoare_vcg_conj_lift hoare_vcg_all_lift - untyped_ranges_zero_lift)+ - apply (clarsimp split del: if_split simp: pred_tcb_at') - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def - st_tcb_at_refs_of_rev' conj_ac - split del: if_split - cong: if_cong) - apply (subgoal_tac "sch_act_not sender s") - prefer 2 - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (drule st_tcb_at_state_refs_ofD') - apply (simp only: conj_ac(1, 2)[where Q="sym_refs R" for R]) - apply (subgoal_tac "distinct (ksIdleThread s # capEPPtr cap # t # sender # queue)") - apply (rule conjI) - apply (clarsimp simp: ep_redux_simps' cong: if_cong) - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - apply (clarsimp simp: singleton_tuple_cartesian split: list.split - | rule conjI | drule(1) bspec - | drule st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - | clarsimp elim!: if_live_state_refsE)+ - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (clarsimp simp: global'_no_ex_cap) - apply (rule conjI - | clarsimp simp: singleton_tuple_cartesian split: list.split - | clarsimp elim!: if_live_state_refsE - | clarsimp simp: global'_no_ex_cap idle'_not_queued' idle'_no_refs tcb_bound_refs'_def - | drule(1) bspec | drule st_tcb_at_state_refs_ofD' - | clarsimp simp: set_eq_subset dest!: bound_tcb_at_state_refs_ofD' )+ - apply (rule hoare_pre) - apply (wp getNotification_wp | wpc | clarsimp)+ - done - -(* t = ksCurThread s *) -lemma rai_invs'[wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) - and (\s. \ntfnptr. isNotificationCap cap - \ capNtfnPtr cap = ntfnptr - \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) - ntfnptr s)\ - receiveSignal t cap isBlocking - \\_. invs'\" - apply (simp add: receiveSignal_def) - apply (rule bind_wp [OF _ get_ntfn_sp']) - apply (rename_tac ep) - apply (case_tac "ntfnObj ep") - \ \ep = IdleNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "capNtfnPtr cap \ t") - apply (frule valid_pspace_valid_objs') - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD' bound_tcb_at_state_refs_ofD')+ - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - \ \ep = ActiveNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_valid_objs' typ_at_lifts hoare_weak_lift_imp - asUser_urz valid_dom_schedule'_lift - | simp add: valid_ntfn'_def)+ - apply (clarsimp simp: pred_tcb_at' valid_pspace'_def) - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def isCap_simps) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD')+ - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm simp: global'_no_ex_cap)+ - \ \ep = WaitingNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - setThreadState_ct_not_inQ typ_at_lifts valid_dom_schedule'_lift - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: valid_tcb_state'_def) - apply (frule_tac t=t in not_in_ntfnQueue) - apply (simp) - apply (simp) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def) - apply (clarsimp simp: valid_ntfn'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' - dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (rename_tac list one two three four five six seven eight nine) - apply (subgoal_tac "set list \ {NTFNSignal} \ {}") - apply safe[1] - apply (auto simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def)[5] - apply (fastforce simp: tcb_bound_refs'_def - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - done - -lemma getCTE_cap_to_refs[wp]: - "\\\ getCTE p \\rv s. \r\zobj_refs' (cteCap rv). ex_nonz_cap_to' r s\" - apply (rule hoare_strengthen_post [OF getCTE_sp]) - apply (clarsimp simp: ex_nonz_cap_to'_def) - apply (fastforce elim: cte_wp_at_weakenE') - done - -lemma lookupCap_cap_to_refs[wp]: - "\\\ lookupCap t cref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" - apply (simp add: lookupCap_def lookupCapAndSlot_def split_def - getSlotCap_def) - apply (wp | simp)+ - done - -crunch setVMRoot - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps simp: crunch_simps) - -lemma arch_stt_objs' [wp]: - "\valid_objs'\ Arch.switchToThread t \\rv. valid_objs'\" - apply (simp add: RISCV64_H.switchToThread_def) - apply wp - done - -declare zipWithM_x_mapM [simp] - -lemma cteInsert_invs_bits[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert a b c - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" - "\\s. P (state_refs_of' s)\ - cteInsert a b c - \\rv s. P (state_refs_of' s)\" -apply (wp sch_act_wf_lift valid_queues_lift - cur_tcb_lift tcb_in_cur_domain'_lift)+ -done - -lemma possibleSwitchTo_sch_act_not: - "\sch_act_not t' and K (t \ t')\ possibleSwitchTo t \\rv. sch_act_not t'\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def curDomain_def) - apply (wp hoare_drop_imps | wpc | simp)+ - done - -crunch possibleSwitchTo - for urz[wp]: "untyped_ranges_zero'" - (simp: crunch_simps unless_def wp: crunch_wps) - -crunch possibleSwitchTo - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - -lemma si_invs'[wp]: - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ - sendIPC bl call ba cg cgr t ep - \\rv. invs'\" - supply if_split[split del] - supply if_cong[cong] - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (case_tac epa) - \ \epa = RecvEP\ - apply simp - apply (rename_tac list) - apply (case_tac list) - apply simp - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (rule_tac P="a\t" in hoare_gen_asm) - apply (wp valid_irq_node_lift - sts_valid_objs' set_ep_valid_objs' setEndpoint_valid_mdb' sts_st_tcb' sts_sch_act' - possibleSwitchTo_sch_act_not setThreadState_ct_not_inQ valid_dom_schedule'_lift - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - hoare_convert_imp [OF doIPCTransfer_sch_act doIPCTransfer_ct'] - hoare_convert_imp [OF setEndpoint_nosch setEndpoint_ksCurThread] - hoare_drop_imp [where f="threadGet tcbFault t"] - | rule_tac f="getThreadState a" in hoare_drop_imp - | wp (once) hoare_drop_imp[where Q'="\_ _. call"] - hoare_drop_imp[where Q'="\_ _. \ call"] - hoare_drop_imp[where Q'="\_ _. cg"] - | simp add: valid_tcb_state'_def case_bool_If - case_option_If - cong: if_cong - | wp (once) sch_act_sane_lift tcb_in_cur_domain'_lift hoare_vcg_const_imp_lift)+ - apply (clarsimp simp: pred_tcb_at' cong: conj_cong imp_cong) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def - st_tcb_at_refs_of_rev' pred_tcb_at' - conj_comms fun_upd_def[symmetric] - split del: if_split) - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD' st_tcb_at_state_refs_ofD')+ - apply (clarsimp simp: valid_pspace'_splits) - apply (subst fun_upd_idem[where x=t]) - apply (clarsimp split: if_split) - apply (rule conjI, clarsimp simp: obj_at'_def) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def) - apply (subgoal_tac "ex_nonz_cap_to' a s") - prefer 2 - apply (clarsimp elim!: if_live_state_refsE) - apply clarsimp - apply (rule conjI) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp simp: conj_ac) - apply (rule conjI, clarsimp simp: idle'_no_refs) - apply (rule conjI, clarsimp simp: global'_no_ex_cap) - apply (rule conjI) - apply (rule impI) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (clarsimp) - apply (simp add: ep_redux_simps') - apply (rule conjI, clarsimp split: if_split) - apply (rule conjI, fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp, erule delta_sym_refs; - solves\auto simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm\) - apply (solves\clarsimp split: list.splits\) - \ \epa = IdleEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp valid_irq_node_lift valid_dom_schedule'_lift sts_sch_act' setThreadState_ct_not_inQ) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "ep \ t") - apply (drule simple_st_tcb_at_state_refs_ofD' ko_at_state_refs_ofD' - bound_tcb_at_state_refs_ofD')+ - apply (rule conjI, erule delta_sym_refs) - apply (auto simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm)[2] - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply simp - apply wp - apply simp - \ \epa = SendEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ - valid_dom_schedule'_lift) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: valid_obj'_def valid_ep'_def st_tcb_at_refs_of_rev') - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - simp: tcb_bound_refs'_def) - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - subgoal by (fastforce simp: obj_at'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap idle'_not_queued) - apply (simp | wp)+ - done - -lemma sfi_invs_plus': - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" - apply (simp add: sendFaultIPC_def) - apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state - threadSet_cap_to' - | wpc | simp)+ - apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s - \ st_tcb_at' simple' t s - \ ex_nonz_cap_to' t s - \ t \ ksIdleThread s - \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" - in hoare_strengthen_postE_R) - apply wp - apply (clarsimp simp: inQ_def pred_tcb_at') - apply (wp | simp)+ - apply (clarsimp simp: eq_commute) - apply (subst(asm) global'_no_ex_cap, auto) - done - -crunch send_fault_ipc - for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" - and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" - (simp: crunch_simps wp: crunch_wps) - -lemma handleFault_corres: - "fr f f' \ - corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread - and (\_. valid_fault f)) - (invs' and sch_act_not thread - and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) - (handle_fault thread f) (handleFault thread f')" - apply (simp add: handle_fault_def handleFault_def) - apply (rule corres_guard_imp) - apply (subst return_bind [symmetric], - rule corres_split[where P="tcb_at thread", - OF gets_the_noop_corres [where x="()"]]) - apply (simp add: tcb_at_def) - apply (rule corres_split_catch) - apply (rule_tac F="valid_fault f" in corres_gen_asm) - apply (rule sendFaultIPC_corres, assumption) - apply simp - apply (rule handleDoubleFault_corres) - apply wpsimp+ - apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def valid_state_def valid_idle_def) - apply auto - done - -lemma sts_invs_minor'': - "\st_tcb_at' (\st'. tcb_st_refs_of' st' = tcb_st_refs_of' st - \ (st \ Inactive \ \ idle' st \ - st' \ Inactive \ \ idle' st')) t - and (\s. t = ksIdleThread s \ idle' st) - and (\s. \ runnable' st \ sch_act_not t s) - and invs'\ - setThreadState st t - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply clarsimp - apply (rule conjI) - apply fastforce - apply (rule conjI) - apply (clarsimp simp: pred_tcb_at'_def) - apply (drule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def) - subgoal by (cases st, auto simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits)[1] - apply (rule conjI) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce elim!: st_tcb_ex_cap'') - done - -lemma hf_invs' [wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ - handleFault t f \\r. invs'\" - apply (simp add: handleFault_def) - apply wp - apply (simp add: handleDoubleFault_def) - apply (wp sts_invs_minor'' dmo_invs')+ - apply (rule hoare_strengthen_postE, rule sfi_invs_plus', - simp_all) - apply (strengthen no_refs_simple_strg') - apply clarsimp - done - -declare zipWithM_x_mapM [simp del] - -lemma gts_st_tcb': - "\\\ getThreadState t \\r. st_tcb_at' (\st. st = r) t\" - apply (rule hoare_strengthen_post) - apply (rule gts_sp') - apply simp - done - -lemma setupCallerCap_pred_tcb_unchanged: - "\pred_tcb_at' proj P t and K (t \ t')\ - setupCallerCap t' t'' g - \\rv. pred_tcb_at' proj P t\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp sts_pred_tcb_neq' hoare_drop_imps) - apply clarsimp - done - -lemma si_blk_makes_simple': - "\st_tcb_at' simple' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' simple' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_drop_imps) - apply (clarsimp simp: pred_tcb_at' del: disjCI) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -lemma si_blk_makes_runnable': - "\st_tcb_at' runnable' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' runnable' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_vcg_const_imp_lift hoare_drop_imps - | simp)+ - apply (clarsimp del: disjCI simp: pred_tcb_at' elim!: pred_tcb'_weakenE) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -lemma sfi_makes_simple': - "\st_tcb_at' simple' t and K (t \ t')\ - sendFaultIPC t' ft - \\rv. st_tcb_at' simple' t\" - apply (rule hoare_gen_asm) - apply (simp add: sendFaultIPC_def - cong: if_cong capability.case_cong bool.case_cong) - apply (wpsimp wp: si_blk_makes_simple' threadSet_pred_tcb_no_state hoare_drop_imps - hoare_vcg_all_liftE_R) - done - -lemma sfi_makes_runnable': - "\st_tcb_at' runnable' t and K (t \ t')\ - sendFaultIPC t' ft - \\rv. st_tcb_at' runnable' t\" - apply (rule hoare_gen_asm) - apply (simp add: sendFaultIPC_def - cong: if_cong capability.case_cong bool.case_cong) - apply (wpsimp wp: si_blk_makes_runnable' threadSet_pred_tcb_no_state hoare_drop_imps - hoare_vcg_all_liftE_R) - done - -lemma hf_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - handleFault t ft - \\rv. st_tcb_at' P t'\" - apply (safe intro!: hoare_gen_asm) - apply (simp_all add: handleFault_def handleDoubleFault_def) - apply (wp sfi_makes_runnable' sfi_makes_simple' sts_st_tcb_at'_cases - | simp add: handleDoubleFault_def)+ - done - -crunch possibleSwitchTo, completeSignal - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - -lemma ri_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveIPC t cap isBlocking - \\rv. st_tcb_at' P t'\" - including no_pre - apply (rule hoare_gen_asm)+ - apply (simp add: receiveIPC_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (rule bind_wp [OF _ gbn_sp']) - apply wp - apply (rename_tac ep q r) - apply (case_tac ep, simp_all) - apply (wp sts_st_tcb_at'_cases | wpc | simp add: doNBRecvFailedTransfer_def)+ - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_vcg_const_imp_lift)+ - apply (simp, simp only: imp_conv_disj) - apply (wp hoare_vcg_disj_lift)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def isSend_def - split: Structures_H.thread_state.split_asm) - apply (rule hoare_pre) - apply wpsimp+ - done - -lemma rai_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveSignal t cap isBlocking - \\rv. st_tcb_at' P t'\" - apply (rule hoare_gen_asm) - apply (simp add: receiveSignal_def) - apply (rule hoare_pre) - by (wp sts_st_tcb_at'_cases getNotification_wp | wpc | simp add: doNBRecvFailedTransfer_def)+ - -lemma sendSignal_st_tcb'_Running: - "\st_tcb_at' (\st. st = Running \ P st) t\ - sendSignal ntfnptr bdg - \\_. st_tcb_at' (\st. st = Running \ P st) t\" - apply (simp add: sendSignal_def) - apply (wp sts_st_tcb_at'_cases cancelIPC_st_tcb_at' gts_wp' getNotification_wp hoare_weak_lift_imp - | wpc | clarsimp simp: pred_tcb_at')+ - done - -lemma sai_st_tcb': - "\st_tcb_at' P t and K (P Running)\ - sendSignal ntfn bdg - \\rv. st_tcb_at' P t\" - apply (rule hoare_gen_asm) - apply (subgoal_tac "\Q. P = (\st. st = Running \ Q st)") - apply (clarsimp intro!: sendSignal_st_tcb'_Running) - apply (fastforce intro!: exI[where x=P]) - done +lemma is_derived_mask'[simp]: + "is_derived' m p (maskCapRights R c) = is_derived' m p c" + by (rule ext, simp add: is_derived'_def badge_derived'_def) -end +end (* Arch *) end diff --git a/proof/refine/X64/ArchIpc_R.thy b/proof/refine/X64/ArchIpc_R.thy index d76313672e..7efd8419f6 100644 --- a/proof/refine/X64/ArchIpc_R.thy +++ b/proof/refine/X64/ArchIpc_R.thy @@ -8,910 +8,84 @@ theory ArchIpc_R imports Ipc_R begin -context begin interpretation Arch . (*FIXME: arch-split*) +context Arch begin arch_global_naming -lemmas lookup_slot_wrapper_defs'[simp] = - lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def +named_theorems Ipc_R_assms -lemma getMessageInfo_corres: +declare word64_minus_one_le[simp] + +lemma getMessageInfo_corres[Ipc_R_assms]: "corres ((=) \ message_info_map) (tcb_at t and pspace_aligned and pspace_distinct) \ (get_message_info t) (getMessageInfo t)" - apply (rule corres_guard_imp) apply (unfold get_message_info_def getMessageInfo_def fun_app_def) apply (simp add: X64_H.msgInfoRegister_def - X64.msgInfoRegister_def X64_A.msg_info_register_def) - apply (rule corres_split_eqr[OF asUser_getRegister_corres]) + X64.msgInfoRegister_def X64_A.msg_info_register_def) + apply (corres corres: asUser_getRegister_corres) apply (rule corres_trivial, simp add: message_info_from_data_eqv) - apply (wp | simp)+ - done - - -lemma get_mi_inv'[wp]: "\I\ getMessageInfo a \\x. I\" - by (simp add: getMessageInfo_def, wp) - -definition - "get_send_cap_relation rv rv' \ - (case rv of Some (c, cptr) \ (\c' cptr'. rv' = Some (c', cptr') \ - cte_map cptr = cptr' \ - cap_relation c c') - | None \ rv' = None)" - -lemma cap_relation_mask: - "\ cap_relation c c'; msk' = rights_mask_map msk \ \ - cap_relation (mask_cap msk c) (maskCapRights msk' c')" - by simp - -lemma lsfco_cte_at': - "\valid_objs' and valid_cap' cap\ - lookupSlotForCNodeOp f cap idx depth - \\rv. cte_at' rv\, -" - apply (simp add: lookupSlotForCNodeOp_def) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (wp) - apply (clarsimp simp: split_def unlessE_def - split del: if_split) - apply (wpsimp wp: hoare_drop_imps throwE_R) - done - -declare unifyFailure_wp [wp] - -(* FIXME: move *) -lemma unifyFailure_wp_E [wp]: - "\P\ f -, \\_. E\ \ \P\ unifyFailure f -, \\_. E\" - unfolding validE_E_def - by (erule unifyFailure_wp)+ - -(* FIXME: move *) -lemma unifyFailure_wp2 [wp]: - assumes x: "\P\ f \\_. Q\" - shows "\P\ unifyFailure f \\_. Q\" - by (wp x, simp) - -definition - ct_relation :: "captransfer \ cap_transfer \ bool" -where - "ct_relation ct ct' \ - ct_receive_root ct = to_bl (ctReceiveRoot ct') - \ ct_receive_index ct = to_bl (ctReceiveIndex ct') - \ ctReceiveDepth ct' = unat (ct_receive_depth ct)" - -(* MOVE *) -lemma valid_ipc_buffer_ptr_aligned_word_size_bits: - "\valid_ipc_buffer_ptr' a s; is_aligned y word_size_bits \ \ is_aligned (a + y) word_size_bits" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (erule (1) aligned_add_aligned) - apply (simp add: msg_align_bits word_size_bits_def) - done - -(* MOVE *) -lemma valid_ipc_buffer_ptr'D2: - "\valid_ipc_buffer_ptr' a s; y < max_ipc_words * word_size; is_aligned y word_size_bits\ \ typ_at' UserDataT (a + y && ~~ mask pageBits) s" - unfolding valid_ipc_buffer_ptr'_def - apply clarsimp - apply (subgoal_tac "(a + y) && ~~ mask pageBits = a && ~~ mask pageBits") - apply simp - apply (rule mask_out_first_mask_some [where n = msg_align_bits]) - apply (erule is_aligned_add_helper [THEN conjunct2]) - apply (erule order_less_le_trans) - apply (simp add: msg_align_bits max_ipc_words word_size_def) - apply simp - done - -lemma loadCapTransfer_corres: - notes msg_max_words_simps = max_ipc_words_def msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def - capTransferDataSize_def msgExtraCapBits_def - shows - "corres ct_relation \ (valid_ipc_buffer_ptr' buffer) (load_cap_transfer buffer) (loadCapTransfer buffer)" - apply (simp add: load_cap_transfer_def loadCapTransfer_def - captransfer_from_words_def - capTransferDataSize_def capTransferFromWords_def - msgExtraCapBits_def word_size add.commute add.left_commute - msg_max_length_def msg_max_extra_caps_def word_size_def - msgMaxLength_def msgMaxExtraCaps_def msgLengthBits_def wordSize_def wordBits_def - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule corres_split[OF load_word_corres]) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (clarsimp simp: ct_relation_def) - apply (wp no_irq_loadWord)+ - apply simp - apply (simp add: conj_comms) - apply safe - apply (erule valid_ipc_buffer_ptr_aligned_word_size_bits, simp add: is_aligned_def word_size_bits_def)+ - apply (erule valid_ipc_buffer_ptr'D2, - simp add: msg_max_words_simps word_size_def word_size_bits_def, - simp add: word_size_bits_def is_aligned_def)+ - done - -lemma getReceiveSlots_corres: - "corres (\xs ys. ys = map cte_map xs) - (tcb_at receiver and valid_objs and pspace_aligned) - (tcb_at' receiver and valid_objs' and pspace_aligned' and pspace_distinct' and - case_option \ valid_ipc_buffer_ptr' recv_buf) - (get_receive_slots receiver recv_buf) - (getReceiveSlots receiver recv_buf)" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def split_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF loadCapTransfer_corres]) - apply (rule corres_empty_on_failure) - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (rule lookup_cap_corres) - apply (simp add: ct_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_unify_failure) - apply (simp add: ct_relation_def) - apply (erule lookupSlotForCNodeOp_corres [OF _ refl]) - apply simp - apply (simp add: split_def liftE_bindE unlessE_whenE) - apply (rule corres_split[OF get_cap_corres]) - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap, auto)[1] - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (wp lookup_cap_valid lookup_cap_valid' lsfco_cte_at | simp)+ - done - -lemma get_recv_slot_inv'[wp]: - "\ P \ getReceiveSlots receiver buf \\rv'. P \" - apply (case_tac buf) - apply (simp add: getReceiveSlots_def) - apply (simp add: getReceiveSlots_def - split_def unlessE_def) - apply (wp | simp)+ - done - -lemma get_rs_cte_at'[wp]: - "\\\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. cte_wp_at' (\c. cteCap c = capability.NullCap) x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (rule getCTE_wp) - apply (simp add: cte_wp_at_ctes_of cong: conj_cong) - apply wp+ - apply simp - done - -lemma get_rs_real_cte_at'[wp]: - "\valid_objs'\ - getReceiveSlots receiver recv_buf - \\rv s. \x \ set rv. real_cte_at' x s\" - apply (cases recv_buf) - apply (simp add: getReceiveSlots_def) - apply (wp,simp) - apply (clarsimp simp add: getReceiveSlots_def - split_def whenE_def unlessE_whenE) - apply wp - apply simp - apply (wp hoare_drop_imps)[1] - apply simp - apply (wp lookup_cap_valid')+ - apply simp - done - -declare word_div_1 [simp] -declare word_minus_one_le [simp] -declare word64_minus_one_le [simp] - -lemma loadWordUser_corres': - "\ y < unat max_ipc_words; y' = of_nat y * 8 \ \ - corres (=) \ (valid_ipc_buffer_ptr' a) (load_word_offs a y) (loadWordUser (a + y'))" - apply simp - apply (erule loadWordUser_corres) + apply wpsimp+ done -declare loadWordUser_inv [wp] +lemma max_ipc_size_le_2_msg_align_bits[Ipc_R_assms]: + "max_ipc_words * word_size \ 2 ^ msg_align_bits" + by (simp add: max_ipc_words word_size_def msg_align_bits) -lemma getExtraCptrs_inv[wp]: - "\P\ getExtraCPtrs buf mi \\rv. P\" - apply (cases mi, cases buf, simp_all add: getExtraCPtrs_def) - apply (wp dmo_inv' mapM_wp' loadWord_inv) - done - -lemma getSlotCap_cte_wp_at_rv: - "\cte_wp_at' (\cte. P (cteCap cte) cte) p\ - getSlotCap p - \\rv. cte_wp_at' (P rv) p\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_ctes_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -lemma badge_derived_mask [simp]: - "badge_derived' (maskCapRights R c) c' = badge_derived' c c'" - by (simp add: badge_derived'_def) - -declare derived'_not_Null [simp] - -lemma maskCapRights_vsCapRef[simp]: - "vsCapRef (maskCapRights msk cap) = vsCapRef cap" - unfolding vsCapRef_def - apply (cases cap, simp_all add: maskCapRights_def isCap_simps Let_def) +lemma maskCapRights_vs_cap_ref'[simp]: + "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" + unfolding vs_cap_ref'_def + apply (cases cap, simp_all add: global.maskCapRights_def isCap_simps Let_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; - simp add: maskCapRights_def X64_H.maskCapRights_def isCap_simps Let_def) - done - -lemma corres_set_extra_badge: - "b' = b \ - corres dc (in_user_frame buffer) - (valid_ipc_buffer_ptr' buffer and - (\_. msg_max_length + 2 + n < unat max_ipc_words)) - (set_extra_badge buffer b n) (setExtraBadge buffer b' n)" - apply (rule corres_gen_asm2) - apply (drule storeWordUser_corres [where a=buffer and w=b]) - apply (simp add: set_extra_badge_def setExtraBadge_def buffer_cptr_index_def - bufferCPtrOffset_def Let_def) - apply (simp add: word_size word_size_def wordSize_def wordBits_def - bufferCPtrOffset_def buffer_cptr_index_def msgMaxLength_def - msg_max_length_def msgLengthBits_def store_word_offs_def - add.commute add.left_commute) - done - -crunch setExtraBadge - for typ_at': "\s. P (typ_at' T p s)" -lemmas setExtraBadge_typ_ats' [wp] = typ_at_lifts [OF setExtraBadge_typ_at'] -crunch setExtraBadge - for valid_pspace'[wp]: valid_pspace' -crunch setExtraBadge - for cte_wp_at'[wp]: "cte_wp_at' P p" -crunch setExtraBadge - for ipc_buffer'[wp]: "valid_ipc_buffer_ptr' buffer" - -crunch getExtraCPtr - for inv'[wp]: P (wp: dmo_inv' loadWord_inv) - -lemmas unifyFailure_discard2 - = corres_injection[OF id_injection unifyFailure_injection, simplified] - -lemma deriveCap_not_null: - "\\\ deriveCap slot cap \\rv. K (rv \ NullCap \ cap \ NullCap)\,-" - apply (simp add: deriveCap_def split del: if_split) - by (case_tac cap; wpsimp simp: isCap_simps) - -lemma deriveCap_derived_foo: - "\\s. \cap'. (cte_wp_at' (\cte. badge_derived' cap (cteCap cte) - \ capASID cap = capASID (cteCap cte) \ cap_asid_base' cap = cap_asid_base' (cteCap cte) - \ cap_vptr' cap = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s \ cap' \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot cap' \ cteCap) slot s) - \ (cte_wp_at' (untyped_derived_eq cap \ cteCap) slot s - \ cte_wp_at' (untyped_derived_eq cap' \ cteCap) slot s) - \ (s \' cap \ s \' cap') \ (cap' \ NullCap \ cap \ NullCap) \ Q cap' s\ - deriveCap slot cap \Q\,-" - using deriveCap_derived[where slot=slot and c'=cap] deriveCap_valid[where slot=slot and c=cap] - deriveCap_untyped_derived[where slot=slot and c'=cap] deriveCap_not_null[where slot=slot and cap=cap] - apply (clarsimp simp: validE_R_def validE_def valid_def split: sum.split) - apply (frule in_inv_by_hoareD[OF deriveCap_inv]) - apply (clarsimp simp: o_def) - apply (drule spec, erule mp) - apply safe - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) mp) - apply fastforce - apply (drule spec, drule(1) bspec, simp) - done - -lemma valid_mdb_untyped_incD': - "valid_mdb' s \ untyped_inc' (ctes_of s)" - by (simp add: valid_mdb'_def valid_mdb_ctes_def) - -lemma cteInsert_cte_wp_at: - "\\s. cte_wp_at' (\c. is_derived' (ctes_of s) src cap (cteCap c)) src s - \ valid_mdb' s \ valid_objs' s - \ (if p = dest then P cap - else cte_wp_at' (\c. P (maskedAsFull (cteCap c) cap)) p s)\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - apply (simp add: cteInsert_def) - apply (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp hoare_weak_lift_imp - | clarsimp simp: comp_def - | unfold setUntypedCapAsFull_def)+ - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=cte in exI) - apply clarsimp - apply (drule cte_at_cte_wp_atD) - apply (elim exE) - apply (rule_tac x=ctea in exI) - apply clarsimp - apply (cases "p=dest") - apply (clarsimp simp: cte_wp_at'_def) - apply (cases "p=src") - apply clarsimp - apply (intro conjI impI) - apply ((clarsimp simp: cte_wp_at'_def maskedAsFull_def split: if_split_asm)+)[2] - apply clarsimp - apply (rule conjI) - apply (clarsimp simp: maskedAsFull_def cte_wp_at_ctes_of split:if_split_asm) - apply (erule disjE) prefer 2 apply simp - apply (clarsimp simp: is_derived'_def isCap_simps) - apply (drule valid_mdb_untyped_incD') - apply (case_tac cte, case_tac cteb, clarsimp) - apply (drule untyped_incD', (simp add: isCap_simps)+) - apply (frule(1) ctes_of_valid'[where p = p]) - apply (clarsimp simp:valid_cap'_def capAligned_def split:if_splits) - apply (drule_tac y ="of_nat fb" in word_plus_mono_right[OF _ is_aligned_no_overflow',rotated]) - apply simp+ - apply (rule word_of_nat_less) - apply simp - apply (simp add:p_assoc_help mask_def) - apply (simp add: max_free_index_def) - apply (clarsimp simp: maskedAsFull_def is_derived'_def badge_derived'_def - isCap_simps capMasterCap_def cte_wp_at_ctes_of - split: if_split_asm capability.splits) - done - -lemma cteInsert_weak_cte_wp_at3: - assumes imp:"\c. P c \ \ isUntypedCap c" - shows " \\s. if p = dest then P cap - else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - by (wp updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases getCTE_wp' hoare_weak_lift_imp - | clarsimp simp: comp_def cteInsert_def - | unfold setUntypedCapAsFull_def - | auto simp: cte_wp_at'_def dest!: imp)+ - -lemma maskedAsFull_null_cap[simp]: - "(maskedAsFull x y = capability.NullCap) = (x = capability.NullCap)" - "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" - by (case_tac x, auto simp:maskedAsFull_def isCap_simps) - -lemma maskCapRights_eq_null: - "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = - (xa = capability.NullCap)" - apply (cases xa; simp add: maskCapRights_def isCap_simps) + simp add: X64_H.maskCapRights_def isCap_simps Let_def) + done + +lemma is_derived'_Untyped[Ipc_R_assms]: + "\isUntypedCap cap'\ + \ is_derived' m src cap' cap + = (isUntypedCap cap \ badge_derived' cap' cap \ descendants_of' src m = {})" + by (clarsimp simp add: X64.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma is_derived'_Reply[Ipc_R_assms]: + "\isReplyCap cap'\ + \ is_derived' m src cap' cap + = (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ capReplyMaster cap \ \ capReplyMaster cap')" + by (clarsimp simp add: X64.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + +lemma maskCapRights_eq_null[Ipc_R_assms, simp]: + "(RetypeDecls_H.maskCapRights r cap = capability.NullCap) = (cap = capability.NullCap)" + apply (cases cap; simp add: global.maskCapRights_def isCap_simps) apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (simp_all add: X64_H.maskCapRights_def isCap_simps) - done - -lemma cte_refs'_maskedAsFull[simp]: - "cte_refs' (maskedAsFull a b) = cte_refs' a" - apply (rule ext)+ - apply (case_tac a) - apply (clarsimp simp:maskedAsFull_def isCap_simps)+ - done - -lemma set_extra_badge_valid_arch_state[wp]: - "set_extra_badge buffer badge n \ valid_arch_state \" - unfolding set_extra_badge_def - by wp - -lemma transferCapsToSlots_corres: - "\ list_all2 (\(cap, slot) (cap', slot'). cap_relation cap cap' - \ slot' = cte_map slot) caps caps'; - mi' = message_info_map mi \ \ - corres ((=) \ message_info_map) - (\s. valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_mdb s - \ valid_list s \ valid_arch_state s - \ (case ep of Some x \ ep_at x s | _ \ True) - \ (\x \ set slots. cte_wp_at (\cap. cap = cap.NullCap) x s \ - real_cte_at x s) - \ (\(cap, slot) \ set caps. valid_cap cap s \ - cte_wp_at (\cp'. (cap \ cap.NullCap \ cp'\cap \ cp' = masked_as_full cap cap )) slot s ) - \ distinct slots - \ in_user_frame buffer s) - (\s. valid_pspace' s - \ (case ep of Some x \ ep_at' x s | _ \ True) - \ (\x \ set (map cte_map slots). - cte_wp_at' (\cte. cteCap cte = NullCap) x s - \ real_cte_at' x s) - \ distinct (map cte_map slots) - \ valid_ipc_buffer_ptr' buffer s - \ (\(cap, slot) \ set caps'. valid_cap' cap s \ - cte_wp_at' (\cte. cap \ NullCap \ cteCap cte \ cap \ cteCap cte = maskedAsFull cap cap) slot s) - \ 2 + msg_max_length + n + length caps' < unat max_ipc_words) - (transfer_caps_loop ep buffer n caps slots mi) - (transferCapsToSlots ep buffer n caps' - (map cte_map slots) mi')" - (is "\ list_all2 ?P caps caps'; ?v \ \ ?corres") -proof (induct caps caps' arbitrary: slots n mi mi' rule: list_all2_induct) - case Nil - show ?case using Nil.prems by (case_tac mi, simp) -next - case (Cons x xs y ys slots n mi mi') - note if_weak_cong[cong] if_cong [cong del] - assume P: "?P x y" - show ?case using Cons.prems P - apply (clarsimp split del: if_split) - apply (simp add: Let_def split_def word_size liftE_bindE - word_bits_conv[symmetric] split del: if_split) - apply (rule corres_const_on_failure) - apply (simp add: dc_def[symmetric] split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_if3) - apply (case_tac "fst x", auto simp add: isCap_simps)[1] - apply (rule corres_split[OF corres_set_extra_badge]) - apply (clarsimp simp: is_cap_simps) - apply (drule conjunct1) - apply simp - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (case_tac mi, simp) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (subgoal_tac "obj_ref_of (fst x) = capEPPtr (fst y)") - prefer 2 - apply (clarsimp simp: is_cap_simps) - apply (simp add: split_def) - apply (wp hoare_vcg_const_Ball_lift) - apply (rule_tac P="slots = []" and Q="slots \ []" in corres_disj_division) - apply simp - apply (rule corres_trivial, simp add: returnOk_def) - apply (case_tac mi, simp) - apply (simp add: list_case_If2 split del: if_split) - apply (rule corres_splitEE) - apply (rule unifyFailure_discard2) - apply (case_tac mi, clarsimp) - apply (rule deriveCap_corres) - apply (simp add: remove_rights_def) - apply clarsimp - apply (rule corres_split_norE) - apply (rule corres_whenE) - apply (case_tac cap', auto)[1] - apply (rule corres_trivial, simp) - apply (case_tac mi, simp) - apply simp - apply (simp add: liftE_bindE) - apply (rule corres_split_nor) - apply (rule cteInsert_corres, simp_all add: hd_map)[1] - apply (simp add: tl_map) - apply (rule corres_rel_imp, rule Cons.hyps, simp_all)[1] - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_vcg_const_Ball_lift cap_insert_derived_valid_arch_state - cap_insert_weak_cte_wp_at) - apply (wp hoare_vcg_const_Ball_lift | simp add:split_def del: imp_disj1)+ - apply (wp cap_insert_cte_wp_at) - apply (wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - cteInsert_valid_pspace - | simp add: split_def)+ - apply (wp cteInsert_weak_cte_wp_at hoare_valid_ipc_buffer_ptr_typ_at')+ - apply (wpsimp wp: hoare_vcg_const_Ball_lift cteInsert_cte_wp_at valid_case_option_post_wp - simp: split_def) - apply (unfold whenE_def) - apply wp+ - apply (clarsimp simp: conj_comms ball_conj_distrib split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ cap.NullCap \ - cte_wp_at (is_derived (cdt s) (a, b) cap') (a, b) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule derive_cap_is_derived) - apply (wp derive_cap_is_derived_foo)+ - apply (simp split del: if_split) - apply (rule_tac Q' ="\cap' s. (cap'\ capability.NullCap \ - cte_wp_at' (\c. is_derived' (ctes_of s) (cte_map (a, b)) cap' (cteCap c)) (cte_map (a, b)) s - \ QM s cap')" for QM - in hoare_strengthen_postE_R) - prefer 2 - apply clarsimp - apply assumption - apply (subst imp_conjR) - apply (rule hoare_vcg_conj_liftE_R') - apply (rule hoare_strengthen_postE_R[OF deriveCap_derived]) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (wp deriveCap_derived_foo) - apply (clarsimp simp: cte_wp_at_caps_of_state remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI, (clarsimp split del: if_split)+) - apply (clarsimp simp:conj_comms split del:if_split) - apply (intro conjI allI) - apply (clarsimp split:if_splits) - apply (case_tac "cap = fst x",simp+) - apply (clarsimp simp:masked_as_full_def is_cap_simps cap_master_cap_simps) - apply (clarsimp split del: if_split) - apply (intro conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (drule hd_in_set) - apply (drule(1) bspec) - apply (clarsimp split:if_split_asm) - apply (fastforce simp:neq_Nil_conv) - apply (intro ballI conjI) - apply (clarsimp simp:neq_Nil_conv) - apply (intro impI) - apply (drule(1) bspec[OF _ subsetD[rotated]]) - apply (clarsimp simp:neq_Nil_conv) - apply (clarsimp split:if_splits) - apply clarsimp - apply (intro conjI) - apply (drule(1) bspec,clarsimp)+ - subgoal for \ aa _ _ capa - by (case_tac "capa = aa"; clarsimp split:if_splits simp:masked_as_full_def is_cap_simps) - apply (case_tac "isEndpointCap (fst y) \ capEPPtr (fst y) = the ep \ (\y. ep = Some y)") - apply (clarsimp simp:conj_comms split del:if_split) - apply (subst if_not_P) - apply clarsimp - apply (clarsimp simp:valid_pspace'_def cte_wp_at_ctes_of split del:if_split) - apply (intro conjI) - apply (case_tac "cteCap cte = fst y",clarsimp simp: badge_derived'_def) - apply (clarsimp simp: maskCapRights_eq_null maskedAsFull_def badge_derived'_def isCap_simps - split: if_split_asm) - apply (clarsimp split del: if_split) - apply (case_tac "fst y = capability.NullCap") - apply (clarsimp simp: neq_Nil_conv split del: if_split)+ - apply (intro allI impI conjI) - apply (clarsimp split:if_splits) - apply (clarsimp simp:image_def)+ - apply (thin_tac "\x\set ys. Q x" for Q) - apply (drule(1) bspec)+ - apply clarsimp+ - apply (drule(1) bspec) - apply (rule conjI) - apply clarsimp+ - apply (case_tac "cteCap cteb = ab") - by (clarsimp simp: isCap_simps maskedAsFull_def split:if_splits)+ -qed - -declare constOnFailure_wp [wp] - -lemma transferCapsToSlots_pres1[crunch_rules]: - assumes x: "\cap src dest. \P\ cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\P\ transferCapsToSlots ep buffer n caps slots mi \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply simp - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong - split del: if_split) - apply (rule hoare_pre) - apply (wp x eb | assumption | simp split del: if_split | wpc - | wp (once) hoare_drop_imps)+ - done - -lemma cteInsert_cte_cap_to': - "\ex_cte_cap_to' p and cte_wp_at' (\cte. cteCap cte = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_cte_cap_to' p\" - apply (simp add: ex_cte_cap_to'_def) - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (rule_tac x = "cref" in exI) - apply (rule conjI) - apply clarsimp+ - done - -declare maskCapRights_eq_null[simp] - -crunch setExtraBadge - for ex_cte_cap_wp_to'[wp]: "ex_cte_cap_wp_to' P p" - (rule: ex_cte_cap_to'_pres) - -crunch setExtraBadge - for valid_objs'[wp]: valid_objs' -crunch setExtraBadge - for aligned'[wp]: pspace_aligned' -crunch setExtraBadge - for distinct'[wp]: pspace_distinct' - -lemma cteInsert_assume_Null: - "\P\ cteInsert cap src dest \Q\ \ - \\s. cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ P s\ - cteInsert cap src dest - \Q\" - apply (rule hoare_name_pre_state) - apply (erule impCE) - apply (simp add: cteInsert_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ getCTE_sp])+ - apply (rule hoare_name_pre_state) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (erule hoare_weaken_pre) - apply simp - done - -crunch setExtraBadge - for mdb'[wp]: valid_mdb' - -lemma cteInsert_weak_cte_wp_at2: - assumes weak:"\c cap. P (maskedAsFull c cap) = P c" - shows - "\\s. if p = dest then P cap else cte_wp_at' (\c. P (cteCap c)) p s\ - cteInsert cap src dest - \\uu. cte_wp_at' (\c. P (cteCap c)) p\" - supply if_cong[cong] - apply (rule hoare_pre) - apply (rule hoare_use_eq_irq_node' [OF cteInsert_ksInterruptState]) - apply (clarsimp simp:cteInsert_def) - apply (wp hoare_vcg_ex_lift updateMDB_weak_cte_wp_at updateCap_cte_wp_at_cases - setUntypedCapAsFull_cte_wp_at getCTE_wp hoare_weak_lift_imp) - apply (clarsimp simp:cte_wp_at_ctes_of weak) - apply auto - done - -lemma transferCapsToSlots_presM: - assumes x: "\cap src dest. \\s. P s \ (emx \ cte_wp_at' (\cte. cteCap cte = NullCap) dest s \ ex_cte_cap_to' dest s) - \ (vo \ valid_objs' s \ valid_cap' cap s \ real_cte_at' dest s) - \ (drv \ cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s - \ cte_wp_at' (untyped_derived_eq cap o cteCap) src s - \ valid_mdb' s) - \ (pad \ pspace_aligned' s \ pspace_distinct' s)\ - cteInsert cap src dest \\rv. P\" - assumes eb: "\b n. \P\ setExtraBadge buffer b n \\_. P\" - shows "\\s. P s - \ (emx \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) \ distinct slots) - \ (vo \ valid_objs' s \ (\x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set caps. s \' fst x ) \ distinct slots) - \ (pad \ pspace_aligned' s \ pspace_distinct' s) - \ (drv \ vo \ pspace_aligned' s \ pspace_distinct' s \ valid_mdb' s - \ length slots \ 1 - \ (\x \ set caps. s \' fst x \ (slots \ [] - \ cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s)))\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. P\" - apply (induct caps arbitrary: slots n mi) - apply (simp, wp, simp) - apply (simp add: Let_def split_def whenE_def - cong: if_cong list.case_cong split del: if_split) - apply (rule hoare_pre) - apply (wp eb hoare_vcg_const_Ball_lift hoare_vcg_const_imp_lift - | assumption | wpc)+ - apply (rule cteInsert_assume_Null) - apply (wp x hoare_vcg_const_Ball_lift cteInsert_cte_cap_to' hoare_weak_lift_imp) - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift hoare_weak_lift_imp)+ - apply (rule cteInsert_weak_cte_wp_at2,clarsimp) - apply (wp hoare_vcg_const_Ball_lift cteInsert_cte_wp_at hoare_weak_lift_imp - deriveCap_derived_foo)+ - apply (thin_tac "\slots. PROP P slots" for P) - apply (clarsimp simp: cte_wp_at_ctes_of remove_rights_def - real_cte_tcb_valid if_apply_def2 - split del: if_split) - apply (rule conjI) - apply (clarsimp simp:cte_wp_at_ctes_of untyped_derived_eq_def) - apply (intro conjI allI) - apply (clarsimp simp:Fun.comp_def cte_wp_at_ctes_of)+ - apply (clarsimp simp:valid_capAligned) - done - -lemmas transferCapsToSlots_pres2 - = transferCapsToSlots_presM[where vo=False and emx=True - and drv=False and pad=False, simplified] - -crunch transferCapsToSlots - for pspace_aligned'[wp]: pspace_aligned' -crunch transferCapsToSlots - for pspace_canonical'[wp]: pspace_canonical' -crunch transferCapsToSlots - for pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' -crunch transferCapsToSlots - for pspace_distinct'[wp]: pspace_distinct' - -lemma transferCapsToSlots_typ_at'[wp]: - "\\s. P (typ_at' T p s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (typ_at' T p s)\" - by (wp transferCapsToSlots_pres1 setExtraBadge_typ_at') - -lemma transferCapsToSlots_valid_objs[wp]: - "\valid_objs' and valid_mdb' and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and (\s. \x \ set caps. s \' fst x) and K(distinct slots)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_objs'\" - apply (rule hoare_pre) - apply (rule transferCapsToSlots_presM[where vo=True and emx=False and drv=False and pad=False]) - apply (wp | simp)+ - done - -abbreviation(input) - "transferCaps_srcs caps s \ \x\set caps. cte_wp_at' (\cte. fst x \ NullCap \ cteCap cte = fst x) (snd x) s" - -lemma transferCapsToSlots_mdb[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_mdb'\" - apply (wpsimp wp: transferCapsToSlots_presM[where drv=True and vo=True and emx=True and pad=True]) - apply (frule valid_capAligned) - apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def badge_derived'_def) - apply wp - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarify) - apply (case_tac cte) - apply (clarsimp dest!:ctes_of_valid_cap' split:if_splits) - apply (fastforce simp:valid_cap'_def) - done - -crunch setExtraBadge - for no_0'[wp]: no_0_obj' - -lemma transferCapsToSlots_no_0_obj' [wp]: - "\no_0_obj'\ transferCapsToSlots ep buffer n caps slots mi \\rv. no_0_obj'\" - by (wp transferCapsToSlots_pres1) - -lemma transferCapsToSlots_vp[wp]: - "\\s. valid_pspace' s \ distinct slots - \ length slots \ 1 - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_pspace'\" - apply (rule hoare_pre) - apply (simp add: valid_pspace'_def | wp)+ - apply (fastforce simp: cte_wp_at_ctes_of dest: ctes_of_valid') - done - -crunch setExtraBadge, doIPCTransfer - for sch_act [wp]: "\s. P (ksSchedulerAction s)" - (wp: crunch_wps mapME_wp' simp: zipWithM_x_mapM) -crunch setExtraBadge - for pred_tcb_at' [wp]: "\s. pred_tcb_at' proj P p s" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and obj_at' [wp]: "\s. P' (obj_at' P p s)" - and queues [wp]: "\s. P (ksReadyQueues s)" - and queuesL1 [wp]: "\s. P (ksReadyQueuesL1Bitmap s)" - and queuesL2 [wp]: "\s. P (ksReadyQueuesL2Bitmap s)" - (simp: storeWordUser_def) - -lemma tcts_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) - -crunch setExtraBadge - for state_refs_of'[wp]: "\s. P (state_refs_of' s)" - -lemma tcts_state_refs_of'[wp]: - "\\s. P (state_refs_of' s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. P (state_refs_of' s)\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for if_live'[wp]: if_live_then_nonz_cap' - -lemma tcts_iflive[wp]: - "\\s. if_live_then_nonz_cap' s \ distinct slots \ - (\x\set slots. - ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. if_live_then_nonz_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch setExtraBadge - for if_unsafe'[wp]: if_unsafe_then_cap' - -lemma tcts_ifunsafe[wp]: - "\\s. if_unsafe_then_cap' s \ distinct slots \ - (\x\set slots. cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s \ - ex_cte_cap_to' x s)\ transferCapsToSlots ep buffer n caps slots mi - \\rv. if_unsafe_then_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - -crunch ensureNoChildren - for it[wp]: "\s. P (ksIdleThread s)" - -crunch deriveCap - for idle'[wp]: "valid_idle'" - -crunch setExtraBadge - for valid_idle'[wp]: valid_idle' - -lemma tcts_idle'[wp]: - "\\s. valid_idle' s\ transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_idle'\" - apply (rule hoare_pre) - apply (wp transferCapsToSlots_pres1) - apply simp - done - -lemma tcts_ct[wp]: - "\cur_tcb'\ transferCapsToSlots ep buffer n caps slots mi \\rv. cur_tcb'\" - by (wp transferCapsToSlots_pres1 cur_tcb_lift) - -crunch setExtraBadge - for valid_arch_state'[wp]: valid_arch_state' - -lemma transferCapsToSlots_valid_arch [wp]: - "\valid_arch_state'\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_arch_state'\" - by (rule transferCapsToSlots_pres1; wp) - -crunch setExtraBadge - for valid_global_refs'[wp]: valid_global_refs' - -lemma transferCapsToSlots_valid_globals [wp]: - "\valid_global_refs' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' and K (distinct slots) - and K (length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_global_refs'\" - apply (wp transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=True] | clarsimp)+ - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) + apply (case_tac arch_capability; simp add: X64_H.maskCapRights_def isCap_simps) done -crunch setExtraBadge - for irq_node'[wp]: "\s. P (irq_node' s)" - -lemma transferCapsToSlots_irq_node'[wp]: - "\\s. P (irq_node' s)\ transferCapsToSlots ep buffer n caps slots mi \\rv s. P (irq_node' s)\" - by (wp transferCapsToSlots_pres1) - -lemma valid_irq_handlers_ctes_ofD: - "\ ctes_of s p = Some cte; cteCap cte = IRQHandlerCap irq; valid_irq_handlers' s \ - \ irq_issued' irq s" - by (auto simp: valid_irq_handlers'_def cteCaps_of_def ran_def) - -crunch setExtraBadge - for valid_irq_handlers'[wp]: valid_irq_handlers' +lemma capASID_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ capASID cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemma transferCapsToSlots_irq_handlers[wp]: - "\valid_irq_handlers' and valid_objs' and valid_mdb' and pspace_distinct' and pspace_aligned' - and K(distinct slots \ length slots \ 1) - and (\s. \x \ set slots. real_cte_at' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - and transferCaps_srcs caps\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. valid_irq_handlers'\" - apply (wpsimp wp: transferCapsToSlots_presM[where vo=True and emx=False and drv=True and pad=False]) - apply (clarsimp simp: is_derived'_def cte_wp_at_ctes_of badge_derived'_def) - apply (erule(2) valid_irq_handlers_ctes_ofD) - apply wp - apply (clarsimp simp:cte_wp_at_ctes_of | intro ballI conjI)+ - apply (drule(1) bspec,clarsimp) - apply (case_tac cte,clarsimp) - apply (frule(1) CSpace_I.ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done +lemma cap_asid_base'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_asid_base' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -crunch setExtraBadge - for irq_state'[wp]: "\s. P (ksInterruptState s)" +lemma cap_vptr'_gen_cap[Ipc_R_assms]: + "\ isArchObjectCap cap \ cap_vptr' cap = None" + by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemma setExtraBadge_irq_states'[wp]: - "\valid_irq_states'\ setExtraBadge buffer b n \\_. valid_irq_states'\" - apply (wp valid_irq_states_lift') - apply (simp add: setExtraBadge_def storeWordUser_def) - apply (wpsimp wp: no_irq dmo_lift' no_irq_storeWord) - apply assumption - done +lemmas transferCapsToSlots_pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="transferCapsToSlots _ _ _ _ _ _"] -lemma transferCapsToSlots_irq_states' [wp]: - "\valid_irq_states'\ transferCapsToSlots ep buffer n caps slots mi \\_. valid_irq_states'\" - by (wp transferCapsToSlots_pres1) +crunch makeArchFaultMessage + for sch_act[Ipc_R_assms, wp]: "\s. P (ksSchedulerAction s)" -lemma transferCapsToSlots_irqs_masked'[wp]: - "\irqs_masked'\ transferCapsToSlots ep buffer n caps slots mi \\rv. irqs_masked'\" - by (wp transferCapsToSlots_pres1 irqs_masked_lift) +lemma is_derived'_IRQHandlerCap[Ipc_R_assms]: + "\isIRQHandlerCap cap'\ \ is_derived' (ctes_of (s::kernel_state)) src cap' cap = + (isIRQHandlerCap cap \ badge_derived' cap' cap)" + by (clarsimp simp add: X64.is_derived'_def gen_isCap_simps) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) -lemma storeWordUser_vms'[wp]: - "\valid_machine_state'\ storeWordUser a w \\_. valid_machine_state'\" +lemma storeWordUser_vms'[Ipc_R_assms, wp]: + "storeWordUser a w \valid_machine_state'\" proof - have aligned_offset_ignore: "\(l::machine_word) (p::machine_word) sz. l<8 \ p && mask 3 = 0 \ @@ -946,757 +120,88 @@ proof - done qed -lemma setExtraBadge_vms'[wp]: - "\valid_machine_state'\ setExtraBadge buffer b n \\_. valid_machine_state'\" -by (simp add: setExtraBadge_def) wp - -lemma transferCapsToSlots_vms[wp]: - "\\s. valid_machine_state' s\ - transferCapsToSlots ep buffer n caps slots mi - \\_ s. valid_machine_state' s\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge, transferCapsToSlots - for pspace_domain_valid[wp]: "pspace_domain_valid" - -crunch setExtraBadge - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma tcts_ct_not_inQ[wp]: - "\ct_not_inQ\ - transferCapsToSlots ep buffer n caps slots mi - \\_. ct_not_inQ\" - by (wp transferCapsToSlots_pres1) - -crunch setExtraBadge - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" -crunch setExtraBadge - for ctes_of[wp]: "\s. P (ctes_of s)" - -lemma tcts_zero_ranges[wp]: - "\\s. untyped_ranges_zero' s \ valid_pspace' s \ distinct slots - \ (\x \ set slots. ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. untyped_ranges_zero'\" - apply (wpsimp wp: transferCapsToSlots_presM[where emx=True and vo=True - and drv=True and pad=True]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (simp add: cteCaps_of_def) - apply (rule hoare_pre, wp untyped_ranges_zero_lift) - apply (simp add: o_def) - apply (clarsimp simp: valid_pspace'_def ball_conj_distrib[symmetric]) - apply (drule(1) bspec) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (case_tac cte, clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply auto[1] - done - -crunch transferCapsToSlots, setExtraBadge - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - -crunch transferCapsToSlots - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift) - -lemma transferCapsToSlots_invs[wp]: - "\\s. invs' s \ distinct slots - \ (\x \ set slots. cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set slots. ex_cte_cap_to' x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (wp valid_irq_node_lift valid_dom_schedule'_lift) - apply fastforce - done - -lemma grs_distinct'[wp]: - "\\\ getReceiveSlots t buf \\rv s. distinct rv\" - apply (cases buf, simp_all add: getReceiveSlots_def - split_def unlessE_def) - apply (wp, simp) - apply (wp | simp only: distinct.simps list.simps empty_iff)+ - apply simp - done - -lemma transferCaps_corres: - "\ info' = message_info_map info; - list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x)) - caps caps' \ - \ - corres ((=) \ message_info_map) - (tcb_at receiver and valid_objs and - pspace_aligned and pspace_distinct and valid_mdb - and valid_list and valid_arch_state - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame recv_buf - and (\s. valid_message_info info) - and transfer_caps_srcs caps) - (tcb_at' receiver and valid_objs' and - pspace_aligned' and pspace_distinct' and pspace_canonical' and pspace_in_kernel_mappings' - and no_0_obj' and valid_mdb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' recv_buf - and transferCaps_srcs caps' - and (\s. length caps' \ msgMaxExtraCaps)) - (transfer_caps info caps ep receiver recv_buf) - (transferCaps info' caps' ep receiver recv_buf)" - apply (simp add: transfer_caps_def transferCaps_def - getThreadCSpaceRoot) - apply (rule corres_assume_pre) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getReceiveSlots_corres]) - apply (rule_tac x=recv_buf in option_corres) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (case_tac info, simp) - apply simp - apply (rule corres_rel_imp, rule transferCapsToSlots_corres, - simp_all add: split_def)[1] - apply (case_tac info, simp) - apply (wp hoare_vcg_all_lift get_rs_cte_at hoare_weak_lift_imp - | simp only: ball_conj_distrib)+ - apply (simp add: cte_map_def tcb_cnode_index_def split_def) - apply (clarsimp simp: valid_pspace'_def valid_ipc_buffer_ptr'_def2 - split_def - cong: option.case_cong) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_caps_of_state) - apply (frule(1) Invariants_AI.caps_of_state_valid) - apply (fastforce simp:valid_cap_def) - apply (cases info) - apply (clarsimp simp: msg_max_extra_caps_def valid_message_info_def - max_ipc_words msg_max_length_def - msgMaxExtraCaps_def msgExtraCapBits_def - shiftL_nat valid_pspace'_def) - apply (drule(1) bspec) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (case_tac cte,clarsimp) - apply (frule(1) ctes_of_valid_cap') - apply (fastforce simp:valid_cap'_def) - done - -crunch transferCaps - for typ_at'[wp]: "\s. P (typ_at' T p s)" +lemma isArchObjectCap_maskCapRights[Ipc_R_assms]: + "isArchObjectCap (Arch.maskCapRights R acap)" + by (cases acap; simp add: X64_H.maskCapRights_def isCap_simps) -lemmas transferCaps_typ_ats[wp] = typ_at_lifts [OF transferCaps_typ_at'] - -lemma isIRQControlCap_mask [simp]: - "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" - apply (case_tac c) - apply (clarsimp simp: isCap_simps maskCapRights_def Let_def)+ - apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (clarsimp simp: isCap_simps X64_H.maskCapRights_def - maskCapRights_def Let_def)+ - done - -lemma isIOPortControlCap'_mask [simp]: - "isIOPortControlCap' (maskCapRights R c) = isIOPortControlCap' c" - apply (case_tac c) - apply (clarsimp simp: isCap_simps maskCapRights_def Let_def)+ - apply (rename_tac arch_capability) - apply (case_tac arch_capability) - apply (clarsimp simp: isCap_simps X64_H.maskCapRights_def - maskCapRights_def Let_def)+ - done - -lemma isPageCap_maskCapRights[simp]: -" isArchCap isPageCap (RetypeDecls_H.maskCapRights R c) = isArchCap isPageCap c" - apply (case_tac c; simp add: isCap_simps isArchCap_def maskCapRights_def) +lemma isFrameCap_maskCapRights[simp]: + "isArchCap isFrameCap (global.maskCapRights R c) = isArchCap isFrameCap c" + apply (case_tac c; simp add: gen_isCap_simps isArchCap_def global.maskCapRights_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: isCap_simps X64_H.maskCapRights_def) done -lemma capReplyMaster_mask[simp]: - "isReplyCap c \ capReplyMaster (maskCapRights R c) = capReplyMaster c" - by (clarsimp simp: isCap_simps maskCapRights_def) - -lemma is_derived_mask' [simp]: - "is_derived' m p (maskCapRights R c) = is_derived' m p c" - apply (rule ext) - apply (simp add: is_derived'_def badge_derived'_def) - done - -lemma updateCapData_ordering: - "\ (x, capBadge cap) \ capBadge_ordering P; updateCapData p d cap \ NullCap \ - \ (x, capBadge (updateCapData p d cap)) \ capBadge_ordering P" - apply (cases cap, simp_all add: updateCapData_def isCap_simps Let_def - capBadge_def X64_H.updateCapData_def - split: if_split_asm) - apply fastforce+ - done - -lemma updateCapData_capReplyMaster: - "isReplyCap cap \ capReplyMaster (updateCapData p d cap) = capReplyMaster cap" - by (clarsimp simp: isCap_simps updateCapData_def split del: if_split) - -lemma updateCapData_is_Reply[simp]: - "(updateCapData p d cap = ReplyCap x y z) = (cap = ReplyCap x y z)" - by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def - X64_H.updateCapData_def - split del: if_split - split: if_split_asm) +lemma arch_updateCapData_ordering[Ipc_R_assms]: + "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ + \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" + by (cases acap; simp add: X64_H.updateCapData_def) + fastforce -lemma updateCapDataIRQ: - "updateCapData p d cap \ NullCap \ - isIRQControlCap (updateCapData p d cap) = isIRQControlCap cap" - apply (cases cap, simp_all add: updateCapData_def isCap_simps Let_def - X64_H.updateCapData_def - split: if_split_asm) - done +lemma ArchUpdateCapData_noReply[Ipc_R_assms]: + "Arch.updateCapData p d acap \ capability.ReplyCap x y z" + by (cases acap; simp add: X64_H.updateCapData_def) -lemma updateCapDataIOPortC: - "updateCapData p d cap \ NullCap \ - isIOPortControlCap' (updateCapData p d cap) = isIOPortControlCap' cap" - apply (cases cap, simp_all add: updateCapData_def isCap_simps Let_def - X64_H.updateCapData_def - split: if_split_asm) - done +lemma ArchUpdateCapData_noIRQControl[Ipc_R_assms]: + "Arch.updateCapData p d acap \ IRQControlCap" + by (cases acap; simp add: X64_H.updateCapData_def) -lemma updateCapData_vsCapRef[simp]: - "vsCapRef (updateCapData pr D c) = vsCapRef c" +lemma updateCapData_vs_cap_ref'[simp]: + "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" by (rule ccontr, - clarsimp simp: isCap_simps updateCapData_def Let_def + clarsimp simp: isCap_simps global.updateCapData_def Let_def X64_H.updateCapData_def - vsCapRef_def + vs_cap_ref'_def split del: if_split - split: if_split_asm) + split: if_split_asm arch_capability.splits) -lemma isPageCap_updateCapData[simp]: -"isArchCap isPageCap (updateCapData pr D c) = isArchCap isPageCap c" - apply (case_tac c; simp add:updateCapData_def isCap_simps isArchCap_def) +lemma isFrameCap_updateCapData[simp]: + "isArchCap isFrameCap (updateCapData pr D c) = isArchCap isFrameCap c" + apply (case_tac c; simp add: global.updateCapData_def isCap_simps isArchCap_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: X64_H.updateCapData_def isCap_simps isArchCap_def) apply (clarsimp split:capability.splits simp:Let_def) done -lemma lookup_cap_to'[wp]: - "\\\ lookupCap t cref \\rv s. \r\cte_refs' rv (irq_node' s). ex_cte_cap_to' r s\,-" - by (simp add: lookupCap_def lookupCapAndSlot_def | wp)+ - -lemma grs_cap_to'[wp]: - "\\\ getReceiveSlots t buf \\rv s. \x \ set rv. ex_cte_cap_to' x s\" - apply (cases buf; simp add: getReceiveSlots_def split_def unlessE_def) - apply (wp, simp) - apply (wp | simp | rule hoare_drop_imps)+ - done - -lemma grs_length'[wp]: - "\\s. 1 \ n\ getReceiveSlots receiver recv_buf \\rv s. length rv \ n\" - apply (simp add: getReceiveSlots_def split_def unlessE_def) - apply (rule hoare_pre) - apply (wp | wpc | simp)+ - done - -lemma transferCaps_invs' [wp]: - "\invs' and transferCaps_srcs caps\ - transferCaps mi caps ep receiver recv_buf - \\rv. invs'\" - apply (simp add: transferCaps_def Let_def split_def) - apply (wp get_rs_cte_at' hoare_vcg_const_Ball_lift - | wpcw | clarsimp)+ - done - -lemma get_mrs_inv'[wp]: - "\P\ getMRs t buf info \\rv. P\" - by (simp add: getMRs_def load_word_offs_def getRegister_def - | wp dmo_inv' loadWord_inv mapM_wp' - asUser_inv det_mapM[where S=UNIV] | wpc)+ - - -lemma copyMRs_typ_at': - "\\s. P (typ_at' T p s)\ copyMRs s sb r rb n \\rv s. P (typ_at' T p s)\" - by (simp add: copyMRs_def | wp mapM_wp [where S=UNIV, simplified] | wpc)+ - -lemmas copyMRs_typ_at_lifts[wp] = typ_at_lifts [OF copyMRs_typ_at'] - -lemma copy_mrs_invs'[wp]: - "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" - including classic_wp_pre - apply (simp add: copyMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord| - simp add: split_def) - apply (case_tac sb, simp_all)[1] - apply wp+ - apply (case_tac rb, simp_all)[1] - apply (wp mapM_wp dmo_invs' no_irq_mapM no_irq_storeWord no_irq_loadWord) - apply blast - apply (rule hoare_strengthen_post) - apply (rule mapM_wp) - apply (wp | simp | blast)+ - done - -crunch transferCaps - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: zipWithM_x_mapM) -crunch transferCaps - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: zipWithM_x_mapM) - -crunch setMRs - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch setMRs - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for pspace_canonical'[wp]: pspace_canonical' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' - (wp: crunch_wps simp: crunch_simps) -crunch copyMRs - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) -crunch setMessageInfo - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps simp: crunch_simps) -crunch setMessageInfo - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps simp: crunch_simps) - -lemma set_mrs_valid_objs' [wp]: - "\valid_objs'\ setMRs t a msgs \\rv. valid_objs'\" - apply (simp add: setMRs_def zipWithM_x_mapM split_def) - apply (wp asUser_valid_objs crunch_wps) - done - -crunch copyMRs - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps simp: crunch_simps) - -lemma setMRs_invs_bits[wp]: - "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - "\\s. P (state_refs_of' s)\ - setMRs t buf mrs - \\rv s. P (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ setMRs t buf mrs \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ setMRs t buf mrs \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ setMRs t buf mrs \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ setMRs t buf mrs \\rv. if_unsafe_then_cap'\" - by (simp add: setMRs_def zipWithM_x_mapM split_def storeWordUser_def | wp crunch_wps)+ - -crunch setMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma copyMRs_invs_bits[wp]: - "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\\s. P (state_refs_of' s)\ - copyMRs s sb r rb n - \\rv s. P (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ copyMRs s sb r rb n \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ copyMRs s sb r rb n \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ copyMRs s sb r rb n \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ copyMRs s sb r rb n \\rv. if_unsafe_then_cap'\" - by (simp add: copyMRs_def storeWordUser_def | wp mapM_wp' | wpc)+ - -crunch copyMRs - for no_0_obj'[wp]: no_0_obj' - (wp: crunch_wps simp: crunch_simps) - -lemma mi_map_length[simp]: "msgLength (message_info_map mi) = mi_length mi" - by (cases mi, simp) - -crunch copyMRs - for cte_wp_at'[wp]: "cte_wp_at' P p" - (wp: crunch_wps) - -lemma lookupExtraCaps_srcs[wp]: - "\\\ lookupExtraCaps thread buf info \transferCaps_srcs\,-" - apply (simp add: lookupExtraCaps_def lookupCapAndSlot_def - split_def lookupSlotForThread_def - getSlotCap_def) - apply (wp mapME_set[where R=\] getCTE_wp') - apply (rule_tac P=\ in hoare_trivE_R) - apply (simp add: cte_wp_at_ctes_of) - apply (wp | simp)+ - done - -crunch lookupExtraCaps - for inv[wp]: "P" - (wp: crunch_wps mapME_wp' simp: crunch_simps) - -lemma invs_mdb_strengthen': - "invs' s \ valid_mdb' s" by auto - -lemma lookupExtraCaps_length: - "\\s. unat (msgExtraCaps mi) \ n\ lookupExtraCaps thread send_buf mi \\rv s. length rv \ n\,-" - apply (simp add: lookupExtraCaps_def getExtraCPtrs_def) - apply (rule hoare_pre) - apply (wp mapME_length | wpc)+ - apply (clarsimp simp: upto_enum_step_def Suc_unat_diff_1 word_le_sub1) - done - -lemma getMessageInfo_msgExtraCaps[wp]: - "\\\ getMessageInfo t \\rv s. unat (msgExtraCaps rv) \ msgMaxExtraCaps\" - apply (simp add: getMessageInfo_def) - apply wp - apply (simp add: messageInfoFromWord_def Let_def msgMaxExtraCaps_def - shiftL_nat) - apply (subst nat_le_Suc_less_imp) - apply (rule unat_less_power) - apply (simp add: word_bits_def msgExtraCapBits_def) - apply (rule and_mask_less'[unfolded mask_2pm1]) - apply (simp add: msgExtraCapBits_def) - apply wpsimp+ - done - -lemma lookupCapAndSlot_corres: - "cptr = to_bl cptr' \ - corres (lfr \ (\a b. cap_relation (fst a) (fst b) \ snd b = cte_map (snd a))) - (valid_objs and pspace_aligned and tcb_at thread) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread) - (lookup_cap_and_slot thread cptr) (lookupCapAndSlot thread cptr')" - unfolding lookup_cap_and_slot_def lookupCapAndSlot_def - apply (simp add: liftE_bindE split_def) - apply (rule corres_guard_imp) - apply (rule_tac r'="\rv rv'. rv' = cte_map (fst rv)" - in corres_splitEE) - apply (rule corres_rel_imp, rule lookupSlotForThread_corres) - apply (simp add: split_def) - apply (rule corres_split[OF getSlotCap_corres]) - apply simp - apply (rule corres_returnOkTT, simp) - apply wp+ - apply (wp | simp add: liftE_bindE[symmetric])+ - done - -lemma lookupExtraCaps_corres: - "\ info' = message_info_map info; buffer = buffer'\ \ - corres (fr \ list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))) - (valid_objs and pspace_aligned and tcb_at thread and (\_. valid_message_info info)) - (valid_objs' and pspace_distinct' and pspace_aligned' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer') - (lookup_extra_caps thread buffer info) (lookupExtraCaps thread buffer' info')" - unfolding lookupExtraCaps_def lookup_extra_caps_def - apply (rule corres_gen_asm) - apply (cases "mi_extra_caps info = 0") - apply (cases info) - apply (simp add: Let_def returnOk_def getExtraCPtrs_def - liftE_bindE upto_enum_step_def mapM_def - sequence_def doMachineOp_return mapME_Nil - split: option.split) - apply (cases info) - apply (rename_tac w1 w2 w3 w4) - apply (simp add: Let_def liftE_bindE) - apply (cases buffer') - apply (simp add: getExtraCPtrs_def mapME_Nil) - apply (rule corres_returnOk) - apply simp - apply (simp add: msgLengthBits_def msgMaxLength_def word_size field_simps - getExtraCPtrs_def upto_enum_step_def upto_enum_word - word_size_def msg_max_length_def liftM_def - Suc_unat_diff_1 word_le_sub1 mapM_map_simp - upt_lhs_sub_map[where x=buffer_cptr_index] - wordSize_def wordBits_def - del: upt.simps) - apply (rule corres_guard_imp) - apply (rule corres_underlying_split) - - apply (rule_tac S = "\x y. x = y \ x < unat w2" - in corres_mapM_list_all2 - [where Q = "\_. valid_objs and pspace_aligned and tcb_at thread" and r = "(=)" - and Q' = "\_. valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' thread - and case_option \ valid_ipc_buffer_ptr' buffer'" and r'="(=)" ]) - apply simp - apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule loadWordUser_corres') - apply (clarsimp simp: buffer_cptr_index_def msg_max_length_def - max_ipc_words valid_message_info_def - msg_max_extra_caps_def word_le_nat_alt) - apply (simp add: buffer_cptr_index_def msg_max_length_def) - apply simp - apply simp - apply (simp add: load_word_offs_word_def) - apply (wp | simp)+ - apply (subst list_all2_same) - apply (clarsimp simp: max_ipc_words field_simps) - apply (simp add: mapME_def, fold mapME_def)[1] - apply (rule corres_mapME [where S = Id and r'="(\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))"]) - apply simp - apply simp - apply simp - apply (rule corres_cap_fault [OF lookupCapAndSlot_corres]) - apply simp - apply simp - apply (wp | simp)+ - apply (simp add: set_zip_same Int_lower1) - apply (wp mapM_wp [OF _ subset_refl] | simp)+ - done - -crunch copyMRs - for ctes_of[wp]: "\s. P (ctes_of s)" - (ignore: threadSet - wp: threadSet_ctes_of crunch_wps) - -lemma copyMRs_valid_mdb[wp]: - "\valid_mdb'\ copyMRs t buf t' buf' n \\rv. valid_mdb'\" - by (simp add: valid_mdb'_def copyMRs_ctes_of) - -crunch copy_mrs - for valid_arch_state[wp]: valid_arch_state - (wp: crunch_wps) - -lemma doNormalTransfer_corres: - "corres dc - (tcb_at sender and tcb_at receiver and (pspace_aligned:: det_state \ bool) - and valid_objs and cur_tcb and valid_mdb and valid_list and valid_arch_state and pspace_distinct - and (\s. case ep of Some x \ ep_at x s | _ \ True) - and case_option \ in_user_frame send_buf - and case_option \ in_user_frame recv_buf) - (tcb_at' sender and tcb_at' receiver and valid_objs' - and pspace_aligned' and pspace_distinct' and pspace_canonical' and cur_tcb' - and valid_mdb' and no_0_obj' and pspace_in_kernel_mappings' - and (\s. case ep of Some x \ ep_at' x s | _ \ True) - and case_option \ valid_ipc_buffer_ptr' send_buf - and case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_normal_transfer sender send_buf ep badge can_grant receiver recv_buf) - (doNormalTransfer sender send_buf ep badge can_grant receiver recv_buf)" - supply if_cong[cong] - apply (simp add: do_normal_transfer_def doNormalTransfer_def) - apply (rule corres_guard_imp) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule_tac F="valid_message_info mi" in corres_gen_asm) - apply (rule_tac r'="list_all2 (\x y. cap_relation (fst x) (fst y) \ snd y = cte_map (snd x))" - in corres_split) - apply (rule corres_if[OF refl]) - apply (rule corres_split_catch) - apply (rule lookupExtraCaps_corres; simp) - apply (rule corres_trivial, simp) - apply wp+ - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_split_eqr[OF copyMRs_corres]) - apply (rule corres_split) - apply (rule transferCaps_corres; simp) - apply (rename_tac mi' mi'') - apply (rule_tac F="mi_label mi' = mi_label mi" - in corres_gen_asm) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply (case_tac mi', clarsimp) - apply (simp add: badge_register_def badgeRegister_def) - apply (fold dc_def) - apply (rule asUser_setRegister_corres) - apply wp - apply simp+ - apply ((wp valid_case_option_post_wp hoare_vcg_const_Ball_lift - hoare_case_option_wp - hoare_valid_ipc_buffer_ptr_typ_at' copyMRs_typ_at' - hoare_vcg_const_Ball_lift lookupExtraCaps_length - | simp add: if_apply_def2)+) - apply (wp hoare_weak_lift_imp | strengthen valid_msg_length_strengthen)+ - apply clarsimp - apply auto - done - -lemma corres_liftE_lift: - "corres r1 P P' m m' \ - corres (f1 \ r1) P P' (liftE m) (withoutFailure m')" - by simp - -lemmas corres_ipc_thread_helper = - corres_split_eqrE[OF corres_liftE_lift [OF getCurThread_corres]] - -lemmas corres_ipc_info_helper = - corres_split_maprE [where f = message_info_map, OF _ - corres_liftE_lift [OF getMessageInfo_corres]] - -crunch doNormalTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas doNormal_lifts[wp] = typ_at_lifts [OF doNormalTransfer_typ_at'] - -lemma doNormal_invs'[wp]: - "\tcb_at' sender and tcb_at' receiver and invs'\ - doNormalTransfer sender send_buf ep badge - can_grant receiver recv_buf \\r. invs'\" - apply (simp add: doNormalTransfer_def) - apply (wp hoare_vcg_const_Ball_lift | simp)+ - done - -crunch doNormalTransfer - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps) -crunch doNormalTransfer - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps) - -lemma transferCaps_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' - and (\s. (\x\set caps. cte_wp_at' (\cte. fst x \ capability.NullCap \ cteCap cte = fst x) (snd x) s))\ - transferCaps tag caps ep receiver recv_buf - \\r. untyped_ranges_zero'\" - apply (simp add: transferCaps_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift hoare_vcg_const_imp_lift - | wpc - | simp add: ball_conj_distrib)+ - apply clarsimp - done - -crunch doNormalTransfer - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 ignore: constOnFailure) +lemma get_mrs_inv'[Ipc_R_assms, wp]: + "getMRs t buf info \P\" + by (wpsimp wp: dmo_inv' loadWord_inv mapM_wp' asUser_inv det_mapM[where S=UNIV] + simp: getMRs_def load_word_offs_def getRegister_def) -lemmas asUser_urz = untyped_ranges_zero_lift[OF asUser_gsUntypedZeroRanges] +lemma badgeRegister_badge_register[Ipc_R_assms]: + "badgeRegister = badge_register" + by (simp add: badge_register_def badgeRegister_def) -crunch doNormalTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: asUser wp: crunch_wps asUser_urz hoare_vcg_const_Ball_lift) +lemmas copyMRs__pspace_in_kernel_mappings'[Ipc_R_assms, wp] = + pspace_in_kernel_mappings'_inv[where f="copyMRs _ _ _ _ _"] -lemma msgFromLookupFailure_map[simp]: - "msgFromLookupFailure (lookup_failure_map lf) - = msg_from_lookup_failure lf" - by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) - -lemma asUser_getRestartPC_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t getRestartPC) (asUser t getRestartPC)" - apply (rule asUser_corres') - apply (rule corres_Id, simp, simp) - apply (rule no_fail_getRestartPC) - done - -lemma asUser_mapM_getRegister_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (as_user t (mapM getRegister regs)) - (asUser t (mapM getRegister regs))" - apply (rule asUser_corres') - apply (rule corres_Id [OF refl refl]) - apply (rule no_fail_mapM) - apply (simp add: getRegister_def) - done - -lemma makeArchFaultMessage_corres: +lemma makeArchFaultMessage_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (make_arch_fault_msg f t) (makeArchFaultMessage (arch_fault_map f) t)" - apply (cases f, clarsimp simp: makeArchFaultMessage_def split: arch_fault.split) + apply (cases f; clarsimp simp: makeArchFaultMessage_def ucast_nat_def split: arch_fault.split) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_trivial, simp add: arch_fault_map_def) + apply (rule corres_trivial, simp) apply (wp+, auto) done -lemma makeFaultMessage_corres: - "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (make_fault_msg ft t) - (makeFaultMessage (fault_map ft) t)" - apply (cases ft, simp_all add: makeFaultMessage_def split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_trivial, simp add: fromEnum_def enum_bool) - apply (wp | simp)+ - apply (simp add: X64_H.syscallMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (simp add: X64_H.exceptionMessage_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) - apply (rule corres_trivial, simp) - apply (wp | simp)+ - apply (rule makeArchFaultMessage_corres) - done - -lemma makeFaultMessage_inv[wp]: - "\P\ makeFaultMessage ft t \\rv. P\" - apply (cases ft, simp_all add: makeFaultMessage_def) - apply (wp asUser_inv mapM_wp' det_mapM[where S=UNIV] - det_getRestartPC getRestartPC_inv - | clarsimp simp: getRegister_def makeArchFaultMessage_def - split: arch_fault.split)+ - done - -lemmas threadget_fault_corres = - threadGet_corres [where r = fault_rel_optionation - and f = tcb_fault and f' = tcbFault, - simplified tcb_relation_def, simplified] +lemma syscallMessage_def'[Ipc_R_assms]: + "FaultHandler_H.syscallMessage \ MachineExports.syscallMessage" + by (simp add: syscallMessage_def) -lemma doFaultTransfer_corres: - "corres dc - (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender - and tcb_at receiver and case_option \ in_user_frame recv_buf - and pspace_aligned and pspace_distinct) - (case_option \ valid_ipc_buffer_ptr' recv_buf) - (do_fault_transfer badge sender receiver recv_buf) - (doFaultTransfer badge sender receiver recv_buf)" - apply (clarsimp simp: do_fault_transfer_def doFaultTransfer_def split_def - X64_H.badgeRegister_def badge_register_def) - apply (rule_tac Q="\fault. K (\f. fault = Some f) and - tcb_at sender and tcb_at receiver and - case_option \ in_user_frame recv_buf and - pspace_aligned and pspace_distinct" - and Q'="\fault'. case_option \ valid_ipc_buffer_ptr' recv_buf" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply (clarsimp simp: obj_at_def is_tcb)+ - apply (rule corres_assume_pre) - apply (fold assert_opt_def | unfold haskell_fail_def)+ - apply (rule corres_assert_opt_assume) - apply (clarsimp split: option.splits - simp: fault_rel_optionation_def assert_opt_def - map_option_case) - defer - defer - apply (clarsimp simp: fault_rel_optionation_def) - apply (wp thread_get_wp) - apply (clarsimp simp: obj_at_def is_tcb) - apply wp - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF makeFaultMessage_corres]) - apply (rule corres_split_eqr[OF setMRs_corres [OF refl]]) - apply (rule corres_split_nor[OF setMessageInfo_corres]) - apply simp - apply (rule asUser_setRegister_corres) - apply (wp | simp)+ - done +lemma exceptionMessage_def'[Ipc_R_assms]: + "FaultHandler_H.exceptionMessage \ MachineExports.exceptionMessage" + by (simp add: exceptionMessage_def) -lemma doFaultTransfer_invs[wp]: - "\invs' and tcb_at' receiver\ - doFaultTransfer badge sender receiver recv_buf - \\rv. invs'\" -supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) - by (simp add: doFaultTransfer_def split_def | wp - | clarsimp split: option.split)+ +lemma makeArchFaultMessage_inv[Ipc_R_assms, wp]: + "makeArchFaultMessage ft t \P\" + unfolding makeArchFaultMessage_def + by (wpsimp wp: asUser_inv getRestartPC_inv split: arch_fault.split) -lemma lookupIPCBuffer_valid_ipc_buffer [wp]: +lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" - unfolding lookupIPCBuffer_def X64_H.lookupIPCBuffer_def + unfolding lookupIPCBuffer_def + supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def locateSlot_conv threadGet_def comp_def) apply (wp getCTE_wp getObject_tcb_wp | wpc)+ @@ -1706,24 +211,25 @@ lemma lookupIPCBuffer_valid_ipc_buffer [wp]: apply (rule_tac x = ko in exI) apply (frule ko_at_cte_ipcbuffer[simplified cteSizeBits_def]) apply (clarsimp simp: cte_wp_at_ctes_of shiftl_t2n' simp del: imp_disjL) + apply (rename_tac ref rg sz d m) apply (clarsimp simp: valid_ipc_buffer_ptr'_def) apply (frule (1) ko_at_valid_objs') apply (clarsimp simp: projectKO_opts_defs split: kernel_object.split_asm) apply (clarsimp simp add: valid_obj'_def valid_tcb'_def isCap_simps cte_level_bits_def field_simps) apply (drule bspec [OF _ ranI [where a = "4 << cteSizeBits"]]) - apply simp - apply (clarsimp simp add: valid_cap'_def) + apply (simp add: cteSizeBits_def) + apply (clarsimp simp add: valid_cap'_def frame_at'_def) apply (rule conjI) apply (rule aligned_add_aligned) apply (clarsimp simp add: capAligned_def) apply assumption apply (erule is_aligned_andI1) - apply (case_tac xd, simp_all add: msg_align_bits bit_simps)[1] + apply (rule order_trans[rotated]) + apply (rule pbfs_atleast_pageBits) + apply (simp add: bit_simps msg_align_bits) apply (clarsimp simp: capAligned_def) - apply (drule_tac x = - "(tcbIPCBuffer ko && mask (pageBitsForSize xd)) >> pageBits" in spec) - apply (subst(asm) mult.commute mult.left_commute, subst(asm) shiftl_t2n[symmetric]) + apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize sz)) >> pageBits" in spec) apply (simp add: shiftr_shiftl1 ) apply (subst (asm) mask_out_add_aligned) apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) @@ -1731,2711 +237,81 @@ lemma lookupIPCBuffer_valid_ipc_buffer [wp]: apply (rule shiftr_less_t2n) apply (clarsimp simp: pbfs_atleast_pageBits) apply (rule and_mask_less') - apply (simp add: word_bits_conv) - done - -lemma doIPCTransfer_corres: - "corres dc - (tcb_at s and tcb_at r and valid_objs and pspace_aligned - and valid_list and valid_arch_state - and pspace_distinct and valid_mdb and cur_tcb - and (\s. case ep of Some x \ ep_at x s | _ \ True)) - (tcb_at' s and tcb_at' r and valid_pspace' and cur_tcb' - and (\s. case ep of Some x \ ep_at' x s | _ \ True)) - (do_ipc_transfer s ep bg grt r) - (doIPCTransfer s ep bg grt r)" - apply (simp add: do_ipc_transfer_def doIPCTransfer_def) - apply (rule_tac Q="\receiveBuffer sa. tcb_at s sa \ valid_objs sa \ - pspace_aligned sa \ pspace_distinct sa \ tcb_at r sa \ - cur_tcb sa \ valid_mdb sa \ valid_list sa \ valid_arch_state sa \ - (case ep of None \ True | Some x \ ep_at x sa) \ - case_option (\_. True) in_user_frame receiveBuffer sa \ - obj_at (\ko. \tcb. ko = TCB tcb - \ \\ft. tcb_fault tcb = Some ft\) s sa" - in corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule lookupIPCBuffer_corres') - apply auto[2] - apply (rule corres_underlying_split [OF _ _ thread_get_sp threadGet_inv]) - apply (rule corres_guard_imp) - apply (rule threadget_fault_corres) - apply simp - defer - apply (rule corres_guard_imp) - apply (subst case_option_If)+ - apply (rule corres_if3) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (simp add: dc_def[symmetric]) - apply (rule doNormalTransfer_corres) - apply (wp | simp add: valid_pspace'_def)+ - apply (simp add: dc_def[symmetric]) - apply (rule doFaultTransfer_corres) - apply (clarsimp simp: obj_at_def) - apply (erule ignore_if) - apply (wp|simp add: obj_at_def is_tcb valid_pspace'_def)+ - done - - -crunch doIPCTransfer - for ifunsafe[wp]: "if_unsafe_then_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -crunch doIPCTransfer - for iflive[wp]: "if_live_then_nonz_cap'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots - simp: zipWithM_x_mapM ball_conj_distrib ) -crunch doIPCTransfer - for vp[wp]: "valid_pspace'" - (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) -crunch doIPCTransfer - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for state_refs_of[wp]: "\s. P (state_refs_of' s)" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for ct[wp]: "cur_tcb'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -crunch doIPCTransfer - for idle'[wp]: "valid_idle'" - (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) -lemmas dit'_typ_ats[wp] = typ_at_lifts [OF doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: crunch_wps simp: crunch_simps) - -lemmas dit_irq_node'[wp] - = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] - -crunch doIPCTransfer - for valid_arch_state'[wp]: "valid_arch_state'" - (wp: crunch_wps simp: crunch_simps) - -(* Levity: added (20090126 19:32:26) *) -declare asUser_global_refs' [wp] - -lemma lec_valid_cap' [wp]: - "\valid_objs'\ lookupExtraCaps thread xa mi \\rv s. (\x\set rv. s \' fst x)\, -" - apply (rule hoare_pre, rule hoare_strengthen_postE_R) - apply (rule hoare_vcg_conj_liftE_R[where P'=valid_objs' and Q'="\_. valid_objs'"]) - apply (rule lookupExtraCaps_srcs) - apply wp - apply (clarsimp simp: cte_wp_at_ctes_of) - apply fastforce - apply simp - done - -crunch doIPCTransfer - for objs'[wp]: "valid_objs'" - ( wp: crunch_wps hoare_vcg_const_Ball_lift - transferCapsToSlots_valid_objs - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for global_refs'[wp]: "valid_global_refs'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_global_refsT - transferCapsToSlots_valid_globals - simp: zipWithM_x_mapM ball_conj_distrib) - -declare asUser_irq_handlers' [wp] - -crunch doIPCTransfer - for irq_handlers'[wp]: "valid_irq_handlers'" - (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_irq_handlers' - transferCapsToSlots_irq_handlers - simp: zipWithM_x_mapM ball_conj_distrib ) - -crunch doIPCTransfer - for irq_states'[wp]: "valid_irq_states'" - (wp: crunch_wps no_irq no_irq_mapM no_irq_storeWord no_irq_loadWord - no_irq_case_option simp: crunch_simps zipWithM_x_mapM) - -crunch doIPCTransfer - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps simp: crunch_simps rule: irqs_masked_lift) - -lemma doIPCTransfer_invs[wp]: - "\invs' and tcb_at' s and tcb_at' r\ - doIPCTransfer s ep bg grt r - \\rv. invs'\" - apply (simp add: doIPCTransfer_def) - apply (wpsimp wp: hoare_drop_imp) + apply (simp add: word_bits_conv pbfs_less_wb'[unfolded word_bits_conv]) done -crunch doIPCTransfer - for nosch[wp]: "\s. P (ksSchedulerAction s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option mapM_wp' - simp: split_def zipWithM_x_mapM) +(* Used in CRefine *) +lemma lookupIPCBuffer_Some_0: + "\\\ lookupIPCBuffer w t \\rv s. rv \ Some 0\" + by (wpsimp simp: lookupIPCBuffer_def Let_def getThreadBufferSlot_def locateSlot_conv) -lemma sanitise_register_corres: - "foldl (\s (a, b). UserContext (user_fpu_state s) ((user_regs s)(a := sanitise_register x a b))) s - (zip msg_template msg) = - foldl (\s (a, b). UserContext (user_fpu_state s) ((user_regs s)(a := sanitiseRegister y a b))) s - (zip msg_template msg)" - apply (rule foldl_cong) - apply simp - apply simp - apply (clarsimp) - apply (rule arg_cong) - apply (clarsimp simp: sanitise_register_def sanitiseRegister_def) - by (auto simp: sanitise_or_flags_def sanitise_and_flags_def user_vtop_def mask_def - sanitiseOrFlags_def sanitiseAndFlags_def) - -lemma handle_fault_reply_registers_corres: +lemma arch_getSanitiseRegisterInfo_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (do t' \ arch_get_sanitise_register_info t; - y \ as_user t - (zipWithM_x - (\r v. setRegister r - (sanitise_register t' r v)) - msg_template msg); - return (label = 0) - od) - (do t' \ getSanitiseRegisterInfo t; - y \ asUser t - (zipWithM_x - (\r v. setRegister r (sanitiseRegister t' r v)) - msg_template msg); - return (label = 0) - od)" - apply (rule corres_guard_imp) - apply (clarsimp simp: arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def) - apply (rule corres_split) - apply (rule asUser_corres') - apply(simp add: setRegister_def syscallMessage_def) - apply(subst zipWithM_x_modify)+ - apply(rule corres_modify') - apply (clarsimp simp: sanitise_register_corres|wp)+ - done - -lemma handleFaultReply_corres: - "ft' = fault_map ft \ - corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ - (handle_fault_reply ft t label msg) - (handleFaultReply ft' t label msg)" - apply (cases ft) - apply(simp_all add: handleFaultReply_def - handle_arch_fault_reply_def handleArchFaultReply_def - syscallMessage_def exceptionMessage_def - split: arch_fault.split) - by (rule handle_fault_reply_registers_corres)+ - -crunch handleFaultReply - for typ_at'[wp]: "\s. P (typ_at' T p s)" - -lemmas hfr_typ_ats[wp] = typ_at_lifts [OF handleFaultReply_typ_at'] - -crunch handleFaultReply - for ct'[wp]: "\s. P (ksCurThread s)" - -lemma doIPCTransfer_sch_act_simple [wp]: - "\sch_act_simple\ doIPCTransfer sender endpoint badge grant receiver \\_. sch_act_simple\" - by (simp add: sch_act_simple_def, wp) - -lemma possibleSwitchTo_invs'[wp]: - "\invs' and st_tcb_at' runnable' t - and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ - possibleSwitchTo t \\_. invs'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp tcbSchedEnqueue_invs' ssa_invs') - apply (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt]) - apply (wpsimp wp: ssa_invs' threadGet_wp)+ - apply (clarsimp dest!: obj_at_ko_at' simp: tcb_in_cur_domain'_def obj_at'_def) - done - -crunch isFinalCapability - for cur'[wp]: "\s. P (cur_tcb' s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch deleteCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma getThreadCallerSlot_inv: - "\P\ getThreadCallerSlot t \\_. P\" - by (simp add: getThreadCallerSlot_def, wp) - -lemma finaliseCapTrue_standin_tcb_at' [wp]: - "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (safe) - apply (wp getObject_ntfn_inv - | wpc - | simp)+ - done - -lemma finaliseCapTrue_standin_cur': - "\\s. cur_tcb' s\ finaliseCapTrue_standin cap v2 \\_ s'. cur_tcb' s'\" - apply (simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ finaliseCapTrue_standin_ct']) - apply (wp) - done - -lemma cteDeleteOne_cur' [wp]: - "\\s. cur_tcb' s\ cteDeleteOne slot \\_ s'. cur_tcb' s'\" - apply (simp add: cteDeleteOne_def unless_def when_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def | wp (once) cur_tcb_lift)+ - done - -lemma handleFaultReply_cur' [wp]: - "\\s. cur_tcb' s\ handleFaultReply x0 thread label msg \\_ s'. cur_tcb' s'\" - apply (clarsimp simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ handleFaultReply_ct']) - apply (wp) - done - -lemma capClass_Reply: - "capClass cap = ReplyClass tcb \ isReplyCap cap \ capTCBPtr cap = tcb" - apply (cases cap, simp_all add: isCap_simps) - apply (rename_tac arch_capability) - apply (case_tac arch_capability, simp_all) - done - -lemma reply_cap_end_mdb_chain: - "\ cte_wp_at (is_reply_cap_to t) slot s; invs s; - invs' s'; - (s, s') \ state_relation; ctes_of s' (cte_map slot) = Some cte \ - \ (mdbPrev (cteMDBNode cte) \ nullPointer - \ mdbNext (cteMDBNode cte) = nullPointer) - \ cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) - (mdbPrev (cteMDBNode cte)) s'" - apply (clarsimp simp only: cte_wp_at_reply_cap_to_ex_rights) - apply (frule(1) pspace_relation_ctes_ofI[OF state_relation_pspace_relation], - clarsimp+) - apply (subgoal_tac "\slot' rights'. caps_of_state s slot' = Some (cap.ReplyCap t True rights') - \ descendants_of slot' (cdt s) = {slot}") - apply (elim state_relationE exE) - apply (clarsimp simp: cdt_relation_def - simp del: split_paired_All) - apply (drule spec, drule(1) mp[OF _ caps_of_state_cte_at]) - apply (frule(1) pspace_relation_cte_wp_at[OF _ caps_of_state_cteD], - clarsimp+) - apply (clarsimp simp: descendants_of'_def cte_wp_at_ctes_of) - apply (frule_tac f="\S. cte_map slot \ S" in arg_cong, simp(no_asm_use)) - apply (frule invs_mdb'[unfolded valid_mdb'_def]) - apply (rule context_conjI) - apply (clarsimp simp: nullPointer_def valid_mdb_ctes_def) - apply (erule(4) subtree_prev_0) - apply (rule conjI) - apply (rule ccontr) - apply (frule valid_mdb_no_loops, simp add: no_loops_def) - apply (drule_tac x="cte_map slot" in spec) - apply (erule notE, rule r_into_trancl, rule ccontr) - apply (clarsimp simp: mdb_next_unfold valid_mdb_ctes_def nullPointer_def) - apply (rule valid_dlistEn, assumption+) - apply (subgoal_tac "ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)") - apply (frule(3) class_linksD) - apply (clarsimp simp: isCap_simps dest!: capClass_Reply[OF sym]) - apply (drule_tac f="\S. mdbNext (cteMDBNode cte) \ S" in arg_cong) - apply (simp, erule notE, rule subtree.trans_parent, assumption+) - apply (case_tac ctea, case_tac cte') - apply (clarsimp simp add: parentOf_def isMDBParentOf_CTE) - apply (simp add: sameRegionAs_def2 isCap_simps) - apply (erule subtree.cases) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) - apply (simp add: mdb_next_unfold) - apply (erule subtree.cases) - apply (clarsimp simp: valid_mdb_ctes_def) - apply (erule_tac cte=ctea in valid_dlistEn, assumption) - apply (simp add: mdb_next_unfold) - apply (clarsimp simp: mdb_next_unfold isCap_simps) - apply (drule_tac f="\S. c' \ S" in arg_cong) - apply (clarsimp simp: no_loops_direct_simp valid_mdb_no_loops) - apply (frule invs_mdb) - apply (drule invs_valid_reply_caps) - apply (clarsimp simp: valid_mdb_def reply_mdb_def - valid_reply_caps_def reply_caps_mdb_def - cte_wp_at_caps_of_state - simp del: split_paired_All) - - apply (erule_tac x=slot in allE, erule_tac x=t in allE, erule impE, fast) - apply (elim exEI) - apply clarsimp - apply (subgoal_tac "P" for P, rule sym, rule equalityI, assumption) - apply clarsimp - apply (erule(4) unique_reply_capsD) - apply (simp add: descendants_of_def) - apply (rule r_into_trancl) - apply (simp add: cdt_parent_rel_def is_cdt_parent_def) - done - -lemma unbindNotification_valid_objs'_strengthen: - "valid_tcb' tcb s \ valid_tcb' (tcbBoundNotification_update Map.empty tcb) s" - "valid_ntfn' ntfn s \ valid_ntfn' (ntfnBoundTCB_update Map.empty ntfn) s" - by (simp_all add: valid_tcb'_def valid_ntfn'_def valid_bound_tcb'_def valid_tcb_state'_def - tcb_cte_cases_def tcb_cte_cases_neqs split: ntfn.splits) - -crunch cteDeleteOne - for valid_objs'[wp]: "valid_objs'" - (simp: crunch_simps unless_def - wp: crunch_wps getObject_inv loadObject_default_inv) - -crunch handleFaultReply - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma emptySlot_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - emptySlot slot irq - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp weak_sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma cancelAllIPC_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllIPC epptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllIPC_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -lemma cancelAllSignals_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cancelAllSignals ntfnptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cancelAllSignals_def) - apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ - done - -crunch finaliseCapTrue_standin - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (ignore: setThreadState - simp: crunch_simps - wp: crunch_wps getObject_inv loadObject_default_inv) - -lemma cteDeleteOne_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - cteDeleteOne sl - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def)+ - done - -crunch emptySlot - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - -crunch handleFaultReply - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" -crunch handleFaultReply - for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - -crunch unbindNotification - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" -(wp: sbn_sch_act') - -crunch handleFaultReply - for valid_objs'[wp]: valid_objs' - -lemma cte_wp_at_is_reply_cap_toI: - "cte_wp_at ((=) (cap.ReplyCap t False rights)) ptr s - \ cte_wp_at (is_reply_cap_to t) ptr s" - by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) - -crunch handle_fault_reply - for pspace_aligned[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - -crunch cteDeleteOne, doIPCTransfer, handleFaultReply - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -lemma doReplyTransfer_corres: - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at ((=) (cap.ReplyCap receiver False rights)) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - apply (simp add: do_reply_transfer_def doReplyTransfer_def cong: option.case_cong) - apply (rule corres_underlying_split [OF _ _ gts_sp gts_sp']) - apply (rule corres_guard_imp) - apply (rule getThreadState_corres, (fastforce simp add: st_tcb_at_tcb_at)+) - apply (rule_tac F = "awaiting_reply state" in corres_req) - apply (clarsimp simp add: st_tcb_at_def obj_at_def is_tcb) - apply (fastforce simp: invs_def valid_state_def intro: has_reply_cap_cte_wpD - dest: has_reply_cap_cte_wpD - dest!: valid_reply_caps_awaiting_reply cte_wp_at_is_reply_cap_toI) - apply (case_tac state, simp_all add: bind_assoc) - apply (simp add: isReply_def liftM_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply clarsimp - apply (rename_tac mdbnode) - apply (rule_tac P="Q" and Q="Q" and P'="Q'" and Q'="(\s. Q' s \ R' s)" for Q Q' R' - in stronger_corres_guard_imp[rotated]) - apply assumption - apply (rule conjI, assumption) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (drule cte_wp_at_is_reply_cap_toI) - apply (erule(4) reply_cap_end_mdb_chain) - apply (rule corres_assert_assume[rotated], simp) - apply (simp add: getSlotCap_def) - apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_assert_assume[rotated]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule corres_guard_imp) - apply (rule corres_split[OF threadget_fault_corres]) - apply (case_tac rv, simp_all add: fault_rel_optionation_def bind_assoc)[1] - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wp set_thread_state_runnable_valid_sched - set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' - sts_valid_objs' delete_one_tcbDomain_obj_at' - | simp add: valid_tcb_state'_def - | strengthen valid_queues_in_correct_ready_q valid_sched_valid_queues - valid_queues_ready_qs_distinct)+ - apply (strengthen cte_wp_at_reply_cap_can_fast_finalise) - apply (wp hoare_vcg_conj_lift) - apply (rule hoare_strengthen_post [OF do_ipc_transfer_non_null_cte_wp_at]) - prefer 2 - apply (erule cte_wp_at_weakenE) - apply (fastforce) - apply (clarsimp simp:is_cap_simps) - apply (wp weak_valid_sched_action_lift)+ - apply (rule_tac Q'="\_ s. valid_objs' s \ cur_tcb' s \ tcb_at' receiver s - \ sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp, simp add: sch_act_wf_weak) - apply (wp tcb_in_cur_domain'_lift) - defer - apply (simp) - apply (wp)+ - apply (clarsimp simp: invs_psp_aligned invs_distinct) - apply (rule conjI, erule invs_valid_objs) - apply (rule conjI, clarsimp)+ - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp) - apply (rule conjI, rule refl) - apply (fastforce) - apply (clarsimp simp: invs_def valid_sched_def valid_sched_action_def) - apply (simp) - apply (auto simp: invs'_def valid_state'_def)[1] - - apply (rule corres_guard_imp) - apply (rule corres_split[OF cap_delete_one_corres]) - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (rule corres_split_eqr[OF getMRs_corres]) - apply (simp(no_asm) del: dc_simp) - apply (rule corres_split_eqr[OF handleFaultReply_corres]) - apply simp - apply (rule corres_split) - apply (rule threadset_corresT; - clarsimp simp add: tcb_relation_def fault_rel_optionation_def cteSizeBits_def - tcb_cap_cases_def tcb_cte_cases_def inQ_def) - apply (rule_tac P="valid_sched and cur_tcb and tcb_at receiver - and pspace_aligned and pspace_distinct" - and P'="tcb_at' receiver and cur_tcb' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and valid_objs' - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_inst) - apply (case_tac rvb, simp_all)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (fold dc_def, rule possibleSwitchTo_corres) - apply simp - apply (wp hoare_weak_lift_imp hoare_weak_lift_imp_conj - set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' - | simp - | force simp: valid_sched_def valid_sched_action_def - valid_tcb_state'_def)+ - apply (rule corres_guard_imp) - apply (rule setThreadState_corres) - apply clarsimp+ - apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state - thread_set_not_state_valid_sched - threadSet_tcbDomain_triv threadSet_valid_objs' - threadSet_sched_pointers threadSet_valid_sched_pointers - | simp add: valid_tcb_state'_def)+ - apply (rule_tac Q'="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and - valid_objs and pspace_aligned and pspace_distinct" - in hoare_strengthen_post [rotated], clarsimp) - apply (wp) - apply (rule hoare_chain [OF cap_delete_one_invs]) - apply (assumption) - apply fastforce - apply (rule_tac Q'="\_. tcb_at' sender and tcb_at' receiver and invs'" - in hoare_strengthen_post [rotated]) - apply (solves\auto simp: invs'_def valid_state'_def\) - apply wp - apply clarsimp - apply (rule conjI) - apply (erule cte_wp_at_weakenE) - apply (clarsimp simp add: can_fast_finalise_def) - apply (erule(1) emptyable_cte_wp_atD) - apply (rule allI, rule impI) - apply (clarsimp simp add: is_master_reply_cap_def) - apply (clarsimp) - done - -(* when we cannot talk about reply cap rights explicitly (for instance, when a schematic ?rights - would be generated too early *) -lemma doReplyTransfer_corres': - "corres dc - (einvs and tcb_at receiver and tcb_at sender - and cte_wp_at (is_reply_cap_to receiver) slot) - (invs' and tcb_at' sender and tcb_at' receiver - and valid_pspace' and cte_at' (cte_map slot)) - (do_reply_transfer sender receiver slot grant) - (doReplyTransfer sender receiver (cte_map slot) grant)" - using doReplyTransfer_corres[of receiver sender _ slot] - by (fastforce simp add: cte_wp_at_reply_cap_to_ex_rights corres_underlying_def) + (arch_get_sanitise_register_info t) + (getSanitiseRegisterInfo t)" + unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def + by (fold archThreadGet_def, corres) -lemma valid_pspace'_splits[elim!]: - "valid_pspace' s \ valid_objs' s" - "valid_pspace' s \ pspace_aligned' s" - "valid_pspace' s \ pspace_canonical' s" - "valid_pspace' s \ pspace_in_kernel_mappings' s" - "valid_pspace' s \ pspace_distinct' s" - "valid_pspace' s \ valid_mdb' s" - "valid_pspace' s \ no_0_obj' s" - by (simp add: valid_pspace'_def)+ - -lemma sts_valid_pspace_hangers: - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. valid_objs'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_distinct'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_aligned'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_canonical'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. pspace_in_kernel_mappings'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. valid_mdb'\" - "\valid_pspace' and tcb_at' t and valid_tcb_state' st\ setThreadState st t \\rv. no_0_obj'\" - by (safe intro!: hoare_strengthen_post [OF sts'_valid_pspace'_inv]) - -declare no_fail_getSlotCap [wp] - -lemma setupCallerCap_corres: - "corres dc - (st_tcb_at (Not \ halted) sender and tcb_at receiver and - st_tcb_at (Not \ awaiting_reply) sender and valid_reply_caps and - valid_objs and pspace_distinct and pspace_aligned and valid_mdb - and valid_list and valid_arch_state and - valid_reply_masters and cte_wp_at (\c. c = cap.NullCap) (receiver, tcb_cnode_index 3)) - (tcb_at' sender and tcb_at' receiver and valid_pspace' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) - (setup_caller_cap sender receiver grant) - (setupCallerCap sender receiver grant)" - supply if_split[split del] - apply (simp add: setup_caller_cap_def setupCallerCap_def - getThreadReplySlot_def locateSlot_conv - getThreadCallerSlot_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split_nor) - apply (rule setThreadState_corres) - apply (simp split: option.split) - apply (rule corres_symb_exec_r) - apply (rule_tac F="\r. cteCap masterCTE = capability.ReplyCap sender True r - \ mdbNext (cteMDBNode masterCTE) = nullPointer" - in corres_gen_asm2, clarsimp simp add: isCap_simps) - apply (rule corres_symb_exec_r) - apply (rule_tac F="rv = capability.NullCap" - in corres_gen_asm2, simp) - apply (rule cteInsert_corres) - apply (simp split: if_splits) - apply (simp add: cte_map_def tcbReplySlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (simp add: cte_map_def tcbCallerSlot_def - tcb_cnode_index_def cte_level_bits_def) - apply (rule_tac Q'="\rv. cte_at' (receiver + 2 ^ cte_level_bits * tcbCallerSlot)" - in hoare_post_add) - - apply (wp, (wp getSlotCap_wp)+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at'_def cte_at'_def) - apply (rule_tac Q'="\rv. cte_at' (sender + 2 ^ cte_level_bits * tcbReplySlot)" - in hoare_post_add) - apply (wp, (wp getCTE_wp')+) - apply blast - apply (rule no_fail_pre, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (wp sts_valid_pspace_hangers - | simp add: cte_wp_at_ctes_of)+ - apply (clarsimp simp: valid_tcb_state_def st_tcb_at_reply_cap_valid - st_tcb_at_tcb_at st_tcb_at_caller_cap_null - split: option.split) - apply (clarsimp simp: valid_tcb_state'_def valid_cap'_def capAligned_reply_tcbI) - apply (frule(1) st_tcb_at_reply_cap_valid, simp, clarsimp) - apply (clarsimp simp: cte_wp_at_ctes_of cte_wp_at_caps_of_state) - apply (drule pspace_relation_cte_wp_at[rotated, OF caps_of_state_cteD], - erule valid_pspace'_splits, clarsimp+)+ - apply (clarsimp simp: cte_wp_at_ctes_of cte_map_def tcbReplySlot_def - tcbCallerSlot_def tcb_cnode_index_def - is_cap_simps) - apply (auto intro: reply_no_descendants_mdbNext_null[OF not_waiting_reply_slot_no_descendants] - simp: cte_index_repair shiftl_t2n') - done - -crunch getThreadCallerSlot - for tcb_at'[wp]: "tcb_at' t" - -lemma getThreadReplySlot_tcb_at'[wp]: - "\tcb_at' t\ getThreadReplySlot tcb \\_. tcb_at' t\" - by (simp add: getThreadReplySlot_def, wp) - -lemma setupCallerCap_tcb_at'[wp]: - "\tcb_at' t\ setupCallerCap sender receiver grant \\_. tcb_at' t\" - by (simp add: setupCallerCap_def, wp hoare_drop_imp) - -crunch setupCallerCap - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps) - -lemma cteInsert_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert newCap srcSlot destSlot - \\_ s. sch_act_wf (ksSchedulerAction s) s\" -by (wp sch_act_wf_lift tcb_in_cur_domain'_lift) - -lemma setupCallerCap_sch_act [wp]: - "\\s. sch_act_not t s \ sch_act_wf (ksSchedulerAction s) s\ - setupCallerCap t r g \\_ s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: setupCallerCap_def getSlotCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv) - apply (wp getCTE_wp' sts_sch_act' hoare_drop_imps hoare_vcg_all_lift) - apply clarsimp - done - -lemma possibleSwitchTo_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def threadGet_def curDomain_def - bitmap_fun_defs) - apply (wp rescheduleRequired_weak_sch_act_wf - weak_sch_act_wf_lift_linear[where f="tcbSchedEnqueue t"] - getObject_tcb_wp hoare_weak_lift_imp - | wpc)+ - apply (clarsimp simp: obj_at'_def projectKOs weak_sch_act_wf_def ps_clear_def tcb_in_cur_domain'_def) - done - -lemmas transferCapsToSlots_pred_tcb_at' = - transferCapsToSlots_pres1 [OF cteInsert_pred_tcb_at'] - -crunch doIPCTransfer, possibleSwitchTo - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - (wp: mapM_wp' crunch_wps simp: zipWithM_x_mapM) - -lemma setSchedulerAction_ct_in_domain: - "\\s. ct_idle_or_in_cur_domain' s - \ p \ ResumeCurrentThread \ setSchedulerAction p - \\_. ct_idle_or_in_cur_domain'\" - by (simp add:setSchedulerAction_def | wp)+ - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - (wp: crunch_wps setSchedulerAction_ct_in_domain simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" - (wp: crunch_wps constOnFailure_wp simp: crunch_simps) - -crunch possibleSwitchTo +crunch getSanitiseRegisterInfo for tcb_at'[wp]: "tcb_at' t" - (wp: crunch_wps) - -crunch possibleSwitchTo - for valid_pspace'[wp]: valid_pspace' - (wp: crunch_wps) - -lemma sendIPC_corres: -(* call is only true if called in handleSyscall SysCall, which - is always blocking. *) - assumes "call \ bl" - shows - "corres dc (einvs and st_tcb_at active t and ep_at ep and ex_nonz_cap_to t) - (invs' and sch_act_not t and tcb_at' t and ep_at' ep) - (send_ipc bl call bg cg cgr t ep) (sendIPC bl call bg cg cgr t ep)" -proof - - show ?thesis - apply (insert assms) - apply (unfold send_ipc_def sendIPC_def Let_def) - apply (case_tac bl) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\ob. ob = Endpoint rv) ep - and ex_nonz_cap_to t" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (case_tac rv) - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_psp_aligned invs_distinct) - apply clarsimp - \ \concludes IdleEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_psp_aligned invs_distinct) - apply clarsimp - \ \concludes SendEP if bl branch\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (simp add: isReceive_def split del:if_split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: case_bool_If case_option_If if3_fold - simp del: dc_simp split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule corres_split[OF possibleSwitchTo_corres]) - apply (fold when_def)[1] - apply (rule_tac P="call" and P'="call" - in corres_symmetric_bool_cases, blast) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (rule corres_if2, simp) - apply (rule setupCallerCap_corres) - apply (rule setThreadState_corres, simp) - apply (rule corres_trivial) - apply (simp add: when_def dc_def[symmetric] split del: if_split) - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (simp split del: if_split add: if_apply_def2) - apply (wp hoare_drop_imps)[1] - apply (wp | simp)+ - apply (wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases) - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases)[1] - apply (simp add: valid_tcb_state_def pred_conj_def) - apply (strengthen reply_cap_doesnt_exist_strg disjI2_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues)+ - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - do_ipc_transfer_valid_arch - | clarsimp simp: is_cap_simps)+)[1] - apply (simp add: pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift hoare_drop_imps)[1] - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply (simp) - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb')+ - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def ep_redux_simps - ep_redux_simps' st_tcb_at_tcb_at valid_ep_def - cong: list.case_cong) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_def2 valid_sched_def valid_sched_action_def) - apply (force simp: st_tcb_def2 dest!: st_tcb_at_caller_cap_null[simplified,rotated]) - subgoal by (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres, - where - R="\rv. einvs and st_tcb_at active t and ep_at ep and - valid_ep rv and obj_at (\k. k = Endpoint rv) ep" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv'"]) - apply (rename_tac rv rv') - apply (case_tac rv) - apply (simp add: ep_relation_def) - \ \concludes IdleEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - \ \concludes SendEP branch if not bl and no ft\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (simp add: valid_ep_def) - apply (case_tac list) - apply simp - apply (rule_tac F="a \ t" in corres_req) - apply (clarsimp simp: invs_def valid_state_def - valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_def obj_at_def tcb_bound_refs_def2) - apply fastforce - apply (clarsimp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. recv_state = Structures_A.BlockedOnReceive ep data" - in corres_gen_asm) - apply (clarsimp simp: isReceive_def case_bool_If - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (simp add: if_apply_def2) - apply ((wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases | - simp add: if_apply_def2 split del: if_split)+)[1] - apply (wp sts_weak_sch_act_wf sts_valid_objs' - sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases) - apply (simp add: valid_tcb_state_def pred_conj_def) - apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift - | clarsimp simp: is_cap_simps - | strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues )+)[1] - apply (simp add: valid_tcb_state'_def pred_conj_def) - apply (strengthen sch_act_wf_weak) - apply (wp weak_sch_act_wf_lift_linear hoare_drop_imps) - apply (wp gts_st_tcb_at)+ - apply (simp add: pred_conj_def cong: conj_cong) - apply (wp hoare_TrueI) - apply simp - apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb') - apply (clarsimp simp add: invs_def valid_state_def - valid_pspace_def ep_redux_simps ep_redux_simps' - st_tcb_at_tcb_at - cong: list.case_cong) - apply (clarsimp simp: valid_ep_def) - apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) - apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid - st_tcb_at_caller_cap_null) - apply (fastforce simp: st_tcb_def2 valid_sched_def valid_sched_action_def) - subgoal by (auto simp: valid_ep'_def - split: list.split; - clarsimp simp: invs'_def valid_state'_def) - apply wp+ - apply (clarsimp simp: ep_at_def2)+ - done -qed - -lemmas setMessageInfo_typ_ats[wp] = typ_at_lifts [OF setMessageInfo_typ_at'] - -(* Annotation added by Simon Winwood (Thu Jul 1 20:54:41 2010) using taint-mode *) -declare tl_drop_1[simp] - -crunch cancel_ipc - for cur[wp]: "cur_tcb" - (wp: crunch_wps simp: crunch_simps) - -lemma valid_sched_weak_strg: - "valid_sched s \ weak_valid_sched_action s" - by (simp add: valid_sched_def valid_sched_action_def) -lemma sendSignal_corres: - "corres dc (einvs and ntfn_at ep) (invs' and ntfn_at' ep) - (send_signal ep bg) (sendSignal ep bg)" - supply if_cong[cong] - apply (simp add: send_signal_def sendSignal_def Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getNotification_corres, - where - R = "\rv. einvs and ntfn_at ep and valid_ntfn rv and - ko_at (Structures_A.Notification rv) ep" and - R' = "\rv'. invs' and ntfn_at' ep and - valid_ntfn' rv' and ko_at' rv' ep"]) - defer - apply (wp get_simple_ko_ko_at get_ntfn_ko')+ - apply (simp add: invs_valid_objs)+ - apply (case_tac "ntfn_obj ntfn") - \ \IdleNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (case_tac "ntfnBoundTCB nTFN") - apply clarsimp - apply (rule corres_guard_imp[OF setNotification_corres]) - apply (clarsimp simp add: ntfn_relation_def)+ - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_if) - apply (fastforce simp: receive_blocked_def receiveBlocked_def - thread_state_relation_def - split: Structures_A.thread_state.splits - Structures_H.thread_state.splits) - apply (rule corres_split[OF cancel_ipc_corres]) - apply (rule corres_split[OF setThreadState_corres]) - apply (clarsimp simp: thread_state_relation_def) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply wp - apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' - sts_st_tcb' sts_valid_objs' hoare_disjI2 - cancel_ipc_cte_wp_at_not_reply_state - | strengthen invs_vobjs_strgs invs_psp_aligned_strg valid_sched_weak_strg - valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct - valid_sched_valid_queues - | simp add: valid_tcb_state_def)+ - apply (rule_tac Q'="\rv. invs' and tcb_at' a" in hoare_strengthen_post) - apply wp - apply (fastforce simp: invs'_def valid_state'_def sch_act_wf_weak valid_tcb_state'_def) - apply (rule setNotification_corres) - apply (clarsimp simp add: ntfn_relation_def) - apply (wp gts_wp gts_wp' | clarsimp)+ - apply (auto simp: valid_ntfn_def receive_blocked_def valid_sched_def invs_cur - elim: pred_tcb_weakenE - intro: st_tcb_at_reply_cap_valid - split: Structures_A.thread_state.splits)[1] - apply (clarsimp simp: valid_ntfn'_def invs'_def valid_state'_def valid_pspace'_def sch_act_wf_weak) - \ \WaitingNtfn\ - apply (clarsimp simp add: ntfn_relation_def Let_def) - apply (simp add: update_waiting_ntfn_def) - apply (rename_tac list) - apply (case_tac "tl list = []") - \ \tl list = []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper split del: if_split) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply ((wp | simp)+)[1] - apply (rule_tac Q'="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and - cur_tcb' and - st_tcb_at' runnable' (hd list) and valid_objs' and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct'" - in hoare_post_imp, clarsimp simp: pred_tcb_at' elim!: sch_act_wf_weak) - apply (wp | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (wp set_simple_ko_valid_objs set_ntfn_aligned' set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def ntfn_queued_st_tcb_at valid_sched_def - valid_sched_action_def) - apply (auto simp: valid_ntfn'_def )[1] - apply (clarsimp simp: invs'_def valid_state'_def) - - \ \tl list \ []\ - apply (rule corres_guard_imp) - apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def split:list.splits) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule possibleSwitchTo_corres) - apply (wp cur_tcb_lift | simp)+ - apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action - | simp)+ - apply (wpsimp wp: sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb) - apply (wp set_ntfn_aligned' set_simple_ko_valid_objs set_ntfn_valid_objs' - hoare_vcg_disj_lift weak_sch_act_wf_lift_linear - | simp add: valid_tcb_state_def valid_tcb_state'_def)+ - apply (fastforce simp: invs_def valid_state_def valid_ntfn_def - valid_pspace_def neq_Nil_conv - ntfn_queued_st_tcb_at valid_sched_def valid_sched_action_def - split: option.splits) - apply (auto simp: valid_ntfn'_def neq_Nil_conv invs'_def valid_state'_def - weak_sch_act_wf_def - split: option.splits)[1] - \ \ActiveNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def combine_ntfn_badges_def - combine_ntfn_msgs_def) - apply (simp add: invs_def valid_state_def valid_ntfn_def) - apply (simp add: invs'_def valid_state'_def valid_ntfn'_def) - done - -lemma valid_Running'[simp]: - "valid_tcb_state' Running = \" - by (rule ext, simp add: valid_tcb_state'_def) - -crunch setMRs - for typ'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma possibleSwitchTo_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) - apply (wp hoare_weak_lift_imp threadSet_sch_act setQueue_sch_act threadGet_wp - | simp add: unless_def | wpc)+ - apply (auto simp: obj_at'_def projectKOs tcb_in_cur_domain'_def) - done - -crunch possibleSwitchTo - for st_refs_of'[wp]: "\s. P (state_refs_of' s)" - and cap_to'[wp]: "ex_nonz_cap_to' p" - and objs'[wp]: valid_objs' - and ct[wp]: cur_tcb' - (wp: cur_tcb_lift crunch_wps) - -lemma possibleSwitchTo_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) - and pspace_aligned' and pspace_distinct'\ - possibleSwitchTo t - \\_. if_live_then_nonz_cap'\" - apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wp | wpc | simp)+ - apply (simp only: imp_conv_disj, wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (wp threadGet_wp)+ - apply (auto simp: obj_at'_def) - done - -crunch possibleSwitchTo - for ifunsafe[wp]: if_unsafe_then_cap' - and idle'[wp]: valid_idle' - and global_refs'[wp]: valid_global_refs' - and arch_state'[wp]: valid_arch_state' - and irq_node'[wp]: "\s. P (irq_node' s)" - and typ_at'[wp]: "\s. P (typ_at' T p s)" - and irq_handlers'[wp]: valid_irq_handlers' - and irq_states'[wp]: valid_irq_states' - (simp: unless_def tcb_cte_cases_def cteSizeBits_def wp: crunch_wps) - -crunch sendSignal - for ct'[wp]: "\s. P (ksCurThread s)" - and it'[wp]: "\s. P (ksIdleThread s)" - (wp: crunch_wps simp: crunch_simps o_def) - -context -notes option.case_cong_weak[cong] -begin -crunch sendSignal, setBoundNotification - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps getObject_inv loadObject_default_inv - simp: crunch_simps unless_def o_def - rule: irqs_masked_lift) -end - -lemma ct_in_state_activatable_imp_simple'[simp]: - "ct_in_state' activatable' s \ ct_in_state' simple' s" - apply (simp add: ct_in_state'_def) - apply (erule pred_tcb'_weakenE) - apply (case_tac st; simp) - done - -lemma setThreadState_nonqueued_state_update: - "\\s. invs' s \ st_tcb_at' simple' t s - \ st \ {Inactive, Running, Restart, IdleThreadState} - \ (st \ Inactive \ ex_nonz_cap_to' t s) - \ (t = ksIdleThread s \ idle' st) - \ (\ runnable' st \ sch_act_simple s)\ - setThreadState st t - \\_. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply (clarsimp simp: pred_tcb_at') - apply (rule conjI, fastforce simp: valid_tcb_state'_def) - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (rule conjI) - apply clarsimp - apply (erule delta_sym_refs) - apply (fastforce split: if_split_asm) - apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) - apply fastforce - done - -lemma cteDeleteOne_reply_cap_to'[wp]: - "\ex_nonz_cap_to' p and - cte_wp_at' (\c. isReplyCap (cteCap c)) slot\ - cteDeleteOne slot - \\rv. ex_nonz_cap_to' p\" - apply (simp add: cteDeleteOne_def ex_nonz_cap_to'_def unless_def) - apply (rule bind_wp [OF _ getCTE_sp]) - apply (rule hoare_assume_pre) - apply (subgoal_tac "isReplyCap (cteCap cte)") - apply (wp hoare_vcg_ex_lift emptySlot_cte_wp_cap_other isFinalCapability_inv - | clarsimp simp: finaliseCap_def isCap_simps - | wp (once) hoare_drop_imps)+ - apply (fastforce simp: cte_wp_at_ctes_of) - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) - done - -crunch setupCallerCap, possibleSwitchTo, asUser, doIPCTransfer - for vms'[wp]: "valid_machine_state'" - (wp: crunch_wps simp: zipWithM_x_mapM_x) - -crunch cancelSignal - for nonz_cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps simp: crunch_simps) - -lemma cancelIPC_nonz_cap_to'[wp]: - "\ex_nonz_cap_to' p\ cancelIPC t \\rv. ex_nonz_cap_to' p\" - apply (simp add: cancelIPC_def getThreadReplySlot_def Let_def - capHasProperty_def) - apply (wp threadSet_cap_to' - | wpc - | simp - | clarsimp elim!: cte_wp_at_weakenE' - | rule hoare_post_imp[where Q'="\rv. ex_nonz_cap_to' p"])+ - done - - -crunch activateIdleThread, getThreadReplySlot, isFinalCapability - for nosch[wp]: "\s. P (ksSchedulerAction s)" - (simp: Let_def) - -crunch setupCallerCap, asUser, setMRs, doIPCTransfer, possibleSwitchTo - for pspace_domain_valid[wp]: "pspace_domain_valid" - (wp: crunch_wps simp: zipWithM_x_mapM_x) - -crunch setupCallerCap, doIPCTransfer, possibleSwitchTo - for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksDomScheduleStart[wp]: "\s. P (ksDomScheduleStart s)" - (wp: crunch_wps simp: zipWithM_x_mapM) - -lemma setThreadState_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - setThreadState st t - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - unfolding setThreadState_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imps) - -lemma cancelAllIPC_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllIPC epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllIPC_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wp)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -lemma cancelAllSignals_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllSignals epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllSignals_def) - apply (wp | wpc)+ - apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) - apply simp - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ - done - -crunch finaliseCapTrue_standin - for not_rct[wp]: "\s. ksSchedulerAction s \ ResumeCurrentThread" - (simp: Let_def) - -lemma cancelIPC_ResumeCurrentThread_imp_notct[wp]: - "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelIPC t - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - (is "\?PRE t'\ _ \_\") -proof - - have aipc: "\t t' ntfn. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cancelSignal t ntfn - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cancelSignal_def) - apply (wp)[1] - apply (wp hoare_convert_imp)+ - apply (rule_tac P="\s. ksSchedulerAction s \ ResumeCurrentThread" - in hoare_weaken_pre) - apply (wpc) - apply (wp | simp)+ - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done - have cdo: "\t t' slot. - \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - cteDeleteOne slot - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp hoare_convert_imp | simp)+ - done - show ?thesis - apply (simp add: cancelIPC_def Let_def) - apply (wp, wpc) - prefer 4 \ \state = Running\ - apply wp - prefer 7 \ \state = Restart\ - apply wp - apply (wp)+ - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp cdo)+ - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply ((wp aipc hoare_convert_imp)+)[6] - apply (wp) - apply (wp hoare_convert_imp)[1] - apply (wpc, wp+) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wp) - apply simp - done +crunch arch_get_sanitise_register_info + for pspace_distinct[wp]: pspace_distinct + and pspace_aligned[wp]: pspace_aligned + +lemma sanitiseRegister_sanitise_register[Ipc_R_assms]: + "sanitiseRegister = sanitise_register" + by (rule ext)+ + (clarsimp simp add: sanitiseRegister_def sanitise_register_def cong: register.case_cong) + +lemma handleArchFaultReply_corres[Ipc_R_assms]: + "corres (=) \ \ + (handle_arch_fault_reply ft t label msg) (handleArchFaultReply (arch_fault_map ft) t label msg)" + by (clarsimp simp: handle_arch_fault_reply_def handleArchFaultReply_def + split: arch_fault.split) + +crunch getSanitiseRegisterInfo, handleArchFaultReply, handle_arch_fault_reply + for inv[Ipc_R_assms, wp]: P + +lemma ctes_of_mdbNext_parentOf[Ipc_R_assms]: + "\ ctes_of s' \ cte_map cptr \ cte_map slot; + ctes_of s' (cte_map cptr) = Some (CTE (capability.ReplyCap t master rights) n); + ctes_of s' (mdbNext (cteMDBNode cte)) = Some (CTE (capability.ReplyCap t master' rights') n'); + ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)\ + \ ctes_of s' \ cte_map cptr parentOf mdbNext (cteMDBNode cte)" + by (clarsimp simp add: parentOf_def isMDBParentOf_CTE sameRegionAs_def2 isCap_simps) + (erule subtree.cases; clarsimp simp: parentOf_def isMDBParentOf_CTE) + +crunch debugPrint + for inv[Ipc_R_assms, wp]: P + and (no_fail) no_fail[Ipc_R_assms, intro!, wp, simp] + +(* this specifically refers to the 4 message registers *) +lemma max_message_size_less_max_ipc_words[Ipc_R_assms]: + "n \ 4 + \ word_size * (word_of_nat msg_max_extra_caps + (word_of_nat msg_max_length + n)) + < max_ipc_words * word_size" + apply (simp add: msg_max_extra_caps_def msg_max_length_def max_ipc_words word_size_def) + apply (rule_tac y="0x3D8 + 8 * 4" in order_le_less_trans) + apply (rule word_plus_mono_right) + apply (rule word_mult_le_mono1'; simp) + apply simp+ + done + +end (* Arch *) + +interpretation Ipc_R?: Ipc_R +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; (fact Ipc_R_assms)?)?) qed -crunch setMRs - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma sai_invs'[wp]: - "\invs' and ex_nonz_cap_to' ntfnptr\ - sendSignal ntfnptr badge \\y. invs'\" - unfolding sendSignal_def - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj nTFN", simp_all) - prefer 3 - apply (rename_tac list) - apply (case_tac list, - simp_all split del: if_split - add: setMessageInfo_def)[1] - apply (wp hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act])+ - apply (clarsimp simp:conj_comms) - apply (simp add: invs'_def valid_state'_def) - apply (wp valid_irq_node_lift sts_valid_objs' setThreadState_ct_not_inQ - set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' valid_dom_schedule'_lift - hoare_convert_imp [OF setNotification_nosch] - | simp split del: if_split)+ - - apply (intro conjI[rotated]; - (solves \clarsimp simp: invs'_def valid_state'_def valid_pspace'_def\)?) - apply (clarsimp simp: invs'_def valid_state'_def split del: if_split) - apply (drule(1) ct_not_in_ntfnQueue, simp+) - apply clarsimp - apply (frule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def) - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_idle'_def pred_tcb_at'_def idle_tcb'_def - dest!: sym_refs_ko_atD' sym_refs_st_tcb_atD' sym_refs_obj_atD' - split: list.splits) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (clarsimp elim!: if_live_then_nonz_capE' simp:invs'_def valid_state'_def) - apply (drule(1) sym_refs_ko_atD') - apply (clarsimp elim!: ko_wp_at'_weakenE - intro!: refs_of_live') - apply (clarsimp split del: if_split)+ - apply (frule ko_at_valid_objs', clarsimp) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (frule invs_sym') - apply (drule(1) sym_refs_obj_atD') - apply (clarsimp split del: if_split cong: if_cong - simp: st_tcb_at_refs_of_rev' ep_redux_simps' ntfn_bound_refs'_def) - apply (frule st_tcb_at_state_refs_ofD') - apply (erule delta_sym_refs) - apply (fastforce simp: split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset symreftype_inverse' - split: if_split_asm) - apply (clarsimp simp:invs'_def) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def valid_state'_def) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) - apply (clarsimp simp:invs'_def valid_state'_def valid_pspace'_def) - apply (frule(1) ko_at_valid_objs') - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def - split: list.splits option.splits) - apply (case_tac "ntfnBoundTCB nTFN", simp_all) - apply (wp set_ntfn_minor_invs') - apply (fastforce simp: valid_ntfn'_def invs'_def valid_state'_def - elim!: obj_at'_weakenE - dest!: global'_no_ex_cap) - apply (wp add: hoare_convert_imp [OF asUser_nosch] - hoare_convert_imp [OF setMRs_sch_act] - setThreadState_nonqueued_state_update sts_st_tcb' - del: cancelIPC_simple) - apply (clarsimp | wp cancelIPC_ct')+ - apply (wp set_ntfn_minor_invs' gts_wp' | clarsimp)+ - apply (frule pred_tcb_at') - by (wp set_ntfn_minor_invs' - | rule conjI - | clarsimp elim!: st_tcb_ex_cap'' - | fastforce simp: receiveBlocked_def projectKOs pred_tcb_at'_def obj_at'_def - dest!: invs_rct_ct_activatable' - split: thread_state.splits - | fastforce simp: invs'_def valid_state'_def receiveBlocked_def projectKOs - valid_obj'_def valid_ntfn'_def - split: thread_state.splits - dest!: global'_no_ex_cap st_tcb_ex_cap'' ko_at_valid_objs')+ - -lemma replyFromKernel_corres: - "corres dc (tcb_at t and invs) (tcb_at' t and invs') - (reply_from_kernel t r) (replyFromKernel t r)" - apply (case_tac r) - apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def - badge_register_def badgeRegister_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres]) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split_eqr[OF setMRs_corres]) - apply simp - apply (rule setMessageInfo_corres) - apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' - | clarsimp)+ - apply fastforce - apply fastforce - done - -lemma rfk_invs': - "\invs' and tcb_at' t\ replyFromKernel t r \\rv. invs'\" - apply (simp add: replyFromKernel_def) - apply (cases r) - apply (wp | clarsimp)+ - done - -crunch replyFromKernel - for nosch[wp]: "\s. P (ksSchedulerAction s)" - -lemma completeSignal_corres: - "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and pspace_distinct and valid_objs) - (ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' and obj_at' isActive ntfnptr) - (complete_signal ntfnptr tcb) (completeSignal ntfnptr tcb)" - apply (simp add: complete_signal_def completeSignal_def) - apply (rule corres_guard_imp) - apply (rule_tac R'="\ntfn. ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' - and valid_ntfn' ntfn and (\_. isActive ntfn)" - in corres_split[OF getNotification_corres]) - apply (rule corres_gen_asm2) - apply (case_tac "ntfn_obj rv") - apply (clarsimp simp: ntfn_relation_def isActive_def - split: ntfn.splits Structures_H.notification.splits)+ - apply (rule corres_guard2_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres setNotification_corres]) - apply (clarsimp simp: ntfn_relation_def) - apply (wp set_simple_ko_valid_objs get_simple_ko_wp getNotification_wp | clarsimp simp: valid_ntfn'_def)+ - apply (clarsimp simp: valid_pspace'_def) - apply (frule_tac P="(\k. k = ntfn)" in obj_at_valid_objs', assumption) - apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def obj_at'_def) - done - - -lemma doNBRecvFailedTransfer_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ - (do_nbrecv_failed_transfer thread) - (doNBRecvFailedTransfer thread)" - unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def - by (simp add: badgeRegister_def badge_register_def, rule asUser_setRegister_corres) - -lemma receiveIPC_corres: - assumes "is_ep_cap cap" and "cap_relation cap cap'" - shows " - corres dc (einvs and valid_sched and tcb_at thread and valid_cap cap and ex_nonz_cap_to thread - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3)) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_ipc thread cap isBlocking) (receiveIPC thread cap' isBlocking)" - apply (insert assms) - apply (simp add: receive_ipc_def receiveIPC_def - split del: if_split) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 right) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getBoundNotification_corres]) - apply (rule_tac r'="ntfn_relation" in corres_split) - apply (rule corres_option_split[rotated 2]) - apply (rule getNotification_corres) - apply clarsimp - apply (rule corres_trivial, simp add: ntfn_relation_def default_notification_def - default_ntfn_def) - apply (rule corres_if) - apply (clarsimp simp: ntfn_relation_def Ipc_A.isActive_def Endpoint_H.isActive_def - split: Structures_A.ntfn.splits Structures_H.notification.splits) - apply clarsimp - apply (rule completeSignal_corres) - apply (rule_tac P="einvs and valid_sched and tcb_at thread and - ep_at word1 and valid_ep ep and - obj_at (\k. k = Endpoint ep) word1 - and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3) - and ex_nonz_cap_to thread" and - P'="invs' and tcb_at' thread and ep_at' word1 and - valid_ep' epa" - in corres_inst) - apply (case_tac ep) - \ \IdleEP\ - apply (simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def - valid_tcb_state_def st_tcb_at_tcb_at) - apply auto[1] - \ \SendEP\ - apply (simp add: ep_relation_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (clarsimp simp: valid_ep_def) - apply (case_tac list, simp_all split del: if_split)[1] - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (case_tac lista, simp_all add: ep_relation_def)[1] - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac - F="\data. - sender_state = - Structures_A.thread_state.BlockedOnSend word1 data" - in corres_gen_asm) - apply (clarsimp simp: isSend_def case_bool_If - case_option_If if3_fold - split del: if_split cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (simp split del: if_split cong: if_cong) - apply (fold dc_def)[1] - apply (rule_tac P="valid_objs and valid_mdb and valid_list and valid_arch_state - and valid_sched - and cur_tcb - and valid_reply_caps - and pspace_aligned and pspace_distinct - and st_tcb_at (Not \ awaiting_reply) a - and st_tcb_at (Not \ halted) a - and tcb_at thread and valid_reply_masters - and cte_wp_at (\c. c = cap.NullCap) - (thread, tcb_cnode_index 3)" - and P'="tcb_at' a and tcb_at' thread and cur_tcb' - and valid_pspace' - and valid_objs' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct'" - in corres_guard_imp [OF corres_if]) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_if2 [OF _ setupCallerCap_corres setThreadState_corres]) - apply simp - apply simp - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule possibleSwitchTo_corres) - apply (wpsimp wp: sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action)+ - apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb - | simp)+ - apply (fastforce simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def - valid_sched_action_def) - apply (clarsimp split: if_split_asm) - apply (clarsimp | wp do_ipc_transfer_tcb_caps do_ipc_transfer_valid_arch)+ - apply (rule_tac Q'="\_ s. sch_act_wf (ksSchedulerAction s) s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s" - in hoare_post_imp) - apply (fastforce elim: sch_act_wf_weak) - apply (wp sts_st_tcb' gts_st_tcb_at | simp)+ - apply (simp cong: list.case_cong) - apply wp - apply simp - apply (wp weak_sch_act_wf_lift_linear setEndpoint_valid_mdb' set_ep_valid_objs') - apply (clarsimp split: list.split) - apply (clarsimp simp add: invs_def valid_state_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_ep_def valid_pspace_def) - apply (drule(1) sym_refs_obj_atD[where P="\ko. ko = Endpoint e" for e]) - apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) - apply (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split)[1] - \ \RecvEP\ - apply (simp add: ep_relation_def) - apply (rule_tac corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) - apply simp - apply (fastforce simp: valid_tcb_state_def) - apply (clarsimp simp add: valid_tcb_state'_def) - apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' - hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift - | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ - apply (clarsimp simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def - valid_obj_def valid_tcb_def valid_bound_ntfn_def invs_distinct - dest!: invs_valid_objs - elim!: obj_at_valid_objsE - split: option.splits) - apply clarsimp - apply (auto simp: valid_cap'_def invs_valid_pspace' valid_obj'_def valid_tcb'_def - valid_bound_ntfn'_def obj_at'_def projectKOs pred_tcb_at'_def - dest!: invs_valid_objs' obj_at_valid_objs' - split: option.splits) - done - -lemma receiveSignal_corres: - "\ is_ntfn_cap cap; cap_relation cap cap' \ \ - corres dc (invs and st_tcb_at active thread and valid_cap cap and ex_nonz_cap_to thread) - (invs' and tcb_at' thread and valid_cap' cap') - (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" - apply (simp add: receive_signal_def receiveSignal_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac word1 word2 rights) - apply (rule corres_guard_imp) - apply (rule_tac R="\rv. invs and tcb_at thread and st_tcb_at active thread and - ntfn_at word1 and ex_nonz_cap_to thread and - valid_ntfn rv and - obj_at (\k. k = Notification rv) word1" and - R'="\rv'. invs' and tcb_at' thread and ntfn_at' word1 and - valid_ntfn' rv'" - in corres_split[OF getNotification_corres]) - apply clarsimp - apply (case_tac "ntfn_obj rv") - \ \IdleNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, fastforce+) - \ \WaitingNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres]) - apply simp - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (rule corres_guard_imp) - apply (rule doNBRecvFailedTransfer_corres, fastforce+) - \ \ActiveNtfn\ - apply (simp add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule setNotification_corres) - apply (simp add: ntfn_relation_def) - apply wp+ - apply (fastforce simp: invs_def valid_state_def valid_pspace_def - elim!: st_tcb_weakenE) - apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) - apply wp+ - apply (clarsimp simp add: ntfn_at_def2 valid_cap_def st_tcb_at_tcb_at) - apply (clarsimp simp add: valid_cap'_def) - done - -lemma tg_sp': - "\P\ threadGet f p \\t. obj_at' (\t'. f t' = t) p and P\" - including no_pre - apply (simp add: threadGet_def) - apply wp - apply (rule hoare_strengthen_post) - apply (rule getObject_tcb_sp) - apply clarsimp - apply (erule obj_at'_weakenE) - apply simp - done - -declare lookup_cap_valid' [wp] +context Arch begin arch_global_naming -lemma sendFaultIPC_corres: - "valid_fault f \ fr f f' \ - corres (fr \ dc) - (einvs and st_tcb_at active thread and ex_nonz_cap_to thread) - (invs' and sch_act_not thread and tcb_at' thread) - (send_fault_ipc thread f) (sendFaultIPC thread f')" - apply (simp add: send_fault_ipc_def sendFaultIPC_def - liftE_bindE Let_def) - apply (rule corres_guard_imp) - apply (rule corres_split [where r'="\fh fh'. fh = to_bl fh'"]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def) - apply simp - apply (rule corres_splitEE) - apply (rule corres_cap_fault) - apply (rule lookup_cap_corres, rule refl) - apply (rule_tac P="einvs and st_tcb_at active thread - and valid_cap handler_cap and ex_nonz_cap_to thread" - and P'="invs' and tcb_at' thread and sch_act_not thread - and valid_cap' handlerCap" - in corres_inst) - apply (case_tac handler_cap, - simp_all add: isCap_defs lookup_failure_map_def - case_bool_If If_rearrage - split del: if_split cong: if_cong)[1] - apply (rule corres_guard_imp) - apply (rule corres_if2 [OF refl]) - apply (simp add: dc_def[symmetric]) - apply (rule corres_split[OF threadset_corres sendIPC_corres], simp_all)[1] - apply (simp add: tcb_relation_def fault_rel_optionation_def inQ_def)+ - apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state - thread_set_typ_at ep_at_typ_at ex_nonz_cap_to_pres - thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched - | simp add: tcb_cap_cases_def)+ - apply ((wp threadSet_invs_trivial threadSet_tcb' - | simp add: tcb_cte_cases_def - | wp (once) sch_act_sane_lift)+)[1] - apply (rule corres_trivial, simp add: lookup_failure_map_def) - apply (clarsimp simp: st_tcb_at_tcb_at split: if_split) - apply (fastforce simp: valid_cap_def) - apply (fastforce simp: valid_cap'_def inQ_def) - apply (fastforce simp: lookup_failure_map_def) - apply wp+ - apply (fastforce elim: st_tcb_at_tcb_at) - apply fastforce - done - -lemma gets_the_noop_corres: - assumes P: "\s. P s \ f s \ None" - shows "corres dc P P' (gets_the f) (return x)" - apply (clarsimp simp: corres_underlying_def gets_the_def - return_def gets_def bind_def get_def) - apply (clarsimp simp: assert_opt_def return_def dest!: P) - done - -lemma handleDoubleFault_corres: - "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) - (tcb_at' thread and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) - (handle_double_fault thread f ft) - (handleDoubleFault thread f' ft')" - apply (simp add: handle_double_fault_def handleDoubleFault_def) - apply (rule corres_guard_imp) - apply (subst bind_return [symmetric], - rule corres_split [OF setThreadState_corres]) - apply simp - apply (rule corres_noop2) - apply (simp add: exs_valid_def return_def) - apply (rule hoare_eq_P) - apply wp - apply (rule asUser_inv) - apply (rule getRestartPC_inv) - apply (wp no_fail_getRestartPC)+ - apply (wp|simp)+ - done - -crunch sendFaultIPC - for tcb'[wp]: "tcb_at' t" (wp: crunch_wps) - -crunch receiveIPC - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveIPC_typ_ats[wp] = typ_at_lifts [OF receiveIPC_typ_at'] - -crunch receiveSignal - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (wp: crunch_wps) - -lemmas receiveAIPC_typ_ats[wp] = typ_at_lifts [OF receiveSignal_typ_at'] - -crunch setupCallerCap - for aligned'[wp]: "pspace_aligned'" - (wp: crunch_wps) -crunch setupCallerCap - for distinct'[wp]: "pspace_distinct'" - (wp: crunch_wps) -crunch setupCallerCap - for cur_tcb[wp]: "cur_tcb'" - (wp: crunch_wps) - -lemma setupCallerCap_state_refs_of[wp]: - "\\s. P ((state_refs_of' s) (sender := {r \ state_refs_of' s sender. snd r = TCBBound}))\ - setupCallerCap sender rcvr grant - \\rv s. P (state_refs_of' s)\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp hoare_drop_imps) - apply (simp add: fun_upd_def cong: if_cong) - done - -lemma is_derived_ReplyCap' [simp]: - "\m p g. is_derived' m p (capability.ReplyCap t False g) = - (\c. \ g. c = capability.ReplyCap t True g)" - apply (subst fun_eq_iff) - apply clarsimp - apply (case_tac x, simp_all add: is_derived'_def isCap_simps - badge_derived'_def - vsCapRef_def) - done - -lemma unique_master_reply_cap': - "\c t. isReplyCap c \ capReplyMaster c \ capTCBPtr c = t \ - (\g . c = capability.ReplyCap t True g)" - by (fastforce simp: isCap_simps conj_comms) - -lemma getSlotCap_cte_wp_at: - "\\\ getSlotCap sl \\rv. cte_wp_at' (\c. cteCap c = rv) sl\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -crunch setThreadState - for no_0_obj'[wp]: no_0_obj' - -lemma setupCallerCap_vp[wp]: - "\valid_pspace' and tcb_at' sender and tcb_at' rcvr\ - setupCallerCap sender rcvr grant \\rv. valid_pspace'\" - apply (simp add: valid_pspace'_def setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv getSlotCap_def) - apply (wp getCTE_wp) - apply (rule_tac Q'="\_. valid_pspace' and - tcb_at' sender and tcb_at' rcvr" - in hoare_post_imp) - apply (clarsimp simp: valid_cap'_def o_def cte_wp_at_ctes_of isCap_simps - valid_pspace'_def) - apply (frule(1) ctes_of_valid', simp add: valid_cap'_def capAligned_def) - apply clarsimp - apply (wp | simp add: valid_pspace'_def valid_tcb_state'_def)+ - done - -declare haskell_assert_inv[wp del] - -lemma setupCallerCap_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_live_then_nonz_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - -lemma setupCallerCap_ifunsafe[wp]: - "\if_unsafe_then_cap' and valid_objs' and - ex_nonz_cap_to' rcvr and tcb_at' rcvr and pspace_aligned' and pspace_distinct'\ - setupCallerCap sender rcvr grant - \\rv. if_unsafe_then_cap'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) - apply (wp getSlotCap_cte_wp_at - | simp add: unique_master_reply_cap' | strengthen eq_imp_strg - | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ - apply (rule_tac Q'="\rv. valid_objs' and tcb_at' rcvr and ex_nonz_cap_to' rcvr" - in hoare_post_imp) - apply (clarsimp simp: ex_nonz_tcb_cte_caps' tcbCallerSlot_def - objBits_def objBitsKO_def dom_def cte_level_bits_def) - apply (wp sts_valid_objs' | simp)+ - apply (clarsimp simp: valid_tcb_state'_def)+ - done - -lemma setupCallerCap_global_refs'[wp]: - "\valid_global_refs'\ - setupCallerCap sender rcvr grant - \\rv. valid_global_refs'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp - | simp add: o_def unique_master_reply_cap' - | strengthen eq_imp_strg - | wp (once) getCTE_wp - | wp (once) hoare_vcg_imp_lift' hoare_vcg_ex_lift | clarsimp simp: cte_wp_at_ctes_of)+ - -crunch setupCallerCap - for valid_arch'[wp]: "valid_arch_state'" - (wp: hoare_drop_imps) - -crunch setupCallerCap - for typ'[wp]: "\s. P (typ_at' T p s)" - -crunch setupCallerCap - for irq_node'[wp]: "\s. P (irq_node' s)" - (wp: hoare_drop_imps) - -lemma setupCallerCap_irq_handlers'[wp]: - "\valid_irq_handlers'\ - setupCallerCap sender rcvr grant - \\rv. valid_irq_handlers'\" - unfolding setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def locateSlot_conv - by (wp hoare_drop_imps | simp)+ - -lemma cteInsert_cap_to': - "\ex_nonz_cap_to' p and cte_wp_at' (\c. cteCap c = NullCap) dest\ - cteInsert cap src dest - \\rv. ex_nonz_cap_to' p\" - supply if_cong[cong] - apply (simp add: cteInsert_def ex_nonz_cap_to'_def updateCap_def setUntypedCapAsFull_def) - apply (wpsimp wp: updateMDB_weak_cte_wp_at setCTE_weak_cte_wp_at hoare_vcg_ex_lift - | rule hoare_drop_imps - | wp getCTE_wp)+ (* getCTE_wp is separate to apply it only to the last one *) - apply (rule_tac x=cref in exI) - apply (fastforce simp: cte_wp_at_ctes_of) - done - -crunch setExtraBadge - for cap_to'[wp]: "ex_nonz_cap_to' p" - -crunch doIPCTransfer - for cap_to'[wp]: "ex_nonz_cap_to' p" - (ignore: transferCapsToSlots - wp: crunch_wps transferCapsToSlots_pres2 cteInsert_cap_to' hoare_vcg_const_Ball_lift - simp: zipWithM_x_mapM ball_conj_distrib) - -lemma st_tcb_idle': - "\valid_idle' s; st_tcb_at' P t s\ \ - (t = ksIdleThread s) \ P IdleThreadState" - by (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - -crunch getThreadCallerSlot - for idle'[wp]: "valid_idle'" -crunch getThreadReplySlot - for idle'[wp]: "valid_idle'" - -crunch setupCallerCap - for it[wp]: "\s. P (ksIdleThread s)" - (simp: updateObject_cte_inv wp: crunch_wps) - -lemma setupCallerCap_idle'[wp]: - "\valid_idle' and valid_pspace' and - (\s. st \ ksIdleThread s \ rt \ ksIdleThread s)\ - setupCallerCap st rt gr - \\_. valid_idle'\" - by (simp add: setupCallerCap_def capRange_def | wp hoare_drop_imps)+ - -crunch doIPCTransfer - for idle'[wp]: "valid_idle'" - (wp: crunch_wps simp: crunch_simps ignore: transferCapsToSlots) - -crunch setExtraBadge - for it[wp]: "\s. P (ksIdleThread s)" -crunch receiveIPC - for it[wp]: "\s. P (ksIdleThread s)" - (ignore: transferCapsToSlots - wp: transferCapsToSlots_pres2 crunch_wps hoare_vcg_const_Ball_lift - simp: crunch_simps ball_conj_distrib) - -crunch setupCallerCap - for irq_states'[wp]: valid_irq_states' - (wp: crunch_wps) - -crunch receiveIPC - for irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps rule: irqs_masked_lift) - -crunch getThreadCallerSlot - for ct_not_inQ[wp]: "ct_not_inQ" -crunch getThreadReplySlot - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma setupCallerCap_ct_not_inQ[wp]: - "\ct_not_inQ\ setupCallerCap sender receiver grant \\_. ct_not_inQ\" - apply (simp add: setupCallerCap_def) - apply (wp hoare_drop_imp setThreadState_ct_not_inQ) - done - -crunch copyMRs - for ksQ'[wp]: "\s. P (ksReadyQueues s)" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ksQ[wp]: "\s. P (ksReadyQueues s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -crunch doIPCTransfer - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma asUser_ct_not_inQ[wp]: - "\ct_not_inQ\ asUser t m \\rv. ct_not_inQ\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps threadSet_not_inQ | simp)+ - done - -crunch copyMRs - for ct_not_inQ[wp]: "ct_not_inQ" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -crunch doIPCTransfer - for ct_not_inQ[wp]: "ct_not_inQ" - (ignore: getRestartPC setRegister transferCapsToSlots - wp: hoare_drop_imps hoare_vcg_split_case_option - mapM_wp' - simp: split_def zipWithM_x_mapM) - -lemma ntfn_q_refs_no_bound_refs': "rf : ntfn_q_refs_of' (ntfnObj ob) \ rf ~: ntfn_bound_refs' (ntfnBoundTCB ob')" - by (auto simp add: ntfn_q_refs_of'_def ntfn_bound_refs'_def - split: Structures_H.ntfn.splits) - -lemma completeSignal_invs: - "\invs' and tcb_at' tcb\ - completeSignal ntfnptr tcb - \\_. invs'\" - supply projectKOs[simp] - apply (simp add: completeSignal_def) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule hoare_pre) - apply (wp set_ntfn_minor_invs' | wpc | simp)+ - apply (rule_tac Q'="\_ s. (state_refs_of' s ntfnptr = ntfn_bound_refs' (ntfnBoundTCB ntfn)) - \ ntfn_at' ntfnptr s - \ valid_ntfn' (ntfnObj_update (\_. Structures_H.ntfn.IdleNtfn) ntfn) s - \ ((\y. ntfnBoundTCB ntfn = Some y) \ ex_nonz_cap_to' ntfnptr s) - \ ntfnptr \ ksIdleThread s" - in hoare_strengthen_post) - apply ((wp hoare_vcg_ex_lift hoare_weak_lift_imp | wpc | simp add: valid_ntfn'_def)+)[1] - apply (clarsimp simp: obj_at'_def state_refs_of'_def typ_at'_def ko_wp_at'_def projectKOs live'_def - split: option.splits) - apply (blast dest: ntfn_q_refs_no_bound_refs') - apply wp - apply (subgoal_tac "valid_ntfn' ntfn s") - apply (subgoal_tac "ntfnptr \ ksIdleThread s") - apply (fastforce simp: valid_ntfn'_def valid_bound_tcb'_def ko_at_state_refs_ofD' live'_def - elim: obj_at'_weakenE - if_live_then_nonz_capD'[OF invs_iflive' - obj_at'_real_def[THEN meta_eq_to_obj_eq, - THEN iffD1]]) - apply (fastforce simp: valid_idle'_def pred_tcb_at'_def obj_at'_def projectKOs - dest!: invs_valid_idle') - apply (fastforce dest: invs_valid_objs' ko_at_valid_objs' - simp: valid_obj'_def projectKOs)[1] - done - -lemma setupCallerCap_urz[wp]: - "\untyped_ranges_zero' and valid_pspace' and tcb_at' sender\ - setupCallerCap sender t g \\rv. untyped_ranges_zero'\" - apply (simp add: setupCallerCap_def getSlotCap_def - getThreadCallerSlot_def getThreadReplySlot_def - locateSlot_conv) - apply (wp getCTE_wp') - apply (rule_tac Q'="\_. untyped_ranges_zero' and valid_mdb' and valid_objs'" in hoare_post_imp) - apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def untyped_derived_eq_def - isCap_simps) - apply (wp sts_valid_pspace_hangers) - apply (clarsimp simp: valid_tcb_state'_def) - done - -lemmas threadSet_urz = untyped_ranges_zero_lift[where f="cteCaps_of", OF _ threadSet_cteCaps_of] - -crunch doIPCTransfer - for urz[wp]: "untyped_ranges_zero'" - (ignore: threadSet wp: threadSet_urz crunch_wps simp: zipWithM_x_mapM) - -crunch receiveIPC - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 simp: zipWithM_x_mapM ignore: constOnFailure) - -crunch possibleSwitchTo - for ctes_of[wp]: "\s. P (ctes_of s)" - (wp: crunch_wps ignore: constOnFailure) - -lemmas possibleSwitchToTo_cteCaps_of[wp] - = cteCaps_of_ctes_of_lift[OF possibleSwitchTo_ctes_of] - -crunch possibleSwitchTo - for ksArch[wp]: "\s. P (ksArchState s)" - (wp: possibleSwitchTo_ctes_of crunch_wps ignore: constOnFailure) - -crunch asUser - for valid_bitmaps[wp]: valid_bitmaps - (rule: valid_bitmaps_lift wp: crunch_wps) - -crunch setupCallerCap, possibleSwitchTo, doIPCTransfer - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) - -(* t = ksCurThread s *) -lemma ri_invs' [wp]: - "\invs' and sch_act_not t - and ct_in_state' simple' - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ - receiveIPC t cap isBlocking - \\_. invs'\" (is "\?pre\ _ \_\") - apply (clarsimp simp: receiveIPC_def) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (rule bind_wp [OF _ gbn_sp']) - apply (rule bind_wp) - (* set up precondition for old proof *) - apply (rule_tac P''="ko_at' ep (capEPPtr cap) and ?pre" in hoare_vcg_if_split) - apply (wp completeSignal_invs) - apply (case_tac ep) - \ \endpoint = RecvEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp sts_sch_act' hoare_vcg_const_Ball_lift valid_irq_node_lift valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' o_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_ep'_def - valid_obj'_def projectKOs tcb_bound_refs'_def - dest!: isCapDs) - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD') - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply ((case_tac tp; fastforce elim: nonempty_cross_distinct_singleton_elim)+)[2] - apply (clarsimp split: if_split_asm) - apply (fastforce simp: valid_pspace'_def global'_no_ex_cap idle'_not_queued) - \ \endpoint = IdleEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wpc, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp sts_sch_act' valid_irq_node_lift valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def o_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "t \ capEPPtr cap") - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule ko_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (clarsimp simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def projectKOs) - \ \endpoint = SendEP\ - apply (simp add: invs'_def valid_state'_def) - apply (rename_tac list) - apply (case_tac list, simp_all split del: if_split) - apply (rename_tac sender queue) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift hoare_drop_imps setEndpoint_valid_mdb' - set_ep_valid_objs' sts_st_tcb' sts_sch_act' valid_dom_schedule'_lift - setThreadState_ct_not_inQ - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - setEndpoint_ksQ - | simp add: valid_tcb_state'_def case_bool_If - case_option_If - split del: if_split cong: if_cong - | wp (once) sch_act_sane_lift hoare_vcg_conj_lift hoare_vcg_all_lift - untyped_ranges_zero_lift)+ - apply (clarsimp split del: if_split simp: pred_tcb_at') - apply (frule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def - st_tcb_at_refs_of_rev' conj_ac - split del: if_split - cong: if_cong) - apply (subgoal_tac "sch_act_not sender s") - prefer 2 - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (drule st_tcb_at_state_refs_ofD') - apply (simp only: conj_ac(1, 2)[where Q="sym_refs R" for R]) - apply (subgoal_tac "distinct (ksIdleThread s # capEPPtr cap # t # sender # queue)") - apply (rule conjI) - apply (clarsimp simp: ep_redux_simps' cong: if_cong) - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def - dest: symreftype_inverse' - split: if_split_asm) - apply (clarsimp simp: singleton_tuple_cartesian split: list.split - | rule conjI | drule(1) bspec - | drule st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - | clarsimp elim!: if_live_state_refsE)+ - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (clarsimp simp: global'_no_ex_cap) - apply (rule conjI - | clarsimp simp: singleton_tuple_cartesian split: list.split - | clarsimp elim!: if_live_state_refsE - | clarsimp simp: global'_no_ex_cap idle'_not_queued' idle'_no_refs tcb_bound_refs'_def - | drule(1) bspec | drule st_tcb_at_state_refs_ofD' - | clarsimp simp: set_eq_subset dest!: bound_tcb_at_state_refs_ofD' )+ - apply (rule hoare_pre) - apply (wp getNotification_wp | wpc | clarsimp)+ - done - -(* t = ksCurThread s *) -lemma rai_invs'[wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) - and (\s. \ntfnptr. isNotificationCap cap - \ capNtfnPtr cap = ntfnptr - \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) - ntfnptr s)\ - receiveSignal t cap isBlocking - \\_. invs'\" - apply (simp add: receiveSignal_def) - apply (rule bind_wp [OF _ get_ntfn_sp']) - apply (rename_tac ep) - apply (case_tac "ntfnObj ep") - \ \ep = IdleNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts valid_dom_schedule'_lift - setThreadState_ct_not_inQ - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "capNtfnPtr cap \ t") - apply (frule valid_pspace_valid_objs') - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD' bound_tcb_at_state_refs_ofD')+ - apply (clarsimp dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - \ \ep = ActiveNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_valid_objs' typ_at_lifts hoare_weak_lift_imp - asUser_urz valid_dom_schedule'_lift - | simp add: valid_ntfn'_def)+ - apply (clarsimp simp: pred_tcb_at' valid_pspace'_def) - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKOs) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def isCap_simps) - apply (drule simple_st_tcb_at_state_refs_ofD' - ko_at_state_refs_ofD')+ - apply (erule delta_sym_refs) - apply (clarsimp split: if_split_asm simp: global'_no_ex_cap)+ - \ \ep = WaitingNtfn\ - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' - setThreadState_ct_not_inQ typ_at_lifts valid_dom_schedule'_lift - asUser_urz - | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def live'_def | wpc)+ - apply (clarsimp simp: valid_tcb_state'_def) - apply (frule_tac t=t in not_in_ntfnQueue) - apply (simp) - apply (simp) - apply (erule pred_tcb'_weakenE, clarsimp) - apply (frule ko_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_obj'_def) - apply (clarsimp simp: valid_ntfn'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) - apply (drule(1) sym_refs_ko_atD') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: st_tcb_at_refs_of_rev' - dest!: isCapDs) - apply (rule conjI, erule delta_sym_refs) - apply (clarsimp split: if_split_asm) - apply (rename_tac list one two three four five six seven eight nine) - apply (subgoal_tac "set list \ {NTFNSignal} \ {}") - apply safe[1] - apply (auto simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def)[5] - apply (fastforce simp: tcb_bound_refs'_def - split: if_split_asm) - apply (fastforce dest!: global'_no_ex_cap) - done - -lemma getCTE_cap_to_refs[wp]: - "\\\ getCTE p \\rv s. \r\zobj_refs' (cteCap rv). ex_nonz_cap_to' r s\" - apply (rule hoare_strengthen_post [OF getCTE_sp]) - apply (clarsimp simp: ex_nonz_cap_to'_def) - apply (fastforce elim: cte_wp_at_weakenE') - done - -lemma lookupCap_cap_to_refs[wp]: - "\\\ lookupCap t cref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" - apply (simp add: lookupCap_def lookupCapAndSlot_def split_def - getSlotCap_def) - apply (wp | simp)+ - done - -crunch setVMRoot - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps simp: crunch_simps) - -lemma arch_stt_objs' [wp]: - "\valid_objs'\ Arch.switchToThread t \\rv. valid_objs'\" - apply (simp add: X64_H.switchToThread_def) - apply wp - done - -declare zipWithM_x_mapM [simp] - -lemma cteInsert_invs_bits[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert a b c - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" - "\\s. P (state_refs_of' s)\ - cteInsert a b c - \\rv s. P (state_refs_of' s)\" -apply (wp sch_act_wf_lift valid_queues_lift - cur_tcb_lift tcb_in_cur_domain'_lift)+ -done - -lemma possibleSwitchTo_sch_act_not: - "\sch_act_not t' and K (t \ t')\ possibleSwitchTo t \\rv. sch_act_not t'\" - apply (simp add: possibleSwitchTo_def setSchedulerAction_def curDomain_def) - apply (wp hoare_drop_imps | wpc | simp)+ - done - -crunch possibleSwitchTo - for vms'[wp]: valid_machine_state' -crunch possibleSwitchTo - for pspace_domain_valid[wp]: pspace_domain_valid -crunch possibleSwitchTo - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - -crunch possibleSwitchTo - for ct'[wp]: "\s. P (ksCurThread s)" -crunch possibleSwitchTo - for it[wp]: "\s. P (ksIdleThread s)" -crunch possibleSwitchTo - for irqs_masked'[wp]: "irqs_masked'" -crunch possibleSwitchTo - for urz[wp]: "untyped_ranges_zero'" - (simp: crunch_simps unless_def wp: crunch_wps) - -crunch possibleSwitchTo - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - -lemma si_invs'[wp]: - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ - sendIPC bl call ba cg cgr t ep - \\rv. invs'\" - supply if_split[split del] - supply if_cong[cong] - apply (simp add: sendIPC_def split del: if_split) - apply (rule bind_wp [OF _ get_ep_sp']) - apply (case_tac epa) - \ \epa = RecvEP\ - apply simp - apply (rename_tac list) - apply (case_tac list) - apply simp - apply (simp split del: if_split add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (rule_tac P="a\t" in hoare_gen_asm) - apply (wp valid_irq_node_lift - sts_valid_objs' set_ep_valid_objs' setEndpoint_valid_mdb' sts_st_tcb' sts_sch_act' - possibleSwitchTo_sch_act_not setThreadState_ct_not_inQ valid_dom_schedule'_lift - possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift - hoare_convert_imp [OF doIPCTransfer_sch_act doIPCTransfer_ct'] - hoare_convert_imp [OF setEndpoint_nosch setEndpoint_ksCurThread] - hoare_drop_imp [where f="threadGet tcbFault t"] - | rule_tac f="getThreadState a" in hoare_drop_imp - | wp (once) hoare_drop_imp[where Q'="\_ _. call"] - hoare_drop_imp[where Q'="\_ _. \ call"] - hoare_drop_imp[where Q'="\_ _. cg"] - | simp add: valid_tcb_state'_def case_bool_If - case_option_If - cong: if_cong - split del: if_split - | wp (once) sch_act_sane_lift tcb_in_cur_domain'_lift hoare_vcg_const_imp_lift)+ - apply (clarsimp simp: pred_tcb_at' cong: conj_cong imp_cong - split del: if_split) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def - st_tcb_at_refs_of_rev' pred_tcb_at' - conj_comms fun_upd_def[symmetric] - split del: if_split) - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD' st_tcb_at_state_refs_ofD')+ - apply (clarsimp simp: valid_pspace'_splits) - apply (subst fun_upd_idem[where x=t]) - apply (clarsimp split: if_split) - apply (rule conjI, clarsimp simp: obj_at'_def projectKOs) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def) - apply (subgoal_tac "ex_nonz_cap_to' a s") - prefer 2 - apply (clarsimp elim!: if_live_state_refsE) - apply clarsimp - apply (rule conjI) - apply (drule bound_tcb_at_state_refs_ofD') - apply (fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp simp: conj_ac) - apply (rule conjI, clarsimp simp: idle'_no_refs) - apply (rule conjI, clarsimp simp: global'_no_ex_cap) - apply (rule conjI) - apply (rule impI) - apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) - apply (clarsimp) - apply (simp add: ep_redux_simps') - apply (rule conjI, clarsimp split: if_split) - apply (rule conjI, fastforce simp: tcb_bound_refs'_def set_eq_subset) - apply (clarsimp, erule delta_sym_refs; - solves\auto simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm\) - apply (solves\clarsimp split: list.splits\) - \ \epa = IdleEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp valid_irq_node_lift valid_dom_schedule'_lift sts_sch_act' setThreadState_ct_not_inQ) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (subgoal_tac "ep \ t") - apply (drule simple_st_tcb_at_state_refs_ofD' ko_at_state_refs_ofD' - bound_tcb_at_state_refs_ofD')+ - apply (rule conjI, erule delta_sym_refs) - apply (auto simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm)[2] - apply (fastforce simp: global'_no_ex_cap) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply simp - apply wp - apply simp - \ \epa = SendEP\ - apply (cases bl) - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre, wp valid_irq_node_lift valid_dom_schedule'_lift) - apply (simp add: valid_ep'_def) - apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ - valid_dom_schedule'_lift) - apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') - apply (rule conjI, clarsimp elim!: obj_at'_weakenE) - apply (frule obj_at_valid_objs', clarsimp) - apply (frule(1) sym_refs_ko_atD') - apply (frule pred_tcb_at') - apply (drule simple_st_tcb_at_state_refs_ofD') - apply (drule bound_tcb_at_state_refs_ofD') - apply (clarsimp simp: valid_obj'_def valid_ep'_def - projectKOs st_tcb_at_refs_of_rev') - apply (rule conjI, clarsimp) - apply (drule (1) bspec) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' - simp: tcb_bound_refs'_def) - apply (clarsimp simp: set_eq_subset) - apply (rule conjI, erule delta_sym_refs) - subgoal by (fastforce simp: obj_at'_def projectKOs symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' - split: if_split_asm) - apply (fastforce simp: global'_no_ex_cap idle'_not_queued) - apply (simp | wp)+ - done - -lemma sfi_invs_plus': - "\invs' and st_tcb_at' simple' t - and sch_act_not t - and ex_nonz_cap_to' t\ - sendFaultIPC t f - \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" - apply (simp add: sendFaultIPC_def) - apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state - threadSet_cap_to' - | wpc | simp)+ - apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s - \ st_tcb_at' simple' t s - \ ex_nonz_cap_to' t s - \ t \ ksIdleThread s - \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" - in hoare_strengthen_postE_R) - apply wp - apply (clarsimp simp: inQ_def pred_tcb_at') - apply (wp | simp)+ - apply (clarsimp simp: eq_commute) - apply (subst(asm) global'_no_ex_cap, auto) - done - -crunch send_fault_ipc - for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" - and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" - (simp: crunch_simps wp: crunch_wps) - -lemma handleFault_corres: - "fr f f' \ - corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread - and (%_. valid_fault f)) - (invs' and sch_act_not thread - and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) - (handle_fault thread f) (handleFault thread f')" - apply (simp add: handle_fault_def handleFault_def) - apply (rule corres_guard_imp) - apply (subst return_bind [symmetric], - rule corres_split[where P="tcb_at thread", - OF gets_the_noop_corres [where x="()"]]) - apply (simp add: tcb_at_def) - apply (rule corres_split_catch) - apply (rule_tac F="valid_fault f" in corres_gen_asm) - apply (rule sendFaultIPC_corres, assumption) - apply simp - apply (rule handleDoubleFault_corres) - apply wp+ - apply (rule hoare_strengthen_postE, rule sfi_invs_plus', simp_all)[1] - apply clarsimp - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def - valid_state_def valid_idle_def) - apply auto - done - -lemma sts_invs_minor'': - "\st_tcb_at' (\st'. tcb_st_refs_of' st' = tcb_st_refs_of' st - \ (st \ Inactive \ \ idle' st \ - st' \ Inactive \ \ idle' st')) t - and (\s. t = ksIdleThread s \ idle' st) - and (\s. \ runnable' st \ sch_act_not t s) - and invs'\ - setThreadState st t - \\rv. invs'\" - apply (simp add: invs'_def valid_state'_def) - apply (rule hoare_pre) - apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ valid_dom_schedule'_lift) - apply clarsimp - apply (rule conjI) - apply fastforce - apply (rule conjI) - apply (clarsimp simp: pred_tcb_at'_def) - apply (drule obj_at_valid_objs') - apply (clarsimp simp: valid_pspace'_def) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def projectKOs) - subgoal by (cases st, auto simp: valid_tcb_state'_def - split: Structures_H.thread_state.splits)[1] - apply (rule conjI) - apply (clarsimp dest!: st_tcb_at_state_refs_ofD' - elim!: rsubst[where P=sym_refs] - intro!: ext) - apply (fastforce elim!: st_tcb_ex_cap'') - done - -lemma hf_invs' [wp]: - "\invs' and sch_act_not t - and st_tcb_at' simple' t - and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ - handleFault t f \\r. invs'\" - apply (simp add: handleFault_def) - apply wp - apply (simp add: handleDoubleFault_def) - apply (wp sts_invs_minor'' dmo_invs')+ - apply (rule hoare_strengthen_postE, rule sfi_invs_plus', - simp_all) - apply (strengthen no_refs_simple_strg') - apply clarsimp - done - -declare zipWithM_x_mapM [simp del] - -lemma gts_st_tcb': - "\\\ getThreadState t \\r. st_tcb_at' (\st. st = r) t\" - apply (rule hoare_strengthen_post) - apply (rule gts_sp') - apply simp - done - -lemma setupCallerCap_pred_tcb_unchanged: - "\pred_tcb_at' proj P t and K (t \ t')\ - setupCallerCap t' t'' g - \\rv. pred_tcb_at' proj P t\" - apply (simp add: setupCallerCap_def getThreadCallerSlot_def - getThreadReplySlot_def) - apply (wp sts_pred_tcb_neq' hoare_drop_imps) - apply clarsimp - done - -lemma si_blk_makes_simple': - "\st_tcb_at' simple' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' simple' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_drop_imps) - apply (clarsimp simp: pred_tcb_at' del: disjCI) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -lemma si_blk_makes_runnable': - "\st_tcb_at' runnable' t and K (t \ t')\ - sendIPC True call bdg x x' t' ep - \\rv. st_tcb_at' runnable' t\" - apply (simp add: sendIPC_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (case_tac rv, simp_all) - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_vcg_const_imp_lift hoare_drop_imps - | simp)+ - apply (clarsimp del: disjCI simp: pred_tcb_at' elim!: pred_tcb'_weakenE) - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - apply (wp sts_st_tcb_at'_cases) - apply clarsimp - done - -lemma sfi_makes_simple': - "\st_tcb_at' simple' t and K (t \ t')\ - sendFaultIPC t' ft - \\rv. st_tcb_at' simple' t\" - apply (rule hoare_gen_asm) - apply (simp add: sendFaultIPC_def - cong: if_cong capability.case_cong bool.case_cong) - apply (wpsimp wp: si_blk_makes_simple' threadSet_pred_tcb_no_state hoare_drop_imps - hoare_vcg_all_liftE_R) - done - -lemma sfi_makes_runnable': - "\st_tcb_at' runnable' t and K (t \ t')\ - sendFaultIPC t' ft - \\rv. st_tcb_at' runnable' t\" - apply (rule hoare_gen_asm) - apply (simp add: sendFaultIPC_def - cong: if_cong capability.case_cong bool.case_cong) - apply (wpsimp wp: si_blk_makes_runnable' threadSet_pred_tcb_no_state hoare_drop_imps - hoare_vcg_all_liftE_R) - done - -lemma hf_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - handleFault t ft - \\rv. st_tcb_at' P t'\" - apply (safe intro!: hoare_gen_asm) - apply (simp_all add: handleFault_def handleDoubleFault_def) - apply (wp sfi_makes_runnable' sfi_makes_simple' sts_st_tcb_at'_cases - | simp add: handleDoubleFault_def)+ - done - -crunch possibleSwitchTo, completeSignal - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - -lemma ri_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveIPC t cap isBlocking - \\rv. st_tcb_at' P t'\" - including no_pre - apply (rule hoare_gen_asm)+ - apply (simp add: receiveIPC_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rule bind_wp [OF _ get_ep_inv']) - apply (rule bind_wp [OF _ gbn_sp']) - apply wp - apply (rename_tac ep q r) - apply (case_tac ep, simp_all) - apply (wp sts_st_tcb_at'_cases | wpc | simp add: doNBRecvFailedTransfer_def)+ - apply (rename_tac list) - apply (case_tac list, simp_all add: case_bool_If case_option_If - split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged - hoare_vcg_const_imp_lift)+ - apply (simp, simp only: imp_conv_disj) - apply (wp hoare_vcg_disj_lift)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def isSend_def - split: Structures_H.thread_state.split_asm) - apply (rule hoare_pre) - apply wpsimp+ - done - -lemma rai_makes_runnable_simple': - "\st_tcb_at' P t' and K (t \ t') and K (P = runnable' \ P = simple')\ - receiveSignal t cap isBlocking - \\rv. st_tcb_at' P t'\" - apply (rule hoare_gen_asm) - apply (simp add: receiveSignal_def) - apply (rule hoare_pre) - by (wp sts_st_tcb_at'_cases getNotification_wp | wpc | simp add: doNBRecvFailedTransfer_def)+ - -lemma sendSignal_st_tcb'_Running: - "\st_tcb_at' (\st. st = Running \ P st) t\ - sendSignal ntfnptr bdg - \\_. st_tcb_at' (\st. st = Running \ P st) t\" - apply (simp add: sendSignal_def) - apply (wp sts_st_tcb_at'_cases cancelIPC_st_tcb_at' gts_wp' getNotification_wp hoare_weak_lift_imp - | wpc | clarsimp simp: pred_tcb_at')+ - done - -lemma sai_st_tcb': - "\st_tcb_at' P t and K (P Running)\ - sendSignal ntfn bdg - \\rv. st_tcb_at' P t\" - apply (rule hoare_gen_asm) - apply (subgoal_tac "\Q. P = (\st. st = Running \ Q st)") - apply (clarsimp intro!: sendSignal_st_tcb'_Running) - apply (fastforce intro!: exI[where x=P]) - done +lemma is_derived_mask'[simp]: + "is_derived' m p (maskCapRights R c) = is_derived' m p c" + by (rule ext, simp add: is_derived'_def badge_derived'_def) -end +end (* Arch *) end From ce78e5ae18a4c11b2b1f3c9b2c2aca86b0ad8046 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Wed, 13 May 2026 06:01:35 +1000 Subject: [PATCH 6/7] refine: arch-split Ipc_R (OTHER ARCHES) Signed-off-by: Rafal Kolanski --- proof/refine/ARM/ArchCSpace_I.thy | 2 +- proof/refine/ARM/ArchCSpace_R.thy | 28 ++++-------- proof/refine/ARM/ArchIpc_R.thy | 56 ++++++++++++++---------- proof/refine/ARM/ArchKHeap_R.thy | 5 +++ proof/refine/ARM/ArchTcbAcc_R.thy | 18 +++++++- proof/refine/ARM/ArchVSpace_R.thy | 7 --- proof/refine/ARM_HYP/ArchCSpace_I.thy | 2 +- proof/refine/ARM_HYP/ArchCSpace_R.thy | 28 ++++-------- proof/refine/ARM_HYP/ArchIpc_R.thy | 63 +++++++++++++++++---------- proof/refine/ARM_HYP/ArchKHeap_R.thy | 5 +++ proof/refine/ARM_HYP/ArchMove_R.thy | 6 ++- proof/refine/ARM_HYP/ArchTcbAcc_R.thy | 18 +++++++- proof/refine/ARM_HYP/ArchVSpace_R.thy | 7 --- proof/refine/ARM_HYP/Syscall_R.thy | 21 +++++++++ proof/refine/RISCV64/ArchCSpace_I.thy | 2 +- proof/refine/RISCV64/ArchCSpace_R.thy | 28 ++++-------- proof/refine/RISCV64/ArchIpc_R.thy | 13 +++--- proof/refine/RISCV64/ArchTcbAcc_R.thy | 18 +++++++- proof/refine/RISCV64/ArchVSpace_R.thy | 7 --- proof/refine/X64/ArchCSpace_I.thy | 2 +- proof/refine/X64/ArchCSpace_R.thy | 28 ++++-------- proof/refine/X64/ArchIpc_R.thy | 46 ++++++++++++------- proof/refine/X64/ArchMove_R.thy | 4 ++ proof/refine/X64/ArchTcbAcc_R.thy | 20 +++++++-- proof/refine/X64/ArchVSpace_R.thy | 7 --- 25 files changed, 259 insertions(+), 182 deletions(-) diff --git a/proof/refine/ARM/ArchCSpace_I.thy b/proof/refine/ARM/ArchCSpace_I.thy index 5af1e3c81b..2011300d4b 100644 --- a/proof/refine/ARM/ArchCSpace_I.thy +++ b/proof/refine/ARM/ArchCSpace_I.thy @@ -277,7 +277,7 @@ lemma capMasterCap_maskCapRights[simp, CSpace_I_2_assms]: apply (case_tac arch_capability; simp add: maskCapRights_def Let_def isCap_simps) done -lemma capBadge_maskCapRights[simp]: +lemma capBadge_maskCapRights[simp, CSpace_I_2_assms]: "capBadge (maskCapRights msk cap) = capBadge cap" apply (cases cap; simp add: global.maskCapRights_def Let_def gen_isCap_simps capBadge_def) apply (rename_tac arch_capability) diff --git a/proof/refine/ARM/ArchCSpace_R.thy b/proof/refine/ARM/ArchCSpace_R.thy index 8837bb672b..4840074dca 100644 --- a/proof/refine/ARM/ArchCSpace_R.thy +++ b/proof/refine/ARM/ArchCSpace_R.thy @@ -340,12 +340,12 @@ context Arch begin arch_global_naming named_theorems CSpace_R_2_assms -lemma deriveCap_derived: +lemma deriveCap_derived[CSpace_R_2_assms]: "\\s. c'\ capability.NullCap \ cte_wp_at' (\cte. badge_derived' c' (cteCap cte) - \ capASID c' = capASID (cteCap cte) - \ cap_asid_base' c' = cap_asid_base' (cteCap cte) - \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s\ + \ capASID c' = capASID (cteCap cte) + \ cap_asid_base' c' = cap_asid_base' (cteCap cte) + \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s + \ valid_objs' s\ deriveCap slot c' \\rv s. rv \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot rv \ cteCap) slot s\, -" @@ -370,9 +370,9 @@ lemma deriveCap_derived: | clarsimp split: option.split_asm)+) done -lemma arch_deriveCap_untyped_derived[wp]: +lemma arch_deriveCap_untyped_derived[CSpace_R_2_assms, wp]: "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - ARM_H.deriveCap slot (capCap c') + ARM_H.deriveCap slot (capCap c') \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" apply (wpsimp simp: ARM_H.deriveCap_def Let_def untyped_derived_eq_ArchObjectCap split_del: if_split @@ -380,16 +380,6 @@ lemma arch_deriveCap_untyped_derived[wp]: apply(clarsimp simp: cte_wp_at_ctes_of isCap_simps untyped_derived_eq_def) by (case_tac "capCap c'"; fastforce) -lemma deriveCap_untyped_derived: - "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - deriveCap slot c' - \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" - apply (simp add: global.deriveCap_def split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp arch_deriveCap_inv | simp add: o_def untyped_derived_eq_ArchObjectCap)+ - apply (clarsimp simp: cte_wp_at_ctes_of gen_isCap_simps untyped_derived_eq_def) - done - lemma corres_caps_decomposition: assumes pspace_corres: "corres_underlying {(s, s'). pspace_relation (kheap s) (ksPSpace s')} False True r P P' f g" @@ -657,7 +647,7 @@ crunch setupReplyMaster for valid_arch'[wp]: "valid_arch_state'" (wp: crunch_wps simp: crunch_simps) -lemma ex_nonz_tcb_cte_caps': +lemma ex_nonz_tcb_cte_caps'[CSpace_R_2_assms]: "\ex_nonz_cap_to' t s; tcb_at' t s; valid_objs' s; sl \ dom tcb_cte_cases\ \ ex_cte_cap_to' (t + sl) s" apply (clarsimp simp: ex_nonz_cap_to'_def ex_cte_cap_to'_def cte_wp_at_ctes_of) @@ -1369,7 +1359,7 @@ lemmas [CSpace_R_3_assms] = updateCap_valid_arch_state' master_cap_relation -lemma derived'_not_Null: +lemma derived'_not_Null[CSpace_R_3_assms, simp]: "\ is_derived' m p c capability.NullCap" "\ is_derived' m p capability.NullCap c" by (clarsimp simp: is_derived'_def badge_derived'_def)+ diff --git a/proof/refine/ARM/ArchIpc_R.thy b/proof/refine/ARM/ArchIpc_R.thy index 8d71d34350..1264622d83 100644 --- a/proof/refine/ARM/ArchIpc_R.thy +++ b/proof/refine/ARM/ArchIpc_R.thy @@ -1,5 +1,6 @@ (* * Copyright 2014, General Dynamics C4 Systems + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -12,7 +13,7 @@ context Arch begin arch_global_naming named_theorems Ipc_R_assms -declare word64_minus_one_le[simp] +declare word32_minus_one_le[simp] lemma getMessageInfo_corres[Ipc_R_assms]: "corres ((=) \ message_info_map) @@ -30,28 +31,32 @@ lemma max_ipc_size_le_2_msg_align_bits[Ipc_R_assms]: "max_ipc_words * word_size \ 2 ^ msg_align_bits" by (simp add: max_ipc_words word_size_def msg_align_bits) -lemma maskCapRights_vs_cap_ref'[simp]: - "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" - unfolding vs_cap_ref'_def +lemma maskCapRights_vsCapRef[simp]: + "vsCapRef (maskCapRights msk cap) = vsCapRef cap" + unfolding vsCapRef_def apply (cases cap, simp_all add: global.maskCapRights_def isCap_simps Let_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: ARM_H.maskCapRights_def isCap_simps Let_def) done +lemma vsCapRef_generic: + "\ isArchObjectCap cap \ vsCapRef cap = None" + by (clarsimp simp add: vsCapRef_def gen_isCap_simps split: capability.splits) + lemma is_derived'_Untyped[Ipc_R_assms]: "\isUntypedCap cap'\ \ is_derived' m src cap' cap = (isUntypedCap cap \ badge_derived' cap' cap \ descendants_of' src m = {})" by (clarsimp simp add: ARM.is_derived'_def gen_isCap_simps) - (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def vsCapRef_generic isCap_simps) lemma is_derived'_Reply[Ipc_R_assms]: "\isReplyCap cap'\ \ is_derived' m src cap' cap = (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ capReplyMaster cap \ \ capReplyMaster cap')" by (clarsimp simp add: ARM.is_derived'_def gen_isCap_simps) - (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def vsCapRef_generic isCap_simps) lemma maskCapRights_eq_null[Ipc_R_assms, simp]: "(RetypeDecls_H.maskCapRights r cap = capability.NullCap) = (cap = capability.NullCap)" @@ -82,23 +87,23 @@ lemma is_derived'_IRQHandlerCap[Ipc_R_assms]: "\isIRQHandlerCap cap'\ \ is_derived' (ctes_of (s::kernel_state)) src cap' cap = (isIRQHandlerCap cap \ badge_derived' cap' cap)" by (clarsimp simp add: ARM.is_derived'_def gen_isCap_simps) - (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def vsCapRef_generic isCap_simps) lemma storeWordUser_vms'[Ipc_R_assms, wp]: "storeWordUser a w \valid_machine_state'\" proof - have aligned_offset_ignore: - "\(l::machine_word) (p::machine_word) sz. l<8 \ p && mask 3 = 0 \ + "\(l::machine_word) (p::machine_word) sz. l<4 \ p && mask 2 = 0 \ p+l && ~~ mask pageBits = p && ~~ mask pageBits" proof - fix l p sz - assume al: "(p::machine_word) && mask 3 = 0" - assume "(l::machine_word) < 8" hence less: "l<2^3" by simp - have le: "3 \ pageBits" by (simp add: pageBits_def) + assume al: "(p::machine_word) && mask 2 = 0" + assume "(l::machine_word) < 4" hence less: "l<2^2" by simp + have le: "2 \ pageBits" by (simp add: pageBits_def) show "?thesis l p sz" by (rule is_aligned_add_helper[simplified is_aligned_mask, THEN conjunct2, THEN mask_out_first_mask_some, - where n=3, OF al less le]) + where n=2, OF al less le]) qed show ?thesis @@ -114,7 +119,7 @@ proof - apply (erule disjE, simp) apply (simp add: pointerInUserData_def word_size) apply (subgoal_tac "a && ~~ mask pageBits = p && ~~ mask pageBits", simp) - apply (simp only: is_aligned_mask[of _ 3]) + apply (simp only: is_aligned_mask[of _ 2]) apply (elim disjE, simp_all) apply (rule aligned_offset_ignore[symmetric], simp+)+ done @@ -125,7 +130,7 @@ lemma isArchObjectCap_maskCapRights[Ipc_R_assms]: by (cases acap; simp add: ARM_H.maskCapRights_def isCap_simps) lemma isFrameCap_maskCapRights[simp]: - "isArchCap isFrameCap (global.maskCapRights R c) = isArchCap isFrameCap c" + "isArchCap isPageCap (global.maskCapRights R c) = isArchCap isPageCap c" apply (case_tac c; simp add: gen_isCap_simps isArchCap_def global.maskCapRights_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: isCap_simps ARM_H.maskCapRights_def) @@ -135,7 +140,6 @@ lemma arch_updateCapData_ordering[Ipc_R_assms]: "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" by (cases acap; simp add: ARM_H.updateCapData_def) - fastforce lemma ArchUpdateCapData_noReply[Ipc_R_assms]: "Arch.updateCapData p d acap \ capability.ReplyCap x y z" @@ -145,12 +149,12 @@ lemma ArchUpdateCapData_noIRQControl[Ipc_R_assms]: "Arch.updateCapData p d acap \ IRQControlCap" by (cases acap; simp add: ARM_H.updateCapData_def) -lemma updateCapData_vs_cap_ref'[simp]: - "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" +lemma updateCapData_vsCapRef[simp]: + "vsCapRef (updateCapData pr D c) = vsCapRef c" by (rule ccontr, clarsimp simp: isCap_simps global.updateCapData_def Let_def ARM_H.updateCapData_def - vs_cap_ref'_def + vsCapRef_def split del: if_split split: if_split_asm arch_capability.splits) @@ -201,6 +205,7 @@ lemma makeArchFaultMessage_inv[Ipc_R_assms, wp]: lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" unfolding lookupIPCBuffer_def + supply tcb_cte_cases_simps(1)[simp del] (* avoid duplicate simp rule warning *) supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def locateSlot_conv threadGet_def comp_def) @@ -219,7 +224,7 @@ lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: isCap_simps cte_level_bits_def field_simps) apply (drule bspec [OF _ ranI [where a = "4 << cteSizeBits"]]) apply (simp add: cteSizeBits_def) - apply (clarsimp simp add: valid_cap'_def frame_at'_def) + apply (clarsimp simp add: valid_cap'_def) apply (rule conjI) apply (rule aligned_add_aligned) apply (clarsimp simp add: capAligned_def) @@ -227,9 +232,10 @@ lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: apply (erule is_aligned_andI1) apply (rule order_trans[rotated]) apply (rule pbfs_atleast_pageBits) - apply (simp add: bit_simps msg_align_bits) + apply (simp add: msg_align_bits pageBits_def) apply (clarsimp simp: capAligned_def) - apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize sz)) >> pageBits" in spec) + apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize d)) >> pageBits" in spec) + apply (subst(asm) mult.commute mult.left_commute, subst(asm) shiftl_t2n[symmetric]) apply (simp add: shiftr_shiftl1 ) apply (subst (asm) mask_out_add_aligned) apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) @@ -250,7 +256,7 @@ lemma arch_getSanitiseRegisterInfo_corres[Ipc_R_assms]: (arch_get_sanitise_register_info t) (getSanitiseRegisterInfo t)" unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def - by (fold archThreadGet_def, corres) + by corres crunch getSanitiseRegisterInfo for tcb_at'[wp]: "tcb_at' t" @@ -292,12 +298,16 @@ lemma max_message_size_less_max_ipc_words[Ipc_R_assms]: \ word_size * (word_of_nat msg_max_extra_caps + (word_of_nat msg_max_length + n)) < max_ipc_words * word_size" apply (simp add: msg_max_extra_caps_def msg_max_length_def max_ipc_words word_size_def) - apply (rule_tac y="0x3D8 + 8 * 4" in order_le_less_trans) + apply (rule_tac y="0x1EC + 4 * 4" in order_le_less_trans) apply (rule word_plus_mono_right) apply (rule word_mult_le_mono1'; simp) apply simp+ done +crunch setThreadState, asUser + for valid_pde_mappings'[wp]: valid_pde_mappings' + (simp: crunch_simps wp: hoare_drop_imps) + end (* Arch *) interpretation Ipc_R?: Ipc_R diff --git a/proof/refine/ARM/ArchKHeap_R.thy b/proof/refine/ARM/ArchKHeap_R.thy index 7e7e7ed9ba..29801b4561 100644 --- a/proof/refine/ARM/ArchKHeap_R.thy +++ b/proof/refine/ARM/ArchKHeap_R.thy @@ -268,6 +268,11 @@ lemma pspace_in_kernel_mappings'_wp[wp]: unfolding pspace_in_kernel_mappings'_def by wp +(* only on arches without kernel mappings, used for arch interface assumptions *) +lemma pspace_in_kernel_mappings'_inv: + "f \pspace_in_kernel_mappings'\" + by wp + lemma setEndpoint_pspace_in_kernel_mappings'[KHeap_R_assms]: "setEndpoint p ko \pspace_in_kernel_mappings'\" by wp diff --git a/proof/refine/ARM/ArchTcbAcc_R.thy b/proof/refine/ARM/ArchTcbAcc_R.thy index 8171c5867f..5c0fb4ce9d 100644 --- a/proof/refine/ARM/ArchTcbAcc_R.thy +++ b/proof/refine/ARM/ArchTcbAcc_R.thy @@ -470,6 +470,7 @@ lemma asUser_valid_objs[wp]: simp: valid_tcb'_def tcb_cte_cases_def valid_arch_tcb'_def cteSizeBits_def atcbContextSet_def)+ +(* interface lemma, but can't be done via locale *) lemma asUser_valid_pspace'[wp]: "\valid_pspace'\ asUser t m \\rv. valid_pspace'\" apply (simp add: asUser_def) @@ -477,11 +478,13 @@ lemma asUser_valid_pspace'[wp]: simp: atcbContextSet_def valid_arch_tcb'_def)+ done +(* interface lemma, but can't be done via locale *) lemma asUser_st_hyp_refs_of'[wp]: "asUser t m \\s. P (state_hyp_refs_of' s)\" unfolding asUser_def by (wpsimp wp: threadSet_state_hyp_refs_of' hoare_drop_imps simp: atcbContextSet_def) +(* interface lemma, but can't be done via locale *) lemma asUser_iflive'[wp]: "asUser t m \if_live_then_nonz_cap'\ " unfolding asUser_def @@ -844,7 +847,7 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms -lemma setMRs_corres: +lemma setMRs_corres[TcbAcc_R_3_assms]: assumes m: "mrs' = mrs" shows "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) @@ -931,6 +934,13 @@ lemma asUser_invs[wp]: crunch storeWordUser for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" +lemma set_mrs_invs'[TcbAcc_R_3_assms, wp]: + "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" + apply (simp add: setMRs_def) + apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| + simp add: zipWithM_x_mapM split_def)+ + done + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -949,10 +959,16 @@ arch_requalify_facts asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' lemmas [wp] = asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' end diff --git a/proof/refine/ARM/ArchVSpace_R.thy b/proof/refine/ARM/ArchVSpace_R.thy index ecf0138e7c..d6fa9bb513 100644 --- a/proof/refine/ARM/ArchVSpace_R.thy +++ b/proof/refine/ARM/ArchVSpace_R.thy @@ -2038,13 +2038,6 @@ crunch updateCap lemmas setMRs_typ_at_lifts[wp] = typ_at_lifts [OF setMRs_typ_at'] -lemma set_mrs_invs'[wp]: - "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" - apply (simp add: setMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| - simp add: zipWithM_x_mapM split_def)+ - done - lemma same_refs_vs_cap_ref_eq: assumes "valid_slots entries s" assumes "same_refs entries cap s" diff --git a/proof/refine/ARM_HYP/ArchCSpace_I.thy b/proof/refine/ARM_HYP/ArchCSpace_I.thy index 0ecfac2646..4d71f3ff7d 100644 --- a/proof/refine/ARM_HYP/ArchCSpace_I.thy +++ b/proof/refine/ARM_HYP/ArchCSpace_I.thy @@ -279,7 +279,7 @@ lemma capMasterCap_maskCapRights[simp, CSpace_I_2_assms]: apply (case_tac arch_capability; simp add: maskCapRights_def Let_def isCap_simps) done -lemma capBadge_maskCapRights[simp]: +lemma capBadge_maskCapRights[simp, CSpace_I_2_assms]: "capBadge (maskCapRights msk cap) = capBadge cap" apply (cases cap; simp add: global.maskCapRights_def Let_def gen_isCap_simps capBadge_def) apply (rename_tac arch_capability) diff --git a/proof/refine/ARM_HYP/ArchCSpace_R.thy b/proof/refine/ARM_HYP/ArchCSpace_R.thy index 4145fef756..9141052ec3 100644 --- a/proof/refine/ARM_HYP/ArchCSpace_R.thy +++ b/proof/refine/ARM_HYP/ArchCSpace_R.thy @@ -351,12 +351,12 @@ context Arch begin arch_global_naming named_theorems CSpace_R_2_assms -lemma deriveCap_derived: +lemma deriveCap_derived[CSpace_R_2_assms]: "\\s. c'\ capability.NullCap \ cte_wp_at' (\cte. badge_derived' c' (cteCap cte) - \ capASID c' = capASID (cteCap cte) - \ cap_asid_base' c' = cap_asid_base' (cteCap cte) - \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s\ + \ capASID c' = capASID (cteCap cte) + \ cap_asid_base' c' = cap_asid_base' (cteCap cte) + \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s + \ valid_objs' s\ deriveCap slot c' \\rv s. rv \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot rv \ cteCap) slot s\, -" @@ -381,9 +381,9 @@ lemma deriveCap_derived: | clarsimp split: option.split_asm)+) done -lemma arch_deriveCap_untyped_derived[wp]: +lemma arch_deriveCap_untyped_derived[CSpace_R_2_assms, wp]: "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - ARM_HYP_H.deriveCap slot (capCap c') + ARM_HYP_H.deriveCap slot (capCap c') \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" apply (wpsimp simp: ARM_HYP_H.deriveCap_def Let_def untyped_derived_eq_ArchObjectCap split_del: if_split @@ -391,16 +391,6 @@ lemma arch_deriveCap_untyped_derived[wp]: apply(clarsimp simp: cte_wp_at_ctes_of isCap_simps untyped_derived_eq_def) by (case_tac "capCap c'"; fastforce) -lemma deriveCap_untyped_derived: - "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - deriveCap slot c' - \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" - apply (simp add: global.deriveCap_def split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp arch_deriveCap_inv | simp add: o_def untyped_derived_eq_ArchObjectCap)+ - apply (clarsimp simp: cte_wp_at_ctes_of gen_isCap_simps untyped_derived_eq_def) - done - lemma corres_caps_decomposition: assumes pspace_corres: "corres_underlying {(s, s'). pspace_relation (kheap s) (ksPSpace s')} False True r P P' f g" @@ -670,7 +660,7 @@ crunch setupReplyMaster for valid_arch'[wp]: "valid_arch_state'" (wp: crunch_wps simp: crunch_simps) -lemma ex_nonz_tcb_cte_caps': +lemma ex_nonz_tcb_cte_caps'[CSpace_R_2_assms]: "\ex_nonz_cap_to' t s; tcb_at' t s; valid_objs' s; sl \ dom tcb_cte_cases\ \ ex_cte_cap_to' (t + sl) s" apply (clarsimp simp: ex_nonz_cap_to'_def ex_cte_cap_to'_def cte_wp_at_ctes_of) @@ -1385,7 +1375,7 @@ lemmas [CSpace_R_3_assms] = updateCap_valid_arch_state' master_cap_relation -lemma derived'_not_Null: +lemma derived'_not_Null[CSpace_R_3_assms, simp]: "\ is_derived' m p c capability.NullCap" "\ is_derived' m p capability.NullCap c" by (clarsimp simp: is_derived'_def badge_derived'_def)+ diff --git a/proof/refine/ARM_HYP/ArchIpc_R.thy b/proof/refine/ARM_HYP/ArchIpc_R.thy index 706d79aa4d..6b6ae2f770 100644 --- a/proof/refine/ARM_HYP/ArchIpc_R.thy +++ b/proof/refine/ARM_HYP/ArchIpc_R.thy @@ -1,5 +1,6 @@ (* * Copyright 2014, General Dynamics C4 Systems + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -12,7 +13,7 @@ context Arch begin arch_global_naming named_theorems Ipc_R_assms -declare word64_minus_one_le[simp] +declare word32_minus_one_le[simp] lemma getMessageInfo_corres[Ipc_R_assms]: "corres ((=) \ message_info_map) @@ -30,28 +31,32 @@ lemma max_ipc_size_le_2_msg_align_bits[Ipc_R_assms]: "max_ipc_words * word_size \ 2 ^ msg_align_bits" by (simp add: max_ipc_words word_size_def msg_align_bits) -lemma maskCapRights_vs_cap_ref'[simp]: - "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" - unfolding vs_cap_ref'_def +lemma maskCapRights_vsCapRef[simp]: + "vsCapRef (maskCapRights msk cap) = vsCapRef cap" + unfolding vsCapRef_def apply (cases cap, simp_all add: global.maskCapRights_def isCap_simps Let_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: ARM_HYP_H.maskCapRights_def isCap_simps Let_def) done +lemma vsCapRef_generic: + "\ isArchObjectCap cap \ vsCapRef cap = None" + by (clarsimp simp add: vsCapRef_def gen_isCap_simps split: capability.splits) + lemma is_derived'_Untyped[Ipc_R_assms]: "\isUntypedCap cap'\ \ is_derived' m src cap' cap = (isUntypedCap cap \ badge_derived' cap' cap \ descendants_of' src m = {})" by (clarsimp simp add: ARM_HYP.is_derived'_def gen_isCap_simps) - (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def vsCapRef_generic isCap_simps) lemma is_derived'_Reply[Ipc_R_assms]: "\isReplyCap cap'\ \ is_derived' m src cap' cap = (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ capReplyMaster cap \ \ capReplyMaster cap')" by (clarsimp simp add: ARM_HYP.is_derived'_def gen_isCap_simps) - (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def vsCapRef_generic isCap_simps) lemma maskCapRights_eq_null[Ipc_R_assms, simp]: "(RetypeDecls_H.maskCapRights r cap = capability.NullCap) = (cap = capability.NullCap)" @@ -82,23 +87,23 @@ lemma is_derived'_IRQHandlerCap[Ipc_R_assms]: "\isIRQHandlerCap cap'\ \ is_derived' (ctes_of (s::kernel_state)) src cap' cap = (isIRQHandlerCap cap \ badge_derived' cap' cap)" by (clarsimp simp add: ARM_HYP.is_derived'_def gen_isCap_simps) - (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def vsCapRef_generic isCap_simps) lemma storeWordUser_vms'[Ipc_R_assms, wp]: "storeWordUser a w \valid_machine_state'\" proof - have aligned_offset_ignore: - "\(l::machine_word) (p::machine_word) sz. l<8 \ p && mask 3 = 0 \ + "\(l::machine_word) (p::machine_word) sz. l<4 \ p && mask 2 = 0 \ p+l && ~~ mask pageBits = p && ~~ mask pageBits" proof - fix l p sz - assume al: "(p::machine_word) && mask 3 = 0" - assume "(l::machine_word) < 8" hence less: "l<2^3" by simp - have le: "3 \ pageBits" by (simp add: pageBits_def) + assume al: "(p::machine_word) && mask 2 = 0" + assume "(l::machine_word) < 4" hence less: "l<2^2" by simp + have le: "2 \ pageBits" by (simp add: pageBits_def) show "?thesis l p sz" by (rule is_aligned_add_helper[simplified is_aligned_mask, THEN conjunct2, THEN mask_out_first_mask_some, - where n=3, OF al less le]) + where n=2, OF al less le]) qed show ?thesis @@ -114,7 +119,7 @@ proof - apply (erule disjE, simp) apply (simp add: pointerInUserData_def word_size) apply (subgoal_tac "a && ~~ mask pageBits = p && ~~ mask pageBits", simp) - apply (simp only: is_aligned_mask[of _ 3]) + apply (simp only: is_aligned_mask[of _ 2]) apply (elim disjE, simp_all) apply (rule aligned_offset_ignore[symmetric], simp+)+ done @@ -125,7 +130,7 @@ lemma isArchObjectCap_maskCapRights[Ipc_R_assms]: by (cases acap; simp add: ARM_HYP_H.maskCapRights_def isCap_simps) lemma isFrameCap_maskCapRights[simp]: - "isArchCap isFrameCap (global.maskCapRights R c) = isArchCap isFrameCap c" + "isArchCap isPageCap (global.maskCapRights R c) = isArchCap isPageCap c" apply (case_tac c; simp add: gen_isCap_simps isArchCap_def global.maskCapRights_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: isCap_simps ARM_HYP_H.maskCapRights_def) @@ -135,7 +140,6 @@ lemma arch_updateCapData_ordering[Ipc_R_assms]: "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" by (cases acap; simp add: ARM_HYP_H.updateCapData_def) - fastforce lemma ArchUpdateCapData_noReply[Ipc_R_assms]: "Arch.updateCapData p d acap \ capability.ReplyCap x y z" @@ -145,12 +149,12 @@ lemma ArchUpdateCapData_noIRQControl[Ipc_R_assms]: "Arch.updateCapData p d acap \ IRQControlCap" by (cases acap; simp add: ARM_HYP_H.updateCapData_def) -lemma updateCapData_vs_cap_ref'[simp]: - "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" +lemma updateCapData_vsCapRef[simp]: + "vsCapRef (updateCapData pr D c) = vsCapRef c" by (rule ccontr, clarsimp simp: isCap_simps global.updateCapData_def Let_def ARM_HYP_H.updateCapData_def - vs_cap_ref'_def + vsCapRef_def split del: if_split split: if_split_asm arch_capability.splits) @@ -201,6 +205,7 @@ lemma makeArchFaultMessage_inv[Ipc_R_assms, wp]: lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" unfolding lookupIPCBuffer_def + supply tcb_cte_cases_simps(1)[simp del] (* avoid duplicate simp rule warning *) supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def locateSlot_conv threadGet_def comp_def) @@ -219,7 +224,7 @@ lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: isCap_simps cte_level_bits_def field_simps) apply (drule bspec [OF _ ranI [where a = "4 << cteSizeBits"]]) apply (simp add: cteSizeBits_def) - apply (clarsimp simp add: valid_cap'_def frame_at'_def) + apply (clarsimp simp add: valid_cap'_def) apply (rule conjI) apply (rule aligned_add_aligned) apply (clarsimp simp add: capAligned_def) @@ -227,9 +232,10 @@ lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: apply (erule is_aligned_andI1) apply (rule order_trans[rotated]) apply (rule pbfs_atleast_pageBits) - apply (simp add: bit_simps msg_align_bits) + apply (simp add: msg_align_bits pageBits_def) apply (clarsimp simp: capAligned_def) - apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize sz)) >> pageBits" in spec) + apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize d)) >> pageBits" in spec) + apply (subst(asm) mult.commute mult.left_commute, subst(asm) shiftl_t2n[symmetric]) apply (simp add: shiftr_shiftl1 ) apply (subst (asm) mask_out_add_aligned) apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) @@ -292,12 +298,16 @@ lemma max_message_size_less_max_ipc_words[Ipc_R_assms]: \ word_size * (word_of_nat msg_max_extra_caps + (word_of_nat msg_max_length + n)) < max_ipc_words * word_size" apply (simp add: msg_max_extra_caps_def msg_max_length_def max_ipc_words word_size_def) - apply (rule_tac y="0x3D8 + 8 * 4" in order_le_less_trans) + apply (rule_tac y="0x1EC + 4 * 4" in order_le_less_trans) apply (rule word_plus_mono_right) apply (rule word_mult_le_mono1'; simp) apply simp+ done +crunch setThreadState, asUser + for valid_pde_mappings'[wp]: valid_pde_mappings' + (simp: crunch_simps wp: hoare_drop_imps) + end (* Arch *) interpretation Ipc_R?: Ipc_R @@ -312,6 +322,15 @@ lemma is_derived_mask'[simp]: "is_derived' m p (maskCapRights R c) = is_derived' m p c" by (rule ext, simp add: is_derived'_def badge_derived'_def) +lemma dmo_addressTranslateS1_valid_machine_state'[wp]: + "doMachineOp (addressTranslateS1 pc) \valid_machine_state'\" + by (wpsimp simp: valid_machine_state'_def + pointerInUserData_def + pointerInDeviceData_def + wp: dmo_lift' hoare_vcg_all_lift + addressTranslateS1_underlying_memory + hoare_vcg_disj_lift) + end (* Arch *) end diff --git a/proof/refine/ARM_HYP/ArchKHeap_R.thy b/proof/refine/ARM_HYP/ArchKHeap_R.thy index 2691f28ec3..3e3752d0f7 100644 --- a/proof/refine/ARM_HYP/ArchKHeap_R.thy +++ b/proof/refine/ARM_HYP/ArchKHeap_R.thy @@ -326,6 +326,11 @@ lemma pspace_in_kernel_mappings'_wp[wp]: unfolding pspace_in_kernel_mappings'_def by wp +(* only on arches without kernel mappings, used for arch interface assumptions *) +lemma pspace_in_kernel_mappings'_inv: + "f \pspace_in_kernel_mappings'\" + by wp + lemma setEndpoint_pspace_in_kernel_mappings'[KHeap_R_assms]: "setEndpoint p ko \pspace_in_kernel_mappings'\" by wp diff --git a/proof/refine/ARM_HYP/ArchMove_R.thy b/proof/refine/ARM_HYP/ArchMove_R.thy index 56768243de..a13637a5a6 100644 --- a/proof/refine/ARM_HYP/ArchMove_R.thy +++ b/proof/refine/ARM_HYP/ArchMove_R.thy @@ -20,7 +20,7 @@ lemmas of_nat_inj32 = of_nat_inj[where 'a=32, folded word_bits_def] (* prefer 2 as a tactic *) method prefer_next = tactic \SUBGOAL (K (prefer_tac 2)) 1\ -context begin interpretation Arch . +context Arch begin arch_global_naming (* Move to Machine_AI *) lemma no_fail_writeContextIDAndPD[wp]: "no_fail \ (writeContextIDAndPD a w)" @@ -43,6 +43,10 @@ lemma flush_space_vspace_objs[wp]: "\valid_vspace_objs\ flush_space space \\rv. valid_vspace_objs\" by (wpsimp simp: flush_space_def) +(* FIXME: move, missing in Ipc_AI on this architecture *) +crunch handle_arch_fault_reply, arch_get_sanitise_register_info + for inv[Ipc_AI_2_assms]: P + end end diff --git a/proof/refine/ARM_HYP/ArchTcbAcc_R.thy b/proof/refine/ARM_HYP/ArchTcbAcc_R.thy index beab48d04f..57e1a91522 100644 --- a/proof/refine/ARM_HYP/ArchTcbAcc_R.thy +++ b/proof/refine/ARM_HYP/ArchTcbAcc_R.thy @@ -508,6 +508,7 @@ lemma asUser_valid_objs[wp]: simp: valid_tcb'_def tcb_cte_cases_def valid_arch_tcb'_def cteSizeBits_def atcbContextSet_def)+ +(* interface lemma, but can't be done via locale *) lemma asUser_valid_pspace'[wp]: "\valid_pspace'\ asUser t m \\rv. valid_pspace'\" apply (simp add: asUser_def) @@ -515,11 +516,13 @@ lemma asUser_valid_pspace'[wp]: simp: atcbContextSet_def valid_arch_tcb'_def)+ done +(* interface lemma, but can't be done via locale *) lemma asUser_st_hyp_refs_of'[wp]: "asUser t m \\s. P (state_hyp_refs_of' s)\" unfolding asUser_def by (wpsimp wp: threadSet_state_hyp_refs_of' hoare_drop_imps simp: atcbContextSet_def) +(* interface lemma, but can't be done via locale *) lemma asUser_iflive'[wp]: "asUser t m \if_live_then_nonz_cap'\ " unfolding asUser_def @@ -882,7 +885,7 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms -lemma setMRs_corres: +lemma setMRs_corres[TcbAcc_R_3_assms]: assumes m: "mrs' = mrs" shows "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) @@ -969,6 +972,13 @@ lemma asUser_invs[wp]: crunch storeWordUser for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" +lemma set_mrs_invs'[TcbAcc_R_3_assms, wp]: + "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" + apply (simp add: setMRs_def) + apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| + simp add: zipWithM_x_mapM split_def)+ + done + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -987,10 +997,16 @@ arch_requalify_facts asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' lemmas [wp] = asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' end diff --git a/proof/refine/ARM_HYP/ArchVSpace_R.thy b/proof/refine/ARM_HYP/ArchVSpace_R.thy index 2e929f91cd..5c064fb6e9 100644 --- a/proof/refine/ARM_HYP/ArchVSpace_R.thy +++ b/proof/refine/ARM_HYP/ArchVSpace_R.thy @@ -2688,13 +2688,6 @@ crunch updateCap lemmas setMRs_typ_at_lifts[wp] = typ_at_lifts [OF setMRs_typ_at'] -lemma set_mrs_invs'[wp]: - "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" - apply (simp add: setMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| - simp add: zipWithM_x_mapM split_def)+ - done - lemma same_refs_vs_cap_ref_eq: assumes "valid_slots entries s" assumes "same_refs entries cap s" diff --git a/proof/refine/ARM_HYP/Syscall_R.thy b/proof/refine/ARM_HYP/Syscall_R.thy index 7c796ead87..7b163097bd 100644 --- a/proof/refine/ARM_HYP/Syscall_R.thy +++ b/proof/refine/ARM_HYP/Syscall_R.thy @@ -1857,6 +1857,16 @@ lemma getHDFAR_invs'[wp]: "valid invs' (doMachineOp getHDFAR) (\_. invs')" by (simp add: getHDFAR_def doMachineOp_def split_def select_f_returns | wp)+ +lemma dmo_addressTranslateS1_invs'[wp]: + "doMachineOp (addressTranslateS1 pc) \invs'\" + apply (wp dmo_invs' no_irq_addressTranslateS1 no_irq) + apply clarsimp + apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" + in use_valid) + apply (clarsimp simp: addressTranslateS1_def machine_op_lift_def + machine_rest_lift_def split_def | wp)+ + done + lemma hv_invs'[wp]: "\invs' and tcb_at' t'\ handleVMFault t' vptr \\r. invs'\" apply (simp add: ARM_HYP_H.handleVMFault_def cong: vmfault_type.case_cong) @@ -2228,6 +2238,17 @@ crunch handleVMFault and norq[wp]: "\s. P (ksReadyQueues s)" (ignore: getFAR getDFSR getIFSR) +(* only needed on ARM_HYP *) +lemma setupCallerCap_cap_to'[wp]: + "setupCallerCap a b c \ex_nonz_cap_to' p\" + unfolding setupCallerCap_def getThreadCallerSlot_def getThreadReplySlot_def + apply (wp cteInsert_cap_to') + apply (rule_tac Q'="\rv. ex_nonz_cap_to' p + and cte_wp_at' (\c. (cteCap c) = rv) callerSlot" + in hoare_post_imp) + apply (wpsimp simp: cte_wp_at_ctes_of wp: getSlotCap_cte_wp_at hoare_drop_imps)+ + done + crunch handleVMFault, handleHypervisorFault for cap_to'[wp]: "ex_nonz_cap_to' t" and ksit[wp]: "\s. P (ksIdleThread s)" diff --git a/proof/refine/RISCV64/ArchCSpace_I.thy b/proof/refine/RISCV64/ArchCSpace_I.thy index 1543e2f9e3..10f58b03d0 100644 --- a/proof/refine/RISCV64/ArchCSpace_I.thy +++ b/proof/refine/RISCV64/ArchCSpace_I.thy @@ -260,7 +260,7 @@ lemma capMasterCap_maskCapRights[simp, CSpace_I_2_assms]: apply (case_tac arch_capability; simp add: maskCapRights_def Let_def isCap_simps) done -lemma capBadge_maskCapRights[simp]: +lemma capBadge_maskCapRights[simp, CSpace_I_2_assms]: "capBadge (maskCapRights msk cap) = capBadge cap" apply (cases cap; simp add: global.maskCapRights_def Let_def gen_isCap_simps capBadge_def) apply (rename_tac arch_capability) diff --git a/proof/refine/RISCV64/ArchCSpace_R.thy b/proof/refine/RISCV64/ArchCSpace_R.thy index aef8dd259d..33b19b961a 100644 --- a/proof/refine/RISCV64/ArchCSpace_R.thy +++ b/proof/refine/RISCV64/ArchCSpace_R.thy @@ -299,12 +299,12 @@ context Arch begin arch_global_naming named_theorems CSpace_R_2_assms -lemma deriveCap_derived: +lemma deriveCap_derived[CSpace_R_2_assms]: "\\s. c'\ capability.NullCap \ cte_wp_at' (\cte. badge_derived' c' (cteCap cte) - \ capASID c' = capASID (cteCap cte) - \ cap_asid_base' c' = cap_asid_base' (cteCap cte) - \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s\ + \ capASID c' = capASID (cteCap cte) + \ cap_asid_base' c' = cap_asid_base' (cteCap cte) + \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s + \ valid_objs' s\ deriveCap slot c' \\rv s. rv \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot rv \ cteCap) slot s\, -" @@ -329,9 +329,9 @@ lemma deriveCap_derived: | clarsimp split: option.split_asm)+) done -lemma arch_deriveCap_untyped_derived[wp]: +lemma arch_deriveCap_untyped_derived[CSpace_R_2_assms, wp]: "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - RISCV64_H.deriveCap slot (capCap c') + RISCV64_H.deriveCap slot (capCap c') \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" apply (wpsimp simp: RISCV64_H.deriveCap_def Let_def untyped_derived_eq_ArchObjectCap split_del: if_split @@ -339,16 +339,6 @@ lemma arch_deriveCap_untyped_derived[wp]: apply(clarsimp simp: cte_wp_at_ctes_of isCap_simps untyped_derived_eq_def) by (case_tac "capCap c'"; fastforce) -lemma deriveCap_untyped_derived: - "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - deriveCap slot c' - \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" - apply (simp add: global.deriveCap_def split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp arch_deriveCap_inv | simp add: o_def untyped_derived_eq_ArchObjectCap)+ - apply (clarsimp simp: cte_wp_at_ctes_of gen_isCap_simps untyped_derived_eq_def) - done - lemma corres_caps_decomposition: assumes pspace_corres: "corres_underlying {(s, s'). pspace_relation (kheap s) (ksPSpace s')} False True r P P' f g" @@ -620,7 +610,7 @@ crunch setupReplyMaster for valid_arch'[wp]: "valid_arch_state'" (wp: crunch_wps simp: crunch_simps) -lemma ex_nonz_tcb_cte_caps': +lemma ex_nonz_tcb_cte_caps'[CSpace_R_2_assms]: "\ex_nonz_cap_to' t s; tcb_at' t s; valid_objs' s; sl \ dom tcb_cte_cases\ \ ex_cte_cap_to' (t + sl) s" apply (clarsimp simp: ex_nonz_cap_to'_def ex_cte_cap_to'_def cte_wp_at_ctes_of) @@ -1308,7 +1298,7 @@ lemmas [CSpace_R_3_assms] = master_cap_relation updateMDB_pspace_in_kernel_mappings' -lemma derived'_not_Null: +lemma derived'_not_Null[CSpace_R_3_assms, simp]: "\ is_derived' m p c capability.NullCap" "\ is_derived' m p capability.NullCap c" by (clarsimp simp: is_derived'_def badge_derived'_def)+ diff --git a/proof/refine/RISCV64/ArchIpc_R.thy b/proof/refine/RISCV64/ArchIpc_R.thy index 25a783b391..4bba6aff70 100644 --- a/proof/refine/RISCV64/ArchIpc_R.thy +++ b/proof/refine/RISCV64/ArchIpc_R.thy @@ -1,5 +1,6 @@ (* * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -72,8 +73,8 @@ lemma cap_vptr'_gen_cap[Ipc_R_assms]: "\ isArchObjectCap cap \ cap_vptr' cap = None" by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemmas transferCapsToSlots_pspace_in_kernel_mappings'[Ipc_R_assms, wp] = - pspace_in_kernel_mappings'_inv[where f="transferCapsToSlots _ _ _ _ _ _"] +crunch transferCapsToSlots + for pspace_in_kernel_mappings'[Ipc_R_assms, wp]: pspace_in_kernel_mappings' crunch makeArchFaultMessage for sch_act[Ipc_R_assms, wp]: "\s. P (ksSchedulerAction s)" @@ -135,7 +136,6 @@ lemma arch_updateCapData_ordering[Ipc_R_assms]: "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" by (cases acap; simp add: RISCV64_H.updateCapData_def) - fastforce lemma ArchUpdateCapData_noReply[Ipc_R_assms]: "Arch.updateCapData p d acap \ capability.ReplyCap x y z" @@ -171,8 +171,9 @@ lemma badgeRegister_badge_register[Ipc_R_assms]: "badgeRegister = badge_register" by (simp add: badge_register_def badgeRegister_def) -lemmas copyMRs__pspace_in_kernel_mappings'[Ipc_R_assms, wp] = - pspace_in_kernel_mappings'_inv[where f="copyMRs _ _ _ _ _"] +crunch copyMRs + for pspace_in_kernel_mappings'[Ipc_R_assms, wp]: pspace_in_kernel_mappings' + (wp: crunch_wps simp: crunch_simps) lemma makeArchFaultMessage_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -250,7 +251,7 @@ lemma arch_getSanitiseRegisterInfo_corres[Ipc_R_assms]: (arch_get_sanitise_register_info t) (getSanitiseRegisterInfo t)" unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def - by (fold archThreadGet_def, corres) + by corres crunch getSanitiseRegisterInfo for tcb_at'[wp]: "tcb_at' t" diff --git a/proof/refine/RISCV64/ArchTcbAcc_R.thy b/proof/refine/RISCV64/ArchTcbAcc_R.thy index 306c180d53..fe554f78b4 100644 --- a/proof/refine/RISCV64/ArchTcbAcc_R.thy +++ b/proof/refine/RISCV64/ArchTcbAcc_R.thy @@ -459,6 +459,7 @@ lemma asUser_valid_objs[wp]: simp: valid_tcb'_def tcb_cte_cases_def valid_arch_tcb'_def cteSizeBits_def atcbContextSet_def)+ +(* interface lemma, but can't be done via locale *) lemma asUser_valid_pspace'[wp]: "\valid_pspace'\ asUser t m \\rv. valid_pspace'\" apply (simp add: asUser_def) @@ -466,11 +467,13 @@ lemma asUser_valid_pspace'[wp]: simp: atcbContextSet_def valid_arch_tcb'_def)+ done +(* interface lemma, but can't be done via locale *) lemma asUser_st_hyp_refs_of'[wp]: "asUser t m \\s. P (state_hyp_refs_of' s)\" unfolding asUser_def by (wpsimp wp: threadSet_state_hyp_refs_of' hoare_drop_imps simp: atcbContextSet_def) +(* interface lemma, but can't be done via locale *) lemma asUser_iflive'[wp]: "asUser t m \if_live_then_nonz_cap'\ " unfolding asUser_def @@ -834,7 +837,7 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms -lemma setMRs_corres: +lemma setMRs_corres[TcbAcc_R_3_assms]: assumes m: "mrs' = mrs" shows "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) @@ -921,6 +924,13 @@ lemma asUser_invs[wp]: crunch storeWordUser for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" +lemma set_mrs_invs'[TcbAcc_R_3_assms, wp]: + "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" + apply (simp add: setMRs_def) + apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| + simp add: zipWithM_x_mapM split_def)+ + done + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -939,10 +949,16 @@ arch_requalify_facts asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' lemmas [wp] = asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' end diff --git a/proof/refine/RISCV64/ArchVSpace_R.thy b/proof/refine/RISCV64/ArchVSpace_R.thy index 981ca80144..b80d62c46c 100644 --- a/proof/refine/RISCV64/ArchVSpace_R.thy +++ b/proof/refine/RISCV64/ArchVSpace_R.thy @@ -368,13 +368,6 @@ definition lemmas setMRs_typ_at_lifts[wp] = typ_at_lifts [OF setMRs_typ_at'] -lemma set_mrs_invs'[wp]: - "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" - apply (simp add: setMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| - simp add: zipWithM_x_mapM split_def)+ - done - crunch unmapPage for cte_at'[wp]: "cte_at' p" (wp: crunch_wps simp: crunch_simps) diff --git a/proof/refine/X64/ArchCSpace_I.thy b/proof/refine/X64/ArchCSpace_I.thy index 8a443aae03..aa7d18d292 100644 --- a/proof/refine/X64/ArchCSpace_I.thy +++ b/proof/refine/X64/ArchCSpace_I.thy @@ -291,7 +291,7 @@ lemma capMasterCap_maskCapRights[simp, CSpace_I_2_assms]: apply (case_tac arch_capability; simp add: maskCapRights_def Let_def isCap_simps) done -lemma capBadge_maskCapRights[simp]: +lemma capBadge_maskCapRights[simp, CSpace_I_2_assms]: "capBadge (maskCapRights msk cap) = capBadge cap" apply (cases cap; simp add: global.maskCapRights_def Let_def gen_isCap_simps capBadge_def) apply (rename_tac arch_capability) diff --git a/proof/refine/X64/ArchCSpace_R.thy b/proof/refine/X64/ArchCSpace_R.thy index 8c634fc9f9..cd30414b2f 100644 --- a/proof/refine/X64/ArchCSpace_R.thy +++ b/proof/refine/X64/ArchCSpace_R.thy @@ -315,12 +315,12 @@ context Arch begin arch_global_naming named_theorems CSpace_R_2_assms -lemma deriveCap_derived: +lemma deriveCap_derived[CSpace_R_2_assms]: "\\s. c'\ capability.NullCap \ cte_wp_at' (\cte. badge_derived' c' (cteCap cte) - \ capASID c' = capASID (cteCap cte) - \ cap_asid_base' c' = cap_asid_base' (cteCap cte) - \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s - \ valid_objs' s\ + \ capASID c' = capASID (cteCap cte) + \ cap_asid_base' c' = cap_asid_base' (cteCap cte) + \ cap_vptr' c' = cap_vptr' (cteCap cte)) slot s + \ valid_objs' s\ deriveCap slot c' \\rv s. rv \ NullCap \ cte_wp_at' (is_derived' (ctes_of s) slot rv \ cteCap) slot s\, -" @@ -345,9 +345,9 @@ lemma deriveCap_derived: | clarsimp split: option.split_asm)+) done -lemma arch_deriveCap_untyped_derived[wp]: +lemma arch_deriveCap_untyped_derived[CSpace_R_2_assms, wp]: "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - X64_H.deriveCap slot (capCap c') + X64_H.deriveCap slot (capCap c') \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" apply (wpsimp simp: X64_H.deriveCap_def Let_def untyped_derived_eq_ArchObjectCap split_del: if_split @@ -355,16 +355,6 @@ lemma arch_deriveCap_untyped_derived[wp]: apply(clarsimp simp: cte_wp_at_ctes_of isCap_simps untyped_derived_eq_def) by (case_tac "capCap c'"; fastforce) -lemma deriveCap_untyped_derived: - "\\s. cte_wp_at' (\cte. untyped_derived_eq c' (cteCap cte)) slot s\ - deriveCap slot c' - \\rv s. cte_wp_at' (untyped_derived_eq rv o cteCap) slot s\, -" - apply (simp add: global.deriveCap_def split del: if_split cong: if_cong) - apply (rule hoare_pre) - apply (wp arch_deriveCap_inv | simp add: o_def untyped_derived_eq_ArchObjectCap)+ - apply (clarsimp simp: cte_wp_at_ctes_of gen_isCap_simps untyped_derived_eq_def) - done - lemma corres_caps_decomposition: assumes pspace_corres: "corres_underlying {(s, s'). pspace_relation (kheap s) (ksPSpace s')} False True r P P' f g" @@ -636,7 +626,7 @@ crunch setupReplyMaster for valid_arch'[wp]: "valid_arch_state'" (wp: crunch_wps simp: crunch_simps) -lemma ex_nonz_tcb_cte_caps': +lemma ex_nonz_tcb_cte_caps'[CSpace_R_2_assms]: "\ex_nonz_cap_to' t s; tcb_at' t s; valid_objs' s; sl \ dom tcb_cte_cases\ \ ex_cte_cap_to' (t + sl) s" apply (clarsimp simp: ex_nonz_cap_to'_def ex_cte_cap_to'_def cte_wp_at_ctes_of) @@ -1371,7 +1361,7 @@ lemmas [CSpace_R_3_assms] = master_cap_relation updateMDB_pspace_in_kernel_mappings' -lemma derived'_not_Null: +lemma derived'_not_Null[CSpace_R_3_assms, simp]: "\ is_derived' m p c capability.NullCap" "\ is_derived' m p capability.NullCap c" by (clarsimp simp: is_derived'_def badge_derived'_def)+ diff --git a/proof/refine/X64/ArchIpc_R.thy b/proof/refine/X64/ArchIpc_R.thy index 7efd8419f6..ef27ef19cf 100644 --- a/proof/refine/X64/ArchIpc_R.thy +++ b/proof/refine/X64/ArchIpc_R.thy @@ -1,5 +1,6 @@ (* * Copyright 2014, General Dynamics C4 Systems + * Copyright 2023, Proofcraft Pty Ltd * * SPDX-License-Identifier: GPL-2.0-only *) @@ -31,27 +32,31 @@ lemma max_ipc_size_le_2_msg_align_bits[Ipc_R_assms]: by (simp add: max_ipc_words word_size_def msg_align_bits) lemma maskCapRights_vs_cap_ref'[simp]: - "vs_cap_ref' (maskCapRights msk cap) = vs_cap_ref' cap" - unfolding vs_cap_ref'_def + "vsCapRef (maskCapRights msk cap) = vsCapRef cap" + unfolding vsCapRef_def apply (cases cap, simp_all add: global.maskCapRights_def isCap_simps Let_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: X64_H.maskCapRights_def isCap_simps Let_def) done +lemma vsCapRef_generic: + "\ isArchObjectCap cap \ vsCapRef cap = None" + by (clarsimp simp add: vsCapRef_def gen_isCap_simps split: capability.splits) + lemma is_derived'_Untyped[Ipc_R_assms]: "\isUntypedCap cap'\ \ is_derived' m src cap' cap = (isUntypedCap cap \ badge_derived' cap' cap \ descendants_of' src m = {})" by (clarsimp simp add: X64.is_derived'_def gen_isCap_simps) - (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def vsCapRef_generic isCap_simps) lemma is_derived'_Reply[Ipc_R_assms]: "\isReplyCap cap'\ \ is_derived' m src cap' cap = (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ capReplyMaster cap \ \ capReplyMaster cap')" by (clarsimp simp add: X64.is_derived'_def gen_isCap_simps) - (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def vsCapRef_generic isCap_simps) lemma maskCapRights_eq_null[Ipc_R_assms, simp]: "(RetypeDecls_H.maskCapRights r cap = capability.NullCap) = (cap = capability.NullCap)" @@ -72,8 +77,8 @@ lemma cap_vptr'_gen_cap[Ipc_R_assms]: "\ isArchObjectCap cap \ cap_vptr' cap = None" by (cases cap; simp add: isCap_simps split: arch_capability.split option.split) -lemmas transferCapsToSlots_pspace_in_kernel_mappings'[Ipc_R_assms, wp] = - pspace_in_kernel_mappings'_inv[where f="transferCapsToSlots _ _ _ _ _ _"] +crunch transferCapsToSlots + for pspace_in_kernel_mappings'[Ipc_R_assms, wp]: pspace_in_kernel_mappings' crunch makeArchFaultMessage for sch_act[Ipc_R_assms, wp]: "\s. P (ksSchedulerAction s)" @@ -82,7 +87,7 @@ lemma is_derived'_IRQHandlerCap[Ipc_R_assms]: "\isIRQHandlerCap cap'\ \ is_derived' (ctes_of (s::kernel_state)) src cap' cap = (isIRQHandlerCap cap \ badge_derived' cap' cap)" by (clarsimp simp add: X64.is_derived'_def gen_isCap_simps) - (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def) + (cases cap; clarsimp simp: badge_derived'_def capMasterCap_def vsCapRef_generic isCap_simps) lemma storeWordUser_vms'[Ipc_R_assms, wp]: "storeWordUser a w \valid_machine_state'\" @@ -125,7 +130,7 @@ lemma isArchObjectCap_maskCapRights[Ipc_R_assms]: by (cases acap; simp add: X64_H.maskCapRights_def isCap_simps) lemma isFrameCap_maskCapRights[simp]: - "isArchCap isFrameCap (global.maskCapRights R c) = isArchCap isFrameCap c" + "isArchCap isPageCap (global.maskCapRights R c) = isArchCap isPageCap c" apply (case_tac c; simp add: gen_isCap_simps isArchCap_def global.maskCapRights_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: isCap_simps X64_H.maskCapRights_def) @@ -135,7 +140,6 @@ lemma arch_updateCapData_ordering[Ipc_R_assms]: "\ (x, arch_capBadge acap) \ capBadge_ordering P; Arch.updateCapData p d acap \ NullCap \ \ (x, capBadge (Arch.updateCapData p d acap)) \ capBadge_ordering P" by (cases acap; simp add: X64_H.updateCapData_def) - fastforce lemma ArchUpdateCapData_noReply[Ipc_R_assms]: "Arch.updateCapData p d acap \ capability.ReplyCap x y z" @@ -146,11 +150,11 @@ lemma ArchUpdateCapData_noIRQControl[Ipc_R_assms]: by (cases acap; simp add: X64_H.updateCapData_def) lemma updateCapData_vs_cap_ref'[simp]: - "vs_cap_ref' (updateCapData pr D c) = vs_cap_ref' c" + "vsCapRef (updateCapData pr D c) = vsCapRef c" by (rule ccontr, clarsimp simp: isCap_simps global.updateCapData_def Let_def X64_H.updateCapData_def - vs_cap_ref'_def + vsCapRef_def split del: if_split split: if_split_asm arch_capability.splits) @@ -171,8 +175,9 @@ lemma badgeRegister_badge_register[Ipc_R_assms]: "badgeRegister = badge_register" by (simp add: badge_register_def badgeRegister_def) -lemmas copyMRs__pspace_in_kernel_mappings'[Ipc_R_assms, wp] = - pspace_in_kernel_mappings'_inv[where f="copyMRs _ _ _ _ _"] +crunch copyMRs + for pspace_in_kernel_mappings'[Ipc_R_assms, wp]: pspace_in_kernel_mappings' + (wp: crunch_wps simp: crunch_simps) lemma makeArchFaultMessage_corres[Ipc_R_assms]: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ @@ -219,7 +224,7 @@ lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: isCap_simps cte_level_bits_def field_simps) apply (drule bspec [OF _ ranI [where a = "4 << cteSizeBits"]]) apply (simp add: cteSizeBits_def) - apply (clarsimp simp add: valid_cap'_def frame_at'_def) + apply (clarsimp simp add: valid_cap'_def) apply (rule conjI) apply (rule aligned_add_aligned) apply (clarsimp simp add: capAligned_def) @@ -230,6 +235,7 @@ lemma lookupIPCBuffer_valid_ipc_buffer[Ipc_R_assms, wp]: apply (simp add: bit_simps msg_align_bits) apply (clarsimp simp: capAligned_def) apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize sz)) >> pageBits" in spec) + apply (subst(asm) mult.commute mult.left_commute, subst(asm) shiftl_t2n[symmetric]) apply (simp add: shiftr_shiftl1 ) apply (subst (asm) mask_out_add_aligned) apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) @@ -250,7 +256,7 @@ lemma arch_getSanitiseRegisterInfo_corres[Ipc_R_assms]: (arch_get_sanitise_register_info t) (getSanitiseRegisterInfo t)" unfolding arch_get_sanitise_register_info_def getSanitiseRegisterInfo_def - by (fold archThreadGet_def, corres) + by corres crunch getSanitiseRegisterInfo for tcb_at'[wp]: "tcb_at' t" @@ -262,7 +268,10 @@ crunch arch_get_sanitise_register_info lemma sanitiseRegister_sanitise_register[Ipc_R_assms]: "sanitiseRegister = sanitise_register" by (rule ext)+ - (clarsimp simp add: sanitiseRegister_def sanitise_register_def cong: register.case_cong) + (clarsimp simp: sanitiseRegister_def sanitise_register_def + sanitiseOrFlags_def sanitise_or_flags_def + sanitiseAndFlags_def sanitise_and_flags_def mask_def + cong: register.case_cong) lemma handleArchFaultReply_corres[Ipc_R_assms]: "corres (=) \ \ @@ -308,6 +317,11 @@ qed context Arch begin arch_global_naming +lemma isIRQControlCap_mask[simp]: + "isIOPortControlCap' (maskCapRights R c) = isIOPortControlCap' c" + by (case_tac c; + clarsimp simp: isCap_simps maskCapRights_def X64_H.maskCapRights_def Let_def) + lemma is_derived_mask'[simp]: "is_derived' m p (maskCapRights R c) = is_derived' m p c" by (rule ext, simp add: is_derived'_def badge_derived'_def) diff --git a/proof/refine/X64/ArchMove_R.thy b/proof/refine/X64/ArchMove_R.thy index 3d443a524f..f128287c33 100644 --- a/proof/refine/X64/ArchMove_R.thy +++ b/proof/refine/X64/ArchMove_R.thy @@ -180,6 +180,10 @@ lemma no_irq_invalidateTranslationSingleASID[wp]: "no_irq (invalidateTranslationSingleASID a b)" by (simp add: invalidateTranslationSingleASID_def) +(* FIXME: move, missing in Ipc_AI on this architecture *) +crunch handle_arch_fault_reply, arch_get_sanitise_register_info + for inv[Ipc_AI_2_assms]: P + end end diff --git a/proof/refine/X64/ArchTcbAcc_R.thy b/proof/refine/X64/ArchTcbAcc_R.thy index 90cae65e03..0135753561 100644 --- a/proof/refine/X64/ArchTcbAcc_R.thy +++ b/proof/refine/X64/ArchTcbAcc_R.thy @@ -449,6 +449,7 @@ lemma asUser_valid_objs[wp]: simp: valid_tcb'_def tcb_cte_cases_def valid_arch_tcb'_def cteSizeBits_def atcbContextSet_def)+ +(* interface lemma, but can't be done via locale *) lemma asUser_valid_pspace'[wp]: "\valid_pspace'\ asUser t m \\rv. valid_pspace'\" apply (simp add: asUser_def) @@ -456,11 +457,13 @@ lemma asUser_valid_pspace'[wp]: simp: atcbContextSet_def valid_arch_tcb'_def)+ done +(* interface lemma, but can't be done via locale *) lemma asUser_st_hyp_refs_of'[wp]: "asUser t m \\s. P (state_hyp_refs_of' s)\" unfolding asUser_def by (wpsimp wp: threadSet_state_hyp_refs_of' hoare_drop_imps simp: atcbContextSet_def) +(* interface lemma, but can't be done via locale *) lemma asUser_iflive'[wp]: "asUser t m \if_live_then_nonz_cap'\ " unfolding asUser_def @@ -819,9 +822,7 @@ context Arch begin arch_global_naming named_theorems TcbAcc_R_3_assms - -(* FIXME arch-split: investigate making this generic *) -lemma setMRs_corres: +lemma setMRs_corres[TcbAcc_R_3_assms]: assumes m: "mrs' = mrs" shows "corres (=) (tcb_at t and pspace_aligned and pspace_distinct and case_option \ in_user_frame buf) @@ -908,6 +909,13 @@ lemma asUser_invs[wp]: crunch storeWordUser for pred_tcb_at'[wp]: "\s. pred_tcb_at' proj P p s" +lemma set_mrs_invs'[TcbAcc_R_3_assms, wp]: + "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" + apply (simp add: setMRs_def) + apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| + simp add: zipWithM_x_mapM split_def)+ + done + lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] @@ -926,10 +934,16 @@ arch_requalify_facts asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' lemmas [wp] = asUser_valid_objs asUser_invs storeWordUser_pred_tcb_at' + asUser_valid_pspace' + asUser_st_hyp_refs_of' + asUser_iflive' end diff --git a/proof/refine/X64/ArchVSpace_R.thy b/proof/refine/X64/ArchVSpace_R.thy index 1183d0ed7b..8052d2737f 100644 --- a/proof/refine/X64/ArchVSpace_R.thy +++ b/proof/refine/X64/ArchVSpace_R.thy @@ -798,13 +798,6 @@ lemma set_cap_valid_page_map_inv: lemmas setMRs_typ_at_lifts[wp] = typ_at_lifts [OF setMRs_typ_at'] -lemma set_mrs_invs'[wp]: - "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" - apply (simp add: setMRs_def) - apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| - simp add: zipWithM_x_mapM split_def)+ - done - lemma same_refs_vs_cap_ref_eq: assumes "valid_slots entries s" assumes "same_refs entries cap s" From a5120497175eb543a7a2e9db2181152f1dd45329 Mon Sep 17 00:00:00 2001 From: Rafal Kolanski Date: Tue, 12 May 2026 16:35:30 +1000 Subject: [PATCH 7/7] crefine: update for Ipc_R arch-split Signed-off-by: Rafal Kolanski --- proof/crefine/AARCH64/Arch_C.thy | 6 ++++-- proof/crefine/AARCH64/Interrupt_C.thy | 4 ++-- proof/crefine/AARCH64/Invoke_C.thy | 1 + proof/crefine/AARCH64/Ipc_C.thy | 5 +++-- proof/crefine/AARCH64/Tcb_C.thy | 3 ++- proof/crefine/ARM/Arch_C.thy | 7 ++++--- proof/crefine/ARM/DetWP.thy | 10 ++++++---- proof/crefine/ARM/Interrupt_C.thy | 3 ++- proof/crefine/ARM/Invoke_C.thy | 1 + proof/crefine/ARM/Ipc_C.thy | 2 +- proof/crefine/ARM/Tcb_C.thy | 1 + proof/crefine/ARM_HYP/Arch_C.thy | 4 ++-- proof/crefine/ARM_HYP/DetWP.thy | 10 ++++++---- proof/crefine/ARM_HYP/Interrupt_C.thy | 3 ++- proof/crefine/ARM_HYP/Invoke_C.thy | 1 + proof/crefine/ARM_HYP/Ipc_C.thy | 11 ++++++----- proof/crefine/ARM_HYP/Tcb_C.thy | 1 + proof/crefine/RISCV64/Arch_C.thy | 4 ++-- proof/crefine/RISCV64/Interrupt_C.thy | 4 ++-- proof/crefine/RISCV64/Invoke_C.thy | 1 + proof/crefine/RISCV64/Ipc_C.thy | 7 ++++--- proof/crefine/RISCV64/Tcb_C.thy | 3 ++- proof/crefine/X64/Arch_C.thy | 7 ++++--- proof/crefine/X64/Invoke_C.thy | 1 + proof/crefine/X64/Ipc_C.thy | 9 +++++---- proof/crefine/X64/Tcb_C.thy | 3 ++- 26 files changed, 68 insertions(+), 44 deletions(-) diff --git a/proof/crefine/AARCH64/Arch_C.thy b/proof/crefine/AARCH64/Arch_C.thy index 8e0d7127b5..da7d955f20 100644 --- a/proof/crefine/AARCH64/Arch_C.thy +++ b/proof/crefine/AARCH64/Arch_C.thy @@ -898,7 +898,7 @@ lemma decodeARMPageTableInvocation_ccorres: (decodeARMMMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMPageTableInvocation_'proc)" - supply Collect_const[simp del] if_cong[cong] option.case_cong[cong] + supply Collect_const[simp del] if_cong[cong] option.case_cong[cong] tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' @@ -1828,6 +1828,7 @@ lemma decodeARMFrameInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMFrameInvocation_'proc)" (is "\ _; _ \ \ ccorres _ _ ?P _ _ _ _") + supply tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' call_' @@ -2484,6 +2485,7 @@ lemma decodeARMVSpaceRootInvocation_ccorres: (decodeARMMMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMVSpaceRootInvocation_'proc)" + supply tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_') apply (simp add: Let_def isCap_simps invocation_eq_use_types decodeARMMMUInvocation_def @@ -2702,7 +2704,7 @@ lemma decodeARMMMUInvocation_ccorres: (decodeARMMMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMMMUInvocation_'proc)" - supply ccorres_prog_only_cong[cong] + supply ccorres_prog_only_cong[cong] tl_drop_1[simp] apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' call_') apply csymbr diff --git a/proof/crefine/AARCH64/Interrupt_C.thy b/proof/crefine/AARCH64/Interrupt_C.thy index 0c551336dd..2fdaa8ee66 100644 --- a/proof/crefine/AARCH64/Interrupt_C.thy +++ b/proof/crefine/AARCH64/Interrupt_C.thy @@ -475,7 +475,7 @@ lemma Arch_decodeIRQControlInvocation_ccorres: (Arch.decodeIRQControlInvocation label args srcSlot (map fst extraCaps) >>= invocationCatch thread isBlocking isCall (InvokeIRQControl o ArchIRQControl)) (Call Arch_decodeIRQControlInvocation_'proc)" - supply maxIRQ_casts[simp] + supply maxIRQ_casts[simp] tl_drop_1[simp] supply gen_invocation_type_eq[simp] if_cong[cong] Collect_const[simp del] apply (cinit' lift: invLabel_' length___unsigned_long_' srcSlot_' current_extra_caps_' buffer_' simp: ArchInterrupt_H.AARCH64_H.decodeIRQControlInvocation_def) @@ -769,7 +769,7 @@ lemma decodeIRQControlInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeIRQControl) (Call decodeIRQControlInvocation_'proc)" supply gen_invocation_type_eq[simp] if_cong[cong] Collect_const[simp del] - supply maxIRQ_casts[simp] + supply maxIRQ_casts[simp] tl_drop_1[simp] apply (cinit' lift: invLabel_' srcSlot_' length___unsigned_long_' current_extra_caps_' buffer_') apply (simp add: decodeIRQControlInvocation_def invocation_eq_use_types cong: StateSpace.state.fold_congs globals.fold_congs) diff --git a/proof/crefine/AARCH64/Invoke_C.thy b/proof/crefine/AARCH64/Invoke_C.thy index bb842c6fef..3844b2853f 100644 --- a/proof/crefine/AARCH64/Invoke_C.thy +++ b/proof/crefine/AARCH64/Invoke_C.thy @@ -1007,6 +1007,7 @@ lemma decodeCNodeInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeCNode) (Call decodeCNodeInvocation_'proc)" supply if_cong[cong] + supply tl_drop_1[simp] apply (cases "\isCNodeCap cp") apply (simp add: decodeCNodeInvocation_def cong: conj_cong) diff --git a/proof/crefine/AARCH64/Ipc_C.thy b/proof/crefine/AARCH64/Ipc_C.thy index e20eeac5aa..de3f272185 100644 --- a/proof/crefine/AARCH64/Ipc_C.thy +++ b/proof/crefine/AARCH64/Ipc_C.thy @@ -2577,7 +2577,7 @@ lemma transferCapsLoop_ccorres: (W ep caps')" unfolding W_def check1_def check2_def split_def proof (rule ccorres_gen_asm, induct caps arbitrary: n slots mi) - note if_split[split] + note if_split[split] tl_drop_1[simp] case Nil thus ?case apply (simp only: transferCapsToSlots.simps) @@ -2812,7 +2812,8 @@ next in hoare_strengthen_postE_R) prefer 2 apply (clarsimp simp: cte_wp_at_ctes_of valid_pspace'_splits valid_pspace_canonical' - is_derived_capMasterCap image_def) + is_derived_capMasterCap image_def valid_pspace_mdb' + valid_pspace_valid_objs') apply (clarsimp split:if_splits) apply (rule conjI) apply clarsimp+ diff --git a/proof/crefine/AARCH64/Tcb_C.thy b/proof/crefine/AARCH64/Tcb_C.thy index 6543480f61..e4d2a1817d 100644 --- a/proof/crefine/AARCH64/Tcb_C.thy +++ b/proof/crefine/AARCH64/Tcb_C.thy @@ -2297,7 +2297,7 @@ lemma decodeWriteRegisters_ccorres: (decodeWriteRegisters args cp >>= invocationCatch thread isBlocking isCall InvokeTCB) (Call decodeWriteRegisters_'proc)" - supply unsigned_numeral[simp del] + supply unsigned_numeral[simp del] tl_drop_1[simp] apply (cinit' lift: cap_' length___unsigned_long_' buffer_' simp: decodeWriteRegisters_def) apply (rename_tac length' cap') apply (rule ccorres_Cond_rhs_Seq) @@ -4623,6 +4623,7 @@ lemma decodeSetFlags_ccorres: (decodeSetFlags args cp >>= invocationCatch thread isBlocking isCall InvokeTCB) (Call decodeSetFlags_'proc)" + supply tl_drop_1[simp] apply (cinit' lift: cap_' length___unsigned_long_' buffer_' call_' simp: decodeSetFlags_def ) apply csymbr+ diff --git a/proof/crefine/ARM/Arch_C.thy b/proof/crefine/ARM/Arch_C.thy index 70b0e3409a..091344a8a9 100644 --- a/proof/crefine/ARM/Arch_C.thy +++ b/proof/crefine/ARM/Arch_C.thy @@ -601,7 +601,7 @@ lemma decodeARMPageTableInvocation_ccorres: (decodeARMMMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMPageTableInvocation_'proc)" - supply if_cong[cong] + supply if_cong[cong] tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' simp: decodeARMMMUInvocation_def invocation_eq_use_types) @@ -2294,7 +2294,7 @@ lemma decodeARMFrameInvocation_ccorres: (decodeARMMMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMFrameInvocation_'proc)" - supply if_cong[cong] option.case_cong[cong] + supply if_cong[cong] option.case_cong[cong] tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' call_' simp: decodeARMMMUInvocation_def decodeARMPageFlush_def) @@ -2943,6 +2943,7 @@ lemma decodeARMPageDirectoryInvocation_ccorres: (decodeARMMMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMPageDirectoryInvocation_'proc)" + supply tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' simp: decodeARMMMUInvocation_def invocation_eq_use_types) @@ -3256,7 +3257,7 @@ lemma decodeARMMMUInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMMMUInvocation_'proc)" (is "\ ?F; _ \ \ ccorres ?r ?xf ?P (?P' slot_') [] ?a ?c") - supply if_cong[cong] + supply if_cong[cong] tl_drop_1[simp] apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' call_') apply csymbr diff --git a/proof/crefine/ARM/DetWP.thy b/proof/crefine/ARM/DetWP.thy index 57e376c2fb..4158854470 100644 --- a/proof/crefine/ARM/DetWP.thy +++ b/proof/crefine/ARM/DetWP.thy @@ -136,20 +136,22 @@ lemma det_wp_getMRs: apply (clarsimp simp: getMRs_def) apply (rule det_wp_pre) apply (wp det_mapM det_getRegister order_refl det_wp_mapM) + apply (fold word_size_bits_def) apply (simp add: word_size) apply (wp asUser_inv mapM_wp' getRegister_inv) apply clarsimp + apply (simp add: wordSize_word_size pointerInUserData_def) apply (rule conjI) - apply (simp add: pointerInUserData_def wordSize_def' word_size) apply (erule valid_ipc_buffer_ptr'D2) + apply (simp add: pointerInUserData_def word_size_def) apply (rule word_mult_less_mono1) apply (erule order_le_less_trans) apply (simp add: msgMaxLength_def max_ipc_words) apply simp apply (simp add: max_ipc_words) - apply (simp add: is_aligned_mult_triv2 [where n = 2, simplified] word_bits_conv) - apply (erule valid_ipc_buffer_ptr_aligned_2) - apply (simp add: wordSize_def' is_aligned_mult_triv2 [where n = 2, simplified] word_bits_conv) + apply (simp add: word_size_word_size_bits is_aligned_mult_triv2[where n = word_size_bits]) + apply (erule valid_ipc_buffer_ptr_aligned_word_size_bits) + apply (simp add: word_size_word_size_bits is_aligned_mult_triv2[where n = word_size_bits]) done end diff --git a/proof/crefine/ARM/Interrupt_C.thy b/proof/crefine/ARM/Interrupt_C.thy index 57f56c08f6..36ee664d25 100644 --- a/proof/crefine/ARM/Interrupt_C.thy +++ b/proof/crefine/ARM/Interrupt_C.thy @@ -543,6 +543,7 @@ lemma Arch_decodeIRQControlInvocation_ccorres: (Arch.decodeIRQControlInvocation label args slot (map fst extraCaps) >>= invocationCatch thread isBlocking isCall (InvokeIRQControl o ArchIRQControl)) (Call Arch_decodeIRQControlInvocation_'proc)" + supply tl_drop_1[simp] apply (cinit' lift: invLabel_' srcSlot_' length___unsigned_long_' current_extra_caps_' buffer_') apply (simp add: ARM_H.decodeIRQControlInvocation_def invocation_eq_use_types del: Collect_const @@ -829,7 +830,7 @@ lemma Arch_decodeIRQControlInvocation_ccorres: dest!: interpret_excaps_eq) lemma decodeIRQControlInvocation_ccorres: - notes if_cong[cong] + notes if_cong[cong] tl_drop_1[simp] shows "interpret_excaps extraCaps' = excaps_map extraCaps \ ccorres (intr_and_se_rel \ dc) (liftxf errstate id (K ()) ret__unsigned_long_') diff --git a/proof/crefine/ARM/Invoke_C.thy b/proof/crefine/ARM/Invoke_C.thy index 5eb38091be..74040a2394 100644 --- a/proof/crefine/ARM/Invoke_C.thy +++ b/proof/crefine/ARM/Invoke_C.thy @@ -1003,6 +1003,7 @@ lemma decodeCNodeInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeCNode) (Call decodeCNodeInvocation_'proc)" supply if_cong[cong] + supply tl_drop_1[simp] apply (cases "\isCNodeCap cp") apply (simp add: decodeCNodeInvocation_def cong: conj_cong) diff --git a/proof/crefine/ARM/Ipc_C.thy b/proof/crefine/ARM/Ipc_C.thy index b716137f6a..763b558963 100644 --- a/proof/crefine/ARM/Ipc_C.thy +++ b/proof/crefine/ARM/Ipc_C.thy @@ -2374,7 +2374,7 @@ lemma transferCapsLoop_ccorres: (W ep caps')" unfolding W_def check1_def check2_def split_def proof (rule ccorres_gen_asm, induct caps arbitrary: n slots mi) - note if_split[split] + note if_split[split] tl_drop_1[simp] case Nil thus ?case apply (simp only: transferCapsToSlots.simps) diff --git a/proof/crefine/ARM/Tcb_C.thy b/proof/crefine/ARM/Tcb_C.thy index 67f15b8c75..0aec541c90 100644 --- a/proof/crefine/ARM/Tcb_C.thy +++ b/proof/crefine/ARM/Tcb_C.thy @@ -4511,6 +4511,7 @@ lemma decodeSetFlags_ccorres: (decodeSetFlags args cp >>= invocationCatch thread isBlocking isCall InvokeTCB) (Call decodeSetFlags_'proc)" + supply tl_drop_1[simp] apply (cinit' lift: cap_' length___unsigned_long_' buffer_' call_' simp: decodeSetFlags_def ) apply csymbr+ diff --git a/proof/crefine/ARM_HYP/Arch_C.thy b/proof/crefine/ARM_HYP/Arch_C.thy index ece5d4d4fb..e0db4bdba8 100644 --- a/proof/crefine/ARM_HYP/Arch_C.thy +++ b/proof/crefine/ARM_HYP/Arch_C.thy @@ -643,7 +643,7 @@ lemma decodeARMPageTableInvocation_ccorres: (decodeARMMMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMPageTableInvocation_'proc)" - supply if_cong[cong] + supply if_cong[cong] tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' simp: decodeARMMMUInvocation_def invocation_eq_use_types) @@ -3663,7 +3663,7 @@ lemma decodeARMMMUInvocation_ccorres: (decodeARMMMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeARMMMUInvocation_'proc)" - supply if_cong[cong] + supply if_cong[cong] tl_drop_1[simp] apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' call_') apply csymbr diff --git a/proof/crefine/ARM_HYP/DetWP.thy b/proof/crefine/ARM_HYP/DetWP.thy index 57e376c2fb..4158854470 100644 --- a/proof/crefine/ARM_HYP/DetWP.thy +++ b/proof/crefine/ARM_HYP/DetWP.thy @@ -136,20 +136,22 @@ lemma det_wp_getMRs: apply (clarsimp simp: getMRs_def) apply (rule det_wp_pre) apply (wp det_mapM det_getRegister order_refl det_wp_mapM) + apply (fold word_size_bits_def) apply (simp add: word_size) apply (wp asUser_inv mapM_wp' getRegister_inv) apply clarsimp + apply (simp add: wordSize_word_size pointerInUserData_def) apply (rule conjI) - apply (simp add: pointerInUserData_def wordSize_def' word_size) apply (erule valid_ipc_buffer_ptr'D2) + apply (simp add: pointerInUserData_def word_size_def) apply (rule word_mult_less_mono1) apply (erule order_le_less_trans) apply (simp add: msgMaxLength_def max_ipc_words) apply simp apply (simp add: max_ipc_words) - apply (simp add: is_aligned_mult_triv2 [where n = 2, simplified] word_bits_conv) - apply (erule valid_ipc_buffer_ptr_aligned_2) - apply (simp add: wordSize_def' is_aligned_mult_triv2 [where n = 2, simplified] word_bits_conv) + apply (simp add: word_size_word_size_bits is_aligned_mult_triv2[where n = word_size_bits]) + apply (erule valid_ipc_buffer_ptr_aligned_word_size_bits) + apply (simp add: word_size_word_size_bits is_aligned_mult_triv2[where n = word_size_bits]) done end diff --git a/proof/crefine/ARM_HYP/Interrupt_C.thy b/proof/crefine/ARM_HYP/Interrupt_C.thy index bc255e18bf..44894681ed 100644 --- a/proof/crefine/ARM_HYP/Interrupt_C.thy +++ b/proof/crefine/ARM_HYP/Interrupt_C.thy @@ -504,6 +504,7 @@ lemma Arch_decodeIRQControlInvocation_ccorres: (Arch.decodeIRQControlInvocation label args slot (map fst extraCaps) >>= invocationCatch thread isBlocking isCall (InvokeIRQControl o ArchIRQControl)) (Call Arch_decodeIRQControlInvocation_'proc)" + supply tl_drop_1[simp] apply (cinit' lift: invLabel_' srcSlot_' length___unsigned_long_' current_extra_caps_' buffer_') apply (simp add: ARM_HYP_H.decodeIRQControlInvocation_def invocation_eq_use_types del: Collect_const @@ -808,7 +809,7 @@ lemma decodeIRQControlInvocation_ccorres: (decodeIRQControlInvocation label args slot (map fst extraCaps) >>= invocationCatch thread isBlocking isCall InvokeIRQControl) (Call decodeIRQControlInvocation_'proc)" - supply gen_invocation_type_eq[simp] + supply gen_invocation_type_eq[simp] tl_drop_1[simp] apply (cinit' lift: invLabel_' srcSlot_' length___unsigned_long_' current_extra_caps_' buffer_') apply (simp add: decodeIRQControlInvocation_def invocation_eq_use_types del: Collect_const diff --git a/proof/crefine/ARM_HYP/Invoke_C.thy b/proof/crefine/ARM_HYP/Invoke_C.thy index 312f1dbdad..ec404062f3 100644 --- a/proof/crefine/ARM_HYP/Invoke_C.thy +++ b/proof/crefine/ARM_HYP/Invoke_C.thy @@ -1029,6 +1029,7 @@ lemma decodeCNodeInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeCNode) (Call decodeCNodeInvocation_'proc)" supply if_cong[cong] + supply tl_drop_1[simp] apply (cases "\isCNodeCap cp") apply (simp add: decodeCNodeInvocation_def cong: conj_cong) diff --git a/proof/crefine/ARM_HYP/Ipc_C.thy b/proof/crefine/ARM_HYP/Ipc_C.thy index cbf73f2e8a..e03ee852ef 100644 --- a/proof/crefine/ARM_HYP/Ipc_C.thy +++ b/proof/crefine/ARM_HYP/Ipc_C.thy @@ -187,7 +187,7 @@ crunch getSanitiseRegisterInfo lemma empty_fail_getSanitiseRegisterInfo[wp, simp]: "empty_fail (getSanitiseRegisterInfo t)" - by (wpsimp simp: getSanitiseRegisterInfo_def2 wp: ArchMove_C.empty_fail_archThreadGet) + by (wpsimp simp: getSanitiseRegisterInfo_def wp: ArchMove_C.empty_fail_archThreadGet) lemma asUser_getRegister_getSanitiseRegisterInfo_comm: "do @@ -2294,7 +2294,8 @@ lemma doFaultTransfer_ccorres [corres]: mask_def msgLengthBits_def split: fault.split arch_fault.split) apply (wpsimp simp: setMRs_to_setMR zipWithM_mapM split_def - wp: mapM_wp' setMR_tcbFault_obj_at hoare_drop_imps)+ + wp: mapM_wp' setMR_tcbFault_obj_at)+ + apply assumption apply (clarsimp simp: obj_at'_def projectKOs) done @@ -2820,7 +2821,7 @@ lemma transferCapsLoop_ccorres: (W ep caps')" unfolding W_def check1_def check2_def split_def proof (rule ccorres_gen_asm, induct caps arbitrary: n slots mi) - note if_split[split] + note if_split[split] tl_drop_1[simp] case Nil thus ?case apply (simp only: transferCapsToSlots.simps) @@ -3712,7 +3713,7 @@ lemma replyFromKernel_error_ccorres [corres]: apply wp apply (simp add: Collect_const_mem) apply (vcg exspec=setMRs_syscall_error_modifies) - apply (wp hoare_case_option_wp) + apply (wp hoare_case_option_wp asUser_valid_ipc_buffer_ptr') apply (vcg exspec=setRegister_modifies) apply simp apply (wp lookupIPCBuffer_aligned_option_to_0) @@ -3809,7 +3810,7 @@ lemma Arch_getSanitiseRegisterInfo_ccorres: (UNIV \ {s. thread_' s = tcb_ptr_to_ctcb_ptr r}) hs (getSanitiseRegisterInfo r) (Call Arch_getSanitiseRegisterInfo_'proc)" - apply (cinit' lift: thread_' simp: getSanitiseRegisterInfo_def2) + apply (cinit' lift: thread_' simp: getSanitiseRegisterInfo_def[folded archThreadGet_def]) apply (rule ccorres_move_c_guard_tcb) apply (rule ccorres_pre_archThreadGet) apply (rule_tac P="\s. v \ Some 0" in ccorres_cross_over_guard) diff --git a/proof/crefine/ARM_HYP/Tcb_C.thy b/proof/crefine/ARM_HYP/Tcb_C.thy index 12bebbefe3..830d809364 100644 --- a/proof/crefine/ARM_HYP/Tcb_C.thy +++ b/proof/crefine/ARM_HYP/Tcb_C.thy @@ -4602,6 +4602,7 @@ lemma decodeSetFlags_ccorres: (decodeSetFlags args cp >>= invocationCatch thread isBlocking isCall InvokeTCB) (Call decodeSetFlags_'proc)" + supply tl_drop_1[simp] apply (cinit' lift: cap_' length___unsigned_long_' buffer_' call_' simp: decodeSetFlags_def ) apply csymbr+ diff --git a/proof/crefine/RISCV64/Arch_C.thy b/proof/crefine/RISCV64/Arch_C.thy index 756b4311e6..b7e3b84e04 100644 --- a/proof/crefine/RISCV64/Arch_C.thy +++ b/proof/crefine/RISCV64/Arch_C.thy @@ -765,7 +765,7 @@ lemma decodeRISCVPageTableInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeRISCVPageTableInvocation_'proc)" (is "_ \ _ \ ccorres _ _ ?pre ?pre' _ _ _") - supply Collect_const[simp del] if_cong[cong] option.case_cong[cong] + supply Collect_const[simp del] if_cong[cong] option.case_cong[cong] tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: label___unsigned_long_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' @@ -2288,7 +2288,7 @@ lemma decodeRISCVMMUInvocation_ccorres: (decodeRISCVMMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeRISCVMMUInvocation_'proc)" - supply ccorres_prog_only_cong[cong] + supply ccorres_prog_only_cong[cong] tl_drop_1[simp] apply (cinit' lift: label___unsigned_long_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' call_') apply csymbr diff --git a/proof/crefine/RISCV64/Interrupt_C.thy b/proof/crefine/RISCV64/Interrupt_C.thy index 003f997d96..80bc9e3268 100644 --- a/proof/crefine/RISCV64/Interrupt_C.thy +++ b/proof/crefine/RISCV64/Interrupt_C.thy @@ -495,7 +495,7 @@ lemma Arch_decodeIRQControlInvocation_ccorres: (Arch.decodeIRQControlInvocation label args srcSlot (map fst extraCaps) >>= invocationCatch thread isBlocking isCall (InvokeIRQControl o ArchIRQControl)) (Call Arch_decodeIRQControlInvocation_'proc)" - supply maxIRQ_casts[simp] + supply maxIRQ_casts[simp] tl_drop_1[simp] supply gen_invocation_type_eq[simp] if_cong[cong] Collect_const[simp del] apply (cinit' lift: invLabel_' length___unsigned_long_' srcSlot_' current_extra_caps_' buffer_' simp: ArchInterrupt_H.RISCV64_H.decodeIRQControlInvocation_def) @@ -670,7 +670,7 @@ lemma decodeIRQControlInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeIRQControl) (Call decodeIRQControlInvocation_'proc)" supply gen_invocation_type_eq[simp] if_cong[cong] Collect_const[simp del] - supply maxIRQ_casts[simp] + supply maxIRQ_casts[simp] tl_drop_1[simp] apply (cinit' lift: invLabel_' srcSlot_' length___unsigned_long_' current_extra_caps_' buffer_') apply (simp add: decodeIRQControlInvocation_def invocation_eq_use_types cong: StateSpace.state.fold_congs globals.fold_congs) diff --git a/proof/crefine/RISCV64/Invoke_C.thy b/proof/crefine/RISCV64/Invoke_C.thy index 1336fc38bc..870897648e 100644 --- a/proof/crefine/RISCV64/Invoke_C.thy +++ b/proof/crefine/RISCV64/Invoke_C.thy @@ -998,6 +998,7 @@ lemma decodeCNodeInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeCNode) (Call decodeCNodeInvocation_'proc)" supply if_cong[cong] + supply tl_drop_1[simp] apply (cases "\isCNodeCap cp") apply (simp add: decodeCNodeInvocation_def cong: conj_cong) diff --git a/proof/crefine/RISCV64/Ipc_C.thy b/proof/crefine/RISCV64/Ipc_C.thy index 6352766c50..941014be7a 100644 --- a/proof/crefine/RISCV64/Ipc_C.thy +++ b/proof/crefine/RISCV64/Ipc_C.thy @@ -2567,7 +2567,7 @@ lemma transferCapsLoop_ccorres: (W ep caps')" unfolding W_def check1_def check2_def split_def proof (rule ccorres_gen_asm, induct caps arbitrary: n slots mi) - note if_split[split] + note if_split[split] tl_drop_1[simp] case Nil thus ?case apply (simp only: transferCapsToSlots.simps) @@ -2801,8 +2801,9 @@ next \ cte_wp_at' (\c. fst x \ NullCap \ stable_masked (fst x) (cteCap c)) (snd x) s)" in hoare_strengthen_postE_R) prefer 2 - apply (clarsimp simp:cte_wp_at_ctes_of valid_pspace_mdb' valid_pspace'_splits - valid_pspace_valid_objs' is_derived_capMasterCap image_def) + apply (clarsimp simp: cte_wp_at_ctes_of valid_pspace_mdb' valid_pspace'_splits + valid_pspace_valid_objs' valid_pspace_canonical' + is_derived_capMasterCap image_def) apply (clarsimp split:if_splits) apply (rule conjI) apply clarsimp+ diff --git a/proof/crefine/RISCV64/Tcb_C.thy b/proof/crefine/RISCV64/Tcb_C.thy index 2a2825ab88..7de9c80e5d 100644 --- a/proof/crefine/RISCV64/Tcb_C.thy +++ b/proof/crefine/RISCV64/Tcb_C.thy @@ -2320,7 +2320,7 @@ lemma decodeWriteRegisters_ccorres: (decodeWriteRegisters args cp >>= invocationCatch thread isBlocking isCall InvokeTCB) (Call decodeWriteRegisters_'proc)" - supply unsigned_numeral[simp del] + supply unsigned_numeral[simp del] tl_drop_1[simp] apply (cinit' lift: cap_' length___unsigned_long_' buffer_' simp: decodeWriteRegisters_def) apply (rename_tac length' cap') apply (rule ccorres_Cond_rhs_Seq) @@ -4600,6 +4600,7 @@ lemma decodeSetFlags_ccorres: (decodeSetFlags args cp >>= invocationCatch thread isBlocking isCall InvokeTCB) (Call decodeSetFlags_'proc)" + supply tl_drop_1[simp] apply (cinit' lift: cap_' length___unsigned_long_' buffer_' call_' simp: decodeSetFlags_def ) apply csymbr+ diff --git a/proof/crefine/X64/Arch_C.thy b/proof/crefine/X64/Arch_C.thy index fae7bf76c4..3d43e1db7e 100644 --- a/proof/crefine/X64/Arch_C.thy +++ b/proof/crefine/X64/Arch_C.thy @@ -1011,7 +1011,7 @@ lemma decodeX64PageTableInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeX86PageTableInvocation_'proc)" (is "_ \ _ \ ccorres _ _ ?pre _ _ _ _") - supply Collect_const[simp del] if_cong[cong] + supply Collect_const[simp del] if_cong[cong] tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' simp: decodeX64MMUInvocation_def invocation_eq_use_types decodeX64PageTableInvocation_def) @@ -2983,7 +2983,7 @@ lemma decodeX64PageDirectoryInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeX64PageDirectoryInvocation_'proc)" (is "_ \ _ \ ccorres _ _ ?pre _ _ _ _") - supply Collect_const[simp del] if_cong[cong] + supply Collect_const[simp del] if_cong[cong] tl_drop_1[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: label___unsigned_long_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' simp: decodeX64MMUInvocation_def invocation_eq_use_types decodeX64PageDirectoryInvocation_def) @@ -3458,7 +3458,7 @@ lemma decodeX64PDPTInvocation_ccorres: >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeX64PDPTInvocation_'proc)" (is "_ \ _ \ ccorres _ _ ?pre ?cpre _ _ _") - supply Collect_const[simp del] if_cong[cong] + supply Collect_const[simp del] if_cong[cong] tl_drop_1[simp] from_bool_eq_if[simp] from_bool_eq_if'[simp] from_bool_0[simp] ccorres_IF_True[simp] apply (clarsimp simp only: isCap_simps) apply (cinit' lift: label___unsigned_long_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' @@ -3807,6 +3807,7 @@ lemma decodeX64MMUInvocation_ccorres: (decodeX64MMUInvocation label args cptr slot cp extraCaps >>= invocationCatch thread isBlocking isCall InvokeArchObject) (Call decodeX86MMUInvocation_'proc)" + supply tl_drop_1[simp] apply (cinit' lift: invLabel_' length___unsigned_long_' cte_' current_extra_caps_' cap_' buffer_' call_') apply csymbr diff --git a/proof/crefine/X64/Invoke_C.thy b/proof/crefine/X64/Invoke_C.thy index ca0755849e..ee00d42c27 100644 --- a/proof/crefine/X64/Invoke_C.thy +++ b/proof/crefine/X64/Invoke_C.thy @@ -1005,6 +1005,7 @@ lemma decodeCNodeInvocation_ccorres: (decodeCNodeInvocation lab args cp (map fst extraCaps) >>= invocationCatch thread isBlocking isCall InvokeCNode) (Call decodeCNodeInvocation_'proc)" + supply tl_drop_1[simp] apply (cases "\isCNodeCap cp") apply (simp add: decodeCNodeInvocation_def cong: conj_cong) diff --git a/proof/crefine/X64/Ipc_C.thy b/proof/crefine/X64/Ipc_C.thy index 6d116cf287..c9dee04781 100644 --- a/proof/crefine/X64/Ipc_C.thy +++ b/proof/crefine/X64/Ipc_C.thy @@ -2574,7 +2574,7 @@ lemma transferCapsLoop_ccorres: (W ep caps')" unfolding W_def check1_def check2_def split_def proof (rule ccorres_gen_asm, induct caps arbitrary: n slots mi) - note if_split[split] + note if_split[split] tl_drop_1[simp] case Nil thus ?case apply (simp only: transferCapsToSlots.simps) @@ -2808,8 +2808,9 @@ next \ cte_wp_at' (\c. fst x \ NullCap \ stable_masked (fst x) (cteCap c)) (snd x) s)" in hoare_strengthen_postE_R) prefer 2 - apply (clarsimp simp:cte_wp_at_ctes_of valid_pspace_mdb' valid_pspace'_splits - valid_pspace_valid_objs' is_derived_capMasterCap image_def) + apply (clarsimp simp: cte_wp_at_ctes_of valid_pspace_mdb' valid_pspace'_splits + is_derived_capMasterCap image_def + valid_pspace_valid_objs' valid_pspace_canonical') apply (clarsimp split:if_splits) apply (rule conjI) apply clarsimp+ @@ -3704,7 +3705,7 @@ lemma copyMRsFaultReply_ccorres_syscall: let ?obj_at_ft = "obj_at' (\tcb. tcbFault tcb = Some f) s" note symb_exec_r_fault = ccorres_symb_exec_r_known_rv_UNIV [where xf'=ret__unsigned_' and R="?obj_at_ft" and R'=UNIV] - note empty_fail_cond[simp] + note empty_fail_cond[simp] tl_drop_1[simp] show ?thesis apply (unfold K_def, rule ccorres_gen_asm) using [[goals_limit=1]] apply (cinit' lift: sender_' receiver_' diff --git a/proof/crefine/X64/Tcb_C.thy b/proof/crefine/X64/Tcb_C.thy index 20a1c9319f..ee35fa83d8 100644 --- a/proof/crefine/X64/Tcb_C.thy +++ b/proof/crefine/X64/Tcb_C.thy @@ -2321,7 +2321,7 @@ lemma decodeWriteRegisters_ccorres: (decodeWriteRegisters args cp >>= invocationCatch thread isBlocking isCall InvokeTCB) (Call decodeWriteRegisters_'proc)" - supply unsigned_numeral[simp del] + supply unsigned_numeral[simp del] tl_drop_1[simp] apply (cinit' lift: cap_' length___unsigned_long_' buffer_' simp: decodeWriteRegisters_def) apply (rename_tac length' cap') apply (rule ccorres_Cond_rhs_Seq) @@ -4642,6 +4642,7 @@ lemma decodeSetFlags_ccorres: (decodeSetFlags args cp >>= invocationCatch thread isBlocking isCall InvokeTCB) (Call decodeSetFlags_'proc)" + supply tl_drop_1[simp] apply (cinit' lift: cap_' length___unsigned_long_' buffer_' call_' simp: decodeSetFlags_def ) apply csymbr+