diff --git a/lib/Lib.thy b/lib/Lib.thy index a3b1110041..7f9826ea8e 100644 --- a/lib/Lib.thy +++ b/lib/Lib.thy @@ -2269,6 +2269,16 @@ lemma in_set_zip2: "(x, y) \ set (zip xs ys) \ y \ set ys" by (erule in_set_zipE) +lemma in_set_zipD: + "t \ set (zip xs ys) \ fst t \ set xs \ snd t \ set ys" + by (clarsimp simp add: set_zip) + +lemma set_map_fst_filter_zip: + "set (map fst (filter P (zip xs ys))) \ set xs" + apply (induct xs, simp) + apply (case_tac ys; simp) + by (metis (mono_tags, lifting) image_Collect_subsetI insertI2 in_set_zipD) + lemma map_zip_snd_take: "map (\(x, y). f y) (zip xs ys) = map f (take (length xs) ys)" apply (subst map_zip_snd' [symmetric, where xs=xs and ys="take (length xs) ys"], simp) diff --git a/lib/Monad_Lists.thy b/lib/Monad_Lists.thy index 832f7bb9bb..f2cbcf942b 100644 --- a/lib/Monad_Lists.thy +++ b/lib/Monad_Lists.thy @@ -512,6 +512,33 @@ lemma mapM_wp': apply simp done +lemma mapM_gets_the_wp: + "\\s. \vs. map (\t. f t s) ts = map Some vs \ P vs s\ + mapM (gets_the \ f) ts + \P\" + unfolding comp_def +proof (induct ts arbitrary: P) + case Nil thus ?case by (wpsimp simp: mapM_Nil) +next + case (Cons x xs) show ?case by (wpsimp simp: mapM_Cons wp: Cons) +qed + +lemma mapM_gets_the_wp_nth: + "\\s. \vs. (\i < length vs. f (ts ! i) s = Some (vs ! i)) \ P vs s\ + mapM (gets_the \ f) ts + \P\" + apply (wpsimp wp: mapM_gets_the_wp) + by (simp add: map_equality_iff) + +lemma mapM_gets_the_sp: + "\P\ mapM (gets_the \ f) ts \\rv s. P s \ map (\t. f t s) ts = map Some rv\" + by (wpsimp wp: mapM_gets_the_wp simp: comp_def) + +lemma mapM_gets_the_sp_nth: + "\P\ mapM (gets_the \ f) ts \\rv s. P s \ (\i < length rv. f (ts ! i) s = Some (rv ! i))\" + apply (wpsimp wp: mapM_gets_the_wp simp: comp_def) + by (simp add: map_equality_iff) + lemma mapM_set: assumes "\x. x \ set xs \ \P\ f x \\_. P\" assumes "\x. x \ set xs \ \P\ f x \\_. Q x\" diff --git a/lib/Monads/reader_option/Reader_Option_Monad.thy b/lib/Monads/reader_option/Reader_Option_Monad.thy index cf03b2c3b2..c1780e45e2 100644 --- a/lib/Monads/reader_option/Reader_Option_Monad.thy +++ b/lib/Monads/reader_option/Reader_Option_Monad.thy @@ -29,7 +29,7 @@ definition opt_map :: "('s,'a) lookup \ ('a \ 'b option) "f |> g \ \s. case f s of None \ None | Some x \ g x" abbreviation opt_map_Some :: "('s \ 'a) \ ('a \ 'b) \ 's \ 'b" (infixl "||>" 54) where - "f ||> g \ f |> (Some \ g)" + "f ||> g \ f |> (\s. Some (g s))" lemmas opt_map_Some_def = opt_map_def @@ -118,7 +118,7 @@ lemma opt_map_Some_foldr_upd: lemmas opt_map_foldr_upd_simps = opt_map_foldr_upd opt_map_Some_foldr_upd -lemma opt_map_Some_comp[simp]: +lemma opt_map_Some_comp: "f ||> g ||> h = f ||> h o g" by (fastforce simp: opt_map_def split: option.split) @@ -143,10 +143,6 @@ lemma opt_map_zero_r[simp]: "f |> Map.empty = Map.empty" by (fastforce simp: opt_map_def split: option.split) -lemma opt_map_Some_eta_fold: - "f |> (\x. Some (g x)) = f ||> g" - by (simp add: o_def) - lemma case_opt_map_distrib: "(\s. case_option None g (f s)) |> h = (\s. case_option None (g |> h) (f s))" by (fastforce simp: opt_map_def split: option.splits) diff --git a/proof/access-control/Syscall_AC.thy b/proof/access-control/Syscall_AC.thy index ad13ff9fb8..e97d307af4 100644 --- a/proof/access-control/Syscall_AC.thy +++ b/proof/access-control/Syscall_AC.thy @@ -976,7 +976,7 @@ crunch_ignore (add: cap_swap_ext cap_move_ext cap_insert_ext create_cap_ext set_ lemma zet_zip_contrapos: "fst t \ set xs \ t \ set (zip xs ys)" - by (auto simp: set_zip_helper) + by (auto simp: in_set_zipD) lemma ct_active_update[simp]: "ct_active (s\cdt := b\) = ct_active s" diff --git a/proof/crefine/AARCH64/Retype_C.thy b/proof/crefine/AARCH64/Retype_C.thy index 0916051c60..1dc37d6ca0 100644 --- a/proof/crefine/AARCH64/Retype_C.thy +++ b/proof/crefine/AARCH64/Retype_C.thy @@ -7301,7 +7301,7 @@ lemma ccorres_typ_region_bytes_dummy: apply (simp add: hrs_htd_update gsCNodes_typ_region_bytes cnodes_retype_have_size_mono[where T=S] tcb_ctes_typ_region_bytes[OF _ _ invs_pspace_aligned'] - pte_typ_region_bytes o_def) + pte_typ_region_bytes) (* True for either version of config_ARM_PA_SIZE_BITS_40 with corresponding max vm level change *) apply (simp add: cmap_array_typ_region_bytes_triv invs_pspace_aligned' bit_simps objBitsT_simps word_bits_def zero_ranges_are_zero_typ_region_bytes @@ -8005,7 +8005,7 @@ crunch placeNewDataObject for ksArchState[wp]: "\s. P (ksArchState s)" (simp: crunch_simps) -lemma createObject_cnodes_have_size_pt[unfolded o_def]: +lemma createObject_cnodes_have_size_pt: "\\s. is_aligned ptr (APIType_capBits newType userSize) \ cnodes_retype_have_size R (APIType_capBits newType userSize) (gsPTTypes (ksArchState s) ||> (\pt_t. pt_bits pt_t - cte_level_bits))\ createObject newType ptr userSize dev @@ -8014,8 +8014,7 @@ lemma createObject_cnodes_have_size_pt[unfolded o_def]: apply (simp add: createObject_def) apply (rule hoare_pre) apply (wp mapM_x_wp' | wpc | simp add: createObjects_def AARCH64_H.createObject_def updatePTType_def)+ - apply (cases newType, simp_all add: AARCH64_H.toAPIType_def o_def) - apply (rule conjI, clarsimp)+ + apply (cases newType, simp_all add: AARCH64_H.toAPIType_def) apply clarsimp supply fun_upd_def[symmetric, simp del] fun_upd_apply[simp] apply (clarsimp simp: APIType_capBits_def cnodes_retype_have_size_def bit_simps cte_level_bits_def diff --git a/proof/crefine/ARM_HYP/Arch_C.thy b/proof/crefine/ARM_HYP/Arch_C.thy index 0ead82e81a..9cc8df1e92 100644 --- a/proof/crefine/ARM_HYP/Arch_C.thy +++ b/proof/crefine/ARM_HYP/Arch_C.thy @@ -2102,7 +2102,7 @@ lemma performPageInvocationMapPDE_ccorres: apply (simp add: typ_at_to_obj_at_arches[symmetric]) apply ((wp mapM_x_storePDE_pde_mappings' mapM_x_wp' valid_pde_slots_lift2 | simp add: split_def)+)[2] apply (clarsimp simp: valid_pde_mapping'_def valid_pde_slots'2_def) - apply (drule set_zip_helper, clarsimp) + apply (drule in_set_zipD, clarsimp) apply clarsimp apply (simp add: typ_at_to_obj_at_arches) apply (frule bspec, erule hd_in_zip_set) diff --git a/proof/crefine/RISCV64/IpcCancel_C.thy b/proof/crefine/RISCV64/IpcCancel_C.thy index 567f1b5588..dfe7e847f8 100644 --- a/proof/crefine/RISCV64/IpcCancel_C.thy +++ b/proof/crefine/RISCV64/IpcCancel_C.thy @@ -164,7 +164,8 @@ lemma ntfn_ptr_set_queue_spec: lemma cancelSignal_ccorres_helper: "ccorres dc xfdc (invs' and (\s. sym_refs (state_refs_of' s)) - and st_tcb_at' ((=) (BlockedOnNotification ntfn)) thread and ko_at' ntfn' ntfn) + and st_tcb_at' ((=) (BlockedOnNotification ntfn)) thread and ko_at' ntfn' ntfn + and K (distinct (ntfnQueue (ntfnObj ntfn')))) UNIV [] (setNotification ntfn (ntfnObj_update @@ -2472,7 +2473,7 @@ lemma cancelSignal_ccorres[corres]: apply (simp only: simp_list_case_return return_bind ccorres_seq_skip) apply (rule ccorres_stateAssert)+ apply (rule ccorres_pre_getNotification) - apply (rule ccorres_assert) + apply (rule ccorres_assert2)+ apply (rule ccorres_rhs_assoc2)+ apply (ctac (no_vcg) add: cancelSignal_ccorres_helper) apply (ctac add: setThreadState_ccorres) @@ -2552,11 +2553,11 @@ lemma ep_ptr_set_queue_spec: oops lemma valid_ep_blockedD: - "\ valid_ep' ep s; (isSendEP ep \ isRecvEP ep) \ \ (epQueue ep) \ [] \ (\t\set (epQueue ep). tcb_at' t s) \ distinct (epQueue ep)" + "\ valid_ep' ep s; isSendEP ep \ isRecvEP ep \ + \ epQueue ep \ [] \ (\t\set (epQueue ep). tcb_at' t s)" unfolding valid_ep'_def isSendEP_def isRecvEP_def by (clarsimp split: endpoint.splits) - lemma ep_to_ep_queue: assumes ko: "ko_at' ep' ep s" and waiting: "(isSendEP ep' \ isRecvEP ep')" @@ -2742,7 +2743,7 @@ lemma cancelIPC_ccorres_helper: "ccorres dc xfdc (invs' and (\s. sym_refs (state_refs_of' s)) and st_tcb_at' (\st. (isBlockedOnSend st \ isBlockedOnReceive st) \ blockingObject st = ep) thread - and ko_at' ep' ep) + and ko_at' ep' ep and K (distinct (epQueue ep'))) {s. epptr_' s = Ptr ep} [] (setEndpoint ep (if remove1 thread (epQueue ep') = [] then Structures_H.endpoint.IdleEP diff --git a/proof/crefine/RISCV64/Ipc_C.thy b/proof/crefine/RISCV64/Ipc_C.thy index 5caf1bad09..f97df4a5ed 100644 --- a/proof/crefine/RISCV64/Ipc_C.thy +++ b/proof/crefine/RISCV64/Ipc_C.thy @@ -4467,21 +4467,22 @@ lemma ccorres_getCTE_cte_at: done lemma sendIPC_dequeue_ccorres_helper: - "ep_ptr = Ptr ep ==> - ccorres (\rv rv'. rv' = tcb_ptr_to_ctcb_ptr dest) dest___ptr_to_struct_tcb_C_' - (invs' and (\s. sym_refs (state_refs_of' s)) - and st_tcb_at' (\st. isBlockedOnReceive st \ - blockingObject st = ep) dest - and ko_at' (RecvEP (dest#rest)) ep) UNIV hs - (setEndpoint ep $ case rest of [] \ Structures_H.IdleEP - | (a#list) \ Structures_H.RecvEP rest) - (\queue :== CALL ep_ptr_get_queue(ep_ptr);; - \dest___ptr_to_struct_tcb_C :== head_C \queue;; - \queue :== CALL tcbEPDequeue(\dest___ptr_to_struct_tcb_C,\queue);; - CALL ep_ptr_set_queue(ep_ptr,\queue);; - IF head_C \queue = Ptr 0 THEN - CALL endpoint_ptr_set_state(ep_ptr,scast EPState_Idle) - FI)" + "ep_ptr = Ptr ep \ + ccorres (\rv rv'. rv' = tcb_ptr_to_ctcb_ptr dest) dest___ptr_to_struct_tcb_C_' + (invs' and (\s. sym_refs (state_refs_of' s)) + and st_tcb_at' (\st. isBlockedOnReceive st \ blockingObject st = ep) dest + and ko_at' (RecvEP (dest#rest)) ep + and K (distinct (dest # rest))) + UNIV hs + (setEndpoint ep $ case rest of [] \ Structures_H.IdleEP + | (a#list) \ Structures_H.RecvEP rest) + (\queue :== CALL ep_ptr_get_queue(ep_ptr);; + \dest___ptr_to_struct_tcb_C :== head_C \queue;; + \queue :== CALL tcbEPDequeue(\dest___ptr_to_struct_tcb_C,\queue);; + CALL ep_ptr_set_queue(ep_ptr,\queue);; + IF head_C \queue = Ptr 0 THEN + CALL endpoint_ptr_set_state(ep_ptr,scast EPState_Idle) + FI)" apply (rule ccorres_from_vcg) apply (rule allI) apply (rule conseqPre, vcg) @@ -4503,6 +4504,7 @@ lemma sendIPC_dequeue_ccorres_helper: apply (rule_tac x=\ in exI) apply (intro conjI) apply assumption+ + apply fastforce apply (drule (2) ep_to_ep_queue) apply (simp add: tcb_queue_relation'_def) apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def @@ -4852,7 +4854,7 @@ lemma sendIPC_enqueue_ccorres_helper: and ko_at' (ep::Structures_H.endpoint) epptr and K ((ep = IdleEP \ queue = [thread]) \ (\q. ep = SendEP q \ thread \ set q \ - queue = q @ [thread]))) + queue = q @ [thread] \ distinct q))) UNIV hs (setEndpoint epptr (Structures_H.endpoint.SendEP queue)) (\queue :== CALL ep_ptr_get_queue(ep_Ptr epptr);; @@ -5379,7 +5381,7 @@ lemma receiveIPC_enqueue_ccorres_helper: and ko_at' (ep::Structures_H.endpoint) epptr and K ((ep = IdleEP \ queue = [thread]) \ (\q. ep = RecvEP q \ thread \ set q \ - queue = q @ [thread]))) + queue = q @ [thread] \ distinct q))) UNIV hs (setEndpoint epptr (Structures_H.endpoint.RecvEP queue)) (\queue :== CALL ep_ptr_get_queue(ep_Ptr epptr);; @@ -5522,7 +5524,9 @@ lemma receiveIPC_dequeue_ccorres_helper: (invs' and (\s. sym_refs (state_refs_of' s)) and st_tcb_at' (\st. isBlockedOnSend st \ blockingObject st = ep) sender - and ko_at' (SendEP (sender#rest)) ep) UNIV hs + and ko_at' (SendEP (sender # rest)) ep + and K (distinct (sender # rest))) + UNIV hs (setEndpoint ep (case rest of [] \ Structures_H.IdleEP | (a#list) \ Structures_H.SendEP rest)) (\queue :== CALL ep_ptr_get_queue(Ptr ep);; @@ -5553,6 +5557,7 @@ lemma receiveIPC_dequeue_ccorres_helper: apply (rule_tac x=\ in exI) apply (intro conjI) apply assumption+ + apply fastforce apply (drule (2) ep_to_ep_queue) apply (simp add: tcb_queue_relation'_def) apply (clarsimp simp: typ_heap_simps cendpoint_relation_def Let_def @@ -6085,7 +6090,8 @@ lemma sendSignal_dequeue_ccorres_helper: (invs' and (\s. sym_refs (state_refs_of' s)) and st_tcb_at' ((=) (BlockedOnNotification ntfn)) dest and ko_at' nTFN ntfn - and K (ntfnObj nTFN = WaitingNtfn (dest # rest))) UNIV hs + and K (ntfnObj nTFN = WaitingNtfn (dest # rest)) and K (distinct (dest # rest))) + UNIV hs (setNotification ntfn $ ntfnObj_update (\_. case rest of [] \ Structures_H.ntfn.IdleNtfn | (a#list) \ Structures_H.ntfn.WaitingNtfn rest) nTFN) (\ntfn_queue :== CALL ntfn_ptr_get_queue(Ptr ntfn);; @@ -6516,7 +6522,7 @@ lemma receiveSignal_enqueue_ccorres_helper: and ko_at' (ntfn::Structures_H.notification) ntfnptr and K ((ntfnObj ntfn = IdleNtfn \ queue = [thread]) \ (\q. ntfnObj ntfn = WaitingNtfn q \ thread \ set q \ - queue = q @ [thread]))) + queue = q @ [thread] \ distinct q))) UNIV hs (setNotification ntfnptr $ ntfnObj_update (\_. Structures_H.WaitingNtfn queue) ntfn) (\ntfn_queue :== CALL ntfn_ptr_get_queue(ntfn_Ptr ntfnptr);; diff --git a/proof/crefine/RISCV64/Recycle_C.thy b/proof/crefine/RISCV64/Recycle_C.thy index 9e156bf41e..921bb97ca0 100644 --- a/proof/crefine/RISCV64/Recycle_C.thy +++ b/proof/crefine/RISCV64/Recycle_C.thy @@ -934,6 +934,7 @@ lemma cancelBadgedSends_ccorres: apply (rule ccorres_return_Skip) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_return_Skip) + apply (rule ccorres_assert2) apply (rename_tac list) apply (simp add: Collect_True Collect_False endpoint_state_defs ccorres_cond_iffs @@ -964,6 +965,7 @@ lemma cancelBadgedSends_ccorres: subgoal by simp apply (simp add: refill_buffer_relation_def image_def dom_def Let_def typ_heap_simps update_ep_map_tos) + apply (thin_tac "distinct _") apply (rule ccorres_symb_exec_r) apply (rule_tac xs=list in filterM_voodoo) apply (rule_tac P="\xs s. (\x \ set xs \ set list. diff --git a/proof/crefine/RISCV64/SR_lemmas_C.thy b/proof/crefine/RISCV64/SR_lemmas_C.thy index 47004f01b8..54ac841e2d 100644 --- a/proof/crefine/RISCV64/SR_lemmas_C.thy +++ b/proof/crefine/RISCV64/SR_lemmas_C.thy @@ -1212,8 +1212,7 @@ lemma ntfn_blocked_in_queueD: (* MOVE *) lemma valid_ntfn_isWaitingNtfnD: "\ valid_ntfn' ntfn s; isWaitingNtfn (ntfnObj ntfn) \ - \ (ntfnQueue (ntfnObj ntfn)) \ [] \ (\t\set (ntfnQueue (ntfnObj ntfn)). tcb_at' t s) - \ distinct (ntfnQueue (ntfnObj ntfn))" + \ ntfnQueue (ntfnObj ntfn) \ [] \ (\t\set (ntfnQueue (ntfnObj ntfn)). tcb_at' t s)" unfolding valid_ntfn'_def isWaitingNtfn_def by (clarsimp split: Structures_H.notification.splits ntfn.splits) diff --git a/proof/invariant-abstract/ARM/ArchArch_AI.thy b/proof/invariant-abstract/ARM/ArchArch_AI.thy index 89132a5352..95f36226ae 100644 --- a/proof/invariant-abstract/ARM/ArchArch_AI.thy +++ b/proof/invariant-abstract/ARM/ArchArch_AI.thy @@ -192,7 +192,7 @@ lemmas perform_asid_pool_invocation_typ_ats [wp] = lemma perform_asid_control_invocation_tcb_at: - "\invs and valid_aci aci and st_tcb_at active p and + "\invs and valid_aci aci and tcb_at p and ex_nonz_cap_to p and K (\w a b c. aci = asid_control_invocation.MakePool w a b c \ w \ p)\ perform_asid_control_invocation aci \\rv. tcb_at p\" @@ -204,10 +204,6 @@ lemma perform_asid_control_invocation_tcb_at: apply (intro impI conjI) apply (clarsimp simp: retype_addrs_def obj_bits_api_def default_arch_object_def image_def ptr_add_def) apply (clarsimp simp: st_tcb_at_tcb_at)+ - apply (frule st_tcb_ex_cap) - apply fastforce - apply (clarsimp split: Structures_A.thread_state.splits) - apply auto[1] apply (clarsimp simp: ex_nonz_cap_to_def valid_aci_def) apply (frule invs_untyped_children) apply (clarsimp simp:cte_wp_at_caps_of_state) @@ -250,9 +246,10 @@ lemma invoke_arch_tcb: apply fastforce apply (clarsimp split: Structures_A.thread_state.splits) apply auto[1] - apply (clarsimp simp: ex_nonz_cap_to_def) + apply (frule st_tcb_at_tcb_at) + apply clarsimp apply (frule invs_untyped_children) - apply (clarsimp simp:cte_wp_at_caps_of_state) + apply (clarsimp simp: ex_nonz_cap_to_def cte_wp_at_caps_of_state) apply (erule_tac ptr="(aa,ba)" in untyped_children_in_mdbE[where P="\c. t \ zobj_refs c" for t]) apply (simp add: cte_wp_at_caps_of_state)+ apply fastforce diff --git a/proof/invariant-abstract/ARM/ArchDetSchedAux_AI.thy b/proof/invariant-abstract/ARM/ArchDetSchedAux_AI.thy index 1ab432c4d3..51b30f2314 100644 --- a/proof/invariant-abstract/ARM/ArchDetSchedAux_AI.thy +++ b/proof/invariant-abstract/ARM/ArchDetSchedAux_AI.thy @@ -16,27 +16,91 @@ lemmas arch_machine_ops_valid_sched_pred[wp] = arch_machine_ops_last_machine_time[THEN dmo_valid_sched_pred] arch_machine_ops_last_machine_time[THEN dmo_valid_sched_pred'] +lemma set_pt_eps_of[wp]: + "set_pt ptr pt \\s. P (eps_of s)\" + by (set_object_easy_cases def: set_pt_def) + +lemma set_pd_eps_of[wp]: + "set_pd ptr pd \\s. P (eps_of s)\" + by (set_object_easy_cases def: set_pd_def) + +lemma set_pt_ntfns_of[wp]: + "set_pt ptr pt \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: set_pt_def) + +lemma set_pd_ntfns_of[wp]: + "set_pd ptr pd \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: set_pd_def) + +lemma set_pt_tcbs_of[wp]: + "set_pt ptr pt \\s. P (tcbs_of s)\" + by (set_object_easy_cases def: set_pt_def) + +lemma set_pd_tcbs_of[wp]: + "set_pd ptr pd \\s. P (tcbs_of s)\" + by (set_object_easy_cases def: set_pd_def) + lemma set_pd_valid_sched_pred[wp]: "set_pd ptr pd \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ntfns_of, rotated], wpsimp) apply (wpsimp simp: set_pd_def wp: set_object_wp_strong get_object_wp) - by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def fun_upd_def - split: kernel_object.splits if_splits) + apply (fastforce simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def + split: kernel_object.splits if_splits) + done lemma set_pt_valid_sched_pred[wp]: "set_pt ptr pt \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ntfns_of, rotated], wpsimp) apply (wpsimp simp: set_pt_def wp: set_object_wp_strong get_object_wp) - by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def fun_upd_def - split: kernel_object.splits if_splits) + apply (fastforce simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def + split: kernel_object.splits if_splits) + done + +lemma set_asid_pool_eps_of[wp]: + "set_asid_pool ptr pool \\s. P (eps_of s)\" + by (set_object_easy_cases def: set_asid_pool_def) + +lemma set_asid_pool_ntfns_of[wp]: + "set_asid_pool ptr pool \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: set_asid_pool_def) + +lemma set_asid_pool_tcbs_of[wp]: + "set_asid_pool ptr pool \\s. P (tcbs_of s)\" + by (set_object_easy_cases def: set_asid_pool_def) lemma set_asid_pool_bound_sc_obj_tcb_at[wp]: "set_asid_pool ptr pool \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ntfns_of, rotated], wpsimp) apply (wpsimp simp: set_asid_pool_def wp: set_object_wp_strong get_object_wp) - by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def fun_upd_def - split: kernel_object.splits if_splits) + apply (fastforce simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def + split: kernel_object.splits if_splits) + done + +crunch copy_global_mappings + for eps_of[wp]: "\s. P (eps_of s)" + and ntfns_of[wp]: "\s. P (ntfns_of s)" + and prios_of[wp]: "\s. P (prios_of s)" + (wp: dxo_wp_weak crunch_wps) lemma copy_global_mappings_valid_sched_pred[wp]: "copy_global_mappings pd \valid_sched_pred_strong P\" - by (wpsimp simp: copy_global_mappings_def store_pde_def wp: mapM_x_wp_inv) + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (wpsimp simp: copy_global_mappings_def store_pte_def store_pde_def wp: mapM_x_wp_inv) + done lemma init_arch_objects_valid_sched_pred[wp, DetSchedAux_AI_assms]: "init_arch_objects new_type dev ptr num_objects obj_sz refs \valid_sched_pred_strong P\" @@ -251,6 +315,32 @@ lemma perform_asid_control_invocation_sc_at_pred_n_live: unfolding sc_at_pred_n_def using live by (auto intro!: perform_asid_control_invocation_obj_at_live simp: cspace_agnostic_pred_def live_def) +lemma perform_asid_control_invocation_ep_at_pred_live: + assumes live: "\ep. P ep \ ep \ IdleEP" + shows + "\\s. Q (ep_at_pred P p s) + \ invs s + \ ct_active s + \ valid_aci aci s + \ scheduler_action s = resume_cur_thread\ + perform_asid_control_invocation aci + \\rv s. Q (ep_at_pred P p s)\" + unfolding ep_at_pred_def2 using live + by (auto intro!: perform_asid_control_invocation_obj_at_live simp: cspace_agnostic_pred_def live_def) + +lemma perform_asid_control_invocation_ntfn_at_pred_live: + assumes live: "\ntfn. P ntfn \ live_ntfn ntfn" + shows + "\\s. Q (ntfn_at_pred P p s) + \ invs s + \ ct_active s + \ valid_aci aci s + \ scheduler_action s = resume_cur_thread\ + perform_asid_control_invocation aci + \\rv s. Q (ntfn_at_pred P p s)\" + unfolding ntfn_at_pred_def2 using live + by (auto intro!: perform_asid_control_invocation_obj_at_live simp: cspace_agnostic_pred_def live_def) + lemma perform_asid_control_invocation_valid_idle: "\invs and ct_active and valid_aci aci @@ -302,18 +392,22 @@ lemma perform_asid_control_invocation_valid_sched: apply (rule_tac I="invs and ct_active and (\s. scheduler_action s = resume_cur_thread) and valid_aci aci" in valid_sched_tcb_state_preservation_gen) - apply simp - apply (wpsimp wp: perform_asid_control_invocation_st_tcb_at - perform_asid_control_invocation_pred_tcb_at_live - perform_asid_control_invocation_sc_at_pred_n_live[where Q="Not"] - perform_asid_control_etcb_at - perform_asid_control_invocation_sc_at_pred_n - perform_asid_control_invocation_valid_idle - perform_asid_control_invocation_pred_map_sc_refill_cfgs_of - perform_asid_control_invocation_implies_zero_budget - perform_asid_control_invocation_sporadic_implies - hoare_vcg_all_lift - simp: ipc_queued_thread_state_live live_sc_def)+ + apply simp + apply (wpsimp wp: perform_asid_control_invocation_st_tcb_at + perform_asid_control_invocation_pred_tcb_at_live + perform_asid_control_invocation_sc_at_pred_n_live[where Q="Not"] + perform_asid_control_etcb_at + perform_asid_control_invocation_sc_at_pred_n + perform_asid_control_invocation_valid_idle + perform_asid_control_invocation_pred_map_sc_refill_cfgs_of + perform_asid_control_invocation_implies_zero_budget + perform_asid_control_invocation_sporadic_implies + perform_asid_control_invocation_ep_at_pred_live + perform_asid_control_invocation_ntfn_at_pred_live + hoare_vcg_all_lift + simp: ipc_queued_thread_state_live live_sc_def + ntfn_queue_nonempty_live + tcb_at_st_tcb_at)+ done lemma perform_asid_control_invocation_cur_sc_active: diff --git a/proof/invariant-abstract/ARM/ArchDetSchedSchedule_AI.thy b/proof/invariant-abstract/ARM/ArchDetSchedSchedule_AI.thy index 6c59a3001d..ed0a1bf320 100644 --- a/proof/invariant-abstract/ARM/ArchDetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/ARM/ArchDetSchedSchedule_AI.thy @@ -57,14 +57,15 @@ lemma misc_dmo_valid_sched_pred_strong[wp]: apply (wpsimp wp: dmo_valid_sched_pred )+ done -crunch arch_switch_to_thread, - arch_switch_to_idle_thread, - arch_finalise_cap, - arch_invoke_irq_control, - handle_vm_fault +crunch arch_switch_to_thread, arch_switch_to_idle_thread, arch_finalise_cap, + arch_invoke_irq_control for valid_sched_pred_strong[wp, DetSchedSchedule_AI_assms]: "valid_sched_pred_strong P" (wp: dmo_valid_sched_pred crunch_wps simp: crunch_simps) +lemma handle_vm_fault_valid_sched_pred_strong[wp, DetSchedSchedule_AI_assms]: + "handle_vm_fault thread fault_type \valid_sched_pred_strong P\" + by (wp dmo_valid_sched_pred | simp add: Let_def | cases fault_type)+ + crunch perform_page_table_invocation, perform_page_directory_invocation, perform_page_invocation, perform_asid_pool_invocation diff --git a/proof/invariant-abstract/ARM/ArchSyscall_AI.thy b/proof/invariant-abstract/ARM/ArchSyscall_AI.thy index 63203958a6..eca4a65e04 100644 --- a/proof/invariant-abstract/ARM/ArchSyscall_AI.thy +++ b/proof/invariant-abstract/ARM/ArchSyscall_AI.thy @@ -32,6 +32,8 @@ crunch handle_arch_fault_reply, arch_get_sanitise_register_info for cur_thread[wp,Syscall_AI_assms]: "\s. P (cur_thread s)" crunch handle_arch_fault_reply, arch_get_sanitise_register_info for valid_objs[wp,Syscall_AI_assms]: "valid_objs" +crunch handle_arch_fault_reply, arch_get_sanitise_register_info + for valid_mdb[wp,Syscall_AI_assms]: valid_mdb crunch handle_arch_fault_reply, arch_get_sanitise_register_info for cte_wp_at[wp,Syscall_AI_assms]: "\s. P (cte_wp_at P' p s)" (* make_fault_message_inv[Syscall_AI_assms] *) diff --git a/proof/invariant-abstract/DetSchedAux_AI.thy b/proof/invariant-abstract/DetSchedAux_AI.thy index cdb7a7cab0..a709bb0b24 100644 --- a/proof/invariant-abstract/DetSchedAux_AI.thy +++ b/proof/invariant-abstract/DetSchedAux_AI.thy @@ -19,15 +19,59 @@ lemmas [wp] = init_arch_objects_pred_tcb_at init_arch_objects_cur_thread +method set_object_easy_cases uses def final + = simp add: def set_object_def split_def, + (wp get_object_wp zipWithM_x_inv' | wp (once) hoare_drop_imp | wpc)+, + (fastforce simp: final obj_at_def opt_map_def eps_of_kh_def tcbs_of_kh_def a_type_def + intro: rsubst[where P=P] + split: kernel_object.splits)? + +lemma set_cap_eps_of[wp]: + "set_cap c p \\s. P (eps_of s)\" + by (set_object_easy_cases def: set_cap_def) + +lemma set_cap_ntfns_of[wp]: + "set_cap c p \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: set_cap_def) + +lemma set_cap_prios_of[wp]: + "set_cap c p \\s. P (prios_of s)\" + by (set_object_easy_cases def: set_cap_def) + lemma set_cap_valid_sched_pred[wp]: "set_cap cap slot \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ntfns_of, rotated], wpsimp) by (wpsimp simp: set_cap_def obj_at_kh_kheap_simps vs_all_heap_simps wp: set_object_wp get_object_wp) -crunch create_cap, cap_insert +crunch cap_insert for valid_sched_pred[wp]: "valid_sched_pred_strong P::'z::state_ext state \ _" (wp: dxo_wp_weak crunch_wps) +crunch create_cap + for eps_of[wp]: "\s. P (eps_of s)" + and ntfns_of[wp]: "\s. P (ntfns_of s)" + and cur_time[wp]: "\s. P (cur_time s)" + (wp: dxo_wp_weak crunch_wps) + +lemma create_cap_prios_of[wp]: + "create_cap type bits untyped is_device dest \\s. P (prios_of s)\" + apply (simp add: create_cap_def set_object_def split_def) + by (wpsimp wp: get_object_wp dxo_wp_weak | fastforce)+ + +lemma create_cap_valid_sched_pred[wp]: + "create_cap type bits untyped is_device dest \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (wpsimp simp: create_cap_def obj_at_kh_kheap_simps vs_all_heap_simps + wp: set_object_wp get_object_wp dxo_wp_weak) + done + crunch update_cdt_list for valid_sched_pred[wp]: "valid_sched_pred_strong P" (wp: dxo_wp_weak crunch_wps) @@ -40,10 +84,28 @@ lemma store_word_offs_valid_sched_pred[wp]: "store_word_offs ptr offs v \valid_sched_pred_strong P\" by (wpsimp simp: store_word_offs_def wp: dmo_valid_sched_pred) +lemma set_mrs_eps_of[wp]: + "set_mrs thread buf msgs \\s. P (eps_of s)\" + by (set_object_easy_cases def: set_mrs_def store_word_offs_def) + +lemma set_mrs_ntfns_of[wp]: + "set_mrs thread buf msgs \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: set_mrs_def store_word_offs_def) + +lemma set_mrs_prios_of[wp]: + "set_mrs thread buf msgs \\s. P (prios_of s)\" + by (set_object_easy_cases def: set_mrs_def store_word_offs_def final: get_tcb_def) + lemma set_mrs_valid_sched_pred[wp]: "set_mrs thread buf msgs \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ntfns_of, rotated], wpsimp) apply (wpsimp simp: set_mrs_def wp: zipWithM_x_inv' set_object_wp) - by (auto simp: vs_all_heap_simps obj_at_kh_kheap_simps) + apply (fastforce simp: vs_all_heap_simps obj_at_kh_kheap_simps) + done global_interpretation set_mrs: valid_sched_pred_locale _ "set_mrs r t mrs" by unfold_locales wp @@ -622,13 +684,85 @@ lemma released_sc_cur_time_increasing: \ sc_refill_cfg_sc_at (released_sc (cur_time s')) scp s'" by (clarsimp simp: sc_refill_cfg_sc_at_def obj_at_def refill_ready_def word_le_nat_alt) +lemma eps_of_ko_at_Some: + "(eps_of s p = Some ep) = ep_at_pred ((=) ep) p s" + by (simp add: eps_of_def ep_at_pred_def in_opt_map_eq) + +lemma ntfns_of_ko_at_Some: + "(ntfns_of s p = Some ntfn) = ntfn_at_pred ((=) ntfn) p s" + by (simp add: ntfn_of_def ntfn_at_pred_def in_opt_map_eq) + (fastforce split: kernel_object.splits) + +lemma eps_of_obj_at_None: + "(eps_of s p = None) = (\ (obj_at (\obj. \ep. obj = Endpoint ep) p s))" + by (simp add: eps_of_def obj_at_def opt_map_def ep_of_def + split: option.splits kernel_object.splits) + +lemma ntfns_of_obj_at_None: + "(ntfns_of s p = None) = (\ (obj_at (\obj. \ntfn. obj = Notification ntfn) p s))" + by (simp add: ntfn_of_def obj_at_def opt_map_def split: option.splits kernel_object.splits) + +lemma ep_queues_of_ep_at_pred: + "(ep_queues_of s p = Some q) = ep_at_pred (\ep. ep_queue ep = q) p s" + by (simp add: eps_of_def ep_at_pred_def in_opt_map_eq) + +lemma ntfn_queues_of_ntfn_at_pred: + "(ntfn_queues_of s p = Some q) = ntfn_at_pred (\ntfn. ntfn_queue (ntfn_obj ntfn) = q) p s" + by (simp add: ntfn_of_def ntfn_at_pred_def in_opt_map_eq) + (fastforce split: kernel_object.splits) + +lemma in_ep_queue_st_tcb_at: + "\ep_queues_of s ep_ptr = Some q; t \ set q; valid_objs s; sym_refs (state_refs_of s)\ + \ st_tcb_at (\st. (\data. st = BlockedOnSend ep_ptr data) + \ (\data pl. st = BlockedOnReceive ep_ptr data pl)) t s" + apply (clarsimp simp: opt_map_def eps_of_kh_def split: option.splits) + apply (erule (1) valid_objsE) + apply (clarsimp simp: valid_obj_def valid_ep_def) + apply (clarsimp simp: sym_refs_def) + apply (erule_tac x=ep_ptr in allE) + apply (fastforce simp: state_refs_of_def is_tcb obj_at_def pred_tcb_at_def tcb_st_refs_of_def + get_refs_def2 + split: thread_state.splits if_splits endpoint.splits) + done + +lemma in_ntfn_queue_st_tcb_at: + "\ntfn_queues_of s ntfn_ptr = Some q; t \ set q; valid_objs s; sym_refs (state_refs_of s)\ + \ st_tcb_at (\st. st = BlockedOnNotification ntfn_ptr) t s" + apply (clarsimp simp: opt_map_def split: option.splits) + apply (frule st_in_waitingntfn[where q=q]; fastforce?) + apply (rename_tac notification, case_tac notification; clarsimp) + apply (case_tac ntfn_obj; clarsimp) + done + +lemma tcb_at_priority_Some: + "tcb_at t s \ \prio. prios_of s t = Some prio" + by (clarsimp simp: obj_at_def opt_map_def tcb_heap_of_state_def is_tcb_def) + (rename_tac ko, case_tac ko; clarsimp) + +lemma prios_of_etcb_at: + "(prios_of s t = Some prio) \ (tcb_at t s \ etcb_at (\etcb. etcb_priority etcb = prio) t s)" + by (fastforce simp add: etcb_at_def2 in_opt_map_eq vs_all_heap_simps obj_at_def is_tcb_def) + \ \Used for retyping Untyped memory, including ASID pool creation. Retyping may destroy objects if the Untyped memory is reset. But under the invariants, destruction can only occur for objects which are not referenced by any caps.\ lemma valid_sched_tcb_state_preservation_gen: assumes I: "\s. I s \ ct_active s \ invs s" assumes st_tcb: "\P t. \st_tcb_at P t and ex_nonz_cap_to t and I\ f \\_. st_tcb_at P t\" + assumes tcb_at: "\t. \tcb_at t and ex_nonz_cap_to t and I\ f \\_. tcb_at t\" assumes fault_tcb: "\P t. \fault_tcb_at P t and ex_nonz_cap_to t and I\ f \\_. fault_tcb_at P t\" + assumes ep_at_queue: + "\t q. \\s. ep_at_pred (\ep. ep_queue ep = q \ q \ []) t s \ I s\ + f \\_ s. ep_at_pred (\ep. ep_queue ep = q \ q \ []) t s\" + assumes not_ep_at: + "\t. \\s. \ ep_at_pred (\ep. ep_queue ep \ []) t s \ I s\ + f \\_ s. \ ep_at_pred (\ep. ep_queue ep \ []) t s\" + assumes ntfn_at_queue: + "\t q. \\s. ntfn_at_pred (\ntfn. ntfn_queue (ntfn_obj ntfn) = q \ q \ []) t s \ I s\ + f \\_ s. ntfn_at_pred (\ntfn. ntfn_queue (ntfn_obj ntfn) = q \ q \ []) t s\" + assumes not_ntfn_at: + "\t. \\s. \ ntfn_at_pred (\ntfn. ntfn_queue (ntfn_obj ntfn) \ []) t s \ I s\ + f \\_ s. \ ntfn_at_pred (\ntfn. ntfn_queue (ntfn_obj ntfn) \ []) t s\" assumes not_ipc_queued: "\t. \\s. \ st_tcb_at ipc_queued_thread_state t s \ I s\ f \\_ s. \ st_tcb_at ipc_queued_thread_state t s\" assumes non_empty_sc_replies: "\scp. \\s. \ sc_replies_sc_at (\rs. rs \ []) scp s \ I s\ @@ -830,7 +964,96 @@ lemma valid_sched_tcb_state_preservation_gen: apply (frule (1) non_empty_sc_replies_nonz_cap) apply (rule use_valid, assumption, rule sc_refill_cfg) by (intro conjI; assumption) - by simp + apply (prop_tac "sorted_ipc_queues s'") + subgoal for s r s' + apply (clarsimp simp: sorted_ipc_queues_def) + apply (rename_tac ptr) + apply (drule_tac x=ptr in spec) + apply (rule conjI) + apply clarsimp + apply (rename_tac q) + apply (case_tac "q = []", clarsimp) + apply (thin_tac "none_top _ (ntfn_queues_of s ptr)") + apply (clarsimp simp: none_top_def split: option.splits) + subgoal + by (fastforce dest!: use_valid[OF _ not_ep_at] + simp: eps_of_obj_at_None ep_at_pred_def obj_at_def + ep_queues_of_ep_at_pred) + apply (rename_tac q') + apply (prop_tac "q' \ []") + apply (rule ccontr) + subgoal + by (force dest!: use_valid[OF _ not_ep_at] + simp: eps_of_obj_at_None ep_at_pred_def obj_at_def ep_queues_of_ep_at_pred) + apply (frule_tac q1=q' and t1=ptr in use_valid[OF _ ep_at_queue]) + apply (clarsimp simp: ep_queues_of_ep_at_pred ep_at_pred_def) + apply (prop_tac "q' = q") + apply (clarsimp simp: ep_at_pred_def ep_queues_of_ep_at_pred) + apply clarsimp + apply (prop_tac "\t \ set q. prios_of s' t = prios_of s t") + apply (prop_tac "\t \ set q. ex_nonz_cap_to t s") + subgoal + by (fastforce intro: ep_queue_cap_to + simp: ep_queues_of_ep_at_pred ep_at_pred_def obj_at_def) + apply clarsimp + apply (drule_tac x=t in bspec, fastforce) + apply (frule invs_valid_objs) + apply (frule invs_sym_refs) + apply (frule (3) in_ep_queue_st_tcb_at) + apply (frule use_valid[OF _ st_tcb], fastforce) + apply (frule st_tcb_at_tcb_at) + apply (frule tcb_at_priority_Some) + apply clarsimp + apply (frule use_valid[OF _ tcb_at], fastforce) + apply (frule_tac t1=t and P1="\etcb. etcb_priority etcb = prio" in use_valid[OF _ etcb_at]) + apply (fastforce dest: prios_of_etcb_at[THEN iffD1]) + apply (elim impE) + apply (force elim!: st_tcb_weakenE) + apply (fastforce intro!: prios_of_etcb_at[THEN iffD2]) + subgoal by (fastforce elim: sorted_wrt_mono_rel[rotated] simp: img_ord_def) + apply clarsimp + apply (rename_tac q) + apply (case_tac "q = []", clarsimp) + apply (thin_tac "none_top _ (ep_queues_of s ptr)") + apply (clarsimp simp: none_top_def split: option.splits) + subgoal + by (fastforce dest!: use_valid[OF _ not_ntfn_at] + simp: ntfns_of_obj_at_None ntfn_at_pred_def obj_at_def + ntfn_queues_of_ntfn_at_pred) + apply (rename_tac q') + apply (prop_tac "q' \ []") + apply (rule ccontr) + apply (frule_tac t1=ptr in use_valid[OF _ not_ntfn_at]) + apply (clarsimp simp: ntfns_of_obj_at_None ntfn_at_pred_def obj_at_def opt_map_def) + apply (clarsimp simp: ntfn_queues_of_ntfn_at_pred ntfn_at_pred_def) + apply (clarsimp simp: eps_of_ko_at_Some ntfn_queues_of_ntfn_at_pred) + apply (frule_tac q1=q' and t1=ptr in use_valid[OF _ ntfn_at_queue]) + apply (clarsimp simp: ntfn_queues_of_ntfn_at_pred ntfn_at_pred_def) + apply (prop_tac "q' = q") + apply (clarsimp simp: ntfn_at_pred_def) + apply clarsimp + apply (prop_tac "\t \ set q. prios_of s' t = prios_of s t") + apply (clarsimp simp: ntfn_at_pred_def ntfn_queue_def split: ntfn.splits) + apply (frule invs_valid_objs) + apply (frule invs_sym_refs) + apply (frule (4) ex_nonz_cap_to_tcb_in_waitingntfn) + apply (drule_tac x=t in bspec, fastforce) + apply (frule_tac ntfn_ptr=ptr in in_ntfn_queue_st_tcb_at[rotated]) + apply fastforce + apply fastforce + apply (force simp: ntfn_at_pred_def opt_map_def split: option.splits) + apply (frule use_valid[OF _ st_tcb], fastforce) + apply (frule st_tcb_at_tcb_at) + apply (frule tcb_at_priority_Some) + apply clarsimp + apply (frule use_valid[OF _ tcb_at], fastforce) + apply (frule_tac t1=t and P1="\etcb. etcb_priority etcb = prio" in use_valid[OF _ etcb_at]) + apply (fastforce dest: prios_of_etcb_at[THEN iffD1]) + apply (elim impE) + apply (force elim!: st_tcb_weakenE) + apply (fastforce intro!: prios_of_etcb_at[THEN iffD2]) + by (fastforce elim: sorted_wrt_mono_rel[rotated] simp: img_ord_def) + by simp lemma invoke_untyped_valid_idle: "\invs and ct_active @@ -975,6 +1198,42 @@ lemma invoke_untyped_sc_at_pred_n_live: unfolding sc_at_pred_n_def using live by (auto intro!: invoke_untyped_obj_at_live simp: cspace_agnostic_pred_def live_def) +lemma ep_at_pred_def2: + "ep_at_pred P ptr s = obj_at (\ko. \ep. ko = Endpoint ep \ P ep) ptr s" + by (fastforce simp: ep_at_pred_def obj_at_def) + +lemma ntfn_at_pred_def2: + "ntfn_at_pred P ptr s = obj_at (\ko. \ntfn. ko = Notification ntfn \ P ntfn) ptr s" + by (fastforce simp: ntfn_at_pred_def obj_at_def) + +(* FIXME RT: move to Untyped_AI *) +lemma invoke_untyped_ep_at_pred_live: + assumes live: "\ep. P ep \ (ep \ IdleEP)" + shows + "\\s. Q (ep_at_pred P p s) + \ invs s + \ ct_active s + \ valid_untyped_inv ui s + \ scheduler_action s = resume_cur_thread\ + invoke_untyped ui + \\rv s. Q (ep_at_pred P p s)\" + unfolding ep_at_pred_def2 using live + by (auto intro!: invoke_untyped_obj_at_live simp: cspace_agnostic_pred_def live_def) + +(* FIXME RT: move to Untyped_AI *) +lemma invoke_untyped_ntfn_at_pred_live: + assumes live: "\ntfn. P ntfn \ live_ntfn ntfn" + shows + "\\s. Q (ntfn_at_pred P p s) + \ invs s + \ ct_active s + \ valid_untyped_inv ui s + \ scheduler_action s = resume_cur_thread\ + invoke_untyped ui + \\rv s. Q (ntfn_at_pred P p s)\" + unfolding ntfn_at_pred_def2 using live + by (auto intro!: invoke_untyped_obj_at_live simp: cspace_agnostic_pred_def live_def) + lemma ipc_queued_thread_state_live: "ipc_queued_thread_state (tcb_state tcb) \ live (TCB tcb)" by (cases "tcb_state tcb"; simp add: ipc_queued_thread_state_def live_def) @@ -1103,6 +1362,14 @@ lemma invoke_untyped_cur_time_monotonic: wp: reset_untyped_cap_cur_time_monotonic mapM_x_wp_inv) done +(* FIXME RT: move *) +lemma ntfn_queue_nonempty_live: + "ntfn_queue (ntfn_obj notification) \ [] \ live_ntfn notification" + apply (cases notification) + apply (clarsimp simp: live_ntfn_def) + apply (case_tac ntfn_obj; clarsimp) + done + lemma invoke_untyped_valid_sched: "\valid_sched and valid_machine_time and invs and ct_active and valid_untyped_inv ui and (\s. scheduler_action s = resume_cur_thread)\ @@ -1112,17 +1379,21 @@ lemma invoke_untyped_valid_sched: apply (rule_tac I="invs and ct_active and valid_untyped_inv ui and valid_sched and (\s. scheduler_action s = resume_cur_thread)" in valid_sched_tcb_state_preservation_gen) - apply simp - apply (wpsimp wp: invoke_untyped_pred_tcb_at invoke_untyped_pred_tcb_at_live - invoke_untyped_sc_at_pred_n_live[where Q="Not"] - invoke_untyped_etcb_at invoke_untyped_sc_at_pred_n - invoke_untyped_pred_map_sc_refill_cfgs_of - invoke_untyped_valid_idle invoke_untyped_valid_sched_pred_misc - invoke_untyped_cur_time_monotonic - invoke_untyped_implies_zero_budget - invoke_untyped_sporadic_implies - hoare_vcg_all_lift - simp: ipc_queued_thread_state_live live_sc_def)+ + apply (wpsimp wp: invoke_untyped_pred_tcb_at + invoke_untyped_pred_tcb_at_live + invoke_untyped_sc_at_pred_n_live[where Q="Not"] + invoke_untyped_etcb_at invoke_untyped_sc_at_pred_n + invoke_untyped_pred_map_sc_refill_cfgs_of + invoke_untyped_valid_idle + invoke_untyped_valid_sched_pred_misc + invoke_untyped_cur_time_monotonic + invoke_untyped_implies_zero_budget + invoke_untyped_sporadic_implies + invoke_untyped_ep_at_pred_live + invoke_untyped_ntfn_at_pred_live + hoare_vcg_all_lift + simp: ipc_queued_thread_state_live live_sc_def + ntfn_queue_nonempty_live)+ done lemma cur_sc_active_rewrite: @@ -1389,16 +1660,6 @@ lemma distinct_not_in_takeWhile: apply (subst set_append, auto) done -(* FIXME: Move *) -lemma dropWhile_dropped_P: - "\x \ set queue; x \ set (dropWhile P queue)\ \ P x" - by (induction queue arbitrary: x; fastforce split: if_split_asm) - -(* FIXME: Move *) -lemma takeWhile_taken_P: - "x \ set (takeWhile P queue) \ P x" - by (induction queue arbitrary: x; fastforce split: if_split_asm) - (* FIXME: remove *) lemmas hoare_vcg_imp_lift'' = hoare_vcg_imp_lift_N[where N="\P. P" and P=P' and Q=P and P'=Q' and Q'=Q for P' P Q' Q] diff --git a/proof/invariant-abstract/DetSchedInvs_AI.thy b/proof/invariant-abstract/DetSchedInvs_AI.thy index f6e6d0b15b..3ac4fd3e0f 100644 --- a/proof/invariant-abstract/DetSchedInvs_AI.thy +++ b/proof/invariant-abstract/DetSchedInvs_AI.thy @@ -717,6 +717,9 @@ lemma etcb_at'_pred_map: "\ etcb_at' P etcbs ref; pred_map \ etcbs ref \ \ pred_map P etcbs ref" by (simp add: etcb_at'_def) +abbreviation prios_of :: "'z state \ obj_ref \ priority" where + "prios_of s \ tcbs_of s ||> tcb_priority" + \ \Project scheduling contexts from the kernel heap\ definition sc_of :: "kernel_object \ sched_context" where @@ -890,6 +893,9 @@ global_interpretation ep_recv_qs: opt_map_opt_map_cons_def_locale _ ep_of eps_of_kh Endpoint recv_q_of RecvEP ep_recv_qs_of_eps using ep_recv_qs_of_eps_def recv_q_of_None recv_q_of_Some by unfold_locales +abbreviation ep_queues_of :: "'z state \ obj_ref \ obj_ref list" where + "ep_queues_of s \ eps_of s ||> ep_queue" + \ \Notifications\ \ \Project notifications from the kernel heap\ @@ -910,6 +916,9 @@ lemma ntfn_of_None: abbreviation ntfns_of :: "'z state \ obj_ref \ Structures_A.notification" where "ntfns_of \ (\s. kheap s |> ntfn_of)" +abbreviation ntfn_queues_of :: "'z state \ obj_ref \ obj_ref list" where + "ntfn_queues_of s \ ntfns_of s ||> ntfn_obj ||> ntfn_queue" + \ \Replies\ \ \Project replies from the kernel heap\ @@ -1668,6 +1677,9 @@ type_synonym valid_sched_t \ (obj_ref \ fault option) \ (obj_ref \ sc_refill_cfg) \ (obj_ref \ obj_ref list) + \ (obj_ref \ obj_ref list) + \ (obj_ref \ obj_ref list) + \ (obj_ref \ priority) \ bool" abbreviation valid_sched_pred :: "valid_sched_t \ 'z::state_ext state \ bool" where @@ -1675,19 +1687,18 @@ abbreviation valid_sched_pred :: "valid_sched_t \ 'z::state_ext stat \s. P (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)" + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) (prios_of s)" type_synonym valid_sched_strong_t - = "time \ obj_ref \ (obj_ref \ obj_ref list) \ (obj_ref \ obj_ref list) - \ (obj_ref \ obj_ref option) \ time \ nat \ valid_sched_t" + = "time \ obj_ref \ (obj_ref \ obj_ref option) \ time \ nat \ (obj_ref \ endpoint) + \ (obj_ref \ notification) \ valid_sched_t" \ \Sometimes it's useful to prove preservation of some additional projections, even though they are not used in valid_sched.\ abbreviation valid_sched_pred_strong :: "valid_sched_strong_t \ 'z::state_ext state \ bool" where "valid_sched_pred_strong P - \ \s. valid_sched_pred (P (consumed_time s) (cur_sc s) (ep_send_qs_of s) - (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) - (time_state_of s)) s" + \ \s. valid_sched_pred (P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) + (time_state_of s) (eps_of s) (ntfns_of s)) s" \ \Adapter for valid_sched_pred\ abbreviation (input) valid_sched_pred_strengthen :: "valid_sched_t \ valid_sched_strong_t" where @@ -2348,8 +2359,8 @@ lemma active_scs_valid_lift_pre_conj: \ \Adapter for valid_sched_pred\ abbreviation (input) valid_sched_valid_ready_qs :: valid_sched_t where "valid_sched_valid_ready_qs ctime cdom ct it rq rlq sa etcbs tcb_sts - tcb_scps tcb_faults sc_refill_cfgs sc_reps\ - valid_ready_qs_2 rq ctime etcbs tcb_sts tcb_scps sc_refill_cfgs" + tcb_scps tcb_faults sc_refill_cfgs sc_reps ep_qs ntfn_qs prios \ + valid_ready_qs_2 rq ctime etcbs tcb_sts tcb_scps sc_refill_cfgs" lemma valid_ready_qsE: assumes v: "valid_ready_qs_2 qs ctime etcbs sts scps cfgs" @@ -2360,10 +2371,6 @@ lemma valid_ready_qsE: shows "valid_ready_qs_2 qs' ctime' etcbs' sts' scps' cfgs'" using assms by (simp add: valid_ready_qs_2_def) -fun opt_ord where - "opt_ord (Some x) (Some y) = (x \ y)" -| "opt_ord x y = (y = None \ x = None)" - definition sorted_release_q_2 :: "(obj_ref \ sc_refill_cfg) \ obj_ref list \ bool" where @@ -2430,8 +2437,8 @@ lemma ready_or_released_in_release_queue: \ \Adapter for valid_sched_pred\ abbreviation (input) valid_sched_valid_release_q :: "obj_ref set \ valid_sched_t" where "valid_sched_valid_release_q S ctime cdom ct it rq rlq sa etcbs tcb_sts - tcb_scps tcb_faults sc_refill_cfgs sc_reps\ - valid_release_q_except_set_2 S rlq tcb_sts tcb_scps sc_refill_cfgs" + tcb_scps tcb_faults sc_refill_cfgs sc_reps ep_qs ntfn_ps prios \ + valid_release_q_except_set_2 S rlq tcb_sts tcb_scps sc_refill_cfgs" lemma valid_release_qE: assumes v: "valid_release_q_except_set_2 except queue tcb_sts tcb_scps sc_refill_cfgs" @@ -2585,6 +2592,7 @@ lemma active_bound_sc_tcb_at: \ \Adapter for valid_sched_pred\ abbreviation (input) valid_sched_ipc_queues :: valid_sched_t where "valid_sched_ipc_queues ctime cdom ct it rq rlq sa etcbs sts scps faults scrcs replies + ep_qs ntfn_pqs prios \ released_ipc_queues_2 ctime sts scps faults scrcs" (* FIXME RT: move *) @@ -2876,8 +2884,8 @@ lemma valid_blockedD: \ \Adapter for valid_sched_pred\ abbreviation (input) valid_sched_valid_blocked :: "obj_ref set \ valid_sched_t" where "valid_sched_valid_blocked S ctime cdom ct it rq rlq sa etcbs tcb_sts - tcb_scps tcb_faults sc_refill_cfgs sc_reps \ - valid_blocked_except_set_2 S rq rlq sa ct tcb_sts tcb_scps sc_refill_cfgs" + tcb_scps tcb_faults sc_refill_cfgs sc_reps ep_qs ntfn_ps prios \ + valid_blocked_except_set_2 S rq rlq sa ct tcb_sts tcb_scps sc_refill_cfgs" definition in_cur_domain_2 where "in_cur_domain_2 thread cdom ekh \ etcb_at' (\t. etcb_domain t = cdom) ekh thread" @@ -3009,8 +3017,56 @@ lemma active_reply_scsE: shows "active_reply_scs_2 replies' refill_cfgs'" using assms by (simp add: active_reply_scs_2_def active_if_reply_sc_at_2_def) +abbreviation priority_ordered :: "obj_ref list \ (obj_ref \ priority) \ bool" where + "priority_ordered ts prios \ sorted_wrt (img_ord prios (opt_ord_rel (\))) ts" + +definition sorted_ipc_queues_except_set_2 :: + "obj_ref set \ (obj_ref \ obj_ref list) \ (obj_ref \ obj_ref list) \ (obj_ref \ priority) \ bool" where + "sorted_ipc_queues_except_set_2 except ep_qs ntfn_qs prios \ + \ptr. ptr \ except \ + (none_top (\q. priority_ordered q prios) (ep_qs ptr) + \ none_top (\q. priority_ordered q prios) (ntfn_qs ptr))" + +abbreviation sorted_ipc_queues_except_set :: "obj_ref set \ 'z::state_ext state \ bool" where + "sorted_ipc_queues_except_set except s \ + sorted_ipc_queues_except_set_2 except (ep_queues_of s) (ntfn_queues_of s) (prios_of s)" + +abbreviation "sorted_ipc_queues_except_2 t \ sorted_ipc_queues_except_set_2 {t}" +abbreviation "sorted_ipc_queues_except t s \ sorted_ipc_queues_except_2 t (ep_queues_of s) (ntfn_queues_of s) (prios_of s)" +abbreviation "sorted_ipc_queues_2 \ sorted_ipc_queues_except_set_2 {}" +abbreviation "sorted_ipc_queues s \ sorted_ipc_queues_2 (ep_queues_of s) (ntfn_queues_of s) (prios_of s)" + +lemmas sorted_ipc_queues_except_set_def = sorted_ipc_queues_except_set_2_def +lemmas sorted_ipc_queues_except_def = sorted_ipc_queues_except_set_2_def +lemmas sorted_ipc_queues_def = sorted_ipc_queues_except_set_2_def + +lemma sorted_ipc_queues_endpoint_priority_ordered: + "\sorted_ipc_queues s; ep_queues_of s ptr = Some q\ \ priority_ordered q (prios_of s)" + by (fastforce simp: sorted_ipc_queues_def dest: spec[where x=ptr]) + +lemma sorted_ipc_queues_notification_priority_ordered: + "\sorted_ipc_queues s; ntfn_queues_of s ptr = Some q\ \ priority_ordered q (prios_of s)" + by (fastforce simp: sorted_ipc_queues_def dest: spec[where x=ptr]) + +lemma sorted_ipc_queues_except_set_lift_pre_conj: + assumes "\P. \\s. P (eps_of s) \ R s\ f \\_ s. P (eps_of s)\" + assumes "\P. \\s. P (ntfns_of s) \ R s\ f \\_ s. P (ntfns_of s)\" + assumes "\P. \\s. P (prios_of s) \ R s\ f \\_ s. P (prios_of s)\" + shows "\\s. sorted_ipc_queues_except_set S s \ R s\ f \\_ s. sorted_ipc_queues_except_set S s\" + unfolding sorted_ipc_queues_def + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_ex_lift assms + split: none_top_split) + by (fastforce simp: none_top_def comp_def split: option.splits) + +lemmas sorted_ipc_queues_except_set_lift = + sorted_ipc_queues_except_set_lift_pre_conj[where R=\, simplified] + +lemmas sorted_ipc_queues_lift = + sorted_ipc_queues_except_set_lift[where S="{}", simplified] + definition valid_sched_2 where - "valid_sched_2 wk_vsa vbl riq ctime cdom ct it queues rlq sa etcbs tcb_sts tcb_scps tcb_faults sc_refill_cfgs sc_reps \ + "valid_sched_2 wk_vsa vbl riq ctime cdom ct it queues rlq sa etcbs tcb_sts tcb_scps tcb_faults + sc_refill_cfgs sc_reps ep_qs ntfn_qs prios \ valid_ready_qs_2 queues ctime etcbs tcb_sts tcb_scps sc_refill_cfgs \ valid_release_q_2 rlq tcb_sts tcb_scps sc_refill_cfgs \ ready_or_release_2 queues rlq @@ -3021,7 +3077,8 @@ definition valid_sched_2 where \ valid_idle_etcb_2 etcbs \ (riq \ released_ipc_queues_2 ctime tcb_sts tcb_scps tcb_faults sc_refill_cfgs) \ active_reply_scs_2 sc_reps sc_refill_cfgs - \ active_scs_valid_2 sc_refill_cfgs" + \ active_scs_valid_2 sc_refill_cfgs + \ sorted_ipc_queues_2 ep_qs ntfn_qs prios" abbreviation valid_sched :: "'z::state_ext state \ bool" where "valid_sched \ valid_sched_pred (valid_sched_2 True True True)" @@ -3169,6 +3226,10 @@ lemma valid_sched_ct_not_in_q[elim!]: "valid_sched s \ ct_not_in_q s" by (simp add: valid_sched_def) +lemma valid_sched_sorted_ipc_queues[elim!]: + "valid_sched s \ sorted_ipc_queues s" + by (simp add: valid_sched_def) + (* sched_context and other thread properties *) abbreviation sc_with_tcb_prop :: "obj_ref \ (obj_ref \ 'z state \ bool) \ 'z state \ bool" @@ -3550,6 +3611,7 @@ lemma valid_sched_lift_pre_conj: assumes "\t. \\s. budget_ready t s \ R s\ f \\rv s. budget_ready t s\" assumes "\t. \\s. budget_sufficient t s \ R s\ f \\rv s. budget_sufficient t s\" assumes "\P. \\s. P (etcbs_of s) \ R s\ f \\rv s. P (etcbs_of s)\" + assumes "\P. \\s. P (prios_of s) \ R s\ f \\rv s. P (prios_of s)\" assumes "\P. \\s. P (scheduler_action s) \ R s\ f \\rv s. P (scheduler_action s)\" assumes "\P. \\s. P (ready_queues s) \ R s\ f \\rv s. P (ready_queues s)\" assumes "\P. \\s. P (cur_domain s) \ R s\ f \\rv s. P (cur_domain s)\" @@ -3560,13 +3622,17 @@ lemma valid_sched_lift_pre_conj: assumes "\t. \\s. pred_map_eq None (tcb_scps_of s) t \ R s\ f \\rf s. pred_map_eq None (tcb_scps_of s) t\" assumes "\t. \\s. timeout_faulted_tcb_at t s \ R s\ f \\rv s. timeout_faulted_tcb_at t s\" assumes "\scp. \\s. active_if_reply_sc_at scp s \ R s\ f \\rv s. active_if_reply_sc_at scp s\" + assumes "\scp. \\s. active_if_reply_sc_at scp s \ R s\ f \\rv s. active_if_reply_sc_at scp s\" + assumes "\P. \\s. P (eps_of s) \ R s\ f \\rv s. P (eps_of s)\" + assumes "\P. \\s. P (ntfns_of s) \ R s\ f \\rv s. P (ntfns_of s)\" shows "\\s. valid_sched s \ R s\ f \\rv. valid_sched\" by (wpsimp simp: valid_sched_def ready_or_release_def ready_or_release_def wp: valid_ready_qs_lift_pre_conj ct_not_in_q_lift_pre_conj ct_in_cur_domain_lift_pre_conj valid_release_q_lift_pre_conj valid_sched_action_lift_pre_conj valid_blocked_lift_pre_conj assms released_ipc_queues_lift_pre_conj active_scs_valid_lift_pre_conj - active_reply_scs_lift_pre_conj hoare_vcg_all_lift hoare_vcg_imp_lift) + active_reply_scs_lift_pre_conj sorted_ipc_queues_except_set_lift_pre_conj + hoare_vcg_all_lift hoare_vcg_imp_lift) lemmas valid_sched_lift = valid_sched_lift_pre_conj[where R = \, simplified] diff --git a/proof/invariant-abstract/DetSchedSchedule_AI.thy b/proof/invariant-abstract/DetSchedSchedule_AI.thy index 2eaf948e64..ea2af2b9f5 100644 --- a/proof/invariant-abstract/DetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/DetSchedSchedule_AI.thy @@ -731,7 +731,8 @@ lemma schedule_tcb_valid_sched_pred[valid_sched_wp]: \ (pred_map runnable (tcb_sts_of s) t \ active_sc_tcb_at t s \ in_release_q t s) then choose_new_thread else (scheduler_action s)) (etcbs_of s) (tcb_sts_of s) - (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) (sc_replies_of s)\ + (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) (sc_replies_of s) + (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ schedule_tcb t \\_. valid_sched_pred P\" by (wpsimp wp: schedule_tcb_wp split: if_splits) @@ -831,7 +832,8 @@ lemma reschedule_required_valid_sched_except_blocked: and valid_idle_etcb and released_ipc_queues and active_reply_scs - and active_scs_valid\ + and active_scs_valid + and sorted_ipc_queues\ reschedule_required \\_. valid_sched_except_blocked\" apply (wpsimp wp: valid_sched_wp) @@ -846,7 +848,8 @@ lemma reschedule_required_valid_sched': and valid_idle_etcb and released_ipc_queues and active_reply_scs - and active_scs_valid\ + and active_scs_valid + and sorted_ipc_queues\ reschedule_required \\_. valid_sched\" unfolding valid_sched_def @@ -945,21 +948,33 @@ lemma set_thread_state_def2: crunch set_thread_state_act for valid_sched_except_sched_act[wp]: - "\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (cur_time s) + "\s. P (consumed_time s) (cur_sc s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (machine_state s) (kheap s)" lemma set_thread_state_only_valid_sched_except_tcb_st[wp]: "set_thread_state_only t st - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (cur_time s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (machine_state s) (tcb_scps_of s) (tcb_faults_of s) (scs_of s)\" - by (wpsimp simp: set_thread_state_only_def vs_all_heap_simps obj_at_kh_kheap_simps sc_heap.all_simps - wp: gets_the_wp' set_object_wp) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated]) + apply (wpsimp simp: set_thread_state_only_def wp: set_object_wp) + apply (erule_tac P=P in rsubst) + apply (frule get_tcb_ko_atI) + apply (fastforce simp: eps_of_kh_def opt_map_def obj_at_def split: option.splits) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated]) + apply (wpsimp simp: set_thread_state_only_def wp: set_object_wp) + apply (erule_tac P=P in rsubst) + apply (frule get_tcb_ko_atI) + apply (fastforce simp: eps_of_kh_def opt_map_def obj_at_def split: option.splits) + apply (wpsimp simp: set_thread_state_only_def vs_all_heap_simps obj_at_kh_kheap_simps + sc_heap.all_simps + wp: gets_the_wp' set_object_wp) + done lemma set_thread_state_valid_sched_misc[wp]: - "set_thread_state t st \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) + "set_thread_state t st \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) @@ -1008,10 +1023,40 @@ lemma set_thread_state_scheduler_action_tcb_st_heap: apply (wpsimp simp: set_thread_state_def2 wp: set_thread_state_act_wp set_thread_state_only_tcb_st_heap) by (auto simp: fun_upd_def obj_at_kh_kheap_simps vs_all_heap_simps split: if_splits) +lemma thread_set_prios_of: + "(\x. tcb_priority (f x) = tcb_priority x) \ thread_set f tptr \\s. P (prios_of s)\" + apply (wpsimp wp: thread_set_wp simp: obj_at_kh_kheap_simps vs_all_heap_simps fun_upd_def) + by (fastforce elim!: rsubst[where P=P] simp: tcbs_of_kh_def opt_map_def) + +lemma thread_set_eps_of[wp]: + "thread_set f tptr \\s. P (eps_of s)\" + apply (wpsimp wp: thread_set_wp) + by (fastforce elim!: rsubst[where P=P] + simp: eps_of_kh_def opt_map_def obj_at_kh_kheap_simps vs_all_heap_simps) + +lemma thread_set_ntfns_of[wp]: + "thread_set f tptr \\s. P (ntfns_of s)\" + apply (wpsimp wp: thread_set_wp) + by (fastforce elim!: rsubst[where P=P] + simp: eps_of_kh_def opt_map_def obj_at_kh_kheap_simps vs_all_heap_simps) + +lemma set_thread_state_prios_of[wp]: + "set_thread_state t st \\s. P (prios_of s)\" + unfolding set_thread_state_def + apply (wpsimp wp: set_object_wp) + apply (erule rsubst[where P=P]) + apply (frule get_tcb_ko_atI) + apply (fastforce simp: obj_at_def opt_map_def tcbs_of_kh_def split: option.splits) + done + +crunch set_thread_state + for sorted_ipc_queues_except_set[wp]: "sorted_ipc_queues_except_set S" + (wp: sorted_ipc_queues_except_set_lift crunch_wps) + lemma set_thread_state_valid_sched_pred_strong': "\\s. pred_map \ (tcbs_of s) t \ - P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) - (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) + P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (if t = cur_thread s \ scheduler_action s = resume_cur_thread @@ -1019,7 +1064,8 @@ lemma set_thread_state_valid_sched_pred_strong': then choose_new_thread else scheduler_action s) (etcbs_of s) ((tcb_sts_of s)(t \ st)) - (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) (sc_replies_of s)\ + (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) (sc_replies_of s) + (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ set_thread_state t st \\rv. valid_sched_pred_strong P\" apply (rule hoare_lift_Pf2[where f=consumed_time, rotated], wpsimp) @@ -1033,6 +1079,11 @@ lemma set_thread_state_valid_sched_pred_strong': apply (rule hoare_lift_Pf2[where f=etcbs_of, rotated], wpsimp) apply (rule hoare_lift_Pf2[where f=last_machine_time_of, rotated], wpsimp) apply (rule hoare_lift_Pf2[where f=time_state_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) by (rule set_thread_state_scheduler_action_tcb_st_heap) lemmas set_thread_state_valid_sched_pred_strong[valid_sched_wp] @@ -1401,25 +1452,37 @@ lemma set_tcb_obj_ref_is_refill_ready[wp]: by (wpsimp wp: set_tcb_obj_ref_wp simp: obj_at_kh_kheap_simps vs_all_heap_simps) lemma set_tcb_obj_ref_valid_sched_except_tcb_heap[wp]: - "set_tcb_obj_ref f ref v \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) + "set_tcb_obj_ref f ref v \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (last_machine_time_of s) (scs_of s)\" + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp simp: set_tcb_obj_ref_thread_set) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp simp: set_tcb_obj_ref_thread_set) by (wpsimp wp: set_tcb_obj_ref_wp - simp: fun_upd_def obj_at_kh_kheap_simps vs_all_heap_simps sc_heap.all_simps) + simp: obj_at_kh_kheap_simps vs_all_heap_simps sc_heap.all_simps) lemma set_tcb_obj_ref_valid_sched_except_tcb_scp_heap: assumes "\tcb. tcb_state (f (\_. v) tcb) = tcb_state tcb" assumes "\tcb. tcb_fault (f (\_. v) tcb) = tcb_fault tcb" assumes "\tcb. etcb_of (f (\_. v) tcb) = etcb_of tcb" - shows "set_tcb_obj_ref f ref v \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) - (ep_recv_qs_of s) (sc_tcbs_of s) (sc_replies_of s) + shows "set_tcb_obj_ref f ref v \\s. P (consumed_time s) (cur_sc s) (eps_of s) + (ntfns_of s) (sc_tcbs_of s) (sc_replies_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_faults_of s) (scs_of s)\" - by (wpsimp wp: set_tcb_obj_ref_wp - simp: fun_upd_def obj_at_kh_kheap_simps vs_all_heap_simps sc_heap.all_simps assms) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp simp: set_tcb_obj_ref_thread_set) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp simp: set_tcb_obj_ref_thread_set) + apply (wpsimp wp: set_tcb_obj_ref_wp) + apply (clarsimp simp: obj_at_kh_kheap_simps vs_all_heap_simps sc_heap.all_simps assms) + done + +lemma set_tcb_obj_ref_prios_of: + "(\tcb. etcb_of (f (\_. v) tcb) = etcb_of tcb) + \ set_tcb_obj_ref f ref v \\s. P (prios_of s)\" + apply (wpsimp wp: set_tcb_obj_ref_wp) + by (fastforce simp: obj_at_kh_kheap_simps vs_all_heap_simps tcbs_of_kh_def etcb_of_def opt_map_def + elim!: rsubst[where P=P]) lemma set_tcb_obj_ref_valid_sched_pred: assumes "\tcb. tcb_state (f (\_. v) tcb) = tcb_state tcb" @@ -1427,7 +1490,18 @@ lemma set_tcb_obj_ref_valid_sched_pred: assumes "\tcb. tcb_fault (f (\_. v) tcb) = tcb_fault tcb" assumes "\tcb. etcb_of (f (\_. v) tcb) = etcb_of tcb" shows "set_tcb_obj_ref f ref v \valid_sched_pred_strong P\" - by (wpsimp wp: set_tcb_obj_ref_wp simp: fun_upd_def obj_at_kh_kheap_simps vs_all_heap_simps assms) + apply (rule hoare_lift_Pf2[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated]) + apply (wpsimp wp: thread_set_prios_of simp: set_tcb_obj_ref_thread_set) + using assms + apply (clarsimp simp: etcb_of_def vs_all_heap_simps assms) + apply simp + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (wpsimp wp: set_tcb_obj_ref_wp) + apply (clarsimp simp: obj_at_kh_kheap_simps vs_all_heap_simps assms) + done lemmas set_bound_notification_valid_sched_pred[wp] = set_tcb_obj_ref_valid_sched_pred[where f=tcb_bound_notification_update, simplified] @@ -1440,13 +1514,23 @@ lemmas set_tcb_sched_context_valid_sched_except_tcb_scp_heap[wp] = lemma set_tcb_sched_context_valid_sched_pred': "\\s. pred_map \ (tcb_sts_of s) ref - \ P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + \ P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) - ((tcb_scps_of s)(ref \ scpo)) (tcb_faults_of s) (sc_refill_cfgs_of s) (sc_replies_of s)\ + ((tcb_scps_of s)(ref \ scpo)) (tcb_faults_of s) (sc_refill_cfgs_of s) (sc_replies_of s) + (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ set_tcb_obj_ref tcb_sched_context_update ref scpo - \\rv. valid_sched_pred_strong P\" - by (wpsimp wp: set_tcb_obj_ref_wp simp: fun_upd_def obj_at_kh_kheap_simps vs_all_heap_simps) + \\_. valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf2[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated]) + apply (wpsimp wp: thread_set_prios_of simp: set_tcb_obj_ref_thread_set) + apply (clarsimp simp: etcb_of_def vs_all_heap_simps) + apply (wpsimp wp: set_tcb_obj_ref_wp simp: obj_at_kh_kheap_simps vs_all_heap_simps) + done \ \The implication in the set_tcb_sched_context_valid_sched_pred' precondition is probably not useful, but this is to document that we are throwing away some @@ -1759,19 +1843,44 @@ lemma update_sched_context_sc_heap: by (wpsimp wp: update_sched_context_wp simp: fun_upd_def obj_at_kh_kheap_simps vs_all_heap_simps sc_heap.all_simps) +lemma update_sched_context_eps_of[wp]: + "update_sched_context scp f \\s. P (eps_of s)\" + unfolding set_tcb_obj_ref_def + apply (wpsimp wp: update_sched_context_wp) + by (fastforce elim!: rsubst[where P=P] simp: obj_at_def opt_map_def eps_of_kh_def) + +lemma update_sched_context_ntfns_of[wp]: + "update_sched_context scp f \\s. P (ntfns_of s)\" + unfolding set_tcb_obj_ref_def + apply (wpsimp wp: update_sched_context_wp) + by (fastforce elim!: rsubst[where P=P] simp: obj_at_def opt_map_def eps_of_kh_def) + +lemma update_sched_context_tcbs_of[wp]: + "update_sched_context scp f \\s. P (tcbs_of s)\" + unfolding set_tcb_obj_ref_def + apply (wpsimp wp: update_sched_context_wp) + by (fastforce elim!: rsubst[where P=P] simp: obj_at_def opt_map_def tcbs_of_kh_def) + lemma update_sched_context_valid_sched_pred': assumes "\sc. sc_refill_cfg_of (f sc) = g (sc_refill_cfg_of sc)" assumes "\sc. sc_tcb (f sc) = h (sc_tcb sc)" assumes "\sc. sc_replies (f sc) = k (sc_replies sc)" shows "\\s. pred_map \ (scs_of s) scp - \ P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) + \ P (consumed_time s) (cur_sc s) (heap_upd h scp (sc_tcbs_of s)) (last_machine_time_of s) (time_state_of s) + (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (heap_upd g scp (sc_refill_cfgs_of s)) (heap_upd k scp (sc_replies_of s))\ + (heap_upd g scp (sc_refill_cfgs_of s)) (heap_upd k scp (sc_replies_of s)) + (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ update_sched_context scp f \\rv. valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf2[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) by (wpsimp wp: update_sched_context_wp simp: fun_upd_def heap_upd_def obj_at_kh_kheap_simps vs_all_heap_simps sc_heap_proj_known_sc assms) @@ -1808,8 +1917,8 @@ lemmas update_sc_budget_valid_sched_pred[valid_sched_wp] = lemmas update_sc_refill_cfg_valid_sched_misc = update_sched_context_valid_sched_pred [where h=id and k=id - and P="\cons csc ep_send_qs ep_recv_qs sc_tcbs lmt ts ctime cdom ct it rqs rlq sa etcbs sts scps faults _ repl. - P cons csc ep_send_qs ep_recv_qs sc_tcbs lmt ts ctime cdom ct it rqs rlq sa etcbs sts scps faults repl :: bool" for P + and P="\cons csc sc_tcbs lmt ts eps ntfns ctime cdom ct it rqs rlq sa etcbs sts scps faults _ repl epqs ntfnqs prios. + P cons csc sc_tcbs lmt ts eps ntfns ctime cdom ct it rqs rlq sa etcbs sts scps faults repl epqs ntfnqs prios :: bool" for P , simplified] lemmas update_sc_refill_cfg_valid_sched_miscs[wp] = @@ -1823,24 +1932,26 @@ lemmas update_sc_tcb_valid_sched_pred[valid_sched_wp] = [where f="sc_tcb_update f" and g=id and h=f and k=id for f, simplified] lemmas update_sc_tcb_valid_sched_misc[wp] = - update_sc_tcb_valid_sched_pred[where P="\cons csc ep_send_qs ep_recv_qs _ lmt ts. P cons csc ep_send_qs ep_recv_qs lmt ts :: valid_sched_t" for P] + update_sc_tcb_valid_sched_pred[ + where P="\cons csc _ lmt ts eps ntfns. P cons csc lmt ts eps ntfns :: valid_sched_t" for P] lemmas update_sc_replies_valid_sched_pred[valid_sched_wp] = update_sched_context_valid_sched_pred [where f="sc_replies_update f" and g=id and h=id and k=f for f, simplified] lemmas update_sc_replies_valid_sched_misc[wp] = - update_sc_replies_valid_sched_pred[where P="\cons csc ep_send_qs ep_recv_qs sc_tcbs lmt ts ctime cdom ct it rqs rlq sa etcbs sts scps faults rcs _. - P cons csc ep_send_qs ep_recv_qs sc_tcbs lmt ts ctime cdom ct it rqs rlq sa etcbs sts scps faults rcs :: bool" for P] + update_sc_replies_valid_sched_pred[ + where P="\cons csc sc_tcbs lmt ts eps ntfns ctime cdom ct it rqs rlq sa etcbs sts scps faults rcs _ epqs ntfnqs prios. + P cons csc sc_tcbs lmt ts eps ntfns ctime cdom ct it rqs rlq sa etcbs sts scps faults rcs epqs ntfnqs prios :: bool" for P] lemma set_refills_valid_sched_pred': "\\s. pred_map \ (scs_of s) scp - \ P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) - (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) + \ P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (heap_upd (scrc_refills_update (\_. refills)) scp (sc_refill_cfgs_of s)) - (sc_replies_of s)\ + (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ set_refills scp refills \\rv. valid_sched_pred_strong P\" by (wpsimp simp: set_refills_def fun_upd_def heap_upd_def vs_all_heap_simps sc_heap_proj_known_sc @@ -1851,20 +1962,25 @@ lemmas set_refills_valid_sched_pred[valid_sched_wp] = set_refills_valid_sched_pred'[THEN hoare_drop_assertion] lemma update_sched_context_valid_sched_misc[wp]: - "update_sched_context scp f \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) + "update_sched_context scp f \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) - (last_machine_time_of s) (tcbs_of s)\" - by (wpsimp wp: update_sched_context_wp - simp: fun_upd_def obj_at_kh_kheap_simps vs_all_heap_simps tcb_heap.all_simps) + (last_machine_time_of s) (tcbs_of s) (etcbs_of s)\" + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=tcbs_of, rotated], wpsimp) + apply (wpsimp wp: update_sched_context_wp) + done lemma set_refills_valid_sched_misc[wp]: - "set_refills scp refills \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) + "set_refills scp refills \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (sc_tcbs_of s) (sc_replies_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) - (scheduler_action s) (tcbs_of s)\" + (scheduler_action s) (tcbs_of s) (etcbs_of s)\" apply (rule hoare_lift_Pf[where f=sc_tcbs_of, rotated], wp valid_sched_wp) apply (rule hoare_lift_Pf[where f=sc_replies_of, rotated], wp valid_sched_wp) + apply (rule hoare_lift_Pf[where f=eps_of, rotated], wp valid_sched_wp) + apply (rule hoare_lift_Pf[where f=ntfns_of, rotated], wp valid_sched_wp) by (wpsimp simp: set_refills_def) lemma update_sched_context_is_sc_active_indep: @@ -2052,7 +2168,7 @@ lemma set_refills_valid_sched: by (wpsimp simp: valid_sched_def wp: set_refills_valid_ready_qs set_refills_valid_release_q valid_idle_etcb_lift set_refills_valid_sched_action set_refills_active_scs_valid - set_refills_released_ipc_queues) + set_refills_released_ipc_queues sorted_ipc_queues_lift) lemma set_refills_valid_sched_not_in: "\valid_sched and sc_not_in_release_q sc_ptr and @@ -2077,8 +2193,8 @@ crunch sched_context_donate and cur_time[wp]: "\s. P (cur_time s)" and cur_domain[wp]: "\s. P (cur_domain s)" and last_machine_time_of[wp]: "\s. P (last_machine_time_of s)" - and ep_send_qs_of[wp]: "\s. P (ep_send_qs_of s)" - and ep_recv_qs_of[wp]: "\s. P (ep_recv_qs_of s)" + and eps_of[wp]: "\s. P (eps_of s)" + and ntfns_of[wp]: "\s. P (ntfns_of s)" (wp: crunch_wps) lemma sched_context_donate_etcb_heap[wp]: @@ -2102,14 +2218,14 @@ lemma sched_context_donate_sc_replies_heap[wp]: by (wpsimp simp: sched_context_donate_def wp: tcb_release_remove_wp) lemma sched_context_donate_valid_sched_misc[wp]: - "sched_context_donate scp t \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) + "sched_context_donate scp t \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (etcbs_of s) (tcb_sts_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) (sc_replies_of s)\" apply (rule hoare_lift_Pf[where f=consumed_time, rotated], wpsimp) apply (rule hoare_lift_Pf[where f=cur_sc, rotated], wpsimp) - apply (rule hoare_lift_Pf[where f=ep_send_qs_of, rotated], wpsimp) - apply (rule hoare_lift_Pf[where f=ep_recv_qs_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ntfns_of, rotated], wpsimp) apply (rule hoare_lift_Pf[where f=cur_time, rotated], wpsimp) apply (rule hoare_lift_Pf[where f=cur_domain, rotated], wpsimp) apply (rule hoare_lift_Pf[where f=cur_thread, rotated], wpsimp) @@ -2164,14 +2280,46 @@ lemmas as_user_sk_obj_at_preds[wp] = as_user_sk_obj_at_pred[where C=Notification, simplified] as_user_sk_obj_at_pred[where C=Reply, simplified] +lemma as_user_eps_of[wp]: + "as_user t m \\s. P (eps_of s)\" + by (set_object_easy_cases def: as_user_def) + +lemma as_user_ntfns_of[wp]: + "as_user t m \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: as_user_def) + +lemma as_user_prios_of[wp]: + "as_user t m \\s. P (prios_of s)\" + unfolding as_user_def + apply (wpsimp wp: set_object_wp) + apply (erule rsubst[where P=P]) + apply (frule get_tcb_ko_atI) + apply (fastforce simp: obj_at_def opt_map_def tcbs_of_kh_def split: option.splits) + done + lemma as_user_valid_sched_pred[wp]: "as_user t m \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf2[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) by (wpsimp wp: as_user_tcb_arch_inv simp: fun_upd_def vs_all_heap_simps) \ \complete_yield_to\ +crunch sched_context_update_consumed + for eps_of[wp]: "\s. P (eps_of s)" + and ntfns_of[wp]: "\s. P (ntfns_of s)" + and prios_of[wp]: "\s. P (prios_of s)" + lemma sched_context_update_consumed_valid_sched_pred[wp]: "sched_context_update_consumed scp \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf2[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) apply (wpsimp simp: sched_context_update_consumed_def wp: update_sched_context_wp) by (clarsimp simp: fun_upd_def obj_at_kh_kheap_simps vs_all_heap_simps) @@ -2380,12 +2528,11 @@ crunch handle_reserved_irq end lemma switch_to_idle_thread_valid_sched_pred[valid_sched_wp]: - "\\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) - (cur_time s) (cur_domain s) (idle_thread s) (idle_thread s) - (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) + "\\s. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (idle_thread s) (idle_thread s) + (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)\ + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ switch_to_idle_thread \\rv. valid_sched_pred_strong P :: 'state_ext state \ _\" by (wpsimp simp: switch_to_idle_thread_def) @@ -2468,6 +2615,10 @@ lemma activate_thread_released_ipc_queues[wp]: apply (wpsimp simp: activate_thread_def wp: valid_sched_wp gts_wp') by (clarsimp simp: vs_all_heap_simps elim!: released_ipc_queuesE) +lemma activate_thread_sorted_ipc_queues[wp]: + "activate_thread \sorted_ipc_queues_except_set S :: 'state_ext state \ _\" + by (wpsimp simp: activate_thread_def wp: gts_wp') + lemma activate_thread_valid_sched[wp]: "activate_thread \valid_sched :: 'state_ext state \ _\" by (wpsimp simp: valid_sched_def) @@ -2475,12 +2626,13 @@ lemma activate_thread_valid_sched[wp]: \ \We can't write a wp-style rule, because we don't know how some arch functions update arch state.\ lemma switch_to_thread_valid_sched_pred[valid_sched_wp]: "\\s. \d p. etcb_eq p d t s - \ P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) - (cur_time s) (cur_domain s) t (idle_thread s) + \ P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) t (idle_thread s) (tcb_sched_ready_q_update d p (tcb_sched_dequeue t) (ready_queues s)) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)\ + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) + (prios_of s)\ switch_to_thread t \\rv. valid_sched_pred_strong P :: 'state_ext state \ _\" by (wpsimp simp: switch_to_thread_def @@ -2488,12 +2640,14 @@ lemma switch_to_thread_valid_sched_pred[valid_sched_wp]: lemma guarded_switch_to_valid_sched_pred[valid_sched_wp]: "\\s. \d p. etcb_eq p d t s - \ P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + \ P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) + (time_state_of s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) t (idle_thread s) (tcb_sched_ready_q_update d p (tcb_sched_dequeue t) (ready_queues s)) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)\ + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) + (prios_of s)\ guarded_switch_to t \\rv. valid_sched_pred_strong P :: 'state_ext state \ _\" by (wpsimp simp: guarded_switch_to_def released_sc_tcb_at_def @@ -2501,20 +2655,20 @@ lemma guarded_switch_to_valid_sched_pred[valid_sched_wp]: lemma switch_to_thread_valid_sched_misc[wp]: "switch_to_thread t - \\s::'state_ext state. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) + \\s::'state_ext state. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (sc_tcbs_of s) (sc_replies_of s) (cur_time s) (cur_domain s) (idle_thread s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) - (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s)\" + (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) (prios_of s)\" by (wpsimp wp: valid_sched_wp) lemma guarded_switch_to_valid_sched_misc[wp]: "guarded_switch_to t - \\s::'state_ext state. P (consumed_time s) (cur_sc s) (ep_send_qs_of s ) (ep_recv_qs_of s) + \\s::'state_ext state. P (consumed_time s) (cur_sc s) (eps_of s ) (ntfns_of s) (sc_tcbs_of s) (sc_replies_of s) (cur_time s) (cur_domain s) (idle_thread s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) - (tcb_faults_of s) (sc_refill_cfgs_of s)\" + (tcb_faults_of s) (sc_refill_cfgs_of s) (prios_of s)\" by (wpsimp wp: valid_sched_wp) crunch switch_to_thread @@ -2601,7 +2755,7 @@ lemma switch_to_thread_ready_or_release[wp]: lemma switch_to_thread_valid_sched: "\is_activatable t and in_cur_domain t and valid_sched_action and valid_ready_qs and valid_release_q and ready_or_release and valid_blocked and valid_idle_etcb - and released_ipc_queues and active_reply_scs and active_scs_valid + and released_ipc_queues and active_reply_scs and active_scs_valid and sorted_ipc_queues and (\s. (active_sc_tcb_at (cur_thread s) s \ ct_not_in_release_q s) \ ct_in_q s)\ switch_to_thread t @@ -2633,7 +2787,7 @@ context DetSchedSchedule_AI begin lemma switch_to_idle_thread_valid_sched: "\valid_sched_action and valid_idle and valid_ready_qs and valid_release_q and valid_blocked and ct_in_q and valid_idle_etcb and released_ipc_queues and ready_or_release - and active_reply_scs and active_scs_valid\ + and active_reply_scs and active_scs_valid and sorted_ipc_queues\ switch_to_idle_thread \\_. valid_sched :: 'state_ext state \ _\" by (wpsimp simp: valid_sched_def) @@ -2645,7 +2799,7 @@ crunch choose_thread lemma choose_thread_valid_sched[wp]: "\valid_sched_action and valid_idle and valid_ready_qs and valid_release_q and ready_or_release and valid_blocked and ct_in_q and valid_idle_etcb and released_ipc_queues and active_reply_scs - and active_scs_valid\ + and active_scs_valid and sorted_ipc_queues\ choose_thread \\_. valid_sched :: 'state_ext state \ _\" apply (wpsimp simp: choose_thread_def @@ -2664,13 +2818,15 @@ lemma do_extended_op_valid_sched_pred[wp]: \ \We leave the resulting cur_domain unspecified, since we can't specify it in terms of state projections that are part of valid_sched_pred\ lemma next_domain_valid_sched_pred[valid_sched_wp]: - "\\s. \cdom'. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + "\\s. \cdom'. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) + (time_state_of s) (eps_of s) (ntfns_of s) (cur_time s) cdom' (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)\ + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) + (prios_of s)\ next_domain - \\rv. valid_sched_pred_strong P\" + \\_. valid_sched_pred_strong P\" by (wpsimp simp: next_domain_def Let_def) crunch next_domain @@ -2824,11 +2980,12 @@ context DetSchedSchedule_AI begin lemma choose_thread_valid_sched_pred[valid_sched_wp]: "\\s. \ct' qs'. choose_thread_spec s ct' qs' - \ P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) - (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) (cur_time s) (cur_domain s) ct' (idle_thread s) qs' - (release_queue s) (scheduler_action s) + \ P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) + (time_state_of s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) ct' + (idle_thread s) qs' (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)\ + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) + (prios_of s)\ choose_thread \\rv. valid_sched_pred_strong P :: 'state_ext state \ _\" apply (wpsimp simp: choose_thread_def wp: valid_sched_wp) @@ -2837,11 +2994,11 @@ lemma choose_thread_valid_sched_pred[valid_sched_wp]: lemma choose_thread_valid_sched_misc[wp]: "choose_thread - \\s::'state_ext state. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) + \\s::'state_ext state. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (sc_tcbs_of s) (sc_replies_of s) (cur_time s) (cur_domain s) (idle_thread s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) - (tcb_faults_of s) (sc_refill_cfgs_of s)\" + (tcb_faults_of s) (sc_refill_cfgs_of s) (prios_of s)\" by (wpsimp wp: valid_sched_wp) lemma choose_thread_ct_not_queued: @@ -2899,16 +3056,16 @@ lemmas choose_thread_ct_activatable' = choose_thread_ct_activatable[folded obj_at_kh_kheap_simps] lemma schedule_choose_new_thread_valid_sched_misc[wp]: - "\\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) + "\\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (sc_tcbs_of s) (cur_time s) (idle_thread s) (release_queue s) resume_cur_thread (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) - (sc_replies_of s)\ + (sc_replies_of s) (prios_of s)\ schedule_choose_new_thread - \\_ s::'state_ext state. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) + \\_ s::'state_ext state. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (sc_tcbs_of s) (cur_time s) (idle_thread s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) - (sc_replies_of s)\" + (sc_replies_of s) (prios_of s)\" unfolding schedule_choose_new_thread_def by (wpsimp wp: set_scheduler_action_wp) @@ -3040,11 +3197,12 @@ context DetSchedSchedule_AI begin lemma schedule_choose_new_thread_valid_sched_except_domain[valid_sched_wp]: "\\s. \cdom' ct' qs'. schedule_choose_new_thread_spec s cdom' ct' qs' - \ P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) - (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) (cur_time s) cdom' ct' (idle_thread s) qs' - (release_queue s) resume_cur_thread + \ P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) + (time_state_of s) (eps_of s) (ntfns_of s) (cur_time s) cdom' ct' + (idle_thread s) qs' (release_queue s) resume_cur_thread (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)\ + (sc_refill_cfgs_of s) (sc_replies_of s) + (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ schedule_choose_new_thread \\rv. valid_sched_pred_strong P :: 'state_ext state \ _\" by (wpsimp simp: schedule_choose_new_thread_def wp: valid_sched_wp) @@ -3063,7 +3221,7 @@ lemma schedule_choose_new_thread_valid_sched: and (\s. scheduler_action s = choose_new_thread) and (\s. active_sc_tcb_at (cur_thread s) s \ ct_not_in_release_q s \ ct_in_q s) and released_ipc_queues and active_reply_scs - and active_scs_valid\ + and active_scs_valid and sorted_ipc_queues\ schedule_choose_new_thread \\_. valid_sched :: 'state_ext state \ _\" apply (wpsimp simp: valid_sched_wpsimps wp: valid_sched_wp) @@ -3089,89 +3247,9 @@ lemma schedule_choose_new_thread_ct_not_in_release_q: end -(* FIXME: Should tcb_release_enqueue be defined using takeWhile/dropWhile? - As shown here, they're equivalent for sorted lists, so perhaps it doesn't matter. *) -definition insort_filter :: "('a \ bool) \ 'a \ 'a list \ 'a list" where - "insort_filter P x xs \ filter P xs @ x # filter (\x. \ P x) xs" - -definition insort_partition :: "('a \ bool) \ 'a \ 'a list \ 'a list" where - "insort_partition P x xs \ takeWhile P xs @ x # dropWhile P xs" - -lemma sorted_filter_takeWhile: - assumes tr: "transp cmp" - shows "sorted_wrt cmp xs \ filter (\x. cmp x y) xs = takeWhile (\x. cmp x y) xs" -proof (induct xs) - case (Cons x xs) - have xs: "sorted_wrt cmp xs" and x: "\z\set xs. cmp x z" using Cons.prems by auto - note eq = Cons.hyps[OF xs, symmetric] - show ?case - apply (clarsimp simp: eq filter_empty_conv dest!: bspec[OF x]) - by (drule (1) transpD[OF tr], simp) -qed auto - -lemma sorted_not_filter_dropWhile: - assumes tr: "transp cmp" - shows "sorted_wrt cmp xs \ filter (\x. \ cmp x y) xs = dropWhile (\x. cmp x y) xs" -proof (induct xs) - case (Cons x xs) - have xs: "sorted_wrt cmp xs" and x: "\z\set xs. cmp x z" using Cons.prems by auto - note eq = Cons.hyps[OF xs, symmetric] - show ?case - apply (clarsimp simp: eq filter_id_conv dest!: bspec[OF x]) - by (drule (1) transpD[OF tr], simp) -qed auto - -lemma sorted_insort_filter_eq_insort_partition: - assumes "transp cmp" - assumes "sorted_wrt cmp xs" - shows "insort_filter (\x. cmp x y) x xs = insort_partition (\x. cmp x y) x xs" - by (auto simp: insort_filter_def insort_partition_def - sorted_filter_takeWhile[OF assms] sorted_not_filter_dropWhile[OF assms]) - -lemma total_reflD: - "total {(x,y). cmp x y} \ reflp cmp \ \ cmp a b \ cmp b a" - apply (case_tac "a=b") - apply (fastforce dest: reflpD) - by (fastforce simp: total_on_def) - -lemma sorted_insort_partition: - assumes tot: "total {(x,y). cmp x y}" - assumes tr: "transp cmp" - assumes re: "reflp cmp" - assumes sorted: "sorted_wrt cmp xs" - shows "sorted_wrt cmp (insort_partition (\x. cmp x z) z xs)" - unfolding insort_partition_def - apply (clarsimp simp: sorted_wrt_append, intro conjI) - apply (subst sorted_filter_takeWhile[symmetric, OF tr sorted]) - apply (rule sorted_wrt_filter, rule sorted) - apply (clarsimp simp: sorted_not_filter_dropWhile[symmetric, OF tr sorted]) - apply (fastforce dest: total_reflD[OF tot re]) - apply (subst sorted_not_filter_dropWhile[symmetric, OF tr sorted]) - apply (rule sorted_wrt_filter, rule sorted) - apply (clarsimp, intro conjI) - apply (erule takeWhile_taken_P) - apply (clarsimp simp: sorted_not_filter_dropWhile[symmetric, OF tr sorted]) - apply (drule takeWhile_taken_P) - apply (rule transpD[OF tr], assumption) - apply (fastforce dest: total_reflD[OF tot re]) - done - -lemma sorted_insort_filter: - assumes tot: "total {(x,y). cmp x y}" - assumes tr: "transp cmp" - assumes re: "reflp cmp" - assumes sorted: "sorted_wrt cmp xs" - shows "sorted_wrt cmp (insort_filter (\x. cmp x z) z xs)" - apply (subst sorted_insort_filter_eq_insort_partition[OF tr sorted]) - by (rule sorted_insort_partition[OF tot tr re sorted]) - definition tcb_release_enqueue_upd :: "(obj_ref \ time) \ obj_ref \ obj_ref list \ obj_ref list" where "tcb_release_enqueue_upd tcb_ready_times t \ insort_filter (\t'. img_ord (the \ tcb_ready_times) (\) t' t) t" -lemma map_fst_filter_zip_map_reduce: - "map fst (filter P (zip xs (map f xs))) = filter (\x. P (x, f x)) xs" - by (induct xs) auto - lemma tcb_release_enqueue_wp': "\\s. tcb_sc_refill_cfgs_of s t \ None \ (\rt. tcb_ready_times_of s t = Some rt \ @@ -3367,50 +3445,83 @@ lemma possible_switch_to_valid_ready_qs: \ \set_simple_ko functions\ -lemma set_endpoint_idle_valid_sched_pred[wp]: - "\\s. P (consumed_time s) (cur_sc s) ((ep_send_qs_of s)(ep_ptr := None)) - ((ep_recv_qs_of s)(ep_ptr := None)) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) - (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) - (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s) \ - set_endpoint ep_ptr IdleEP - \\_. valid_sched_pred_strong P\" - apply (wpsimp wp: set_simple_ko_wp) - by (clarsimp simp: fun_upd_def ep_at_pred_def obj_at_def vs_all_heap_simps) - -lemma set_endpoint_send_valid_sched_pred[wp]: - "\\s. P (consumed_time s) (cur_sc s) ((ep_send_qs_of s)(ep_ptr := Some queue)) - ((ep_recv_qs_of s)(ep_ptr := None)) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) - (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) - (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s) \ - set_endpoint ep_ptr (SendEP queue) - \\_. valid_sched_pred_strong P\" - apply (wpsimp wp: set_simple_ko_wp) - by (clarsimp simp: fun_upd_def ep_at_pred_def obj_at_def vs_all_heap_simps) - -lemma set_endpoint_recv_valid_sched_pred[wp]: - "\\s. P (consumed_time s) (cur_sc s) ((ep_send_qs_of s)(ep_ptr := None)) - ((ep_recv_qs_of s)(ep_ptr := Some queue)) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) - (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) - (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s) \ - set_endpoint ep_ptr (RecvEP queue) - \\_. valid_sched_pred_strong P\" - apply (wpsimp wp: set_simple_ko_wp) - by (clarsimp simp: fun_upd_def ep_at_pred_def obj_at_def vs_all_heap_simps) - -lemma set_notification_valid_sched_pred[wp]: - "set_notification ntfn_ptr ntfn \valid_sched_pred_strong P\" - apply (wpsimp simp: set_simple_ko_def wp: set_object_wp get_object_wp) - by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def - split: option.splits kernel_object.splits if_splits) +lemma set_endpoint_ntfns_of[wp]: + "set_endpoint ep_ptr ep \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: set_simple_ko_def) + +lemma set_endpoint_etcbs_of[wp]: + "set_endpoint ep_ptr ep \\s. P (etcbs_of s)\" + apply (wpsimp wp: set_simple_ko_wp get_object_wp) + by (fastforce elim!: rsubst[where P=P] + simp: vs_all_heap_simps obj_at_kh_kheap_simps map_project_def ep_at_pred_def) + +lemma set_endpoint_tcbs_of[wp]: + "set_endpoint ep_ptr ep \\s. P (tcbs_of s)\" + by (set_object_easy_cases def: set_simple_ko_def) + +lemma set_endpoint_scs_of[wp]: + "set_endpoint ep_ptr ep \\s. P (scs_of s)\" + apply (wpsimp wp: set_simple_ko_wp get_object_wp) + by (fastforce elim!: rsubst[where P=P] + simp: vs_all_heap_simps obj_at_kh_kheap_simps ep_at_pred_def) + +lemma set_notification_eps_of[wp]: + "set_notification ntfn_ptr ntfn \\s. P (eps_of s)\" + by (set_object_easy_cases def: set_simple_ko_def) + +lemma set_ntfn_obj_ref_eps_of[wp]: + "set_ntfn_obj_ref update ref new \\s. P (eps_of s)\" + by (set_object_easy_cases def: update_sk_obj_ref_def) + +lemma set_notification_etcbs_of[wp]: + "set_notification ntfn_ptr ntfn \\s. P (etcbs_of s)\" + apply (wpsimp wp: set_simple_ko_wp get_object_wp) + by (fastforce elim!: rsubst[where P=P] + simp: vs_all_heap_simps obj_at_kh_kheap_simps map_project_def ntfn_at_pred_def) + +lemma set_notification_tcbs_of[wp]: + "set_notification ntfn_ptr ntfn \\s. P (tcbs_of s)\" + apply (wpsimp wp: set_simple_ko_wp get_object_wp) + by (fastforce elim!: rsubst[where P=P] + simp: vs_all_heap_simps obj_at_kh_kheap_simps map_project_def ntfn_at_pred_def) + +lemma set_notification_scs_of[wp]: + "set_notification ntfn_ptr ntfn \\s. P (scs_of s)\" + apply (wpsimp wp: set_simple_ko_wp get_object_wp) + by (fastforce elim!: rsubst[where P=P] + simp: vs_all_heap_simps obj_at_kh_kheap_simps map_project_def ntfn_at_pred_def) + +lemma set_reply_eps_of[wp]: + "set_reply reply_ptr reply \\s. P (eps_of s)\" + by (set_object_easy_cases def: set_simple_ko_def) + +lemma set_reply_ntfns_of[wp]: + "set_reply reply_ptr reply \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: set_simple_ko_def) + +lemma set_reply_etcbs_of[wp]: + "set_reply reply_ptr reply \\s. P (etcbs_of s)\" + apply (wpsimp wp: set_simple_ko_wp get_object_wp) + by (fastforce elim!: rsubst[where P=P] + simp: vs_all_heap_simps obj_at_kh_kheap_simps map_project_def reply_at_pred_def) + +lemma set_reply_tcbs_of[wp]: + "set_reply reply_ptr reply \\s. P (tcbs_of s)\" + by (set_object_easy_cases def: set_simple_ko_def) + +lemma set_reply_scs_of[wp]: + "set_reply reply_ptr reply \\s. P (scs_of s)\" + apply (wpsimp wp: set_simple_ko_wp get_object_wp) + by (fastforce elim!: rsubst[where P=P] + simp: vs_all_heap_simps obj_at_kh_kheap_simps map_project_def reply_at_pred_def) lemma set_replies_valid_sched_pred[wp]: "set_reply reply_ptr reply \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf2[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) apply (wpsimp simp: set_simple_ko_def wp: set_object_wp get_object_wp) by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def split: option.splits kernel_object.splits if_splits) @@ -3419,17 +3530,13 @@ lemma set_reply_obj_ref_valid_sched_pred[wp]: "set_reply_obj_ref update ref new \valid_sched_pred_strong P\" by (wpsimp simp: update_sk_obj_ref_def wp: set_object_wp get_object_wp) -lemma set_notification_obj_ref_valid_sched_pred[wp]: - "set_ntfn_obj_ref update ref new \valid_sched_pred_strong P\" - by (wpsimp simp: update_sk_obj_ref_def wp: set_object_wp get_object_wp) - lemma set_simple_ko_valid_sched_pred[wp]: "set_simple_ko f ptr ep \\s. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)\" + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (tcbs_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (machine_state s)\" apply (wpsimp simp: set_simple_ko_def wp: set_object_wp_strong get_object_wp) by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def split: option.splits kernel_object.splits if_splits) @@ -3473,12 +3580,18 @@ lemma possible_switch_to_valid_sched_action[wp]: lemma reply_unlink_sc_valid_sched_misc[wp]: "reply_unlink_sc sc_ptr reply_ptr - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) - (ready_queues s) (release_queue s) (scheduler_action s) + (ready_queues s) (release_queue s) (scheduler_action s) (last_machine_time_of s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s)\" - by (wpsimp simp: reply_unlink_sc_def wp: get_simple_ko_wp) + (sc_refill_cfgs_of s) (sc_tcbs_of s) \" + apply (rule hoare_lift_Pf2[where f=sc_tcbs_of, rotated]) + apply (wpsimp simp: reply_unlink_sc_def wp: get_simple_ko_wp) + apply (rule hoare_lift_Pf2[where f=sc_refill_cfgs_of, rotated]) + apply (wpsimp simp: reply_unlink_sc_def wp: update_sched_context_wp get_simple_ko_wp) + apply (clarsimp simp: obj_at_def vs_all_heap_simps fun_upd_def) + apply (wpsimp simp: reply_unlink_sc_def wp: get_simple_ko_wp) + done lemma reply_unlink_tcb_valid_sched_pred_lift: assumes "\\s::'z::state_ext state. valid_sched_pred_strong P' s\ @@ -3494,11 +3607,14 @@ lemma reply_unlink_tcb_valid_sched_pred_lift: lemma reply_unlink_tcb_valid_sched_pred[valid_sched_wp]: "\\s. pred_map (\st. reply_object st = Some r ) (tcb_sts_of s) t \ - P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) - (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) - (if t = cur_thread s \ scheduler_action s = resume_cur_thread then choose_new_thread else scheduler_action s) + P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) + (ready_queues s) (release_queue s) + (if t = cur_thread s \ scheduler_action s = resume_cur_thread + then choose_new_thread + else scheduler_action s) (etcbs_of s) ((tcb_sts_of s)(t \ Inactive)) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)\ + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ reply_unlink_tcb t r \\_. valid_sched_pred_strong P\" apply (rule reply_unlink_tcb_valid_sched_pred_lift) @@ -3506,10 +3622,10 @@ lemma reply_unlink_tcb_valid_sched_pred[valid_sched_wp]: lemma reply_unlink_tcb_valid_sched_misc[wp]: "reply_unlink_tcb t r - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (sc_tcbs_of s) (sc_replies_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (etcbs_of s) (tcb_scps_of s) - (tcb_faults_of s) (sc_refill_cfgs_of s)\" + (tcb_faults_of s) (sc_refill_cfgs_of s) (prios_of s)\" by (wpsimp wp: reply_unlink_tcb_valid_sched_pred) lemma valid_sched_scheduler_act_not: @@ -3524,7 +3640,8 @@ lemma valid_sched_scheduler_act_not_better: lemma reply_unlink_tcb_valid_sched: "reply_unlink_tcb t rptr \valid_sched\" - apply (wpsimp wp: reply_unlink_tcb_valid_sched_pred_lift[OF set_thread_state_Inactive_not_runnable_valid_sched]) + apply (wpsimp wp: reply_unlink_tcb_valid_sched_pred_lift + set_thread_state_Inactive_not_runnable_valid_sched) by (auto simp: vs_all_heap_simps valid_sched_valid_sched_except_blocked runnable_eq) lemma reply_unlink_tcb_valid_release_q: @@ -3564,7 +3681,8 @@ lemma reply_unlink_tcb_valid_sched_except_blocked: "\valid_sched_except_blocked \ reply_unlink_tcb t rptr \\_. valid_sched_except_blocked\" - apply (wpsimp wp: reply_unlink_tcb_valid_sched_pred_lift[OF set_thread_state_Inactive_not_runnable_valid_sched_except_blocked]) + apply (wpsimp wp: reply_unlink_tcb_valid_sched_pred_lift + set_thread_state_Inactive_not_runnable_valid_sched_except_blocked) by (auto simp: vs_all_heap_simps runnable_eq) lemma reply_unlink_tcb_valid_blocked_except_set: @@ -3583,10 +3701,10 @@ lemma get_tcb_NoneD: "get_tcb t s = None \ \ (\v. k lemma update_sk_obj_ref_valid_sched_misc[wp]: "update_sk_obj_ref C f ref new \\s. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) - (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) - (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s)\" + (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (sc_tcbs_of s) (machine_state s)\" by (wpsimp simp: update_sk_obj_ref_def) lemma set_scheduler_action_swt_valid_sched_except_blocked: @@ -3657,14 +3775,24 @@ lemma set_thread_state_valid_sched: (* refill_unblock_check lemmas *) +crunch refill_unblock_check + for eps_of[wp]: "\s. P (eps_of s)" + and ntfns_of[wp]: "\s. P (ntfns_of s)" + and prios_of[wp]: "\s. P (prios_of s)" + (wp: crunch_wps simp: crunch_simps) + lemma refill_unblock_check_valid_sched_misc[wp]: "refill_unblock_check scptr - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_replies_of s)\" + (last_machine_time_of s) (tcbs_of s) (sc_tcbs_of s) (sc_replies_of s)\" unfolding refill_unblock_check_defs - apply (wpsimp wp: hoare_drop_imp whileLoop_valid_inv) + apply (rule hoare_lift_Pf2[where f=tcbs_of]) + apply (wpsimp wp: whileLoop_valid_inv) + apply (rule hoare_lift_Pf2[where f=sc_replies_of]) + apply (wpsimp wp: whileLoop_valid_inv) + apply (wpsimp wp: whileLoop_valid_inv) done lemma refill_unblock_check_valid_blocked_except_set[wp]: @@ -4464,10 +4592,11 @@ lemma refill_unblock_check_valid_sched: (* end : refill_unblock_check lemmas *) crunch if_cond_refill_unblock_check - for valid_sched_misc[wp]: "\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) - (sc_tcbs_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) - (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) - (tcb_faults_of s) (sc_replies_of s)" + for valid_sched_misc[wp]: + "\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) + (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) + (ready_queues s) (release_queue s) (scheduler_action s) + (last_machine_time_of s) (tcbs_of s) (sc_replies_of s) (sc_tcbs_of s)" and valid_blocked_except[wp]: "valid_blocked_except t" and released_sc_tcb_at[wp]: "released_sc_tcb_at t" (simp: crunch_simps wp: refill_unblock_check_valid_sched_except_blocked) @@ -4498,12 +4627,13 @@ lemma map_option_scrc_refills_update_rewrite: done lemma refill_budget_check_round_robin_sc_refills_update_unspecified: - "\\s. \f. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) - (last_machine_time_of s) (time_state_of s) + "\\s. \f. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) + (last_machine_time_of s) (time_state_of s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (heap_upd (scrc_refills_update f) (cur_sc s) (sc_refill_cfgs_of s)) (sc_replies_of s)\ + (heap_upd (scrc_refills_update f) (cur_sc s) (sc_refill_cfgs_of s)) (sc_replies_of s) + (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ refill_budget_check_round_robin usage \\_. valid_sched_pred_strong P\" unfolding refill_budget_check_round_robin_def update_refill_tl_def update_refill_hd_def @@ -4567,24 +4697,31 @@ lemma refill_budget_check_cur_sc_active[wp]: "refill_budget_check usage \cur_sc_active\" by (rule cur_sc_active_lift; wpsimp) +crunch refill_budget_check_round_robin + for eps_of[wp]: "\s. P (eps_of s)" + and ntfns_of[wp]: "\s. P (ntfns_of s)" + and prios_of[wp]: "\s. P (prios_of s)" + (wp: crunch_wps) + lemma refill_budget_check_round_robin_valid_sched_misc[wp]: "refill_budget_check_round_robin consumed - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) - (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) - (release_queue s) (scheduler_action s) (etcbs_of s) - (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_replies_of s)\" + \\s. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (eps_of s) (ntfns_of s) + (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) + (ready_queues s) (release_queue s) (scheduler_action s) + (last_machine_time_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (etcbs_of s) (sc_replies_of s) (prios_of s)\" unfolding refill_budget_check_round_robin_def update_refill_tl_def update_refill_hd_def by (wpsimp wp: hoare_drop_imp) lemma refill_budget_check_valid_sched_misc[wp]: "refill_budget_check consumed - \\s. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (cur_time s) (cur_domain s) (cur_thread s) - (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_replies_of s) - (ep_send_qs_of s) (ep_recv_qs_of s)\" + \\s. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (eps_of s) (ntfns_of s) + (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) + (ready_queues s) (release_queue s) (scheduler_action s) + (last_machine_time_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (etcbs_of s) (sc_replies_of s) (prios_of s)\" unfolding refill_budget_check_defs schedule_used_defs - apply (wpsimp wp: hoare_drop_imp whileLoop_valid_inv) - done + by (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift whileLoop_valid_inv get_refills_wp) lemma commit_time_is_active_sc[wp]: "commit_time \\s. P (is_active_sc scp s)\" @@ -4597,30 +4734,37 @@ lemma commit_time_cur_sc_active[wp]: lemma maybe_add_empty_tail_valid_sched_misc[wp]: "maybe_add_empty_tail sc_ptr - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_replies_of s)\" + (last_machine_time_of s) (time_state_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_tcbs_of s) (etcbs_of s) (sc_replies_of s) (prios_of s)\" unfolding maybe_add_empty_tail_def refill_add_tail_def set_refills_def - by (wpsimp wp: is_round_robin_wp) + apply (rule hoare_lift_Pf2[where f=sc_replies_of, rotated]) + apply (wpsimp wp: is_round_robin_wp) + apply (wpsimp wp: is_round_robin_wp) + done lemma refill_new_valid_sched_misc[wp]: "refill_new sc_ptr max_refills budget period - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_replies_of s)\" - unfolding refill_new_def by wpsimp + (last_machine_time_of s) (time_state_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_tcbs_of s) (etcbs_of s) (sc_replies_of s) (prios_of s)\" + unfolding refill_new_def + by (rule hoare_lift_Pf2[where f=sc_replies_of, rotated]; wpsimp) lemma refill_update_valid_sched_misc[wp]: "refill_update sc_ptr period budget mrefills - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_replies_of s)\" + (last_machine_time_of s) (time_state_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_tcbs_of s) (etcbs_of s) (sc_replies_of s) (prios_of s)\" unfolding refill_update_def refill_add_tail_def update_refill_tl_def update_refill_hd_def - apply (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift) - done + by (rule hoare_lift_Pf2[where f=sc_replies_of, rotated]; + wpsimp wp: hoare_drop_imps hoare_vcg_all_lift) lemma maybe_add_empty_tail_is_active_sc[wp]: "maybe_add_empty_tail sc_ptr \\s. Q (is_active_sc scp s)\" @@ -4704,17 +4848,15 @@ lemma thread_set_valid_sched_misc[wp]: lemma reply_push_valid_sched_misc[wp]: "reply_push caller callee reply_ptr can_donate - \\s. P (consumed_time s) (cur_sc s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) - (etcbs_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) - (ep_send_qs_of s) (ep_recv_qs_of s)\" + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) + (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (etcbs_of s) + (tcb_faults_of s) (sc_refill_cfgs_of s)\" by (wpsimp wp: get_simple_ko_wp hoare_vcg_if_lift2 hoare_drop_imps hoare_vcg_all_lift simp: reply_push_def bind_sc_reply_def) crunch bind_sc_reply - for pspace_distinct[wp]: pspace_distinct - and pspace_aligned[wp]: pspace_aligned - and active_scs_valid[wp]: active_scs_valid - (ignore: update_sched_context) + for active_scs_valid[wp]: active_scs_valid + (ignore: update_sched_context wp: update_sc_replies_valid_sched_pred) crunch set_cdt,set_original,set_extra_badge for valid_refills[wp]: "valid_refills scp" @@ -4899,7 +5041,7 @@ crunch restart_thread_if_no_fault for misc[wp]: "\s. P (tcb_scps_of s) (sc_tcbs_of s) (idle_thread s)" and active_scs_valid[wp]: active_scs_valid and current_time_bounded[wp]: current_time_bounded - (simp: crunch_simps wp: crunch_wps) + (simp: crunch_simps wp: crunch_wps ignore: update_sched_context) lemma cancel_all_ipc_loop_valid_sched: "\(\s. \t\set queue. blocked_on_send_recv_tcb_at t s \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) @@ -4913,26 +5055,78 @@ lemma cancel_all_ipc_loop_valid_sched: simp: cancel_all_ipc_loop_body_def)+ done +(* FIXME RT: move *) +lemma sorted_wrt_subseq: + "\sorted_wrt P ys; subseq xs ys\ \ sorted_wrt P xs" + apply (induct xs arbitrary: ys) + apply fastforce + apply (frule list_emb_ConsD) + apply (clarsimp simp: sorted_wrt_append simp flip: subseq_singleton_left) + done + +(* FIXME RT: move *) +lemma remove1_subseq: + "subseq (remove1 x xs) xs" + by (induct xs; fastforce) + +lemma set_notification_sorted_ipc_queues[wp]: + "\\s. sorted_ipc_queues_except ntfn_ptr s + \ priority_ordered (ntfn_queue (ntfn_obj ntfn)) (prios_of s)\ + set_notification ntfn_ptr ntfn + \\_. sorted_ipc_queues\" + apply (wpsimp wp: set_simple_ko_wp) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (prop_tac "tcbs_of s ntfn_ptr = None") + apply (clarsimp simp: obj_at_def tcbs_of_kh_def opt_map_def is_ntfn_def) + apply (rename_tac ko, case_tac ko; clarsimp simp: ntfn_at_pred_def) + apply (clarsimp simp: obj_at_def eps_of_kh_def tcbs_of_kh_def) + done + +lemma set_endpoint_sorted_ipc_queues[wp]: + "\\s. sorted_ipc_queues_except ep_ptr s \ priority_ordered (ep_queue ep) (prios_of s)\ + set_endpoint ep_ptr ep + \\_. sorted_ipc_queues\" + apply (wpsimp wp: set_simple_ko_wp) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (prop_tac "tcbs_of s ep_ptr = None") + apply (clarsimp simp: obj_at_def tcbs_of_kh_def opt_map_def is_ep_def) + apply (rename_tac ko, case_tac ko; clarsimp simp: ep_at_pred_def) + apply (clarsimp simp: obj_at_def eps_of_kh_def tcbs_of_kh_def) + done + +lemma set_endpoint_valid_sched: + "\\s. valid_sched s \ priority_ordered (ep_queue ep) (prios_of s)\ + set_endpoint ep_ptr ep + \\_. valid_sched\" + apply (clarsimp simp: valid_sched_def) + apply wpsimp + apply (clarsimp simp: sorted_ipc_queues_def) + done + +lemma set_endpoint_valid_sched_except_blocked: + "\\s. valid_sched_except_blocked s \ priority_ordered (ep_queue ep) (prios_of s)\ + set_endpoint ep_ptr ep + \\_. valid_sched_except_blocked\" + apply (clarsimp simp: valid_sched_def) + apply wpsimp + apply (clarsimp simp: sorted_ipc_queues_def) + done + lemma cancel_all_ipc_valid_sched: "\\s. valid_sched s \ valid_objs s \ valid_idle s \ sym_refs (state_refs_of s) \ current_time_bounded s\ cancel_all_ipc epptr - \\rv. valid_sched\" + \\_. valid_sched\" unfolding cancel_all_ipc_def endpoint.case_eq_if apply (wpsimp wp: reschedule_valid_sched_const cancel_all_ipc_loop_valid_sched - get_simple_ko_wp get_ep_queue_wp' + get_simple_ko_wp get_ep_queue_wp' set_endpoint_valid_sched simp: obj_at_def) - apply (erule (1) pspace_valid_objsE - ; clarsimp simp: valid_obj_def valid_ep_distinct_queue pred_map_P_not_idle cong: conj_cong) - apply (rename_tac ep q t) - apply (case_tac ep - ; clarsimp simp: ep_queue_of_def valid_ep_def - ; drule (1) bspec - ; clarsimp simp: vs_all_heap_simps obj_at_def is_tcb) - apply (drule_tac y=t and x=epptr and tp=TCBBlockedSend in sym_refsE - ; clarsimp simp: in_state_refs_of_iff in_get_refs in_tcb_st_refs_of_iff) - apply (drule_tac y=t and x=epptr and tp=TCBBlockedRecv in sym_refsE - ; clarsimp simp: in_state_refs_of_iff in_get_refs in_tcb_st_refs_of_iff) + apply (erule (1) pspace_valid_objsE; + clarsimp simp: valid_obj_def valid_ep_distinct_queue pred_map_P_not_idle cong: conj_cong) + apply (prop_tac "ep_queues_of s epptr = Some q") + apply (clarsimp simp: opt_map_def eps_of_kh_def ep_queue_of_def split: endpoint.splits) + apply (frule (3) in_ep_queue_st_tcb_at) + apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps is_blocked_thread_state_defs) done lemma set_thread_state_possible_switch_to_valid_sched_strong: @@ -4948,6 +5142,7 @@ lemma set_thread_state_possible_switch_to_valid_sched_strong: (sc_refill_cfgs_of s)) and active_reply_scs and active_scs_valid + and sorted_ipc_queues and released_if_bound_sc_tcb_at t and (\s. t \ idle_thread s) and K (active ts)\ @@ -5016,18 +5211,37 @@ lemma cancel_all_signals_loop_valid_sched: apply (clarsimp simp: vs_all_heap_simps) by simp +lemma set_notification_valid_sched: + "\\s. valid_sched s \ priority_ordered (ntfn_queue (ntfn_obj ntfn)) (prios_of s)\ + set_notification ntfn_ptr ntfn + \\_. valid_sched\" + apply (clarsimp simp: valid_sched_def) + apply wpsimp + apply (clarsimp simp: sorted_ipc_queues_def) + done + +lemma set_notification_valid_sched_except_blocked: + "\\s. valid_sched_except_blocked s \ priority_ordered (ntfn_queue (ntfn_obj ntfn)) (prios_of s)\ + set_notification ntfn_ptr ntfn + \\_. valid_sched_except_blocked\" + apply (clarsimp simp: valid_sched_def) + apply wpsimp + apply (clarsimp simp: sorted_ipc_queues_def) + done + lemma cancel_all_signals_valid_sched[wp]: "\\s. valid_sched s \ valid_objs s \ valid_idle s \ sym_refs (state_refs_of s) \ current_time_bounded s\ cancel_all_signals ntfnptr - \\rv. valid_sched\" + \\_. valid_sched\" apply (wpsimp wp: reschedule_valid_sched_const cancel_all_signals_loop_valid_sched get_simple_ko_wp + set_notification_valid_sched simp: cancel_all_signals_def obj_at_def) + apply (frule (3) st_in_waitingntfn) apply (erule (1) pspace_valid_objsE) apply (clarsimp simp: valid_obj_def valid_ntfn_distinct_queue pred_map_P_not_idle cong: conj_cong) - apply (rename_tac q t) - by (drule_tac x=ntfnptr and y=t and tp=TCBSignal in sym_refsE - ; clarsimp simp: in_state_refs_of_iff refs_of_rev vs_all_heap_simps) + apply (fastforce simp: vs_all_heap_simps obj_at_kh_kheap_simps) + done lemma thread_set_etcbs: "\\x. tcb_priority (f x) = tcb_priority x; \x. tcb_domain (f x) = tcb_domain x\ \ @@ -5063,23 +5277,41 @@ lemma thread_set_not_state_valid_sched: (\x. tcb_priority (f x) = tcb_priority x) \ (\x. tcb_domain (f x) = tcb_domain x) \ thread_set f tptr \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf2[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp wp: thread_set_prios_of) by (wpsimp wp: thread_set_wp simp: obj_at_kh_kheap_simps vs_all_heap_simps fun_upd_def) -lemma unbind_notification_valid_sched[wp]: - "unbind_notification ntfnptr \valid_sched_pred_strong P\" - by (wpsimp simp: unbind_notification_def wp: get_tcb_obj_ref_wp) +lemma unbind_notification_valid_sched_misc[wp]: + "unbind_notification ntfnptr + \\s. P (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (sc_tcbs_of s) (eps_of s) (ntfn_queues_of s) + (prios_of s) (consumed_time s)\" + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated]) + apply (wpsimp simp: unbind_notification_def update_sk_obj_ref_def + wp: get_tcb_obj_ref_wp get_simple_ko_wp set_simple_ko_wp) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: obj_at_kh_kheap_simps vs_all_heap_simps opt_map_def) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated]) + apply (wpsimp simp: unbind_notification_def wp: get_tcb_obj_ref_wp) + apply (wpsimp simp: unbind_notification_def update_sk_obj_ref_def + wp: get_tcb_obj_ref_wp get_simple_ko_wp) + done lemma sched_context_unbind_tcb_valid_sched_misc[wp]: "sched_context_unbind_tcb sc_ptr - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (cur_time s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (etcbs_of s) (tcb_sts_of s) (tcb_faults_of s) (sc_refill_cfgs_of s)\" - by (wpsimp simp: sched_context_unbind_tcb_def - wp: hoare_drop_imp hoare_vcg_all_lift set_tcb_sched_context_valid_sched_except_tcb_scp_heap) + by (wpsimp simp: sched_context_unbind_tcb_def) lemma sched_context_unbind_all_tcbs_valid_sched_misc[wp]: "sched_context_unbind_all_tcbs sc_ptr - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (cur_time s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (etcbs_of s) (tcb_sts_of s) (tcb_faults_of s) (sc_refill_cfgs_of s)\" unfolding sched_context_unbind_all_tcbs_def @@ -5088,7 +5320,7 @@ lemma sched_context_unbind_all_tcbs_valid_sched_misc[wp]: lemma unbind_from_sc_valid_sched_misc[wp]: "unbind_from_sc tcb_ptr - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (cur_time s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (etcbs_of s) (tcb_sts_of s) (tcb_faults_of s) (sc_refill_cfgs_of s)\" by (wpsimp simp: unbind_from_sc_def wp: hoare_drop_imp hoare_vcg_all_lift) @@ -5176,10 +5408,12 @@ lemma sched_context_donate_ct_in_cur_domain[wp]: lemma sched_context_set_inactive_valid_sched_misc[wp]: "sched_context_set_inactive sc_ptr - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (sc_tcbs_of s) (sc_replies_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (tcbs_of s)\" unfolding sched_context_set_inactive_def + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) by (wpsimp wp: get_sched_context_wp update_sched_context_wp update_sk_obj_ref_wp simp: obj_at_def vs_all_heap_simps fun_upd_def tcb_heap.all_simps) @@ -5473,6 +5707,11 @@ lemma sched_context_donate_ready_or_release[wp]: unfolding sched_context_donate_def by (wpsimp wp: gbn_wp thread_get_wp tcb_release_remove_ready_or_release) +lemma sched_context_donate_sorted_ipc_queues[wp]: + "sched_context_donate sc_ptr tcb_ptr \sorted_ipc_queues_except_set S\" + unfolding sched_context_donate_def + by (wpsimp wp: sorted_ipc_queues_except_set_lift set_tcb_obj_ref_prios_of) + lemma sched_context_donate_valid_sched_except_blocked: "\\s. valid_sched_except_blocked s \ pred_map_eq None (tcb_scps_of s) t \ sched_context_donate_ipc_queues_precond t scp s\ @@ -5550,7 +5789,7 @@ lemma test_reschedule_valid_sched_except_wk_sched_action: test_reschedule t \\_. valid_sched\" apply (wpsimp simp: valid_sched_def wp: test_reschedule_valid_sched_action_except) - by (auto simp: valid_sched_action_def weak_valid_sched_action_def ) + by (auto simp: valid_sched_action_def weak_valid_sched_action_def) lemma set_tcb_sc_update_active_sc_tcb_at_None[wp]: "\\\ set_tcb_obj_ref tcb_sched_context_update t None \\rv s. \ (bound_sc_obj_tcb_at (P (cur_time s)) t s)\" @@ -5723,6 +5962,11 @@ lemma reply_unlink_sc_active_reply_scs[wp]: by (auto simp: obj_at_kh_kheap_simps heap_upd_def vs_all_heap_simps split: if_splits elim!: active_reply_scsE) +lemma reply_unlink_sc_sorted_ipc_queues[wp]: + "reply_unlink_sc sc_ptr reply_ptr \sorted_ipc_queues_except_set S\" + unfolding reply_unlink_sc_def + by (wpsimp wp: get_simple_ko_wp) + lemma reply_unlink_sc_valid_sched[wp]: "reply_unlink_sc sc_ptr reply_ptr \valid_sched\" by (wpsimp simp: valid_sched_def) @@ -5756,7 +6000,8 @@ lemma reply_remove_valid_sched: reply_remove_sched_context_donate_released_ipc_queues) apply (strengthen valid_sched_not_runnable_not_queued valid_sched_scheduler_act_not_better valid_sched_not_runnable_not_in_release_q released_ipc_queues_except_strengthen) - by (auto dest: ipc_queued_thread_state_not_runnable simp: valid_sched_def pred_map_simps tcb_at_kh_simps) + by (auto dest: ipc_queued_thread_state_not_runnable + simp: valid_sched_def pred_map_simps tcb_at_kh_simps) \ \The operations that make up cancel_ipc affect valid_sched_pred in similar ways.\ locale set_thread_state_Inactive_valid_sched_pred_equiv = @@ -5778,6 +6023,8 @@ locale set_thread_state_Inactive_valid_sched_pred_equiv = (tcb_faults_of s) (sc_refill_cfgs_of s)\" assumes non_empty_sc_replies_at[wp]: "\scp. f tptr \\s::'state_ext state. \ non_empty_sc_replies_at scp s\" + assumes sorted_ipc_queues[wp]: + "f tptr \\s::'state_ext state. sorted_ipc_queues s\" context set_thread_state_Inactive_valid_sched_pred_equiv begin @@ -5855,6 +6102,7 @@ lemma valid_sched: \ released_ipc_queues_2 (cur_time s) ((tcb_sts_of s)(tptr \ Inactive)) (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) \ active_reply_scs s + \ sorted_ipc_queues s \ active_scs_valid s \ \ pred_map runnable (tcb_sts_of s) tptr\ f tptr @@ -5873,6 +6121,7 @@ lemma valid_sched_except_blocked: \ released_ipc_queues_2 (cur_time s) ((tcb_sts_of s)(tptr \ Inactive)) (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) \ active_reply_scs s + \ sorted_ipc_queues s \ active_scs_valid s \ \ pred_map runnable (tcb_sts_of s) tptr\ f tptr @@ -5896,27 +6145,85 @@ lemma reply_remove_tcb_non_empty_sc_replies_at[wp]: global_interpretation reply_remove_tcb: set_thread_state_Inactive_valid_sched_pred_equiv "\t. reply_remove_tcb t r" apply unfold_locales - prefer 2 subgoal by wp - unfolding reply_remove_tcb_def - supply if_split[split del] - apply (rule bind_wp[OF _ gts_sp]) - apply (rule bind_wp[OF _ assert_sp], rule hoare_gen_asm_conj) - apply (clarsimp simp: pred_conj_def obj_at_kh_kheap_simps pred_map_eq_normalise) - apply (rule bind_wp_fwd_skip - , solves \wpsimp wp: hoare_drop_imps - simp: obj_at_kh_kheap_simps vs_all_heap_simps fun_upd_def\)+ - by (wpsimp wp: reply_unlink_tcb_valid_sched_pred simp: fun_upd_def) + prefer 2 subgoal by wp + unfolding reply_remove_tcb_def + supply if_split[split del] + apply (rule bind_wp[OF _ gts_sp]) + apply (rule bind_wp[OF _ assert_sp], rule hoare_gen_asm_conj) + apply (clarsimp simp: pred_conj_def obj_at_kh_kheap_simps pred_map_eq_normalise) + apply (rule bind_wp_fwd_skip, + solves \wpsimp wp: hoare_drop_imps + simp: obj_at_kh_kheap_simps vs_all_heap_simps fun_upd_def\)+ + apply (wpsimp wp: reply_unlink_tcb_valid_sched_pred simp: fun_upd_def) + apply (wpsimp wp: get_simple_ko_wp get_sk_obj_ref_wp gts_wp) + done + +lemma set_ntfn_obj_ref_prios_of[wp]: + "set_ntfn_obj_ref f ref v \\s. P (prios_of s)\" + apply (wpsimp wp: update_sk_obj_ref_wp) + by (fastforce simp: obj_at_kh_kheap_simps vs_all_heap_simps elim!: rsubst[where P=P]) + +lemma ntfn_sc_update_valid_sched_misc[wp]: + "set_ntfn_obj_ref ntfn_sc_update ptr f + \\s. P (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (eps_of s) (ntfn_queues_of s) (prios_of s) + (consumed_time s) (machine_state s)\" + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated]) + apply (wpsimp wp: update_sk_obj_ref_wp) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: opt_map_def obj_at_def) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) + apply wpsimp + done + +lemma do_unbind_notification_valid_sched_misc[wp]: + "do_unbind_notification ntfn_ptr tcb_ptr + \\s. P (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (ntfn_queues_of s) (prios_of s) + (consumed_time s) (sc_tcbs_of s) (machine_state s) (eps_of s)\" + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated]) + apply (wpsimp wp: update_sk_obj_ref_wp) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: opt_map_def obj_at_def) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=machine_state, rotated], wpsimp) + apply wpsimp + done -lemma unbind_maybe_notification_valid_sched[wp]: - "unbind_maybe_notification ptr \valid_sched_pred_strong P\" - by (wpsimp wp: get_sk_obj_ref_wp simp: unbind_maybe_notification_def) +lemma unbind_maybe_notification_valid_sched_misc[wp]: + "unbind_maybe_notification ptr + \\s. P (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (ntfn_queues_of s) (prios_of s) + (consumed_time s) (sc_tcbs_of s) (machine_state s) (eps_of s)\" + unfolding unbind_maybe_notification_def + by (wpsimp wp: get_sk_obj_ref_wp) + +lemma cancel_signal_sorted_ipc_queues[wp]: + "cancel_signal t ntfn_ptr \sorted_ipc_queues\" + unfolding cancel_signal_def + apply (wpsimp wp: get_simple_ko_wp) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (drule_tac x=ntfn_ptr in spec) + apply (clarsimp elim!: sorted_wrt_subseq simp: remove1_subseq list_case_If opt_map_def obj_at_def) + done global_interpretation cancel_signal: set_thread_state_Inactive_valid_sched_pred_equiv "\t. cancel_signal t ntfn" apply unfold_locales - unfolding cancel_signal_def - supply if_split[split del] - apply (rule bind_wp_fwd_skip, solves wpsimp, simp?)+ - by (wpsimp wp: set_thread_state_Inactive.valid_sched_pred get_simple_ko_wp simp: fun_upd_def)+ + apply (simp only: cancel_signal_def) + apply (rule bind_wp_fwd_skip, solves wpsimp, simp?)+ + apply (wpsimp wp: set_thread_state_Inactive.valid_sched_pred get_simple_ko_wp simp: fun_upd_def) + apply (clarsimp simp: cancel_signal_def) + apply (wpsimp wp: set_thread_state_Inactive.valid_sched_pred get_simple_ko_wp simp: fun_upd_def) + apply wpsimp + done crunch reply_remove_tcb for st_tcb_at_not_runnable[wp]: "st_tcb_at (\st. \runnable st) t" @@ -5964,12 +6271,22 @@ lemma cancel_all_ipc_loop_body_reply_unlink_ts_pred_other: hoare_vcg_imp_lift') done +lemma blocked_cancel_ipc_sorted_ipc_queues[wp]: + "blocked_cancel_ipc st t r \sorted_ipc_queues\" + unfolding blocked_cancel_ipc_def + apply (wpsimp wp: get_simple_ko_wp simp: get_ep_queue_def get_blocking_object_def) + apply (rename_tac ep_ptr ep) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (drule_tac x=ep_ptr in spec) + apply (fastforce elim!: sorted_wrt_subseq + simp: remove1_subseq list_case_If opt_map_def eps_of_kh_def obj_at_def is_ep_def) + done + global_interpretation blocked_cancel_ipc: set_thread_state_Inactive_valid_sched_pred_equiv "\t. blocked_cancel_ipc st t r" apply unfold_locales - unfolding blocked_cancel_ipc_def - subgoal for P - supply if_split[split del] + subgoal for P + apply (clarsimp simp: blocked_cancel_ipc_def) apply (rule bind_wp_fwd_skip, solves wpsimp, simp?)+ apply (cases r; simp add: bind_assoc; thin_tac _) apply (wpsimp wp: set_thread_state_valid_sched_pred_strong simp: fun_upd_def) @@ -5977,7 +6294,8 @@ global_interpretation blocked_cancel_ipc: reply_unlink_tcb_valid_sched_pred_lift[THEN hoare_drop_assertion]) apply (clarsimp simp: fun_upd_def split: if_splits) done - apply (wpsimp wp: hoare_drop_imp simp: blocked_cancel_ipc_def) + apply (wpsimp wp: hoare_drop_imp simp: blocked_cancel_ipc_def) + apply wpsimp done lemmas cancel_ipc_valid_sched_lemmas @@ -5993,13 +6311,39 @@ crunch sched_context_unbind_yield_from for valid_sched[wp]: "valid_sched_pred_strong P" (wp: maybeM_inv mapM_x_wp') +lemma do_unbind_ntfn_sc_valid_sched_misc[wp]: + "do_unbind_ntfn_sc ntfn scptr + \\s. P (consumed_time s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (sc_tcbs_of s) + (eps_of s) (ntfn_queues_of s) (prios_of s)\" + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated]) + apply (wpsimp wp: update_sk_obj_ref_wp) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: opt_map_def obj_at_def) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) + by wpsimp + lemma sched_context_unbind_ntfn_valid_sched[wp]: - "sched_context_unbind_ntfn scptr \valid_sched_pred_strong P\" - by (wpsimp wp: get_sc_obj_ref_wp simp: sched_context_unbind_ntfn_def) + "sched_context_unbind_ntfn sc_ptr + \\s. P (consumed_time s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (sc_tcbs_of s) + (eps_of s) (ntfn_queues_of s) (prios_of s)\" + unfolding sched_context_unbind_ntfn_def + by (wpsimp simp: get_sc_obj_ref_def) lemma sched_context_maybe_unbind_ntfn_valid_sched[wp]: - "sched_context_maybe_unbind_ntfn scptr \valid_sched_pred_strong P\" - by (wpsimp wp: get_sk_obj_ref_wp simp: sched_context_maybe_unbind_ntfn_def) + "sched_context_maybe_unbind_ntfn ntfn_ptr + \\s. P (consumed_time s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_tcbs_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (eps_of s) (ntfn_queues_of s) (prios_of s)\" + unfolding sched_context_maybe_unbind_ntfn_def + by (wpsimp wp: get_sk_obj_ref_wp) (* FIXME: Move *) lemma sym_ref_tcb_reply_Receive: @@ -6016,21 +6360,27 @@ lemma sym_ref_tcb_reply_Receive: done lemma thread_set_fault_valid_sched_pred: - "\\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) - (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) + "\\s. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (last_machine_time_of s) (time_state_of s) + (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (heap_upd f tptr (tcb_faults_of s)) - (sc_refill_cfgs_of s) (sc_replies_of s)\ + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) (prios_of s)\ thread_set (tcb_fault_update f) tptr - \\rv. valid_sched_pred_strong P\" + \\_. valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf2[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp wp: thread_set_prios_of) apply (wpsimp wp: thread_set_wp) by (auto simp: heap_upd_def fun_upd_def obj_at_kh_kheap_simps vs_all_heap_simps - elim!: rsubst[of "\t::obj_ref \ fault option. P _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ t _ _ :: bool"] + elim!: rsubst[of "\t::obj_ref \ fault option. P _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ t _ _ _ _ _ :: bool"] split: if_splits) lemmas thread_set_fault_valid_sched_misc[wp] - = thread_set_fault_valid_sched_pred[where P="\cons csc ep_send_qs ep_recv_qs tcbs lmt ts ctime cdom ct it qs rq sa etcbs sts scps _ scrcs reps. - P cons csc ep_send_qs ep_recv_qs tcbs lmt ts ctime cdom ct it qs rq sa etcbs sts scps scrcs reps :: bool" for P] + = thread_set_fault_valid_sched_pred[ + where P="\cons csc tcbs lmt ts eps ntfns ctime cdom ct it qs rq sa etcbs sts scps _ scrcs reps epqs ntfnqs prios. + P cons csc tcbs lmt ts eps ntfns ctime cdom ct it qs rq sa etcbs sts scps scrcs reps epqs ntfnqs prios :: bool" for P] lemma cancel_ipc_valid_sched[wp]: "cancel_ipc tptr \valid_sched\" @@ -6049,7 +6399,9 @@ lemma cancel_ipc_valid_sched[wp]: \ released_ipc_queues_2 (cur_time s) ((tcb_sts_of s)(tptr \ Inactive)) (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) \ active_reply_scs s - \ active_scs_valid s" in bind_wp) + \ active_scs_valid s + \ sorted_ipc_queues s" + in bind_wp) apply (wpsimp wp: cancel_ipc_valid_sched_lemmas) apply (prop_tac "\ ipc_queued_thread_state state \ valid_sched s") apply (fastforce simp: valid_sched_def vs_all_heap_simps runnable_eq fun_upd_def @@ -6104,36 +6456,10 @@ lemma cancel_ipc_not_queued[wp]: apply (case_tac state; wpsimp) done -lemma distinct_zip_snd_unique: - "\distinct xs; (a, b) \ set (zip xs ys); (a, b') \ set (zip xs ys)\ - \ b = b'" - apply (induct xs arbitrary: ys, simp) - apply (clarsimp simp: zip_Cons1) - apply (erule disjE, fastforce dest!: in_set_zipE) - apply (erule disjE, fastforce dest!: in_set_zipE, clarsimp) - done - -lemma set_insort_filter_insert: - "set (insort_filter P x xs) = insert x (set xs)" - by (auto simp: insort_filter_def) - lemma set_tcb_release_enqueue_upd_insert: "set (tcb_release_enqueue_upd ready_times t queue) = insert t (set queue)" by (simp add: tcb_release_enqueue_upd_def set_insort_filter_insert) -lemma distinct_filter_iff: - "distinct xs \ distinct (filter P xs) \ distinct (filter (Not \ P) xs)" -proof (induct xs) - case (Cons x xs) show ?case - apply (cases "x \ set xs"; simp) - by (rule Cons[simplified comp_def]) -qed auto - -lemma distinct_insort_filter: - "distinct (insort_filter P x xs) \ x \ set xs \ distinct xs" - by (auto simp: insort_filter_def distinct_filter_iff[where xs=xs and P=P, simplified comp_def] - simp del: distinct_filter) - lemma distinct_tcb_release_enqueue_upd: "distinct (tcb_release_enqueue_upd ready_times t queue) \ \ in_queue_2 queue t \ distinct queue" by (simp add: tcb_release_enqueue_upd_def distinct_insort_filter in_queue_2_def) @@ -6147,14 +6473,6 @@ lemma valid_release_q_active_sc: "valid_release_q s \ t \ set (release_queue s) \ active_sc_tcb_at t s" by (clarsimp simp: valid_release_q_def) -lemma insort_filter_cong: - assumes xs: "x = y" "xs = ys" - assumes P: "\x. x \ set ys \ P x \ Q x" - shows "insort_filter P x xs = insort_filter Q y ys" - unfolding insort_filter_def - apply (intro arg_cong2[where f=append] arg_cong2[where f=Cons] filter_cong xs) - by (auto simp: P) - lemma tcb_release_enqueue_upd_def2: assumes "\x \ set (t # queue). \y. hp x = Some y" shows "tcb_release_enqueue_upd hp t queue = insort_filter (\t'. img_ord hp opt_ord t' t) t queue" @@ -6164,44 +6482,16 @@ lemma sc_ready_times_2_Some: "hp t = Some scrc \ sc_ready_times_2 hp t = Some (sc_ready_time scrc)" by (simp add: sc_ready_times_2_def map_project_simps) -lemma transp_img_ord: - "transp cmp \ transp (img_ord f cmp)" - unfolding transp_def img_ord_def by blast - -lemma transp_opt_ord: - "transp (opt_ord :: ('a::preorder) option \ 'a option \ bool)" - apply (clarsimp simp: transp_def) - by (case_tac x; case_tac y; case_tac z; clarsimp elim!: order_trans) - -lemma reflp_img_ord: - "reflp cmp \ reflp (img_ord f cmp)" - unfolding reflp_def img_ord_def by blast - -lemma reflp_opt_ord: - "reflp (opt_ord :: ('a::preorder) option \ 'a option \ bool)" - apply (clarsimp simp: reflp_def) - by (case_tac x; clarsimp) - -lemma total_img_ord: - "\total {(x,y). cmp x y}; reflp cmp\ \ total {(x,y). img_ord f cmp x y}" - apply (clarsimp simp: total_on_def reflp_def img_ord_def) - by (drule_tac x="f x" in spec; drule_tac x="f y" in spec; fastforce) - -lemma total_opt_ord: - "total {(x :: ('a::linorder) option, y). opt_ord x y}" - apply (clarsimp simp: total_on_def) - apply (case_tac x; case_tac y) - by (auto simp: linear) - lemma sorted_tcb_release_enqueue_upd: assumes "sorted_release_q_2 hp queue" assumes "\x \ set (t # queue). \y. hp x = Some y" shows "sorted_release_q_2 hp (tcb_release_enqueue_upd (sc_ready_times_2 hp) t queue)" using assms - apply (clarsimp simp add: sorted_release_q_2_def) - apply (subst tcb_release_enqueue_upd_def2, fastforce simp add: sc_ready_times_2_Some) - by (erule sorted_insort_filter[where cmp="img_ord (sc_ready_times_2 hp) opt_ord" and xs=queue, rotated 3] - ; intro transp_img_ord reflp_img_ord total_img_ord transp_opt_ord reflp_opt_ord total_opt_ord) + apply (clarsimp simp: sorted_release_q_2_def) + apply (subst tcb_release_enqueue_upd_def2, fastforce simp: sc_ready_times_2_Some) + by (fastforce elim!: sorted_insort_filter[rotated 3] + intro: total_img_ord total_opt_ord totalI transp_img_ord transp_opt_ord + reflp_img_ord reflp_opt_ord) lemma tcb_release_enqueue_valid_release_q[wp]: "\\s. valid_release_q s \ active_sc_tcb_at t s \ pred_map runnable (tcb_sts_of s) t \ not_in_release_q t s\ @@ -6239,12 +6529,6 @@ lemma tcb_release_enqueue_valid_blocked_except_set: apply (wpsimp wp: valid_sched_wp) by (auto elim!: valid_blockedE' simp: in_queue_2_def tcb_release_enqueue_upd_def insort_filter_def) -lemma set_map_fst_filter_zip: - "set (map fst (filter P (zip xs ys))) \ set xs" - apply (induct xs, simp) - apply (case_tac ys; simp) - by (metis (mono_tags, lifting) image_Collect_subsetI insertI2 set_zip_helper) - lemma tcb_release_enqueue_not_in_release_q_other[wp]: "\K (t \ t') and not_in_release_q t'\ tcb_release_enqueue t @@ -6592,7 +6876,8 @@ lemma tcb_sched_context_update_None_valid_sched: set_tcb_sched_context_valid_release_q_not_queued set_tcb_sched_context_None_valid_blocked set_tcb_sched_context_None_released_ipc_queues - set_tcb_sched_context_valid_sched_action_act_not) + set_tcb_sched_context_valid_sched_action_act_not + sorted_ipc_queues_lift set_tcb_obj_ref_prios_of) lemma sched_context_unbind_tcb_valid_sched: "\valid_sched and @@ -6628,11 +6913,14 @@ lemma sched_context_unbind_all_tcbs_valid_sched[wp]: lemma sched_context_unbind_reply_valid_sched_misc[wp]: "sched_context_unbind_reply sc_ptr - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (sc_tcbs_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) - (tcbs_of s) (sc_refill_cfgs_of s)\" + (tcbs_of s) (sc_refill_cfgs_of s) (prios_of s)\" unfolding sched_context_unbind_reply_def + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) by (wpsimp wp: get_sched_context_wp update_sched_context_wp update_sk_obj_ref_wp simp: obj_at_def vs_all_heap_simps fun_upd_def tcb_heap.all_simps) @@ -6657,6 +6945,10 @@ lemma sched_context_unbind_reply_valid_sched[wp]: "sched_context_unbind_reply scp \valid_sched\" by (wpsimp simp: valid_sched_def) +crunch unbind_maybe_notification, sched_context_maybe_unbind_ntfn + for current_time_bounded[wp]: current_time_bounded + (wp: crunch_wps) + lemma fast_finalise_valid_sched: "\valid_sched and invs and simple_sched_action and (\s. \slot. cte_wp_at ((=) cap) slot s) and current_time_bounded\ @@ -6697,6 +6989,10 @@ lemma unbind_from_sc_valid_sched: unfolding unbind_from_sc_def by (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift maybeM_wp sched_context_unbind_tcb_valid_sched) +crunch unbind_notification + for scheduler_action[wp]: "\s. P (scheduler_action s)" + (wp: crunch_wps) + (* precondition could be weaker (invs > (sym_refs and valid_objs and (\s. cap \ ThreadCap idle_thread_ptr)) but this is much simpler to prove *) lemma finalise_cap_valid_sched[wp]: @@ -6766,10 +7062,9 @@ crunch fast_finalise, cap_delete_one, deleting_irq_handler, cancel_ipc, suspend, end lemma update_time_stamp_valid_sched_misc[wp]: - "update_time_stamp \\s. P (cur_sc s) (cur_domain s) (cur_thread s) (idle_thread s) - (ready_queues s) (release_queue s) (scheduler_action s) - (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) - (sc_refill_cfgs_of s) (sc_replies_of s) (ep_send_qs_of s) (ep_recv_qs_of s)\" + "update_time_stamp + \\s. P (cur_sc s) (cur_domain s) (cur_thread s) (idle_thread s) + (ready_queues s) (release_queue s) (scheduler_action s) (kheap s)\" unfolding update_time_stamp_def by wpsimp @@ -6811,22 +7106,14 @@ lemma update_time_stamp_valid_sched[wp]: "\valid_sched and valid_machine_time\ update_time_stamp \\_. valid_sched :: 'state_ext state \ _\" - apply (wpsimp wp: valid_sched_lift_pre_conj[where R=valid_machine_time] simp: valid_sched_def) - done + by (wpsimp wp: valid_sched_lift_pre_conj[where R=valid_machine_time] simp: valid_sched_def) lemma preemption_point_valid_sched[wp]: "\valid_sched and valid_machine_time\ preemption_point \\_. valid_sched :: 'state_ext state \ _\" - apply (clarsimp simp: preemption_point_def) - apply (wpsimp wp: OR_choiceE_weak_wp hoare_vcg_all_lift | wp (once) hoare_drop_imps)+ - done - -lemma preemption_point_simple_sched_action[wp]: - "preemption_point \simple_sched_action :: 'state_ext state \ _\" - apply (wpsimp simp: preemption_point_def - wp: OR_choiceE_weak_wp hoare_drop_imps) - done + unfolding preemption_point_def + by (wpsimp wp: OR_choiceE_weak_wp hoare_vcg_all_lift | wp (once) hoare_drop_imps)+ crunch finalise_cap for vmt[wp]: "(\s. P (last_machine_time_of s) (cur_time s)) :: 'state_ext state \ _" @@ -7305,7 +7592,7 @@ lemma fast_finalise_cur_sc_chargeable: apply (case_tac d; simp) apply wpsimp apply (wpsimp wp: cancel_all_ipc_cur_sc_chargeable) - apply (wpsimp wp: cancel_all_signals_cur_sc_chargeable unbind_maybe_notification_invs simp:) + apply (wpsimp wp: cancel_all_signals_cur_sc_chargeable unbind_maybe_notification_invs) subgoal for rcap apply (wpsimp wp: cancel_ipc_cur_sc_chargeable reply_remove_cur_sc_chargeable) apply (wpsimp wp: gts_wp get_simple_ko_wp)+ @@ -7382,10 +7669,8 @@ lemma finalise_cap_cur_sc_chargeable: split: thread_state.splits if_splits) apply (erule reply_tcb_not_idle_thread_helper, simp add: obj_at_def, clarsimp) apply wpsimp - apply (wpsimp simp: wp: suspend_cur_sc_chargeable split: if_split) - apply wpsimp - apply (wpsimp split: if_split simp:) - apply (wpsimp)+ + apply (wpsimp wp: suspend_cur_sc_chargeable split: if_split) + apply (wpsimp split: if_split)+ done lemma set_tcb_pred_tcb_const: @@ -7463,27 +7748,101 @@ end lemma ct_in_state_def2: "ct_in_state test s = st_tcb_at test (cur_thread s) s" by (simp add: ct_in_state_def) +lemma thread_read_Some_tcbs_of: + "thread_read f t s = (tcbs_of s ||> f) t" + by (clarsimp simp: thread_read_def opt_map_def oliftM_def obind_def get_tcb_def + tcbs_of_kh_def tcb_of_def + split: option.splits) + +lemma tcb_ep_append_priority_ordered[wp]: + "\\s. priority_ordered q (prios_of s) \ (\t \ set q. tcb_at t s) \ tcb_at tptr s\ + tcb_ep_append tptr q + \\q' s. priority_ordered q' (prios_of s)\" + apply (wpsimp wp: monadic_rewrite_refine_valid[where P'="\s. priority_ordered q (prios_of s)"]) + apply (rule monadic_rewrite_sym) + apply (rule tcb_ep_append_insort_filter) + apply wpsimp + apply (clarsimp simp: thread_read_Some_tcbs_of) + apply (fastforce intro: sorted_insort_filter total_img_ord total_opt_ord totalI reflp_opt_ord + transp_img_ord transp_opt_ord reflp_img_ord) + apply fastforce + apply fastforce + done + +lemma tcb_ep_dequeue_priority_ordered[wp]: + "\\s. priority_ordered (filter ((\) tptr) q) (prios_of s)\ + tcb_ep_dequeue tptr q + \\q' s. priority_ordered q' (prios_of s)\" + by (wpsimp simp: tcb_ep_dequeue_def) + +lemma tcb_ep_dequeue_tcb_at[wp]: + "\\s. \t \ set q. tcb_at t s\ + tcb_ep_dequeue tptr q + \\q' s. \t \ set q'. tcb_at t s\" + by (wpsimp simp: tcb_ep_dequeue_def) + +lemma reorder_ep_sorted_ipc_queues: + "\\s. sorted_ipc_queues_except ep_ptr s + \ none_top (\q. priority_ordered (filter ((\) tptr) q) (prios_of s)) (ep_queues_of s ep_ptr) + \ valid_objs s \ tcb_at tptr s\ + reorder_ep ep_ptr tptr + \\_. sorted_ipc_queues\" + unfolding reorder_ep_def get_ep_queue_def + apply (rule bind_wp[OF _ get_simple_ko_sp], rename_tac ep) + by (case_tac ep; clarsimp; wpsimp; + fastforce simp: sorted_ipc_queues_def obj_at_def opt_map_def eps_of_kh_def + valid_obj_def valid_ep_def is_ep_def ep_at_pred_def + split: option.splits) + +lemma reorder_ntfn_sorted_ipc_queues: + "\\s. sorted_ipc_queues_except ntfn_ptr s + \ none_top (\q. priority_ordered (filter ((\) tptr) q) (prios_of s)) (ntfn_queues_of s ntfn_ptr) + \ valid_objs s \ tcb_at tptr s \ ntfn_at ntfn_ptr s\ + reorder_ntfn ntfn_ptr tptr + \\_. sorted_ipc_queues\" + unfolding reorder_ntfn_def + apply (wpsimp wp: get_simple_ko_wp) + by (fastforce simp: obj_at_def get_ntfn_queue_def ntfn_at_pred_def valid_obj_def + valid_ntfn_def is_ntfn_def none_top_def opt_map_def + split: ntfn.splits option.splits) + crunch reorder_ntfn, reorder_ep - for valid_sched[wp]:"valid_sched" + for valid_ready_qs[wp]: valid_ready_qs + and valid_release_q[wp]: valid_release_q + and ready_or_release[wp]: ready_or_release + and ct_not_in_q[wp]: ct_not_in_q + and valid_sched_action[wp]: valid_sched_action + and ct_in_cur_domain[wp]: ct_in_cur_domain + and valid_blocked[wp]: valid_blocked + and etcbs_of[wp]: "\s. P (etcbs_of s)" + and released_ipc_queues[wp]: released_ipc_queues + and active_reply_scs[wp]: active_reply_scs + and active_scs_valid[wp]: active_scs_valid and simple_sched_action[wp]: simple_sched_action - (wp: mapM_wp' get_simple_ko_wp) + (wp: mapM_wp' get_simple_ko_wp crunch_wps) lemma thread_set_priority_valid_sched_misc[wp]: "thread_set_priority p t - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (sc_tcbs_of s) (cur_time s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (sc_tcbs_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) (sc_replies_of s)\" - apply (wpsimp simp: thread_set_priority_def wp: thread_set_wp) + unfolding thread_set_priority_def + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (wpsimp wp: thread_set_wp) by (clarsimp simp: obj_at_kh_kheap_simps fun_upd_def vs_all_heap_simps) lemma thread_set_domain_valid_sched_misc[wp]: "thread_set_domain t d - \\s. P (consumed_time s) (cur_sc s) (ep_send_qs_of s) (ep_recv_qs_of s) (cur_time s) + \\s. P (consumed_time s) (cur_sc s) (eps_of s) (ntfns_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (ready_queues s) (release_queue s) (scheduler_action s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) (sc_refill_cfgs_of s) (sc_replies_of s)\" - apply (wpsimp simp: thread_set_domain_def wp: thread_set_wp) + unfolding thread_set_domain_def + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfns_of, rotated], wpsimp) + apply (wpsimp wp: thread_set_wp) by (clarsimp simp: obj_at_kh_kheap_simps fun_upd_def vs_all_heap_simps) lemma thread_set_domain_st_tcb[wp]: @@ -7525,10 +7884,9 @@ lemma thread_set_priority_valid_idle_etcb[wp]: apply (clarsimp simp: valid_idle_etcb_def vs_all_heap_simps etcb_at'_def dest!: get_tcb_SomeD) done -lemma thread_set_priority_valid_sched: - "\valid_sched and not_queued t\ thread_set_priority t p \\_. valid_sched\" - unfolding valid_sched_def valid_sched_action_def - by (wpsimp wp: thread_set_priority_valid_ready_qs_not_q) +crunch thread_set_priority + for valid_sched_action[wp]: valid_sched_action + (simp: valid_sched_action_def) lemma is_schedulable_opt_ready_queues_update[simp]: "is_schedulable_opt t (ready_queues_update f s) = is_schedulable_opt t s" @@ -7541,47 +7899,181 @@ lemma ct_not_in_q_not_cur_threadE: \ not_cur_thread tptr s" by (clarsimp simp: ct_not_in_q_def not_cur_thread_def not_queued_def) -lemma set_priority_valid_sched: - "\valid_sched and ct_released and ct_active and ct_not_in_release_q\ +crunch set_priority + for valid_release_q[wp]: valid_release_q + and valid_sched_action[wp]: valid_sched_action + and ct_in_cur_domain[wp]: ct_in_cur_domain + and released_ipc_queues[wp]: released_ipc_queues + and active_reply_scs[wp]: active_reply_scs + and active_scs_valid[wp]: active_scs_valid + and simple_sched_action[wp]: simple_sched_action + (wp: mapM_wp' get_simple_ko_wp crunch_wps) + +lemma set_priority_ready_or_release[wp]: + "\ready_or_release and ct_not_in_release_q\ set_priority tptr prio - \\_. valid_sched \" - apply (clarsimp simp: set_priority_def) - apply (rule bind_wp[OF _ gts_sp]) - apply (wpsimp wp: hoare_vcg_if_lift2 reschedule_required_valid_sched' - tcb_sched_enqueue_valid_blocked_except_set) - apply (wpsimp wp: thread_set_priority_valid_ready_qs_not_q) - apply (wpsimp wp: tcb_sched_dequeue_valid_ready_qs tcb_dequeue_not_queued - tcb_sched_dequeue_valid_blocked_except_set_const) - apply (wpsimp wp: thread_set_priority_valid_sched) - apply (wpsimp wp: thread_get_wp)+ - apply (rule_tac Q'="\r. valid_sched" in hoare_strengthen_post; wpsimp wp: thread_set_priority_valid_sched) - apply (rule_tac Q'="\r. valid_sched" in hoare_strengthen_post; wpsimp wp: thread_set_priority_valid_sched) - apply (clarsimp simp: valid_sched_def valid_sched_action_def obj_at_def) - apply (intro conjI; intro impI) - apply (frule pred_tcb_at_tcb_at, clarsimp simp: obj_at_def is_tcb) - apply (intro conjI; intro impI) - apply (clarsimp simp: valid_ready_qs_def valid_blocked_thread_def tcb_at_kh_simps - released_sc_tcb_at_def) - apply (fastforce simp: not_queued_def ready_or_release_2_def) - apply (intro conjI) - apply (clarsimp simp: valid_blocked_thread_def ct_in_state_def runnable_eq_active) - apply (clarsimp simp: valid_ready_qs_def valid_blocked_thread_def tcb_at_kh_simps - released_sc_tcb_at_def) - apply (clarsimp simp: vs_all_heap_simps valid_ready_qs_def in_ready_q_def tcb_at_kh_simps - , fastforce) - apply (clarsimp simp: vs_all_heap_simps valid_ready_qs_def in_ready_q_def tcb_at_kh_simps - , fastforce) + \\_. ready_or_release\" + unfolding set_priority_def + apply (wpsimp wp: thread_get_wp gts_wp hoare_vcg_imp_lift') + apply (fastforce simp: st_tcb_at_def obj_at_def ready_or_release_def in_ready_q_def) + done + +lemma set_priority_valid_blocked[wp]: + "set_priority tptr prio \valid_blocked\" + unfolding set_priority_def + apply (wpsimp wp: tcb_sched_enqueue_valid_blocked_except_set + tcb_sched_dequeue_valid_blocked_except_set_const + reschedule_required_valid_blocked thread_get_wp hoare_vcg_imp_lift' gts_wp) + apply (clarsimp simp: st_tcb_at_def obj_at_def valid_blocked_thread_def is_tcb_def) + done + +lemma thread_set_priority_blocked_sorted_ipc_queues_except: + "\\s. sorted_ipc_queues s + \ st_tcb_at (\ts. ntfn_blocked ts = Some ipc_ptr \ ep_blocked ts = Some ipc_ptr) tptr s + \ valid_objs s \ sym_refs (state_refs_of s)\ + thread_set_priority tptr prio + \\_ s. sorted_ipc_queues_except ipc_ptr s\" + unfolding thread_set_priority_def + apply (wpsimp wp: thread_set_wp) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (drule_tac x=ptr in spec) + apply (intro conjI impI) + apply (clarsimp simp: eps_of_kh_def in_opt_map_eq) + apply (clarsimp simp: none_top_def split: option.splits) + apply (clarsimp simp: st_tcb_at_def obj_at_def opt_map_def eps_of_kh_def) + apply (clarsimp simp: st_tcb_at_def obj_at_def eps_of_kh_def) + apply (erule sorted_wrt_img_ord_eq_lift[THEN iffD1, rotated]) + apply (clarsimp simp flip: eps_of_def) + apply (frule (3) in_ep_queue_st_tcb_at) + apply (clarsimp simp: tcbs_of_kh_def st_tcb_at_def obj_at_def get_tcb_def + ep_blocked_def ntfn_blocked_def + split: thread_state.splits) + apply (clarsimp simp: opt_map_def eps_of_kh_def) + apply (clarsimp simp: opt_map_def eps_of_kh_def split: option.splits) + apply (fastforce elim!: sorted_wrt_img_ord_eq_lift[THEN iffD1, rotated] + dest: in_ntfn_queue_st_tcb_at in_ep_queue_st_tcb_at + simp: tcbs_of_kh_def st_tcb_at_def obj_at_def ntfn_blocked_def ep_blocked_def) + done + +lemma thread_set_priority_not_blocked_sorted_ipc_queues: + "\\s. sorted_ipc_queues s + \ st_tcb_at (\ts. ntfn_blocked ts = None \ ep_blocked ts = None) tptr s + \ valid_objs s \ sym_refs (state_refs_of s)\ + thread_set_priority tptr prio + \\_ s. sorted_ipc_queues s\" + unfolding thread_set_priority_def + apply (wpsimp wp: thread_set_wp) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (drule_tac x=ptr in spec) + apply (intro conjI impI) + apply (clarsimp simp: eps_of_kh_def in_opt_map_eq) + apply (clarsimp simp: st_tcb_at_def obj_at_def eps_of_kh_def) + apply (erule sorted_wrt_img_ord_eq_lift[THEN iffD1, rotated]) + apply (clarsimp simp flip: eps_of_def) + apply (frule (3) in_ep_queue_st_tcb_at) + apply (fastforce simp: tcbs_of_kh_def st_tcb_at_def obj_at_def ep_blocked_def) + apply clarsimp + apply (erule sorted_wrt_img_ord_eq_lift[THEN iffD1, rotated]) + apply (frule (3) in_ntfn_queue_st_tcb_at) + apply (clarsimp simp: tcbs_of_kh_def st_tcb_at_def obj_at_def ntfn_blocked_def) done +lemma thread_set_priority_priority_ordered: + "\\s. priority_ordered q (prios_of s)\ + thread_set_priority tptr prio + \\_ s. priority_ordered (filter ((\) tptr) q) (prios_of s)\" + unfolding thread_set_priority_def + apply (wpsimp wp: thread_set_wp) + apply (frule sorted_wrt_filter) + apply (erule sorted_wrt_img_ord_eq_lift[THEN iffD1, rotated]) + apply (clarsimp simp: tcbs_of_kh_def) + done + +lemma set_priority_sorted_ipc_queues: + "\\s. sorted_ipc_queues s \ valid_objs s \ sym_refs (state_refs_of s)\ + set_priority tptr prio + \\_. sorted_ipc_queues\" + unfolding set_priority_def + apply (rule bind_wp[OF _ gts_sp], rename_tac ts) + apply (rule hoare_if) + \ \thread is runnable\ + apply (wpsimp wp: thread_set_priority_not_blocked_sorted_ipc_queues thread_get_wp) + apply (fastforce simp: st_tcb_at_def ep_blocked_def ntfn_blocked_def obj_at_def + split: thread_state.splits) + \ \thread isn't runnable\ + apply (case_tac "ep_blocked ts"; clarsimp) + \ \not blocked on an endpoint\ + apply (case_tac "ntfn_blocked ts") + apply (wpsimp wp: thread_set_priority_not_blocked_sorted_ipc_queues) + apply (clarsimp simp: st_tcb_at_def obj_at_def) + apply (wpsimp wp: get_simple_ko_wp reorder_ntfn_sorted_ipc_queues + thread_set_priority_blocked_sorted_ipc_queues_except + thread_set_priority_priority_ordered + simp: none_top_def + split: option.splits + | wp (once) hoare_vcg_imp_lift' hoare_vcg_all_lift)+ + apply (frule (1) st_tcb_at_valid_st2) + apply (frule st_tcb_at_tcb_at) + apply (rename_tac ntfn_ptr s) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (drule_tac x=ntfn_ptr in spec) + apply (fastforce simp: st_tcb_at_def obj_at_def valid_tcb_state_def ntfn_blocked_def + split: thread_state.splits) + \ \blocked on an endpoint\ + apply (case_tac "ntfn_blocked ts") + apply (clarsimp simp: maybeM_def) + apply (wpsimp wp: get_simple_ko_wp reorder_ep_sorted_ipc_queues + thread_set_priority_blocked_sorted_ipc_queues_except + thread_set_priority_priority_ordered hoare_vcg_imp_lift' hoare_vcg_all_lift + simp: none_top_def + split: option.splits) + apply (rename_tac ep_ptr s) + apply (frule st_tcb_at_tcb_at) + apply clarsimp + apply (intro conjI impI) + apply (clarsimp simp: st_tcb_at_def obj_at_def) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (drule_tac x=ep_ptr in spec) + apply fastforce + apply (wp hoare_pre_cont) + apply (clarsimp simp: st_tcb_at_def ep_blocked_def ntfn_blocked_def obj_at_def + split: thread_state.splits) + done + +lemma set_priority_valid_ready_qs: + "\valid_ready_qs and ct_released\ set_priority tptr prio \\_. valid_ready_qs\" + unfolding set_priority_def + apply (wpsimp wp: thread_set_priority_valid_ready_qs_not_q tcb_sched_dequeue_valid_ready_qs + tcb_dequeue_not_queued thread_get_wp hoare_vcg_imp_lift' gts_wp) + by (fastforce simp: valid_ready_qs_def tcb_at_kh_simps vs_all_heap_simps in_ready_q_def obj_at_def) + +lemma set_priority_ct_not_in_q[wp]: + "set_priority tptr prio \ct_not_in_q\" + unfolding set_priority_def + apply (wpsimp wp: thread_get_wp hoare_vcg_imp_lift' gts_wp) + apply (clarsimp simp: tcb_at_kh_simps vs_all_heap_simps obj_at_def is_tcb_def) + done + +lemma set_priority_valid_idle_etcb[wp]: + "set_priority tptr prio \valid_idle_etcb\" + supply valid_idle_etcb_lift[wp del] + unfolding set_priority_def + apply (wpsimp wp: thread_get_wp hoare_vcg_imp_lift' gts_wp) + apply (clarsimp simp: tcb_at_kh_simps vs_all_heap_simps obj_at_def is_tcb_def) + done + +lemma set_priority_valid_sched: + "\\s. valid_sched s \ ct_released s \ ct_not_in_release_q s + \ valid_objs s \ sym_refs (state_refs_of s)\ + set_priority tptr prio + \\_. valid_sched\" + apply (clarsimp simp: valid_sched_def) + by (wpsimp wp: set_priority_valid_ready_qs set_priority_sorted_ipc_queues) + lemma set_mcpriority_valid_sched_pred_strong[wp]: "set_mcpriority tptr prio \valid_sched_pred_strong P\" by (simp add: set_mcpriority_def thread_set_not_state_valid_sched) -lemma set_priority_simple_sched_action[wp]: - "set_priority param_a param_b \simple_sched_action\" - unfolding set_priority_def - by (wpsimp simp: get_thread_state_def thread_get_def wp: maybeM_inv) - lemma postpone_in_release_q: "\sc_tcb_sc_at ((=) (Some tcbptr)) sc_ptr\ postpone sc_ptr @@ -7623,6 +8115,10 @@ lemma set_tcb_sched_context_released_ipc_queues: apply (wpsimp wp: valid_sched_wp) by (cases sco; clarsimp simp: is_blocked_thread_state_defs vs_all_heap_simps elim!: released_ipc_queuesE split: if_splits) +lemma set_tcb_sched_context_sorted_ipc_queues[wp]: + "set_tcb_obj_ref tcb_sched_context_update t sco \sorted_ipc_queues_except_set S\" + by (wpsimp wp: set_tcb_sched_context_valid_sched_pred) + crunch if_cond_refill_unblock_check for sc_tcb_sc_at[wp]: "\s. P' (sc_tcb_sc_at P scp s)" (wp: crunch_wps) @@ -7654,7 +8150,8 @@ lemma sched_context_bind_tcb_valid_sched: valid_blocked_except_set {tcbptr} and not_cur_thread tcbptr and current_time_bounded and sc_tcb_sc_at ((=) (Some tcbptr)) scptr and - bound_sc_tcb_at (\a. a = Some scptr) tcbptr" + bound_sc_tcb_at (\a. a = Some scptr) tcbptr and + sorted_ipc_queues" in hoare_strengthen_post[rotated]) apply (clarsimp simp: tcb_at_kh_simps sc_at_kh_simps valid_sched_def heap_refs_retract_at_def vs_all_heap_simps @@ -7706,11 +8203,7 @@ crunch set_priority for scheduler_act_not[wp]: "scheduler_act_not y" (wp: crunch_wps simp: crunch_simps) -crunch reorder_ntfn - for valid_sched_pred[wp]: "valid_sched_pred_strong P" - (wp: crunch_wps simp: crunch_simps ignore: set_simple_ko) - -crunch reorder_ep +crunch reorder_ep, reorder_ntfn for valid_sched_pred[wp]: "\s. P (consumed_time s) (cur_sc s) (sc_tcbs_of s) (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) @@ -8084,6 +8577,17 @@ lemma install_tcb_cap_heap_refs_eq_tcb_scps_of[wp]: apply (wpsimp wp: check_cap_inv cap_delete_fh_lift hoare_vcg_imp_lift') done +crunch set_mcpriority + for state_refs_of[wp]: "\s. P (state_refs_of s)" + (wp: thread_set_refs_trivial) + +lemma sc_not_bound_not_in_release_q: + "\valid_release_q s; heap_ref_eq sc_ptr tcb_ptr (tcb_scps_of s); + sc_tcb_sc_at ((=) None) sc_ptr s; sym_refs (state_refs_of s)\ + \ not_in_release_q tcb_ptr s" + by (fastforce dest: sym_ref_tcb_sc valid_release_q_no_sc_not_in_release_q + simp: sc_at_pred_n_def obj_at_def vs_all_heap_simps) + lemma tcs_valid_sched: "\valid_sched and valid_machine_time and invs and simple_sched_action and (\s. bound_sc_tcb_at bound (cur_thread s) s) and current_time_bounded @@ -8108,27 +8612,64 @@ lemma tcs_valid_sched: apply (wpsimp wp: set_priority_valid_sched hoare_vcg_all_lift hoare_vcg_imp_lift) apply assumption \ \set mcpriority\ - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift ) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift) + apply (rule_tac Q'="\_ s. valid_sched s \ simple_sched_action s \ + (\opt. sc \ Some opt \ + (\sc_ptr. opt \ Some sc_ptr \ + bound_sc_tcb_at ((=) None) target s \ + target \ cur_thread s \ + (blocked_on_recv_ntfn_tcb_at target s \ released_sc_at sc_ptr s) \ + (blocked_on_send_tcb_at target s \ + (if timeout_faulted_tcb_at target s + then is_active_sc sc_ptr s + else released_sc_at sc_ptr s)) \ + (blocked_on_reply_tcb_at target s \ is_active_sc sc_ptr s) \ + current_time_bounded s \ + sc_not_in_release_q sc_ptr s)) \ + (ct_released s \ ct_not_in_release_q s \ invs s)" + and E'="\_. valid_sched" + in hoare_post_impE) + apply fastforce + apply clarsimp \ \install_tcb_cap\ apply (clarsimp cong: conj_cong) apply (rule hoare_vcg_conj_elimE, wpsimp) apply (rule valid_validE_R) - apply ((wpsimp wp: hoare_vcg_all_lift install_tcb_cap_ct_active + apply ((wpsimp wp: install_tcb_cap_invs hoare_vcg_all_lift install_tcb_cap_ct_active hoare_vcg_imp_lift install_tcb_cap_timeout_faulted_tcb_at - split: if_split - | rule valid_validE, wps)+)[1] + split: if_split | strengthen invs_valid_objs + | rule valid_validE, wps)+)[1] \ \resolve using preconditions\ apply (clarsimp, frule tcb_at_invs, frule valid_sched_active_scs_valid) apply (prop_tac "active_scs_valid s \ released_ipc_queues s", fastforce) apply (clarsimp simp: obj_at_def is_tcb) - apply (clarsimp simp: tcb_at_kh_simps[symmetric] - pred_tcb_at_def obj_at_def sc_at_released_kh_simps released_sc_at_def - split: option.splits cong: conj_cong; - intro conjI; (erule disjE)?; - clarsimp dest!: active_scs_validE - simp: ipc_queued_thread_state_def2 sc_tcb_sc_at_def obj_at_def - dest!: sym[of _ "tcb_sched_context _"]) - by (drule_tac tp=x in sym_ref_tcb_sc[OF invs_sym_refs], fastforce+)+ + apply (rule conjI) + apply (intro conjI impI allI) + apply fastforce + apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply (clarsimp simp: tcb_at_kh_simps[symmetric] pred_tcb_at_def obj_at_def + sc_at_released_kh_simps ipc_queued_thread_state_def2) + apply (clarsimp intro!: released_sc_at_valid_refills + simp: tcb_at_kh_simps[symmetric] pred_tcb_at_def sc_at_released_kh_simps + ipc_queued_thread_state_def2 obj_at_def) + apply (clarsimp simp: tcb_at_kh_simps[symmetric] pred_tcb_at_def sc_at_released_kh_simps + ipc_queued_thread_state_def2 obj_at_def released_sc_at_def) + apply (clarsimp simp: pred_map_ipc_queued_thread_state_iff pred_map_weakenE + released_sc_at_valid_refills sc_at_released_kh_simps tcb_at_kh_simps(2)) + apply (clarsimp simp: pred_map_ipc_queued_thread_state_iff pred_map_weakenE + sc_at_released_kh_simps tcb_at_kh_simps(2)) + apply (clarsimp simp: pred_map_ipc_queued_thread_state_iff + released_sc_at_valid_refills sc_at_released_kh_simps tcb_at_kh_simps(2)) + apply (clarsimp simp: pred_map_ipc_queued_thread_state_iff pred_map_weakenE + sc_at_released_kh_simps tcb_at_kh_simps(2)) + apply (frule valid_sched_valid_release_q) + apply (erule (1) sc_not_bound_not_in_release_q) + apply fastforce + apply fastforce + apply (fastforce simp: tcb_cap_valid_def pred_tcb_at_def pred_neg_def + sc_at_ppred_def obj_at_def is_ep_def is_tcb_def + elim: cte_wp_at_weakenE dest: tcb_ep_slot_cte_wp_ats) + done end @@ -10863,42 +11404,6 @@ lemma read_release_q_non_empty_and_ready_simp: by (clarsimp simp: read_release_q_non_empty_and_ready_def asks_def obind_def split: if_split_asm) -lemma get_tcb_def2: - "get_tcb ptr = do { - kobj \ read_object ptr; - case kobj of TCB tcb \ oreturn tcb - | _ \ ofail - }" - unfolding get_tcb_def - by (rule ext; - clarsimp simp: get_tcb_def omonad_defs obind_def oreturn_def - split: option.splits Structures_A.kernel_object.splits)+ - -lemma get_tcb_wp: - "\\s. \tcb. kheap s tcb_ptr = Some (TCB tcb) \ P tcb s\ - get_tcb tcb_ptr - \P\" - apply (simp add: get_tcb_def2 del: read_object_def) - apply (rule obind_wp[OF _ read_object_sp], rename_tac r) - apply (case_tac r; wpsimp) - apply (simp add: obj_at_def) - done - -lemma thread_read_wp: - "\\s. \tcb. kheap s tcb_ptr = Some (TCB tcb) \ P (f tcb) s\ - thread_read f tcb_ptr - \P\" - unfolding thread_read_def - by (wpsimp wp: get_tcb_wp simp: oliftM_def) - -lemma ovalid_thread_read_sp: - "\P\ thread_read f ptr \\rv s. \tcb. kheap s ptr = Some (TCB tcb) \ f tcb = rv \ P s\" - by (wpsimp wp: thread_read_wp) - -lemma thread_read_no_ofail[wp]: - "no_ofail (tcb_at tcb_ptr) (thread_read f tcb_ptr)" - by (wpsimp simp: thread_read_def oliftM_def) - lemma no_ofail_read_tcb_refill_ready: "no_ofail (\s. ((\sc. sc_refills sc \ []) |< (tcbs_of s |> tcb_sched_context |> scs_of s)) tcb_ptr) (read_tcb_refill_ready tcb_ptr)" @@ -10944,6 +11449,9 @@ lemma valid_release_q_read_tcb_sched_context_bound: by (clarsimp simp: vs_all_heap_simps read_tcb_obj_ref_def thread_read_def oliftM_def obind_def get_tcb_def) +crunch tcb_release_dequeue + for sorted_ipc_queues[wp]: "sorted_ipc_queues_except_set S" + lemma awaken_valid_sched: "\valid_sched and valid_idle\ awaken @@ -10956,7 +11464,8 @@ lemma awaken_valid_sched: \ ct_not_in_q s \ valid_sched_action s \ ct_in_cur_domain s \ valid_blocked s \ valid_idle_etcb s \ released_ipc_queues s \ active_reply_scs s \ active_scs_valid s \ valid_idle s - \ release_queue s \ [] \ budget_ready (hd (release_queue s)) s" + \ release_queue s \ [] \ budget_ready (hd (release_queue s)) s + \ sorted_ipc_queues s" in hoare_weaken_pre[rotated]) apply clarsimp apply (prop_tac "read_release_q_non_empty_and_ready s = Some True") @@ -12080,6 +12589,10 @@ lemma commit_time_active_reply_scs[wp]: "commit_time \active_reply_scs\" unfolding commit_time_def by (wpsimp wp: hoare_drop_imps) +lemma commit_time_sorted_ipc_queues[wp]: + "commit_time \sorted_ipc_queues_except_set S\" + unfolding commit_time_def by (wpsimp wp: hoare_drop_imps) + lemma commit_time_valid_sched: "\valid_sched and simple_sched_action @@ -12532,7 +13045,7 @@ lemma schedule_valid_sched_helper: released_ipc_queues and active_scs_valid and valid_ready_qs and - ready_or_release and + ready_or_release and sorted_ipc_queues and cur_sc_in_release_q_imp_zero_consumed and cur_sc_more_than_ready and current_time_bounded and consumed_time_bounded" in hoare_strengthen_post[rotated]) apply clarsimp @@ -12545,7 +13058,7 @@ lemma schedule_valid_sched_helper: (\s. scheduler_action s = switch_thread candidate \ in_ready_q candidate s )) s \ released_ipc_queues s \ active_scs_valid s \ - ready_or_release s \ + ready_or_release s \ sorted_ipc_queues s \ current_time_bounded s \ consumed_time_bounded s \ (active_sc_tcb_at (cur_thread s) s \ ct_not_in_release_q s \ ct_in_q s) \ @@ -12574,7 +13087,7 @@ lemma schedule_valid_sched_helper: ct_in_q and released_ipc_queues) b \ active_scs_valid b \ - ready_or_release b \ + ready_or_release b \ sorted_ipc_queues b \ consumed_time_bounded b \ current_time_bounded b \ cur_sc_in_release_q_imp_zero_consumed b \ @@ -12591,7 +13104,7 @@ lemma schedule_valid_sched_helper: released_ipc_queues s \ ct_in_q s \ active_scs_valid s \ - ready_or_release s \ + ready_or_release s \ sorted_ipc_queues s \ consumed_time_bounded s \ current_time_bounded s \ cur_sc_in_release_q_imp_zero_consumed s \ @@ -12674,7 +13187,7 @@ lemma schedule_valid_sched_helper: active_scs_valid b \ current_time_bounded b \ consumed_time_bounded b \ - ready_or_release b \ + ready_or_release b \ sorted_ipc_queues b \ cur_sc_more_than_ready b" in hoare_strengthen_post[rotated]) apply clarsimp @@ -12788,7 +13301,8 @@ lemma restart_valid_sched: bound_sc_tcb_at (\a. a = sc_opt) thread" in hoare_strengthen_post[rotated]) apply (rule conjI) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps heap_refs_retract_at_def valid_sched_def) + apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps heap_refs_retract_at_def + valid_sched_def) apply (fastforce dest!: no_bound_sc_not_schedulable simp: op_equal) apply wpsimp apply (rule_tac Q'="\r. (valid_sched_except_blocked and @@ -12829,12 +13343,20 @@ lemma restart_valid_sched: end -lemma bind_notification_valid_sched[wp]: - "\valid_sched\ bind_notification param_a param_b \\_. valid_sched\" - apply (clarsimp simp: bind_notification_def update_sk_obj_ref_def) - apply (wpsimp simp: set_object_def set_simple_ko_def - wp: get_simple_ko_wp hoare_drop_imp) - done +lemma bind_notification_valid_sched_misc[wp]: + "bind_notification tcbptr ntfnptr + \\s. P (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (eps_of s) (ntfn_queues_of s) (prios_of s)\" + unfolding bind_notification_def + apply (rule hoare_lift_Pf2[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf2[where f=ntfn_queues_of, rotated]) + apply (wpsimp wp: update_sk_obj_ref_wp) + apply (erule_tac P=P in rsubst) + apply (fastforce simp: opt_map_def obj_at_def) + apply (rule hoare_lift_Pf2[where f=prios_of, rotated], wpsimp) + by wpsimp lemma suspend_it_det_ext[wp]: "\\s. P (idle_thread s)\ suspend param_a \\_ s. P (idle_thread s)\" @@ -13181,6 +13703,43 @@ lemma cancel_badged_sends_filterM_valid_sched: apply simp done +(* FIXME RT: move *) +lemma filterM_subseq: + "\\\ filterM P xs \\rv _. subseq rv xs\" + apply (rule rev_induct [where xs=xs]) + apply wpsimp + apply (simp add: filterM_append) + apply (erule bind_wp_fwd) + apply (rule bind_wp_fwd, rule hoare_vcg_prop) + apply wpsimp + apply blast + done + +crunch restart_thread_if_no_fault + for prios_of[wp]: "\s. P (prios_of s)" + +lemma cancel_badged_sends_filterM_priority_ordered: + "\\s. priority_ordered xs (prios_of s)\ + filterM (\t. do st \ get_thread_state t; + if blocking_ipc_badge st = badge + then do _ \ restart_thread_if_no_fault t; + return False + od + else return True + od) xs + \\rv s. priority_ordered rv (prios_of s)\" + apply (rule hoare_strengthen_post[ + where Q'="\rv s. priority_ordered xs (prios_of s) \ subseq rv xs"]) + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule hoare_lift_Pf3[where f=prios_of]) + apply wpsimp + apply (wpsimp wp: filterM_preserved) + apply (rule hoare_weaken_pre) + apply (rule filterM_subseq) + apply simp + apply (fastforce intro: sorted_wrt_subseq) + done + lemma cancel_badged_sends_valid_sched: "\valid_objs and valid_sched and simple_sched_action and current_time_bounded and (\s. sym_refs (state_refs_of s)) and valid_idle\ @@ -13189,22 +13748,31 @@ lemma cancel_badged_sends_valid_sched: apply (simp add: cancel_badged_sends_def) apply (rule bind_wp[OF _ get_simple_ko_sp]) apply (case_tac ep; clarsimp; - wpsimp wp: cancel_badged_sends_filterM_valid_sched hoare_vcg_ball_lift - reschedule_valid_sched_const) + wpsimp wp: cancel_badged_sends_filterM_valid_sched + reschedule_valid_sched_const set_endpoint_valid_sched) + apply (rule_tac Q'="\rv s. priority_ordered rv (prios_of s)" in hoare_post_imp) + apply (case_tac rv; clarsimp) + apply (rule cancel_badged_sends_filterM_priority_ordered) + apply (wpsimp wp: hoare_vcg_ball_lift set_endpoint_valid_sched) + apply clarsimp apply (intro conjI, intro ballI) - apply (subgoal_tac "st_tcb_at (\st. \payl. st = (BlockedOnSend epptr payl)) x s") - apply (intro conjI) - apply (clarsimp simp: tcb_at_kh_simps pred_map_def) - apply (clarsimp, drule (1) st_tcb_at_idle_thread, simp) - apply (subgoal_tac "tcb_at x s") - apply (subgoal_tac "(epptr, TCBBlockedSend) \ state_refs_of s x") - apply (clarsimp simp: state_refs_of_def refs_of_def tcb_at_def is_tcb get_refs_def - tcb_st_refs_of_def pred_tcb_at_def obj_at_def - dest!: get_tcb_SomeD split: option.splits thread_state.splits if_splits) - apply (erule sym_refsE, clarsimp) - apply (clarsimp simp: obj_at_def state_refs_of_def refs_of_def split: option.splits) - apply (fastforce elim: ep_list_tcb_at') - apply (fastforce elim: valid_objs_SendEP_distinct simp: obj_at_def) + apply (subgoal_tac "st_tcb_at (\st. \payl. st = (BlockedOnSend epptr payl)) x s") + apply (intro conjI) + apply (clarsimp simp: tcb_at_kh_simps pred_map_def) + apply (clarsimp, drule (1) st_tcb_at_idle_thread, simp) + apply (subgoal_tac "tcb_at x s") + apply (subgoal_tac "(epptr, TCBBlockedSend) \ state_refs_of s x") + apply (clarsimp simp: state_refs_of_def refs_of_def tcb_at_def is_tcb get_refs_def + tcb_st_refs_of_def pred_tcb_at_def obj_at_def + dest!: get_tcb_SomeD split: option.splits thread_state.splits if_splits) + apply (erule sym_refsE, clarsimp) + apply (clarsimp simp: obj_at_def state_refs_of_def refs_of_def split: option.splits) + apply (fastforce elim: ep_list_tcb_at') + apply (fastforce elim: valid_objs_SendEP_distinct simp: obj_at_def) + apply (drule valid_sched_sorted_ipc_queues) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (drule_tac x=epptr in spec) + apply (clarsimp simp: none_top_def obj_at_def opt_map_def eps_of_kh_def comp_def) done context DetSchedSchedule_AI_det_ext begin @@ -13519,9 +14087,14 @@ lemma reply_push_active_reply_scs[wp]: ; wpsimp wp: get_simple_ko_wp set_sc_replies_active_reply_scs) by (clarsimp simp: vs_all_heap_simps) +crunch bind_sc_reply + for sorted_ipc_queues[wp]: "sorted_ipc_queues_except_set S" + (wp: crunch_wps sorted_ipc_queues_lift ignore: update_sk_obj_ref) + crunch reply_push for ready_or_release[wp]: "ready_or_release" - (wp: crunch_wps simp: crunch_simps) + and sorted_ipc_queues[wp]: "sorted_ipc_queues_except_set S" + (wp: crunch_wps simp: crunch_simps ignore: update_sk_obj_ref) lemma reply_push_valid_sched[wp]: "\\s. valid_sched_except_blocked s @@ -13642,7 +14215,7 @@ crunch do_ipc_transfer crunch do_ipc_transfer, handle_fault_reply for valid_sched_pred[wp]: "valid_sched_pred_strong P :: 'state_ext state \ _" - (wp: crunch_wps maybeM_wp transfer_caps_loop_pres ) + (wp: crunch_wps maybeM_wp transfer_caps_loop_pres) lemma send_ipc_not_queued_for_timeout: "\not_queued t @@ -13999,6 +14572,29 @@ lemma send_ipc_active_scs_valid: by (wpsimp wp: refill_unblock_check_active_scs_valid hoare_drop_imp hoare_vcg_all_lift hoare_vcg_if_lift2) +lemma send_ipc_sorted_ipc_queues: + "\sorted_ipc_queues and tcb_at t and valid_objs\ + send_ipc block call badge can_grant can_grant_reply can_donate t epptr + \\_. sorted_ipc_queues :: 'state_ext state \ _\" + unfolding send_ipc_def + apply (wpsimp wp: thread_get_wp' hoare_vcg_all_lift) + apply (rule_tac Q'="\_. sorted_ipc_queues" in hoare_post_imp) + apply fastforce + apply (wpsimp wp: thread_get_wp' hoare_vcg_all_lift) + apply (rule_tac Q'="\_. sorted_ipc_queues" in hoare_post_imp) + apply fastforce + apply (wpsimp wp: thread_get_wp' hoare_drop_imps)+ + apply (wpsimp wp: get_simple_ko_wp) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (frule (1) valid_objs_ko_at) + apply (intro conjI impI allI) + apply (drule_tac x=epptr in spec) + apply (clarsimp simp: eps_of_kh_def opt_map_def obj_at_def) + apply (clarsimp simp: valid_obj_def valid_ep_def) + apply (drule_tac x=epptr in spec) + apply (fastforce simp: obj_at_def eps_of_kh_def opt_map_def split: list.splits) + done + crunch reply_push for tcb_at[wp]: "tcb_at t" (wp: hoare_drop_imps crunch_wps simp: crunch_simps) @@ -14011,10 +14607,11 @@ lemmas send_ipc_valid_sched_unbundled = send_ipc_valid_ready_qs send_ipc_valid_release_q send_ipc_ct_not_in_q send_ipc_valid_sched_action send_ipc_ct_in_cur_domain send_ipc_valid_blocked send_ipc_released_ipc_queues send_ipc_active_reply_scs send_ipc_active_scs_valid + send_ipc_sorted_ipc_queues -crunch reply_push - for not_in_release_q[wp]: "not_in_release_q p" - (wp: crunch_wps simp: crunch_simps) +lemma valid_blocked_thread_tcb_at: + "valid_sender_sc_tcb_at t s \ tcb_at t s" + by (fastforce simp: vs_all_heap_simps obj_at_def is_tcb_def) lemma send_ipc_valid_sched: "\\s. valid_sched_except_blocked s @@ -14031,104 +14628,14 @@ lemma send_ipc_valid_sched: \ not_queued t s \ not_in_release_q t s \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) - \ current_time_bounded s\ + \ current_time_bounded s + \ valid_objs s\ send_ipc block call badge can_grant can_grant_reply can_donate t epptr - \\rv. valid_sched :: 'state_ext state \ _\" - \ \We can prove this lemma two different ways.\ - apply (rule conj_absorb[THEN iffD1, OF conjI]) - \ \Firstly, we simply use the lemmas above, which unbundle valid_sched for send_ipc.\ - apply (wpsimp wp: send_ipc_valid_sched_unbundled simp: valid_sched_def) - apply (clarsimp simp: vs_all_heap_simps) - \ \Secondly, we can independently perform a bundled proof. Although this is redundant, this - might be preferable to the unbundled proofs, since it avoids duplication of proof structure, - and checks faster than the collection of unbundled proofs. However, it is currently not - possible to drop the unbundled lemmas, since they are needed for existing unbundled - charge_budget lemmas.\ - unfolding send_ipc_def if_cond_refill_unblock_check_def - supply if_split[split del] - apply (rule bind_wp[OF _ get_simple_ko_inv]) - apply (case_tac "\dest queue. ep \ RecvEP (dest # queue)"; clarsimp) - apply (case_tac "\q. ep = RecvEP q", elim exE, (case_tac q; simp)) - apply (case_tac ep; simp - ; wpsimp wp: set_thread_state_ipc_queued_valid_blocked_except_set - set_thread_state_valid_sched_except_blocked - simp: valid_sched_valid_sched_except_blocked scheduler_act_not_def - ; clarsimp elim!: valid_blocked_divided_threadE) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp[OF _ gts_sp], simp add: pred_conj_def obj_at_kh_kheap_simps pred_map_eq_normalise) - apply ((case_tac recv_state; clarsimp), rename_tac ep_ptr reply_opt) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule_tac Q'="\_ s. valid_sched_except_blocked s \ valid_blocked_except t s - \ released_if_bound_sc_tcb_at dest s - \ (valid_blocked_tcb_at t s \ block \ pred_map bound (tcb_faults_of s) t) - \ (can_donate \ pred_map bound (tcb_scps_of s) t \ \ timeout_faulted_tcb_at t s) - \ valid_sender_sc_tcb_at t s - \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) - \ scheduler_act_not t s \ not_queued t s \ not_in_release_q t s - \ dest \ idle_thread s - \ \ pred_map runnable (tcb_sts_of s) dest \ current_time_bounded s" - in bind_wp_fwd) - apply (wpsimp wp: reply_unlink_tcb.valid_sched_lemmas hoare_vcg_disj_lift simp: valid_sched_def) - apply (simp flip: id_def)? \ \Unifier did something weird here\ - apply (prop_tac "\ pred_map runnable (tcb_sts_of s) dest \ released_if_bound_sc_tcb_at dest s" - , clarsimp simp: tcb_sts.pred_map_simps elim!: released_ipc_queues_blocked_on_recv_ntfn_E1) - apply (prop_tac "dest \ idle_thread s", clarsimp simp: vs_all_heap_simps) - apply (clarsimp elim!: released_ipc_queuesE) - apply (clarsimp simp: vs_all_heap_simps split: if_splits) - apply (rule bind_wp[OF _ gsc_sp], clarsimp simp: pred_conj_def obj_at_kh_kheap_simps pred_map_eq_normalise) - apply (rule bind_wp[OF _ thread_get_sp]) - apply (rule_tac Q'="\_ s. valid_sched s \ released_if_bound_sc_tcb_at dest s \ dest \ idle_thread s - \ current_time_bounded s \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) - \ not_in_release_q dest s" - in bind_wp) - apply (wpsimp wp: possible_switch_to_valid_sched_weak - refill_unblock_check_valid_sched_except_blocked) - apply (rule_tac Q'="\_ s. pred_map runnable (tcb_sts_of s) dest - \ dest \ idle_thread s \ released_if_bound_sc_tcb_at dest s" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_map_simps) - apply (wpsimp wp: get_tcb_obj_ref_wp)+ - apply (rule_tac Q'="\_ s. valid_sched_except_blocked s \ valid_blocked_except dest s - \ pred_map runnable (tcb_sts_of s) dest \ current_time_bounded s - \ dest \ idle_thread s \ released_if_bound_sc_tcb_at dest s - \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) - \ not_in_release_q dest s \ active_scs_valid s" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_map_eq obj_at_def released_sc_tcb_at_def - split: if_split) - apply (erule disjE; clarsimp simp: vs_all_heap_simps tcb_at_kh_simps opt_map_red) - apply (clarsimp simp: heap_refs_inv_def2 tcb_at_kh_simps sc_at_kh_simps vs_all_heap_simps pred_map_eq) - apply (rename_tac scp sc' n sc; frule_tac x=t and y=scp in spec2) - apply (frule_tac x=dest and y=scp in spec2, fastforce simp: opt_map_red) - apply (subst conj_assoc[symmetric]) - apply (rule hoare_vcg_conj_lift, subst pred_conj_def[symmetric]) - apply (wpsimp wp: set_thread_state_break_valid_sched) - apply (wpsimp wp: set_thread_state_pred_map_tcb_sts_of) - apply clarsimp - apply (simp add: pred_conj_def obj_at_def valid_blocked_thread_def) - apply (intro hoare_if[rotated] hoare_when_cases) - apply clarsimp - apply (intro conjI) - apply (clarsimp simp: valid_sched_valid_sched_except_blocked vs_all_heap_simps - elim!: valid_blockedE') - apply (clarsimp simp: valid_release_q_def valid_sched_def in_release_q_def) - apply (wpsimp wp: sched_context_donate_valid_sched sched_context_donate_not_in_release_q - sched_context_donate_released_if_bound_callee get_tcb_obj_ref_wp) - apply (prop_tac "not_in_release_q dest s") - apply (clarsimp simp: valid_release_q_def in_release_q_def valid_sched_def) - apply (clarsimp simp: obj_at_kh_kheap_simps pred_map_eq_normalise vs_all_heap_simps - valid_sched_valid_sched_except_blocked - elim!: valid_blockedE') - apply (wpsimp wp: set_thread_state_Inactive_not_queued_valid_sched simp: valid_sched_def) - apply (clarsimp simp: valid_release_q_def in_release_q_def) - apply (wpsimp wp: reply_push_released_if_bound_callee) - apply (prop_tac "not_in_release_q dest s") - apply (clarsimp simp: valid_release_q_def in_release_q_def valid_sched_def) - apply simp - \ \Focus on just the assumption we need to speed up the proof\ - by (match premises in H: \timeout_faulted_tcb_at t s \ active_sc_tcb_at t s \ released_if_bound_sc_tcb_at t s\ - and D: \can_donate \ _\ for s - \ \insert D H, fastforce simp: vs_all_heap_simps\) + \\_. valid_sched :: 'state_ext state \ _\" + apply (wpsimp wp: send_ipc_valid_sched_unbundled simp: valid_sched_def) + apply (frule valid_blocked_thread_tcb_at) + apply (clarsimp simp: vs_all_heap_simps) + done lemma send_fault_ipc_valid_sched_misc[wp]: "send_fault_ipc t handler_cap fault can_donate @@ -14226,13 +14733,22 @@ lemma send_fault_ipc_active_reply_scs: \\_. active_reply_scs :: 'state_ext state \ _\" unfolding send_fault_ipc_def by (wpsimp wp: send_ipc_active_reply_scs) +lemma send_fault_ipc_sorted_ipc_queues: + "\(sorted_ipc_queues and tcb_at t and valid_objs) and K (valid_fault fault)\ + send_fault_ipc t handler_cap fault can_donate + \\_. sorted_ipc_queues :: 'state_ext state \ _\" + unfolding send_fault_ipc_def + apply (rule hoare_gen_asm) + by (wpsimp wp: send_ipc_sorted_ipc_queues thread_set_fault_valid_objs) + lemmas send_fault_ipc_valid_sched_unbundled = send_fault_ipc_valid_ready_qs send_fault_ipc_valid_release_q send_fault_ipc_ct_not_in_q send_fault_ipc_valid_sched_action send_fault_ipc_ct_in_cur_domain send_fault_ipc_valid_blocked send_fault_ipc_released_ipc_queues send_fault_ipc_active_reply_scs + send_fault_ipc_sorted_ipc_queues lemma send_fault_ipc_valid_sched: - "\\s. valid_sched_except_blocked s + "\(\s. valid_sched_except_blocked s \ idle_thread_is_idle s \ \In do_reply_transfer, valid_blocked might be broken for handle_timeout\ \ valid_blocked_except t s @@ -14246,11 +14762,14 @@ lemma send_fault_ipc_valid_sched: \ not_queued t s \ not_in_release_q t s \ active_scs_valid s - \ current_time_bounded s \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s)\ + \ current_time_bounded s \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) + \ valid_objs s) + and K (valid_fault fault)\ send_fault_ipc t handler_cap fault can_donate \\rv. valid_sched :: 'state_ext state \ _\" + apply (rule hoare_gen_asm) unfolding send_fault_ipc_def - apply (wpsimp wp: send_ipc_valid_sched thread_set_fault_valid_sched_pred) + apply (wpsimp wp: send_ipc_valid_sched thread_set_fault_valid_sched_pred thread_set_fault_valid_objs) by (auto simp: valid_sched_def heap_upd_def vs_all_heap_simps is_timeout_fault_def is_timeout_fault_opt_def elim!: released_ipc_queuesE valid_blocked_divided_threadE @@ -14318,10 +14837,18 @@ lemma handle_timeout_active_reply_scs: \\_. active_reply_scs :: 'state_ext state \ _\" unfolding handle_timeout_def by (wpsimp wp: send_fault_ipc_active_reply_scs) +lemma handle_timeout_sorted_ipc_queues: + "\\s. sorted_ipc_queues s \ valid_objs s \ tcb_at t s \ is_timeout_fault timeout\ + handle_timeout t timeout + \\_. sorted_ipc_queues :: 'state_ext state \ _\" + unfolding handle_timeout_def + by (wpsimp wp: send_fault_ipc_sorted_ipc_queues simp: valid_fault_def is_timeout_fault_def) + lemmas handle_timeout_valid_sched_bundled = handle_timeout_valid_ready_qs handle_timeout_valid_release_q handle_timeout_ct_not_in_q handle_timeout_valid_sched_action handle_timeout_ct_in_cur_domain handle_timeout_valid_blocked handle_timeout_released_ipc_queues handle_timeout_active_reply_scs + handle_timeout_sorted_ipc_queues lemma handle_timeout_valid_sched: "\\s. valid_sched_except_blocked s @@ -14332,11 +14859,14 @@ lemma handle_timeout_valid_sched: \ not_queued t s \ not_in_release_q t s \ is_timeout_fault timeout \ active_scs_valid s - \ current_time_bounded s \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s)\ + \ current_time_bounded s \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) + \ valid_objs s\ handle_timeout t timeout \\rv. valid_sched :: 'state_ext state \ _\" unfolding handle_timeout_def - by (wpsimp wp: send_fault_ipc_valid_sched) + apply (wpsimp wp: send_fault_ipc_valid_sched) + apply (fastforce simp: is_timeout_fault_def valid_fault_def) + done end @@ -14573,10 +15103,12 @@ abbreviation (input) \ idle_thread_is_idle s \ receiver \ idle_thread s \ active_if_bound_sc_tcb_at receiver s + \ valid_objs s \ valid_mdb s \ current_time_bounded s" lemma valid_sched_active_reply_scs[simp,elim!]: - "valid_sched_2 wk_vsa vbl riq ctime cdom ct it queues rlq sa etcbs tcb_sts tcb_scps tcb_faults sc_refill_cfgs sc_repls + "valid_sched_2 wk_vsa vbl riq ctime cdom ct it queues rlq sa etcbs tcb_sts tcb_scps tcb_faults + sc_refill_cfgs sc_repls ep_qs ntfn_qs prios \ active_reply_scs_2 sc_repls sc_refill_cfgs" by (simp add: valid_sched_def) @@ -14593,9 +15125,16 @@ lemma refill_unblock_check_active_if_bound_sc_tcb_at[wp]: apply (erule disjE; fastforce simp: obj_at_def pred_map_eq vs_all_heap_simps) done +crunch handle_fault_reply + for valid_mdb[wp]: "valid_mdb :: 'state_ext state \ _" + +lemma tcb_fault_update_None_valid_mdb[wp]: + "thread_set (tcb_fault_update (\_. None)) t \valid_mdb\" + by (wpsimp wp: thread_set_mdb | fastforce simp: ran_tcb_cap_cases)+ + lemma do_reply_transfer_valid_sched: "\\s. valid_sched s \ valid_objs s \ valid_replies s \ valid_idle s \ sym_refs (state_refs_of s) - \ current_time_bounded s\ + \ valid_objs s \ valid_mdb s \ pspace_aligned s \ pspace_distinct s \current_time_bounded s\ do_reply_transfer sender reply grant \\rv. valid_sched::'state_ext state \ _\" apply (simp add: do_reply_transfer_def maybeM_def) @@ -14613,6 +15152,7 @@ lemma do_reply_transfer_valid_sched: \ idle_thread_is_idle s \ receiver \ idle_thread s \ active_if_bound_sc_tcb_at receiver s + \ valid_objs s \ valid_mdb s \ pspace_aligned s \ pspace_distinct s \ current_time_bounded s" in bind_wp_fwd) apply (wpsimp wp: reply_remove_valid_sched reply_remove_tcb_scps_of_retract @@ -14640,7 +15180,8 @@ lemma do_reply_transfer_valid_sched: apply (rule_tac Q'="\_ s. do_reply_transfer_pred receiver s" in bind_wp_fwd) apply (wpsimp wp: set_thread_state_not_runnable_valid_sched_except_blocked set_thread_state_valid_blocked_const - thread_set_fault_valid_sched_pred + thread_set_fault_valid_sched_pred thread_set_fault_valid_objs + hoare_vcg_imp_lift' simp: if_distrib) apply (prop_tac "\ pred_map runnable (tcb_sts_of s) receiver", clarsimp simp: vs_all_heap_simps) apply (prop_tac "not_queued receiver s" @@ -14682,7 +15223,8 @@ lemma handle_fault_valid_sched: and not_queued thread and not_in_release_q thread and released_if_bound_sc_tcb_at thread and K (\ is_timeout_fault ex) and current_time_bounded - and (\s. heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s))\ + and (\s. heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s)) + and K (valid_fault ex)\ handle_fault thread ex \\rv. valid_sched::'state_ext state \ _\" apply (clarsimp simp: handle_fault_def unless_def) @@ -15015,6 +15557,15 @@ lemma send_signal_WN_sym_refs_helper: apply (fastforce split: if_split option.split simp: state_refs_of_def refs_of_def vs_all_heap_simps) done +crunch maybe_donate_sc + for sorted_ipc_queues[wp]: sorted_ipc_queues + (wp: crunch_wps simp: crunch_simps) + +(* FIXME RT: move *) +lemma tl_subseq: + "subseq (tl ls) ls" + by fastforce + lemma send_signal_WaitingNtfn_helper: "ntfn_obj ntfn = WaitingNtfn wnlist \ \ko_at (Notification ntfn) ntfnptr and @@ -15086,18 +15637,32 @@ lemma send_signal_WaitingNtfn_helper: apply (rule set_thread_state_break_valid_sched[simplified pred_conj_def]) apply (wpsimp wp: set_thread_state_pred_map_tcb_sts_of) apply simp - apply wpsimp + apply (wpsimp wp: set_notification_valid_sched) apply wpsimp apply (wpsimp wp: assert_inv) apply (clarsimp simp: valid_sched_def invs_valid_objs) + apply (rule conjI) + apply (frule sorted_ipc_queues_notification_priority_ordered[where ptr=ntfnptr and q=wnlist]) + apply (clarsimp simp: obj_at_def opt_map_def split: option.splits) + apply (erule sorted_wrt_subseq) + apply (case_tac "tl wnlist"; clarsimp) + apply (clarsimp simp: obj_at_def opt_map_def) + apply (metis tl_subseq) + apply (frule invs_valid_objs) + apply (frule invs_sym_refs) + apply (frule invs_valid_idle) + apply (prop_tac "valid_ntfn ntfn s") + apply (fastforce simp: obj_at_def valid_obj_def) + apply (clarsimp simp: obj_at_def) + apply (frule (3) st_in_waitingntfn) + apply (drule_tac x="hd wnlist" in bspec, fastforce) apply (intro conjI; simp add: pred_tcb_at_eq_commute) apply (clarsimp simp: pred_tcb_at_def obj_at_def elim!: valid_ready_qs_not_queued_not_runnable) - apply (fastforce dest: st_tcb_at_idle_thread) - apply (subgoal_tac "valid_ntfn ntfn s") - apply (clarsimp simp: valid_ntfn_def split: list.splits option.splits) - apply (case_tac wnlist; simp) - apply (frule invs_valid_objs, fastforce simp: pred_tcb_at_def valid_objs_def dom_def obj_at_def valid_obj_def) + apply (fastforce dest: st_tcb_at_idle_thread) + apply (clarsimp simp: pred_tcb_at_def obj_at_def valid_idle_def) + apply (clarsimp simp: valid_ntfn_def split: list.splits option.splits) + apply (case_tac wnlist; simp) apply (rule valid_sched_not_runnable_scheduler_act_not; clarsimp simp: valid_sched_def tcb_at_kh_simps pred_map_def) apply (rule valid_sched_not_runnable_not_in_release_q; clarsimp simp: valid_sched_def tcb_at_kh_simps pred_map_def) apply (prop_tac "ipc_queued_thread (hd wnlist) s", simp add: tcb_at_kh_simps pred_map_def) @@ -15106,15 +15671,18 @@ lemma send_signal_WaitingNtfn_helper: lemma cancel_signal_valid_sched: "\valid_sched and st_tcb_at (Not \ runnable) tcbptr\ - cancel_signal tcbptr ntfnptr - \\rv. valid_sched\" + cancel_signal tcbptr ntfnptr + \\_. valid_sched\" unfolding cancel_signal_def - apply (wpsimp wp: set_thread_state_valid_sched - set_object_wp get_simple_ko_wp) + apply (wpsimp wp: set_thread_state_valid_sched set_notification_valid_sched_except_blocked + get_simple_ko_wp) apply (strengthen valid_sched_not_runnable_scheduler_act_not valid_sched_not_runnable_not_in_release_q valid_sched_not_runnable_not_queued) - by (clarsimp simp: valid_sched_def tcb_at_kh_simps pred_map_def) + apply (clarsimp simp: valid_sched_def tcb_at_kh_simps pred_map_def sorted_ipc_queues_def) + apply (drule_tac x=ntfnptr in spec) + apply (clarsimp elim!: sorted_wrt_subseq simp: remove1_subseq list_case_If opt_map_def obj_at_def) + done lemma blocked_cancel_ipc_BOR_valid_sched': "\valid_sched and st_tcb_at (\ts. \ runnable ts) tcbptr\ @@ -15135,18 +15703,31 @@ lemma blocked_cancel_ipc_BOR_valid_sched': apply (simp add: vs_all_heap_simps obj_at_kh_kheap_simps) apply (wpsimp simp: get_blocking_object_def wp: get_simple_ko_wp reply_unlink_tcb_valid_sched)+ - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_all_lift hoare_drop_imp set_object_wp - simp: set_simple_ko_def get_blocking_object_def)+ - apply (clarsimp simp: scheduler_act_not_def valid_sched_def valid_sched_action_def - weak_valid_sched_action_2_def st_tcb_at_def obj_at_def) - apply (intro conjI impI) - apply (erule valid_ready_qs_not_queued_not_runnable) - apply (clarsimp simp: st_tcb_at_def obj_at_def) - apply (erule valid_release_q_not_in_release_q_not_runnable) - apply (simp add: vs_all_heap_simps obj_at_kh_kheap_simps) + apply (rule_tac Q'="\_ s. valid_sched s \ scheduler_act_not tcbptr s + \ st_tcb_at (\st. \ runnable st) tcbptr s + \ not_queued tcbptr s \ not_in_release_q tcbptr s" + in hoare_post_imp, fastforce) + apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_all_lift + get_simple_ko_wp assert_opt_wp set_endpoint_valid_sched_except_blocked + set_endpoint_valid_sched + simp: get_blocking_object_def get_ep_queue_def)+ + apply (rename_tac ep_ptr ep') + apply (frule valid_sched_valid_release_q) + apply (frule valid_release_q_not_in_release_q_not_runnable[where t=tcbptr]) + apply (clarsimp simp: pred_tcb_weakenE) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_ready_qs_not_queued_not_runnable[where t=tcbptr]) + apply (clarsimp simp: pred_tcb_weakenE) + apply (clarsimp simp: st_tcb_at_def obj_at_def) + apply (prop_tac "scheduler_act_not tcbptr s") apply (clarsimp simp: scheduler_act_not_def valid_sched_def valid_sched_action_def - weak_valid_sched_action_2_def st_tcb_at_def obj_at_def vs_all_heap_simps)+ - done + weak_valid_sched_action_2_def vs_all_heap_simps) + apply clarsimp + apply (frule valid_sched_sorted_ipc_queues) + apply (frule_tac ptr=ep_ptr and q="ep_queue ep'" in sorted_ipc_queues_endpoint_priority_ordered) + apply (clarsimp simp: eps_of_kh_def sorted_ipc_queues_def opt_map_def) + by (auto elim!: sorted_wrt_subseq + simp: remove1_subseq list_case_If opt_map_def eps_of_kh_def) lemma blocked_cancel_ipc_BOR_st_tcb_at_not_runnable[wp]: "\tcb_at tcbptr\ @@ -15313,6 +15894,10 @@ lemma maybe_donate_sc_valid_blocked: by (wpsimp wp: sched_context_donate_valid_blocked get_sc_obj_ref_wp get_sk_obj_ref_wp get_tcb_obj_ref_wp) +crunch maybe_donate_sc + for sorted_ipc_queues[wp]: "sorted_ipc_queues_except_set S" + (wp: crunch_wps simp: crunch_simps) + lemma maybe_donate_sc_valid_sched: "\valid_sched and not_queued tcb_ptr and scheduler_act_not tcb_ptr @@ -15365,7 +15950,8 @@ lemma complete_signal_valid_sched: apply (prop_tac "heap_ref_eq a tcb_ptr (tcb_scps_of s)") apply (clarsimp simp: tcb_at_kh_simps vs_all_heap_simps) apply (fastforce simp: heap_refs_inv_def2 vs_all_heap_simps opt_map_red tcb_at_kh_simps obj_at_def) - apply (wpsimp wp: maybe_donate_sc_valid_sched maybe_donate_sc_in_release_q_imp_not_ready) + apply (wpsimp wp: maybe_donate_sc_valid_sched maybe_donate_sc_in_release_q_imp_not_ready + set_notification_valid_sched) done lemma refill_unblock_check_ko_at_endoint[wp]: @@ -15495,7 +16081,7 @@ lemma send_signal_valid_sched: apply (rule bind_wp[OF _ get_simple_ko_sp]) apply (case_tac "ntfn_obj ntfn"; clarsimp) apply (case_tac "ntfn_bound_tcb ntfn"; clarsimp) - apply wpsimp + apply (wpsimp wp: set_notification_valid_sched) apply (rule bind_wp[OF _ gts_sp]) apply (case_tac st; clarsimp simp: receive_blocked_def) prefer 4 @@ -15520,8 +16106,7 @@ lemma send_signal_valid_sched: apply (clarsimp simp: valid_ntfn_def) apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_objs_def valid_obj_def dom_def obj_at_def) - apply (wpsimp+)[8] - done + by (wpsimp wp: set_notification_valid_sched simp: valid_sched_def sorted_ipc_queues_def)+ lemma receive_ipc_preamble_valid_sched: "\valid_sched and invs\ @@ -15564,9 +16149,10 @@ crunch receive_ipc_preamble (* Preconditions for the guts of receive_ipc, after the reply preamble *) abbreviation (input) receive_ipc_valid_sched_preconds :: - "obj_ref \ obj_ref \ cap \ obj_ref option \ endpoint \ ('state_ext state \ bool) \ 'state_ext state \ bool" + "obj_ref \ obj_ref \ cap \ obj_ref option \ endpoint \ obj_ref list + \ ('state_ext state \ bool) \ 'state_ext state \ bool" where - "receive_ipc_valid_sched_preconds t ep_ptr reply reply_opt ep ex_invs \ + "receive_ipc_valid_sched_preconds t ep_ptr reply reply_opt ep queue ex_invs \ \s. valid_sched s \ st_tcb_at active t s \ cur_thread s = t @@ -15575,29 +16161,35 @@ abbreviation (input) receive_ipc_valid_sched_preconds :: \ scheduler_act_not t s \ released_if_bound_sc_tcb_at t s \ receive_ipc_preamble_rv reply reply_opt s - \ ko_at (Endpoint ep) ep_ptr s + \ ep_at_pred (\endpoint. endpoint = ep \ ep_queue ep = queue) ep_ptr s \ ex_invs s" lemma receive_ipc_blocked_valid_sched': assumes ep: "case ep of IdleEP \ queue = [] | RecvEP q \ queue = q | SendEP _ \ False" - shows "\ receive_ipc_valid_sched_preconds t ep_ptr reply reply_opt ep invs \ - receive_ipc_blocked is_blocking t ep_ptr reply_opt pl queue - \ \rv. valid_sched \" - apply (cases reply_opt; clarsimp simp: receive_ipc_blocked_def) - apply (wpsimp wp: set_thread_state_valid_sched) - apply (clarsimp simp: valid_sched_def) - apply (wpsimp wp: set_thread_state_valid_sched) + shows "\receive_ipc_valid_sched_preconds t ep_ptr reply reply_opt ep queue invs\ + receive_ipc_blocked is_blocking t ep_ptr reply_opt pl queue + \\_. valid_sched\" + apply (clarsimp simp: receive_ipc_blocked_def) + apply (wpsimp wp: set_thread_state_valid_sched set_endpoint_valid_sched hoare_vcg_ball_lift) + apply (clarsimp simp: valid_sched_def) + apply (intro conjI) + apply (fastforce dest!: sorted_ipc_queues_endpoint_priority_ordered[where ptr=ep_ptr] + simp: obj_at_def opt_map_def eps_of_kh_def ep_at_pred_def) + apply (frule invs_valid_objs) + apply (frule valid_objs_ko_at) + apply (fastforce simp: ep_at_pred_def obj_at_def) + apply (force simp: valid_obj_def valid_ep_def ep_at_pred_def obj_at_def split: endpoint.splits) apply (clarsimp simp: valid_sched_def) done lemma receive_ipc_idle_valid_sched: - "\ receive_ipc_valid_sched_preconds t ep_ptr reply reply_opt IdleEP invs \ + "\ receive_ipc_valid_sched_preconds t ep_ptr reply reply_opt IdleEP queue invs \ receive_ipc_idle is_blocking t ep_ptr reply_opt pl \ \rv. valid_sched \" apply (rule hoare_weaken_pre, rule monadic_rewrite_refine_valid[where P''=\]) apply (rule monadic_rewrite_receive_ipc_idle) apply (rule receive_ipc_blocked_valid_sched'[where ep=IdleEP and reply=reply]) - by (auto simp: st_tcb_at_tcb_at) + by (auto simp: st_tcb_at_tcb_at ep_at_pred_def) lemmas receive_ipc_blocked_valid_sched = receive_ipc_blocked_valid_sched'[where ep="RecvEP queue" and queue=queue for queue, simplified] @@ -15624,10 +16216,21 @@ lemma receive_ipc_preamble_rv_reprogram_timer[simp]: "receive_ipc_preamble_rv a b (s\reprogram_timer := True\) = receive_ipc_preamble_rv a b s" by (cases b; fastforce) +lemma update_sched_context_ep_at_pred[wp]: + "update_sched_context sc_ptr f \\s. Q (ep_at_pred P ptr s)\" + apply (wpsimp wp: update_sched_context_wp) + by (clarsimp simp: ep_at_pred_def obj_at_def) + crunch refill_unblock_check for receive_ipc_preamble_rv[wp]: "receive_ipc_preamble_rv a b" + and ep_at_pred[wp]: "\s. Q (ep_at_pred P ptr s)" (wp: crunch_wps hoare_vcg_if_lift2 simp: is_round_robin_def) +lemma set_endpoint_ep_at_pred[wp]: + "\\s. P ep\ set_endpoint ep_ptr ep \\_. ep_at_pred P ep_ptr\" + apply (wpsimp wp: set_simple_ko_wp) + by (clarsimp simp: ep_at_pred_def) + lemma receive_ipc_valid_sched: "\\s. valid_sched s \ st_tcb_at active thread s @@ -15657,10 +16260,11 @@ lemma receive_ipc_valid_sched: apply (rule bind_wp[OF _ gbn_sp[simplified pred_conj_comm]]) apply (rule bind_wp[OF _ get_notification_default_sp]) apply (rule hoare_weaken_pre) - apply (rule_tac P''="receive_ipc_valid_sched_preconds thread ep_ptr reply_cap reply_opt ep - (invs and current_time_bounded)" + apply (rule_tac P''="receive_ipc_valid_sched_preconds + thread ep_ptr reply_cap reply_opt ep (ep_queue ep) + (invs and current_time_bounded)" in hoare_vcg_if_split, wp complete_signal_valid_sched) - prefer 2 apply (clarsimp simp: runnable_eq_active) + prefer 2 apply (clarsimp simp: runnable_eq_active ep_at_pred_def obj_at_def) apply (thin_tac "\ (_ \ _)", clarsimp) apply (rule_tac Q'="\r s. valid_sched s \ st_tcb_at active thread s \ @@ -15673,12 +16277,14 @@ lemma receive_ipc_valid_sched: ko_at (Endpoint ep) ep_ptr s \ invs s \ current_time_bounded s" in bind_wp_fwd) apply (wpsimp split: if_split) - apply (frule (1) not_idle_thread[OF invs_valid_idle], simp) + apply (frule (1) not_idle_thread[OF invs_valid_idle], simp add: obj_at_def ep_at_pred_def) apply (case_tac ep; simp) - \ \IdleEP, RecvEP\ - apply (wpsimp wp: receive_ipc_blocked_valid_sched[where reply=reply_cap]) - prefer 2 - apply (wpsimp wp: receive_ipc_blocked_valid_sched[where reply=reply_cap]) + \ \IdleEP, RecvEP\ + apply (wpsimp wp: receive_ipc_blocked_valid_sched[where reply=reply_cap]) + apply (fastforce simp: ep_at_pred_def obj_at_def) + prefer 2 + apply (wpsimp wp: receive_ipc_blocked_valid_sched[where reply=reply_cap]) + apply (fastforce simp: ep_at_pred_def obj_at_def) \ \SendEP\ apply (rename_tac queue) apply (rule bind_wp[OF _ assert_sp], simp) @@ -15693,21 +16299,28 @@ lemma receive_ipc_valid_sched: apply (rule_tac s="mk_ep SendEP queue" in subst[where P="\c. \P\ set_endpoint p c >>= r \Q\" for P p r Q] , simp add: mk_ep_def split: list.splits) apply (rule_tac Q'="\r. receive_ipc_valid_sched_preconds thread ep_ptr reply_cap reply_opt - (mk_ep SendEP queue) + (mk_ep SendEP queue) queue (\s. sym_refs (\p. if p = ep_ptr then set (sender # queue) \ {EPSend} else state_refs_of s p) \ all_invs_but_sym_refs s \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) \ current_time_bounded s)" in bind_wp_fwd) - apply (wpsimp wp: hoare_vcg_ball_lift set_simple_ko_at valid_ioports_lift) + apply (wpsimp wp: hoare_vcg_ball_lift set_simple_ko_at valid_ioports_lift set_endpoint_valid_sched) apply (frule invs_sym_refs, frule sym_refs_inj_tcb_scps) apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) apply (apply_conjunct \erule delta_sym_refs; fastforce simp: ko_at_state_refs_ofD split: if_splits\) - apply (fastforce elim!: obj_at_valid_objsE if_live_then_nonz_capD2 heap_refs_injD - simp: valid_obj_def valid_ep_def mk_ep_def live_def - split: endpoint.splits if_splits) + apply (intro conjI impI allI) + apply (frule valid_sched_sorted_ipc_queues) + apply (frule_tac ptr=ep_ptr and q="sender # queue" + in sorted_ipc_queues_endpoint_priority_ordered) + apply (clarsimp simp: obj_at_def opt_map_def eps_of_kh_def) + apply (fastforce simp: mk_ep_def split: if_splits) + apply (fastforce simp: mk_ep_def split: if_splits) + apply (fastforce elim!: obj_at_valid_objsE simp: valid_obj_def valid_ep_def mk_ep_def + split: if_splits) + apply (fastforce elim!: obj_at_valid_objsE if_live_then_nonz_capD2 simp: live_def) \ \get_thread_state\ apply (rule bind_wp[OF _ gts_sp]) apply (rename_tac sender_state) @@ -15715,7 +16328,7 @@ lemma receive_ipc_valid_sched: apply (rename_tac ep_ptr' sender_data) \ \do_ipc_transfer, and stash some knowledge for later\ apply (rule_tac Q'="\r. receive_ipc_valid_sched_preconds thread ep_ptr reply_cap reply_opt - (mk_ep SendEP queue) + (mk_ep SendEP queue) queue (\s. st_tcb_at ((=) (BlockedOnSend ep_ptr sender_data)) sender s \ state_refs_of s ep_ptr = set queue \ {EPSend} \ all_invs_but_sym_refs s @@ -15727,6 +16340,8 @@ lemma receive_ipc_valid_sched: , (drule_tac x=ep_ptr and y=sender and tp=TCBBlockedSend in sym_refsE ; fastforce simp: in_state_refs_of_iff refs_of_rev pred_tcb_at_def obj_at_def) , clarsimp) + apply (prop_tac "ko_at (Endpoint (mk_ep SendEP queue)) ep_ptr s") + apply (clarsimp simp: ep_at_pred_def obj_at_def) apply (frule ko_at_state_refs_ofD, simp) \ \refill_unblock_check\ apply (rule bind_wp[OF _ gsc_sp]) @@ -15816,10 +16431,17 @@ lemma receive_signal_valid_sched: apply (rule bind_wp[OF _ get_simple_ko_sp]) apply (rename_tac ntfn) apply (case_tac "ntfn_obj ntfn"; clarsimp simp: if_cond_refill_unblock_check_def) - apply (wpsimp wp: set_thread_state_valid_sched) + apply (wpsimp wp: set_thread_state_valid_sched set_notification_valid_sched) apply (clarsimp simp: valid_sched_def) - apply (wpsimp wp: set_thread_state_valid_sched) - apply (clarsimp simp: valid_sched_def) + apply (wpsimp wp: set_thread_state_valid_sched set_notification_valid_sched) + apply (rename_tac ntfn_ptr badge cap_rights ntfn queue s) + apply (intro conjI; fastforce?) + apply (frule valid_sched_sorted_ipc_queues) + apply (frule_tac ptr=ntfn_ptr and q=queue in sorted_ipc_queues_notification_priority_ordered) + apply (clarsimp simp: obj_at_def opt_map_def valid_obj_def valid_ntfn_def) + apply fastforce + apply (frule (1) valid_objs_ko_at) + apply (clarsimp simp: obj_at_def opt_map_def valid_obj_def valid_ntfn_def) apply (wpsimp wp: maybe_donate_sc_valid_sched hoare_vcg_if_lift2 refill_unblock_check_valid_sched get_tcb_obj_ref_wp simp: valid_ntfn_def) @@ -15835,7 +16457,8 @@ lemma receive_signal_valid_sched: apply (fastforce dest: valid_sched_no_active_sc_not_in_release_q[where tptr=thread] simp: vs_all_heap_simps obj_at_kh_kheap_simps pred_map_def heap_refs_inv_def2 pred_map_eq) - apply (wpsimp wp: maybe_donate_sc_valid_sched maybe_donate_sc_in_release_q_imp_not_ready)+ + apply (wpsimp wp: maybe_donate_sc_valid_sched maybe_donate_sc_in_release_q_imp_not_ready + set_notification_valid_sched)+ done crunch restart_thread_if_no_fault @@ -16027,8 +16650,14 @@ lemma handle_recv_valid_sched: catch_wp[OF handle_fault_valid_sched] weaker_hoare_ifE[where P=P and P'=P for P, simplified pred_conj_def, simplified]; wpsimp wp: receive_ipc_valid_sched receive_signal_valid_sched; - clarsimp simp: ct_in_state_def elim!: invs_retract_tcb_scps) - by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps current_time_bounded_def) + clarsimp simp: ct_in_state_def) + apply (rule hoare_vcg_conj_elimE) + apply (simp add: lookup_cap_def lookup_slot_for_thread_def) + apply wp + apply (simp add: split_def) + apply (wp resolve_address_bits_valid_fault2)+ + by (auto elim!: invs_valid_tcb_ctable st_tcb_ex_cap + simp: obj_at_kh_kheap_simps vs_all_heap_simps valid_fault_def) crunch reply_from_kernel for valid_sched_pred[wp]: "valid_sched_pred_strong P" @@ -16105,6 +16734,10 @@ lemma thread_set_domain_valid_ready_qs_not_q: apply (rule_tac x=ref' in exI, clarsimp) done +crunch thread_set_domain + for sorted_ipc_queues[wp]: sorted_ipc_queues + (wp: crunch_wps sorted_ipc_queues_lift thread_set_prios_of ignore: thread_set) + lemma thread_set_domain_not_idle_valid_sched: "\valid_sched and scheduler_act_not tptr and not_queued tptr and (\s. tptr \ cur_thread s) and (\s. tptr \ idle_thread s) and valid_idle\ @@ -16229,11 +16862,9 @@ lemma invoke_domain_valid_sched: done lemma sched_context_bind_ntfn_valid_sched[wp]: - "\valid_sched\ - sched_context_bind_ntfn x21 x41 - \\_. valid_sched\" - unfolding sched_context_bind_ntfn_def - by wpsimp + "sched_context_bind_ntfn sc_ptr ntfn_ptr \valid_sched\" + unfolding sched_context_bind_ntfn_def + by wpsimp lemma refill_unblock_check_budget_ready_ct[wp]: "\\s. budget_ready (cur_thread s) s\ @@ -17779,9 +18410,8 @@ lemma charge_budget_valid_release_q: sc_at_pred_n_def obj_at_def ct_in_state_def pred_tcb_at_def runnable_eq_active split: if_splits) - apply (fastforce simp: cur_sc_chargeable_def obj_at_def valid_release_q_def - in_queue_2_def vs_all_heap_simps) - done + by (fastforce simp: cur_sc_chargeable_def obj_at_def valid_release_q_def + in_queue_2_def vs_all_heap_simps) lemma refill_reset_rr_active_sc_tcb_at[wp]: "refill_reset_rr scp \(\s. P (active_sc_tcb_at t s)) :: 'state_ext state \ _\" @@ -18046,6 +18676,28 @@ lemma charge_budget_ready_or_release: apply (clarsimp simp: charge_budget_def when_def) by (wpsimp wp: hoare_drop_imp) +lemma end_timeslice_sorted_ipc_queues: + "\sorted_ipc_queues and valid_objs and cur_tcb\ + end_timeslice canTimeout + \\_. sorted_ipc_queues :: 'state_ext state \ _\" + unfolding end_timeslice_def + apply (wpsimp wp: handle_timeout_sorted_ipc_queues) + apply (clarsimp simp: is_timeout_fault_def is_tcb_def) + done + +crunch refill_reset_rr + for sorted_ipc_queues[wp]: sorted_ipc_queues + +lemma charge_budget_sorted_ipc_queues: + "\sorted_ipc_queues and valid_objs and cur_tcb\ + charge_budget consumed canTimeout + \\_. sorted_ipc_queues :: 'state_ext state \ _ \" + apply (clarsimp simp: charge_budget_def refill_reset_rr_def when_def) + apply (wpsimp wp: end_timeslice_sorted_ipc_queues update_sched_context_valid_objs_same + hoare_drop_imp) + apply (clarsimp simp: valid_sched_context_def) + done + lemma charge_budget_valid_sched: "\valid_sched and (\s. heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s)) @@ -18058,7 +18710,8 @@ lemma charge_budget_valid_sched: and current_time_bounded and (\s. (canTimeout \ cur_sc_tcb_are_bound s \ cur_sc_active s)) and K (unat consumed + unat MAX_PERIOD \ unat max_time) - and cur_sc_offset_ready 0\ + and cur_sc_offset_ready 0 + and valid_objs and cur_tcb\ charge_budget consumed canTimeout \\_. valid_sched :: 'state_ext state \ _\" unfolding valid_sched_def @@ -18067,7 +18720,8 @@ lemma charge_budget_valid_sched: charge_budget_valid_sched_action charge_budget_released_ipc_queues charge_budget_active_reply_scs - charge_budget_ready_or_release) + charge_budget_ready_or_release + charge_budget_sorted_ipc_queues) apply (clarsimp simp: active_scs_valid_def) done @@ -18161,6 +18815,12 @@ lemma check_budget_ready_or_release: \\_. ready_or_release :: 'state_ext state \ _ \" unfolding check_budget_def by (wpsimp wp: charge_budget_ready_or_release) +lemma check_budget_sorted_ipc_queues: + "\sorted_ipc_queues and valid_objs and cur_tcb\ + check_budget + \\_. sorted_ipc_queues :: 'state_ext state \ _ \" + unfolding check_budget_def by (wpsimp wp: charge_budget_sorted_ipc_queues) + lemma check_budget_valid_sched: "\valid_sched and (\s. heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s)) @@ -18172,7 +18832,8 @@ lemma check_budget_valid_sched: and current_time_bounded and consumed_time_bounded and (\s. cur_sc_tcb_are_bound s \ cur_sc_active s) - and (\s. cur_sc_offset_ready (consumed_time s) s)\ + and (\s. cur_sc_offset_ready (consumed_time s) s) + and valid_objs and cur_tcb\ check_budget \\_. valid_sched::'state_ext state \ _\" apply (clarsimp simp: valid_sched_def) @@ -18181,7 +18842,8 @@ lemma check_budget_valid_sched: check_budget_valid_sched_action check_budget_released_ipc_queues check_budget_active_reply_scs - check_budget_ready_or_release) + check_budget_ready_or_release + check_budget_sorted_ipc_queues) lemma tcb_sched_dequeue_valid_blocked_except_set: "\\s. if not_queued tcb_ptr s then valid_blocked_except_set {tcb_ptr} s else valid_blocked s\ @@ -19073,7 +19735,8 @@ lemma check_budget_restart_valid_sched: and consumed_time_bounded and cur_sc_active and (\s. cur_sc_offset_ready (consumed_time s) s) - and cur_sc_not_blocked\ + and cur_sc_not_blocked + and valid_objs and cur_tcb\ check_budget_restart \\rv s::'state_ext state. \rv \ valid_sched s\" apply (clarsimp simp: check_budget_restart_def) @@ -19100,23 +19763,19 @@ lemma handle_yield_valid_sched: and (\s. cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s) and cur_sc_active\ handle_yield - \\rv. valid_sched::'state_ext state \ _\" + \\_. valid_sched::'state_ext state \ _\" unfolding handle_yield_def - apply (wpsimp wp: charge_budget_valid_sched get_refills_wp - simp: invs_retract_tcb_scps) - apply (intro conjI) - apply (clarsimp) - apply (drule ct_not_blocked_cur_sc_not_blocked; simp) - apply (rule_tac y=" unat MAX_PERIOD + unat MAX_PERIOD" in order_trans[rotated]) - apply (clarsimp simp: current_time_bounded_def) - apply (rule add_mono[rotated], simp) - apply (clarsimp simp: valid_sched_def active_scs_valid_def) - apply (drule_tac x="cur_sc s" in spec, clarsimp) - apply (clarsimp simp: word_le_nat_alt[symmetric]) - apply (rule valid_refills_r_amount_bounded_max_sc_period) - apply (clarsimp simp: valid_refills_def2 obj_at_def) - apply (clarsimp simp: cur_sc_offset_ready_def obj_at_def refill_ready_def current_time_bounded_def - vs_all_heap_simps) + apply (wpsimp wp: charge_budget_valid_sched get_refills_wp) + apply (intro conjI; fastforce?) + apply (drule ct_not_blocked_cur_sc_not_blocked; simp) + apply (rule_tac y=" unat MAX_PERIOD + unat MAX_PERIOD" in order_trans[rotated]) + apply (clarsimp simp: current_time_bounded_def) + apply (rule add_mono[rotated], simp) + apply (clarsimp simp: valid_sched_def active_scs_valid_def) + apply (drule_tac x="cur_sc s" in spec, clarsimp) + apply (clarsimp simp: word_le_nat_alt[symmetric]) + apply (rule valid_refills_r_amount_bounded_max_sc_period) + apply (clarsimp simp: valid_refills_def2 obj_at_def) done lemma update_time_stamp_ct_budget_ready[wp]: @@ -19275,7 +19934,7 @@ lemma invoke_domain_scheduler_act_sane[wp]: by (wpsimp simp: set_domain_def wp: hoare_vcg_if_lift2) lemma sched_context_bind_ntfn_valid_sched_pred_strong[wp]: - "sched_context_bind_ntfn sc ntfn \valid_sched_pred_strong P\" + "sched_context_bind_ntfn sc ntfn \valid_sched_pred P\" unfolding sched_context_bind_ntfn_def by wpsimp @@ -20524,7 +21183,7 @@ lemma check_budget_restart_valid_sched_weaker: \\rv s::det_ext state. \rv \ valid_sched s\" apply (wpsimp wp: check_budget_restart_valid_sched simp: consumed_time_bounded_def current_time_bounded_def) - apply (erule (2) ct_not_blocked_cur_sc_not_blocked[OF invs_cur_sc_chargeableE]) + apply (fastforce elim!: ct_not_blocked_cur_sc_not_blocked[OF invs_cur_sc_chargeableE]) done lemma check_budget_valid_sched_weaker: @@ -20540,8 +21199,8 @@ lemma check_budget_valid_sched_weaker: and (\s. cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s)\ check_budget \\_. valid_sched::det_ext state \ _\" - apply (wpsimp wp: check_budget_valid_sched simp: invs_retract_tcb_scps) - apply (erule (1) ct_not_blocked_cur_sc_not_blocked) + apply (wpsimp wp: check_budget_valid_sched) + apply (fastforce elim!: ct_not_blocked_cur_sc_not_blocked) done lemma check_budget_cur_sc_offset_sufficient_true[wp]: @@ -21856,6 +22515,26 @@ lemma refill_new_cur_sc_more_than_ready[wp]: unfolding refill_new_def by (wpsimp wp: update_sched_context_cur_sc_more_than_ready) +lemma sched_context_bind_ntfn_valid_sched_misc[wp]: + "sched_context_bind_ntfn sc_ptr ntfn_ptr + \\s. P (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) (prios_of s) + (consumed_time s)\" + unfolding sched_context_bind_ntfn_def + by wpsimp + +lemma sched_context_unbind_ntfn_valid_sched_misc[wp]: + "sched_context_unbind_ntfn sc_ptr + \\s. P (cur_time s) (cur_domain s) (cur_thread s) (idle_thread s) (cur_sc s) + (ready_queues s) (release_queue s) (scheduler_action s) + (etcbs_of s) (tcb_sts_of s) (tcb_scps_of s) (tcb_faults_of s) + (sc_refill_cfgs_of s) (sc_replies_of s) (ep_queues_of s) (ntfn_queues_of s) (prios_of s) + (consumed_time s)\" + unfolding sched_context_unbind_ntfn_def + by (wpsimp simp: get_sc_obj_ref_def) + lemma invoke_sched_context_cur_sc_more_than_ready[wp]: "\cur_sc_more_than_ready and valid_sched_context_inv iv @@ -22185,12 +22864,20 @@ lemma "restart tp \\s. cur_sc_active s \ cur_sc_offset_sufficient (consumed_time s) s\" unfolding restart_def by (wpsimp wp: | wp (once) hoare_drop_imp)+ +lemma sched_context_maybe_unbind_ntfn_cur_sc_offset_ready[wp]: + "sched_context_maybe_unbind_ntfn ntfn_ptr + \\s. cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s\" + and sched_context_maybe_unbind_ntfn_offset_sufficient[wp]: + "sched_context_maybe_unbind_ntfn ntfn_ptr + \\s. cur_sc_active s \ cur_sc_offset_sufficient (consumed_time s) s\" + unfolding sched_context_maybe_unbind_ntfn_def + by (wpsimp wp: get_sk_obj_ref_wp)+ + lemma fast_finalise_cur_sc_offset_ready[wp]: "fast_finalise cap final \\s. cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s\" apply (case_tac cap; (solves \wpsimp\)?; simp) - apply (wpsimp wp: gts_wp get_simple_ko_wp) - done + by (wpsimp wp: gts_wp get_simple_ko_wp) lemma fast_finalise_cur_sc_offset_sufficient[wp]: "fast_finalise cap final @@ -24221,7 +24908,7 @@ crunch cap_delete_one "\s :: det_state. (\t\set (release_queue s). pred_map (\a. \y. a = Some y) (tcb_scps_of s) t)" and heap_refs_inv_sc_tcbs_of[wp]: "\s :: det_state. heap_refs_inv (sc_tcbs_of s) (tcb_scps_of s)" - (simp: crunch_simps wp: crunch_wps) + (simp: crunch_simps wp: crunch_wps ignore: update_sched_context) lemma finalise_cap_release_q_not_blocked_on_reply[wp]: "finalise_cap cap final @@ -25211,10 +25898,9 @@ lemma handle_event_cur_sc_in_release_q_imp_zero_consumed: apply (clarsimp cong: conj_cong) apply (prop_tac "cur_sc_tcb_are_bound s") apply (rule invs_strengthen_cur_sc_tcb_are_bound, fastforce+) - apply (intro conjI impI; blast?) - apply (rule cur_sc_tcb_are_bound_cur_sc_in_release_q_imp_zero_consumed; assumption?) - apply (erule invs_sym_refs) - apply (erule schact_is_rct_sane) + apply (intro conjI impI; fastforce?) + apply (rule cur_sc_tcb_are_bound_cur_sc_in_release_q_imp_zero_consumed; assumption?) + apply (erule invs_sym_refs) apply (rule invs_cur_sc_chargeableE; assumption?) apply (rule ct_not_blocked_cur_sc_not_blocked) apply (rule invs_cur_sc_chargeableE; assumption?) @@ -26463,7 +27149,7 @@ lemma preemption_path_valid_sched: apply (rule hoare_if) apply (wpsimp wp: check_budget_valid_sched) apply (clarsimp simp: schedulable_def2) - apply (intro conjI impI) + apply (intro conjI impI; fastforce?) apply (erule (1) ct_not_blocked_cur_sc_not_blocked) apply (fastforce simp: cur_sc_chargeable_def vs_all_heap_simps) apply (clarsimp simp: vs_all_heap_simps) diff --git a/proof/invariant-abstract/EmptyFail_AI.thy b/proof/invariant-abstract/EmptyFail_AI.thy index 367830a4ef..9c94b74402 100644 --- a/proof/invariant-abstract/EmptyFail_AI.thy +++ b/proof/invariant-abstract/EmptyFail_AI.thy @@ -372,10 +372,6 @@ crunch sc_and_timer for (empty_fail) empty_fail[wp, intro!, simp] (wp: empty_fail_setDeadline empty_fail_whileLoop simp: Let_def) -lemma empty_fail_tcb_ep_find_index[wp]: - "empty_fail (tcb_ep_find_index t q n)" - by (induct n; wpsimp simp: tcb_ep_find_index.simps) - context EmptyFail_AI_schedule begin lemma schedule_choose_new_thread_empty_fail[intro!, wp, simp]: diff --git a/proof/invariant-abstract/Finalise_AI.thy b/proof/invariant-abstract/Finalise_AI.thy index 985b81689d..59790db47a 100644 --- a/proof/invariant-abstract/Finalise_AI.thy +++ b/proof/invariant-abstract/Finalise_AI.thy @@ -1561,12 +1561,9 @@ crunch test_reschedule, tcb_release_remove and obj_at[wp]: "\s. P (obj_at Q p s)" (wp: crunch_wps simp: crunch_simps) -lemma tcb_ep_find_index_inv[wp]: - "tcb_ep_find_index tptr qs curindex \P\" - by (induct curindex) (wpsimp | simp add: tcb_ep_find_index.simps)+ - crunch tcb_ep_dequeue, tcb_ep_append for inv[wp]: P + (wp: crunch_wps) lemmas complete_yield_to_final_cap[wp] = final_cap_lift [OF complete_yield_to_caps_of_state] diff --git a/proof/invariant-abstract/IpcDet_AI.thy b/proof/invariant-abstract/IpcDet_AI.thy index 22a236a90e..f07e8d56a6 100644 --- a/proof/invariant-abstract/IpcDet_AI.thy +++ b/proof/invariant-abstract/IpcDet_AI.thy @@ -93,28 +93,274 @@ lemma sfi_tcb_at [wp]: \\_. tcb_at t\" by (wpsimp simp: send_fault_ipc_def) -lemma tcb_ep_find_index_wp: - "\\s. (\i j. 0 \ i \ i \ Suc sz \ - (\tcb tcba. ko_at (TCB tcb) tptr s \ ko_at (TCB tcba) (queue ! j) s \ - (Suc j = i \ tcb_priority tcba \ tcb_priority tcb) \ - (i < j \ j \ sz \ tcb_priority tcba < tcb_priority tcb) \ Q i s))\ - tcb_ep_find_index tptr queue sz \Q\" - by (induct sz) (wp thread_get_wp' | simp add: tcb_ep_find_index.simps obj_at_def le_Suc_eq)+ +lemma distinct_map_fst_filter_zip: + "distinct list \ distinct (map fst (filter f (zip list zp)))" + apply (induct list rule: length_induct) + using distinct_map_filter distinct_prefix map_fst_zip_prefix + by blast + +lemma get_tcb_def2: + "get_tcb ptr = do { + kobj \ read_object ptr; + case kobj of TCB tcb \ oreturn tcb + | _ \ ofail + }" + unfolding get_tcb_def + by (rule ext; + clarsimp simp: get_tcb_def omonad_defs obind_def oreturn_def + split: option.splits Structures_A.kernel_object.splits)+ + +lemma get_tcb_wp: + "\\s. \tcb. kheap s tcb_ptr = Some (TCB tcb) \ P tcb s\ + get_tcb tcb_ptr + \P\" + apply (simp add: get_tcb_def2 del: read_object_def) + apply (rule obind_wp[OF _ read_object_sp], rename_tac r) + apply (case_tac r; wpsimp) + apply (simp add: obj_at_def) + done + +lemma thread_read_wp: + "\\s. \tcb. kheap s tcb_ptr = Some (TCB tcb) \ P (f tcb) s\ + thread_read f tcb_ptr + \P\" + unfolding thread_read_def + by (wpsimp wp: get_tcb_wp simp: oliftM_def) + +lemma ovalid_thread_read_sp: + "\P\ thread_read f ptr \\rv s. \tcb. kheap s ptr = Some (TCB tcb) \ f tcb = rv \ P s\" + by (wpsimp wp: thread_read_wp) + +lemma thread_read_no_ofail[wp]: + "no_ofail (tcb_at tcb_ptr) (thread_read f tcb_ptr)" + by (wpsimp simp: thread_read_def oliftM_def) + +crunch thread_get + for (empty_fail) empty_fail[wp] + +lemma no_fail_thread_get[wp]: + "no_fail (tcb_at tcb_ptr) (thread_get f tcb_ptr)" + unfolding thread_get_def + apply wpsimp + by (clarsimp simp: tcb_at_def) + +(* FIXME RT: move *) +lemma append_eq: + "\xs = zs; ys = ws\ \ xs @ ys = zs @ ws" + by fastforce + +(* FIXME: Should tcb_release_enqueue be defined using takeWhile/dropWhile? + As shown here, they're equivalent for sorted lists, so perhaps it doesn't matter. *) +definition insort_filter :: "('a \ bool) \ 'a \ 'a list \ 'a list" where + "insort_filter P x xs \ filter P xs @ x # filter (\x. \ P x) xs" + +definition insort_partition :: "('a \ bool) \ 'a \ 'a list \ 'a list" where + "insort_partition P x xs \ takeWhile P xs @ x # dropWhile P xs" + +lemma sorted_filter_takeWhile: + assumes tr: "transp cmp" + shows "sorted_wrt cmp xs \ filter (\x. cmp x y) xs = takeWhile (\x. cmp x y) xs" +proof (induct xs) + case (Cons x xs) + have xs: "sorted_wrt cmp xs" and x: "\z\set xs. cmp x z" using Cons.prems by auto + note eq = Cons.hyps[OF xs, symmetric] + show ?case + apply (clarsimp simp: eq filter_empty_conv dest!: bspec[OF x]) + by (drule (1) transpD[OF tr], simp) +qed auto + +lemma sorted_not_filter_dropWhile: + assumes tr: "transp cmp" + shows "sorted_wrt cmp xs \ filter (\x. \ cmp x y) xs = dropWhile (\x. cmp x y) xs" +proof (induct xs) + case (Cons x xs) + have xs: "sorted_wrt cmp xs" and x: "\z\set xs. cmp x z" using Cons.prems by auto + note eq = Cons.hyps[OF xs, symmetric] + show ?case + apply (clarsimp simp: eq filter_id_conv dest!: bspec[OF x]) + by (drule (1) transpD[OF tr], simp) +qed auto + +lemma sorted_insort_filter_eq_insort_partition: + assumes "transp cmp" + assumes "sorted_wrt cmp xs" + shows "insort_filter (\x. cmp x y) x xs = insort_partition (\x. cmp x y) x xs" + by (auto simp: insort_filter_def insort_partition_def + sorted_filter_takeWhile[OF assms] sorted_not_filter_dropWhile[OF assms]) + +lemma total_reflD: + "total {(x,y). cmp x y} \ reflp cmp \ \ cmp a b \ cmp b a" + apply (case_tac "a=b") + apply (fastforce dest: reflpD) + by (fastforce simp: total_on_def) + +(* FIXME: Move *) +lemma dropWhile_dropped_P: + "\x \ set queue; x \ set (dropWhile P queue)\ \ P x" + by (induction queue arbitrary: x; fastforce split: if_split_asm) + +(* FIXME: Move *) +lemma takeWhile_taken_P: + "x \ set (takeWhile P queue) \ P x" + by (induction queue arbitrary: x; fastforce split: if_split_asm) + +lemma sorted_insort_partition: + assumes tot: "total {(x,y). cmp x y}" + assumes tr: "transp cmp" + assumes re: "reflp cmp" + assumes sorted: "sorted_wrt cmp xs" + shows "sorted_wrt cmp (insort_partition (\x. cmp x z) z xs)" + unfolding insort_partition_def + apply (clarsimp simp: sorted_wrt_append, intro conjI) + apply (subst sorted_filter_takeWhile[symmetric, OF tr sorted]) + apply (rule sorted_wrt_filter, rule sorted) + apply (clarsimp simp: sorted_not_filter_dropWhile[symmetric, OF tr sorted]) + apply (fastforce dest: total_reflD[OF tot re]) + apply (subst sorted_not_filter_dropWhile[symmetric, OF tr sorted]) + apply (rule sorted_wrt_filter, rule sorted) + apply (clarsimp, intro conjI) + apply (erule takeWhile_taken_P) + apply (clarsimp simp: sorted_not_filter_dropWhile[symmetric, OF tr sorted]) + apply (drule takeWhile_taken_P) + apply (rule transpD[OF tr], assumption) + apply (fastforce dest: total_reflD[OF tot re]) + done + +lemma sorted_insort_filter: + assumes tot: "total {(x,y). cmp x y}" + assumes tr: "transp cmp" + assumes re: "reflp cmp" + assumes sorted: "sorted_wrt cmp xs" + shows "sorted_wrt cmp (insort_filter (\x. cmp x z) z xs)" + apply (subst sorted_insort_filter_eq_insort_partition[OF tr sorted]) + by (rule sorted_insort_partition[OF tot tr re sorted]) + +fun opt_ord_rel :: "('a \ 'b \ bool) \ 'a option \ 'b option \ bool" where + "opt_ord_rel R (Some x) (Some y) = (R x y)" +| "opt_ord_rel R x y = (y = None \ x = None)" + +abbreviation opt_ord where "opt_ord \ opt_ord_rel (\)" + +lemma gets_the_thread_read': + "thread_get f = gets_the \ (thread_read f)" + by (fastforce simp: gets_the_thread_read) + +lemma tcb_ep_append_insort_filter: + "monadic_rewrite False True (\s. tcb_at t s \ (\ptr \ set q. tcb_at ptr s)) + (tcb_ep_append t q) + (do s \ get; + return $ + insort_filter (\t'. img_ord (\t'. thread_read tcb_priority t' s) (opt_ord_rel (\)) t' t) + t q + od)" + apply (clarsimp simp: tcb_ep_append_def) + apply monadic_rewrite_symb_exec_l+ + apply monadic_rewrite_symb_exec_r+ + apply (rule_tac P="\s'. s' = s + \ obj_at (\ko. \tcb. ko = TCB tcb \ tcb_priority tcb = prio) t s + \ tcb_at t s \ (\t\set q. thread_read tcb_priority t s' \ None) + \ prios = map (\t. the (thread_read tcb_priority t s')) q" + in monadic_rewrite_guard_arg_cong) + apply (clarsimp simp: insort_filter_def) + apply (frule no_ofailD[OF thread_read_no_ofail, where f1=tcb_priority]) + apply (fastforce dest: thread_read_SomeD[where tp=t] + intro: filter_cong append_eq + simp: obj_at_def img_ord_def) + apply (wpsimp wp: mapM_wp_inv no_fail_mapM_wp)+ + apply (wpsimp wp: mapM_gets_the_wp thread_get_wp' simp: gets_the_thread_read')+ + apply (clarsimp simp: obj_at_def) + apply (fastforce split: kernel_object.splits + simp: is_tcb_def thread_read_def oliftM_def obind_def get_tcb_def + map_equality_iff nth_equalityI) + done + +lemma map_fst_filter_zip_map_reduce: + "map fst (filter P (zip xs (map f xs))) = filter (\x. P (x, f x)) xs" + by (induct xs) auto + +lemma distinct_zip_snd_unique: + "\distinct xs; (a, b) \ set (zip xs ys); (a, b') \ set (zip xs ys)\ \ b = b'" + apply (induct xs arbitrary: ys, simp) + apply (clarsimp simp: zip_Cons1) + apply (erule disjE, fastforce dest!: in_set_zipE) + apply (erule disjE, fastforce dest!: in_set_zipE, clarsimp) + done + +lemma set_insort_filter_insert: + "set (insort_filter P x xs) = insert x (set xs)" + by (auto simp: insort_filter_def) + +lemma distinct_filter_iff: + "distinct xs \ distinct (filter P xs) \ distinct (filter (Not \ P) xs)" +proof (induct xs) + case (Cons x xs) show ?case + apply (cases "x \ set xs"; simp) + by (rule Cons[simplified comp_def]) +qed auto + +lemma distinct_insort_filter: + "distinct (insort_filter P x xs) \ x \ set xs \ distinct xs" + by (auto simp: insort_filter_def distinct_filter_iff[where xs=xs and P=P, simplified comp_def] + simp del: distinct_filter) + +lemma insort_filter_cong: + assumes xs: "x = y" "xs = ys" + assumes P: "\x. x \ set ys \ P x \ Q x" + shows "insort_filter P x xs = insort_filter Q y ys" + unfolding insort_filter_def + apply (intro arg_cong2[where f=append] arg_cong2[where f=Cons] filter_cong xs) + by (auto simp: P) + +lemma transp_img_ord: + "transp cmp \ transp (img_ord f cmp)" + unfolding transp_def img_ord_def by blast + +lemma transp_opt_ord: + "transp R \ transp (opt_ord_rel R)" + apply (clarsimp simp: transp_def) + by (case_tac x; case_tac y; case_tac z; clarsimp elim!: order_trans) + +lemma reflp_img_ord: + "reflp cmp \ reflp (img_ord f cmp)" + unfolding reflp_def img_ord_def by blast + +lemma reflp_opt_ord: + "reflp R \ reflp (opt_ord_rel R :: ('a::preorder) option \ 'a option \ bool)" + apply (clarsimp simp: reflp_def) + by (case_tac x; clarsimp) + +lemma total_img_ord: + "\total {(x,y). cmp x y}; reflp cmp\ \ total {(x,y). img_ord f cmp x y}" + apply (clarsimp simp: total_on_def reflp_def img_ord_def) + by (drule_tac x="f x" in spec; drule_tac x="f y" in spec; fastforce) + +lemma total_opt_ord: + "total {(x, y). R x y} + \ total {(x :: ('a::linorder) option, y). opt_ord_rel R x y}" + apply (clarsimp simp: total_on_def) + apply (case_tac x; case_tac y) + by (auto simp: linear) lemma tcb_ep_append_valid_SendEP: - "\valid_ep (SendEP (t#q)) and K (t \ set q)\ tcb_ep_append t q \\q'. valid_ep (SendEP q')\" - apply (simp only: tcb_ep_append_def) - apply (case_tac q; wpsimp wp: tcb_ep_find_index_wp) - apply (fastforce simp: valid_ep_def set_take_disj_set_drop_if_distinct - dest: in_set_takeD in_set_dropD) + "\\s. valid_ep (SendEP (t # q)) s \ t \ set q\ + tcb_ep_append t q + \\q'. valid_ep (SendEP q')\" + apply (wp monadic_rewrite_refine_valid[where P''=\]) + apply (rule monadic_rewrite_sym) + apply (rule tcb_ep_append_insort_filter) + apply wpsimp+ + apply (fastforce simp: valid_ep_def insort_filter_def distinct_insort_filter) done lemma tcb_ep_append_valid_RecvEP: - "\valid_ep (RecvEP (t#q)) and K (t \ set q)\ tcb_ep_append t q \\q'. valid_ep (RecvEP q')\" - apply (simp only: tcb_ep_append_def) - apply (case_tac q; wpsimp wp: tcb_ep_find_index_wp) - apply (fastforce simp: valid_ep_def set_take_disj_set_drop_if_distinct - dest: in_set_takeD in_set_dropD) + "\\s. valid_ep (RecvEP (t # q)) s \ t \ set q\ + tcb_ep_append t q + \\q'. valid_ep (RecvEP q')\" + apply (wp monadic_rewrite_refine_valid[where P''=\]) + apply (rule monadic_rewrite_sym) + apply (rule tcb_ep_append_insort_filter) + apply wpsimp+ + apply (fastforce simp: valid_ep_def insort_filter_def distinct_insort_filter) done lemma tcb_ep_append_valid_ep: @@ -124,10 +370,15 @@ lemma tcb_ep_append_valid_ep: by (cases ep) (wpsimp wp: tcb_ep_append_valid_SendEP tcb_ep_append_valid_RecvEP)+ lemma tcb_ep_append_rv_wf: - "\\\ tcb_ep_append t q \\rv s. set rv = set (t#q)\" - apply (simp only: tcb_ep_append_def) - apply (wp tcb_ep_find_index_wp) - apply (auto simp: set_append[symmetric]) + "\\\ tcb_ep_append t q \\rv s. set rv = set (t # q)\" + apply (simp add: tcb_ep_append_def) + apply (wpsimp wp: mapM_gets_the_wp simp: gets_the_thread_read') + apply (rule arg_cong[where f="\A. insert t A"]) + apply (simp only: set_eq_subset) + apply (intro conjI) + apply (fastforce dest: in_set_zip1) + apply (force dest!: in_set_impl_in_set_zip1 + simp: image_def map_equality_iff simp flip: not_le) done lemma tcb_ep_append_rv_wf'[wp]: @@ -149,25 +400,32 @@ lemma tcb_ep_append_rv_wf''': by (cases ep; wpsimp) lemma tcb_ep_append_distinct[wp]: - "\\s. distinct q \ t \ set q\ tcb_ep_append t q \\q' s. distinct q'\" - apply (simp only: tcb_ep_append_def) - apply (wpsimp wp: tcb_ep_find_index_wp) - apply (auto simp: set_take_disj_set_drop_if_distinct dest: in_set_dropD in_set_takeD) + "\\s. distinct q \ t \ set q \ tcb_at t s \ (\ptr \ set q. tcb_at ptr s)\ + tcb_ep_append t q + \\q' s. distinct q'\" + apply (wp monadic_rewrite_refine_valid[where P''=\]) + apply (rule monadic_rewrite_sym) + apply (rule tcb_ep_append_insort_filter) + apply wpsimp + apply wpsimp + apply (auto simp: insort_filter_def distinct_insort_filter) done lemma tcb_ep_dequeue_valid_SendEP: "\valid_ep (SendEP q) and K (t \ set q)\ tcb_ep_dequeue t q \\q'. valid_ep (SendEP (t#q'))\" + supply if_split[split del] apply (case_tac q; simp) apply (wpsimp simp: tcb_ep_dequeue_def valid_ep_def) - by (fastforce simp: findIndex_def findIndex'_app - dest: in_set_takeD in_set_dropD findIndex_member) + apply (fastforce split: if_splits) + done lemma tcb_ep_dequeue_valid_RecvEP: "\valid_ep (RecvEP q) and K (t \ set q)\ tcb_ep_dequeue t q \\q'. valid_ep (RecvEP (t#q'))\" + supply if_split[split del] apply (case_tac q; simp) apply (wpsimp simp: tcb_ep_dequeue_def valid_ep_def) - by (fastforce simp: findIndex_def findIndex'_app - dest: in_set_takeD in_set_dropD findIndex_member) + apply (fastforce split: if_splits) + done lemma tcb_ep_dequeue_valid_ep: "\valid_ep (update_ep_queue ep q) and K (ep \ IdleEP \ t \ set q)\ @@ -325,7 +583,7 @@ lemma get_notification_default_sp: lemma tcb_ep_append_not_null [wp]: "\\\ tcb_ep_append t q \\rv _. rv \ []\" apply (simp only: tcb_ep_append_def) - apply (wpsimp wp: tcb_ep_find_index_wp) + apply (wpsimp wp: mapM_gets_the_wp) done definition receive_ipc_blocked :: @@ -541,6 +799,10 @@ global_interpretation do_ipc_transfer: non_reply_op "do_ipc_transfer sender ep b global_interpretation get_sched_context: non_sc_op "get_sched_context ptr" by unfold_locales wpsimp +lemma ep_at_pred_obj_at: + "ep_at_pred P p s = obj_at (\ko. \ep. ko = Endpoint ep \ P ep) p s" + by (fastforce simp: ep_at_pred_def obj_at_def) + lemma make_fault_msg_ko_at_Endpoint[wp]: "make_fault_msg f sender \\s. P (ko_at (Endpoint ep) p s)\" by (cases f; @@ -549,6 +811,16 @@ lemma make_fault_msg_ko_at_Endpoint[wp]: split_del: if_split; clarsimp simp: obj_at_def) +lemma make_fault_msg_ep_at_pred[wp]: + "make_fault_msg f sender \\s. Q (ep_at_pred P p s)\" + unfolding ep_at_pred_obj_at + apply (cases f; + wpsimp simp: tcb_agnostic_pred_def sched_context_update_consumed_def update_sched_context_def + wp: as_user.tcb_agnostic_obj_at set_object_wp get_object_wp + split_del: if_split) + apply (fastforce elim: rsubst[where P=Q] simp: obj_at_def) + done + lemma do_fault_transfer_ko_at_Endpoint[wp]: "do_fault_transfer badge sender receiver buf \ \s. P (ko_at (Endpoint ep) p s) \" by (wpsimp simp: do_fault_transfer_def tcb_agnostic_pred_def thread_get_def @@ -556,11 +828,38 @@ lemma do_fault_transfer_ko_at_Endpoint[wp]: set_message_info.tcb_agnostic_obj_at set_mrs.tcb_agnostic_obj_at) +lemma as_user_ep_at_pred[wp]: + "as_user tptr f \ \s. Q (ep_at_pred P p s) \" + unfolding ep_at_pred_obj_at + by (wpsimp simp: tcb_agnostic_pred_def wp: as_user.tcb_agnostic_obj_at) + +lemma set_message_info_ep_at_pred[wp]: + "set_message_info thread info \ \s. Q (ep_at_pred P p s) \" + unfolding ep_at_pred_obj_at + by (wpsimp simp: tcb_agnostic_pred_def wp: set_message_info.tcb_agnostic_obj_at) + +lemma set_mrs_info_ep_at_pred[wp]: + "set_mrs thread buf msgs \ \s. Q (ep_at_pred P p s) \" + unfolding ep_at_pred_obj_at + by (wpsimp simp: tcb_agnostic_pred_def wp: set_mrs.tcb_agnostic_obj_at) + +lemma do_fault_transfer_ep_at_pred[wp]: + "do_fault_transfer badge sender receiver buf \ \s. Q (ep_at_pred P p s) \" + by (wpsimp simp: do_fault_transfer_def thread_get_def) + lemma do_ipc_transfer_ko_at_Endpoint[wp]: "do_ipc_transfer sender ep_ptr badge grant receiver \ \s. P (ko_at (Endpoint ep) p s) \" by (wpsimp simp: do_ipc_transfer_def tcb_cspace_agnostic_pred_def wp: do_normal_transfer.tcb_cspace_agnostic_obj_at) +lemma do_normal_transfer_ep_at_pred[wp]: + "do_normal_transfer sender sbuf endpoint badge grant receiver rbuf \ \s. Q (ep_at_pred P p s) \" + unfolding ep_at_pred_obj_at + by (wpsimp simp: tcb_cspace_agnostic_pred_def wp: do_normal_transfer.tcb_cspace_agnostic_obj_at) + +crunch do_ipc_transfer + for ep_at_pred[wp]: "\s. Q (ep_at_pred P p s)" + lemma do_ipc_transfer_valid_irq_node[wp]: "do_ipc_transfer sender ep_ptr badge grant receiver \ valid_irq_node \" by (wpsimp simp: valid_irq_node_def cap_table_at_typ wp: hoare_vcg_all_lift | wps)+ @@ -1238,8 +1537,9 @@ lemma maybe_return_sc_fault_tcbs_valid_states[wp]: by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' maybe_return_sc_pred_tcb_at) crunch maybe_return_sc - for misc_proj[wp]: "\s. P (cur_thread s) (cur_sc s) (release_queue s) - (cur_domain s) (domain_time s) (idle_thread s)" + for misc_proj[wp]: "\s. P (cur_thread s) (idle_thread s) (domain_time s) (cur_sc s) (release_queue s) + (cur_domain s) (domain_time s) (idle_thread s) (consumed_time s) + (reprogram_timer s) (machine_state s)" (wp: crunch_wps simp: crunch_simps) crunch reschedule_required @@ -2606,6 +2906,7 @@ lemma rai_invs': clarsimp intro!: not_BlockedOnReply_not_in_replies_blocked simp: st_tcb_at_def obj_at_def\) apply (subgoal_tac "ntfn_bound_tcb notification = None") + apply (rule conjI, erule st_tcb_at_tcb_at) apply (rule conjI, fastforce elim: fault_tcbs_valid_states_active) apply (rule conjI, rule delta_sym_refs, assumption) apply (fastforce simp: state_refs_of_def obj_at_def st_tcb_at_def split: if_splits) diff --git a/proof/invariant-abstract/RISCV64/ArchArch_AI.thy b/proof/invariant-abstract/RISCV64/ArchArch_AI.thy index 2ad047b514..007df917ad 100644 --- a/proof/invariant-abstract/RISCV64/ArchArch_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchArch_AI.thy @@ -225,7 +225,7 @@ lemmas perform_asid_pool_invocation_typ_ats [wp] = abs_typ_at_lifts [OF perform_asid_pool_invocation_typ_at] lemma perform_asid_control_invocation_tcb_at: - "\invs and valid_aci aci and st_tcb_at active p and + "\invs and valid_aci aci and tcb_at p and ex_nonz_cap_to p and K (\w a b c. aci = asid_control_invocation.MakePool w a b c \ w \ p)\ perform_asid_control_invocation aci \\rv. tcb_at p\" @@ -237,10 +237,6 @@ lemma perform_asid_control_invocation_tcb_at: apply (intro impI conjI) apply (clarsimp simp: retype_addrs_def obj_bits_api_def default_arch_object_def image_def ptr_add_def) apply (clarsimp simp: st_tcb_at_tcb_at)+ - apply (frule st_tcb_ex_cap) - apply fastforce - apply (clarsimp split: Structures_A.thread_state.splits) - apply auto[1] apply (clarsimp simp: ex_nonz_cap_to_def valid_aci_def) apply (frule invs_untyped_children) apply (clarsimp simp:cte_wp_at_caps_of_state) @@ -280,9 +276,10 @@ lemma invoke_arch_tcb: apply fastforce apply (clarsimp split: Structures_A.thread_state.splits) apply auto[1] - apply (clarsimp simp: ex_nonz_cap_to_def) + apply (frule st_tcb_at_tcb_at) + apply clarsimp apply (frule invs_untyped_children) - apply (clarsimp simp:cte_wp_at_caps_of_state) + apply (clarsimp simp: ex_nonz_cap_to_def cte_wp_at_caps_of_state) apply (erule_tac ptr="(aa,ba)" in untyped_children_in_mdbE[where P="\c. t \ zobj_refs c" for t]) apply (simp add: cte_wp_at_caps_of_state)+ apply fastforce diff --git a/proof/invariant-abstract/RISCV64/ArchDetSchedAux_AI.thy b/proof/invariant-abstract/RISCV64/ArchDetSchedAux_AI.thy index 68bea77d3d..731e7d75d2 100644 --- a/proof/invariant-abstract/RISCV64/ArchDetSchedAux_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchDetSchedAux_AI.thy @@ -16,21 +16,65 @@ lemmas arch_machine_ops_valid_sched_pred[wp] = arch_machine_ops_last_machine_time[THEN dmo_valid_sched_pred] arch_machine_ops_last_machine_time[THEN dmo_valid_sched_pred'] +lemma set_pt_eps_of[wp]: + "set_pt ptr pt \\s. P (eps_of s)\" + by (set_object_easy_cases def: set_pt_def) + +lemma set_pt_ntfns_of[wp]: + "set_pt ptr pt \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: set_pt_def) + +lemma set_pt_tcbs_of[wp]: + "set_pt ptr pt \\s. P (tcbs_of s)\" + by (set_object_easy_cases def: set_pt_def) + lemma set_pt_valid_sched_pred[wp]: "set_pt ptr pt \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ntfns_of, rotated], wpsimp) apply (wpsimp simp: set_pt_def wp: set_object_wp_strong get_object_wp) - by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def fun_upd_def - split: kernel_object.splits if_splits) + apply (fastforce simp: obj_at_kh_kheap_simps vs_all_heap_simps) + done + +lemma set_asid_pool_eps_of[wp]: + "set_asid_pool ptr pool \\s. P (eps_of s)\" + by (set_object_easy_cases def: set_asid_pool_def) + +lemma set_asid_pool_ntfns_of[wp]: + "set_asid_pool ptr pool \\s. P (ntfns_of s)\" + by (set_object_easy_cases def: set_asid_pool_def) + +lemma set_asid_pool_tcbs_of[wp]: + "set_asid_pool ptr pool \\s. P (tcbs_of s)\" + by (set_object_easy_cases def: set_asid_pool_def) lemma set_asid_pool_bound_sc_obj_tcb_at[wp]: "set_asid_pool ptr pool \valid_sched_pred_strong P\" + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=eps_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ntfns_of, rotated], wpsimp) apply (wpsimp simp: set_asid_pool_def wp: set_object_wp_strong get_object_wp) - by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps a_type_def fun_upd_def - split: kernel_object.splits if_splits) + apply (fastforce simp: obj_at_kh_kheap_simps vs_all_heap_simps) + done + +crunch copy_global_mappings + for eps_of[wp]: "\s. P (eps_of s)" + and ntfns_of[wp]: "\s. P (ntfns_of s)" + and prios_of[wp]: "\s. P (prios_of s)" + (wp: dxo_wp_weak crunch_wps) lemma copy_global_mappings_valid_sched_pred[wp]: "copy_global_mappings pd \valid_sched_pred_strong P\" - by (wpsimp simp: copy_global_mappings_def store_pte_def wp: mapM_x_wp_inv) + apply (rule hoare_lift_Pf[where f=ntfn_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=ep_queues_of, rotated], wpsimp) + apply (rule hoare_lift_Pf[where f=prios_of, rotated], wpsimp) + apply (wpsimp simp: copy_global_mappings_def store_pte_def wp: mapM_x_wp_inv) + done lemma init_arch_objects_valid_sched_pred[wp, DetSchedAux_AI_assms]: "init_arch_objects new_type dev ptr num_objects obj_sz refs \valid_sched_pred_strong P\" @@ -251,6 +295,32 @@ lemma perform_asid_control_invocation_sc_at_pred_n_live: unfolding sc_at_pred_n_def using live by (auto intro!: perform_asid_control_invocation_obj_at_live simp: cspace_agnostic_pred_def live_def) +lemma perform_asid_control_invocation_ep_at_pred_live: + assumes live: "\ep. P ep \ ep \ IdleEP" + shows + "\\s. Q (ep_at_pred P p s) + \ invs s + \ ct_active s + \ valid_aci aci s + \ scheduler_action s = resume_cur_thread\ + perform_asid_control_invocation aci + \\rv s. Q (ep_at_pred P p s)\" + unfolding ep_at_pred_def2 using live + by (auto intro!: perform_asid_control_invocation_obj_at_live simp: cspace_agnostic_pred_def live_def) + +lemma perform_asid_control_invocation_ntfn_at_pred_live: + assumes live: "\ntfn. P ntfn \ live_ntfn ntfn" + shows + "\\s. Q (ntfn_at_pred P p s) + \ invs s + \ ct_active s + \ valid_aci aci s + \ scheduler_action s = resume_cur_thread\ + perform_asid_control_invocation aci + \\rv s. Q (ntfn_at_pred P p s)\" + unfolding ntfn_at_pred_def2 using live + by (auto intro!: perform_asid_control_invocation_obj_at_live simp: cspace_agnostic_pred_def live_def) + lemma perform_asid_control_invocation_valid_idle: "\invs and ct_active and valid_aci aci @@ -302,18 +372,22 @@ lemma perform_asid_control_invocation_valid_sched: apply (rule_tac I="invs and ct_active and (\s. scheduler_action s = resume_cur_thread) and valid_aci aci" in valid_sched_tcb_state_preservation_gen) - apply simp - apply (wpsimp wp: perform_asid_control_invocation_st_tcb_at - perform_asid_control_invocation_pred_tcb_at_live - perform_asid_control_invocation_sc_at_pred_n_live[where Q="Not"] - perform_asid_control_etcb_at - perform_asid_control_invocation_sc_at_pred_n - perform_asid_control_invocation_valid_idle - perform_asid_control_invocation_pred_map_sc_refill_cfgs_of - perform_asid_control_invocation_implies_zero_budget - perform_asid_control_invocation_sporadic_implies - hoare_vcg_all_lift - simp: ipc_queued_thread_state_live live_sc_def)+ + apply simp + apply (wpsimp wp: perform_asid_control_invocation_st_tcb_at + perform_asid_control_invocation_pred_tcb_at_live + perform_asid_control_invocation_sc_at_pred_n_live[where Q="Not"] + perform_asid_control_etcb_at + perform_asid_control_invocation_sc_at_pred_n + perform_asid_control_invocation_valid_idle + perform_asid_control_invocation_pred_map_sc_refill_cfgs_of + perform_asid_control_invocation_implies_zero_budget + perform_asid_control_invocation_sporadic_implies + perform_asid_control_invocation_ep_at_pred_live + perform_asid_control_invocation_ntfn_at_pred_live + hoare_vcg_all_lift + simp: ipc_queued_thread_state_live live_sc_def + ntfn_queue_nonempty_live + tcb_at_st_tcb_at)+ done lemma perform_asid_control_invocation_cur_sc_active: diff --git a/proof/invariant-abstract/RISCV64/ArchDetSchedSchedule_AI.thy b/proof/invariant-abstract/RISCV64/ArchDetSchedSchedule_AI.thy index 0a24a54c15..668d5c7765 100644 --- a/proof/invariant-abstract/RISCV64/ArchDetSchedSchedule_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchDetSchedSchedule_AI.thy @@ -40,21 +40,22 @@ lemma misc_dmo_valid_sched_pred_strong[wp]: "\a b. do_machine_op (storeWord a b) \valid_sched_pred_strong Q\" by (wpsimp wp: dmo_valid_sched_pred )+ -crunch arch_switch_to_thread, - arch_switch_to_idle_thread, - arch_finalise_cap, - arch_invoke_irq_control, - handle_vm_fault +crunch arch_switch_to_thread, arch_switch_to_idle_thread, arch_finalise_cap, + arch_invoke_irq_control for valid_sched_pred_strong[wp, DetSchedSchedule_AI_assms]: "valid_sched_pred_strong P" (wp: dmo_valid_sched_pred crunch_wps simp: crunch_simps) +lemma handle_vm_fault_valid_sched_pred_strong[wp, DetSchedSchedule_AI_assms]: + "handle_vm_fault thread fault_type \valid_sched_pred_strong P\" + unfolding handle_vm_fault_def + by (wp dmo_valid_sched_pred | simp add: Let_def | cases fault_type)+ + crunch perform_page_table_invocation, perform_page_invocation, perform_asid_pool_invocation for valid_sched_misc[wp]: "valid_sched_pred_strong P" (wp: dmo_valid_sched_pred crunch_wps simp: crunch_simps detype_def ignore: do_machine_op) - crunch arch_perform_invocation for valid_sched_misc[wp, DetSchedSchedule_AI_assms]: "\s. P (consumed_time s) (cur_time s) (cur_domain s) (cur_thread s) diff --git a/proof/invariant-abstract/RISCV64/ArchSyscall_AI.thy b/proof/invariant-abstract/RISCV64/ArchSyscall_AI.thy index 5a1f239a62..b9df46e89a 100644 --- a/proof/invariant-abstract/RISCV64/ArchSyscall_AI.thy +++ b/proof/invariant-abstract/RISCV64/ArchSyscall_AI.thy @@ -32,6 +32,8 @@ crunch handle_arch_fault_reply, make_fault_msg, arch_get_sanitise_register_info for cur_thread[wp,Syscall_AI_assms]: "\s. P (cur_thread s)" crunch handle_arch_fault_reply, arch_get_sanitise_register_info for valid_objs[wp,Syscall_AI_assms]: "valid_objs" +crunch handle_arch_fault_reply, arch_get_sanitise_register_info + for valid_mdb[wp,Syscall_AI_assms]: valid_mdb crunch handle_arch_fault_reply, arch_get_sanitise_register_info for cte_wp_at[wp,Syscall_AI_assms]: "\s. P (cte_wp_at P' p s)" diff --git a/proof/invariant-abstract/SchedContextInv_AI.thy b/proof/invariant-abstract/SchedContextInv_AI.thy index 07c26fc18f..993465bf3c 100644 --- a/proof/invariant-abstract/SchedContextInv_AI.thy +++ b/proof/invariant-abstract/SchedContextInv_AI.thy @@ -1598,7 +1598,7 @@ crunch refill_new (simp: crunch_simps wp: crunch_wps) lemma invoke_sched_control_configure_flags_invs[wp]: - "\\s. invs s \ valid_sched_control_inv i s \ bound_sc_tcb_at bound (cur_thread s) s\ + "\\s. invs s \ valid_sched_control_inv i s\ invoke_sched_control_configure_flags i \\rv. invs\" supply if_split[split del] diff --git a/proof/invariant-abstract/Syscall_AI.thy b/proof/invariant-abstract/Syscall_AI.thy index 6ea3854dcb..a867d4819d 100644 --- a/proof/invariant-abstract/Syscall_AI.thy +++ b/proof/invariant-abstract/Syscall_AI.thy @@ -319,6 +319,11 @@ locale Systemcall_AI_Pre = \ valid_objs :: 'state_ext state \ _\ handle_arch_fault_reply x4 t d dl \\_ .valid_objs\" + assumes handle_arch_fault_valid_mdb[wp]: + "\ x4 t d dl. + \ valid_mdb :: 'state_ext state \ _\ + handle_arch_fault_reply x4 t d dl + \\_ .valid_mdb\" assumes arch_get_sanitise_register_info_pred_tcb_at[wp]: "\ P t g. \ pred_tcb_at proj P t :: 'state_ext state \ _\ @@ -501,16 +506,15 @@ lemma do_reply_invs[wp]: done lemma pinv_invs[wp]: - "\\s. invs s \ ct_active s \ valid_invocation i s \ - scheduler_action s = resume_cur_thread\ - perform_invocation blocking call can_donate i - \\rv. invs :: 'state_ext state \ _\" - apply (cases i - ; wpsimp wp: tcbinv_invs send_signal_interrupt_states invoke_domain_invs - simp: ct_in_state_def) - apply (auto simp: invs_def valid_state_def valid_pspace_def cur_sc_tcb_def pred_tcb_at_def - obj_at_def sym_refs_bound_sc_tcb_iff_sc_tcb_sc_at[symmetric] - if_live_then_nonz_capD2 live_def) + "\\s. invs s \ ct_active s \ valid_invocation i s \ scheduler_action s = resume_cur_thread\ + perform_invocation blocking call can_donate i + \\_. invs :: 'state_ext state \ _\" + apply (cases i; + wpsimp wp: tcbinv_invs send_signal_interrupt_states invoke_domain_invs + simp: ct_in_state_def) + apply (auto simp: invs_def valid_state_def valid_pspace_def cur_sc_tcb_def pred_tcb_at_def + obj_at_def sym_refs_bound_sc_tcb_iff_sc_tcb_sc_at[symmetric] + if_live_then_nonz_capD2 live_def) done end @@ -571,7 +575,8 @@ lemma pinv_tcb[wp]: perform_invocation blocking call can_donate i \\rv. tcb_at tptr :: 'state_ext state \ bool\" apply (case_tac i, simp_all split:option.splits) - apply (wpsimp simp: st_tcb_at_tcb_at)+ + apply (wpsimp simp: st_tcb_at_tcb_at) + apply (fastforce intro!: runnable_nonz_cap_to simp: runnable_eq_active) apply ((wpsimp wp: tcb_at_typ_at simp: st_tcb_at_tcb_at)+)[3] apply ((wpsimp simp: st_tcb_at_tcb_at)+)[5] apply ((simp add: tcb_at_typ, wpsimp simp: st_tcb_at_tcb_at tcb_at_typ[symmetric])+)[2] diff --git a/proof/invariant-abstract/Tcb_AI.thy b/proof/invariant-abstract/Tcb_AI.thy index a542654cb2..274ab0b192 100644 --- a/proof/invariant-abstract/Tcb_AI.thy +++ b/proof/invariant-abstract/Tcb_AI.thy @@ -1743,25 +1743,18 @@ lemma tcb_ep_dequeue_append_valid_ntfn_rv: tcb_ep_append t qs' od \\rv s. valid_ntfn (ntfn_set_obj ntfn (WaitingNtfn rv)) s\" - apply (simp only: tcb_ep_append_def tcb_ep_dequeue_def) - apply (wp tcb_ep_find_index_wp) - apply (rule conjI) - apply (clarsimp simp: valid_ntfn_def split: option.split) - apply (clarsimp simp: valid_ntfn_def simp del: imp_disjL dest!: findIndex_member) - apply (intro conjI; clarsimp?) - apply (fastforce dest: in_set_takeD in_set_dropD) - apply (fastforce dest: in_set_dropD) - apply (fastforce dest: in_set_dropD) - apply (fastforce dest: in_set_dropD) - apply (fastforce dest: in_set_takeD) - apply (clarsimp simp: Int_Un_distrib set_take_disj_set_drop_if_distinct) - apply (rule disjoint_subset_both[OF set_take_subset set_drop_subset]) - apply (simp add: Int_commute) - apply (fastforce dest: in_set_takeD) - apply (clarsimp simp: Int_Un_distrib set_take_disj_set_drop_if_distinct) - apply (fastforce dest: in_set_takeD in_set_dropD) - apply (clarsimp split: option.split) - apply (case_tac ys; clarsimp) + apply (rule hoare_weaken_pre) + apply (rule monadic_rewrite_refine_valid) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_sym) + apply (rule tcb_ep_append_insort_filter) + apply (wpsimp simp: tcb_ep_append_def tcb_ep_dequeue_def) + apply (clarsimp simp: valid_ntfn_def split: option.split) + apply (simp add: tcb_ep_append_def tcb_ep_dequeue_def) + apply wpsimp + apply fastforce + apply (fastforce simp: valid_ntfn_def insort_filter_def distinct_insort_filter + split: option.splits) done lemma reorder_ntfn_invs[wp]: diff --git a/proof/invariant-abstract/Untyped_AI.thy b/proof/invariant-abstract/Untyped_AI.thy index 8dbb199051..ebecc34ebf 100644 --- a/proof/invariant-abstract/Untyped_AI.thy +++ b/proof/invariant-abstract/Untyped_AI.thy @@ -1368,12 +1368,6 @@ lemma retype_ret_valid_caps: done end -(* FIXME: move to Lib *) -lemma set_zip_helper: - "t \ set (zip xs ys) \ fst t \ set xs \ snd t \ set ys" - by (clarsimp simp add: set_zip) - - lemma ex_cte_cap_protects: "\ ex_cte_cap_wp_to P p s; cte_wp_at ((=) (UntypedCap dev ptr bits idx)) p' s; descendants_range_in S p' s; untyped_children_in_mdb s; S\ untyped_range (UntypedCap dev ptr bits idx); @@ -3217,7 +3211,7 @@ lemma (in Untyped_AI_nonempty_table) create_caps_invs: apply (rule hoare_gen_asm) apply (subgoal_tac "set (zip crefs orefs) \ set crefs \ set (retype_addrs ptr tp (length slots) us)") prefer 2 - apply (auto dest!: set_zip_helper)[1] + apply (auto dest!: in_set_zipD)[1] apply (induct ("zip crefs orefs")) apply (simp add: mapM_x_def sequence_x_def) apply wpsimp @@ -3509,7 +3503,7 @@ lemma retype_region_post_retype_invs_folded: lemma tup_in_fst_image_set_zipD: "x \ fst ` set (zip xs ys) \ x \ set xs" - by (auto dest!: set_zip_helper) + by (auto dest!: in_set_zipD) lemma distinct_map_fst_zip: "distinct xs \ distinct (map fst (zip xs ys))" @@ -3817,12 +3811,14 @@ lemma invoke_untyped_pred_tcb_at[wp]: done lemma invoked_untyp_tcb[wp]: - "\invs and st_tcb_at active tptr - and valid_untyped_inv ui and ct_active and (\s. scheduler_action s = resume_cur_thread)\ - invoke_untyped ui \\rv. \s :: 'state_ext state. tcb_at tptr s\" + "\invs and ex_nonz_cap_to tptr and tcb_at tptr + and valid_untyped_inv ui and ct_active and (\s. scheduler_action s = resume_cur_thread)\ + invoke_untyped ui + \\_ s :: 'state_ext state. tcb_at tptr s\" apply (simp add: tcb_at_st_tcb_at) apply (rule hoare_pre, wp invoke_untyped_pred_tcb_at) - by (fastforce simp: pred_tcb_weakenE elim: runnable_nonz_cap_to[unfolded runnable_eq]) + apply (clarsimp simp: pred_tcb_at_def) + done end diff --git a/proof/refine/RISCV64/CSpace_R.thy b/proof/refine/RISCV64/CSpace_R.thy index 2cf4115e5d..3c6c306277 100644 --- a/proof/refine/RISCV64/CSpace_R.thy +++ b/proof/refine/RISCV64/CSpace_R.thy @@ -3297,7 +3297,6 @@ lemma cteInsert_invs: apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) apply (wpsimp wp: valid_bitmaps_lift valid_irq_node_lift irqs_masked_lift cteInsert_norq sym_heap_sched_pointers_lift) - apply (subst fold_list_refs_of_replies') by (auto simp: invs'_def valid_pspace'_def elim: valid_capAligned) lemma deriveCap_corres: @@ -4109,7 +4108,6 @@ lemma arch_update_setCTE_invs: setCTE_norq hoare_vcg_disj_lift untyped_ranges_zero_lift valid_replies'_lift sym_heap_sched_pointers_lift | simp add: pred_tcb_at'_def)+ - apply (subst fold_list_refs_of_replies') apply (clarsimp simp: valid_global_refs'_def is_arch_update'_def fun_upd_def[symmetric] cte_wp_at_ctes_of isCap_simps untyped_ranges_zero_fun_upd) apply (frule capMaster_eq_capBits_eq) @@ -5937,7 +5935,6 @@ lemma updateFreeIndex_forward_invs': apply (clarsimp simp: cte_wp_at_ctes_of fun_upd_def[symmetric]) apply (clarsimp simp: isCap_simps valid_pspace'_def) apply (frule(1) valid_global_refsD_with_objSize) - apply (subst fold_list_refs_of_replies') apply clarsimp apply (intro conjI allI impI) apply (clarsimp simp: modify_map_def cteCaps_of_def ifunsafe'_def3 split:if_splits) diff --git a/proof/refine/RISCV64/EmptyFail_H.thy b/proof/refine/RISCV64/EmptyFail_H.thy index 1189568113..8082b8ae5b 100644 --- a/proof/refine/RISCV64/EmptyFail_H.thy +++ b/proof/refine/RISCV64/EmptyFail_H.thy @@ -305,10 +305,6 @@ crunch setMRs, setMessageInfo for (empty_fail) empty_fail[wp, simp] (wp: empty_fail_catch simp: const_def Let_def) -lemma tcbEPFindIndex_empty_fail[intro!, wp, simp]: - "empty_fail (tcbEPFindIndex t qs ci)" - by (induct ci; subst tcbEPFindIndex.simps; wpsimp) - crunch callKernel for (empty_fail) empty_fail (wp: empty_fail_catch) diff --git a/proof/refine/RISCV64/Finalise_R.thy b/proof/refine/RISCV64/Finalise_R.thy index a5756daa59..9c9dd67b70 100644 --- a/proof/refine/RISCV64/Finalise_R.thy +++ b/proof/refine/RISCV64/Finalise_R.thy @@ -4216,7 +4216,7 @@ lemma replyClear_corres: apply (rule corres_False'[where P'=\]) apply (wpsimp wp: gts_wp gts_wp')+ apply (clarsimp simp: pred_tcb_at_def obj_at_def is_obj_defs invs_def valid_pspace_def valid_state_def) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def invs'_def valid_pspace'_def opt_map_Some_eta_fold) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def invs'_def valid_pspace'_def) done lemma fast_finaliseCap_corres: diff --git a/proof/refine/RISCV64/Invariants_H.thy b/proof/refine/RISCV64/Invariants_H.thy index a8798c69aa..9c26f10f5b 100644 --- a/proof/refine/RISCV64/Invariants_H.thy +++ b/proof/refine/RISCV64/Invariants_H.thy @@ -281,6 +281,27 @@ abbreviation tcbSchedNexts_of :: "kernel_state \ obj_ref \ bool" where "sym_heap_sched_pointers s \ sym_heap (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" +abbreviation prios_of' :: "kernel_state \ obj_ref \ priority" where + "prios_of' s \ tcbs_of' s ||> tcbPriority" + +abbreviation ep_of' :: "kernel_object \ endpoint option" where + "ep_of' \ projectKO_opt" + +abbreviation eps_of' :: "kernel_state \ obj_ref \ endpoint" where + "eps_of' s \ ksPSpace s |> ep_of'" + +abbreviation ep_queues_of' :: "kernel_state \ obj_ref \ obj_ref list" where + "ep_queues_of' s \ eps_of' s ||> epQueue" + +abbreviation ntfn_of' :: "kernel_object \ notification option" where + "ntfn_of' \ projectKO_opt" + +abbreviation ntfns_of' :: "kernel_state \ obj_ref \ notification" where + "ntfns_of' s \ ksPSpace s |> ntfn_of'" + +abbreviation ntfn_queues_of' :: "kernel_state \ obj_ref \ obj_ref list" where + "ntfn_queues_of' s \ ntfns_of' s ||> ntfnObj ||> ntfnQueue" + definition tcb_cte_cases :: "machine_word \ ((tcb \ cte) \ ((cte \ cte) \ tcb \ tcb))" where "tcb_cte_cases \ [ 0 << cteSizeBits \ (tcbCTable, tcbCTable_update), 1 << cteSizeBits \ (tcbVTable, tcbVTable_update), @@ -639,15 +660,13 @@ definition valid_tcb' :: "tcb \ kernel_state \ bool" whe definition valid_ep' :: "Structures_H.endpoint \ kernel_state \ bool" where "valid_ep' ep s \ case ep of IdleEP \ True - | SendEP ts \ (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts) - | RecvEP ts \ (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts)" + | SendEP ts \ (ts \ [] \ (\t \ set ts. tcb_at' t s)) + | RecvEP ts \ (ts \ [] \ (\t \ set ts. tcb_at' t s))" definition valid_ntfn' :: "notification \ kernel_state \ bool" where "valid_ntfn' ntfn s \ (case ntfnObj ntfn of IdleNtfn \ True - | WaitingNtfn ts \ - ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts - \ (case ntfnBoundTCB ntfn of Some tcb \ ts = [tcb] | _ \ True) + | WaitingNtfn ts \ ts \ [] \ (\t \ set ts. tcb_at' t s) | ActiveNtfn b \ True) \ valid_bound_tcb' (ntfnBoundTCB ntfn) s \ valid_bound_sc' (ntfnSc ntfn) s" diff --git a/proof/refine/RISCV64/IpcCancel_R.thy b/proof/refine/RISCV64/IpcCancel_R.thy index bad293b5d7..3d679ec8b7 100644 --- a/proof/refine/RISCV64/IpcCancel_R.thy +++ b/proof/refine/RISCV64/IpcCancel_R.thy @@ -269,6 +269,11 @@ lemma blocked_cancelIPC_corres: apply (erule disjE; clarsimp simp: ep_relation_def get_ep_queue_def split del: if_split) \\BlockedOnReceive\ apply (rename_tac list) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp, rotated]) + apply wpsimp + apply wpsimp + apply (clarsimp dest: invs_valid_objs valid_objs_ko_at + simp: ex_abs_def valid_obj_def valid_ep_def) apply (cases reply_opt; simp split del: if_split add: bind_assoc cong: if_cong) \\reply_opt = None\ @@ -283,9 +288,6 @@ lemma blocked_cancelIPC_corres: clarsimp simp: st_tcb_at_def obj_at_def is_ep is_tcb intro!: valid_ep_remove1_RecvEP) apply clarsimp - apply (frule Receive_or_Send_ep_at'[rotated], simp) - apply (simp add: thread_state_relation_def) - apply (fastforce simp: valid_ep'_def) \\reply_opt bound\ apply (rule corres_guard_imp) apply (rule_tac R="\_. ep_at epPtr and reply_tcb_reply_at ((=) (Some t)) a and ?abs_guard" @@ -326,6 +328,11 @@ lemma blocked_cancelIPC_corres: set_remove1) \\BlockedOnSend\ apply (rename_tac list) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp, rotated]) + apply wpsimp + apply wpsimp + apply (clarsimp dest: invs_valid_objs valid_objs_ko_at + simp: ex_abs_def valid_obj_def valid_ep_def) apply (rule corres_guard_imp) apply (rule corres_split[OF setEndpoint_corres]) apply (simp add: ep_relation_def split: list.split) @@ -338,8 +345,6 @@ lemma blocked_cancelIPC_corres: clarsimp simp: st_tcb_at_def obj_at_def is_ep is_tcb intro!: valid_ep_remove1_SendEP) apply (clarsimp split del: if_split) - apply (frule (1) Receive_or_Send_ep_at'[rotated], blast) - apply (fastforce simp: valid_ep'_def) apply (wpsimp wp: getEndpoint_wp hoare_vcg_conj_lift get_simple_ko_wp)+ apply (frule (2) Receive_or_Send_ep_at, clarsimp) apply (rule conjI, clarsimp) @@ -364,47 +369,63 @@ lemma blocked_cancelIPC_corres: apply (fastforce dest!: sym_ref_BlockedOnSend_SendEP' simp: ko_wp_at'_def) done +lemma pspace_relation_ntfn_relation: + "\pspace_relation (kheap s) (ksPSpace s'); kheap s ptr = Some (Notification ntfn); + ksPSpace s' ptr = Some (KONotification ntfn')\ + \ ntfn_relation ntfn ntfn'" + apply (clarsimp simp: pspace_relation_def) + apply (drule_tac x=ptr in bspec) + apply (fastforce simp: obj_at_def) + apply (clarsimp simp: other_obj_relation_def obj_at_def obj_at'_def) + done + lemma cancelSignal_corres: "corres dc - (invs and valid_ready_qs and st_tcb_at ((=) (Structures_A.BlockedOnNotification ntfn)) t) - (invs' and st_tcb_at' ((=) (BlockedOnNotification ntfn)) t) - (cancel_signal t ntfn) (cancelSignal t ntfn)" + (invs and valid_ready_qs and st_tcb_at ((=) (Structures_A.BlockedOnNotification ntfnPtr)) t) + (invs' and st_tcb_at' ((=) (BlockedOnNotification ntfnPtr)) t) + (cancel_signal t ntfnPtr) (cancelSignal t ntfnPtr)" apply add_sym_refs apply add_ready_qs_runnable + apply (rule_tac Q="ntfn_at ntfnPtr" in corres_cross_add_abs_guard) + apply (fastforce dest: st_tcb_at_valid_st2 + simp: valid_tcb_state_def obj_at_def is_ntfn_def) + apply (rule_tac Q'="ntfn_at' ntfnPtr" in corres_cross_add_guard) + apply (fastforce dest!: state_relationD elim!: ntfn_at_cross) apply (simp add: cancel_signal_def cancelSignal_def Let_def) apply (rule corres_stateAssert_add_assertion[rotated]) apply (clarsimp simp: sym_refs_asrt_def) apply (rule corres_stateAssert_add_assertion[rotated]) apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF getNotification_corres]) - apply (rule_tac F="isWaitingNtfn (ntfnObj ntfnaa)" in corres_gen_asm2) - apply (case_tac "ntfn_obj ntfna"; simp add: ntfn_relation_def isWaitingNtfn_def) - apply (case_tac "ntfna", case_tac "ntfnaa") - apply clarsimp - apply wpfix - apply (rename_tac list bound_tcb sc) - apply (rule_tac R="remove1 t list = []" in corres_cases') - apply (simp del: dc_simp) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def) - apply (rule setThreadState_corres) - apply simp - apply (wp abs_typ_at_lifts)+ - apply (simp add: list_case_If del: dc_simp) - apply (rule corres_split[OF setNotification_corres]) - apply (clarsimp simp add: ntfn_relation_def neq_Nil_conv) - apply (rule setThreadState_corres) - apply simp - apply (wp abs_typ_at_lifts)+ - apply (wp get_simple_ko_wp getNotification_wp)+ + apply (rule corres_underlying_split [OF _ _ get_simple_ko_sp get_ntfn_sp']) + apply (rule corres_guard_imp [OF getNotification_corres]) + apply clarsimp+ + apply (rename_tac ntfn ntfn') + apply (rule stronger_corres_guard_imp) + apply (rule_tac F="isWaitingNtfn (ntfnObj ntfn')" in corres_gen_asm2) + apply (case_tac "ntfn_obj ntfn"; simp add: ntfn_relation_def isWaitingNtfn_def) + apply (case_tac "ntfn", case_tac "ntfn'") + apply clarsimp + apply wpfix + apply (rule corres_assert_assume_r) + apply (rename_tac list bound_tcb sc) + apply (rule_tac R="remove1 t list = []" in corres_cases') + apply (simp del: dc_simp) + apply (rule corres_split[OF setNotification_corres]) + apply (simp add: ntfn_relation_def) + apply (rule setThreadState_corres) + apply simp + apply (wp abs_typ_at_lifts)+ + apply (simp add: list_case_If del: dc_simp) + apply (rule corres_split[OF setNotification_corres]) + apply (clarsimp simp add: ntfn_relation_def neq_Nil_conv) + apply (rule setThreadState_corres) + apply simp + apply (wp abs_typ_at_lifts)+ apply (clarsimp simp: conj_comms st_tcb_at_tcb_at) apply (clarsimp simp: st_tcb_at_def obj_at_def) apply (erule pspace_valid_objsE, fastforce) apply (clarsimp simp: valid_obj_def valid_tcb_def valid_tcb_state_def) - apply (drule sym, simp add: obj_at_def) - apply clarsimp - apply (erule pspace_valid_objsE[where p=ntfn], fastforce) + apply (erule pspace_valid_objsE[where p=ntfnPtr], fastforce) apply (fastforce simp: valid_obj_def valid_ntfn_def split: option.splits Structures_A.ntfn.splits) apply (clarsimp simp: conj_comms pred_tcb_at' cong: conj_cong) @@ -412,16 +433,20 @@ lemma cancelSignal_corres: apply (simp add: pred_tcb_at'_def) apply (drule obj_at_ko_at') apply clarsimp - apply (frule ko_at_valid_objs') - apply fastforce - apply simp - apply (clarsimp simp: valid_obj'_def valid_tcb'_def valid_tcb_state'_def) - apply (drule sym, simp) + apply (frule ko_at_valid_objs') + apply fastforce + apply simp + apply (clarsimp simp: valid_obj'_def valid_tcb'_def valid_tcb_state'_def) apply (intro conjI impI allI; fastforce?) - apply (drule sym_refs_st_tcb_atD', fastforce) - apply (fastforce simp: isWaitingNtfn_def ko_wp_at'_def obj_at'_def - ntfn_bound_refs'_def get_refs_def - split: Structures_H.notification.splits ntfn.splits option.splits) + apply (drule sym_refs_st_tcb_atD', fastforce) + apply (fastforce simp: isWaitingNtfn_def ko_wp_at'_def obj_at'_def + ntfn_bound_refs'_def get_refs_def + split: Structures_H.notification.splits ntfn.splits option.splits) + apply (frule invs_valid_objs) + apply (frule valid_objs_valid_ntfn) + apply (fastforce simp: obj_at_def) + apply (clarsimp simp: valid_ntfn_def ntfn_relation_def) + apply (case_tac "ntfn_obj ntfn"; clarsimp) done lemma cte_map_tcb_2: @@ -1040,7 +1065,7 @@ crunch updateReply, setSchedContext, updateSchedContext and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers and valid_sched_pointers[wp]: valid_sched_pointers - (simp: crunch_simps opt_map_Some_eta_fold wp: crunch_wps) + (simp: crunch_simps wp: crunch_wps) lemma scReplies_of_scTCB_update[simp]: "\ ko_at' sc scp s\ @@ -1319,7 +1344,7 @@ lemma replyPop_corres: and (\s. tcbSCs_of s t = tcbsc) and pspace_aligned' and pspace_distinct' and pspace_bounded'" in hoare_strengthen_post[rotated]) - apply (clarsimp split: if_split simp: valid_reply'_def opt_map_Some_eta_fold obj_at'_def) + apply (clarsimp split: if_split simp: valid_reply'_def obj_at'_def) apply (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imp simp: valid_reply'_def) apply (rule hoare_vcg_conj_lift) apply (wpsimp wp: updateSchedContext_wp) @@ -1335,7 +1360,7 @@ lemma replyPop_corres: apply (clarsimp simp: valid_obj_def valid_sched_context_def obj_at_def) apply (case_tac "sc_replies sc0"; simp) apply (intro conjI impI allI; rename_tac ls; case_tac ls; clarsimp) - apply (clarsimp simp: valid_obj'_def opt_map_red opt_map_Some_eta_fold) + apply (clarsimp simp: valid_obj'_def opt_map_red) apply (intro conjI impI) apply (fastforce simp: obj_at'_def opt_map_red opt_pred_def valid_sched_context'_def valid_obj'_def valid_reply'_def @@ -1772,59 +1797,37 @@ lemma cancelSignal_invs': "\invs' and st_tcb_at' (\st. st = BlockedOnNotification ntfn) t\ cancelSignal t ntfn \\_. invs'\" - proof - - have NTFNSN: "\ntfn ntfn'. - \\s. sch_act_not (ksCurThread s) s \ setNotification ntfn ntfn' - \\_ s. sch_act_not (ksCurThread s) s\" - apply (rule hoare_weaken_pre) - apply wps - apply (wp, simp) - done - show ?thesis - apply (simp add: cancelSignal_def invs'_def Let_def valid_dom_schedule'_def) - apply (intro bind_wp[OF _ stateAssert_sp]) - apply (wp valid_irq_node_lift sts_sch_act' irqs_masked_lift - hoare_vcg_all_lift [OF set_ntfn'.ksReadyQueues] - setThreadState_ct_not_inQ NTFNSN set_ntfn'.get_wp - hoare_vcg_all_lift set_ntfn'.ksReadyQueues hoare_vcg_imp_lift' - | simp add: valid_tcb_state'_def list_case_If split del: if_split)+ - apply (clarsimp simp: pred_tcb_at' ready_qs_runnable_def) - apply (case_tac "ntfnObj ko", simp_all add: isWaitingNtfn_def) - apply (rule conjI) - apply (clarsimp simp: valid_ntfn'_def) - apply normalise_obj_at' - apply (frule ko_at_valid_objs') - apply (simp add: valid_pspace_valid_objs') - apply (clarsimp simp: projectKO_opt_ntfn split: kernel_object.splits) - apply (simp add: valid_obj'_def valid_ntfn'_def) - apply (rule conjI, clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (rule conjI, erule_tac rfs'="list_refs_of_replies' s" in delta_sym_refs) - subgoal - by (auto simp: symreftype_inverse' list_refs_of_replies'_def - get_refs_def2 opt_map_def - split: option.splits) - subgoal - by (auto simp: symreftype_inverse' list_refs_of_replies'_def - get_refs_def2 opt_map_def - split: option.splits) - apply (frule obj_at_valid_objs', clarsimp) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) - apply (frule st_tcb_at_state_refs_ofD') - apply (frule ko_at_state_refs_ofD') - apply (fastforce simp: get_refs_def elim!: if_live_state_refsE split: option.splits) - apply (frule obj_at_valid_objs', clarsimp) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) - apply (rule conjI, clarsimp split: option.splits) - apply (frule st_tcb_at_state_refs_ofD') - apply (frule ko_at_state_refs_ofD') - apply (rule conjI) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (clarsimp simp: valid_pspace'_def) - apply (rule conjI) - apply (fastforce simp: list_refs_of_replies'_def opt_map_def o_def) - apply (fastforce simp: get_refs_def elim!: if_live_state_refsE split: option.splits) - done - qed + apply (simp add: cancelSignal_def invs'_def Let_def valid_dom_schedule'_def) + apply (intro bind_wp[OF _ stateAssert_sp]) + apply (wp valid_irq_node_lift sts_sch_act' irqs_masked_lift + hoare_vcg_all_lift [OF set_ntfn'.ksReadyQueues] + setThreadState_ct_not_inQ set_ntfn'.get_wp + hoare_vcg_all_lift set_ntfn'.ksReadyQueues hoare_vcg_imp_lift' + | simp add: valid_tcb_state'_def list_case_If split del: if_split)+ + apply (clarsimp simp: pred_tcb_at' ready_qs_runnable_def) + apply (case_tac "ntfnObj ko", simp_all add: isWaitingNtfn_def) + apply (rule conjI) + apply (clarsimp simp: valid_ntfn'_def) + apply normalise_obj_at' + apply (frule ko_at_valid_objs') + apply (simp add: valid_pspace_valid_objs') + apply (clarsimp simp: projectKO_opt_ntfn split: kernel_object.splits) + apply (simp add: valid_obj'_def valid_ntfn'_def) + apply (rule conjI, clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (frule obj_at_valid_objs', clarsimp) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) + apply (frule st_tcb_at_state_refs_ofD') + apply (frule ko_at_state_refs_ofD') + apply (fastforce simp: get_refs_def elim!: if_live_state_refsE split: option.splits) + apply (frule obj_at_valid_objs', clarsimp) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) + apply (frule st_tcb_at_state_refs_ofD') + apply (frule ko_at_state_refs_ofD') + apply (rule conjI) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (clarsimp simp: valid_pspace'_def) + apply (fastforce simp: get_refs_def elim!: if_live_state_refsE split: option.splits) + done lemma ep_redux_simps3: "ep_q_refs_of' (case xs of [] \ IdleEP | y # ys \ RecvEP (y # ys)) @@ -1880,11 +1883,12 @@ lemma blockedCancelIPC_valid_pspace'[wp]: apply (wpsimp wp: valid_mdb'_lift hoare_vcg_imp_lift getEndpoint_wp hoare_vcg_all_lift sts'_valid_replies' replyUnlink_st_tcb_at' simp: valid_tcb_state'_def epBlocked_def) + apply (rename_tac ep') apply (rule ccontr, normalise_obj_at') apply (match premises in epQueue: "_ (valid_ep' ep s)" for ep s \ \rule meta_mp[rotated, where P="valid_ep' ep s"]\) apply (drule(1) ep_ko_at_valid_objs_valid_ep') - apply (case_tac "remove1 tptr (epQueue ko)"; clarsimp) + apply (case_tac "remove1 tptr (epQueue ep')"; clarsimp) apply (clarsimp simp: valid_ep'_def) apply (fastforce dest: nonempty_epQueue_remove1_valid_ep'[rotated]) apply (case_tac "rptrOpt"; clarsimp simp: pred_tcb_at'_eq_commute) @@ -1948,7 +1952,7 @@ lemma valid_irq_node'_ksSchedulerAction[simp]: crunch blockedCancelIPC for list_refs_of_replies'[wp]: "\s. P (list_refs_of_replies' s)" - (simp_del: comp_apply wp: crunch_wps) + (wp: crunch_wps) lemma blockedCancelIPC_invs': "\invs' and st_tcb_at' ((=) st) tptr\ @@ -2543,6 +2547,7 @@ proof - apply (wpsimp wp: cancelAllIPC_loop_body_st_tcb_at'_other) apply (simp add: valid_objs'_valid_tcbs')+ apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_const_Ball_lift hoare_vcg_imp_lift' + set_endpoint_valid_sched simp: reply_unlink_ts_pred_def)+ apply (clarsimp simp: valid_ep_def) apply (clarsimp simp: valid_ep'_def) @@ -2738,64 +2743,70 @@ lemma cancelAllSignals_corres: apply (simp add: cancel_all_signals_def cancelAllSignals_def) apply add_sym_refs apply (intro corres_stateAssert_add_assertion) - apply (rule corres_underlying_split [OF _ _ get_simple_ko_sp get_ntfn_sp']) - apply (rule corres_guard_imp [OF getNotification_corres]) - apply simp+ - apply (case_tac "ntfn_obj ntfna", simp_all add: ntfn_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def) - apply (rule corres_split [OF ntfn_cancel_corres_helper]) - apply (rule rescheduleRequired_corres) - apply (simp add: dc_def) + apply (rule corres_underlying_split [OF _ _ get_simple_ko_sp get_ntfn_sp']) + apply (rule corres_guard_imp [OF getNotification_corres]) + apply simp+ + apply (case_tac "ntfn_obj ntfna", simp_all add: ntfn_relation_def) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp, rotated]) + apply wpsimp + apply wpsimp + apply (fastforce dest: invs_valid_objs valid_objs_ko_at + simp: ex_abs_def valid_obj_def valid_ntfn_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF setNotification_corres]) + apply (simp add: ntfn_relation_def) + apply (rule corres_split [OF ntfn_cancel_corres_helper]) + apply (rule rescheduleRequired_corres) + apply (simp add: dc_def) + apply (rename_tac list) + apply (rule_tac Q'="\_ s. (\x\set list. released_if_bound_sc_tcb_at x s) + \ current_time_bounded s" + in hoare_post_add) + apply (rule mapM_x_wp') + apply wpsimp + apply (wpsimp wp: hoare_vcg_ball_lift hoare_vcg_imp_lift) + apply (wpsimp wp: get_tcb_obj_ref_wp) + apply (wpsimp wp: set_thread_state_weak_valid_sched_action + set_thread_state_pred_map_tcb_sts_of hoare_vcg_imp_lift + simp: disj_imp) + apply (rule hoare_pre_cont) + apply (wpsimp wp: set_thread_state_weak_valid_sched_action + set_thread_state_pred_map_tcb_sts_of hoare_vcg_imp_lift) + apply clarsimp + apply (rule conjI; clarsimp) + apply fastforce + apply (fastforce simp: vs_all_heap_simps) apply (rename_tac list) - apply (rule_tac Q'="\_ s. (\x\set list. released_if_bound_sc_tcb_at x s) - \ current_time_bounded s" - in hoare_post_add) + apply (rule_tac Q'="\_ s. valid_sched_pointers s" in hoare_post_add) apply (rule mapM_x_wp') - apply wpsimp - apply (wpsimp wp: hoare_vcg_ball_lift hoare_vcg_imp_lift) - apply (wpsimp wp: get_tcb_obj_ref_wp) - apply (wpsimp wp: set_thread_state_weak_valid_sched_action - set_thread_state_pred_map_tcb_sts_of hoare_vcg_imp_lift - simp: disj_imp) - apply (rule hoare_pre_cont) - apply (wpsimp wp: set_thread_state_weak_valid_sched_action - set_thread_state_pred_map_tcb_sts_of hoare_vcg_imp_lift) - apply clarsimp - apply (rule conjI; clarsimp) - apply fastforce - apply (fastforce simp: vs_all_heap_simps) - apply (rename_tac list) - apply (rule_tac Q'="\_ s. valid_sched_pointers s" in hoare_post_add) - apply (rule mapM_x_wp') - apply (rule hoare_name_pre_state) - apply (wpsimp wp: hoare_vcg_const_Ball_lift - sts_st_tcb' - simp: valid_tcb_state'_def) - apply (wpsimp wp: hoare_vcg_const_Ball_lift in_correct_ready_q_lift ready_qs_distinct_lift)+ - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply (frule valid_sched_valid_ready_qs) - apply (frule valid_ready_qs_in_correct_ready_q) - apply (frule valid_ready_qs_ready_qs_distinct) - apply (frule valid_sched_ready_or_release) - apply (erule (1) obj_at_valid_objsE) - apply (frule valid_sched_active_scs_valid) - apply (clarsimp simp: valid_obj_def valid_ntfn_def not_idle_tcb_in_waitingntfn - valid_sched_weak_valid_sched_action - dest!: valid_objs_valid_tcbs) - apply (clarsimp simp: ball_conj_distrib[symmetric]) - apply (rename_tac q s t) - apply (rule context_conjI) - apply (drule_tac x=ntfn and y=t and tp=TCBSignal in sym_refsE; - clarsimp simp: in_state_refs_of_iff refs_of_rev vs_all_heap_simps) - apply (clarsimp simp: valid_sched_released_ipc_queues released_ipc_queues_blocked_on_recv_ntfn_E1) - apply clarsimp - apply (frule invs'_valid_tcbs') - apply (fastforce simp: invs'_def valid_ntfn'_def - valid_obj'_def sym_refs_asrt_def sch_act_wf_asrt_def - intro: ksReadyQueues_asrt_cross - | drule ko_at_valid_objs')+ + apply (rule hoare_name_pre_state) + apply (wpsimp wp: hoare_vcg_const_Ball_lift + sts_st_tcb' + simp: valid_tcb_state'_def) + apply (wpsimp wp: hoare_vcg_const_Ball_lift in_correct_ready_q_lift ready_qs_distinct_lift + set_notification_valid_sched)+ + apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_ready_qs_in_correct_ready_q) + apply (frule valid_ready_qs_ready_qs_distinct) + apply (frule valid_sched_ready_or_release) + apply (erule (1) obj_at_valid_objsE) + apply (frule valid_sched_active_scs_valid) + apply (clarsimp simp: valid_obj_def valid_ntfn_def not_idle_tcb_in_waitingntfn + valid_sched_weak_valid_sched_action + dest!: valid_objs_valid_tcbs) + apply (clarsimp simp: ball_conj_distrib[symmetric]) + apply (rename_tac q s t) + apply (rule context_conjI) + apply (drule_tac x=ntfn and y=t and tp=TCBSignal in sym_refsE; + clarsimp simp: in_state_refs_of_iff refs_of_rev vs_all_heap_simps) + apply (clarsimp simp: valid_sched_released_ipc_queues released_ipc_queues_blocked_on_recv_ntfn_E1) + apply clarsimp + apply (frule invs'_valid_tcbs') + apply (fastforce simp: invs'_def valid_ntfn'_def + valid_obj'_def sym_refs_asrt_def sch_act_wf_asrt_def + intro: ksReadyQueues_asrt_cross + | drule ko_at_valid_objs')+ done lemma ep'_Idle_case_helper: @@ -2910,7 +2921,7 @@ lemma valid_pspace'_pspace_bounded'[elim!]: lemma cancel_all_invs'_helper: "\invs' and (\s. (\x \ set q. - tcb_at' x s \ ex_nonz_cap_to' x s \ + ex_nonz_cap_to' x s \ st_tcb_at' (\st. (\obj grant reply. st = BlockedOnReceive obj grant reply) \ (\obj badge grant grantreply iscall. st = BlockedOnSend obj badge grant grantreply iscall)) x s) @@ -3049,6 +3060,22 @@ crunch setEndpoint, setNotification for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers and valid_sched_pointers[wp]: valid_sched_pointers +(* FIXME RT: move up *) +lemma in_epQueue_st_tcb_at': + "\t \ set (epQueue ep); ep \ IdleEP; ko_at' ep epPtr s; valid_objs' s; + sym_refs (state_refs_of' s)\ + \ st_tcb_at' (\st. (\grant reply. st = BlockedOnReceive epPtr grant reply) + \ (\badge grant grantreply iscall. + st = BlockedOnSend epPtr badge grant grantreply iscall)) t s" + apply (frule (1) ep_ko_at_valid_objs_valid_ep') + apply (clarsimp simp: valid_ep'_def) + apply (clarsimp simp: sym_refs_def) + apply (erule_tac x=epPtr in allE) + apply (fastforce simp: state_refs_of'_def is_tcb obj_at'_def tcb_st_refs_of'_def + get_refs_def2 st_tcb_at'_def tcb_bound_refs'_def + split: thread_state.splits if_splits endpoint.splits) + done + lemma cancelAllIPC_invs'[wp]: "cancelAllIPC ep_ptr \invs'\" supply valid_dom_schedule'_def[simp] @@ -3060,27 +3087,18 @@ lemma cancelAllIPC_invs'[wp]: valid_global_refs_lift' valid_arch_state_lift' valid_irq_node_lift ssa_invs' sts_sch_act' getEndpoint_wp irqs_masked_lift) - apply (clarsimp simp: invs'_def valid_ep'_def) - apply (wpsimp wp: hoare_vcg_const_Ball_lift) - apply (wpsimp wp: getEndpoint_wp) + apply (clarsimp simp: invs'_def valid_ep'_def) + apply (wpsimp wp: hoare_vcg_const_Ball_lift) + apply (wpsimp wp: getEndpoint_wp)+ apply (clarsimp simp: invs'_def valid_ep'_def) apply (frule obj_at_valid_objs', fastforce) - apply (clarsimp simp: valid_obj'_def) - apply (rule conjI) - apply (metis fold_list_refs_of_replies') + apply (clarsimp simp: valid_obj'_def) apply (clarsimp simp: sym_refs_asrt_def sch_act_wf_asrt_def) apply (rule conjI) - apply (drule(1) sym_refs_ko_atD') - apply (clarsimp simp: valid_ep'_def st_tcb_at_refs_of_rev' split: endpoint.splits) - apply (intro conjI) - apply ((drule(1) bspec | drule st_tcb_at_state_refs_ofD' - | clarsimp elim!: if_live_state_refsE split: if_splits)+)[1] - apply (fastforce simp: st_tcb_at'_def obj_at'_def) - apply (intro conjI) - apply ((drule(1) bspec | drule st_tcb_at_state_refs_ofD' - | clarsimp elim!: if_live_state_refsE split: if_splits)+)[1] - apply (fastforce simp: st_tcb_at'_def obj_at'_def) - apply (clarsimp simp: valid_ep'_def split: endpoint.splits) + apply (drule (1) sym_refs_ko_atD') + apply (fastforce dest: bspec st_tcb_at_state_refs_ofD' elim!: if_live_state_refsE + simp: valid_ep'_def st_tcb_at_refs_of_rev' split: endpoint.splits if_splits) + apply (fastforce dest!: in_epQueue_st_tcb_at' simp: st_tcb_at'_def obj_at'_def) done lemma ex_nonz_cap_to'_tcb_in_WaitingNtfn'_q: @@ -3141,7 +3159,7 @@ lemma cancelAllSignals_invs'[wp]: hoare_drop_imps hoare_vcg_all_lift simp: valid_dom_schedule'_def) apply (clarsimp simp: invs'_def valid_dom_schedule'_def) - apply (wpsimp wp: hoare_vcg_const_Ball_lift) + apply (wpsimp wp: hoare_vcg_const_Ball_lift)+ apply (clarsimp simp: invs'_def valid_pspace'_def valid_ntfn'_def valid_dom_schedule'_def) apply (prop_tac "valid_ntfn' ntfn s") @@ -3169,13 +3187,13 @@ lemma cancelAllIPC_st_tcb_at: apply wpsimp apply (wpsimp wp: mapM_x_wp' sts_st_tcb_at'_cases threadGet_wp hoare_vcg_imp_lift simp: obj_at_ko_at'_eq[where P=\, simplified]) - apply (rule_tac Q'="\_. tcb_at' x and st_tcb_at' P t" in hoare_strengthen_post) - apply (wpsimp wp: replyUnlink_st_tcb_at') - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (wpsimp wp: gts_wp') - apply (fastforce simp: obj_at_ko_at'_eq[where P=\, simplified]) - apply wpsimp - by clarsimp + apply (rule_tac Q'="\_. tcb_at' x and st_tcb_at' P t" in hoare_strengthen_post) + apply (wpsimp wp: replyUnlink_st_tcb_at') + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (wpsimp wp: gts_wp') + apply (fastforce simp: obj_at_ko_at'_eq[where P=\, simplified]) + apply wpsimp+ + done lemmas cancelAllIPC_makes_simple[wp] = cancelAllIPC_st_tcb_at [where P=simple', simplified] @@ -3324,11 +3342,11 @@ lemma cancelAllSignals_unlive: apply wp apply (fastforce simp: obj_at'_real_def live_ntfn'_def ko_wp_at'_def) apply (wp rescheduleRequired_unlive) - apply (rule cancelAllSignals_unlive_helper[THEN hoare_strengthen_post]) - apply fastforce - apply (wpsimp wp: hoare_vcg_const_Ball_lift set_ntfn'.ko_wp_at - simp: objBits_simps') - apply (clarsimp, frule (1) ko_at_valid_objs'_pre, + apply (rule cancelAllSignals_unlive_helper[THEN hoare_strengthen_post]) + apply fastforce + apply (wpsimp wp: hoare_vcg_const_Ball_lift set_ntfn'.ko_wp_at + simp: objBits_simps')+ + apply (frule (1) ko_at_valid_objs'_pre, clarsimp simp: valid_obj'_def valid_ntfn'_def) apply (intro conjI[rotated]; clarsimp) apply (fastforce simp: obj_at'_def) @@ -3384,14 +3402,14 @@ lemma cancelBadgedSends_filterM_helper': apply (clarsimp simp: filterM_append bind_assoc simp del: set_append distinct_append) apply (drule spec, erule bind_wp_fwd) apply (rule bind_wp [OF _ gts_inv']) - apply (simp add: opt_map_Some_eta_fold split del: if_split) + apply (simp split del: if_split) apply (rule hoare_pre) apply (wpsimp wp: setThreadState_state_refs_of' valid_irq_node_lift hoare_vcg_const_Ball_lift valid_irq_handlers_lift'' irqs_masked_lift sts_st_tcb' hoare_vcg_all_lift sts_sch_act' threadGet_inv[THEN hoare_drop_imp] hoare_vcg_imp_lift' simp: cteCaps_of_def o_def) - apply (clarsimp simp: opt_map_Some_eta_fold) + apply clarsimp apply (frule insert_eqD, frule state_refs_of'_elemD) apply (clarsimp simp: valid_tcb_state'_def st_tcb_at_refs_of_rev') apply (frule pred_tcb_at') @@ -3509,6 +3527,11 @@ lemma cancelBadgedSends_corres: apply (case_tac ep; simp add: ep_relation_def) apply (rename_tac queue) apply (simp add: filterM_mapM list_case_return cong: list.case_cong) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp, rotated]) + apply wpsimp + apply wpsimp + apply (fastforce dest: invs_valid_objs valid_objs_ko_at + simp: ex_abs_def valid_obj_def valid_ep_def) apply (rule corres_guard_imp) apply (rule corres_split_nor[OF setEndpoint_corres]) apply (clarsimp simp: ep_relation_def) @@ -3541,7 +3564,7 @@ lemma cancelBadgedSends_corres: apply (rule corres_return_eq_same, simp) apply (rule wp_post_taut) apply (rule wp_post_taut) - apply simp+ + apply (simp add: comp_apply)+ apply (wpsimp wp: gts_wp) apply (wpsimp wp: gts_wp') apply clarsimp @@ -3599,7 +3622,7 @@ lemma cancelBadgedSends_corres: pred_neg_def weak_sch_act_wf_def) apply simp apply simp - apply (wpsimp wp: hoare_vcg_ball_lift) + apply (wpsimp wp: set_endpoint_valid_sched hoare_vcg_ball_lift) apply (wpsimp wp: hoare_vcg_ball_lift) apply (clarsimp simp: obj_at_def is_ep_def cong: conj_cong) apply (prop_tac "valid_ep (Structures_A.SendEP queue) s") @@ -3615,7 +3638,7 @@ lemma cancelBadgedSends_corres: apply (intro conjI impI ballI; (fastforce simp: valid_ep'_def obj_at'_def)?) apply (frule (2) in_send_ep_queue_TCBBlockedSend') apply fastforce - apply (fastforce simp: st_tcb_at_refs_of_rev' st_tcb_at'_def obj_at'_def pred_neg_def) + apply (fastforce simp: st_tcb_at_refs_of_rev' st_tcb_at'_def obj_at'_def pred_neg_def comp_apply) done crunch schedContextCancelYieldTo, tcbReleaseRemove diff --git a/proof/refine/RISCV64/Ipc_R.thy b/proof/refine/RISCV64/Ipc_R.thy index 477208f37b..edb542ddcf 100644 --- a/proof/refine/RISCV64/Ipc_R.thy +++ b/proof/refine/RISCV64/Ipc_R.thy @@ -2212,51 +2212,6 @@ crunch doIPCTransfer for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" (wp: crunch_wps constOnFailure_wp simp: crunch_simps) -lemma tcbEPFindIndex_corres: - "corres (=) ((tcb_at t and pspace_aligned and pspace_distinct) and (\s. \t \ set list. tcb_at t s) - and K (n < length list)) - (tcb_at' t and (\s. \t \ set list. tcb_at' t s)) - (tcb_ep_find_index t list n) (tcbEPFindIndex t list n)" - apply (rule corres_gen_asm') - apply (induct n) - apply (subst tcb_ep_find_index.simps) - apply (subst tcbEPFindIndex.simps) - apply (rule corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule_tac r="(=)" in threadGet_corres) - apply (clarsimp simp: tcb_relation_def)+ - apply (rule corres_underlying_split) - apply (rule corres_guard_imp) - apply (rule_tac r="(=)" in threadGet_corres) - apply (clarsimp simp: tcb_relation_def) - apply simp - apply fastforce - apply (rule corres_if, simp) - apply (rule corres_trivial, simp) - apply (rule corres_trivial, simp) - apply wpsimp - apply wpsimp - apply wpsimp - apply wpsimp - apply (subst tcb_ep_find_index.simps) - apply (subst tcbEPFindIndex.simps) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr) - apply (rule threadGet_corres, simp add: tcb_relation_def) - apply (rule corres_split_eqr) - apply (rule threadGet_corres, simp add: tcb_relation_def) - apply (rule corres_if, simp) - apply (rule corres_if, simp) - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_trivial, simp) - apply (wp thread_get_wp) - apply (wp threadGet_wp) - apply (wp thread_get_wp) - apply (wpsimp wp: threadGet_wp) - apply (fastforce simp: obj_at'_def)+ - done - (* The condition `reply_ptr \ fst ` replies_with_sc s` is provable in the presence of sym_refs, but sym_refs may not hold at a call of reply_push. If we had sym_refs for replies <-> scs only, then that would be enough and should be true at any call of @@ -2285,28 +2240,68 @@ lemma reply_push_valid_objs: apply (clarsimp simp: obj_at_def is_tcb sk_obj_at_pred_def is_reply) done -lemma tcbEPAppend_corres: - "corres (=) (\s. tcb_at t s \ pspace_aligned s \ pspace_distinct s \ (\t \ set qs. tcb_at t s)) - (\s. tcb_at' t s \ (\t \ set qs. tcb_at' t s)) - (tcb_ep_append t qs) (tcbEPAppend t qs)" - apply (clarsimp simp: tcb_ep_append_def tcbEPAppend_def null_def split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_if; clarsimp?) - apply (rule_tac corres_split[OF tcbEPFindIndex_corres]) - apply wpsimp+ +definition priority_ordered' :: "obj_ref list \ kernel_state \ bool" where + "priority_ordered' ts s \ (\t \ set ts. tcb_at' t s) \ priority_ordered ts (prios_of' s)" + +defs priority_ordered'_asrt_def: + "priority_ordered'_asrt \ priority_ordered'" + +declare priority_ordered'_asrt_def[simp] + +lemma priority_ordered_cross: + "\pspace_relation (kheap s) (ksPSpace s'); priority_ordered ts (prios_of s); + \t \ set ts. tcb_at t s; pspace_aligned s; pspace_distinct s\ + \ priority_ordered' ts s'" + apply (clarsimp simp: priority_ordered'_def) + apply (rule context_conjI) + apply (fastforce intro: tcb_at_cross) + apply (erule sorted_wrt_mono_rel[rotated]) + apply (rename_tac t t') + apply (frule_tac x=t in bspec, fastforce) + apply (drule_tac x=t' in bspec, fastforce) + apply (frule_tac x=t in bspec, fastforce) + apply (drule_tac x=t' in bspec, fastforce) + apply (drule tcb_at_ko_at)+ + apply clarsimp + apply (clarsimp simp: obj_at_def obj_at'_def) + apply (frule_tac ptr=t in pspace_relation_tcb_relation) + apply fastforce + apply fastforce + apply (frule_tac ptr=t' in pspace_relation_tcb_relation) + apply fastforce + apply fastforce + apply (clarsimp simp: img_ord_def tcb_relation_def opt_map_def tcbs_of_kh_def) done -lemma tcbEPFindIndex_inv[wp]: - "tcbEPFindIndex t list n \P\" - apply (rule hoare_weaken_pre) - apply (induct n) - apply (subst tcbEPFindIndex.simps, wpsimp) - apply (subst tcbEPFindIndex.simps, wpsimp, assumption) - apply wpsimp+ +lemma tcbEPAppend_corres: + "corres (=) + ((\s. tcb_at t s \ pspace_aligned s \ pspace_distinct s \ (\t \ set qs. tcb_at t s) + \ priority_ordered qs (prios_of s)) + and (\s. distinct qs)) + \ + (tcb_ep_append t qs) (tcbEPAppend t qs)" + apply (rule corres_gen_asm) + apply (clarsimp simp: tcb_ep_append_def tcbEPAppend_def split del: if_split) + apply (rule corres_stateAssert_ignore) + apply (fastforce intro!: priority_ordered_cross) + apply (rule stronger_corres_guard_imp) + apply (rule_tac r'="(=)" in corres_split[OF threadGet_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_split[OF corres_mapM_scheme[ + where r="(=)" and r'="(=)" and S="set (zip qs qs)"]]) + apply simp + apply clarsimp + apply (rule stronger_corres_guard_imp) + apply (rule threadGet_corres') + apply (clarsimp simp: tcb_relation_def) + apply fastforce + apply assumption + apply (wpsimp wp: threadGet_wp)+ done crunch tcbEPAppend for ep_at'[wp]: "ep_at' epptr" + (wp: crunch_wps) crunch bindScReply for valid_tcbs'[wp]: valid_tcbs' @@ -2409,6 +2404,7 @@ lemma sendIPC_corres: and active_scs_valid and valid_release_q and current_time_bounded and in_correct_ready_q and ready_qs_distinct and ready_or_release + and sorted_ipc_queues and valid_sched_action and ep_at ep and ex_nonz_cap_to t and st_tcb_at active t and scheduler_act_not t and (\s. cd \ bound_sc_tcb_at (\a. \y. a = Some y) t s)) invs' @@ -2425,7 +2421,7 @@ lemma sendIPC_corres: apply (rule corres_split [OF getEndpoint_corres, where R="\rv. all_invs_but_fault_tcbs and valid_list and st_tcb_at active t and ep_at ep and valid_sched_action and active_scs_valid - and valid_release_q + and valid_release_q and sorted_ipc_queues and in_correct_ready_q and ready_qs_distinct and ready_or_release and valid_ep rv and obj_at (\ob. ob = Endpoint rv) ep and ex_nonz_cap_to t and scheduler_act_not t and current_time_bounded @@ -2455,7 +2451,12 @@ lemma sendIPC_corres: apply (rule setEndpoint_corres) apply (simp add: ep_relation_def) apply (wpsimp wp: hoare_vcg_ball_lift)+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_def valid_state_def valid_pspace_def valid_ep_def) + apply (frule valid_objs_valid_tcbs) + apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_def valid_state_def + valid_pspace_def valid_ep_def) + apply (fastforce dest!: sorted_ipc_queues_endpoint_priority_ordered + simp: sorted_ipc_queues_def opt_map_def obj_at_def eps_of_kh_def + split: option.splits) apply (clarsimp simp: invs'_def valid_pspace'_def valid_ep'_def) \ \concludes SendEP\ apply (simp add: ep_relation_def) @@ -4503,9 +4504,6 @@ lemma sendSignal_corres: apply (intro conjI impI) apply (metis hd_Cons_tl list.set_intros(1) list.set_intros(2)) apply (metis hd_Cons_tl list.set_intros(2)) - using distinct_tl apply fastforce - using distinct_tl apply fastforce - apply (case_tac list; clarsimp simp: valid_ntfn'_def split: list.splits option.splits) \ \ActiveNtfn\ apply (clarsimp simp add: ntfn_relation_def Let_def) apply (rule corres_guard_imp) @@ -4601,86 +4599,30 @@ crunch cleanReply for schedulerAction[wp]: "\s. P (ksSchedulerAction s)" (simp: crunch_simps) -lemma tcbEPFindIndex_wp: - "\\s. (\i j. 0 \ i \ i \ Suc sz \ - (\tcb tcba. ko_at' tcb tptr s \ ko_at' tcba (queue ! j) s \ - (Suc j = i \ tcbPriority tcba \ tcbPriority tcb) \ - (i < j \ j \ sz \ tcbPriority tcba < tcbPriority tcb) \ Q i s))\ - tcbEPFindIndex tptr queue sz \Q\" - apply (induct sz; subst tcbEPFindIndex.simps) - apply (wpsimp wp: threadGet_wp) - apply (clarsimp simp: obj_at'_def) - apply (wpsimp wp: threadGet_wp | assumption)+ - apply (clarsimp simp: obj_at'_def) - done - crunch tcbEPAppend, tcbEPDequeue for inv[wp]: P - -lemma tcbEPAppend_rv_wf: - "\\\ tcbEPAppend t q \\rv s. set rv = set (t#q)\" - apply (simp only: tcbEPAppend_def) - apply (wp tcbEPFindIndex_wp) - apply (auto simp: null_def set_append[symmetric]) - done - -lemma tcbEPAppend_rv_wf': - "\P (set (t#q))\ tcbEPAppend t q \\rv. P (set rv)\" - apply (clarsimp simp: valid_def) - apply (frule use_valid[OF _ tcbEPAppend_rv_wf], simp, simp) - apply (frule use_valid[OF _ tcbEPAppend_inv, where P = "P (set (t#q))"], simp+) - done - -lemma tcbEPAppend_rv_wf'': - "\P (ep_q_refs_of' (updateEpQueue ep (t#q))) and K (ep \ IdleEP)\ - tcbEPAppend t q - \\rv. P (ep_q_refs_of' (updateEpQueue ep rv))\" - by (cases ep; wpsimp wp: tcbEPAppend_rv_wf' simp: updateEpQueue_def) - -lemma tcbEPDequeue_rv_wf: - "\\_. t \ set q \ distinct q\ tcbEPDequeue t q \\rv s. set rv = set q - {t}\" - apply (wpsimp simp: tcbEPDequeue_def) - apply (fastforce dest: findIndex_member) - done - -lemma tcbEPDequeue_rv_wf': - "\P (set q - {t}) and K (t \ set q \ distinct q)\ tcbEPDequeue t q \\rv. P (set rv)\" - apply (clarsimp simp: valid_def) - apply (frule use_valid[OF _ tcbEPDequeue_rv_wf], simp, simp) - apply (frule use_valid[OF _ tcbEPDequeue_inv, where P = "P (set q - {t})"], simp+) - done - -lemma tcbEPDequeue_rv_wf'': - "\P (ep_q_refs_of' (updateEpQueue ep q)) and K (t \ set q \ distinct q \ ep \ IdleEP)\ - tcbEPDequeue t q - \\rv. P (ep_q_refs_of' (updateEpQueue ep (t#rv)))\" - by (cases ep; wpsimp wp: tcbEPDequeue_rv_wf' simp: Times_Diff_distrib1 insert_absorb updateEpQueue_def) + (wp: crunch_wps) lemma tcbEPAppend_not_null[wp]: "\\\ tcbEPAppend t q \\rv _. rv \ []\" by (wpsimp simp: tcbEPAppend_def split_del: if_split) -lemma tcbEPAppend_distinct[wp]: - "\\s. distinct q \ t \ set q\ tcbEPAppend t q \\q' s. distinct q'\" - apply (simp only: tcbEPAppend_def) - apply (wpsimp wp: tcbEPFindIndex_wp) - apply (auto simp: set_take_disj_set_drop_if_distinct dest: in_set_dropD in_set_takeD) - done - lemma tcbEPAppend_valid_SendEP: "\valid_ep' (SendEP (t#q)) and K (t \ set q)\ tcbEPAppend t q \\q'. valid_ep' (SendEP q')\" apply (simp only: tcbEPAppend_def) - apply (case_tac q; wpsimp wp: tcbEPFindIndex_wp) - apply (fastforce simp: valid_ep'_def set_take_disj_set_drop_if_distinct - dest: in_set_takeD in_set_dropD) + apply (wpsimp wp: mapM_wp_lift threadGet_wp) + apply fastforce + apply (wpsimp wp: mapM_wp_lift threadGet_wp)+ + apply (fastforce simp: valid_ep'_def dest: in_set_zip1) done lemma tcbEPAppend_valid_RecvEP: "\valid_ep' (RecvEP (t#q)) and K (t \ set q)\ tcbEPAppend t q \\q'. valid_ep' (RecvEP q')\" apply (simp only: tcbEPAppend_def) - apply (case_tac q; wpsimp wp: tcbEPFindIndex_wp) - apply (fastforce simp: valid_ep'_def set_take_disj_set_drop_if_distinct - dest: in_set_takeD in_set_dropD) + apply (wpsimp wp: mapM_wp_lift threadGet_wp) + apply fastforce + apply (wpsimp wp: mapM_wp_lift threadGet_wp)+ + apply (fastforce simp: valid_ep'_def dest: in_set_zip1) done lemma tcbEPAppend_valid_ep': @@ -4691,15 +4633,11 @@ lemma tcbEPAppend_valid_ep': lemma tcbEPDequeue_valid_SendEP: "\valid_ep' (SendEP q) and K (t \ set q)\ tcbEPDequeue t q \\q'. valid_ep' (SendEP (t#q'))\" - apply (wpsimp simp: tcbEPDequeue_def valid_ep'_def) - by (clarsimp simp: findIndex_def findIndex'_app - dest!: in_set_takeD in_set_dropD findIndex_member) + by (wpsimp simp: tcbEPDequeue_def valid_ep'_def) lemma tcbEPDequeue_valid_RecvEP: "\valid_ep' (RecvEP q) and K (t \ set q)\ tcbEPDequeue t q \\q'. valid_ep' (RecvEP (t#q'))\" - apply (wpsimp simp: tcbEPDequeue_def valid_ep'_def) - by (clarsimp simp: findIndex_def findIndex'_app - dest!: in_set_takeD in_set_dropD findIndex_member) + by (wpsimp simp: tcbEPDequeue_def valid_ep'_def) lemma tcbEPDequeue_valid_ep': "\valid_ep' (updateEpQueue ep q) and K (ep \ IdleEP \ t \ set q)\ @@ -4900,18 +4838,6 @@ lemma rfk_invs': crunch replyFromKernel for nosch[wp]: "\s. P (ksSchedulerAction s)" -lemma set_tcb_obj_ref_ntfns_of[wp]: - "set_tcb_obj_ref f t new \\s. P (ntfns_of s)\" - by (wpsimp simp: set_tcb_obj_ref_def wp: set_object_wp) - (fastforce dest!: get_tcb_SomeD elim!: rsubst[where P=P] simp: opt_map_def - split: option.splits Structures_A.kernel_object.splits)+ - -lemma update_sched_context_ntfns_of[wp]: - "update_sched_context f' scp \\s. P (ntfns_of s)\" - by (wpsimp simp: update_sched_context_def wp: set_object_wp get_object_wp) - (fastforce elim!: rsubst[where P=P] simp: opt_map_def obj_at_def - split: option.splits Structures_A.kernel_object.splits)+ - crunch maybe_donate_sc for ntfn_at[wp]: "ntfn_at ntfnp" and ntfns_of[wp]: "\s. P (ntfns_of s)" @@ -5019,7 +4945,7 @@ lemma completeSignal_corres: apply (clarsimp simp: valid_sched_def obj_at_def is_ntfn valid_sched_action_def invs_def valid_state_def valid_pspace_def opt_map_red) apply (clarsimp simp: invs'_def) - apply wpsimp + apply (wpsimp wp: set_notification_valid_sched) apply wpsimp apply (wpsimp simp: valid_ntfn_def) apply (clarsimp simp: live_ntfn'_def valid_ntfn'_def) @@ -5117,8 +5043,12 @@ lemma maybeReturnSc_corres: done lemma tcbEPDequeue_corres: - "qs = qs' \ corres (=) \ \ (tcb_ep_dequeue t qs) (tcbEPDequeue t qs')" - by (clarsimp simp: tcb_ep_dequeue_def tcbEPDequeue_def) + "qs = qs' \ + corres (=) + (pspace_aligned and pspace_distinct) \ + (tcb_ep_dequeue t qs) (tcbEPDequeue t qs')" + unfolding tcb_ep_dequeue_def tcbEPDequeue_def + by (fastforce intro: filter_cong) lemma doNBRecvFailedTransfer_corres: "corres dc (pspace_aligned and pspace_distinct and tcb_at thread) \ @@ -5573,7 +5503,7 @@ lemma receiveIPC_corres: apply (wpsimp wp: valid_replies'_sc_asrt_lift valid_bound_obj'_lift) apply (wpsimp wp: gts_st_tcb_at) apply wpsimp - apply (wpsimp wp: hoare_vcg_ball_lift valid_bound_obj_lift) + apply (wpsimp wp: hoare_vcg_ball_lift valid_bound_obj_lift set_endpoint_valid_sched) apply (clarsimp simp: pred_conj_def cong: conj_cong) apply (wpsimp wp: valid_replies'_sc_asrt_lift valid_bound_obj'_lift hoare_drop_imps) apply (clarsimp simp: invs_def valid_state_def st_tcb_at_tcb_at @@ -5589,12 +5519,20 @@ lemma receiveIPC_corres: by (auto simp: ko_at_state_refs_ofD get_refs_def2 pred_tcb_at_def obj_at_def valid_ep_def split: list.splits if_splits) - apply (clarsimp split: list.split) apply (frule (2) ri_preamble_not_in_sc) apply (frule_tac y=sender in valid_sched_scheduler_act_not_better) apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) apply (prop_tac "ex_nonz_cap_to epptr s") apply (fastforce simp: live_def obj_at_def is_ep elim!: if_live_then_nonz_capD2) + apply (case_tac "queue = []") + apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) + apply (clarsimp simp: list_case_If split: if_splits) + apply (rule conjI) + apply (frule valid_sched_sorted_ipc_queues) + apply (frule_tac ptr=epptr and q="sender # queue" + in sorted_ipc_queues_endpoint_priority_ordered) + apply (clarsimp simp: opt_map_def obj_at_def eps_of_kh_def) + apply (force elim!: sorted_wrt_subseq) apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) apply (fastforce simp: valid_ep'_def invs'_def split: list.split) \ \RecvEP\ @@ -5609,8 +5547,16 @@ lemma receiveIPC_corres: apply (simp add: ep_relation_def) apply (wpsimp wp: hoare_vcg_ball_lift)+ apply (rule corres_guard_imp[OF doNBRecvFailedTransfer_corres]; clarsimp) + apply clarsimp + apply (frule invs_valid_tcbs) apply (clarsimp simp: invs_def valid_pspace_def valid_state_def valid_ep_def) - apply (fastforce elim: ri_preamble_vbreply reply_at_ppred_reply_at) + apply (intro conjI) + apply (fastforce elim: ri_preamble_vbreply ) + apply (fastforce elim: reply_at_ppred_reply_at) + apply (fastforce dest!: valid_sched_sorted_ipc_queues + sorted_ipc_queues_endpoint_priority_ordered + simp: sorted_ipc_queues_def opt_map_def obj_at_def eps_of_kh_def + split: option.splits) apply (clarsimp simp: invs'_def valid_pspace'_def valid_ep'_def) apply fastforce \ \ end of ep cases \ @@ -5693,13 +5639,15 @@ lemma as_user_refs_of[wp]: lemma receiveSignal_corres: "\ is_ntfn_cap cap; cap_relation cap cap' \ \ - corres dc ((invs and weak_valid_sched_action and scheduler_act_not thread and valid_ready_qs - and st_tcb_at active thread and active_scs_valid and valid_release_q - and current_time_bounded and (\s. thread = cur_thread s) and not_queued thread - and not_in_release_q thread and ready_or_release and ex_nonz_cap_to thread) - and valid_cap cap) - (invs' and tcb_at' thread and ex_nonz_cap_to' thread and valid_cap' cap') - (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" + corres dc + ((invs and weak_valid_sched_action and scheduler_act_not thread and valid_ready_qs + and st_tcb_at active thread and active_scs_valid and valid_release_q + and sorted_ipc_queues + and current_time_bounded and (\s. thread = cur_thread s) and not_queued thread + and not_in_release_q thread and ready_or_release and ex_nonz_cap_to thread) + and valid_cap cap) + (invs' and tcb_at' thread and ex_nonz_cap_to' thread and valid_cap' cap') + (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" (is "\_;_\ \ corres _ (?pred and _) _ _ _") apply (simp add: receive_signal_def receiveSignal_def) apply add_sym_refs @@ -5749,6 +5697,13 @@ lemma receiveSignal_corres: apply fastforce \ \WaitingNtfn\ apply (case_tac isBlocking; simp) + apply (rename_tac queue) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp, rotated]) + apply wpsimp + apply wpsimp + apply (fastforce dest: invs_valid_objs valid_objs_ko_at + simp: ex_abs_def valid_obj_def valid_ntfn_def) + apply (rule_tac F="distinct queue" in corres_req, fastforce) apply (rule corres_guard_imp) apply (rule corres_split[OF setThreadState_corres]) apply (clarsimp simp: thread_state_relation_def) @@ -5764,7 +5719,15 @@ lemma receiveSignal_corres: apply (wpsimp wp: set_thread_state_weak_valid_sched_action) apply (wpsimp wp: hoare_vcg_ball_lift2) apply clarsimp + apply (frule invs_psp_aligned) + apply (frule invs_distinct) + apply (clarsimp cong: conj_cong) apply (rule conjI, fastforce simp: valid_tcb_state_def valid_ntfn_def)+ + apply (intro conjI) + apply (fastforce simp: sorted_ipc_queues_def opt_map_def obj_at_def eps_of_kh_def + split: option.splits) + apply fastforce + apply fastforce apply (erule delta_sym_refs[OF invs_sym_refs]; clarsimp split: if_split_asm) apply (fastforce simp: state_refs_of_def get_refs_def tcb_st_refs_of_def pred_tcb_at_def obj_at_def is_obj_defs @@ -5824,7 +5787,7 @@ lemma sendFaultIPC_corres: shows "corres (fr \ (=)) (invs and valid_list and valid_sched_action and active_scs_valid - and valid_release_q and valid_ready_qs and ready_or_release + and valid_release_q and valid_ready_qs and ready_or_release and sorted_ipc_queues and st_tcb_at active thread and scheduler_act_not thread and current_time_bounded and (\s. can_donate \ bound_sc_tcb_at (\sc. sc \ None) thread s) @@ -5988,6 +5951,17 @@ crunch scheduleTCB crunch doNBRecvFailedTransfer for invs'[wp]: invs' +lemma tcbEPAppend_tcb_at': + "\\s. \ptr \ set q. tcb_at' ptr s \ tcb_at' t s\ + tcbEPAppend t q + \\q' s. \ptr \set q'. tcb_at' ptr s\" + unfolding tcbEPAppend_def + apply (wpsimp wp: mapM_wp_lift threadGet_wp) + apply fastforce + apply (wpsimp wp: mapM_wp_lift threadGet_wp)+ + apply (fastforce simp: valid_ep'_def dest: in_set_zip1) + done + (* t = ksCurThread s *) lemma rai_invs'[wp]: "\invs' and st_tcb_at' active' t @@ -6017,10 +5991,9 @@ lemma rai_invs'[wp]: dest: invs_valid_objs') \ \WaitingNtfn\ apply (wpsimp wp: setNotification_invs' maybeReturnSc_invs') - apply (rule_tac Q'="\_ _. ntfnBoundTCB ep = None" in hoare_post_add) apply (clarsimp simp: valid_ntfn'_def cong: conj_cong) - apply (wpsimp wp: maybeReturnSc_invs' tcbEPAppend_rv_wf' sts_invs_minor' - hoare_vcg_ball_lift hoare_drop_imps)+ + apply (wpsimp wp: maybeReturnSc_invs' sts_invs_minor' tcbEPAppend_tcb_at' + hoare_vcg_ball_lift hoare_drop_imps hoare_vcg_conj_lift)+ apply (frule invs_valid_objs') apply (erule valid_objsE') apply (fastforce simp: obj_at'_def) @@ -6028,12 +6001,6 @@ lemma rai_invs'[wp]: isCap_simps sym_refs_asrt_def pred_tcb_at'_def obj_at'_def) apply (rule conjI, clarsimp) apply (rule conjI, clarsimp) - apply (rule conjI, clarsimp) - apply (rule context_conjI) - apply (drule_tac ko=ep in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def) - apply (fastforce simp: tcb_bound_refs'_def refs_of_rev' get_refs_def ko_wp_at'_def - split: option.splits) apply (drule_tac ko=ep in sym_refs_ko_atD'[rotated]) apply (fastforce simp: obj_at'_def) apply (fastforce simp: tcb_bound_refs'_def refs_of_rev' get_refs_def ko_wp_at'_def @@ -6445,7 +6412,7 @@ lemma cancelIPC_sym_heap_scReplies [wp]: cancelIPC t \\_. sym_heap_scReplies\" unfolding cancelIPC_def - by (wpsimp wp: gts_wp', simp add: comp_def) + by (wpsimp wp: gts_wp') lemma replyTCB_is_not_ksIdleThread: "\ko_at' reply replyPtr s; the (replyTCB reply) = ksIdleThread s; replyTCB reply = Some tcb; @@ -6848,6 +6815,7 @@ lemma handleFault_corres: assumes "fr f f'" shows "corres dc (invs and valid_list and valid_sched_action and active_scs_valid and valid_release_q and valid_ready_qs and ready_or_release + and sorted_ipc_queues and scheduler_act_not t and st_tcb_at active t and current_time_bounded and ex_nonz_cap_to t and K (valid_fault f)) (invs' and sch_act_not t and st_tcb_at' active' t and ex_nonz_cap_to' t) @@ -6899,6 +6867,7 @@ lemma handleTimeout_corres: assumes "fr f f'" shows "corres dc (invs and valid_list and valid_sched_action and active_scs_valid and valid_release_q and valid_ready_qs and ready_or_release + and sorted_ipc_queues and scheduler_act_not t and st_tcb_at active t and current_time_bounded and cte_wp_at is_ep_cap (t,tcb_cnode_index 4) and K (valid_fault f)) invs' @@ -7068,7 +7037,7 @@ lemma doReplyTransfer_corres: apply (rule_tac Q="valid_sched_action and tcb_at recvr and sc_tcb_sc_at (\a. a \ None) (the scopt) and active_sc_at (the scopt) and valid_refills (the scopt) and - valid_release_q and active_scs_valid and + valid_release_q and active_scs_valid and sorted_ipc_queues and (\s. sc_tcb_sc_at (\tcb_ptr_opt. tcb_ptr_opt = Some recvr \ not_queued recvr s @@ -7083,7 +7052,7 @@ lemma doReplyTransfer_corres: and P="valid_sched_action and tcb_at recvr and current_time_bounded and sc_tcb_sc_at (\a. a \ None) (the scopt) and active_sc_at (the scopt) and valid_refills (the scopt) and - valid_release_q and active_scs_valid and + valid_release_q and active_scs_valid and sorted_ipc_queues and (\s. sc_tcb_sc_at (\tcb_ptr_opt. tcb_ptr_opt = Some recvr \ not_queued recvr s @@ -7118,7 +7087,7 @@ lemma doReplyTransfer_corres: \ pred_map runnable (tcb_sts_of s) recvr) (the scopt) s) s \ invs s \ valid_release_q s \ tcb_at recvr s \ - valid_list s \ valid_sched_action s \ + valid_list s \ valid_sched_action s \ sorted_ipc_queues s \ scheduler_act_not recvr s \ st_tcb_at active recvr s \ valid_ready_qs s \ ready_or_release s" in corres_guard_imp) @@ -7222,9 +7191,10 @@ lemma doReplyTransfer_corres: and valid_release_q and valid_ready_qs and scheduler_act_not recvr and active_scs_valid and current_time_bounded and active_if_bound_sc_tcb_at recvr and ready_or_release + and sorted_ipc_queues and not_queued recvr and not_in_release_q recvr" in hoare_strengthen_post[rotated]) - apply clarsimp + apply (clarsimp simp del: comp_apply) apply (frule invs_psp_aligned, frule invs_distinct) apply (clarsimp simp: obj_at_def is_tcb) apply (subgoal_tac "pred_map (\a. a = Some y) (tcb_scps_of s) recvr") @@ -7248,7 +7218,7 @@ lemma doReplyTransfer_corres: recvr \ idle_thread s \ fault_tcb_at ((=) None) recvr s \ valid_release_q s \ valid_ready_qs s \ ready_or_release s \ - active_scs_valid s \ + active_scs_valid s \ sorted_ipc_queues s \ heap_refs_inv (sc_tcbs_of s) (tcb_scps_of s) \ (pred_map_eq None (tcb_scps_of s) recvr \ active_sc_tcb_at recvr s) \ not_queued recvr s \ not_in_release_q recvr s" @@ -7257,7 +7227,7 @@ lemma doReplyTransfer_corres: apply (wpsimp wp: thread_set_no_change_tcb_state thread_set_cap_to thread_set_no_change_tcb_state thread_set_pred_tcb_at_sets_true simp: ran_tcb_cap_cases) - apply simp + apply (simp del: comp_apply) apply (wpsimp wp: hoare_drop_imp) apply wpsimp apply wpsimp diff --git a/proof/refine/RISCV64/KHeap_R.thy b/proof/refine/RISCV64/KHeap_R.thy index a5f1ba40cb..be98648313 100644 --- a/proof/refine/RISCV64/KHeap_R.thy +++ b/proof/refine/RISCV64/KHeap_R.thy @@ -1446,15 +1446,6 @@ lemmas obj_at_simps = obj_at_def obj_at'_def map_to_ctes_upd_other is_other_obj_relation_type_def a_type_def objBits_simps other_obj_relation_def pageBits_def -lemma setEndpoint_corres: - "ep_relation e e' \ - corres dc (ep_at ptr) (ep_at' ptr) - (set_endpoint ptr e) (setEndpoint ptr e')" - apply (simp add: set_simple_ko_def setEndpoint_def is_ep_def[symmetric]) - apply (corresK_search search: setObject_other_corres[where P="\_. True"]) - apply (corresKsimp wp: get_object_ret get_object_wp)+ - by (fastforce simp: is_ep obj_at_simps objBits_defs partial_inv_def) - lemma setNotification_corres: "ntfn_relation ae ae' \ corres dc (ntfn_at ptr) (ntfn_at' ptr) @@ -3740,6 +3731,18 @@ lemma ep_at_cross: apply (case_tac z; simp) by (fastforce dest!: aligned_distinct_ko_at'I[where 'a=endpoint] elim: obj_at'_weakenE) +lemma setEndpoint_corres: + "ep_relation e e' \ + corres dc + (ep_at ptr and pspace_aligned and pspace_distinct) \ + (set_endpoint ptr e) (setEndpoint ptr e')" + apply (rule_tac Q'="ep_at' ptr" in corres_cross_add_guard) + apply (fastforce dest!: state_relationD elim!: ep_at_cross) + apply (simp add: set_simple_ko_def setEndpoint_def is_ep_def[symmetric]) + apply (corresK_search search: setObject_other_corres[where P="\_. True"]) + apply (corresKsimp wp: get_object_ret get_object_wp)+ + by (fastforce simp: is_ep obj_at_simps objBits_defs partial_inv_def) + lemma ntfn_at_cross: assumes p: "pspace_relation (kheap s) (ksPSpace s')" assumes ps: "pspace_aligned s" "pspace_distinct s" diff --git a/proof/refine/RISCV64/Refine.thy b/proof/refine/RISCV64/Refine.thy index 2cc119e8d2..bb5cff9b31 100644 --- a/proof/refine/RISCV64/Refine.thy +++ b/proof/refine/RISCV64/Refine.thy @@ -409,7 +409,8 @@ lemma valid_sched_init[simp]: valid_ready_qs_def ready_or_release_2_def in_queues_2_def idle_sc_ptr_def valid_blocked_defs default_domain_def minBound_word released_ipc_queues_defs active_reply_scs_def active_if_reply_sc_at_def - active_sc_def MIN_REFILLS_def) + active_sc_def MIN_REFILLS_def + sorted_ipc_queues_def eps_of_kh_def opt_map_def) by (auto simp: vs_all_heap_simps active_scs_valid_def cfg_valid_refills_def rr_valid_refills_def MIN_REFILLS_def bounded_release_time_def default_sched_context_def MAX_PERIOD_def active_sc_def @@ -1107,7 +1108,7 @@ lemma do_user_op_corres: apply (rule corres_underlying_split[OF corres_machine_op,where Q = dc and Q'=dc]) apply (rule corres_underlying_trivial) apply (wp | simp add: dc_def device_memory_update_def)+ - apply (clarsimp simp: invs_def valid_state_def pspace_respects_device_region_def) + apply (fastforce simp: invs_def valid_state_def pspace_respects_device_region_def) apply fastforce done diff --git a/proof/refine/RISCV64/SchedContext_R.thy b/proof/refine/RISCV64/SchedContext_R.thy index a15b65e367..2ee6b09fb1 100644 --- a/proof/refine/RISCV64/SchedContext_R.thy +++ b/proof/refine/RISCV64/SchedContext_R.thy @@ -257,10 +257,8 @@ lemma schedContextUpdateConsumed_objs'[wp]: lemma schedContextUpdateConsumed_sym_refs_lis_refs_of_replies'[wp]: "schedContextUpdateConsumed scPtr \\s. sym_refs (list_refs_of_replies' s)\" - apply (clarsimp simp: schedContextUpdateConsumed_def) - apply wpsimp - apply (clarsimp simp: opt_map_def o_def) - done + unfolding schedContextUpdateConsumed_def + by wpsimp crunch schedContextUpdateConsumed for aligned'[wp]: "pspace_aligned'" diff --git a/proof/refine/RISCV64/Schedule_R.thy b/proof/refine/RISCV64/Schedule_R.thy index d118ee1a79..b009440d57 100644 --- a/proof/refine/RISCV64/Schedule_R.thy +++ b/proof/refine/RISCV64/Schedule_R.thy @@ -2383,9 +2383,7 @@ crunch scheduleUsed, refillPopHead, handleOverrunLoop, nonOverlappingMergeRefill lemma refillBudgetCheck_list_refs_of_replies'[wp]: "refillBudgetCheck usage \\s. sym_refs (list_refs_of_replies' s)\" unfolding refillBudgetCheck_def - apply (wpsimp wp: hoare_drop_imps) - apply (simp add: o_def) - done + by (wpsimp wp: hoare_drop_imps) lemma refillBudgetCheck_if_live_then_nonz_cap'[wp]: "refillBudgetCheck uage \if_live_then_nonz_cap'\" diff --git a/proof/refine/RISCV64/Syscall_R.thy b/proof/refine/RISCV64/Syscall_R.thy index 831eb78040..0ee8aeb789 100644 --- a/proof/refine/RISCV64/Syscall_R.thy +++ b/proof/refine/RISCV64/Syscall_R.thy @@ -220,7 +220,7 @@ lemma decodeInvocation_corres: \ \DomainCap\ apply (clarsimp simp: isCap_defs) apply (rule corres_guard_imp) - apply (rule decodeDomainInvocation_corres) + apply (rule decodeDomainInvocation_corres) apply (simp+)[4] \ \SchedContextCap\ apply (clarsimp simp: isCap_defs o_def) @@ -501,7 +501,7 @@ lemma performInvocation_corres: apply (rule corres_splitEE) apply (simp) apply (erule invokeSchedControlConfigureFlags_corres) - apply (rule corres_trivial, simp add: returnOk_def) + apply (rule corres_trivial, simp add: returnOk_def comp_apply) apply (wpsimp+)[4] \ \CNodes\ apply clarsimp @@ -1719,8 +1719,8 @@ lemma valid_sc_strengthen: lemma endTimeslice_corres: (* called when ct_schedulable *) "corres dc (invs and valid_list and valid_sched_action and active_scs_valid and valid_release_q - and valid_ready_qs and cur_sc_active and ct_active and current_time_bounded - and ct_not_queued and ct_not_in_release_q + and valid_ready_qs and sorted_ipc_queues and cur_sc_active and ct_active + and current_time_bounded and ct_not_queued and ct_not_in_release_q and cur_sc_tcb_are_bound and scheduler_act_sane and ready_or_release) invs' (end_timeslice canTimeout) (endTimeslice canTimeout)" @@ -1966,6 +1966,7 @@ lemma chargeBudget_corres: "corres dc (invs and valid_list and valid_sched_action and active_scs_valid and valid_release_q and valid_ready_qs and released_ipc_queues and cur_sc_active and ready_or_release + and sorted_ipc_queues and current_time_bounded and cur_sc_chargeable and scheduler_act_sane and ct_not_queued and ct_not_in_release_q and ct_not_blocked and cur_sc_offset_ready 0) @@ -2029,10 +2030,11 @@ lemma chargeBudget_corres: apply (rule hoare_strengthen_post [where Q'="\_. invs and active_scs_valid and valid_sched_action and in_correct_ready_q and ready_or_release - and ready_qs_distinct", rotated]) + and sorted_ipc_queues and ready_qs_distinct", rotated]) apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_objs_valid_tcbs valid_sched_action_def) - apply (wpsimp wp: end_timeslice_invs end_timeslice_valid_sched_action) + apply (wpsimp wp: end_timeslice_invs end_timeslice_valid_sched_action + end_timeslice_sorted_ipc_queues) apply (rule hoare_strengthen_post[where Q'="\_. invs'", rotated]) apply (clarsimp simp: invs'_def valid_pspace'_def) apply wpsimp @@ -2867,8 +2869,10 @@ proof - apply (erule cur_sc_offset_ready_weaken_zero) apply (rule conjI) apply (fastforce simp: ct_in_state_def pred_tcb_at_def obj_at_def cur_tcb_def is_tcb dest!: invs_cur) - apply (erule ct_not_blocked_cur_sc_not_blocked) - apply (rule ct_activatable_ct_not_blocked) + apply (rule conjI) + apply (erule ct_not_blocked_cur_sc_not_blocked) + apply (fastforce simp: ct_in_state_def pred_tcb_at_def obj_at_def) + apply fastforce apply (fastforce simp: ct_in_state_def pred_tcb_at_def obj_at_def dest!: active_activatable) apply clarsimp apply (wpsimp wp: update_time_stamp_current_time_bounded hoare_vcg_disj_lift diff --git a/proof/refine/RISCV64/Tcb_R.thy b/proof/refine/RISCV64/Tcb_R.thy index e22d145f03..acb1869da2 100644 --- a/proof/refine/RISCV64/Tcb_R.thy +++ b/proof/refine/RISCV64/Tcb_R.thy @@ -594,26 +594,11 @@ lemma tcbEPDequeueAppend_valid_ntfn'_rv: tcbEPAppend t qs' od \\rv s. valid_ntfn' (ntfnObj_update (\_. WaitingNtfn rv) ntfn) s\" - apply (simp only: tcbEPAppend_def tcbEPDequeue_def) - apply (wp tcbEPFindIndex_wp) - apply (rule conjI) - apply (clarsimp simp: valid_ntfn'_def split: option.split) - apply (clarsimp simp: valid_ntfn'_def simp del: imp_disjL dest!: findIndex_member) - apply (intro conjI; clarsimp?) - apply (fastforce dest: in_set_takeD in_set_dropD) - apply (fastforce dest: in_set_dropD) - apply (fastforce dest: in_set_dropD) - apply (fastforce dest: in_set_dropD) - apply (fastforce dest: in_set_takeD) - apply (clarsimp simp: Int_Un_distrib set_take_disj_set_drop_if_distinct) - apply (rule disjoint_subset_both[OF set_take_subset set_drop_subset]) - apply (simp add: Int_commute) - apply (fastforce dest: in_set_takeD) - apply (clarsimp simp: Int_Un_distrib set_take_disj_set_drop_if_distinct) - apply (fastforce dest: in_set_takeD in_set_dropD) - apply (clarsimp split: option.split) - apply (rename_tac ys zs i j tcb tcba tptr) - apply (case_tac ys; clarsimp) + apply (simp add: tcbEPAppend_def tcbEPDequeue_def bind_assoc) + apply (wpsimp wp: mapM_wp_lift threadGet_wp) + apply fastforce + apply (wpsimp wp: threadGet_wp)+ + apply (fastforce simp: valid_ntfn'_def split: option.split dest!: in_set_zip1) done lemma reorderNtfn_invs': @@ -639,8 +624,7 @@ lemma reorderNtfn_invs': done lemma set_ep_minor_invs': - "\invs' and obj_at' (\ep. ep_q_refs_of' ep = ep_q_refs_of' val) ptr - and valid_ep' val + "\invs' and valid_ep' val and (\s. live' (KOEndpoint val) \ ex_nonz_cap_to' ptr s)\ setEndpoint ptr val \\rv. invs'\" @@ -657,25 +641,34 @@ lemma updateEpQueue_triv: "ep \ IdleEP \ updateEpQueue ep lemma updateEPQueue_IdleEP[simp]: "(updateEpQueue ep qs = IdleEP) = (ep = IdleEP)" by (cases ep; simp add: updateEpQueue_def) +lemma tcbEPDequeueAppend_valid_ep'_rv: + "\valid_ep' ep and K (ep \ IdleEP \ epQueue ep = qs \ t \ set qs)\ + do qs' \ tcbEPDequeue t qs; + tcbEPAppend t qs' + od + \\rv s. valid_ep' (updateEpQueue ep rv) s\" + apply (simp add: tcbEPAppend_def tcbEPDequeue_def bind_assoc) + apply (wpsimp wp: mapM_wp_lift threadGet_wp) + apply fastforce + apply (wpsimp wp: threadGet_wp)+ + by (fastforce simp: valid_ep'_def updateEpQueue_def split: endpoint.splits dest!: in_set_zip1) + lemma reorderEp_invs': "\invs' and st_tcb_at' (\st. epBlocked st = Some ntfnPtr) tptr\ reorderEp ntfnPtr tptr \\rv. invs'\" apply (simp only: reorderEp_def) apply (subst bind_assoc[symmetric, where m="tcbEPDequeue tptr _"]) - apply (wp set_ep_minor_invs') + apply (rule bind_wp | simp only: K_bind_def)+ + apply (wp set_ep_minor_invs') apply (simp add: pred_conj_def live_ntfn'_def) - apply (wpsimp wp: getEndpoint_wp tcbEPAppend_valid_ep' tcbEPAppend_rv_wf' tcbEPAppend_rv_wf'' - tcbEPDequeue_valid_ep' tcbEPDequeue_rv_wf' tcbEPDequeue_rv_wf'')+ + apply (wpsimp wp: getEndpoint_wp tcbEPDequeueAppend_valid_ep'_rv hoare_vcg_conj_lift)+ apply (frule ep_ko_at_valid_objs_valid_ep', fastforce) - apply (clarsimp simp: updateEpQueue_triv sym_refs_asrt_def valid_ep'_def pred_tcb_at'_def - obj_at'_def projectKO_eq projectKO_tcb projectKO_ep) + apply (clarsimp simp: sym_refs_asrt_def pred_tcb_at'_def obj_at'_def) apply (frule_tac ko=obj and p=tptr in sym_refs_ko_atD'[rotated]) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb) - apply (case_tac "tcbState obj"; clarsimp simp: epBlocked_def split: ntfn.splits if_splits) - apply (auto simp: invs'_def if_live_then_nonz_cap'_def - refs_of_rev' get_refs_def ko_wp_at'_def obj_at'_def projectKO_eq projectKO_tcb - split: option.splits) + apply (clarsimp simp: obj_at'_def) + apply (case_tac "tcbState obj"; clarsimp simp: epBlocked_def split: if_splits) + apply (auto simp: invs'_def if_live_then_nonz_cap'_def refs_of_rev' ko_wp_at'_def) done lemma threadSetPriority_valid_objs'[wp]: @@ -721,6 +714,9 @@ crunch threadSetPriority and valid_machine_state'[wp]: valid_machine_state' (wp: threadSet_sched_pointers) +global_interpretation threadSetPriority: typ_at_all_props' "threadSetPriority tptr prio" + by typ_at_props' + crunch threadSetPriority for st_tcb_at'[wp]: "\s. st_tcb_at' Q tcbPtr s" (wp: threadSet_st_tcb_at2 ignore: threadSet) @@ -784,17 +780,24 @@ lemma setP_invs': apply (fastforce simp: ready_qs_runnable_def pred_tcb_at'_def obj_at'_def) done -lemma reorder_ntfn_corres: - "ntfn = ntfn' \ corres dc (invs and st_tcb_at (\st. ntfn_blocked st = Some ntfn) t) - (invs' and st_tcb_at' (\st. ntfnBlocked st = Some ntfn) t) - (reorder_ntfn ntfn t) (reorderNtfn ntfn' t)" +lemma tcb_ep_dequeue_distinct: + "\\_. distinct q\ tcb_ep_dequeue t q \\q' _. distinct q'\" + by (wpsimp simp: tcb_ep_dequeue_def) + +lemma reorderNtfn_corres: + "ntfn_ptr = ntfnPtr \ + corres dc + (\s. invs s \ st_tcb_at (\st. ntfn_blocked st = Some ntfn_ptr) t s + \ none_top (\q. priority_ordered (filter ((\) t) q) (prios_of s)) (ntfn_queues_of s ntfn_ptr)) + (invs' and st_tcb_at' (\st. ntfnBlocked st = Some ntfn_ptr) t) + (reorder_ntfn ntfn_ptr t) (reorderNtfn ntfnPtr t)" apply add_sym_refs apply (clarsimp simp: reorder_ntfn_def reorderNtfn_def) apply (rule corres_stateAssert_assume) apply (rule corres_guard_imp) apply (rule corres_split) apply (rule getNotification_corres) - apply (rule corres_assert_opt_assume_l) + apply (rule corres_assert_opt_l) apply (rule corres_assert_assume_r) apply (rule corres_split) apply (rule tcbEPDequeue_corres) @@ -807,8 +810,8 @@ lemma reorder_ntfn_corres: apply (clarsimp simp: ntfn_relation_def) apply wp apply wp - apply (rule tcb_ep_dequeue_rv_wf') - apply (rule tcbEPDequeue_rv_wf') + apply (wpsimp wp: tcb_ep_dequeue_distinct) + apply wp apply (wp get_simple_ko_wp) apply (wp getNotification_wp) apply (clarsimp simp: pred_tcb_at_def obj_at_def ntfn_blocked_def) @@ -817,13 +820,22 @@ lemma reorder_ntfn_corres: apply (erule (1) valid_objsE[where x=t]) apply (clarsimp simp: valid_obj_def valid_tcb_def valid_tcb_state_def obj_at_def) apply (frule invs_valid_objs) - apply (erule (1) valid_objsE[where x=ntfn']) + apply (erule (1) valid_objsE[where x=ntfnPtr]) apply (clarsimp simp: valid_obj_def valid_ntfn_def) apply (frule invs_sym_refs) apply (drule_tac p=t in sym_refs_ko_atD[rotated]) apply (simp add: obj_at_def) apply clarsimp - apply (fastforce simp: refs_of_rev obj_at_def get_ntfn_queue_def is_tcb_def is_ntfn_def) + apply (rename_tac ntfn) + apply (case_tac "ntfn_obj ntfn"; clarsimp) + apply (fastforce simp: refs_of_rev obj_at_def) + apply (rename_tac q) + apply (clarsimp simp: get_ntfn_queue_def invs_psp_aligned invs_distinct) + apply (intro conjI impI) + apply (fastforce simp: refs_of_rev obj_at_def) + apply (fastforce simp: refs_of_rev obj_at_def) + apply (clarsimp simp: opt_map_def) + apply (fastforce simp: refs_of_rev obj_at_def) apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKO_eq projectKO_tcb ntfnBlocked_def) apply (clarsimp split: thread_state.splits) apply (frule invs_valid_objs') @@ -831,7 +843,7 @@ lemma reorder_ntfn_corres: apply (clarsimp simp: valid_obj'_def valid_tcb'_def valid_tcb_state'_def obj_at'_def projectKO_eq projectKO_ntfn) apply (frule invs_valid_objs') - apply (erule (1) valid_objsE'[where x=ntfn']) + apply (erule (1) valid_objsE'[where x=ntfnPtr]) apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) apply (drule_tac p=t and ko=obj in sym_refs_ko_atD'[rotated]) apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb) @@ -841,69 +853,58 @@ lemma reorder_ntfn_corres: apply (clarsimp simp: sym_refs_asrt_def) done -lemma reorder_ep_corres: - "a = a' \ corres dc (invs and st_tcb_at (\st. ep_blocked st = Some a) t) - (invs' and st_tcb_at' (\st. epBlocked st = Some a) t) - (reorder_ep a t) (reorderEp a' t)" +lemma reorderEp_corres: + "ep_ptr = epPtr \ + corres dc + (\s. invs s \ st_tcb_at (\st. ep_blocked st = Some ep_ptr) t s \ ep_at ep_ptr s + \ none_top (\q. priority_ordered (filter ((\) t) q) (prios_of s)) (ep_queues_of s ep_ptr)) + invs' + (reorder_ep ep_ptr t) (reorderEp epPtr t)" apply add_sym_refs + apply (rule_tac Q'="ep_at' epPtr" in corres_cross_add_guard) + apply (fastforce intro!: ep_at_cross simp: vs_all_heap_simps obj_at_def is_tcb_def) apply (clarsimp simp: reorder_ep_def reorderEp_def) - apply (rule corres_stateAssert_assume) - apply (rule corres_guard_imp) - apply (rule corres_split) - apply (rule getEndpoint_corres) - apply (rename_tac ep ep') - apply (rule_tac F="ep \ Structures_A.endpoint.IdleEP" in corres_gen_asm) - apply (rule_tac r'="(=)" in corres_split) - apply (rule corres_trivial) - apply (case_tac ep; clarsimp simp: get_ep_queue_def getEpQueue_def ep_relation_def) - apply clarsimp - apply (rule corres_split) - apply (rule tcbEPDequeue_corres) - apply clarsimp - apply (rule corres_split) - apply clarsimp - apply (rule tcbEPAppend_corres) - apply (rule setEndpoint_corres) - apply (case_tac ep; clarsimp simp: ep_relation_def updateEpQueue_def) - apply wp - apply wp - apply (rule tcb_ep_dequeue_rv_wf') - apply (rule tcbEPDequeue_rv_wf') + apply (rule corres_stateAssert_assume[rotated]) + apply (simp add: sym_refs_asrt_def) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule getEndpoint_corres) + apply (rename_tac ep ep') + apply (rule_tac F="ep \ Structures_A.endpoint.IdleEP" in corres_gen_asm) + apply (rule_tac r'="(=)" in corres_split) + apply (rule corres_trivial) + apply (case_tac ep; clarsimp simp: get_ep_queue_def getEpQueue_def ep_relation_def) apply clarsimp - apply (wpsimp simp: get_ep_queue_def) - apply (wpsimp simp: getEpQueue_def) - apply (wp get_simple_ko_wp) - apply (wp getEndpoint_wp) - apply (clarsimp simp: pred_tcb_at_def obj_at_def ep_blocked_def) - apply (frule invs_valid_objs) - apply (erule (1) valid_objsE[where x=t]) - apply (clarsimp simp: valid_obj_def valid_tcb_def ) - apply (prop_tac "ep_at a' s") - apply (clarsimp simp: valid_tcb_state_def split: Structures_A.thread_state.splits) - apply (clarsimp simp: obj_at_def) - apply (frule invs_valid_objs) - apply (erule (1) valid_objsE[where x=a']) - apply (clarsimp simp: valid_obj_def valid_ep_def) - apply (frule invs_sym_refs) - apply (drule_tac p=t in sym_refs_ko_atD[rotated]) - apply (simp add: obj_at_def) - apply (fastforce simp: obj_at_def is_tcb_def split: if_splits Structures_A.thread_state.splits) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKO_eq projectKO_tcb epBlocked_def) - apply (frule invs_valid_objs') - apply (erule (1) valid_objsE'[where x=t]) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def) - apply (prop_tac "ep_at' a' s") - apply (clarsimp simp: valid_tcb_state'_def obj_at'_def projectKO_eq projectKO_ep - split: thread_state.splits) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_ep) - apply (frule invs_valid_objs') - apply (erule (1) valid_objsE'[where x=a']) - apply (clarsimp simp: valid_obj'_def valid_ep'_def) - apply (drule_tac p=t and ko=obj in sym_refs_ko_atD'[rotated]) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb) - apply (fastforce simp: refs_of_rev' ko_wp_at'_def obj_at'_def projectKO_eq projectKO_tcb - split: thread_state.splits if_splits endpoint.splits) - apply (clarsimp simp: sym_refs_asrt_def) + apply (rule corres_split) + apply (rule tcbEPDequeue_corres) + apply clarsimp + apply (rule corres_split) + apply clarsimp + apply (rule tcbEPAppend_corres) + apply (rule setEndpoint_corres) + apply (case_tac ep; clarsimp simp: ep_relation_def updateEpQueue_def) + apply wp + apply wp + apply (wpsimp wp: tcb_ep_dequeue_distinct) + apply wp + apply (wpsimp simp: get_ep_queue_def) + apply (wpsimp simp: getEpQueue_def) + apply (wp get_simple_ko_wp) + apply (wp getEndpoint_wp) + apply (clarsimp simp: pred_tcb_at_def obj_at_def ep_blocked_def) + apply (frule invs_valid_objs) + apply (erule (1) valid_objsE[where x=t]) + apply (clarsimp simp: valid_obj_def valid_tcb_def) + apply (frule invs_valid_objs) + apply (erule (1) valid_objsE[where x=epPtr]) + apply (clarsimp simp: valid_obj_def valid_ep_def) + apply (frule invs_sym_refs) + apply (drule_tac p=t in sym_refs_ko_atD[rotated]) + apply (simp add: obj_at_def) + subgoal + by (fastforce simp: obj_at_def is_tcb_def opt_map_def comp_apply eps_of_kh_def + split: if_splits Structures_A.thread_state.splits endpoint.splits) + apply clarsimp done lemma threadSetPriority_valid_tcbs'[wp]: @@ -1037,46 +1038,69 @@ lemma setPriority: (einvs and tcb_at t and ct_not_in_release_q) (invs' and (\_. prio \ maxPriority)) (set_priority t prio) (setPriority t prio)" + supply if_split[split del] apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) apply (fastforce intro: tcb_at_cross) apply (simp add: setPriority_def set_priority_def runnable'_case_thread_state_If) + apply (rule corres_split_forwards'[OF _ gts_sp gts_sp']) + apply (corres corres: getThreadState_corres) + apply fastforce + apply fastforce + apply (rename_tac ts ts') + apply (rule_tac F="ep_blocked ts = epBlocked ts' \ ntfn_blocked ts = ntfnBlocked ts'" + in corres_req) + apply (case_tac ts; simp add: ep_blocked_def epBlocked_def ntfn_blocked_def ntfnBlocked_def) apply (rule stronger_corres_guard_imp) - apply (rule_tac r'=thread_state_relation in corres_split) - apply (rule getThreadState_corres) - apply (rule corres_if) - apply (case_tac rv; simp add: thread_state_relation_def) - apply (rule threadSetPriority_onRunning_corres) - apply (rule_tac r'=dc in corres_split) - apply (clarsimp simp: thread_set_priority_def threadSetPriority_def) - apply (rule threadSet_not_queued_corres; - simp add: tcb_relation_def tcb_cap_cases_def tcb_cte_cases_def cteSizeBits_def) - apply (rule_tac r'=dc in corres_split) - apply (clarsimp simp: maybeM_def case_option_If2 split del: if_split) - apply (rule corres_if) - apply (case_tac rv; simp add: ep_blocked_def epBlocked_def) - apply (rule reorder_ep_corres) - apply (case_tac rv; simp add: ep_blocked_def epBlocked_def) - apply clarsimp - apply (clarsimp simp: maybeM_def case_option_If2 split del: if_split) - apply (rule corres_if) - apply (case_tac rv; simp add: ntfn_blocked_def ntfnBlocked_def) - apply (rule reorder_ntfn_corres) - apply (case_tac rv; simp add: ntfn_blocked_def ntfnBlocked_def) - apply (rule corres_trivial, clarsimp) - apply (wpsimp wp: hoare_vcg_const_imp_lift simp: if_fun_split) - apply (wpsimp wp: hoare_vcg_const_imp_lift reorderEp_invs' simp: if_fun_split) - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_all_lift simp: if_fun_split) - apply (subgoal_tac "ep_blocked rv = epBlocked rv' \ ntfn_blocked rv = ntfnBlocked rv'") - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_all_lift - threadSet_valid_objs_tcbPriority_update threadSetPriority_invs' - simp: if_fun_split) - apply (case_tac rv; simp add: ep_blocked_def epBlocked_def ntfn_blocked_def ntfnBlocked_def) - apply (wp gts_wp) - apply (wp gts_wp') - apply (fastforce dest: valid_sched_valid_ready_qs valid_ready_qs_not_queued_not_runnable - simp: pred_tcb_at_def obj_at_def in_ready_q_def) - apply (drule ready_qs_runnable_cross; clarsimp simp: ready_qs_runnable_def) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def) + apply (rule corres_if) + apply (case_tac ts; simp add: thread_state_relation_def) + apply (rule threadSetPriority_onRunning_corres) + apply (rule_tac r'=dc in corres_split) + apply (clarsimp simp: thread_set_priority_def threadSetPriority_def) + apply (rule threadSet_not_queued_corres; + simp add: tcb_relation_def tcb_cap_cases_def tcb_cte_cases_def cteSizeBits_def) + apply clarsimp + apply (rule_tac R="epBlocked ts' = None \ ep_blocked ts = None" in corres_cases'; clarsimp) + apply (clarsimp simp: maybeM_def case_option_If2) + apply (rule corres_if_strong[where R=\ and R'=\]) + apply fastforce + apply (corres corres: reorderNtfn_corres[unfolded dc_def]) + apply (rule corres_return_trivial[unfolded dc_def]) + apply (clarsimp simp: maybeM_def case_option_If2) + apply (rule_tac F="ntfn_blocked ts = None \ ntfnBlocked ts' = None" in corres_gen_asm) + apply (frule_tac Some_to_the) + apply clarsimp + apply (rule reorderEp_corres[unfolded dc_def]) + apply fastforce + apply (wpsimp wp: thread_set_priority_invs hoare_vcg_if_lift2 hoare_vcg_imp_lift' + thread_set_priority_priority_ordered hoare_vcg_all_lift + simp: none_top_def + split: option.splits) + apply (wpsimp wp: threadSetPriority_invs' hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (clarsimp split: if_splits) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_sorted_ipc_queues) + apply (frule invs_valid_objs) + apply (frule tcb_at_ko_at) + apply clarsimp + apply (frule (1) valid_objs_ko_at) + apply safe[1] + apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply (fastforce dest!: valid_ready_qs_not_queued_not_runnable + simp: pred_tcb_at_def obj_at_def comp_apply in_ready_q_def) + apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply (clarsimp simp: sorted_ipc_queues_def none_top_def split: option.splits) + apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply (clarsimp simp: ep_blocked_def valid_obj_def valid_tcb_def valid_tcb_state_def + pred_tcb_at_def obj_at_def + split: Structures_A.thread_state.splits) + apply (clarsimp simp: ep_blocked_def ntfn_blocked_def split: Structures_A.thread_state.splits) + apply (clarsimp simp: sorted_ipc_queues_def) + apply (drule_tac x=y in spec) + apply fastforce + apply (clarsimp simp: ep_blocked_def ntfn_blocked_def split: Structures_A.thread_state.splits) + apply (fastforce dest: ready_qs_runnable_cross + simp: ready_qs_runnable_def pred_tcb_at'_def obj_at'_def comp_apply + split: if_splits) done lemma setMCPriority_corres: @@ -1667,7 +1691,7 @@ lemma installThreadBuffer_corres: apply (rule corres_gen_asm2) apply (rule corres_guard_imp[where P=P and P'=P' and Q="P and cte_at (a, tcb_cnode_index 2)" and Q'="P' and cte_at' (cte_map (a, cap))" for P P' a cap]) - apply (cases g, simp add: returnOk_def) + apply (cases g, simp add: returnOk_def comp_apply) apply (clarsimp simp: installThreadBuffer_corres_helper bind_liftE_distrib liftE_bindE) apply (rule corres_guard_imp) apply (rule corres_split_norE) diff --git a/proof/refine/RISCV64/Untyped_R.thy b/proof/refine/RISCV64/Untyped_R.thy index 322c16af35..6bad3f59e8 100644 --- a/proof/refine/RISCV64/Untyped_R.thy +++ b/proof/refine/RISCV64/Untyped_R.thy @@ -5223,7 +5223,6 @@ lemma insertNewCap_list_refs_of_replies'[wp]: apply (rule bind_wp_fwd_skip, wpsimp) apply (rule bind_wp_fwd_skip, wpsimp) apply (wpsimp wp: getCTE_wp) - apply (clarsimp simp: opt_map_def list_refs_of_reply'_def o_def split: option.splits) done lemma insertNewCap_ifunsafe'[wp]: diff --git a/spec/abstract/IpcCancel_A.thy b/spec/abstract/IpcCancel_A.thy index b1ca28430e..fdfd9f2699 100644 --- a/spec/abstract/IpcCancel_A.thy +++ b/spec/abstract/IpcCancel_A.thy @@ -300,37 +300,20 @@ where BlockedOnNotification r \ Some r | _ \ None" -fun - tcb_ep_find_index :: "obj_ref \ obj_ref list \ nat \ (nat, 'z::state_ext) s_monad" -where - "tcb_ep_find_index tptr qs curindex = do - prio \ thread_get tcb_priority tptr; - curprio \ thread_get tcb_priority (qs ! curindex); - if prio > curprio then - if curindex = 0 then return 0 - else tcb_ep_find_index tptr qs (curindex - 1) - else return (curindex + 1) - od" +definition tcb_ep_dequeue :: "obj_ref \ obj_ref list \ (obj_ref list, 'z::state_ext) s_monad" where + "tcb_ep_dequeue tptr qs \ return $ filter ((\) tptr) qs" -declare tcb_ep_find_index.simps[simp del] - -definition - tcb_ep_dequeue :: "obj_ref \ obj_ref list \ (obj_ref list, 'z::state_ext) s_monad" -where - "tcb_ep_dequeue tptr qs = do - index \ return $ the $ findIndex (\x. x = tptr) qs; - return $ take index qs @ drop (index + 1) qs +definition tcb_ep_append :: "obj_ref \ obj_ref list \ (obj_ref list, 'z::state_ext) s_monad" where + "tcb_ep_append tptr qs \ do + prio \ thread_get tcb_priority tptr; + prios \ mapM (thread_get tcb_priority) qs; + zprios \ return $ zip qs prios; + zprios' \ return $ filter (\(_, p). p \ prio) zprios + @ [(tptr, prio)] + @ filter (\(_, p). p < prio) zprios; + return (map fst zprios') od" -definition - tcb_ep_append :: "obj_ref \ obj_ref list \ (obj_ref list, 'z::state_ext) s_monad" -where - "tcb_ep_append tptr qs \ - if qs = [] then return [tptr] - else do index \ tcb_ep_find_index tptr qs (length qs - 1); - return $ take index qs @ tptr # drop index qs - od" - text \Bring endpoint queue back into priority order\ definition reorder_ep :: "obj_ref \ obj_ref \ (unit, 'z::state_ext) s_monad" diff --git a/spec/design/skel/KernelStateData_H.thy b/spec/design/skel/KernelStateData_H.thy index 7a7b8f656d..1ba50070e8 100644 --- a/spec/design/skel/KernelStateData_H.thy +++ b/spec/design/skel/KernelStateData_H.thy @@ -93,7 +93,7 @@ where return r od" -#INCLUDE_HASKELL SEL4/Model/StateData.lhs decls_only ONLY capHasProperty sym_refs_asrt valid_replies'_sc_asrt ready_qs_runnable tcs_cross_asrt1 tcs_cross_asrt2 ct_not_inQ_asrt sch_act_wf_asrt valid_idle'_asrt cur_tcb'_asrt sch_act_sane_asrt ct_not_ksQ_asrt ct_active'_asrt rct_imp_activatable'_asrt ct_activatable'_asrt ready_or_release'_asrt findTimeAfter_asrt not_tcbInReleaseQueue_asrt tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt tcbQueueHead_ksReleaseQueue_active_sc_tcb_at'_asrt not_tcbQueued_asrt ksReadyQueues_asrt ksReleaseQueue_asrt idleThreadNotQueued sc_at'_asrt valid_tcbs'_asrt -#INCLUDE_HASKELL SEL4/Model/StateData.lhs NOT doMachineOp KernelState ReadyQueue ReleaseQueue ReaderM Kernel KernelR getsJust assert stateAssert funOfM condition whileLoop findM funArray newKernelState capHasProperty ifM whenM whileM andM orM sym_refs_asrt valid_replies'_sc_asrt ready_qs_runnable tcs_cross_asrt1 tcs_cross_asrt2 ct_not_inQ_asrt sch_act_wf_asrt valid_idle'_asrt cur_tcb'_asrt sch_act_sane_asrt ct_not_ksQ_asrt ct_active'_asrt rct_imp_activatable'_asrt ct_activatable'_asrt ready_or_release'_asrt findTimeAfter_asrt not_tcbInReleaseQueue_asrt tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt tcbQueueHead_ksReleaseQueue_active_sc_tcb_at'_asrt not_tcbQueued_asrt ksReadyQueues_asrt ksReleaseQueue_asrt idleThreadNotQueued sc_at'_asrt valid_tcbs'_asrt +#INCLUDE_HASKELL SEL4/Model/StateData.lhs decls_only ONLY capHasProperty sym_refs_asrt valid_replies'_sc_asrt ready_qs_runnable tcs_cross_asrt1 tcs_cross_asrt2 ct_not_inQ_asrt sch_act_wf_asrt valid_idle'_asrt cur_tcb'_asrt sch_act_sane_asrt ct_not_ksQ_asrt ct_active'_asrt rct_imp_activatable'_asrt ct_activatable'_asrt ready_or_release'_asrt findTimeAfter_asrt not_tcbInReleaseQueue_asrt tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt tcbQueueHead_ksReleaseQueue_active_sc_tcb_at'_asrt not_tcbQueued_asrt ksReadyQueues_asrt ksReleaseQueue_asrt idleThreadNotQueued sc_at'_asrt valid_tcbs'_asrt priority_ordered'_asrt +#INCLUDE_HASKELL SEL4/Model/StateData.lhs NOT doMachineOp KernelState ReadyQueue ReleaseQueue ReaderM Kernel KernelR getsJust assert stateAssert funOfM condition whileLoop findM funArray newKernelState capHasProperty ifM whenM whileM andM orM sym_refs_asrt valid_replies'_sc_asrt ready_qs_runnable tcs_cross_asrt1 tcs_cross_asrt2 ct_not_inQ_asrt sch_act_wf_asrt valid_idle'_asrt cur_tcb'_asrt sch_act_sane_asrt ct_not_ksQ_asrt ct_active'_asrt rct_imp_activatable'_asrt ct_activatable'_asrt ready_or_release'_asrt findTimeAfter_asrt not_tcbInReleaseQueue_asrt tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt tcbQueueHead_ksReleaseQueue_active_sc_tcb_at'_asrt not_tcbQueued_asrt ksReadyQueues_asrt ksReleaseQueue_asrt idleThreadNotQueued sc_at'_asrt valid_tcbs'_asrt priority_ordered'_asrt end diff --git a/spec/haskell/src/SEL4/Model/StateData.lhs b/spec/haskell/src/SEL4/Model/StateData.lhs index adc2e392c5..6485164a4d 100644 --- a/spec/haskell/src/SEL4/Model/StateData.lhs +++ b/spec/haskell/src/SEL4/Model/StateData.lhs @@ -532,3 +532,8 @@ An assert that will say that valid_tcbs' holds > valid_tcbs'_asrt :: KernelState -> Bool > valid_tcbs'_asrt _ = True + +An assert that will say that priority_ordered' holds of the given list + +> priority_ordered'_asrt :: [PPtr TCB] -> KernelState -> Bool +> priority_ordered'_asrt _ _ = True diff --git a/spec/haskell/src/SEL4/Object/Endpoint.lhs b/spec/haskell/src/SEL4/Object/Endpoint.lhs index 2c9d0d9ef0..4e9c293002 100644 --- a/spec/haskell/src/SEL4/Object/Endpoint.lhs +++ b/spec/haskell/src/SEL4/Object/Endpoint.lhs @@ -34,6 +34,7 @@ This module specifies the contents and behaviour of a synchronous IPC endpoint. > import Data.List > import Data.Maybe +> import Data.Helpers (mapMaybe, distinct) \end{impdetails} @@ -257,6 +258,7 @@ If a thread is blocking on an endpoint, then the endpoint is fetched and the thr > ep <- getEndpoint epptr > assert (not $ isIdle ep) > "blockedCancelIPC: endpoint must not be idle" +> assert (distinct (epQueue ep)) "the endpoint queue of ep must be a list of distinct pointers" > let queue' = delete tptr $ epQueue ep > ep' <- return $ case queue' of > [] -> IdleEP @@ -309,6 +311,7 @@ If an endpoint is deleted, then every pending IPC operation using it must be can > IdleEP -> > return () > _ -> do +> assert (distinct (epQueue ep)) "the endpoint queue of ep must be a list of distinct pointers" > setEndpoint epptr IdleEP > forM_ (epQueue ep) (\t -> cancelAllIPC_loop_body t) > rescheduleRequired @@ -327,6 +330,7 @@ If a badged endpoint is recycled, then cancel every pending send operation using > IdleEP -> return () > RecvEP {} -> return () > SendEP queue -> do +> assert (distinct queue) "queue must be a list of distinct pointers" > setEndpoint epptr IdleEP > queue' <- (flip filterM queue) $ \t -> do > st <- getThreadState t diff --git a/spec/haskell/src/SEL4/Object/Notification.lhs b/spec/haskell/src/SEL4/Object/Notification.lhs index 524d14bf4c..761dd22679 100644 --- a/spec/haskell/src/SEL4/Object/Notification.lhs +++ b/spec/haskell/src/SEL4/Object/Notification.lhs @@ -33,6 +33,7 @@ This module specifies the behavior of notification objects. > import Data.Bits > import Data.List > import Data.Maybe(fromJust) +> import Data.Helpers (mapMaybe, distinct) \end{impdetails} @@ -135,6 +136,7 @@ If the notification object is already waiting, the current thread is blocked and > WaitingNtfn queue -> case isBlocking of > True -> do +> assert (distinct queue) "queue must be a list of distinct pointers" > setThreadState (BlockedOnNotification { > waitingOnNotification = ntfnPtr } ) thread > qs' <- tcbEPAppend thread queue @@ -165,6 +167,7 @@ If a notification object is deleted, then pending receive operations must be can > ntfn <- getNotification ntfnPtr > case ntfnObj ntfn of > WaitingNtfn queue -> do +> assert (distinct queue) "queue must be a list of distinct pointers" > setNotification ntfnPtr (ntfn { ntfnObj = IdleNtfn }) > forM_ queue (\t -> do > setThreadState Restart t @@ -185,6 +188,7 @@ The following function will remove the given thread from the queue of the notifi > ntfn <- getNotification ntfnPtr > assert (isWaiting (ntfnObj ntfn)) > "cancelSignal: notification object must be waiting" +> assert (distinct (ntfnQueue (ntfnObj ntfn))) "the notification queue must be a list of distinct pointers" > let queue' = delete threadPtr $ ntfnQueue $ ntfnObj ntfn > ntfn' <- case queue' of > [] -> return $ IdleNtfn diff --git a/spec/haskell/src/SEL4/Object/TCB.lhs b/spec/haskell/src/SEL4/Object/TCB.lhs index 8a357d8385..1c8ec189f9 100644 --- a/spec/haskell/src/SEL4/Object/TCB.lhs +++ b/spec/haskell/src/SEL4/Object/TCB.lhs @@ -1113,26 +1113,14 @@ On some architectures, the thread context may include registers that may be modi > "every thread in the release queue is associated with an active scheduling context" > whileLoop (const (fromJust . runReaderT releaseQNonEmptyAndReady)) (const tcbReleaseDequeue) () -> tcbEPFindIndex :: PPtr TCB -> [PPtr TCB] -> Int -> Kernel Int -> tcbEPFindIndex tptr queue curIndex = do -> prio <- threadGet tcbPriority tptr -> curPrio <- threadGet tcbPriority (queue !! curIndex) -> if prio > curPrio -> then -> if curIndex == 0 -> then return 0 -> else tcbEPFindIndex tptr queue (curIndex - 1) -> else return (curIndex + 1) - > tcbEPAppend :: PPtr TCB -> [PPtr TCB] -> Kernel [PPtr TCB] -> tcbEPAppend tptr queue = -> if null queue -> then return [tptr] -> else do -> index <- tcbEPFindIndex tptr queue (length queue - 1) -> return $ take index queue ++ [tptr] ++ drop index queue +> tcbEPAppend tptr queue = do +> stateAssert (priority_ordered'_asrt queue) "queue must be ordered by priority" +> prio <- threadGet tcbPriority tptr +> prios <- mapM (threadGet tcbPriority) queue +> zprios <- return $ zip queue prios +> zprios' <- return $ filter (\(t, p) -> p >= prio) zprios ++ [(tptr, prio)] ++ filter (\(t, p) -> p < prio) zprios +> return (map fst zprios') > tcbEPDequeue :: PPtr TCB -> [PPtr TCB] -> Kernel [PPtr TCB] -> tcbEPDequeue tptr queue = do -> index <- return $ fromJust $ findIndex (\x -> x == tptr) queue -> return $ take index queue ++ drop (index + 1) queue +> tcbEPDequeue tptr queue = return $ filter (\t -> t /= tptr) queue