diff --git a/lib/RCorres.thy b/lib/RCorres.thy index 22663fd86f..21ba080dd7 100644 --- a/lib/RCorres.thy +++ b/lib/RCorres.thy @@ -34,8 +34,8 @@ text \ goal when the postcondition of the rcorres goal mentions only the return value and state from one of the two monads. These lifting rules often require @{const no_fail} assumptions, and so when lifting an rcorres goal with a concrete function that is a @{const Nondet_Monad.bind} of other - functions, we will immediately be required to show @{const no_fail} for the composite function - anyway. Therefore, we have chosen to keep failure separate. The section below regarding + functions, we will immediately be required to show @{const no_fail} for the composite concrete + function anyway. Therefore, we have chosen to keep failure separate. The section below regarding interactions with @{const no_fail} includes a rule that allows us to show @{const no_fail} for composite functions by transforming complex predicates with rcorres. The section below regarding @{const corres_underlying} shows the relation between rcorres and @{const corres_underlying}.\ @@ -305,11 +305,13 @@ lemmas rcorres_if_r_fwd = rcorres_if_r[where T=R and F=R for R, simplified] section \Lifting rules\ +named_theorems rcorres_op_lifts + text \ We would like a lifting rule for conjunctions, and so a rule with assumptions including @{const rcorres} statements for the postconditions @{term R'} and @{term Q'} separately, with - conclusion an @{term rcorres} statement for the conjunction @{term "R' \ Q'"}, roughly speaking. - The inclusion of the @{term det_wp} assumption in the following rule warrants some explanation. + conclusion an @{const rcorres} statement for the conjunction @{term "R' \ Q'"}, roughly speaking. + The inclusion of the @{const det_wp} assumption in the following rule warrants some explanation. Noting the definition of @{const rcorres}, suppose that we have two states @{term s} and @{term s'} which satisfy the precondition of the conclusion, as well as a pair @{term "(rv', t')"} in the @@ -327,10 +329,10 @@ text \ It does not seem possible for us to state an adequate lifting rule for conjunction for @{const rcorres} with a nondeterministic abstract monadic function, and so in such a situation, it may be necessary to unfold the definition of @{const rcorres}.\ -lemma rcorres_conj_lift: - "\det_wp P f; rcorres Q f f' R'; rcorres R f f' Q'\ +lemma rcorres_conj_lift[rcorres_op_lifts]: + "\det_wp P f; rcorres R f f' R'; rcorres Q f f' Q'\ \ rcorres - (\s s'. P s \ Q s s' \ R s s') + (\s s'. P s \ R s s' \ Q s s') f f' (\rv rv' s s'. R' rv rv' s s' \ Q' rv rv' s s')" by (fastforce simp: rcorres_def det_wp_def) @@ -341,7 +343,7 @@ lemma rcorres_conj_lift_fwd: apply (fastforce intro!: rcorres_weaken_pre[OF rcorres_conj_lift]) done -lemma rcorres_imp_lift: +lemma rcorres_imp_lift[rcorres_op_lifts]: "\rcorres P' f f' (\rv rv' s s'. \ P rv rv' s s'); rcorres Q' f f' Q\ \ rcorres (\s s'. \ P' s s' \ Q' s s') @@ -354,10 +356,14 @@ lemma rcorres_imp_lift_fwd: \ rcorres R f f' (\rv rv' s s'. A s s' \ R' rv rv' s s')" by (rule rcorres_weaken_pre, rule rcorres_imp_lift, fastforce+) +lemma rcorres_drop_imp: + "rcorres P f f' Q \ rcorres P f f' (\rv rv' s s'. Q' rv rv' s s' \ Q rv rv' s s')" + by (fastforce simp: rcorres_def) + text \As with @{thm rcorres_conj_lift}, the @{const det_wp} assumption seems necessary in order to state an adequate lifting rule for @{const All}.\ -lemma rcorres_allI: +lemma rcorres_allI[rcorres_op_lifts]: "\det_wp P f; \x. rcorres (\s s'. R x s s') f f' (\rv rv' s s'. R' x rv rv' s s')\ \ rcorres (\s s'. P s \ (\x. R x s s')) f f' (\rv rv' s s'. \x. R' x rv rv' s s')" by (fastforce simp: rcorres_def det_wp_def singleton_iff) @@ -369,8 +375,18 @@ lemma rcorres_allI_fwd: apply (fastforce intro!: rcorres_weaken_pre[OF rcorres_allI]) done +lemma rcorres_exI[rcorres_op_lifts]: + "rcorres R f f' (\rv rv' s s'. R' (x rv rv' s s') rv rv' s s') + \ rcorres R f f' (\rv rv' s s'. \x. R' x rv rv' s s')" + by (fastforce simp: rcorres_def) + +lemma rcorres_exI_abs_rv: + "rcorres R f f' (\rv rv' s s'. R' rv rv rv' s s') + \ rcorres R f f' (\rv rv' s s'. \x. R' x rv rv' s s')" + by (rule rcorres_exI) + lemma rcorres_prop: - "\no_fail (\s. Q s) f; empty_fail f\ \ rcorres (\s s'. Q s \ R') f f' (\_ _ _ _. R')" + "\no_fail Q f; empty_fail f\ \ rcorres (\s s'. Q s \ R') f f' (\_ _ _ _. R')" by (fastforce simp: rcorres_def no_fail_def empty_fail_def) lemma rcorres_prop_fwd: @@ -476,13 +492,16 @@ method rcorres uses rcorres_del rcorres_lift_del wp simp declares rcorres rcorre text \ This method is intended to be used to solve or make progress with @{const rcorres} goals via - lifting, when the precondition is not schematic.\ -method rcorres_conj_lift methods solve uses rule simp wp = + lifting, when the precondition is not schematic. + + The user may specify a set to the argument rule: so that side conditions such as @{const no_fail}, + @{const empty_fail}, and @{const det_wp} can be solved more directly.\ +method rcorres_conj_lift methods solve_final_imp uses rule simp wp = (rule rcorres_conj_lift_fwd, (solves \rule det_wp_pre, rule rule, clarsimp\ | solves \wpsimp wp: wp simp: simp\))?, rule rcorres_weaken_pre, (rule rcorres_lift, (solves \rule rule\ | solves \wpsimp wp: wp simp: simp\)+)[1], - solves solve + solves solve_final_imp experiment fixes f f' :: "('s, 'r) nondet_monad" diff --git a/proof/refine/Bits_R.thy b/proof/refine/Bits_R.thy index 223a5ea0dc..3bacdbc297 100644 --- a/proof/refine/Bits_R.thy +++ b/proof/refine/Bits_R.thy @@ -276,14 +276,6 @@ lemma obj_at_valid_objs': apply simp done -lemma tcb_in_valid_state': - "\ st_tcb_at' P t s; valid_objs' s \ \ \st. P st \ valid_tcb_state' st s" - apply (clarsimp simp: pred_tcb_at'_def) - apply (drule obj_at_valid_objs') - apply fastforce - apply (fastforce simp add: valid_obj'_def valid_tcb'_def) - done - lemma getCurThread_corres[corres]: "corres (=) \ \ (gets cur_thread) getCurThread" by (simp add: getCurThread_def curthread_relation) diff --git a/proof/refine/CSpace1_R.thy b/proof/refine/CSpace1_R.thy index 8b1b0cfd10..4485787035 100644 --- a/proof/refine/CSpace1_R.thy +++ b/proof/refine/CSpace1_R.thy @@ -265,46 +265,6 @@ lemma no_fail_getCTE [wp]: "no_fail (cte_at' p) (getCTE p)" by (wpsimp simp: getCTE_def) -lemma tcb_cases_related: - "tcb_cap_cases ref = Some (getF, setF, restr) - \ \getF' setF'. - (\x. tcb_cte_cases (cte_map (x, ref) - x) = Some (getF', setF')) - \ (\tcb tcb'. tcb_relation tcb tcb' \ cap_relation (getF tcb) (cteCap (getF' tcb')))" - by (clarsimp simp: tcb_relation_def cte_map_def tcb_cap_cases_def tcb_cte_cases_neqs - tcb_cte_cases_def tcb_cnode_index_def - to_bl_1 - simp flip: cteSizeBits_cte_level_bits - split: if_split_asm) - -lemma pspace_relation_cte_wp_at: - "\ pspace_relation (kheap s) (ksPSpace s'); - cte_wp_at ((=) c) (cref, oref) s; pspace_aligned' s'; - pspace_distinct' s' \ - \ cte_wp_at' (\cte. cap_relation c (cteCap cte)) (cte_map (cref, oref)) s'" - apply (simp add: cte_wp_at_cases) - apply (erule disjE) - apply clarsimp - apply (drule(1) pspace_relation_absD) - apply (simp add: unpleasant_helper) - apply (drule spec, drule mp, erule domI) - apply (clarsimp simp: cte_relation_def) - apply (drule(2) aligned'_distinct'_ko_at'I[where 'a=cte], simp) - apply simp - apply (drule ko_at_imp_cte_wp_at') - apply (clarsimp elim!: cte_wp_at_weakenE') - apply clarsimp - apply (drule(1) pspace_relation_absD) - apply (clarsimp simp: tcb_relation_cut_def) - apply (simp split: kernel_object.split_asm) - apply (drule(2) aligned'_distinct'_ko_at'I[where 'a=tcb], simp) - apply simp - apply (drule tcb_cases_related) - apply (clarsimp simp: obj_at'_def gen_objBits_simps) - apply (erule(2) cte_wp_at_tcbI') - apply fastforce - apply simp - done - lemma pspace_relation_ctes_ofI: "\ pspace_relation (kheap s) (ksPSpace s'); cte_wp_at ((=) c) slot s; pspace_aligned' s'; @@ -1486,10 +1446,6 @@ lemma cte_map_inj_eq: apply simp done -lemma other_obj_relation_KOCTE[simp]: - "\ other_obj_relation ko (KOCTE cte)" - by (simp add: other_obj_relation_def split: Structures_A.kernel_object.splits) - lemma setCTE_pspace_only: "(rv, s') \ fst (setCTE p v s) \ \ps'. s' = ksPSpace_update (\s. ps') s" apply (clarsimp simp: setCTE_def setObject_def in_monad split_def @@ -1544,6 +1500,28 @@ lemma setObject_cte_scs_of'_use_valid_ksPSpace: using use_valid[OF step setObject_scs_of'(1)] pre by auto +lemma setObject_cte_epQueues_of[wp]: + "setObject c (cte :: cte) \\s. P' (epQueues_of s)\" + by setObject_easy_cases + +lemma setObject_cte_epQueues_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + assumes pre: "P (epQueues_of s)" + shows "P (ps |> ep_of' ||> epQueue)" + using use_valid[OF step setObject_cte_epQueues_of] pre + by auto + +lemma setObject_cte_ntfnQueues_of[wp]: + "setObject c (cte :: cte) \\s. P' (ntfnQueues_of s)\" + by setObject_easy_cases + +lemma setObject_cte_ntfnQueues_of_use_valid_ksPSpace: + assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" + assumes pre: "P (ntfnQueues_of s)" + shows "P (ps |> ntfn_of' ||> ntfnQueue)" + using use_valid[OF step setObject_cte_ntfnQueues_of] pre + by auto + lemma setObject_cte_tcbSchedPrevs_of_use_valid_ksPSpace: assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" assumes pre: "P (tcbSchedPrevs_of s)" @@ -1590,6 +1568,8 @@ lemma updateCap_stuff: (pspace_distinct' s' \ pspace_distinct' s'') \ replyPrevs_of s'' = replyPrevs_of s' \ scReplies_of s'' = scReplies_of s' \ + epQueues_of s'' = epQueues_of s' \ + ntfnQueues_of s'' = ntfnQueues_of s' \ tcbSchedPrevs_of s'' = tcbSchedPrevs_of s' \ tcbSchedNexts_of s'' = tcbSchedNexts_of s' \ (\domain priority. @@ -1607,16 +1587,18 @@ lemma updateCap_stuff: apply (frule setCTE_pspace_only) apply (clarsimp simp: setCTE_def) apply (intro conjI impI) - apply (erule use_valid [OF _ setObject_aligned]) - apply (clarsimp simp: updateObject_cte in_monad typeError_def - in_magnitude_check gen_objBits_simps - split: kernel_object.split_asm if_split_asm) - apply (erule use_valid [OF _ setObject_distinct]) - apply (clarsimp simp: updateObject_cte in_monad typeError_def - in_magnitude_check gen_objBits_simps - split: kernel_object.split_asm if_split_asm) - apply (erule setObject_cte_replies_of'_use_valid_ksPSpace; simp) - apply (erule setObject_cte_scs_of'_use_valid_ksPSpace; simp) + apply (erule use_valid [OF _ setObject_aligned]) + apply (clarsimp simp: updateObject_cte in_monad typeError_def + in_magnitude_check gen_objBits_simps + split: kernel_object.split_asm if_split_asm) + apply (erule use_valid [OF _ setObject_distinct]) + apply (clarsimp simp: updateObject_cte in_monad typeError_def + in_magnitude_check gen_objBits_simps + split: kernel_object.split_asm if_split_asm) + apply (erule setObject_cte_replies_of'_use_valid_ksPSpace; simp) + apply (erule setObject_cte_scs_of'_use_valid_ksPSpace; simp) + apply (erule setObject_cte_epQueues_of_use_valid_ksPSpace; simp) + apply (erule setObject_cte_ntfnQueues_of_use_valid_ksPSpace; simp) apply (erule setObject_cte_tcbSchedPrevs_of_use_valid_ksPSpace; simp) apply (erule setObject_cte_tcbSchedNexts_of_use_valid_ksPSpace; simp) apply (fastforce elim: setObject_cte_inQ_of_use_valid_ksPSpace) @@ -1767,7 +1749,9 @@ lemma set_cap_not_quite_corres: cur_time t = ksCurTime t' \ cur_sc t = ksCurSc t' \ reprogram_timer t = ksReprogramTimer t' \ - sc_replies_of t = sc_replies_of s" + sc_replies_of t = sc_replies_of s \ + ep_queues_of t = ep_queues_of s \ + ntfn_queues_of t = ntfn_queues_of s" using cr apply (clarsimp simp: updateCap_def in_monad) apply (drule use_valid [OF _ getCTE_sp[where P="\s. s2 = s" for s2], OF _ refl]) @@ -1781,6 +1765,10 @@ lemma set_cap_not_quite_corres: apply (frule setCTE_pspace_only) apply (prop_tac "sc_replies_of x = sc_replies_of s") apply (erule use_valid[OF _ set_cap.valid_sched_pred], simp) + apply (prop_tac "ep_queues_of x = ep_queues_of s") + apply (erule use_valid[OF _ set_cap.valid_sched_pred], simp) + apply (prop_tac "ntfn_queues_of x = ntfn_queues_of s") + apply (erule use_valid[OF _ set_cap.valid_sched_pred], simp) apply (clarsimp simp: set_cap_def split_def in_monad set_object_def get_object_def) apply (rename_tac obj ps' x' obj' kobj) @@ -2029,7 +2017,7 @@ lemma updateCap_corres: apply (clarsimp simp: null_filter_def is_zombie_def split: if_split_asm) subgoal by (auto elim!: modify_map_casesE del: disjE)[1] - apply (clarsimp simp: sc_replies_relation_def) + apply (clarsimp simp: sc_replies_relation_def ep_queues_relation_def ntfn_queues_relation_def) done end (* CSpace1_R *) @@ -2085,6 +2073,10 @@ lemma updateMDB_ctes_of: apply simp done +crunch setCTE + for eps_of'[wp]: "\s. P (eps_of' s)" + and ntfns_of'[wp]: "\s. P (ntfns_of' s)" + crunch updateMDB for replies_of'[wp]: "\s. P (replies_of' s)" and scs_of'[wp]: "\s. P (scs_of' s)" @@ -2100,6 +2092,8 @@ crunch updateMDB and tcbSchedNexts[wp]: "\s. P (tcbSchedNexts_of s)" and tcbInReleaseQueue[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" and inQ_opt_pred[wp]: "\s. P (inQ d p |< tcbs_of' s)" + and eps_of'[wp]: "\s. P (eps_of' s)" + and ntfns_of'[wp]: "\s. P (ntfns_of' s)" (wp: crunch_wps simp: crunch_simps setObject_def updateObject_cte) (* needed to make mdb_inv_preserved work with CSpace1_R(_2?) *) @@ -2944,6 +2938,8 @@ lemma updateMDB_the_lot: ksReprogramTimer s'' = ksReprogramTimer s' \ replyPrevs_of s'' = replyPrevs_of s' \ scReplies_of s'' = scReplies_of s' \ + epQueues_of s'' = epQueues_of s' \ + ntfnQueues_of s'' = ntfnQueues_of s' \ tcbSchedNexts_of s'' = tcbSchedNexts_of s' \ tcbSchedPrevs_of s'' = tcbSchedPrevs_of s' \ (tcbInReleaseQueue |< tcbs_of' s'') = (tcbInReleaseQueue |< tcbs_of' s') \ @@ -2988,6 +2984,8 @@ lemma updateMDB_the_lot': ksReprogramTimer s'' = ksReprogramTimer s' \ replyPrevs_of s'' = replyPrevs_of s' \ scReplies_of s'' = scReplies_of s' \ + epQueues_of s'' = epQueues_of s' \ + ntfnQueues_of s'' = ntfnQueues_of s' \ tcbSchedNexts_of s'' = tcbSchedNexts_of s' \ tcbSchedPrevs_of s'' = tcbSchedPrevs_of s' \ (tcbInReleaseQueue |< tcbs_of' s'') = (tcbInReleaseQueue |< tcbs_of' s') \ @@ -3130,6 +3128,20 @@ lemma setCTE_UntypedCap_corres: apply (rule use_valid[OF _ setCTE_tcbInReleaseQueue], assumption) apply clarsimp + apply (extract_conjunct \match conclusion in "ep_queues_relation _ _" \ -\) + apply (rule use_valid[OF _ setCTE_tcbSchedPrevs_of], assumption) + apply (rule use_valid[OF _ setCTE_tcbSchedNexts_of], assumption) + apply (rule use_valid[OF _ set_cap.valid_sched_pred], assumption) + apply (rule use_valid[OF _ setCTE_eps_of'], assumption) + apply clarsimp + + apply (extract_conjunct \match conclusion in "ntfn_queues_relation _ _" \ -\) + apply (rule use_valid[OF _ setCTE_tcbSchedPrevs_of], assumption) + apply (rule use_valid[OF _ setCTE_tcbSchedNexts_of], assumption) + apply (rule use_valid[OF _ set_cap.valid_sched_pred], assumption) + apply (rule use_valid[OF _ setCTE_ntfns_of'], assumption) + apply clarsimp + apply (frule setCTE_pspace_only) apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def) apply (rename_tac obj ps' s'' obj' kobj; case_tac obj; diff --git a/proof/refine/CSpace_R.thy b/proof/refine/CSpace_R.thy index 99f484685d..2c5eb31f07 100644 --- a/proof/refine/CSpace_R.thy +++ b/proof/refine/CSpace_R.thy @@ -836,7 +836,9 @@ lemma set_cap_not_quite_corres': cur_time t = ksCurTime t' \ cur_sc t = ksCurSc t' \ reprogram_timer t = ksReprogramTimer t' \ - sc_replies_of t = sc_replies_of s" + sc_replies_of t = sc_replies_of s \ + ep_queues_of t = ep_queues_of s \ + ntfn_queues_of t = ntfn_queues_of s" using cr by (rule set_cap_not_quite_corres; fastforce simp: c p) @@ -2548,51 +2550,6 @@ lemma setCTE_ko_wp_at_live[wp]: apply (clarsimp simp: ps_clear_upd gen_objBits_simps live'_def) done -lemma setCTE_iflive': - "\\s. cte_wp_at' (\cte'. \p'\zobj_refs' (cteCap cte') - - zobj_refs' (cteCap cte). - ko_wp_at' (Not \ live') p' s) p s - \ if_live_then_nonz_cap' s\ - setCTE p cte - \\rv s. if_live_then_nonz_cap' s\" - unfolding if_live_then_nonz_cap'_def ex_nonz_cap_to'_def - apply (rule hoare_pre) - apply (simp only: imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - hoare_vcg_ex_lift setCTE_weak_cte_wp_at) - apply clarsimp - apply (drule spec, drule(1) mp) - apply clarsimp - apply (rule_tac x=cref in exI) - apply (clarsimp simp: cte_wp_at'_def) - apply (rule ccontr) - apply (drule bspec, fastforce) - apply (clarsimp simp: ko_wp_at'_def) - done - -lemma updateMDB_iflive'[wp]: - "\\s. if_live_then_nonz_cap' s\ - updateMDB p m - \\rv s. if_live_then_nonz_cap' s\" - apply (clarsimp simp: updateMDB_def) - apply (rule bind_wp [OF _ getCTE_sp]) - apply (wp setCTE_iflive') - apply (clarsimp elim!: cte_wp_at_weakenE') - done - -lemma updateCap_iflive': - "\\s. cte_wp_at' (\cte'. \p'\zobj_refs' (cteCap cte') - - zobj_refs' cap. - ko_wp_at' (Not \ live') p' s) p s - \ if_live_then_nonz_cap' s\ - updateCap p cap - \\rv s. if_live_then_nonz_cap' s\" - apply (simp add: updateCap_def) - apply (rule bind_wp [OF _ getCTE_sp]) - apply (wp setCTE_iflive') - apply (clarsimp elim!: cte_wp_at_weakenE') - done - lemma setCTE_ko_wp_at_not_live[wp]: "\\s. P (ko_wp_at' (Not \ live') p' s)\ setCTE p v @@ -2631,46 +2588,10 @@ lemma zobj_refs'_capFreeIndex_update[simp]: zobj_refs' (capFreeIndex_update f (ctecap)) = zobj_refs' ctecap" by (case_tac ctecap,auto simp: gen_isCap_simps) -lemma setUntypedCapAsFull_if_live_then_nonz_cap': - "\\s. if_live_then_nonz_cap' s \ cte_wp_at' ((=) srcCTE) src s\ - setUntypedCapAsFull (cteCap srcCTE) cap src - \\rv s. if_live_then_nonz_cap' s\" - apply (clarsimp simp:if_live_then_nonz_cap'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) - apply (clarsimp simp:setUntypedCapAsFull_def split del: if_split) - apply (wp hoare_vcg_if_split) - apply (clarsimp simp:ex_nonz_cap_to'_def cte_wp_at_ctes_of) - apply (wp updateCap_ctes_of_wp)+ - apply clarsimp - apply (elim allE impE) - apply (assumption) - apply (clarsimp simp:ex_nonz_cap_to'_def cte_wp_at_ctes_of modify_map_def split:if_splits) - apply (rule_tac x = cref in exI) - apply (intro conjI impI; clarsimp) - done - lemma maskedAsFull_simps[simp]: "maskedAsFull capability.NullCap cap = capability.NullCap" by (auto simp:maskedAsFull_def) -lemma cteInsert_iflive'[wp]: - "\\s. if_live_then_nonz_cap' s - \ cte_wp_at' (\c. cteCap c = NullCap) dest s\ - cteInsert cap src dest - \\rv. if_live_then_nonz_cap'\" - apply (simp add: cteInsert_def split del: if_split) - apply (wp updateCap_iflive' hoare_drop_imps) - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (wp hoare_vcg_conj_lift hoare_vcg_ex_lift hoare_vcg_ball_lift getCTE_wp - setUntypedCapAsFull_ctes_of setUntypedCapAsFull_if_live_then_nonz_cap')+ - apply (clarsimp simp:cte_wp_at_ctes_of) - apply (intro conjI) - apply (rule_tac x = "case (ctes_of s dest) of Some a \a" in exI) - apply (clarsimp) - apply (case_tac cte,simp) - apply clarsimp+ - done - lemma ifunsafe'_def2: "if_unsafe_then_cap' = (\s. \cref cte. ctes_of s cref = Some cte \ cteCap cte \ NullCap @@ -3059,20 +2980,6 @@ crunch cteInsert for pspace_domain_valid[wp]: "pspace_domain_valid" (wp: crunch_wps) -lemma setCTE_ct_not_inQ[wp]: - "\ct_not_inQ\ setCTE ptr cte \\_. ct_not_inQ\" - apply (rule ct_not_inQ_lift [OF setCTE_nosch]) - apply (simp add: setCTE_def ct_not_inQ_def) - apply (rule hoare_weaken_pre) - apply (wps setObject_cte_ct) - apply (rule setObject_cte_obj_at_tcb') - apply (clarsimp simp add: obj_at'_def)+ - done - -crunch cteInsert - for ct_not_inQ[wp]: "ct_not_inQ" - (simp: crunch_simps wp: hoare_drop_imp) - lemma setCTE_ksCurDomain[wp]: "\\s. P (ksCurDomain s)\ setCTE p cte @@ -3124,12 +3031,6 @@ crunch cteInsert for tcbPriority_inv[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t" (wp: crunch_simps hoare_drop_imps) -lemma cteInsert_ct_idle_or_in_cur_domain'[wp]: - "\ ct_idle_or_in_cur_domain' \ cteInsert a b c \ \_. ct_idle_or_in_cur_domain' \" - apply (rule ct_idle_or_in_cur_domain'_lift) - apply (wp hoare_vcg_disj_lift)+ - done - lemma setObject_cte_domIdx: "\\s. P (ksDomScheduleIdx s)\ setObject t (v::cte) \\rv s. P (ksDomScheduleIdx s)\" by (clarsimp simp: valid_def setCTE_def[symmetric] dest!: setCTE_pspace_only) @@ -3768,14 +3669,6 @@ lemma capMaster_same_refs: apply (rule master_eqI, rule zobj_refs_Master, simp) done -lemma arch_update_setCTE_iflive: - "\cte_wp_at' (is_arch_update' cap) p and cte_wp_at' ((=) oldcte) p and if_live_then_nonz_cap'\ - setCTE p (cteCap_update (\_. cap) oldcte) - \\rv. if_live_then_nonz_cap'\" - apply (wp setCTE_iflive') - apply (clarsimp simp: cte_wp_at_ctes_of is_arch_update'_def dest!: capMaster_zobj_refs) - done - lemma arch_update_setCTE_ifunsafe: "\cte_wp_at' (is_arch_update' cap) p and cte_wp_at' ((=) oldcte) p and if_unsafe_then_cap'\ setCTE p (cteCap_update (\_. cap) oldcte) @@ -3809,10 +3702,7 @@ lemma arch_update_setCTE_invs: \\rv. invs'\" apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) apply (wp arch_update_setCTE_mdb setCTE_pspace_in_kernel_mappings' valid_bitmaps_lift - sch_act_wf_lift tcb_in_cur_domain'_lift - ct_idle_or_in_cur_domain'_lift - arch_update_setCTE_iflive arch_update_setCTE_ifunsafe - valid_irq_node_lift setCTE_typ_at' setCTE_irq_handlers' + arch_update_setCTE_ifunsafe valid_irq_node_lift setCTE_typ_at' setCTE_irq_handlers' irqs_masked_lift setCTE_norq hoare_vcg_disj_lift untyped_ranges_zero_lift valid_replies'_lift sym_heap_sched_pointers_lift setCTE_valid_arch @@ -5043,6 +4933,32 @@ lemma cteInsert_simple_invs: elim: valid_capAligned) done +lemma setCTE_set_cap_ep_queues_relation_valid_corres: + assumes pre: "ep_queues_relation s s'" + and step_abs: "(x, t) \ fst (set_cap cap slot s)" + and step_conc: "(y, t') \ fst (setCTE slot' cap' s')" + shows "ep_queues_relation t t'" + apply (insert pre) + apply (rule use_valid[OF step_abs set_cap.valid_sched_pred]) + apply (rule use_valid[OF step_conc setCTE_eps_of']) + apply (rule use_valid[OF step_conc setCTE_tcbSchedNexts_of]) + apply (rule use_valid[OF step_conc setCTE_tcbSchedPrevs_of]) + apply clarsimp + done + +lemma setCTE_set_cap_ntfn_queues_relation_valid_corres: + assumes pre: "ntfn_queues_relation s s'" + and step_abs: "(x, t) \ fst (set_cap cap slot s)" + and step_conc: "(y, t') \ fst (setCTE slot' cap' s')" + shows "ntfn_queues_relation t t'" + apply (insert pre) + apply (rule use_valid[OF step_abs set_cap.valid_sched_pred]) + apply (rule use_valid[OF step_conc setCTE_ntfns_of']) + apply (rule use_valid[OF step_conc setCTE_tcbSchedNexts_of]) + apply (rule use_valid[OF step_conc setCTE_tcbSchedPrevs_of]) + apply clarsimp + done + lemma updateCap_same_master: "\ cap_relation cap cap' \ \ corres dc (valid_objs and pspace_aligned and pspace_distinct and @@ -5079,6 +4995,10 @@ lemma updateCap_same_master: subgoal by (erule setCTE_set_cap_ready_queues_relation_valid_corres; assumption) apply (extract_conjunct \match conclusion in "release_queue_relation a b" for a b \ -\) subgoal by (erule setCTE_set_cap_release_queue_relation_valid_corres; assumption) + apply (extract_conjunct \match conclusion in "ep_queues_relation a b" for a b \ -\) + subgoal by (erule setCTE_set_cap_ep_queues_relation_valid_corres; assumption) + apply (extract_conjunct \match conclusion in "ntfn_queues_relation a b" for a b \ -\) + subgoal by (erule setCTE_set_cap_ntfn_queues_relation_valid_corres; assumption) apply (rule conjI) apply (frule setCTE_pspace_only) apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def) @@ -5181,7 +5101,7 @@ lemma updateFreeIndex_forward_invs': apply (simp add: valid_pspace'_def, wp updateFreeIndex_forward_valid_objs' updateFreeIndex_forward_valid_mdb') apply (simp add: updateFreeIndex_def updateTrackedFreeIndex_def) - apply (wp valid_bitmaps_lift updateCap_iflive' sym_heap_sched_pointers_lift + apply (wp valid_bitmaps_lift sym_heap_sched_pointers_lift | simp add: pred_tcb_at'_def)+ apply (rule hoare_vcg_conj_lift) @@ -5193,7 +5113,7 @@ lemma updateFreeIndex_forward_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift + apply (wp irqs_masked_lift cur_tcb_lift hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp sym_heap_sched_pointers_lift valid_bitmaps_lift | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] diff --git a/proof/refine/Corres.thy b/proof/refine/Corres.thy index bae1cdc8ef..774ec55673 100644 --- a/proof/refine/Corres.thy +++ b/proof/refine/Corres.thy @@ -5,7 +5,7 @@ *) theory Corres -imports StateRelation "CorresK.CorresK_Lemmas" +imports StateRelation "CorresK.CorresK_Lemmas" "Lib.RCorres" begin text \Instantiating the corres framework to this particular state relation.\ @@ -33,4 +33,7 @@ lemmas sr_inv_imp = sr_inv_ul_imp[of state_relation] lemmas sr_inv_bind = sr_inv_ul_bind[where sr=state_relation] +lemmas rcorres_from_corres = + rcorres_from_corres_underlying[where nf=False and nf'=True and srel=state_relation, simplified] + end diff --git a/proof/refine/HeapStateRelation.thy b/proof/refine/HeapStateRelation.thy new file mode 100644 index 0000000000..02fba0c50c --- /dev/null +++ b/proof/refine/HeapStateRelation.thy @@ -0,0 +1,684 @@ +(* + * Copyright 2026, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory HeapStateRelation +imports ArchHeapStateRelation +begin + +arch_requalify_consts + aobjs_relation + heap_ghost_relation_wrapper_2 + +\ \An alternative approach to @{const state_relation} using heap projections\ + +abbreviation tcbs_relation :: "'z state \ kernel_state \ bool" where + "tcbs_relation s s' \ map_relation (tcbs_of s) (tcbs_of' s') tcb_relation" + +definition cnode_to_cte_ptrs :: "obj_ref \ cnode_contents \ machine_word set" where + "cnode_to_cte_ptrs p cnode = { cte_map (p, y) | y. y \ dom cnode }" + +definition caps_relation_2 :: + "(obj_ref \ nat) \ (obj_ref \ cnode_contents) \ (obj_ref \ cte) \ bool" + where + "caps_relation_2 cnode_sizes cnodes ctes \ + (\p\dom cnodes. cnode_to_cte_ptrs p (the (cnodes p))) = dom ctes + \ (\p\dom cnodes. \cnode sz. + cnodes p = Some cnode \ cnode_sizes p = Some sz + \ (well_formed_cnode_n sz cnode + \ (\y \ dom cnode. \cap cte. + cnode y = Some cap \ ctes (cte_map (p, y)) = Some cte + \ cap_relation cap (cteCap cte))))" + +abbreviation caps_relation :: "'z state \ kernel_state \ bool" where + "caps_relation s s' \ caps_relation_2 (cnode_sizes_of s) (cnode_contents_of s) (ctes_of' s')" + +lemmas caps_relation_def = caps_relation_2_def + +abbreviation ntfns_relation :: "'z state \ kernel_state \ bool" where + "ntfns_relation s s' \ map_relation (ntfns_of s) (ntfns_of' s') ntfn_relation" + +abbreviation eps_relation :: "'z state \ kernel_state \ bool" where + "eps_relation s s' \ map_relation (eps_of s) (eps_of' s') ep_relation" + +definition scs_relation_2 :: + "(obj_ref \ Structures_A.sched_context) \ (obj_ref \ nat) \ (obj_ref \ sched_context) \ bool" + where + "scs_relation_2 scs sc_sizes scs' \ + dom scs = dom scs' + \ (\p sc n sc'. scs p = Some sc \ sc_sizes p = Some n \ scs' p = Some sc' + \ valid_sched_context_size n \ sc_relation sc n sc')" + +abbreviation scs_relation :: "'z state \ kernel_state \ bool" where + "scs_relation s s' \ scs_relation_2 (scs_of s) (sc_sizes_of s) (scs_of' s')" + +lemmas scs_relation_def = scs_relation_2_def + +abbreviation replies_relation :: "'z state \ kernel_state \ bool" where + "replies_relation s s' \ map_relation (replies_of s) (replies_of' s') reply_relation" + +text \ + The conjunct below involving @{const KOKernelData} is required in order to make the following + definition fully equivalent to @{const pspace_relation}: the conjunct in @{const pspace_relation} + involving @{const pspace_dom} will entail that there are no @{const KOKernelData} objects in the + concrete heap.\ +definition heap_pspace_relation :: "'z::state_ext state \ kernel_state \ bool" where + "heap_pspace_relation s s' \ + tcbs_relation s s' + \ caps_relation s s' + \ scs_relation s s' + \ eps_relation s s' + \ ntfns_relation s s' + \ replies_relation s s' + \ (\p. ksPSpace s' p \ Some KOKernelData) + \ aobjs_relation s s'" + +lemma heap_pspace_relation_tcbs_relation[elim!]: + "heap_pspace_relation s s' \ tcbs_relation s s'" + by (simp add: heap_pspace_relation_def) + +lemma heap_pspace_relation_caps_relation[elim!]: + "heap_pspace_relation s s' \ caps_relation s s'" + by (simp add: heap_pspace_relation_def) + +lemma heap_pspace_relation_scs_relation[elim!]: + "heap_pspace_relation s s' \ scs_relation s s'" + by (simp add: heap_pspace_relation_def) + +lemma heap_pspace_relation_eps_relation[elim!]: + "heap_pspace_relation s s' \ eps_relation s s'" + by (simp add: heap_pspace_relation_def) + +lemma heap_pspace_relation_ntfns_relation[elim!]: + "heap_pspace_relation s s' \ ntfns_relation s s'" + by (simp add: heap_pspace_relation_def) + +lemma heap_pspace_relation_replies_relation[elim!]: + "heap_pspace_relation s s' \ replies_relation s s'" + by (simp add: heap_pspace_relation_def) + +lemma heap_pspace_relation_KOKernelData: + "heap_pspace_relation s s' \ (\p. ksPSpace s' p \ Some KOKernelData)" + by (simp add: heap_pspace_relation_def) + +lemma heap_pspace_relation_aobjs_relation[elim!]: + "heap_pspace_relation s s' \ aobjs_relation s s'" + by (simp add: heap_pspace_relation_def) + +abbreviation heap_ghost_relation_wrapper :: "det_state \ kernel_state \ bool" where + "heap_ghost_relation_wrapper s s' \ + heap_ghost_relation_wrapper_2 + (aobjs_of s) (cnode_sizes_of s) (cnode_contents_of s) (gsUserPages s') (gsCNodes s') + (ksArchState s')" + +lemma tcbs_relation_lift_rcorres[rcorres_lift]: + assumes det: "\s'. det_wp (\s. Q s s') f" + assumes abs: "\P s'. \\s. P (tcbs_of s) \ Q s s'\ f \\_ s. P (tcbs_of s)\" + assumes conc: + "\P s. \\s'. P (dom (tcbs_of' s')) \ Q s s'\ f' \\_ s'. P (dom (tcbs_of' s'))\" + "\P s. \\s'. P (tcbIPCBuffers_of s') \ Q s s'\ f' \\_ s'. P (tcbIPCBuffers_of s')\" + "\P s. \\s'. P (tcbArches_of s') \ Q s s'\ f' \\_ s'. P (tcbArches_of s')\" + "\P s. \\s'. P (tcbStates_of' s') \ Q s s'\ f' \\_ s'. P (tcbStates_of' s')\" + "\P s. \\s'. P (tcbFaults_of s') \ Q s s'\ f' \\_ s'. P (tcbFaults_of s')\" + "\P s. \\s'. P (tcbCTables_of s') \ Q s s'\ f' \\_ s'. P (tcbCTables_of s')\" + "\P s. \\s'. P (tcbVTables_of s') \ Q s s'\ f' \\_ s'. P (tcbVTables_of s')\" + "\P s. \\s'. P (tcbFaultHandlers_of s') \ Q s s'\ f' \\_ s'. P (tcbFaultHandlers_of s')\" + "\P s. \\s'. P (tcbTimeoutHandlers_of s') \ Q s s'\ f' \\_ s'. P (tcbTimeoutHandlers_of s')\" + "\P s. \\s'. P (tcbIPCBufferFrames_of s') \ Q s s'\ f' \\_ s'. P (tcbIPCBufferFrames_of s')\" + "\P s. \\s'. P (tcbBoundNotifications_of s') \ Q s s'\ f' \\_ s'. P (tcbBoundNotifications_of s')\" + "\P s. \\s'. P (tcbSchedContexts_of s') \ Q s s'\ f' \\_ s'. P (tcbSchedContexts_of s')\" + "\P s. \\s'. P (tcbYieldTos_of s') \ Q s s'\ f' \\_ s'. P (tcbYieldTos_of s')\" + "\P s. \\s'. P (tcbMCPs_of s') \ Q s s'\ f' \\_ s'. P (tcbMCPs_of s')\" + "\P s. \\s'. P (tcbPriorities_of s') \ Q s s'\ f' \\_ s'. P (tcbPriorities_of s')\" + "\P s. \\s'. P (tcbDomains_of s') \ Q s s'\ f' \\_ s'. P (tcbDomains_of s')\" + "\P s. \\s'. P (tcbFlags_of s') \ Q s s'\ f' \\_ s'. P (tcbFlags_of s')\" + shows "rcorres (\s s'. tcbs_relation s s' \ Q s s') f f' (\_ _. tcbs_relation)" + apply (rule rcorres_from_valid_det) + apply (fastforce intro: det_wp_pre det) + apply (rename_tac s t) + apply (rule_tac P'1="\_. tcbs_of t = tcbs_of s" in hoare_pre_add[THEN iffD2]) + apply (fastforce dest: use_valid[OF _ abs]) + apply (insert conc) + unfolding map_relation_def + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule hoare_weaken_pre) + apply fast + apply force + apply (clarsimp simp: tcb_relation_def) + apply (rule hoare_allI, rename_tac p) + apply (rule hoare_allI, rename_tac tcb) + apply (simp add: imp_conjL) + apply (rule hoare_impI) + apply (simp add: all_conj_distrib imp_conjR) + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. (tcbs_of' s' ||> tcbIPCBuffer) p = Some (tcb_ipc_buffer tcb)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI) + apply (clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. ((\atcb. arch_tcb_relation (tcb_arch tcb) atcb) + |< (tcbs_of' s' ||> tcbArch)) p" + in hoare_post_imp) + apply (clarsimp simp: opt_pred_def opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. ((\ts. thread_state_relation (tcb_state tcb) ts) + |< (tcbs_of' s' ||> tcbState)) p" + in hoare_post_imp) + apply (clarsimp simp: opt_pred_def opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. fault_rel_optionation + ((tcbs_of t |> tcb_fault) p) ((tcbs_of' s' |> tcbFault) p)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_red) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. opt_ord_rel cap_relation + ((tcbs_of t ||> tcb_ctable) p) + ((tcbs_of' s' ||> tcbCTable ||> cteCap) p)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_red) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. opt_ord_rel cap_relation + ((tcbs_of t ||> tcb_vtable) p) + ((tcbs_of' s' ||> tcbVTable ||> cteCap) p)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_red) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. opt_ord_rel cap_relation + ((tcbs_of t ||> tcb_fault_handler) p) + ((tcbs_of' s' ||> tcbFaultHandler ||> cteCap) p)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_red) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. opt_ord_rel cap_relation + ((tcbs_of t ||> tcb_timeout_handler) p) + ((tcbs_of' s' ||> tcbTimeoutHandler ||> cteCap) p)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_red) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. opt_ord_rel cap_relation + ((tcbs_of t ||> tcb_ipcframe) p) + ((tcbs_of' s' ||> tcbIPCBufferFrame ||> cteCap) p)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_red) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. (tcbs_of' s' |> tcbBoundNotification) p = tcb_bound_notification tcb" + in hoare_post_imp) + apply (clarsimp simp: opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. (tcbs_of' s' |> tcbSchedContext) p = tcb_sched_context tcb" + in hoare_post_imp) + apply (clarsimp simp: opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. (tcbs_of' s' |> tcbYieldTo) p = tcb_yield_to tcb" + in hoare_post_imp) + apply (clarsimp simp: opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. (tcbs_of' s' ||> tcbMCP) p = Some (tcb_mcpriority tcb)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. (tcbs_of' s' ||> tcbPriority) p = Some (tcb_priority tcb)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_map_red) + apply fastforce + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule_tac Q'="\_ s'. (tcbs_of' s' ||> tcbDomain) p = Some (tcb_domain tcb)" + in hoare_post_imp) + apply (clarsimp simp: opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_map_red) + apply fastforce + apply (rule_tac Q'="\_ s'. ((\flg. word_to_tcb_flags flg = (tcb_flags tcb)) + |< (tcbs_of' s' ||> tcbFlags)) p" + in hoare_post_imp) + apply (clarsimp simp: opt_pred_def opt_map_def) + apply (rule hoare_weaken_pre, assumption) + apply (rule conjI) + apply clarsimp + apply (frule_tac m="tcbs_of s" in domI, clarsimp simp: opt_pred_def opt_map_red) + apply fastforce + done + +lemma scs_relation_lift_rcorres_weak[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (scs_of s) \ Q s s'\ f \\_ s. P (scs_of s)\; + \P s'. \\s. P (sc_sizes_of s) \ Q s s'\ f \\_ s. P (sc_sizes_of s)\; + \P s. \\s'. P (scs_of' s') \ Q s s'\ f' \\_ s'. P (scs_of' s')\\ + \ rcorres (\s s'. scs_relation s s' \ Q s s') f f' (\_ _. scs_relation)" + apply (rule rcorres_lift_conc[where p=scs_of']) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply fastforce + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=scs_of]) + apply (rule hoare_lift_Pf2_pre_conj[where f=sc_sizes_of]) + apply wpsimp + apply fastforce + apply fastforce + apply fastforce + apply wpsimp + done + +lemma eps_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (eps_of s) \ Q s s'\ f \\_ s. P (eps_of s)\; + \P s. \\s'. P (eps_of' s') \ Q s s'\ f' \\_ s. P (eps_of' s)\\ + \ rcorres (\s s'. eps_relation s s' \ Q s s') f f' (\_ _. eps_relation)" + apply (rule rcorres_lift_conc[where p=eps_of']) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + by (fastforce intro: no_fail_pre hoare_weaken_pre)+ + +lemma ntfns_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (ntfns_of s) \ Q s s'\ f \\_ s. P (ntfns_of s)\; + \P s. \\s'. P (ntfns_of' s') \ Q s s'\ f' \\_ s'. P (ntfns_of' s')\\ + \ rcorres (\s s'. ntfns_relation s s' \ Q s s') f f' (\_ _. ntfns_relation)" + apply (rule rcorres_lift_conc[where p=ntfns_of']) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + by (fastforce intro: no_fail_pre hoare_weaken_pre)+ + +lemma replies_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (replies_of s) \ Q s s'\ f \\_ s. P (replies_of s)\; + \P s. \\s'. P (replies_of' s') \ Q s s'\ f' \\_ s. P (replies_of' s)\\ + \ rcorres (\s s'. replies_relation s s' \ Q s s') f f' (\_ _. replies_relation)" + apply (rule rcorres_lift_conc[where p=replies_of']) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + by (fastforce intro: no_fail_pre hoare_weaken_pre)+ + +lemma caps_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (cnode_contents_of s) \ Q s s'\ f \\_ s. P (cnode_contents_of s)\; + \P s'. \\s. P (cnode_sizes_of s) \ Q s s'\ f \\_ s. P (cnode_sizes_of s)\; + \P s. \\s'. P (ctes_of' s') \ Q s s'\ f' \\_ s'. P (ctes_of' s')\\ + \ rcorres (\s s'. caps_relation s s' \ Q s s') f f' (\_ _. caps_relation)" + apply (rule rcorres_lift_conc[where p=ctes_of']) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply fastforce + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=cnode_contents_of]) + by (fastforce intro: hoare_weaken_pre)+ + +lemma kernel_data_lift_rcorres[rcorres_lift]: + "\\s'. det_wp (\s. Q s s') f; empty_fail f; + \P s. \\s'. P (kernelData_at s') \ Q s s'\ f' \\_ s'. P (kernelData_at s')\\ + \ rcorres + (\s s'. \p. ksPSpace s' p \ Some KOKernelData \ Q s s') + f f' + (\_ _ s s'. \p. ksPSpace s' p \ Some KOKernelData)" + apply (rule rcorres_allI_fwd) + apply (fastforce intro: det_wp_pre) + apply (rule rcorres_weaken_pre) + apply (rule_tac R="\_ x _. x" in rcorres_lift_conc[where Q="\s s'. Q s s'"]) + apply (rule rcorres_prop_fwd) + by (fastforce intro: det_wp_no_fail no_fail_pre)+ + +lemma sc_replies_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (sc_replies_of s) \ Q s s'\ f \\_ s. P (sc_replies_of s)\; + \P s. \\s'. P (scReplies_of s') \ Q s s'\ f' \\_ s'. P (scReplies_of s')\; + \P s. \\s'. P (replyPrevs_of s') \ Q s s'\ f' \\_ s'. P (replyPrevs_of s')\\ + \ rcorres (\s s'. sc_replies_relation s s' \ Q s s') f f' (\_ _. sc_replies_relation)" + apply (rule rcorres_lift_abs[where p=sc_replies_of]) + apply (rule rcorres_lift_conc) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply force + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=scReplies_of]) + by (fastforce intro: hoare_weaken_pre)+ + +lemma ready_queues_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (ready_queues s) \ Q s s'\ f \\_ s. P (ready_queues s)\; + \P s. \\s'. P (ksReadyQueues s') \ Q s s'\ f' \\_ s'. P (ksReadyQueues s')\; + \P s. \\s'. P (tcbSchedNexts_of s') \ Q s s'\ f' \\_ s'. P (tcbSchedNexts_of s')\; + \P s. \\s'. P (tcbSchedPrevs_of s') \ Q s s'\ f' \\_ s'. P (tcbSchedPrevs_of s')\; + \P d p s. \\s'. P (inQ d p |< tcbs_of' s') \ Q s s'\ f' \\_ s'. P (inQ d p |< tcbs_of' s')\\ + \ rcorres (\s s'. ready_queues_relation s s' \ Q s s') f f' (\_ _. ready_queues_relation)" + apply (rule rcorres_lift_abs[where p=ready_queues]) + apply (rule rcorres_lift_conc) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply force + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=ksReadyQueues]) + apply (rule hoare_lift_Pf2_pre_conj[where f=tcbSchedNexts_of]) + apply (rule hoare_lift_Pf2_pre_conj[where f=tcbSchedPrevs_of]) + apply (rule inQ_lift) + apply (rename_tac d p) + apply (rule_tac f="\s'. inQ d p |< tcbs_of' s'" in hoare_lift_Pf2_pre_conj) + apply wpsimp + by (fastforce intro: hoare_weaken_pre)+ + +lemma release_queue_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (release_queue s) \ Q s s'\ f \\_ s. P (release_queue s)\; + \P s. \\s'. P (ksReleaseQueue s') \ Q s s'\ f' \\_ s'. P (ksReleaseQueue s')\; + \P s. \\s'. P (tcbSchedNexts_of s') \ Q s s'\ f' \\_ s'. P (tcbSchedNexts_of s')\; + \P s. \\s'. P (tcbSchedPrevs_of s') \ Q s s'\ f' \\_ s'. P (tcbSchedPrevs_of s')\; + \P s. \\s'. P (tcbInReleaseQueue |< tcbs_of' s') \ Q s s'\ + f' \\_ s'. P (tcbInReleaseQueue |< tcbs_of' s')\\ + \ rcorres (\s s'. release_queue_relation s s' \ Q s s') f f' (\_ _. release_queue_relation)" + apply (rule rcorres_lift_abs[where p=release_queue]) + apply (rule rcorres_lift_conc) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply force + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=ksReleaseQueue]) + apply (rule hoare_lift_Pf2_pre_conj[where f=tcbSchedNexts_of]) + apply (rule hoare_lift_Pf2_pre_conj[where f=tcbSchedPrevs_of]) + by (fastforce intro: hoare_weaken_pre)+ + +lemma ep_queues_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (ep_queues_of s) \ Q s s'\ f \\_ s. P (ep_queues_of s)\; + \P s. \\s'. P (epQueues_of s') \ Q s s'\ f' \\_ s'. P (epQueues_of s')\; + \P s. \\s'. P (tcbSchedNexts_of s') \ Q s s'\ f' \\_ s'. P (tcbSchedNexts_of s')\; + \P s. \\s'. P (tcbSchedPrevs_of s') \ Q s s'\ f' \\_ s'. P (tcbSchedPrevs_of s')\\ + \ rcorres (\s s'. ep_queues_relation s s' \ Q s s') f f' (\_ _. ep_queues_relation)" + apply (rule rcorres_lift_abs[where p=ep_queues_of]) + apply (rule rcorres_lift_conc) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply force + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=epQueues_of]) + apply (rule hoare_lift_Pf2_pre_conj[where f=tcbSchedNexts_of]) + by (fastforce intro: hoare_weaken_pre)+ + +lemma ntfn_queues_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (ntfn_queues_of s) \ Q s s'\ f \\_ s. P (ntfn_queues_of s) \; + \P s. \\s'. P (ntfnQueues_of s') \ Q s s'\ f' \\_ s. P (ntfnQueues_of s)\; + \P s. \\s'. P (tcbSchedNexts_of s') \ Q s s'\ f' \\_ s. P (tcbSchedNexts_of s)\; + \P s. \\s'. P (tcbSchedPrevs_of s') \ Q s s'\ f' \\_ s. P (tcbSchedPrevs_of s)\\ + \ rcorres (\s s'. ntfn_queues_relation s s' \ Q s s') f f' (\_ _. ntfn_queues_relation)" + apply (rule rcorres_lift_abs[where p=ntfn_queues_of]) + apply (rule rcorres_lift_conc) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply force + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=ntfnQueues_of]) + apply (rule hoare_lift_Pf2_pre_conj[where f=tcbSchedNexts_of]) + by (fastforce intro: hoare_weaken_pre)+ + +lemma sched_act_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (scheduler_action s) \ Q s s'\ f \\_ s. P (scheduler_action s)\; + \P s. \\s'. P (ksSchedulerAction s') \ Q s s'\ f' \\_ s'. P (ksSchedulerAction s')\\ + \ rcorres + (\s s'. sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ Q s s') + f f' + (\_ _ s s'. sched_act_relation (scheduler_action s) (ksSchedulerAction s'))" + apply (rule rcorres_lift_conc) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + by (fastforce intro: hoare_weaken_pre no_fail_pre)+ + +lemma swp_cte_at_lift: + "(\P. \\s. P (caps_of_state s) \ Q s\ f \\_ s. P (caps_of_state s)\) + \ (\P. \\s. P (swp cte_at s) \ Q s\ f \\_ s. P (swp cte_at s)\)" + apply (simp add: swp_def cte_wp_at_caps_of_state) + apply (rule hoare_lift_Pf2_pre_conj[where f="\s y. \cap. caps_of_state s y = Some cap"]) + apply wpsimp + apply fastforce + done + +lemma cdt_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (caps_of_state s) \ Q s s'\ f \\_ s. P (caps_of_state s)\; + \P s'. \\s. P (cdt s) \ Q s s'\ f \\_ s. P (cdt s)\; + \P s. \\s'. P (ctes_of s') \ Q s s'\ f' \\_ s'. P (ctes_of s')\\ + \ rcorres + (\s s'. cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \ Q s s') + f f' + (\_ _ s s'. cdt_relation (swp cte_at s) (cdt s) (ctes_of s'))" + apply (rule rcorres_lift_conc[where p=ctes_of]) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply force + apply fastforce + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=cdt]) + apply (rule hoare_lift_Pf2_pre_conj[where f="swp cte_at"]) + apply (fastforce intro: hoare_weaken_pre) + apply (rule hoare_weaken_pre) + apply (rule swp_cte_at_lift) + by (fastforce intro: hoare_weaken_pre)+ + +lemma cdt_list_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (cdt_list s) \ Q s s'\ f \\_ s. P (cdt_list s)\; + \P s'. \\s. P (cdt s) \ Q s s'\ f \\_ s. P (cdt s)\; + \P s. \\s'. P (ctes_of s') \ Q s s'\ f' \\_ s'. P (ctes_of s')\\ + \ rcorres + (\s s'. cdt_list_relation (cdt_list s) (cdt s) (ctes_of s') \ Q s s') + f f' + (\_ _ s s'. cdt_list_relation (cdt_list s) (cdt s) (ctes_of s'))" + apply (rule rcorres_lift_conc[where p=ctes_of]) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply fastforce + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=cdt_list]) + by (fastforce intro: hoare_weaken_pre)+ + +lemma revokable_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (is_original_cap s) \ Q s s'\ f \\_ s. P (is_original_cap s)\; + \P s'. \\s. P (caps_of_state s) \ Q s s'\ f \\_ s. P (caps_of_state s)\; + \P s. \\s'. P (ctes_of s') \ Q s s'\ f' \\_ s'. P (ctes_of s')\\ + \ rcorres + (\s s'. revokable_relation + (is_original_cap s) (null_filter (caps_of_state s)) (ctes_of s') + \ Q s s') + f f' + (\_ _ s s'. revokable_relation + (is_original_cap s) (null_filter (caps_of_state s)) (ctes_of s'))" + apply (rule rcorres_lift_conc[where p=ctes_of]) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply fastforce + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=is_original_cap]) + by (fastforce intro: hoare_weaken_pre)+ + +lemma arch_state_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (arch_state s) \ Q s s'\ f \\_ s. P (arch_state s)\; + \P s. \\s'. P (ksArchState s') \ Q s s'\ f' \\_ s'. P (ksArchState s')\\ + \ rcorres + (\s s'. (arch_state s, ksArchState s') \ arch_state_relation \ Q s s') + f f' + (\_ _ s s'. (arch_state s, ksArchState s') \ arch_state_relation)" + apply (rule rcorres_lift_conc[where p=ksArchState]) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + by (fastforce intro: no_fail_pre hoare_weaken_pre)+ + +lemma interrupt_state_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (interrupt_irq_node s) \ Q s s'\ f \\_ s. P (interrupt_irq_node s)\; + \P s'. \\s. P (interrupt_states s) \ Q s s'\ f \\_ s. P (interrupt_states s)\; + \P s. \\s'. P (ksInterruptState s') \ Q s s'\ f' \\_ s'. P (ksInterruptState s')\\ + \ rcorres + (\s s'. interrupt_state_relation + (interrupt_irq_node s) (interrupt_states s) (ksInterruptState s') + \ Q s s') + f f' + (\_ _ s s'. interrupt_state_relation + (interrupt_irq_node s) (interrupt_states s) (ksInterruptState s'))" + apply (rule rcorres_lift_conc) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply fastforce + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=interrupt_irq_node]) + by (fastforce intro: hoare_weaken_pre)+ + +lemma idle_sc_relation_lift_rcorres[rcorres_lift]: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s. \\s'. P (ksIdleSC s') \ Q s s'\ f' \\_ s'. P (ksIdleSC s')\\ + \ rcorres + (\s s'. idle_sc_ptr = ksIdleSC s' \ Q s s') + f f' + (\_ _ s s'. idle_sc_ptr = ksIdleSC s')" + apply (rule rcorres_lift_conc) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre hoare_weaken_pre) + apply (fastforce intro: no_fail_pre hoare_weaken_pre) + apply (fastforce intro: no_fail_pre hoare_weaken_pre) + apply wpsimp + apply (fastforce intro: no_fail_pre hoare_weaken_pre) + done + +lemma abs_conc_rel_lift_rcorres: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (p s) \ Q s s'\ f \\_ s. P (p s)\; + \P s. \\s'. P (p' s') \ Q s s'\ f' \\_ s'. P (p' s')\\ + \ rcorres (\s s'. R (p s) (p' s') \ Q s s') f f' (\_ _ s s'. R (p s) (p' s'))" + apply (rule rcorres_lift_conc) + apply (rule rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + by (fastforce intro: no_fail_pre hoare_weaken_pre)+ + +lemmas cur_thread_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=cur_thread and p'=ksCurThread and R="(=)"] + +lemmas idle_thread_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=idle_thread and p'=ksIdleThread and R="(=)"] + +lemmas machine_state_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=machine_state and p'=ksMachineState and R="(=)"] + +lemmas work_units_completed_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=work_units_completed and p'=ksWorkUnitsCompleted and R="(=)"] + +lemmas domain_index_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=domain_index and p'=ksDomScheduleIdx and R="(=)"] + +lemmas domain_list_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=domain_list and p'=ksDomSchedule and R="(=)"] + +lemmas cur_domain_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=cur_domain and p'=ksCurDomain and R="(=)"] + +lemmas domain_time_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=domain_time and p'=ksDomainTime and R="(=)"] + +lemmas consumed_time_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=consumed_time and p'=ksConsumedTime and R="(=)"] + +lemmas cur_time_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=cur_time and p'=ksCurTime and R="(=)"] + +lemmas cur_sc_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=cur_sc and p'=ksCurSc and R="(=)"] + +lemmas reprogram_timer_relation_lift_rcorres[rcorres_lift] = + abs_conc_rel_lift_rcorres[where p=reprogram_timer and p'=ksReprogramTimer and R="(=)"] + +locale HeapStateRelation_R = + assumes pspace_relation_heap_pspace_relation: + "\(s :: det_state) s'. pspace_relation (kheap s) (ksPSpace s') \ heap_pspace_relation s s'" + assumes ghost_relation_heap_ghost_relation: + "\(s :: det_state) s'. ghost_relation_wrapper s s' \ heap_ghost_relation_wrapper s s'" + +end diff --git a/proof/refine/InvariantUpdates_H.thy b/proof/refine/InvariantUpdates_H.thy index 45a7abc354..0b5f2bd0b5 100644 --- a/proof/refine/InvariantUpdates_H.thy +++ b/proof/refine/InvariantUpdates_H.thy @@ -154,7 +154,7 @@ declare valid_arch_tcb'_ksMachineState_update[simp] lemma valid_tcb'_ksMachineState_update[simp]: "valid_tcb' tcb (ksMachineState_update f s) = valid_tcb' tcb s" - by (auto simp: valid_tcb'_def valid_tcb_state'_def valid_bound_obj'_def + by (auto simp: valid_tcb'_def valid_bound_obj'_def split: option.splits thread_state.splits) lemma invs'_wu[simp]: @@ -449,12 +449,6 @@ lemma ct_idle_or_in_cur_domain'_ksReleaseQueue[simp]: unfolding ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def by simp -lemma valid_tcb_state'_update[simp]: - "\f. valid_tcb_state' ts (ksReadyQueues_update f s) = valid_tcb_state' ts s" - "\f. valid_tcb_state' ts (ksReadyQueuesL1Bitmap_update f s) = valid_tcb_state' ts s" - "\f. valid_tcb_state' ts (ksReadyQueuesL2Bitmap_update f s) = valid_tcb_state' ts s" - by (auto simp: valid_tcb_state'_def valid_bound_obj'_def split: thread_state.splits option.splits) - lemma ct_not_inQ_ksReleaseQueue_upd[simp]: "ct_not_inQ (ksReleaseQueue_update f s) = ct_not_inQ s" by (simp add: ct_not_inQ_def) diff --git a/proof/refine/InvariantsPre_H.thy b/proof/refine/InvariantsPre_H.thy index 1a6e56d76a..19dc81d486 100644 --- a/proof/refine/InvariantsPre_H.thy +++ b/proof/refine/InvariantsPre_H.thy @@ -134,4 +134,10 @@ lemma (in Arch) cteSizeBits_cte_level_bits: requalify_facts Arch.cteSizeBits_cte_level_bits +definition aobj_of' :: "kernel_object \ arch_kernel_object" where + "aobj_of' ko \ case ko of KOArch aobj \ Some aobj | _ \ None" + +abbreviation aobjs_of' :: "kernel_state \ obj_ref \ arch_kernel_object" where + "aobjs_of' s \ ksPSpace s |> aobj_of'" + end diff --git a/proof/refine/Invariants_H.thy b/proof/refine/Invariants_H.thy index aa964e5d27..8137b99172 100644 --- a/proof/refine/Invariants_H.thy +++ b/proof/refine/Invariants_H.thy @@ -221,17 +221,56 @@ abbreviation tcb_of' :: "kernel_object \ tcb option" where abbreviation tcbs_of' :: "kernel_state \ obj_ref \ tcb option" where "tcbs_of' s \ ksPSpace s |> tcb_of'" +abbreviation tcbStates_of' :: "kernel_state \ obj_ref \ thread_state option" where + "tcbStates_of' s \ tcbs_of' s ||> tcbState" + abbreviation tcbSCs_of :: "kernel_state \ obj_ref \ obj_ref option" where "tcbSCs_of s \ tcbs_of' s |> tcbSchedContext" -abbreviation scTCBs_of :: "kernel_state \ obj_ref \ obj_ref option" where - "scTCBs_of s \ scs_of' s |> scTCB" +abbreviation tcbIPCBuffers_of :: "kernel_state \ obj_ref \ vptr" where + "tcbIPCBuffers_of s \ tcbs_of' s ||> tcbIPCBuffer" -abbreviation sym_heap_tcbSCs where - "sym_heap_tcbSCs s \ sym_heap (tcbSCs_of s) (scTCBs_of s)" +abbreviation tcbArches_of :: "kernel_state \ obj_ref \ arch_tcb" where + "tcbArches_of s \ tcbs_of' s ||> tcbArch" -abbreviation sym_heap_scReplies where - "sym_heap_scReplies s \ sym_heap (scReplies_of s) (replySCs_of s)" +abbreviation tcbFaults_of :: "kernel_state \ obj_ref \ Fault_H.fault" where + "tcbFaults_of s \ tcbs_of' s |> tcbFault" + +abbreviation tcbCTables_of :: "kernel_state \ obj_ref \ cte" where + "tcbCTables_of s \ tcbs_of' s ||> tcbCTable" + +abbreviation tcbVTables_of :: "kernel_state \ obj_ref \ cte" where + "tcbVTables_of s \ tcbs_of' s ||> tcbVTable" + +abbreviation tcbFaultHandlers_of :: "kernel_state \ obj_ref \ cte" where + "tcbFaultHandlers_of s \ tcbs_of' s ||> tcbFaultHandler" + +abbreviation tcbTimeoutHandlers_of :: "kernel_state \ obj_ref \ cte" where + "tcbTimeoutHandlers_of s \ tcbs_of' s ||> tcbTimeoutHandler" + +abbreviation tcbIPCBufferFrames_of :: "kernel_state \ obj_ref \ cte" where + "tcbIPCBufferFrames_of s \ tcbs_of' s ||> tcbIPCBufferFrame" + +abbreviation tcbBoundNotifications_of :: "kernel_state \ obj_ref \ machine_word" where + "tcbBoundNotifications_of s \ tcbs_of' s |> tcbBoundNotification" + +abbreviation tcbSchedContexts_of :: "kernel_state \ obj_ref \ machine_word" where + "tcbSchedContexts_of s \ tcbs_of' s |> tcbSchedContext" + +abbreviation tcbYieldTos_of :: "kernel_state \ obj_ref \ machine_word" where + "tcbYieldTos_of s \ tcbs_of' s |> tcbYieldTo" + +abbreviation tcbMCPs_of :: "kernel_state \ obj_ref \ priority" where + "tcbMCPs_of s \ tcbs_of' s ||> tcbMCP" + +abbreviation tcbPriorities_of :: "kernel_state \ obj_ref \ priority" where + "tcbPriorities_of s \ tcbs_of' s ||> tcbPriority" + +abbreviation tcbDomains_of :: "kernel_state \ obj_ref \ domain" where + "tcbDomains_of s \ tcbs_of' s ||> tcbDomain" + +abbreviation tcbFlags_of :: "kernel_state \ obj_ref \ tcb_flags" where + "tcbFlags_of s \ tcbs_of' s ||> tcbFlags" abbreviation tcbSchedPrevs_of :: "kernel_state \ obj_ref \ obj_ref option" where "tcbSchedPrevs_of s \ tcbs_of' s |> tcbSchedPrev" @@ -239,20 +278,26 @@ abbreviation tcbSchedPrevs_of :: "kernel_state \ obj_ref \ obj_ref \ obj_ref option" where "tcbSchedNexts_of s \ tcbs_of' s |> tcbSchedNext" +abbreviation scTCBs_of :: "kernel_state \ obj_ref \ obj_ref option" where + "scTCBs_of s \ scs_of' s |> scTCB" + +abbreviation sym_heap_tcbSCs where + "sym_heap_tcbSCs s \ sym_heap (tcbSCs_of s) (scTCBs_of s)" + +abbreviation sym_heap_scReplies where + "sym_heap_scReplies s \ sym_heap (scReplies_of s) (replySCs_of s)" + abbreviation sym_heap_sched_pointers :: "global.kernel_state \ 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 epQueues_of :: "kernel_state \ obj_ref \ tcb_queue" where + "epQueues_of s \ eps_of' s ||> epQueue" abbreviation ntfn_of' :: "kernel_object \ notification option" where "ntfn_of' \ projectKO_opt" @@ -260,8 +305,23 @@ abbreviation ntfn_of' :: "kernel_object \ notification option" where 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" +abbreviation ntfnQueues_of :: "kernel_state \ obj_ref \ tcb_queue" where + "ntfnQueues_of s \ ntfns_of' s ||> ntfnQueue" + +abbreviation cte_of' :: "kernel_object \ cte option" where + "cte_of' \ projectKO_opt" + +abbreviation ctes_of' :: "kernel_state \ obj_ref \ cte" where + "ctes_of' s \ ksPSpace s |> cte_of'" + +abbreviation kernelData_at :: "kernel_state \ obj_ref \ bool" where + "kernelData_at s p \ ksPSpace s p = Some KOKernelData" + +abbreviation userDataDevice_at :: "kernel_state \ obj_ref \ bool" where + "userDataDevice_at s p \ ksPSpace s p = Some KOUserDataDevice" + +abbreviation userData_at :: "kernel_state \ obj_ref \ bool" where + "userData_at s p \ ksPSpace s p = Some KOUserData" definition tcb_cte_cases :: "machine_word \ ((tcb \ cte) \ ((cte \ cte) \ tcb \ tcb))" where "tcb_cte_cases \ [ 0 << cteSizeBits \ (tcbCTable, tcbCTable_update), @@ -278,10 +338,7 @@ type_synonym ref_set = "(obj_ref \ reftype) set" definition tcb_st_refs_of' :: "thread_state \ ref_set" where "tcb_st_refs_of' z \ case z of BlockedOnReply r \ if bound r then {(the r, TCBReply)} else {} - | BlockedOnReceive x _ r \ if bound r then {(x, TCBBlockedRecv), (the r, TCBReply)} - else {(x, TCBBlockedRecv)} - | BlockedOnSend x _ _ _ _ \ {(x, TCBBlockedSend)} - | BlockedOnNotification x \ {(x, TCBSignal)} + | BlockedOnReceive x _ r \ if bound r then {(the r, TCBReply)} else {} | _ \ {}" definition tcb_bound_refs' :: "tcb \ ref_set" where @@ -292,25 +349,12 @@ definition tcb_bound_refs' :: "tcb \ ref_set" where definition refs_of_tcb' :: "tcb \ ref_set" where "refs_of_tcb' tcb \ tcb_st_refs_of' (tcbState tcb) \ tcb_bound_refs' tcb" -definition ep_q_refs_of' :: "endpoint \ (obj_ref \ reftype) set" where - "ep_q_refs_of' ep \ case ep of - IdleEP => {} - | RecvEP q => set q \ {EPRecv} - | SendEP q => set q \ {EPSend}" - -definition ntfn_q_refs_of' :: "Structures_H.ntfn \ (obj_ref \ reftype) set" where - "ntfn_q_refs_of' ntfn \ case ntfn of - IdleNtfn => {} - | WaitingNtfn q => set q \ {NTFNSignal} - | ActiveNtfn b => {}" - definition ntfn_bound_refs' :: "obj_ref option \ (obj_ref \ reftype) set" where "ntfn_bound_refs' t \ set_option t \ {NTFNBound}" definition refs_of_ntfn' :: "notification \ ref_set" where - "refs_of_ntfn' ntfn \ ntfn_q_refs_of' (ntfnObj ntfn) - \ get_refs NTFNBound (ntfnBoundTCB ntfn) - \ get_refs NTFNSchedContext (ntfnSc ntfn)" + "refs_of_ntfn' ntfn \ get_refs NTFNBound (ntfnBoundTCB ntfn) + \ get_refs NTFNSchedContext (ntfnSc ntfn)" definition refs_of_sc' :: "sched_context \ ref_set" where "refs_of_sc' sc \ get_refs SCNtfn (scNtfn sc) @@ -338,7 +382,6 @@ lemmas refs_of'_defs[simp] = refs_of_tcb'_def refs_of_ntfn'_def refs_of_sc'_def definition refs_of' :: "kernel_object \ ref_set" where "refs_of' x \ case x of KOTCB tcb => refs_of_tcb' tcb - | KOEndpoint ep => ep_q_refs_of' ep | KONotification ntfn => refs_of_ntfn' ntfn | KOSchedContext sc => refs_of_sc' sc | KOReply r => refs_of_reply' r @@ -363,8 +406,7 @@ definition live_sc' :: "sched_context \ bool" where \ bound (scYieldFrom sc) \ bound (scNtfn sc) \ scReply sc \ None" definition live_ntfn' :: "notification \ bool" where - "live_ntfn' ntfn \ bound (ntfnBoundTCB ntfn) \ bound (ntfnSc ntfn) - \ (\ts. ntfnObj ntfn = WaitingNtfn ts)" + "live_ntfn' ntfn \ bound (ntfnBoundTCB ntfn) \ bound (ntfnSc ntfn) \ (ntfnState ntfn = Waiting)" definition live_reply' :: "reply \ bool" where "live_reply' reply \ bound (replyTCB reply) \ bound (replyNext reply) \ bound (replyPrev reply)" @@ -380,7 +422,7 @@ primrec live0' :: "Structures_H.kernel_object \ bool" where \ tcbInReleaseQueue tcb \ (tcbState tcb \ Inactive \ tcbState tcb \ IdleThreadState))" | "live0' (KOCTE cte) = False" -| "live0' (KOEndpoint ep) = (ep \ IdleEP)" +| "live0' (KOEndpoint ep) = (epState ep \ IdleEPState)" | "live0' (KONotification ntfn) = live_ntfn' ntfn" | "live0' (KOSchedContext sc) = live_sc' sc" | "live0' (KOReply r) = live_reply' r" @@ -448,6 +490,11 @@ definition ex_nonz_cap_to' :: "obj_ref \ kernel_state \ definition if_live_then_nonz_cap' :: "kernel_state \ bool" where "if_live_then_nonz_cap' s \ \ptr. ko_wp_at' live' ptr s \ ex_nonz_cap_to' ptr s" +defs if_live_then_nonz_cap'_asrt_def: + "if_live_then_nonz_cap'_asrt \ if_live_then_nonz_cap'" + +declare if_live_then_nonz_cap'_asrt_def[simp] + fun cte_refs' :: "capability \ obj_ref \ obj_ref set" where "cte_refs' (CNodeCap ref bits _ _) x = (\x. ref + (x << cteSizeBits)) ` {0 .. mask bits}" | "cte_refs' (ThreadCap ref) x = (\x. ref + x) ` dom tcb_cte_cases" @@ -562,6 +609,9 @@ definition valid_bound_obj' :: "(machine_word \ kernel_state \ bool) \ machine_word option \ kernel_state \ bool" where "valid_bound_obj' f p_opt s \ case p_opt of None \ True | Some p \ f p s" +abbreviation valid_bound_ep' :: "obj_ref option \ kernel_state \ bool" where + "valid_bound_ep' \ valid_bound_obj' ep_at'" + abbreviation valid_bound_ntfn' :: "obj_ref option \ kernel_state \ bool" where "valid_bound_ntfn' \ valid_bound_obj' ntfn_at'" @@ -574,14 +624,6 @@ abbreviation valid_bound_sc' :: "obj_ref option \ kernel_state \ kernel_state \ bool" where "valid_bound_reply' \ valid_bound_obj' reply_at'" -definition valid_tcb_state' :: "thread_state \ kernel_state \ bool" where - "valid_tcb_state' ts s \ case ts of - BlockedOnReceive ref _ rep \ ep_at' ref s \ valid_bound_reply' rep s - | BlockedOnSend ref _ _ _ _ \ ep_at' ref s - | BlockedOnNotification ref \ ntfn_at' ref s - | BlockedOnReply r \ valid_bound_reply' r s - | _ \ True" - definition valid_ipc_buffer_ptr' :: "machine_word \ kernel_state \ bool" where "valid_ipc_buffer_ptr' a s \ is_aligned a msg_align_bits \ typ_at' UserDataT (a && ~~ mask pageBits) s" @@ -593,7 +635,6 @@ lemmas opt_tcb_at'_def = none_top_def definition valid_tcb' :: "tcb \ kernel_state \ bool" where "valid_tcb' t s \ (\(getF, setF) \ ran tcb_cte_cases. s \' cteCap (getF t)) - \ valid_tcb_state' (tcbState t) s \ is_aligned (tcbIPCBuffer t) msg_align_bits \ valid_bound_ntfn' (tcbBoundNotification t) s \ valid_bound_sc' (tcbSchedContext t) s @@ -606,26 +647,17 @@ definition valid_tcb' :: "tcb \ kernel_state \ bool" whe \ tcbFlags t && ~~ tcbFlagMask = 0 \ valid_arch_tcb' (tcbArch t) s" -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)) - | 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) - | ActiveNtfn b \ True) - \ valid_bound_tcb' (ntfnBoundTCB ntfn) s - \ valid_bound_sc' (ntfnSc ntfn) s" + "valid_ntfn' ntfn s \ + ((\msg. ntfnMsgIdentifier ntfn = Some msg) \ ntfnState ntfn = Active) + \ valid_bound_tcb' (ntfnBoundTCB ntfn) s + \ valid_bound_sc' (ntfnSc ntfn) s" definition valid_sched_context' :: "sched_context \ kernel_state \ bool" where "valid_sched_context' sc s \ valid_bound_ntfn' (scNtfn sc) s \ valid_bound_tcb' (scTCB sc) s \ valid_bound_tcb' (scYieldFrom sc) s - \ valid_bound_reply' (scReply sc) s \ MIN_REFILLS \ length (scRefills sc) \ length (scRefills sc) = refillAbsoluteMax' (minSchedContextBits + scSize sc) \ scRefillMax sc \ length (scRefills sc) @@ -647,16 +679,14 @@ definition valid_sched_context_size' :: "sched_context \ bool" where definition valid_obj' :: "kernel_object \ kernel_state \ bool" where "valid_obj' ko s \ case ko of - KOEndpoint endpoint \ valid_ep' endpoint s - | KONotification notification \ valid_ntfn' notification s + KONotification notification \ valid_ntfn' notification s | KOSchedContext sc \ valid_sched_context' sc s \ valid_sched_context_size' sc | KOReply reply \ valid_reply' reply s | KOKernelData \ False - | KOUserData \ True - | KOUserDataDevice \ True | KOTCB tcb \ valid_tcb' tcb s | KOCTE cte \ valid_cte' cte s - | KOArch ako \ valid_arch_obj' ako" + | KOArch ako \ valid_arch_obj' ako + | _ \ True" definition pspace_aligned' :: "kernel_state \ bool" @@ -664,6 +694,11 @@ where "pspace_aligned' s \ \x \ dom (ksPSpace s). is_aligned x (objBitsKO (the (ksPSpace s x)))" +defs pspace_aligned'_asrt_def: + "pspace_aligned'_asrt \ pspace_aligned'" + +declare pspace_aligned'_asrt_def[simp] + definition pspace_bounded' :: "kernel_state \ bool" where "pspace_bounded' s \ \x \ dom (ksPSpace s). objBitsKO (the (ksPSpace s x)) < word_bits" @@ -673,6 +708,11 @@ where "pspace_distinct' s \ \x \ dom (ksPSpace s). ps_clear x (objBitsKO (the (ksPSpace s x))) s" +defs pspace_distinct'_asrt_def: + "pspace_distinct'_asrt \ pspace_distinct'" + +declare pspace_distinct'_asrt_def[simp] + definition pspace_canonical' :: "kernel_state \ bool" where "pspace_canonical' s \ \p \ dom (ksPSpace s). canonical_address p" @@ -969,6 +1009,15 @@ fun runnable' :: "thread_state \ bool" where definition inQ :: "domain \ priority \ tcb \ bool" where "inQ d p tcb \ tcbQueued tcb \ tcbPriority tcb = p \ tcbDomain tcb = d" +lemma inQ_lift: + "(\P d p. \\s. P (inQ d p |< tcbs_of' s) \ Q s\ f \\_ s. P (inQ d p |< tcbs_of' s)\) + \ (\P. \\s. P (\d p. inQ d p |< tcbs_of' s) \ Q s\ f \\_ s. P (\d p. inQ d p |< tcbs_of' s)\)" + apply (rule hoare_liftP_ext_pre_conj[where f="\s d p. inQ d p |< tcbs_of' s"]) + apply (rename_tac d) + apply (rule_tac f="\s p. inQ d p |< tcbs_of' s" in hoare_liftP_ext_pre_conj) + apply wpsimp + done + lemma inQ_implies_tcbQueueds_of: "(inQ domain priority |< tcbs_of' s') tcbPtr \ (tcbQueued |< tcbs_of' s') tcbPtr" by (clarsimp simp: opt_map_def opt_pred_def inQ_def split: option.splits) @@ -1060,26 +1109,52 @@ definition valid_bitmapQ_except :: "domain \ priority \ lemmas bitmapQ_defs = valid_bitmapQ_def valid_bitmapQ_except_def bitmapQ_def bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def +\ \Determines whether a thread is in a notification or endpoint queue\ +primrec inIPCQueueThreadState :: "thread_state \ bool" where + "inIPCQueueThreadState Running = False" +| "inIPCQueueThreadState Inactive = False" +| "inIPCQueueThreadState Restart = False" +| "inIPCQueueThreadState (BlockedOnReceive _ _ _) = True" +| "inIPCQueueThreadState (BlockedOnSend _ _ _ _ _) = True" +| "inIPCQueueThreadState (BlockedOnNotification _) = True" +| "inIPCQueueThreadState IdleThreadState = False" +| "inIPCQueueThreadState (BlockedOnReply _) = False" + +abbreviation sched_flag_set :: "kernel_state \ obj_ref \ bool" where + "sched_flag_set s t \ + (tcbQueued |< tcbs_of' s) t + \ (tcbInReleaseQueue |< tcbs_of' s) t + \ (inIPCQueueThreadState |< tcbStates_of' s) t" + \ \ - The tcbSchedPrev and tcbSchedNext fields of a TCB are used only to indicate membership in the - release queue or one of the ready queues. \ -definition valid_sched_pointers_2 :: - "(obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ (obj_ref \ bool) \ (obj_ref \ bool) \ bool " + Any TCB for which the @{const tcbSchedPrev} or @{const tcbSchedNext} field is not @{const None} + must be in either one of the ready queues, the release queue, or the queue of an endpoint or + notification.\ +definition valid_sched_pointers_except_set_2 :: + "obj_ref set \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ (obj_ref \ bool) \ bool" where - "valid_sched_pointers_2 prevs nexts ready release \ - \ptr. prevs ptr \ None \ nexts ptr \ None \ ready ptr \ release ptr" + "valid_sched_pointers_except_set_2 except prevs nexts flags \ + \ptr. ptr \ except + \ (prevs ptr \ None \ nexts ptr \ None \ flags ptr)" -abbreviation valid_sched_pointers :: "kernel_state \ bool" where - "valid_sched_pointers s \ - valid_sched_pointers_2 (tcbSchedPrevs_of s) (tcbSchedNexts_of s) - (tcbQueued |< tcbs_of' s) (tcbInReleaseQueue |< tcbs_of' s)" +abbreviation valid_sched_pointers_except_set :: "obj_ref set \ kernel_state \ bool" where + "valid_sched_pointers_except_set except s \ + valid_sched_pointers_except_set_2 + except (tcbSchedPrevs_of s) (tcbSchedNexts_of s) (sched_flag_set s)" -lemmas valid_sched_pointers_def = valid_sched_pointers_2_def +abbreviation "valid_sched_pointers_except_2 t \ valid_sched_pointers_except_set_2 {t}" -lemma valid_sched_pointersD: - "\valid_sched_pointers s; \ (tcbQueued |< tcbs_of' s) t; \ (tcbInReleaseQueue |< tcbs_of' s) t\ - \ tcbSchedPrevs_of s t = None \ tcbSchedNexts_of s t = None" - by (fastforce simp: valid_sched_pointers_def in_opt_pred opt_map_red) +abbreviation "valid_sched_pointers_except t s \ + valid_sched_pointers_except_2 t (tcbSchedPrevs_of s) (tcbSchedNexts_of s) (sched_flag_set s)" + +abbreviation "valid_sched_pointers_2 \ valid_sched_pointers_except_set_2 {}" + +abbreviation "valid_sched_pointers s \ + valid_sched_pointers_2 (tcbSchedPrevs_of s) (tcbSchedNexts_of s) (sched_flag_set s)" + +lemmas valid_sched_pointers_except_set_def = valid_sched_pointers_except_set_2_def +lemmas valid_sched_pointers_except_def = valid_sched_pointers_except_set_2_def +lemmas valid_sched_pointers_def = valid_sched_pointers_except_set_2_def definition tcb_in_cur_domain' :: "machine_word \ kernel_state \ bool" where "tcb_in_cur_domain' t \ \s. obj_at' (\tcb. ksCurDomain s = tcbDomain tcb) t s" @@ -1254,7 +1329,7 @@ definition invs' :: "kernel_state \ bool" where \ sym_refs (list_refs_of_replies' s) \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' s + \ if_unsafe_then_cap' s \ valid_global_refs' s \ valid_arch_state' s \ valid_irq_node' (irq_node' s) s \ valid_irq_handlers' s @@ -1342,6 +1417,21 @@ abbreviation defs ct_active'_asrt_def: "ct_active'_asrt \ ct_active'" +defs tcb_at'_asrt_def: + "tcb_at'_asrt \ \tcbPtr s. tcb_at' tcbPtr s" + +declare tcb_at'_asrt_def[simp] + +defs ep_at'_asrt_def: + "ep_at'_asrt \ ep_at'" + +declare ep_at'_asrt_def[simp] + +defs sc_at'_asrt_def: + "sc_at'_asrt \ \scPtr s. sc_at' scPtr s" + +declare sc_at'_asrt_def[simp] + defs invs'_asrt_def: "invs'_asrt \ invs'" @@ -1365,29 +1455,6 @@ locale mdb_order = mdb_next + assumes no_0: "no_0 m" assumes chain: "mdb_chain_0 m" -\ \---------------------------------------------------------------------------\ -section "Alternate split rules for preserving subgoal order" - -lemma ntfn_splits[split]: - " P (case ntfn of Structures_H.ntfn.IdleNtfn \ f1 - | Structures_H.ntfn.ActiveNtfn x \ f2 x - | Structures_H.ntfn.WaitingNtfn x \ f3 x) = - ((ntfn = Structures_H.ntfn.IdleNtfn \ P f1) \ - (\x2. ntfn = Structures_H.ntfn.ActiveNtfn x2 \ - P (f2 x2)) \ - (\x3. ntfn = Structures_H.ntfn.WaitingNtfn x3 \ - P (f3 x3)))" - "P (case ntfn of Structures_H.ntfn.IdleNtfn \ f1 - | Structures_H.ntfn.ActiveNtfn x \ f2 x - | Structures_H.ntfn.WaitingNtfn x \ f3 x) = - (\ (ntfn = Structures_H.ntfn.IdleNtfn \ \ P f1 \ - (\x2. ntfn = Structures_H.ntfn.ActiveNtfn x2 \ - \ P (f2 x2)) \ - (\x3. ntfn = Structures_H.ntfn.WaitingNtfn x3 \ - \ P (f3 x3))))" - by (rule ntfn.splits)+ - -\ \---------------------------------------------------------------------------\ section "Lemmas" @@ -1472,8 +1539,6 @@ lemma cte_at'_def: lemmas refs_of'_simps[simp] = refs_of'_def[split_simps kernel_object.split] lemmas tcb_st_refs_of'_simps[simp] = tcb_st_refs_of'_def[split_simps thread_state.split] -lemmas ep_q_refs_of'_simps[simp] = ep_q_refs_of'_def[split_simps endpoint.split] -lemmas ntfn_q_refs_of'_simps[simp] = ntfn_q_refs_of'_def[split_simps ntfn.split] lemma ntfn_bound_refs'_simps[simp]: "ntfn_bound_refs' (Some t) = {(t, NTFNBound)}" @@ -1481,8 +1546,6 @@ lemma ntfn_bound_refs'_simps[simp]: by (auto simp: ntfn_bound_refs'_def) lemma prod_in_refsD: - "\ref x y. (x, ref) \ ep_q_refs_of' y \ ref \ {EPRecv, EPSend}" - "\ref x y. (x, ref) \ ntfn_q_refs_of' y \ ref \ {NTFNSignal}" "\ref x y. (x, ref) \ tcb_st_refs_of' y \ ref \ {TCBBlockedRecv, TCBReply, TCBSignal, TCBBlockedSend}" "\ref x y. (x, ref) \ tcb_bound_refs' y \ ref \ {TCBBound, TCBSchedContext, TCBYieldTo}" apply (rename_tac ep; case_tac ep; simp) @@ -1494,20 +1557,8 @@ lemma prod_in_refsD: \\ Useful rewrite rules for extracting the existence of objects on the other side of symmetric refs. There should be a rewrite corresponding to each entry of @{term symreftype}.\ lemma refs_of_rev': - "(x, TCBBlockedSend) \ refs_of' ko = - (\tcb. ko = KOTCB tcb \ (\a b c d. tcbState tcb = BlockedOnSend x a b c d))" - "(x, TCBBlockedRecv) \ refs_of' ko = - (\tcb. ko = KOTCB tcb \ (\a b. tcbState tcb = BlockedOnReceive x a b))" - "(x, TCBSignal) \ refs_of' ko = - (\tcb. ko = KOTCB tcb \ tcbState tcb = BlockedOnNotification x)" "(x, TCBBound) \ refs_of' ko = (\tcb. ko = KOTCB tcb \ (tcbBoundNotification tcb = Some x))" - "(x, EPSend) \ refs_of' ko = - (\ep. ko = KOEndpoint ep \ (\q. ep = SendEP q \ x \ set q))" - "(x, EPRecv) \ refs_of' ko = - (\ep. ko = KOEndpoint ep \ (\q. ep = RecvEP q \ x \ set q))" - "(x, NTFNSignal) \ refs_of' ko = - (\ntfn. ko = KONotification ntfn \ (\q. ntfnObj ntfn = WaitingNtfn q \ x \ set q))" "(x, NTFNBound) \ refs_of' ko = (\ntfn. ko = KONotification ntfn \ (ntfnBoundTCB ntfn = Some x))" "(x, TCBSchedContext) \ refs_of' ko = @@ -1530,16 +1581,13 @@ lemma refs_of_rev': (\sc. ko = KOSchedContext sc \ scYieldFrom sc = Some x)" by (auto simp: refs_of'_def tcb_st_refs_of'_def - ep_q_refs_of'_def - ntfn_q_refs_of'_def ntfn_bound_refs'_def tcb_bound_refs'_def in_get_refs split: Structures_H.kernel_object.splits Structures_H.thread_state.splits Structures_H.endpoint.splits - Structures_H.notification.splits - Structures_H.ntfn.splits) + Structures_H.notification.splits) lemma hyp_refs_of'_simps[simp]: "hyp_refs_of' (KOCTE cte) = {}" @@ -1562,18 +1610,6 @@ lemma projectKO_opt_tcbD: "projectKO_opt ko = Some (tcb :: tcb) \ ko = KOTCB tcb" by (cases ko, simp_all add: projectKO_opt_tcb) -lemma st_tcb_at_refs_of_rev': - "ko_wp_at' (\ko. (x, TCBBlockedRecv) \ refs_of' ko) t s - = st_tcb_at' (\ts. \a b. ts = BlockedOnReceive x a b) t s" - "ko_wp_at' (\ko. (x, TCBBlockedSend) \ refs_of' ko) t s - = st_tcb_at' (\ts. \a b c d. ts = BlockedOnSend x a b c d) t s" - "ko_wp_at' (\ko. (x, TCBSignal) \ refs_of' ko) t s - = st_tcb_at' (\ts. ts = BlockedOnNotification x) t s" - by (fastforce simp: refs_of_rev' pred_tcb_at'_def obj_at'_real_def - projectKO_opt_tcb[where e="KOTCB y" for y] - elim!: ko_wp_at'_weakenE - dest!: projectKO_opt_tcbD)+ - lemma state_refs_of'_elemD: "\ ref \ state_refs_of' s x \ \ ko_wp_at' (\obj. ref \ refs_of' obj) x s" by (clarsimp simp add: state_refs_of'_def ko_wp_at'_def @@ -1686,9 +1722,8 @@ lemma hyp_sym_refs_obj_atD': lemma refs_of_live'[simplified]: "refs_of' ko - idle_refs \ {} \ live' ko" apply (cases ko; simp add: live'_def) - apply clarsimp apply (rename_tac notification) - apply (case_tac "ntfnObj notification"; + apply (case_tac "ntfnState notification"; fastforce simp: live_ntfn'_def) apply (fastforce simp: tcb_bound_refs'_def) apply (fastforce simp: live_sc'_def) @@ -2418,18 +2453,6 @@ lemma (in Invariants_H_cte_ats) typ_at_lift_cte_at': apply (wpsimp wp: hoare_vcg_disj_lift hoare_vcg_ex_lift hoare_vcg_all_lift x)+ done -lemma typ_at_lift_valid_tcb_state'_strong: - assumes ep: "\p. f \\s. P (typ_at' EndpointT p s)\" - and reply: "\p. f \\s. P (typ_at' ReplyT p s)\" - and ntfn: "\p. f \\s. P (typ_at' NotificationT p s)\" - shows "f \\s. P (valid_tcb_state' st s)\" - unfolding valid_tcb_state'_def valid_bound_reply'_def - apply (case_tac st ; clarsimp split: option.splits, - wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift hoare_vcg_conj_lift_N[where N=P] - typ_at_lift_ep'_strong[OF ep] typ_at_lift_reply'_strong[OF reply] - typ_at_lift_ntfn'_strong[OF ntfn]) - done - (* proof is identical for all architectures *) lemma (in Arch) koType_obj_range': "koTypeOf k = koTypeOf k' \ koTypeOf k = SchedContextT \ objBitsKO k = objBitsKO k' \ obj_range' p k = obj_range' p k'" @@ -2452,34 +2475,32 @@ lemma valid_dom_schedule'_lift: by (wpsimp wp: dsi ds) lemma valid_bound_tcb_lift: - "(\T p. f \typ_at' T p\) \ f \valid_bound_tcb' tcb\" - by (auto simp: valid_bound_tcb'_def valid_def typ_ats'[symmetric] split: option.splits) + "(\P T p. f \\s. P (typ_at' T p s)\) \ f \\s. P (valid_bound_tcb' tcb s)\" + by (clarsimp simp: valid_bound_tcb'_def valid_def typ_ats'[symmetric] split: option.splits) lemma valid_bound_sc_lift: - "(\T p. f \typ_at' T p\) \ f \valid_bound_sc' tcb\" + "(\P T p. f \\s. P (typ_at' T p s)\) \ f \\s. P (valid_bound_sc' tcb s)\" by (auto simp: valid_bound_obj'_def valid_def typ_ats'[symmetric] split: option.splits) lemma valid_bound_reply_lift: - "(\T p. f \typ_at' T p\) \ f \valid_bound_reply' tcb\" + "(\P T p. f \\s. P (typ_at' T p s)\) \ f \\s. P (valid_bound_reply' tcb s)\" by (auto simp: valid_bound_tcb'_def valid_def typ_ats'[symmetric] split: option.splits) lemma valid_bound_ntfn_lift: - "(\T p. f \typ_at' T p\) \ f \valid_bound_ntfn' ntfn\" + "(\P T p. f \\s. P (typ_at' T p s)\) \ f \\s. P (valid_bound_ntfn' ntfn s)\" + by (auto simp: valid_bound_obj'_def valid_def typ_ats'[symmetric] split: option.splits) + +lemma valid_bound_ep_lift: + "(\P T p. f \\s. P (typ_at' T p s)\) \ f \\s. P (valid_bound_ep' ntfn s)\" by (auto simp: valid_bound_obj'_def valid_def typ_ats'[symmetric] split: option.splits) lemma valid_ntfn_lift': - "(\T p. f \typ_at' T p\) \ f \valid_ntfn' ntfn\" + "(\P T p. f \\s. P (typ_at' T p s)\) \ f \valid_ntfn' ntfn\" unfolding valid_ntfn'_def - apply (cases "ntfnObj ntfn"; clarsimp) - apply (wpsimp wp: valid_bound_tcb_lift valid_bound_sc_lift) - apply (wpsimp wp: valid_bound_tcb_lift valid_bound_sc_lift) - apply (wpsimp wp: hoare_vcg_ball_lift typ_at_lift_tcb'_strong[where P=id, simplified]) - apply (wpsimp wp: valid_bound_tcb_lift valid_bound_sc_lift) - apply simp - done + by (wpsimp wp: valid_bound_tcb_lift valid_bound_sc_lift) lemma valid_sc_lift': - "(\T p. f \typ_at' T p\) \ f \valid_sched_context' sc\" + "(\P T p. f \\s. P (typ_at' T p s)\) \ f \valid_sched_context' sc\" unfolding valid_sched_context'_def by (wpsimp wp: valid_bound_ntfn_lift valid_bound_tcb_lift valid_bound_reply_lift) @@ -3086,6 +3107,15 @@ lemma irq_revocable: "\ m p = Some (CTE IRQControlCap n); irq_control m \ \ mdbRevocable n" unfolding irq_control_def by blast +abbreviation is_sched_linked :: "machine_word \ kernel_state \ bool" where + "is_sched_linked tcbPtr s \ tcbSchedPrevs_of s tcbPtr \ None \ tcbSchedNexts_of s tcbPtr \ None" + +lemma valid_sched_pointersD: + "\valid_sched_pointers s; \ (tcbQueued |< tcbs_of' s) t; \ (tcbInReleaseQueue |< tcbs_of' s) t; + \ (inIPCQueueThreadState |< tcbStates_of' s) t\ + \ \ is_sched_linked t s" + by (fastforce simp: valid_sched_pointers_def in_opt_pred opt_map_red) + lemma sch_act_wf_arch [simp]: "sch_act_wf sa (ksArchState_update f s) = sch_act_wf sa s" by (cases sa) (simp_all add: ct_in_state'_def tcb_in_cur_domain'_def) @@ -3307,10 +3337,6 @@ lemma invs_no_loops [elim!]: apply (simp add: invs'_def valid_pspace'_def valid_mdb'_def) done -lemma invs_iflive'[elim!]: - "invs' s \ if_live_then_nonz_cap' s" - by (simp add: invs'_def) - lemma invs_unsafe_then_cap' [elim!]: "invs' s \ if_unsafe_then_cap' s" by (simp add: invs'_def) @@ -3380,7 +3406,6 @@ lemma invs'_ksDomScheduleIdx: unfolding invs'_def valid_dom_schedule'_def by clarsimp lemmas invs'_implies = - invs_iflive' invs_unsafe_then_cap' invs_no_0_obj' invs_pspace_aligned' diff --git a/proof/refine/KHeap_R.thy b/proof/refine/KHeap_R.thy index 6a303d5568..54021ede3a 100644 --- a/proof/refine/KHeap_R.thy +++ b/proof/refine/KHeap_R.thy @@ -8,9 +8,18 @@ theory KHeap_R imports - ArchMachine_R + ArchMachine_R ArchHeapStateRelationLemmas begin +(* requalify interface lemmas which can't be locale assumptions due to free type variable *) +arch_requalify_facts + aobjs_relation_lift_rcorres + heap_ghost_relation_lift_rcorres + +declare aobjs_relation_lift_rcorres[rcorres_lift] + +declare heap_ghost_relation_lift_rcorres[rcorres_lift] + translations (type) "'a kernel" <=(type) "kernel_state \ ('a \ kernel_state) set \ bool" @@ -320,7 +329,7 @@ lemma pspace_relation_tcb_at: shows "tcb_at t s" using assms by (fastforce elim!: pspace_dom_relatedE obj_relation_cutsE - simp: other_obj_relation_def obj_at_def is_tcb_def opt_map_def + simp: obj_at_def is_tcb_def opt_map_def split: Structures_A.kernel_object.split_asm if_split_asm option.splits) lemma pspace_relation_sc_at: @@ -329,7 +338,7 @@ lemma pspace_relation_sc_at: shows "sc_at scp s" using assms by (fastforce elim!: pspace_dom_relatedE obj_relation_cutsE - simp: other_obj_relation_def other_aobj_relation_def is_sc_obj obj_at_def opt_map_def + simp: other_aobj_relation_def is_sc_obj obj_at_def opt_map_def split: Structures_A.kernel_object.split_asm if_split_asm option.splits arch_kernel_obj.splits kernel_object.splits) @@ -642,11 +651,12 @@ lemma setObject_tcb_strongest: updateObject_default_def ps_clear_upd) done -method setObject_easy_cases = +method setObject_easy_cases uses simp = clarsimp simp: setObject_def in_monad split_def valid_def lookupAround2_char1, erule rsubst[where P=P'], rule ext, clarsimp simp: updateObject_cte updateObject_default_def in_monad typeError_def opt_map_def opt_pred_def projectKO_opts_defs + simp split: if_split_asm Structures_H.kernel_object.split_asm @@ -704,10 +714,69 @@ lemma setObject_cte_inQ[wp]: supply inQ_def[simp] by setObject_easy_cases +lemma setObject_cte_tcbStates_of'[wp]: + "setObject c (cte :: cte) \\s. P' (tcbStates_of' s)\" + by setObject_easy_cases + lemma setObject_reply_tcbs_of'[wp]: "setObject c (reply :: reply) \\s. P' (tcbs_of' s)\" by setObject_easy_cases +lemma setObject_cte_tcbSCs_of[wp]: + "setObject c (cte::cte) \\s. P' (tcbSCs_of s)\" + by setObject_easy_cases + +lemma setObject_ntfns_of'[wp]: + "setObject c (cte :: cte) \\s. P' (ntfns_of' s)\" + "setObject c (reply :: reply) \\s. P' (ntfns_of' s)\" + "setObject c (tcb :: tcb) \\s. P' (ntfns_of' s)\" + "setObject c (sched_context :: sched_context) \\s. P' (ntfns_of' s)\" + "setObject c (endpoint :: endpoint) \\s. P' (ntfns_of' s)\" + by setObject_easy_cases+ + +lemma setObject_eps_of'[wp]: + "setObject c (cte :: cte) \\s. P' (eps_of' s)\" + "setObject c (reply :: reply) \\s. P' (eps_of' s)\" + "setObject c (tcb :: tcb) \\s. P' (eps_of' s)\" + "setObject c (sched_context :: sched_context) \\s. P' (eps_of' s)\" + "setObject c (notification :: notification) \\s. P' (eps_of' s)\" + by setObject_easy_cases+ + +lemma setObject_ctes_of'[wp]: + "setObject c (sc :: sched_context) \\s. P' (ctes_of' s)\" + "setObject c (reply :: reply) \\s. P' (ctes_of' s)\" + "setObject c (tcb :: tcb) \\s. P' (ctes_of' s)\" + "setObject c (notification :: notification) \\s. P' (ctes_of' s)\" + "setObject c (endpoint :: endpoint) \\s. P' (ctes_of' s)\" + by setObject_easy_cases+ + +lemma setObject_kernelData_at[wp]: + "setObject c (sc::sched_context) \\s. P' (kernelData_at s)\" + "setObject c (reply::reply) \\s. P' (kernelData_at s)\" + "setObject c (tcb::tcb) \\s. P' (kernelData_at s)\" + "setObject c (notification::notification) \\s. P' (kernelData_at s)\" + "setObject c (endpoint::endpoint) \\s. P' (kernelData_at s)\" + "setObject c (cte::cte) \\s. P' (kernelData_at s)\" + by (setObject_easy_cases simp: gen_objBits_simps; fastforce)+ + +lemma setObject_userDataDevice_at[wp]: + "setObject c (sc::sched_context) \\s. P' (userDataDevice_at s)\" + "setObject c (reply::reply) \\s. P' (userDataDevice_at s)\" + "setObject c (tcb::tcb) \\s. P' (userDataDevice_at s)\" + "setObject c (notification::notification) \\s. P' (userDataDevice_at s)\" + "setObject c (endpoint::endpoint) \\s. P' (userDataDevice_at s)\" + "setObject c (cte::cte) \\s. P' (userDataDevice_at s)\" + by (setObject_easy_cases simp: gen_objBits_simps; fastforce)+ + +lemma setObject_userData_at[wp]: + "setObject c (sc::sched_context) \\s. P' (userData_at s)\" + "setObject c (reply::reply) \\s. P' (userData_at s)\" + "setObject c (tcb::tcb) \\s. P' (userData_at s)\" + "setObject c (notification::notification) \\s. P' (userData_at s)\" + "setObject c (endpoint::endpoint) \\s. P' (userData_at s)\" + "setObject c (cte::cte) \\s. P' (userData_at s)\" + by (setObject_easy_cases simp: gen_objBits_simps; fastforce)+ + \\ Warning: this may not be a weakest precondition. `setObject c` asserts that there's already a correctly-typed object at `c`, so a weaker valid precondition might be @@ -736,6 +805,15 @@ lemma setObject_scs_of'[wp]: "setObject c (endpoint::endpoint) \\s. P' (scs_of' s)\" by setObject_easy_cases+ +lemma setObject_aobjs_of'[wp]: + "setObject c (sc :: sched_context) \\s. P' (aobjs_of' s)\" + "setObject c (reply :: reply) \\s. P' (aobjs_of' s)\" + "setObject c (tcb :: tcb) \\s. P' (aobjs_of' s)\" + "setObject c (notification :: notification) \\s. P' (aobjs_of' s)\" + "setObject c (endpoint :: endpoint) \\s. P' (aobjs_of' s)\" + "setObject c (cte :: cte) \\s. P' (aobjs_of' s)\" + by (setObject_easy_cases simp: aobj_of'_def)+ + lemmas setReply_replies_of' = setObject_reply_replies_of'[folded setReply_def] crunch setNotification, setEndpoint, setSchedContext @@ -820,10 +898,6 @@ private method getObject_valid_obj = rule hoare_chain, rule getObject_valid_obj; clarsimp simp: gen_objBits_simps valid_obj'_def scBits_pos_power2 -lemma get_ep'_valid_ep[wp]: - "\ valid_objs' \ getEndpoint ep \ valid_ep' \" - unfolding getEndpoint_def by getObject_valid_obj - lemma get_ntfn'_valid_ntfn[wp]: "\ valid_objs' \ getNotification ep \ valid_ntfn' \" unfolding getNotification_def by getObject_valid_obj @@ -1066,7 +1140,7 @@ lemma getEndpoint_corres: apply (clarsimp simp: state_relation_def pspace_relation_def obj_at'_def) apply (drule bspec) apply blast - apply (simp add: other_obj_relation_def) + apply (simp add: ep_relation_def ep_relation_cut_def) done declare magnitudeCheck_inv [wp] @@ -1185,8 +1259,8 @@ lemma typ_at'_koTypeOf: "ko_at' ob' ptr b \ typ_at' (koTypeOf (injectKO ob')) ptr b" by (auto simp: typ_at'_def ko_wp_at'_def obj_at'_def project_inject) -lemmas gen_obj_at_simps = obj_at_def obj_at'_def map_to_ctes_upd_other - a_type_def gen_objBits_simps other_obj_relation_def +lemmas gen_obj_at_simps = + obj_at_def obj_at'_def map_to_ctes_upd_other a_type_def gen_objBits_simps lemma get_reply_corres: "corres reply_relation (reply_at ptr) (reply_at' ptr) @@ -1201,7 +1275,7 @@ lemma get_reply_corres: apply (clarsimp simp add: state_relation_def pspace_relation_def obj_at'_def) apply (drule bspec) apply blast - apply (simp add: other_obj_relation_def) + apply simp done lemma getReply_TCB_corres: @@ -1212,23 +1286,6 @@ lemma getReply_TCB_corres: apply (clarsimp simp: reply_relation_def) done -lemma get_sc_corres: - "corres (\sc sc'. \n. sc_relation sc n sc') (sc_at ptr) (sc_at' ptr) - (get_sched_context ptr) (getSchedContext ptr)" - apply (rule corres_no_failI) - apply wp - apply (simp add: get_sched_context_def getSchedContext_def get_object_def - getObject_def bind_assoc gets_the_def) - apply (clarsimp simp: in_monad split_def bind_def gets_def get_def return_def - dest!: readObject_misc_ko_at') - apply (clarsimp simp: assert_def fail_def obj_at_def return_def is_sc_obj_def - split: Structures_A.kernel_object.splits) - apply (clarsimp simp add: state_relation_def pspace_relation_def obj_at'_def) - apply (drule bspec) - apply blast - apply (fastforce simp add: other_obj_relation_def) - done - lemma get_sc_corres_size: "corres (\sc sc'. sc_relation sc n sc') (sc_obj_at n ptr) (sc_at' ptr) @@ -1244,7 +1301,7 @@ lemma get_sc_corres_size: apply (clarsimp simp: state_relation_def pspace_relation_def obj_at'_def) apply (drule bspec) apply blast - apply (clarsimp simp: other_obj_relation_def scBits_simps sc_relation_def gen_objBits_simps) + apply (clarsimp simp: scBits_simps sc_relation_def gen_objBits_simps) done lemma setObject_qs[wp]: @@ -1268,13 +1325,6 @@ lemma setObject_qsL2[wp]: apply (wp x | simp)+ done -lemma setObject_it[wp]: - assumes x: "\p q n ko. \\s. P (ksIdleThread s)\ updateObject val p q n ko \\rv s. P (ksIdleThread s)\" - shows "\\s. P (ksIdleThread s)\ setObject t val \\rv s. P (ksIdleThread s)\" - apply (simp add: setObject_def split_def) - apply (wp x | simp)+ - done - \\`idle_tcb_ps val` asserts that `val` is a pspace_storable value which corresponds to an idle TCB.\ definition idle_tcb_ps :: "('a :: pspace_storable) \ bool" where @@ -1308,6 +1358,13 @@ lemma threadRead_tcb_at'': lemmas threadRead_tcb_at' = threadRead_tcb_at''[simplified] +lemma threadRead_tcb_at'_eq: + "(\y. threadRead f t s = Some y) = tcb_at' t s" + apply (intro iffI) + apply (fastforce elim!: threadRead_tcb_at') + apply (fastforce intro: no_ofailD[OF no_ofail_threadRead]) + done + lemma ovalid_threadRead: "\\s. tcb_at' t s \ (\tcb. ko_at' tcb t s \ P (f tcb) s)\ threadRead f t @@ -1380,56 +1437,6 @@ lemma setObject_ko_wp_at: split: if_split_asm) done -lemma setObject_idle': - fixes v :: "'a :: pspace_storable" - assumes R: "\ko s y n. - (updateObject v ko ptr y n s) = (updateObject_default v ko ptr y n s)" - assumes z: "\P p q n ko. - \\s. P (ksIdleThread s)\ - updateObject v p q n ko - \\rv s. P (ksIdleThread s)\" - shows "\\s. valid_idle' s - \ (ptr = ksIdleThread s - \ (\val :: 'a. idle_tcb_ps val) - \ idle_tcb_ps v) - \ (ptr = idle_sc_ptr - \ (\val :: 'a. idle_sc_ps val) - \ idle_sc_ps v)\ - setObject ptr v - \\rv s. valid_idle' s\" - apply (simp add: valid_idle'_def pred_tcb_at'_def o_def) - apply (rule hoare_pre) - apply (rule hoare_lift_Pf2 [where f="ksIdleThread"]) - apply (simp add: pred_tcb_at'_def obj_at'_real_def) - apply (wpsimp wp: setObject_ko_wp_at[OF R]) - apply (wp z) - apply (rule conjI) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def idle_tcb_ps_def - idle_sc_ps_def) - apply (rename_tac tcb sc obj) - apply (drule_tac x=obj and y=tcb in spec2, clarsimp simp: project_inject) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def idle_tcb_ps_def - idle_sc_ps_def) - apply (rename_tac tcb sc obj) - apply (drule_tac x=obj and y=sc in spec2, clarsimp simp: project_inject) - done - -lemma getNotification_corres: - "corres ntfn_relation (ntfn_at ptr) (ntfn_at' ptr) - (get_notification ptr) (getNotification ptr)" - apply (rule corres_no_failI) - apply wp - apply (simp add: get_simple_ko_def getNotification_def get_object_def - getObject_def bind_assoc gets_the_def) - apply (clarsimp simp: in_monad split_def bind_def gets_def get_def return_def - dest!: readObject_misc_ko_at') - apply (clarsimp simp: assert_def fail_def obj_at_def return_def is_ntfn partial_inv_def) - apply (clarsimp simp add: state_relation_def pspace_relation_def obj_at'_def) - apply (drule bspec) - apply blast - apply (simp add: other_obj_relation_def) - done - lemma ct_in_state_thread_state_lift': assumes ct: "\P. \\s. P (ksCurThread s)\ f \\_ s. P (ksCurThread s)\" assumes st: "\t. \st_tcb_at' P t\ f \\_. st_tcb_at' P t\" @@ -1440,61 +1447,6 @@ lemma ct_in_state_thread_state_lift': apply (drule (1) use_valid [OF _ st], assumption) done -lemma sch_act_wf_lift: - assumes tcb: "\P t. \st_tcb_at' P t\ f \\rv. st_tcb_at' P t\" - assumes tcb_cd: "\t. \ tcb_in_cur_domain' t\ f \\_ . tcb_in_cur_domain' t \" - assumes kCT: "\P. \\s. P (ksCurThread s)\ f \\_ s. P (ksCurThread s)\" - assumes ksA: "\P. \\s. P (ksSchedulerAction s)\ f \\_ s. P (ksSchedulerAction s)\" - shows - "\\s. sch_act_wf (ksSchedulerAction s) s\ - f - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (clarsimp simp: valid_def) - apply (frule (1) use_valid [OF _ ksA]) - apply (case_tac "ksSchedulerAction b", simp_all) - apply (drule (2) use_valid [OF _ ct_in_state_thread_state_lift' [OF kCT tcb]]) - apply (clarsimp) - apply (rule conjI) - apply (drule (2) use_valid [OF _ tcb]) - apply (drule (2) use_valid [OF _ tcb_cd]) - done - -lemma tcb_in_cur_domain'_lift: - assumes a: "\P. \\s. P (ksCurDomain s)\ f \\_ s. P (ksCurDomain s)\" - assumes b: "\x. \obj_at' (\tcb. x = tcbDomain tcb) t\ f \\_. obj_at' (\tcb. x = tcbDomain tcb) t\" - shows "\ tcb_in_cur_domain' t \ f \ \_. tcb_in_cur_domain' t \" - apply (simp add: tcb_in_cur_domain'_def) - apply (rule_tac f="ksCurDomain" in hoare_lift_Pf) - apply (rule b) - apply (rule a) - done - -lemma ct_idle_or_in_cur_domain'_lift: - assumes a: "\P. \\s. P (ksCurDomain s)\ f \\_ s. P (ksCurDomain s)\" - assumes b: "\P. \\s. P (ksSchedulerAction s)\ f \\_ s. P (ksSchedulerAction s)\" - assumes c: "\P. \\s. P (ksIdleThread s)\ f \\_ s. P (ksIdleThread s)\" - assumes d: "\P. \\s. P (ksCurThread s)\ f \\_ s. P (ksCurThread s)\" - assumes e: "\d t t'. \\s. t = t' \ obj_at' (\tcb. d = tcbDomain tcb) t s\ - f - \\_ s. t = t' \ obj_at' (\tcb. d = tcbDomain tcb) t s\" - shows "\ ct_idle_or_in_cur_domain' \ f \ \_. ct_idle_or_in_cur_domain' \" - apply (simp add: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) - apply (rule_tac f="ksCurThread" in hoare_lift_Pf) - apply (rule_tac f="ksIdleThread" in hoare_lift_Pf) - apply (rule_tac f="ksSchedulerAction" in hoare_lift_Pf) - apply (rule_tac f="ksCurDomain" in hoare_lift_Pf) - apply (wp hoare_vcg_imp_lift) - apply (rule e) - apply simp - apply (rule a) - apply (rule b) - apply (rule c) - apply (rule d) - done - -lemmas cur_tcb_lift = - hoare_lift_Pf [where f = ksCurThread and P = tcb_at', folded cur_tcb'_def] - lemma valid_mdb'_lift: "(\P. f \\s. P (ctes_of s)\) \ f \valid_mdb'\" unfolding valid_mdb'_def @@ -1564,14 +1516,6 @@ lemma setObject_pspace_domain_valid[wp]: in_monad lookupAround2_char1 updateObject_size split: if_split_asm) -lemma ct_not_inQ_lift: - assumes sch_act: "\P. \\s. P (ksSchedulerAction s)\ f \\_ s. P (ksSchedulerAction s)\" - and not_inQ: "\\s. obj_at' (Not \ tcbQueued) (ksCurThread s) s\ - f \\_ s. obj_at' (Not \ tcbQueued) (ksCurThread s) s\" - shows "\ct_not_inQ\ f \\_. ct_not_inQ\" - unfolding ct_not_inQ_def - by (rule hoare_convert_imp [OF sch_act not_inQ]) - lemma obj_at'_ignoring_obj: "obj_at' (\_ :: 'a :: pspace_storable. P) p s = (obj_at' (\_ :: 'a. True) p s \ P)" by (rule iffI; clarsimp simp: obj_at'_def) @@ -1636,6 +1580,7 @@ locale pspace_only' = begin lemma it[wp]: "\P. f \\s. P (ksIdleThread s)\" + and ksIdleSC[wp]: "\P. f \\s. P (ksIdleSC s)\" and ct[wp]: "\P. f \\s. P (ksCurThread s)\" and cur_domain[wp]: "\P. f \\s. P (ksCurDomain s)\" and ksDomSchedule[wp]: "\P. f \\s. P (ksDomSchedule s)\" @@ -1750,8 +1695,6 @@ lemma pspace_domain_valid[wp]: "f ptr val \pspace_domain_valid\" unfolding f_def by (wpsimp simp: default_update updateObject_default_def in_monad) -lemmas x = ct_not_inQ_lift[OF ksSchedulerAction] - lemma setObject_wp: "\\s. P (set_obj' ptr obj s)\ setObject ptr (obj :: 'a :: pspace_storable) @@ -2079,36 +2022,14 @@ lemma valid_bitmaps[wp]: "f p v \valid_bitmaps\" by (wpsimp wp: valid_bitmaps_lift) -lemma tcb_in_cur_domain'[wp]: - "f p v \tcb_in_cur_domain' t\" - by (rule tcb_in_cur_domain'_lift; wp) - lemma pred_tcb_at'[wp]: "f p v \ \s. Q (pred_tcb_at' proj P t s) \" unfolding pred_tcb_at'_def by wp -lemma sch_act_wf[wp]: - "f p v \\s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift) - -lemma cur_tcb'[wp]: - "f p v \cur_tcb'\" - by (wp cur_tcb_lift) - lemma cap_to'[wp]: "f p' v \ex_nonz_cap_to' p\" by (wp ex_nonz_cap_to_pres') -lemma ct_not_inQ[wp]: - "f p v \ct_not_inQ\" - apply (rule ct_not_inQ_lift, wp) - apply (rule hoare_lift_Pf[where f=ksCurThread]; wp) - done - -lemma ct_idle_or_in_cur_domain'[wp]: - "f p v \ ct_idle_or_in_cur_domain' \" - by (rule ct_idle_or_in_cur_domain'_lift; wp) - end locale simple_non_reply_ko' = simple_ko' "f:: obj_ref \ 'a::pspace_storable \ unit kernel" @@ -2176,18 +2097,6 @@ locale simple_non_tcb_non_sc_ko' = "g:: obj_ref \ 'a kernel" + simple_non_tcb_ko' "f:: obj_ref \ 'a::pspace_storable \ unit kernel" "g:: obj_ref \ 'a kernel" for f g -begin - -\\ preservation of valid_idle' requires us to not be touching either of an SC or a TCB \ - -lemma idle'[wp]: - "f p v \valid_idle'\" - unfolding f_def - apply (wp setObject_idle' - ; simp add: default_update updateObject_default_inv idle_tcb_ps_def idle_sc_ps_def) - done - -end locale simple_non_tcb_non_sc_non_reply_ko' = simple_non_tcb_non_sc_ko' "f:: obj_ref \ 'a::pspace_storable \ unit kernel" @@ -2310,12 +2219,6 @@ lemmas set_reply_valid_objs'[wp] = lemmas set_sc_valid_objs'[wp] = set_sc'.valid_objs'[simplified valid_obj'_def pred_conj_def, simplified] -lemma set_ep_state_refs_of'[wp]: - "\\s. P ((state_refs_of' s) (epptr := ep_q_refs_of' ep))\ - setEndpoint epptr ep - \\rv s. P (state_refs_of' s)\" - by (wp set_ep'.state_refs_of') (simp flip: fun_upd_def) - lemma setObject_state_hyp_refs_of': assumes x: "updateObject val = updateObject_default val" assumes y: "(1 :: machine_word) < 2 ^ objBits val" @@ -2360,14 +2263,6 @@ lemma set_ep_state_hyp_refs_of'[wp]: apply (wp setObject_state_hyp_refs_of'; simp add: gen_objBits_simps state_hyp_refs_of'_ep) done -lemma set_ntfn_state_refs_of'[wp]: - "\\s. P ((state_refs_of' s) (p := ntfn_q_refs_of' (ntfnObj ntfn) \ - get_refs NTFNBound (ntfnBoundTCB ntfn) \ - get_refs NTFNSchedContext (ntfnSc ntfn)))\ - setNotification p ntfn - \\_ s. P (state_refs_of' s)\" - by (wp set_ntfn'.state_refs_of') (simp flip: fun_upd_def) - lemma state_hyp_refs_of'_ntfn: "ntfn_at' ntfn s \ (state_hyp_refs_of' s) (ntfn := {}) = state_hyp_refs_of' s" by (rule ext) (clarsimp simp: state_hyp_refs_of'_def obj_at'_def) @@ -2484,25 +2379,44 @@ lemma setObject_tcb_pspace_no_overlap': end +lemma get_object_det_wp[wp]: + "det_wp (obj_at \ ptr) (get_object ptr)" + unfolding get_object_def + apply wpsimp + apply (clarsimp simp: obj_at_def) + done + +lemma put_det_wp[wp]: + "det_wp \ (put s)" + unfolding put_def + by (clarsimp simp: det_wp_def) + +lemma set_object_det_wp[wp]: + "det_wp (obj_at (\k. a_type obj = a_type k) ptr) (set_object ptr obj)" + unfolding set_object_def + apply (wpsimp wp: get_object_wp) + apply (clarsimp simp: obj_at_def) + done + +lemma in_set_notification: + "(rv, s') \ fst (set_notification ptr ntfn s) + \ s' = s\kheap := (kheap s)(ptr \ Structures_A.Notification ntfn)\" + by (clarsimp simp: set_simple_ko_def set_object_def get_object_def in_monad) + +lemma in_set_endpoint: + "(rv, s') \ fst (set_endpoint ptr ep s) + \ s' = s\kheap := (kheap s)(ptr \ Structures_A.Endpoint ep)\" + by (clarsimp simp: set_simple_ko_def set_object_def get_object_def in_monad) + lemma sym_heap_sched_pointers_lift: assumes prevs: "\P. f \\s. P (tcbSchedPrevs_of s)\" assumes nexts: "\P. f \\s. P (tcbSchedNexts_of s)\" shows "f \sym_heap_sched_pointers\" by (rule_tac f=tcbSchedPrevs_of in hoare_lift_Pf2; wpsimp wp: assms) -lemma ep_redux_simps': - "ep_q_refs_of' (case xs of [] \ IdleEP | y # ys \ SendEP xs) - = (set xs \ {EPSend})" - "ep_q_refs_of' (case xs of [] \ IdleEP | y # ys \ RecvEP xs) - = (set xs \ {EPRecv})" - "ntfn_q_refs_of' (case xs of [] \ IdleNtfn | y # ys \ WaitingNtfn xs) - = (set xs \ {NTFNSignal})" - by (fastforce split: list.splits - simp: valid_ep_def valid_ntfn_def)+ - lemma endpoint_live': - "\ko_at' ep ptr s; ep \ IdleEP\ \ ko_wp_at' live' ptr s" - by (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) + "\ko_at' ep ptr s; epState ep \ IdleEPState\ \ ko_wp_at' live' ptr s" + by (clarsimp simp: live'_def ko_wp_at'_def obj_at'_def) lemma aligned_distinct_obj_atI': "\ ksPSpace s x = Some ko; pspace_aligned' s; pspace_distinct' s; pspace_bounded' s; ko = injectKO v \ @@ -2603,26 +2517,30 @@ lemma obj_relation_cuts_range_limit: "\ (p', P) \ obj_relation_cuts ko p; P ko ko' \ \ \x n. p' = p + x \ is_aligned x n \ n \ obj_bits ko \ x \ mask (obj_bits ko)" apply (erule (1) obj_relation_cutsE; clarsimp) - apply (drule (1) wf_cs_nD) - apply (clarsimp simp: cte_map_def) - apply (rule_tac x=cte_level_bits in exI) - apply (simp add: is_aligned_shift of_bl_shift_cte_level_bits) - apply (rule_tac x=minSchedContextBits in exI) - apply (simp add: objBits_simps' min_sched_context_bits_def) - apply (rule_tac x=replySizeBits in exI) - apply (simp add: replySizeBits_def) - apply (rule_tac x=tcbBlockSizeBits in exI) - apply (simp add: tcbBlockSizeBits_def) - apply (rule_tac x=pteBits in exI) - apply (simp add: bit_simps is_aligned_shift mask_def pteBits_def) - apply word_bitwise - apply (rule_tac x=pageBits in exI) - apply (simp add: is_aligned_shift pbfs_atleast_pageBits is_aligned_mult_triv2) - apply (simp add: mask_def shiftl_t2n mult_ac) - apply (frule word_less_power_trans2, rule pbfs_atleast_pageBits) - apply (simp add: pbfs_less_wb'[unfolded word_bits_def, simplified]) + apply (drule (1) wf_cs_nD) + apply (clarsimp simp: cte_map_def) + apply (rule_tac x=cte_level_bits in exI) + apply (simp add: is_aligned_shift of_bl_shift_cte_level_bits) + apply (rule_tac x=minSchedContextBits in exI) + apply (simp add: objBits_simps' min_sched_context_bits_def) + apply (rule_tac x=replySizeBits in exI) + apply (simp add: replySizeBits_def) + apply (rule_tac x=tcbBlockSizeBits in exI) + apply (simp add: tcbBlockSizeBits_def) + apply (rule_tac x=epSizeBits in exI) + apply (simp add: epSizeBits_def) + apply (rule_tac x=ntfnSizeBits in exI) + apply (simp add: ntfnSizeBits_def) + apply (rule_tac x=pteBits in exI) + apply (simp add: bit_simps is_aligned_shift mask_def pteBits_def) + apply word_bitwise + apply (rule_tac x=pageBits in exI) + apply (simp add: is_aligned_shift pbfs_atleast_pageBits is_aligned_mult_triv2) + apply (simp add: mask_def shiftl_t2n mult_ac) + apply (frule word_less_power_trans2, rule pbfs_atleast_pageBits) apply (simp add: pbfs_less_wb'[unfolded word_bits_def, simplified]) - apply fastforce+ + apply (simp add: pbfs_less_wb'[unfolded word_bits_def, simplified]) + apply fastforce+ done lemma obj_relation_cuts_range_mask_range: @@ -2643,7 +2561,7 @@ lemma obj_relation_cuts_obj_bits: pbfs_atleast_pageBits[simplified bit_simps] pteBits_def table_size_def pte_bits_def ptTranslationBits_def pageBits_def sc_relation_def) - apply (cases ko; simp add: other_obj_relation_def other_aobj_relation_def objBits_defs + apply (cases ko; simp add: other_aobj_relation_def objBits_defs split: kernel_object.splits) apply (case_tac ako; case_tac ko'; clarsimp simp: archObjSize_def other_aobj_relation_def is_other_obj_relation_type_def @@ -2666,38 +2584,6 @@ lemma cte_at'_same_type: apply (rule disjI2, rule_tac x=n in exI, clarsimp simp: typ_at'_same_type) done -lemma valid_ep'_ep_update: - "\ valid_objs' s; valid_ep' ep s; ep_at' epPtr s; ksPSpace s x = Some (KOEndpoint obj) \ - \ valid_ep' obj (s\ksPSpace := (ksPSpace s)(epPtr \ KOEndpoint ep)\)" - apply (erule (1) valid_objsE') - apply (fastforce simp: valid_objs'_def valid_obj'_def obj_at'_def valid_ep'_def - split: endpoint.splits) - done - -lemma valid_cap'_ep_update: - "\ valid_cap' cap s; valid_objs' s; valid_ep' ep s; ep_at' epPtr s \ - \ valid_cap' cap (s\ksPSpace := (ksPSpace s)(epPtr \ KOEndpoint ep)\)" - supply ps_clear_upd[simp] - apply (clarsimp simp: typ_at'_same_type ko_wp_at'_def cte_at'_same_type - valid_cap'_def obj_at'_def objBits_simps - split: endpoint.splits capability.splits) - apply fastforce+ - apply (clarsimp split: zombie_type.splits simp: obj_at'_def typ_at'_same_type) - apply (intro conjI impI; clarsimp) - apply (drule_tac x=addr in spec, clarsimp) - apply (drule_tac x=addr in spec, clarsimp) - apply (clarsimp simp: objBits_simps page_table_at'_def frame_at'_def - valid_arch_cap'_def valid_arch_cap_ref'_def - split: arch_capability.splits option.splits if_split_asm - | rule_tac ko="KOEndpoint obj" in typ_at'_same_type[where p'=epPtr] - | simp)+ - apply fastforce - apply (clarsimp simp: valid_untyped'_def ko_wp_at'_def obj_range'_def split: if_split_asm) - apply (drule_tac x=epPtr in spec, fastforce simp: objBits_simps)+ - apply (drule_tac x=addr in spec, fastforce) - apply fastforce - done - lemma valid_cap'_reply_update: "\ valid_cap' cap s; valid_objs' s; valid_reply' reply s; reply_at' rptr s \ \ valid_cap' cap (s\ksPSpace := (ksPSpace s)(rptr \ KOReply reply)\)" @@ -2732,8 +2618,7 @@ lemma sym_ref_Receive_or_Reply_replyTCB': apply (clarsimp simp: ko_wp_at'_def) apply (erule disjE; clarsimp) apply (rename_tac koa; case_tac koa; - simp add: get_refs_def2 ep_q_refs_of'_def ntfn_q_refs_of'_def - tcb_st_refs_of'_def tcb_bound_refs'_def + simp add: get_refs_def2 tcb_st_refs_of'_def tcb_bound_refs'_def split: endpoint.split_asm ntfn.split_asm thread_state.split_asm if_split_asm)+ done @@ -2745,61 +2630,10 @@ lemma sym_ref_replyTCB_Receive_or_Reply: apply (clarsimp simp: state_refs_of'_def pred_tcb_at'_def obj_at'_def) apply (clarsimp simp: ko_wp_at'_def) apply (rename_tac tcb; case_tac tcb; - simp add: get_refs_def2 ntfn_q_refs_of'_def - tcb_st_refs_of'_def tcb_bound_refs'_def + simp add: get_refs_def2 tcb_st_refs_of'_def tcb_bound_refs'_def split: ntfn.split_asm thread_state.split_asm)+ done -lemma sym_ref_BlockedOnSend_SendEP': - "\ sym_refs (state_refs_of' s); st_tcb_at' ((=) (BlockedOnSend eptr p1 p2 p3 p4)) tp s\ - \ \list. ko_wp_at' ((=) (KOEndpoint (SendEP list))) eptr s" - apply (simp add: pred_tcb_at'_def) - apply (drule (1) sym_refs_obj_atD'[rotated, where p=tp]) - apply (clarsimp simp: state_refs_of'_def obj_at'_def) - apply (drule sym[where s="BlockedOnSend _ _ _ _ _"]) - apply (clarsimp simp: ko_wp_at'_def) - apply (rename_tac ko; case_tac ko; - simp add: get_refs_def2 ep_q_refs_of'_def ntfn_q_refs_of'_def - tcb_st_refs_of'_def tcb_bound_refs'_def - split: endpoint.split_asm ntfn.split_asm thread_state.split_asm if_split_asm)+ - done - -lemma sym_ref_BlockedOnReceive_RecvEP': - "\ sym_refs (state_refs_of' s); st_tcb_at' ((=) (BlockedOnReceive eptr pl ropt)) tp s\ - \ \list. ko_wp_at' ((=) (KOEndpoint (RecvEP list))) eptr s" - apply (simp add: pred_tcb_at'_def) - apply (drule (1) sym_refs_obj_atD'[rotated, where p=tp]) - apply (clarsimp simp: state_refs_of'_def obj_at'_def) - apply (drule sym[where s="BlockedOnReceive _ _ _"]) - apply (clarsimp simp: ko_wp_at'_def split: if_split_asm) - apply (rename_tac ko koa; case_tac ko; - simp add: get_refs_def2 ep_q_refs_of'_def ntfn_q_refs_of'_def - tcb_st_refs_of'_def tcb_bound_refs'_def - split: endpoint.split_asm ntfn.split_asm thread_state.split_asm if_split_asm) - apply (rename_tac ko; case_tac ko; - simp add: get_refs_def2 ep_q_refs_of'_def ntfn_q_refs_of'_def - tcb_st_refs_of'_def tcb_bound_refs'_def - split: endpoint.split_asm ntfn.split_asm thread_state.split_asm if_split_asm) - done - -lemma Receive_or_Send_ep_at': - "\ st = BlockedOnReceive epPtr pl rp \ st = BlockedOnSend epPtr p1 p2 p3 p4; - valid_objs' s; st_tcb_at' ((=) st) t s\ - \ ep_at' epPtr s" - apply (drule (1) tcb_in_valid_state') - by (fastforce simp: obj_at'_def valid_tcb_state'_def) - -lemma ep_queued_st_tcb_at': - "\P. \ko_at' ep ptr s; \rt. (t, rt) \ ep_q_refs_of' ep; - valid_objs' s; sym_refs (state_refs_of' s); - \bo bbadge bgrant breply bcall r. P (Structures_H.BlockedOnSend bo bbadge bgrant breply bcall) \ - P (Structures_H.BlockedOnReceive bo bgrant r) \ - \ st_tcb_at' P t s" - apply (case_tac ep, simp_all) - apply (frule(1) sym_refs_ko_atD', clarsimp, erule (1) my_BallE, - clarsimp simp: pred_tcb_at'_def refs_of_rev' obj_at'_def ko_wp_at'_def)+ - done - (* cross lemmas *) context begin interpretation Arch . (*FIXME: arch-split RT*) @@ -2828,10 +2662,10 @@ lemma pspace_aligned_cross: apply (rule is_aligned_weaken) apply (rule is_aligned_shiftl_self, simp) - \\SchedContext, Reply, TCB\ + \\SchedContext, Reply, TCB, EP, Ntfn\ apply ((clarsimp simp: minSchedContextBits_def min_sched_context_bits_def replySizeBits_def - sc_relation_def tcbBlockSizeBits_def - elim!: is_aligned_weaken)+)[3] + sc_relation_def tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def + elim!: is_aligned_weaken)+)[5] \\PageTable\ apply (clarsimp simp: archObjSize_def pteBits_def table_size_def ptTranslationBits_def pte_bits_def) @@ -2847,7 +2681,6 @@ lemma pspace_aligned_cross: apply (rule is_aligned_shift) \\Other non-arch\ - apply (simp add: other_obj_relation_def) apply (clarsimp simp: bit_simps' tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def split: kernel_object.splits Structures_A.kernel_object.splits) \\Other arch\ @@ -2875,7 +2708,6 @@ lemma pspace_relation_pspace_bounded': elim!: is_aligned_weaken) \\other_obj_relation\ - apply (simp add: other_obj_relation_def) apply (clarsimp simp: bit_simps' tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def split: kernel_object.splits Structures_A.kernel_object.splits) @@ -2896,7 +2728,7 @@ lemma pspace_distinct_cross: apply (frule (1) pspace_alignedD') apply (frule (1) pspace_alignedD) apply (frule pspace_relation_pspace_bounded') - apply (frule (1) pspace_boundedD') + apply (frule (1) pspace_boundedD') apply (rule ps_clearI, assumption) apply (case_tac ko'; simp add: scBits_pos_power2 objBits_simps' bit_simps' @@ -2911,17 +2743,15 @@ lemma pspace_distinct_cross: apply (case_tac "p = x") apply clarsimp apply (erule (1) obj_relation_cutsE; clarsimp) - apply (clarsimp simp: cte_relation_def cte_map_def objBits_simps) - apply (rule_tac n=cteSizeBits in is_aligned_add_step_le'; assumption?) - apply (clarsimp simp: pte_relation_def objBits_simps) - apply (rule_tac n=pteBits in is_aligned_add_step_le'; assumption?) - apply (simp add: objBitsKO_Data) - apply (rule_tac n=pageBits in is_aligned_add_step_le'; assumption?) - apply (case_tac ko; simp split: if_split_asm) - apply (rename_tac ako, - case_tac ako; - simp add: is_other_obj_relation_type_def a_type_def split: if_split_asm) - apply (case_tac ako; simp add: is_other_obj_relation_type_def split: if_split_asm) + apply (clarsimp simp: cte_relation_def cte_map_def objBits_simps) + apply (rule_tac n=cteSizeBits in is_aligned_add_step_le'; assumption?) + apply (clarsimp simp: pte_relation_def objBits_simps) + apply (rule_tac n=pteBits in is_aligned_add_step_le'; assumption?) + apply (simp add: objBitsKO_Data) + apply (rule_tac n=pageBits in is_aligned_add_step_le'; assumption?) + apply (rename_tac ako, + case_tac ako; + simp add: is_other_obj_relation_type_def a_type_def split: if_split_asm) apply (frule (1) obj_relation_cuts_obj_bits) apply (drule (2) obj_relation_cuts_range_mask_range)+ apply (prop_tac "x' \ mask_range p' (objBitsKO ko')", simp add: mask_def add_diff_eq) @@ -2936,6 +2766,325 @@ lemma obj_at'_is_canonical: end +lemma tcbs_relation_tcb_relation_abs: + "\kheap s ptr = Some (TCB tcb); tcbs_relation s s'\ + \ \tcb'. ksPSpace s' ptr = Some (KOTCB tcb') \ tcb_relation tcb tcb'" + by (fastforce simp: map_relation_def opt_map_def tcbs_of_kh_def split: option.splits) + +lemma tcbs_relation_tcb_relation_abs_obj_at': + "\kheap s ptr = Some (TCB tcb); tcbs_relation s s'; pspace_aligned' s'; pspace_distinct' s'\ + \ \tcb'. ko_at' tcb' ptr s' \ tcb_relation tcb tcb'" + apply (frule (1) tcbs_relation_tcb_relation_abs) + apply (fastforce dest: aligned'_distinct'_ko_at'I[where 'a=tcb]) + done + +lemma tcbs_relation_tcb_relation_conc: + "\ksPSpace s' ptr = Some (KOTCB tcb'); tcbs_relation s s'\ + \ \tcb. kheap s ptr = Some (TCB tcb) \ tcb_relation tcb tcb'" + by (force simp: map_relation_def opt_map_def tcbs_of_kh_def split: option.splits) + +lemma tcb_at_cross_tcbs_relation: + "\tcb_at tcb_ptr s; tcbs_relation s s'; pspace_aligned' s'; pspace_distinct' s'\ + \ tcb_at' tcb_ptr s'" + apply (clarsimp simp: obj_at_def is_tcb_def) + apply (clarsimp split: Structures_A.kernel_object.splits) + apply (frule (3) tcbs_relation_tcb_relation_abs_obj_at') + apply (clarsimp simp: obj_at'_def) + done + +lemma eps_relation_ep_relation_abs: + "\kheap s ptr = Some (Structures_A.Endpoint ep); eps_relation s s'\ + \ \ep'. ksPSpace s' ptr = Some (KOEndpoint ep') \ ep_relation ep ep'" + by (fastforce simp: map_relation_def opt_map_def eps_of_kh_def split: option.splits ) + +lemma eps_relation_ep_relation_abs_obj_at': + "\kheap s ptr = Some (Structures_A.Endpoint ep); eps_relation s s'; + pspace_aligned' s'; pspace_distinct' s'\ + \ \ep'. ko_at' ep' ptr s' \ ep_relation ep ep'" + apply (frule (1) eps_relation_ep_relation_abs) + apply (fastforce dest: aligned'_distinct'_ko_at'I[where 'a=endpoint]) + done + +lemma eps_relation_ep_relation_conc: + "\ksPSpace s' ptr = Some (KOEndpoint ep'); eps_relation s s'\ + \ \ep. kheap s ptr = Some (Structures_A.Endpoint ep) \ ep_relation ep ep'" + by (force simp: map_relation_def opt_map_def eps_of_kh_def split: option.splits) + +lemma ntfns_relation_ntfn_relation_abs: + "\kheap s ptr = Some (Structures_A.Notification ntfn); ntfns_relation s s'\ + \ \ntfn'. ksPSpace s' ptr = Some (KONotification ntfn') \ ntfn_relation ntfn ntfn'" + by (fastforce simp: map_relation_def opt_map_def tcbs_of_kh_def split: option.splits) + +lemma ntfns_relation_ntfn_relation_abs_obj_at': + "\kheap s ptr = Some (Structures_A.Notification ntfn); ntfns_relation s s'; + pspace_aligned' s'; pspace_distinct' s'\ + \ \ntfn'. ko_at' ntfn' ptr s' \ ntfn_relation ntfn ntfn'" + apply (frule (1) ntfns_relation_ntfn_relation_abs) + apply (fastforce dest: aligned'_distinct'_ko_at'I[where 'a=notification]) + done + +lemma ntfns_relation_ntfn_relation_conc: + "\ksPSpace s' ptr = Some (KONotification ntfn'); ntfns_relation s s'\ + \ \ntfn. kheap s ptr = Some (Structures_A.Notification ntfn) \ ntfn_relation ntfn ntfn'" + by (force simp: map_relation_def opt_map_def split: option.splits) + +lemma scs_relation_sc_relation_abs: + "\kheap s ptr = Some (Structures_A.SchedContext sc n); scs_relation s s'\ + \ \sc'. ksPSpace s' ptr = Some (KOSchedContext sc') + \ valid_sched_context_size n \ sc_relation sc n sc'" + apply (clarsimp simp: scs_relation_def) + apply (drule_tac x=ptr in spec) + apply (prop_tac "ptr \ dom (scs_of s)", force simp: opt_map_def scs_of_kh_def) + apply (clarsimp simp: opt_map_def scs_of_kh_def split: option.splits kernel_object.splits) + done + +lemma scs_relation_sc_relation_abs_obj_at': + "\kheap s ptr = Some (Structures_A.SchedContext sc n); scs_relation s s'; + pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'\ + \ \sc'. ko_at' sc' ptr s' \ valid_sched_context_size n \ sc_relation sc n sc'" + apply (frule (1) scs_relation_sc_relation_abs) + apply (fastforce dest: aligned'_distinct'_ko_at'I[where 'a=sched_context]) + done + +lemma scs_relation_sc_relation_conc: + "\ksPSpace s' ptr = Some (KOSchedContext sc'); scs_relation s s'\ + \ \sc n. kheap s ptr = Some (Structures_A.SchedContext sc n) \ sc_relation sc n sc'" + apply (clarsimp simp: scs_relation_def) + apply (drule_tac x=ptr in spec) + apply (prop_tac "ptr \ dom (scs_of' s')", force simp: opt_map_red) + apply (drule sym[where s="dom _"]) + apply (clarsimp simp: scs_of_kh_def opt_map_def split: option.splits) + done + +lemma sc_at_cross_scs_relation: + "\sc_at sc_ptr s; scs_relation s s'; pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'\ + \ sc_at' sc_ptr s'" + apply (clarsimp simp: obj_at_def is_sc_obj_def) + apply (clarsimp split: Structures_A.kernel_object.splits) + apply (frule (4) scs_relation_sc_relation_abs_obj_at') + apply (clarsimp simp: obj_at'_def) + done + +lemma replies_relation_reply_relation_abs: + "\kheap s ptr = Some (Structures_A.Reply reply); replies_relation s s'\ + \ \reply'. ksPSpace s' ptr = Some (KOReply reply') \ reply_relation reply reply'" + apply (clarsimp simp: map_relation_def) + apply (drule_tac x=ptr in spec) + apply (prop_tac "ptr \ dom (replies_of s)", force simp: opt_map_red) + apply (clarsimp simp: scs_of_kh_def opt_map_def split: option.splits) + done + +lemma replies_relation_reply_relation_abs_obj_at': + "\kheap s ptr = Some (Structures_A.Reply reply); replies_relation s s'; + pspace_aligned' s'; pspace_distinct' s'\ + \ \reply'. ko_at' reply' ptr s' \ reply_relation reply reply'" + apply (frule (1) replies_relation_reply_relation_abs) + apply (fastforce dest: aligned'_distinct'_ko_at'I[where 'a=reply]) + done + +lemma replies_relation_reply_relation_conc: + "\ksPSpace s' ptr = Some (KOReply reply'); replies_relation s s'\ + \ \reply. kheap s ptr = Some (Structures_A.Reply reply) \ reply_relation reply reply'" + apply (clarsimp simp: map_relation_def) + apply (drule_tac x=ptr in spec) + apply (prop_tac "ptr \ dom (replies_of' s')", force simp: opt_map_def) + apply (drule sym[where s="dom _"]) + apply (clarsimp simp: opt_map_def split: option.splits) + done + +lemma getNotification_corres: + "corres ntfn_relation (ntfn_at ptr and pspace_aligned and pspace_distinct) \ + (get_notification ptr) (getNotification ptr)" + apply (rule_tac Q'="ntfn_at' ptr" in corres_cross_add_guard) + apply (frule state_relation_pspace_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation) + apply (frule heap_pspace_relation_ntfns_relation) + apply (clarsimp simp: obj_at_def is_ntfn_def) + apply (rename_tac ko; case_tac ko; clarsimp) + apply (fastforce dest!: ntfns_relation_ntfn_relation_abs_obj_at' + intro!: pspace_aligned_cross pspace_distinct_cross + simp: obj_at'_def) + apply (rule corres_no_failI) + apply wpsimp + apply (simp add: get_simple_ko_def getNotification_def get_object_def + getObject_def bind_assoc gets_the_def) + apply (clarsimp simp: in_monad split_def bind_def gets_def get_def return_def + dest!: readObject_misc_ko_at') + apply (clarsimp simp: assert_def fail_def obj_at_def return_def is_ntfn partial_inv_def) + apply (clarsimp simp add: state_relation_def pspace_relation_def obj_at'_def) + apply (drule bspec) + apply blast + apply (simp add: ntfn_relation_cut_def ntfn_relation_def) + done + +lemma state_relation_sc_relation'': + "\(s, s') \ state_relation; kheap s ptr = Some (kernel_object.SchedContext sc n); sc_at ptr s; + ko_at' sc' ptr s'\ + \ \n. sc_relation sc n sc'" + apply (clarsimp simp: gen_obj_at_simps is_sc_obj) + apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation, rotated]) + apply (fastforce simp: obj_at_def is_sc_obj_def) + done + +lemma get_sc_corres: + "corres (\sc sc'. \n. sc_relation sc n sc') + (sc_at ptr and pspace_aligned and pspace_distinct) \ + (get_sched_context ptr) (getSchedContext ptr)" + apply (rule_tac Q'="sc_at' ptr" in corres_cross_add_guard) + apply (frule state_relation_pspace_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation) + apply (frule heap_pspace_relation_scs_relation) + apply (clarsimp simp: obj_at_def is_sc_obj_def) + apply (rename_tac ko n; case_tac ko; clarsimp) + apply (fastforce dest!: scs_relation_sc_relation_abs_obj_at' + intro!: pspace_aligned_cross pspace_distinct_cross pspace_relation_pspace_bounded' + simp: obj_at'_def) + apply (subst corres_bind_return) + apply (subst corres_bind_return2) + apply (rule corres_symb_exec_l[OF _ _ get_sched_context_sp]) + apply (rule corres_symb_exec_r[OF _ get_sc_sp']) + apply (fastforce intro: state_relation_sc_relation'' simp: obj_at_def is_sc_obj_def) + apply wpsimp + apply wpsimp + apply (rule get_sched_context_exs_valid) + apply (fastforce intro: sc_atD1) + apply wpsimp + apply (fastforce intro: sc_atD1) + apply simp+ + done + +lemma aligned'_distinct'_obj_at'_propI: + "\ksPSpace s' x = Some ko; pspace_aligned' s'; pspace_distinct' s'; + koTypeOf ko = SchedContextT \ pspace_bounded' s'; + ko = injectKO (v:: 'a :: pspace_storable); P v\ + \ obj_at' P x s'" + by (fastforce elim: aligned'_distinct'_ko_wp_at'I simp: obj_at'_real_def project_inject) + +lemma st_tcb_at_coerce_abstract': + "\st_tcb_at' P t s'; tcbs_relation s s'\ + \ st_tcb_at (\st. \st'. thread_state_relation st st' \ P st') t s" + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (frule (1) tcbs_relation_tcb_relation_conc) + by (fastforce simp: st_tcb_at_def obj_at_def tcb_relation_def) + +definition ready_queues_runnable_except_set :: "obj_ref set \ 'z::state_ext state \ bool" where + "ready_queues_runnable_except_set except s \ + \d p. \t\set (ready_queues s d p). t \ except \ st_tcb_at runnable t s" + +abbreviation "ready_queues_runnable s \ ready_queues_runnable_except_set {} s" + +lemmas ready_queues_runnable_def = ready_queues_runnable_except_set_def + +definition release_q_runnable_except_set :: "obj_ref set \ 'z::state_ext state \ bool" where + "release_q_runnable_except_set except s \ + \t\set (release_queue s). t \ except \ st_tcb_at runnable t s" + +abbreviation "release_q_runnable s \ release_q_runnable_except_set {} s" + +lemmas release_q_runnable_def = release_q_runnable_except_set_def + +definition in_correct_ready_q :: "'z state \ bool" where + "in_correct_ready_q s \ + \d p. \t\set (ready_queues s d p). + pred_map (\t. etcb_priority t = p \ etcb_domain t = d) (etcbs_of s) t" + +definition ready_qs_distinct :: "'z state \ bool" where + "ready_qs_distinct s \ \d p. distinct (ready_queues s d p)" + +lemma in_correct_ready_q_lift: + assumes e: "\P. f \\s. P (etcbs_of s)\" + assumes r: "\P. f \\s. P (ready_queues s)\" + shows "f \in_correct_ready_q\" + unfolding in_correct_ready_q_def + apply (rule hoare_pre) + apply (wps assms | wpsimp)+ + done + +lemma in_correct_ready_qD: + "\tcb_ptr \ set (ready_queues s d p); kheap s tcb_ptr = Some (TCB tcb); in_correct_ready_q s\ + \ tcb_domain tcb = d \ tcb_priority tcb = p " + by (fastforce simp: in_correct_ready_q_def vs_all_heap_simps) + +lemma in_correct_ready_q_in_ready_q: + "\kheap s tcb_ptr = Some (TCB tcb); in_correct_ready_q s\ + \ tcb_ptr \ set (ready_queues s (tcb_domain tcb) (tcb_priority tcb)) + = in_ready_q tcb_ptr s" + by (fastforce simp: in_correct_ready_q_def in_ready_q_def vs_all_heap_simps) + +lemma in_set_ready_queues_inQ_eq: + "ready_queues_relation s s' \ t \ set (ready_queues s d p) \ (inQ d p |< tcbs_of' s') t" + by (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + +lemma in_ready_q_tcbQueued_eq: + "ready_queues_relation s s' \ in_ready_q t s \ (tcbQueued |< tcbs_of' s') t" + apply (intro iffI) + apply (clarsimp simp: in_ready_q_def) + apply (frule in_set_ready_queues_inQ_eq) + apply (fastforce simp: inQ_def opt_map_def opt_pred_def split: option.splits) + apply (fastforce simp: ready_queues_relation_def ready_queue_relation_def Let_def inQ_def + opt_pred_def in_ready_q_def + split: option.splits) + done + +lemma in_release_q_tcbInReleaseQueue_eq: + "release_queue_relation s s' \ in_release_queue t s \ (tcbInReleaseQueue |< tcbs_of' s') t" + by (clarsimp simp: release_queue_relation_def list_queue_relation_def in_release_q_def) + +lemma sched_flag_set_live: + "\kheap s ptr = Some (TCB tcb); sched_flag_set s' ptr; tcbs_relation s s'; + ready_queues_relation s s'; release_queue_relation s s'; ready_queues_runnable s; + in_correct_ready_q s; release_q_runnable s; pspace_aligned' s'; pspace_distinct' s'\ + \ live (TCB tcb)" + apply (frule (1) tcbs_relation_tcb_relation_abs) + apply clarsimp + apply (elim disjE) + apply (frule (1) in_ready_q_tcbQueued_eq[THEN iffD2]) + apply (clarsimp simp: live_def ready_queues_runnable_def) + apply (drule_tac x="tcb_domain tcb" in spec) + apply (drule_tac x="tcb_priority tcb" in spec) + apply (drule_tac x=ptr in bspec) + apply (force simp: in_correct_ready_qD in_ready_q_def) + apply (fastforce simp: pred_tcb_at_def obj_at_def split: Structures_A.thread_state.splits) + apply (frule (1) in_release_q_tcbInReleaseQueue_eq[THEN iffD2]) + apply (fastforce simp: live_def release_q_runnable_def in_release_q_def + pred_tcb_at_def obj_at_def) + apply (prop_tac "st_tcb_at' inIPCQueueThreadState ptr s'") + apply (fastforce intro: aligned'_distinct'_obj_at'_propI + simp: st_tcb_at'_def opt_pred_def opt_map_red) + apply (fastforce dest: st_tcb_at_coerce_abstract' simp: pred_tcb_at_def obj_at_def live_def) + done + +lemma live'_sc_cross: + "\live_sc' sc'; kheap s ptr = Some (Structures_A.SchedContext sc n); + ksPSpace s' ptr = Some (KOSchedContext sc'); sc_relation sc n sc'; sc_replies_relation s s'\ + \ live (Structures_A.SchedContext sc n)" + apply (clarsimp simp: live_sc'_def) + apply (elim disjE) + apply (clarsimp simp: sc_relation_def live_def live_sc_def) + apply (clarsimp simp: sc_relation_def live_def live_sc_def) + apply (clarsimp simp: sc_relation_def live_def live_sc_def) + apply (clarsimp simp: obj_at_def live_def live_sc_def sc_replies_relation_def) + apply (drule_tac x=ptr in spec) + apply (fastforce simp: sc_replies_of_scs_def map_project_def scs_of_kh_def opt_map_def) + done + +lemma live'_reply_cross: + "\live_reply' reply'; kheap s ptr = Some (Structures_A.Reply reply); + ksPSpace s' ptr = Some (KOReply reply'); reply_relation reply reply'; valid_replies' s'; + pspace_aligned' s'; pspace_distinct' s'\ + \ live (Structures_A.Reply reply)" + apply (clarsimp simp: reply_relation_def live_def live_reply_def live_reply'_def + valid_replies'_def) + apply (drule_tac x=ptr in spec) + apply (elim disjE) + apply (clarsimp simp: opt_map_red) + apply (prop_tac "\y. replyNexts_of s' ptr = Some y") + apply (clarsimp simp: opt_map_red) + apply (rename_tac reply_next, case_tac reply_next; clarsimp) + apply (clarsimp simp: opt_map_red) + apply (fastforce dest: spec[where x=ptr] simp: opt_map_red) + done + locale KHeap_R = assumes koType_objBitsKO: "\koTypeOf k' = koTypeOf k; koTypeOf k = SchedContextT \ objBitsKO k' = objBitsKO k\ @@ -2957,24 +3106,6 @@ locale KHeap_R = "\p ko. setEndpoint p ko \pspace_in_kernel_mappings'\" assumes setNotification_pspace_in_kernel_mappings'[wp]: "\p ko. setNotification p ko \pspace_in_kernel_mappings'\" - assumes setObject_other_corres_ep: - "\(P :: endpoint \ bool) ptr ob (ob' :: endpoint). - \updateObject ob' = updateObject_default ob'; - \s. obj_at' P ptr s \ map_to_ctes ((ksPSpace s)(ptr \ injectKO ob')) = ctes_of s; - is_other_obj_relation_type (a_type ob); \ko. P ko \ objBits ko = objBits ob'; - \(v :: endpoint). (1 :: machine_word) < 2 ^ objBits v; - \ is_ArchObj ob; other_obj_relation ob (injectKO ob')\ - \ corres dc (typ_at (a_type ob) ptr and obj_at (same_caps ob) ptr) (obj_at' P ptr) - (set_object ptr ob) (setObject ptr ob')" - assumes setObject_other_corres_ntfn: - "\(P :: notification \ bool) ptr ob (ob' :: notification). - \updateObject ob' = updateObject_default ob'; - \s. obj_at' P ptr s \ map_to_ctes ((ksPSpace s)(ptr \ injectKO ob')) = ctes_of s; - is_other_obj_relation_type (a_type ob); \ko. P ko \ objBits ko = objBits ob'; - \(v :: notification). (1 :: machine_word) < 2 ^ objBits v; - \ is_ArchObj ob; other_obj_relation ob (injectKO ob')\ - \ corres dc (typ_at (a_type ob) ptr and obj_at (same_caps ob) ptr) (obj_at' P ptr) - (set_object ptr ob) (setObject ptr ob')" assumes st_tcb_at_coerce_abstract: "\P t c a. \st_tcb_at' P t c; (a, c) \ state_relation\ @@ -3035,38 +3166,6 @@ lemma ctes_of_setObject_cte: declare foldl_True[simp] -lemma setNotification_corres: - "ntfn_relation ae ae' \ - corres dc (ntfn_at ptr) (ntfn_at' ptr) - (set_notification ptr ae) (setNotification ptr ae')" - apply (simp add: set_simple_ko_def setNotification_def is_ntfn_def[symmetric]) - apply (corresK_search search: setObject_other_corres_ntfn[where P="\_. True"]) - apply (corresKsimp wp: get_object_ret get_object_wp)+ - by (fastforce simp: is_ntfn gen_obj_at_simps partial_inv_def) - -lemma setObject_iflive': - fixes v :: "'a :: pspace_storable" - assumes R: "\ko s y n. (updateObject v ko ptr y n s) - = (updateObject_default v ko ptr y n s)" - assumes x: "\x n tcb s t. \ t \ fst (updateObject v (KOTCB tcb) ptr x n s); P s; - lookupAround2 ptr (ksPSpace s) = (Some (x, KOTCB tcb), n) \ - \ \tcb'. t = (KOTCB tcb', s) \ (\(getF, setF) \ ran tcb_cte_cases. getF tcb' = getF tcb)" - assumes y: "\x n cte s. fst (updateObject v (KOCTE cte) ptr x n s) = {}" - shows "\\s. if_live_then_nonz_cap' s \ (live' (injectKO v) \ ex_nonz_cap_to' ptr s) \ P s\ - setObject ptr v - \\rv s. if_live_then_nonz_cap' s\" - unfolding if_live_then_nonz_cap'_def ex_nonz_cap_to'_def - apply (rule hoare_pre) - apply (simp only: imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (rule setObject_ko_wp_at [OF R]) - apply (rule hoare_vcg_ex_lift) - apply (rule setObject_cte_wp_at'[where Q = P, OF x y]) - apply assumption+ - apply clarsimp - apply (clarsimp simp: ko_wp_at'_def) - done - lemma setObject_ifunsafe': fixes v :: "'a :: pspace_storable" assumes x: "\x n tcb s t. \ t \ fst (updateObject v (KOTCB tcb) ptr x n s); P s; @@ -3120,30 +3219,6 @@ lemma setObject_state_hyp_refs_of_eq: cong: option.case_cong if_cong) done -lemma setEndpoint_iflive'[wp]: - "\\s. if_live_then_nonz_cap' s - \ (v \ IdleEP \ ex_nonz_cap_to' p s)\ - setEndpoint p v - \\rv. if_live_then_nonz_cap'\" - unfolding setEndpoint_def - by (wpsimp wp: setObject_iflive'[where P="\"] - simp: updateObject_default_def in_monad - gen_objBits_simps bind_def live'_def) - -lemma set_ntfn_iflive'[wp]: - "\\s. if_live_then_nonz_cap' s - \ (live' (KONotification v) \ ex_nonz_cap_to' p s)\ - setNotification p v - \\_. if_live_then_nonz_cap'\" - apply (simp add: setNotification_def) - apply (wp setObject_iflive'[where P="\"]) - apply simp - apply (simp add: gen_objBits_simps) - apply (clarsimp simp: updateObject_default_def in_monad) - apply (clarsimp simp: updateObject_default_def in_monad bind_def) - apply clarsimp - done - lemma valid_refs'_def2: "valid_refs' R (ctes_of s) = (\cref. \cte_wp_at' (\c. R \ capRange (cteCap c) \ {}) cref s)" by (auto simp: valid_refs'_def cte_wp_at_ctes_of ran_def) diff --git a/proof/refine/Move_R.thy b/proof/refine/Move_R.thy index 7b5b94eadd..0b01ade6b3 100644 --- a/proof/refine/Move_R.thy +++ b/proof/refine/Move_R.thy @@ -262,36 +262,6 @@ lemma check_active_irq_invs_just_idle: and (\s. 0 < domain_time s) and valid_domain_list \" by (wpsimp simp: check_active_irq_def ct_in_state_def) -lemma sym_ref_BlockedOnReceive_RecvEP: - "\ sym_refs (state_refs_of s); kheap s tp = Some (TCB tcb); - tcb_state tcb = Structures_A.BlockedOnReceive eptr ropt pl \ \ - \list. kheap s eptr = Some (Structures_A.Endpoint (Structures_A.RecvEP list))" - apply (drule sym_refs_obj_atD[rotated, where p=tp]) - apply (clarsimp simp: obj_at_def, simp) - apply (clarsimp simp: state_refs_of_def) - apply (drule_tac x="(eptr, TCBBlockedRecv)" in bspec) - apply (fastforce split: if_split_asm) - apply (clarsimp simp: obj_at_def) - apply (rename_tac koa; case_tac koa; - clarsimp simp: ep_q_refs_of_def get_refs_def2) - apply (rename_tac ep; case_tac ep; simp) - done - -lemma sym_ref_BlockedOnSend_SendEP: - "\ sym_refs (state_refs_of s); kheap s tp = Some (TCB tcb); - tcb_state tcb = Structures_A.BlockedOnSend eptr pl \ \ - \list. kheap s eptr = Some (Structures_A.Endpoint (Structures_A.SendEP list))" - apply (drule sym_refs_obj_atD[rotated, where p=tp]) - apply (clarsimp simp: obj_at_def, simp) - apply (clarsimp simp: state_refs_of_def) - apply (drule_tac x="(eptr, TCBBlockedSend)" in bspec) - apply (fastforce split: if_split_asm) - apply (clarsimp simp: obj_at_def) - apply (rename_tac koa; case_tac koa; - clarsimp simp: ep_q_refs_of_def get_refs_def2) - apply (rename_tac ep; case_tac ep; simp) - done - lemma Receive_or_Send_ep_at: "\ st = Structures_A.thread_state.BlockedOnReceive epPtr rp p' \ st = Structures_A.thread_state.BlockedOnSend epPtr p; diff --git a/proof/refine/RISCV64/ADT_H.thy b/proof/refine/RISCV64/ADT_H.thy index 49b78b6a34..73eb5fe293 100644 --- a/proof/refine/RISCV64/ADT_H.thy +++ b/proof/refine/RISCV64/ADT_H.thy @@ -98,18 +98,21 @@ definition absHeapArch :: | KOPTE _ \ map_option PageTable (absPageTable h a)" -definition - "EndpointMap ep \ case ep of - Structures_H.IdleEP \ Structures_A.IdleEP - | Structures_H.SendEP q \ Structures_A.SendEP q - | Structures_H.RecvEP q \ Structures_A.RecvEP q" - -definition - "NtfnMap ntfn \ - \ ntfn_obj = case ntfnObj ntfn of - Structures_H.IdleNtfn \ Structures_A.IdleNtfn - | Structures_H.WaitingNtfn q \ Structures_A.WaitingNtfn q - | Structures_H.ActiveNtfn b \ Structures_A.ActiveNtfn b +definition EndpointMap :: "(obj_ref \ obj_ref) \ endpoint \ Structures_A.endpoint" where + "EndpointMap tcbSchedNexts ep \ case epState ep of + IdleEPState \ Structures_A.IdleEP + | SendEPState + \ Structures_A.SendEP (heap_walk tcbSchedNexts (tcbQueueHead (epQueue ep)) []) + | ReceiveEPState + \ Structures_A.RecvEP (heap_walk tcbSchedNexts (tcbQueueHead (epQueue ep)) [])" + +definition NtfnMap :: "(obj_ref \ obj_ref) \ notification \ Structures_A.notification" where + "NtfnMap tcbSchedNexts ntfn \ + \ ntfn_obj = case ntfnState ntfn of + IdleNtfnState \ Structures_A.IdleNtfn + | Waiting \ Structures_A.WaitingNtfn + (heap_walk tcbSchedNexts (tcbQueueHead (ntfnQueue ntfn)) []) + | Active \ Structures_A.ActiveNtfn (the (ntfnMsgIdentifier ntfn)) , ntfn_bound_tcb = ntfnBoundTCB ntfn , ntfn_sc = ntfnSc ntfn \" @@ -301,8 +304,10 @@ definition absHeap :: (machine_word \ Structures_H.kernel_object) \ Structures_A.kheap" where "absHeap ups cns h \ \x. case h x of - Some (KOEndpoint ep) \ Some (Endpoint (EndpointMap ep)) - | Some (KONotification ntfn) \ Some (Notification (NtfnMap ntfn)) + Some (KOEndpoint ep) \ Some (Structures_A.Endpoint + (EndpointMap (h |> tcb_of' |> tcbSchedNext) ep)) + | Some (KONotification ntfn) \ Some (Structures_A.Notification + (NtfnMap (h |> tcb_of' |> tcbSchedNext) ntfn)) | Some KOKernelData \ undefined \ \forbidden by pspace_relation\ | Some KOUserData \ map_option (ArchObj \ DataPage False) (ups x) | Some KOUserDataDevice \ map_option (ArchObj \ DataPage True) (ups x) @@ -451,20 +456,25 @@ begin private method ako = find_goal \match premises in "kheap s p = Some (ArchObj ako)" for s p ako \ succeed\, (rename_tac ako, case_tac ako; - clarsimp simp: other_obj_relation_def other_aobj_relation_def pte_relation_def split: if_split_asm) + clarsimp simp: other_aobj_relation_def pte_relation_def split: if_split_asm) private method ko = - case_tac ko; clarsimp simp: other_obj_relation_def cte_relation_def split: if_split_asm + case_tac ko; + clarsimp simp: ep_relation_cut_def ntfn_relation_cut_def cte_relation_def + split: if_split_asm lemma absHeap_correct: fixes s' :: kernel_state assumes pspace_aligned: "pspace_aligned s" assumes pspace_distinct: "pspace_distinct s" assumes valid_objs: "valid_objs s" + assumes valid_objs': "valid_objs' s'" assumes valid_refills: "active_scs_valid s" assumes pspace_relation: "pspace_relation (kheap s) (ksPSpace s')" assumes ghost_relation: "ghost_relation (kheap s) (gsUserPages s') (gsCNodes s')" assumes replies: "sc_replies_relation s s'" + assumes ep_queues: "ep_queues_relation s s'" + assumes ntfn_queues: "ntfn_queues_relation s s'" shows "absHeap (gsUserPages s') (gsCNodes s') (ksPSpace s') = kheap s" proof - note relatedE = pspace_dom_relatedE[OF _ pspace_relation] @@ -477,6 +487,12 @@ proof - gsCNodes s' a = Some n" by (fastforce simp add: ghost_relation_def)+ + have pspace_aligned': "pspace_aligned' s'" + by (fastforce intro!: pspace_aligned_cross pspace_aligned pspace_relation) + + have pspace_distinct': "pspace_distinct' s'" + by (force intro!: pspace_distinct_cross pspace_aligned pspace_distinct pspace_relation) + show "?thesis" supply image_cong_simp [cong del] apply (rule ext) @@ -492,7 +508,7 @@ proof - apply (erule_tac x=x in allE, simp add: Ball_def) apply (erule_tac x=x in allE, clarsimp) - apply (case_tac ko; simp add: other_obj_relation_def split: if_split_asm kernel_object.splits) + apply (case_tac ko; simp split: if_split_asm kernel_object.splits) apply (rename_tac sz cs) apply (clarsimp simp: image_def cte_map_def well_formed_cnode_n_def Collect_eq dom_def) apply (erule_tac x="replicate sz False" in allE)+ @@ -506,13 +522,47 @@ proof - apply (clarsimp split: kernel_object.splits) apply (intro conjI impI allI) - apply (erule relatedE, ko, ako, simp add: tcb_relation_cut_def) + apply (rule relatedE, fastforce, ko, ako, simp add: tcb_relation_cut_def) + apply (rename_tac ep' p ep) + apply (frule_tac v=ep' in aligned'_distinct'_ko_at'I) + apply (fastforce intro: pspace_aligned') + apply (fastforce intro: pspace_distinct') + apply fastforce + apply fastforce + apply (insert valid_objs' ep_queues)[1] apply (clarsimp simp: ep_relation_def EndpointMap_def - split: Structures_A.endpoint.splits) - apply (erule relatedE, ko, ako, simp add: tcb_relation_cut_def) + split: Structures_A.endpoint.splits epstate.splits) + apply (clarsimp simp: ep_queues_relation_def) + apply (drule_tac x=p in spec) + apply (fastforce dest: heap_ls_is_walk + simp: list_queue_relation_def eps_of_kh_def opt_map_red + split: epstate.splits Structures_A.endpoint.splits) + apply (clarsimp simp: ep_queues_relation_def) + apply (drule_tac x=p in spec) + apply (fastforce dest: heap_ls_is_walk + simp: list_queue_relation_def eps_of_kh_def opt_map_red + split: epstate.splits Structures_A.endpoint.splits) + apply (clarsimp simp: ntfn_relation_cut_def) + apply (rule relatedE, fastforce, ko, ako, simp add: tcb_relation_cut_def) + apply (rename_tac ntfn' p ntfn) + apply (frule_tac v=ntfn' in aligned'_distinct'_ko_at'I) + apply (fastforce intro: pspace_aligned') + apply (fastforce intro: pspace_distinct') + apply fastforce + apply fastforce + apply (insert valid_objs' ntfn_queues)[1] + apply (frule (1) ntfn_ko_at_valid_objs_valid_ntfn') apply (clarsimp simp: ntfn_relation_def NtfnMap_def - split: Structures_A.ntfn.splits) + split: Structures_A.ntfn.splits) + apply (clarsimp simp: ntfn_queues_relation_def) + apply (drule_tac x=p in spec) + apply (fastforce dest: heap_ls_is_walk + simp: list_queue_relation_def opt_map_red valid_ntfn'_def) + apply (erule relatedE, ko, ako, simp add: tcb_relation_cut_def) + apply (clarsimp simp: ntfn_relation_def NtfnMap_def + split: Structures_A.ntfn.splits) + apply (erule relatedE, ko, ako) apply (rename_tac vmpage_size n) @@ -654,70 +704,72 @@ proof - apply clarsimp apply (rule sym) - \ \apply (rule pspace_aligned_distinct_None'[OF pspace_aligned pspace_distinct]; simp)\ - apply (rule pspace_aligned_distinct_None' - [OF pspace_aligned pspace_distinct], (simp add: bit_simps)+) - apply (cut_tac x=ya and n="2^12" in - ucast_less_shiftl_helper'[where 'a=machine_word_len and a=3,simplified word_bits_conv], simp+) - apply (clarsimp simp add: word_gt_0) - apply (rename_tac p p' pt pte off) - apply (prop_tac "pt_at p s", simp add: obj_at_def) - apply (drule page_table_at_cross[OF _ pspace_aligned pspace_distinct pspace_relation]) - apply (clarsimp simp: page_table_at'_def typ_at'_def ko_wp_at'_def bit_simps) - apply (erule_tac x=off in allE) - apply (clarsimp dest!: koTypeOf_pte simp: objBits_simps bit_simps) - apply (rename_tac pte') - apply (erule pspace_dom_relatedE[OF _ pspace_relation]) - apply (case_tac ko; simp add: tcb_relation_cut_def other_obj_relation_def) - apply (clarsimp simp add: cte_relation_def split: if_split_asm) - apply (clarsimp simp add: cte_relation_def split: if_split_asm) - apply (rename_tac ako' y ko P ako) - apply (case_tac ako; clarsimp simp: other_aobj_relation_def bit_simps) - apply (simp add: pte_relation_def) - using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def] - apply (erule_tac x=y in allE) - apply (clarsimp simp: bit_simps) - apply (drule (2) distinct_word_add_inj_ptes[unfolded bit_simps]) + apply (rule pspace_aligned_distinct_None'[ + OF pspace_aligned pspace_distinct], + (simp add: bit_simps)+) + apply (cut_tac x=ya + and n="2^12" + in ucast_less_shiftl_helper'[ + where 'a=machine_word_len and a=3, simplified word_bits_conv], simp+) + apply (clarsimp simp add: word_gt_0) + apply (rename_tac p p' pt pte off) + apply (prop_tac "pt_at p s", simp add: obj_at_def) + apply (drule page_table_at_cross[OF _ pspace_aligned pspace_distinct pspace_relation]) + apply (clarsimp simp: page_table_at'_def typ_at'_def ko_wp_at'_def bit_simps) + apply (erule_tac x=off in allE) + apply (clarsimp dest!: koTypeOf_pte simp: objBits_simps bit_simps) + apply (rename_tac pte') + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply (case_tac ko; simp add: tcb_relation_cut_def ep_relation_cut_def ntfn_relation_cut_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (rename_tac ako' y ko P ako) + apply (case_tac ako; clarsimp simp: bit_simps) + apply (simp add: other_aobj_relation_def pte_relation_def) + using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def] + apply (erule_tac x=y in allE) + apply (clarsimp simp: bit_simps) + apply (drule (2) distinct_word_add_inj_ptes[unfolded bit_simps]) + apply clarsimp + apply (rename_tac pt) + apply (case_tac "pt off"; simp add: pte_relation_def ppn_len_def ucast_leq_mask) + using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def] + apply (erule_tac x=y in allE) + apply clarsimp + apply (case_tac "n = 0", simp split: if_split_asm) + apply (prop_tac "p = y + ((n << pageBits) - (ucast off << pte_bits))") + apply (clarsimp simp: field_simps bit_simps) + apply simp + apply (case_tac "(n << pageBits) - (ucast off << pte_bits) = 0", simp) + apply (drule_tac x=y and y="(n << pageBits) - (ucast off << pte_bits)" + in pspace_aligned_distinct_None'[OF pspace_aligned pspace_distinct]) + prefer 2 + apply simp + apply (clarsimp simp: bit_simps) + apply (rule conjI) + apply (rule neq_le_trans; clarsimp) + apply (erule (1) pte_offset_in_datapage[unfolded bit_simps]) apply clarsimp - apply (rename_tac pt) - apply (case_tac "pt off"; simp add: ppn_len_def ucast_leq_mask) - using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def] - apply (erule_tac x=y in allE) - apply clarsimp - apply (case_tac "n = 0", simp split: if_split_asm) - apply (prop_tac "p = y + ((n << pageBits) - (ucast off << pte_bits))") - apply (clarsimp simp: field_simps bit_simps) - apply simp - apply (case_tac "(n << pageBits) - (ucast off << pte_bits) = 0", simp) - apply (drule_tac x=y and y="(n << pageBits) - (ucast off << pte_bits)" in - pspace_aligned_distinct_None'[OF pspace_aligned pspace_distinct]) - prefer 2 + apply (subgoal_tac "ucast ya << 3 = 0") + prefer 2 + apply (rule ccontr) + apply (frule_tac x=y in unaligned_helper, assumption) + apply (rule ucast_less_shiftl_helper'[where a=3], simp_all) + apply (rule ext) + apply (frule pspace_relation_absD[OF _ pspace_relation]) apply simp - apply (clarsimp simp: bit_simps) - apply (rule conjI) - apply (rule neq_le_trans; clarsimp) - apply (erule (1) pte_offset_in_datapage[unfolded bit_simps]) - apply clarsimp - apply (subgoal_tac "ucast ya << 3 = 0") - prefer 2 - apply (rule ccontr) - apply (frule_tac x=y in unaligned_helper, assumption) - apply (rule ucast_less_shiftl_helper'[where a=3], simp_all) - apply (rule ext) - apply (frule pspace_relation_absD[OF _ pspace_relation]) - apply simp - apply (erule_tac x=off in allE)+ - apply (clarsimp simp add: pte_relation_def bit_simps) - using valid_objs[simplified valid_objs_def fun_app_def dom_def, simplified] - apply (erule_tac x=y in allE) - apply (clarsimp simp add: valid_obj_def wellformed_pte_def) - apply (erule_tac x=off in allE) - apply (case_tac "pt off"; clarsimp simp add: ucast_down_ucast_id is_down split: if_splits) - apply (rule set_eqI, clarsimp) - apply (case_tac x; simp) - apply (rule set_eqI, clarsimp) - apply (case_tac x; simp) - apply (clarsimp split: if_splits) + apply (erule_tac x=off in allE)+ + apply (clarsimp simp add: pte_relation_def bit_simps) + using valid_objs[simplified valid_objs_def fun_app_def dom_def, simplified] + apply (erule_tac x=y in allE) + apply (clarsimp simp add: valid_obj_def wellformed_pte_def) + apply (erule_tac x=off in allE) + apply (case_tac "pt off"; clarsimp simp add: ucast_down_ucast_id is_down split: if_splits) + apply (rule set_eqI, clarsimp) + apply (case_tac x; simp) + apply (rule set_eqI, clarsimp) + apply (case_tac x; simp) + apply (clarsimp split: if_splits) apply (rule relatedE, assumption, ko, ako, simp add: tcb_relation_cut_def) apply (clarsimp simp: sc_relation_def scMap_def sc_replies_prevs_walk[OF replies]) diff --git a/proof/refine/RISCV64/ArchArchAcc_R.thy b/proof/refine/RISCV64/ArchArchAcc_R.thy index 646e7d9a41..7bbd01438d 100644 --- a/proof/refine/RISCV64/ArchArchAcc_R.thy +++ b/proof/refine/RISCV64/ArchArchAcc_R.thy @@ -295,7 +295,7 @@ lemma getObject_PTE_corres[corres]: apply (clarsimp simp: typ_at'_def ko_wp_at'_def in_magnitude_check objBits_simps bit_simps) apply (clarsimp simp: state_relation_def pspace_relation_def elim!: opt_mapE) apply (drule bspec, blast) - apply (clarsimp simp: other_obj_relation_def pte_relation_def) + apply (clarsimp simp: pte_relation_def) apply (erule_tac x="table_index p" in allE) apply (clarsimp simp: mask_pt_bits_inner_beauty[simplified bit_simps] bit_simps obj_at'_def) done @@ -360,11 +360,7 @@ lemma setObject_PT_corres: apply (drule bspec, assumption) apply clarsimp apply (erule (1) obj_relation_cutsE) - apply simp - apply simp - apply clarsimp - apply simp - apply clarsimp + apply simp+ apply (frule (1) pspace_alignedD) apply (drule_tac p=x in pspace_alignedD, assumption) apply simp @@ -376,26 +372,30 @@ lemma setObject_PT_corres: apply (clarsimp simp: word_size bit_simps) apply arith apply ((simp split: if_split_asm)+)[2] - apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.splits) + apply (simp add: split: Structures_A.kernel_object.splits) apply (simp add: other_aobj_relation_def split: arch_kernel_obj.splits) - apply (rule conjI) + apply (extract_conjunct \match conclusion in "sc_replies_relation_2 _ _ _" \ -\) apply (fastforce simp: sc_replies_relation_def sc_replies_of_scs_def map_project_def scs_of_kh_def opt_map_def projectKO_opts_defs) apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x="p && ~~ mask pt_bits" in allE)+ apply fastforce - apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) apply (prop_tac "typ_at' (koTypeOf (injectKO pte')) p b") apply (simp add: typ_at'_def ko_wp_at'_def) + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) subgoal by (fastforce dest: tcbs_of'_non_tcb_update) apply (extract_conjunct \match conclusion in "release_queue_relation_2 _ _ _ _ _" \ -\) - apply (prop_tac "typ_at' (koTypeOf (injectKO pte')) p b") - apply (simp add: typ_at'_def ko_wp_at'_def) subgoal by (fastforce dest: tcbs_of'_non_tcb_update) apply (simp add: map_to_ctes_upd_other) apply (simp add: fun_upd_def) apply (simp add: caps_of_state_after_update obj_at_def swp_cte_at_caps_of) + apply (fold fun_upd_def) + apply (extract_conjunct \match conclusion in "ep_queues_relation_2 _ _ _ _" \ -\) + apply (clarsimp simp: ep_queues_relation_def eps_of_kh_def projectKO_opts_defs obj_at'_def + opt_map_def) + \ \ntfn_queues_relation\ + apply (clarsimp simp: projectKO_opts_defs opt_map_def) done lemma storePTE_corres[corres]: diff --git a/proof/refine/RISCV64/ArchCSpace1_R.thy b/proof/refine/RISCV64/ArchCSpace1_R.thy index fa9b18efd4..00867610ed 100644 --- a/proof/refine/RISCV64/ArchCSpace1_R.thy +++ b/proof/refine/RISCV64/ArchCSpace1_R.thy @@ -262,19 +262,6 @@ lemma cap_asid_base_mask'[simp]: simp_all add: RISCV64_H.maskCapRights_def isCap_simps Let_def) done -lemma tcb_cases_related2: - "tcb_cte_cases (v - x) = Some (getF, setF) \ - \getF' setF' restr. tcb_cap_cases (tcb_cnode_index (unat ((v - x) >> cte_level_bits))) = Some (getF', setF', restr) - \ cte_map (x, tcb_cnode_index (unat ((v - x) >> cte_level_bits))) = v - \ (\tcb tcb'. tcb_relation tcb tcb' \ cap_relation (getF' tcb) (cteCap (getF tcb'))) - \ (\tcb tcb' cap cte. tcb_relation tcb tcb' \ cap_relation cap (cteCap cte) - \ tcb_relation (setF' (\x. cap) tcb) (setF (\x. cte) tcb'))" - apply (clarsimp simp: tcb_cte_cases_def tcb_relation_def cte_level_bits_def cteSizeBits_def - tcb_cap_cases_simps[simplified] - split: if_split_asm) - apply (simp_all add: tcb_cnode_index_def cte_level_bits_def cte_map_def field_simps to_bl_1) - done - lemma cte_map_pulls_tcb_to_abstract: "\ y = cte_map z; pspace_relation (kheap s) (ksPSpace s'); ksPSpace s' x = Some (KOTCB tcb); @@ -284,7 +271,7 @@ lemma cte_map_pulls_tcb_to_abstract: \ (z = (x, tcb_cnode_index (unat ((y - x) >> cte_level_bits))))" apply (rule pspace_dom_relatedE, assumption+) apply (erule(1) obj_relation_cutsE; - clarsimp simp: other_obj_relation_def other_aobj_relation_def + clarsimp simp: other_aobj_relation_def split: Structures_A.kernel_object.split_asm RISCV64_A.arch_kernel_obj.split_asm if_split_asm) apply (drule tcb_cases_related2) @@ -379,8 +366,6 @@ proof - apply (clarsimp simp: cte_relation_def rel) apply (rule obj_relation_cutsE, assumption+, simp_all add: s'') apply (clarsimp simp: cte_relation_def) - apply (clarsimp simp: is_other_obj_relation_type other_obj_relation_def - split: Structures_A.kernel_object.split_asm) done qed @@ -447,15 +432,13 @@ lemma pspace_relation_cte_wp_atI'[CSpace1_R_assms]: apply (simp split: if_split_asm) apply (erule(1) pspace_dom_relatedE) apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) - apply (subgoal_tac "n = x - y", clarsimp) - apply (drule tcb_cases_related2, clarsimp) - apply (intro exI, rule conjI) - apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) - apply fastforce - apply simp - apply clarsimp - apply (simp add: other_obj_relation_def - split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm) + apply (subgoal_tac "n = x - y", clarsimp) + apply (drule tcb_cases_related2, clarsimp) + apply (intro exI, rule conjI) + apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) + apply fastforce + apply simp + apply clarsimp done lemma same_region_as_final_matters[CSpace1_R_assms]: @@ -790,8 +773,7 @@ lemma updateMDB_pspace_relation[CSpace1_R_2_assms]: apply (rule pspace_dom_relatedE, assumption+) apply (rule obj_relation_cutsE, assumption+; clarsimp split: Structures_A.kernel_object.split_asm - RISCV64_A.arch_kernel_obj.split_asm if_split_asm - simp: other_obj_relation_def) + RISCV64_A.arch_kernel_obj.split_asm if_split_asm) apply (frule(1) tcb_cte_cases_aligned_helpers(1)) apply (frule(1) tcb_cte_cases_aligned_helpers(2)) apply (clarsimp simp del: diff_neg_mask) diff --git a/proof/refine/RISCV64/ArchCSpace_R.thy b/proof/refine/RISCV64/ArchCSpace_R.thy index 18455b9fd9..d4e509f192 100644 --- a/proof/refine/RISCV64/ArchCSpace_R.thy +++ b/proof/refine/RISCV64/ArchCSpace_R.thy @@ -380,6 +380,8 @@ lemma corres_caps_decomposition: "\P. \\s. P (new_release_queue s)\ f \\rv s. P (release_queue s)\" "\P. \\s. P (new_ksReleaseQueue s)\ g \\rv s. P (ksReleaseQueue s)\" "\P. \\s. P (new_sc_replies_of s)\ f \\rv s. P (sc_replies_of s)\" + "\P. \\s. P (new_ep_queues_of s)\ f \\rv s. P (ep_queues_of s)\" + "\P. \\s. P (new_ntfn_queues_of s)\ f \\rv s. P (ntfn_queues_of s)\" "\P. \\s. P (new_scs_of' s) (new_replies_of' s)\ g \\rv s. P (scs_of' s) (replies_of' s)\" "\P. \\s. P (new_ksReleaseQueue s) (new_tcbSchedNexts_of s) (new_tcbSchedPrevs_of s) (new_tcbInReleaseQueue s)\ @@ -389,6 +391,10 @@ lemma corres_caps_decomposition: (\d p. new_inQs d p s)\ g \\rv s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)\" + "\P. \\s. P (new_epQueues_of s) (new_tcbSchedNexts_of s) (new_tcbSchedPrevs_of s)\ + g \\rv s. P (epQueues_of s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + "\P. \\s. P (new_ntfnQueues_of s) (new_tcbSchedNexts_of s) (new_tcbSchedPrevs_of s)\ + g \\rv s. P (ntfnQueues_of s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" "\P. \\s. P (new_di s)\ f \\rv s. P (domain_index s)\" "\P. \\s. P (new_dl s)\ f \\rv s. P (domain_list s)\" "\P. \\s. P (new_cd s)\ f \\rv s. P (cur_domain s)\" @@ -411,6 +417,10 @@ lemma corres_caps_decomposition: \ cdt_list_relation (new_list s) (new_mdb s) (new_ctes s') \ sc_replies_relation_2 (new_sc_replies_of s) (new_scs_of' s' |> scReply) (new_replies_of' s' |> replyPrev) + \ ep_queues_relation_2 (new_ep_queues_of s) (new_epQueues_of s') + (new_tcbSchedNexts_of s') (new_tcbSchedPrevs_of s') + \ ntfn_queues_relation_2 (new_ntfn_queues_of s) (new_ntfnQueues_of s') + (new_tcbSchedNexts_of s') (new_tcbSchedPrevs_of s') \ ready_queues_relation_2 (new_ready_queues s) (new_ksReadyQueues s') (new_tcbSchedNexts_of s') (new_tcbSchedPrevs_of s') (\d p. new_inQs d p s') diff --git a/proof/refine/RISCV64/ArchHeapStateRelation.thy b/proof/refine/RISCV64/ArchHeapStateRelation.thy new file mode 100644 index 0000000000..c7243ea922 --- /dev/null +++ b/proof/refine/RISCV64/ArchHeapStateRelation.thy @@ -0,0 +1,98 @@ +(* + * Copyright 2026, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +theory ArchHeapStateRelation +imports ArchBits_R +begin + +context Arch begin arch_global_naming + +abbreviation asid_pools_relation :: "'z::state_ext state \ kernel_state \ bool" where + "asid_pools_relation s s' \ map_relation (asid_pools_of s) (asid_pools_of' s') asid_pool_relation" + +definition vmpage_size_to_ptrs :: "obj_ref \ vmpage_size \ machine_word set" where + "vmpage_size_to_ptrs p sz = { p + (n << pageBits) | n. n < 2 ^ (pageBitsForSize sz - pageBits) }" + +definition data_pages_relation_2 :: + "(obj_ref \ bool) \ (obj_ref \ vmpage_size) \ (machine_word \ bool) \ (machine_word \ bool) + \ bool" + where + "data_pages_relation_2 flags sizes user_data_devices user_data \ + (\p\dom sizes. vmpage_size_to_ptrs p (the (sizes p))) + = {p. user_data_devices p} \ {p. user_data p} + \ (\p\dom sizes. \ptr\vmpage_size_to_ptrs p (the (sizes p)). + \dev. flags p = Some dev \ (if dev then user_data_devices ptr else user_data ptr))" + +abbreviation data_pages_relation :: "'z::state_ext state \ kernel_state \ bool" where + "data_pages_relation s s' \ + data_pages_relation_2 (page_devs_of s) (page_sizes_of s) + (userDataDevice_at s') (userData_at s')" + +lemmas data_pages_relation_def = data_pages_relation_2_def + +definition ptr_to_pte_ptrs :: "obj_ref \ machine_word set" where + "ptr_to_pte_ptrs p = { p + (ucast y << pteBits) | y. y \ (UNIV :: pt_index set) }" + +definition ptes_relation_2 :: "(obj_ref \ pt) \ (machine_word \ pte) \ bool" where + "ptes_relation_2 pts ptes' \ + (\p\dom pts. ptr_to_pte_ptrs p) = dom ptes' + \ (\p\dom pts. \pt y pte'. pts p = Some pt \ ptes' (p + (ucast y << pteBits)) = Some pte' + \ pte_relation' (pt y) pte')" + +abbreviation ptes_relation :: "'z::state_ext state \ kernel_state \ bool" where + "ptes_relation s s' \ ptes_relation_2 (pts_of s) (ptes_of' s')" + +lemmas ptes_relation_def = ptes_relation_2_def + +definition aobjs_relation :: "'z::state_ext state \ kernel_state \ bool" where + "aobjs_relation s s' \ + data_pages_relation s s' + \ ptes_relation s s' + \ asid_pools_relation s s'" + +lemma aobjs_relation_data_pages_relation[elim!]: + "aobjs_relation s s' \ data_pages_relation s s'" + by (simp add: aobjs_relation_def) + +lemma aobjs_relation_ptes_relation[elim!]: + "aobjs_relation s s' \ ptes_relation s s'" + by (simp add: aobjs_relation_def) + +lemma aobjs_relation_asid_pools_relation[elim!]: + "aobjs_relation s s' \ asid_pools_relation s s'" + by (simp add: aobjs_relation_def) + +definition heap_ghost_relation_2 :: + "(obj_ref \ vmpage_size) \ (obj_ref \ nat) \ (obj_ref \ cnode_contents) + \ (machine_word \ vmpage_size) \ (machine_word \ nat) \ bool" + where + "heap_ghost_relation_2 page_sizes cnode_sizes cnodes ups cns \ + (\p sz. page_sizes p = Some sz \ ups p = Some sz) + \ (\p n. (\cs. cnode_sizes p = Some n \ cnodes p = Some cs \ well_formed_cnode_n n cs) + \ cns p = Some n)" + +abbreviation heap_ghost_relation :: "'z::state_ext state \ kernel_state \ bool" where + "heap_ghost_relation s s' \ + heap_ghost_relation_2 + (page_sizes_of s) (cnode_sizes_of s) (cnode_contents_of s) (gsUserPages s') (gsCNodes s')" + +lemmas heap_ghost_relation_def = heap_ghost_relation_2_def + +\ \an analogue of @{const ghost_relation_wrapper_2}\ +definition heap_ghost_relation_wrapper_2 :: + "(obj_ref \ arch_kernel_obj) \ (obj_ref \ nat) \ (obj_ref \ cnode_contents) + \ (machine_word \ vmpage_size) \ (machine_word \ nat) + \ Arch.kernel_state \ bool" + where + "heap_ghost_relation_wrapper_2 aobjs cnode_sizes cnodes ups cns as \ + heap_ghost_relation_2 (aobjs |> page_of ||> snd) cnode_sizes cnodes ups cns" + +(* inside Arch locale, we have no need for the wrapper *) +lemmas heap_ghost_relation_wrapper_def[simp] = heap_ghost_relation_wrapper_2_def + +end + +end diff --git a/proof/refine/RISCV64/ArchHeapStateRelationLemmas.thy b/proof/refine/RISCV64/ArchHeapStateRelationLemmas.thy new file mode 100644 index 0000000000..b1af196f2c --- /dev/null +++ b/proof/refine/RISCV64/ArchHeapStateRelationLemmas.thy @@ -0,0 +1,588 @@ +(* + * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) + * Copyright 2025, Proofcraft Pty Ltd + * + * SPDX-License-Identifier: GPL-2.0-only + *) + +(* + Arch-specific lemmas related to a heap based approach to the state relation. +*) + +theory ArchHeapStateRelationLemmas +imports HeapStateRelation +begin + +context Arch begin arch_global_naming + +named_theorems HeapStateRelation_R_assms + +lemmas ko_relations = + cte_relation_def pte_relation_def ep_relation_cut_def ntfn_relation_cut_def + other_aobj_relation_def tcb_relation_cut_def asid_pool_relation_def + +(* FIXME arch-split: this proof and many in this file use obj_relation_cuts_def2 and + arch_kernel_obj.split, so cannot be generic. *) +lemma pspace_relation_tcbs_relation: + "pspace_relation (kheap s) (ksPSpace s') \ tcbs_relation s s'" + apply (clarsimp simp: map_relation_def) + apply (rule conjI) + apply (rule dom_eqI) + apply (clarsimp simp: opt_map_def tcbs_of_kh_def split: option.splits) + apply (drule (1) pspace_relation_absD) + apply clarsimp + apply (rename_tac ko, case_tac ko; simp add: tcb_relation_cut_def) + apply (clarsimp simp: opt_map_def tcbs_of_kh_def split: option.splits) + apply (erule (1) pspace_dom_relatedE) + apply (clarsimp simp: obj_relation_cuts_def2 ko_relations + split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) + apply (clarsimp simp: pspace_relation_def opt_map_def tcbs_of_kh_def split: option.splits) + apply (rename_tac p tcb tcb') + apply (drule_tac x=p in bspec, fastforce) + apply (clarsimp simp: tcb_relation_cut_def) + done + +lemma pspace_relation_scs_relation: + "\pspace_relation (kheap s) (ksPSpace s')\ \ scs_relation s s'" + apply (clarsimp simp: scs_relation_def) + apply (rule context_conjI) + apply (simp add: set_eq_subset) + apply (intro conjI impI) + apply (clarsimp simp: opt_map_def scs_of_kh_def split: option.splits) + apply (drule (1) pspace_relation_absD) + apply (clarsimp split: if_splits) + apply (rename_tac ko, case_tac ko; simp) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (erule (1) pspace_dom_relatedE) + apply (clarsimp simp: obj_relation_cuts_def2 ko_relations scs_of_kh_def opt_map_def + split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) + apply (clarsimp simp: pspace_relation_def opt_map_def split: option.splits) + apply (rename_tac p ko sc'' n sc sc') + apply (drule_tac x=p in bspec, fastforce) + apply (case_tac ko; clarsimp split: if_splits) + apply (clarsimp simp: sc_relation_def scs_of_kh_def opt_map_def cte_relation_def) + done + +lemma pspace_relation_eps_relation: + "pspace_relation (kheap s) (ksPSpace s') \ eps_relation s s'" + apply (clarsimp simp: map_relation_def) + apply (rule conjI) + apply (rule dom_eqI) + apply (clarsimp simp: opt_map_def eps_of_kh_def split: option.splits) + apply (drule (1) pspace_relation_absD) + apply (clarsimp split: if_splits) + apply (rename_tac ko, case_tac ko; simp add: ko_relations) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (erule (1) pspace_dom_relatedE) + apply (clarsimp simp: obj_relation_cuts_def2 ko_relations eps_of_kh_def opt_map_def + split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) + apply (clarsimp simp: pspace_relation_def opt_map_def eps_of_kh_def split: option.splits) + apply (rename_tac p ep ep') + apply (drule_tac x=p in bspec, fastforce) + apply (fastforce simp: ko_relations) + done + +lemma pspace_relation_ntfns_relation: + "pspace_relation (kheap s) (ksPSpace s') \ ntfns_relation s s'" + apply (clarsimp simp: map_relation_def) + apply (rule conjI) + apply (rule dom_eqI) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (drule (1) pspace_relation_absD) + apply (clarsimp split: if_splits) + apply (rename_tac ko, case_tac ko; simp add: ko_relations) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (erule (1) pspace_dom_relatedE) + apply (clarsimp simp: obj_relation_cuts_def2 ko_relations opt_map_def + split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) + apply (clarsimp simp: pspace_relation_def opt_map_def split: option.splits) + apply (rename_tac p ntfn ntfn') + apply (drule_tac x=p in bspec, fastforce) + apply (fastforce simp: ko_relations) + done + +lemma pspace_relation_replies_relation: + "pspace_relation (kheap s) (ksPSpace s') \ replies_relation s s'" + apply (clarsimp simp: map_relation_def) + apply (rule conjI) + apply (rule dom_eqI) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (drule (1) pspace_relation_absD) + apply (clarsimp split: if_splits) + apply (rename_tac ko, case_tac ko; simp add: ko_relations) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (erule (1) pspace_dom_relatedE) + apply (clarsimp simp: obj_relation_cuts_def2 ko_relations opt_map_def + split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) + apply (clarsimp simp: pspace_relation_def opt_map_def split: option.splits) + apply (rename_tac p reply reply') + apply (drule_tac x=p in bspec, fastforce) + apply (fastforce simp: ko_relations) + done + +lemma pspace_relation_caps_relation: + "pspace_relation (kheap s) (ksPSpace s') \ caps_relation s s'" + apply (clarsimp simp: caps_relation_def) + apply (rule context_conjI) + apply (simp add: set_eq_subset) + apply (intro conjI impI) + apply clarsimp + apply (clarsimp simp: opt_map_def cnode_to_cte_ptrs_def cnode_of_def split: option.splits) + apply (drule (1) pspace_relation_absD) + apply (clarsimp simp: is_cap_table well_formed_cnode_n_def) + apply (rename_tac contents cref ko' cap, case_tac ko'; clarsimp split: if_splits) + apply (prop_tac "\z. ksPSpace s' (cte_map ( p, cref)) = Some z + \ cte_relation (cref) (CNode (length (cref)) contents) z") + apply (fastforce dest: wf_cs_nD intro: domI) + apply (clarsimp split: kernel_object.split_asm simp: cte_relation_def) + apply (clarsimp simp: opt_map_def cnode_to_cte_ptrs_def split: option.splits) + apply (erule (1) pspace_dom_relatedE) + apply (fastforce simp: obj_relation_cuts_def2 ko_relations + split: Structures_A.kernel_object.split_asm if_split_asm + arch_kernel_obj.split_asm) + apply (clarsimp simp: pspace_relation_def opt_map_def cnode_of_def + split: option.splits) + apply (drule_tac x=p in bspec, fastforce) + apply (rename_tac ko cref, case_tac ko; clarsimp split: if_splits) + apply (clarsimp simp: cte_relation_def) + by (fastforce del: ext intro!: ext) + +lemma pspace_relation_KOKernelData: + "pspace_relation (kheap s) (ksPSpace s') \ \p. ksPSpace s' p \ Some KOKernelData" + apply (clarsimp simp: opt_map_def cnode_to_cte_ptrs_def split: option.splits) + apply (erule (1) pspace_dom_relatedE) + apply (fastforce simp: obj_relation_cuts_def2 ko_relations + split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) + done + +lemma pspace_relation_data_pages_relation: + "pspace_relation (kheap s) (ksPSpace s') \ data_pages_relation s s'" + apply (clarsimp simp: data_pages_relation_def) + apply (rule context_conjI) + apply (simp add: set_eq_subset) + apply (intro conjI impI) + apply clarsimp + apply (clarsimp simp: opt_map_def vmpage_size_to_ptrs_def + split: option.splits) + apply (drule (1) pspace_relation_absD) + apply (clarsimp simp: is_cap_table well_formed_cnode_n_def) + apply (rename_tac ko n ako, case_tac ako; clarsimp split: if_splits) + apply (fastforce intro: domI) + apply (fastforce intro: domI) + apply clarsimp + apply (erule (1) pspace_dom_relatedE) + apply (fastforce elim!: pspace_dom_relatedE + intro!: dom_eqD + simp: obj_relation_cuts_def2 ko_relations vmpage_size_to_ptrs_def opt_map_def + split: Structures_A.kernel_object.split_asm if_split_asm + arch_kernel_obj.split_asm) + apply clarsimp + apply (erule (1) pspace_dom_relatedE) + apply (fastforce simp: obj_relation_cuts_def2 ko_relations vmpage_size_to_ptrs_def opt_map_def + split: Structures_A.kernel_object.split_asm if_split_asm + arch_kernel_obj.split_asm) + apply (clarsimp simp: pspace_relation_def opt_map_red tcbs_of_kh_def vmpage_size_to_ptrs_def) + apply (prop_tac "p + (n << pageBits) + \ {p + (n << pageBits) + |n. n < 2 ^ (pageBitsForSize (the (page_sizes_of s p)) - pageBits)}") + apply fastforce + apply (prop_tac "ksPSpace s' (p + (n << pageBits)) \ None") + apply blast + apply (drule_tac x=p in bspec) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (clarsimp simp: opt_map_def page_of_def + split: arch_kernel_obj.split_asm option.splits) + apply (fastforce intro: domI split: Structures_A.kernel_object.split_asm) + done + +lemma pspace_relation_ptes_relation: + "pspace_relation (kheap s) (ksPSpace s') \ ptes_relation s s'" + apply (clarsimp simp: ptes_relation_def) + apply (rule context_conjI) + apply (simp add: set_eq_subset) + apply (intro conjI impI) + apply clarsimp + apply (clarsimp simp: opt_map_def ptr_to_pte_ptrs_def + split: option.splits) + apply (drule (1) pspace_relation_absD) + apply (clarsimp, rename_tac idx) + apply (drule_tac x=idx in spec) + apply clarsimp + apply (clarsimp simp: pte_relation_def aobj_of'_def pte_of'_def) + apply (clarsimp simp: opt_map_def ptr_to_pte_ptrs_def split: option.splits) + apply (erule (1) pspace_dom_relatedE) + apply (clarsimp simp: pte_relation_def aobj_of'_def pte_of'_def) + apply (rename_tac ako ko ptr abs_ko P) + apply (case_tac ko; clarsimp) + apply (case_tac ako; clarsimp) + apply (fastforce simp: obj_relation_cuts_def2 ko_relations + split: Structures_A.kernel_object.split_asm if_split_asm + arch_kernel_obj.split_asm) + apply (clarsimp simp: pspace_relation_def) + apply (rename_tac p pt pte pte') + apply (drule_tac x=p in bspec) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (clarsimp elim!: pspace_dom_relatedE + simp: obj_relation_cuts_def2 aobj_of'_def ko_relations opt_map_def + split: option.splits) + apply (drule_tac x=pte in spec) + apply (clarsimp simp: pte_of'_def) + done + +lemma pspace_relation_asid_pools_relation: + "pspace_relation (kheap s) (ksPSpace s') \ asid_pools_relation s s'" + apply (clarsimp simp: map_relation_def) + apply (rule conjI) + apply (rule dom_eqI) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (drule (1) pspace_relation_absD) + apply (clarsimp split: if_splits) + apply (rename_tac ko, case_tac ko; simp add: ko_relations) + apply (rename_tac ako, case_tac ako; simp add: ko_relations) + apply (clarsimp simp: aobj_of'_def asid_pool_of'_def) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (erule (1) pspace_dom_relatedE) + apply (clarsimp simp: obj_relation_cuts_def2 ko_relations opt_map_def aobj_of'_def + asid_pool_of'_def + split: Structures_A.kernel_object.split_asm if_split_asm + arch_kernel_obj.split_asm kernel_object.splits) + apply (clarsimp simp: pspace_relation_def opt_map_def split: option.splits) + apply (rename_tac p ko ako ap ap') + apply (drule_tac x=p in bspec, fastforce) + apply (clarsimp simp: aobj_of'_def asid_pool_of'_def other_aobj_relation_def + split: kernel_object.splits arch_kernel_object.splits) + done + +lemma pspace_relation_heap_pspace_relation[HeapStateRelation_R_assms]: + "pspace_relation (kheap s) (ksPSpace s') \ heap_pspace_relation s s'" + apply (intro iffI) + apply (clarsimp simp: heap_pspace_relation_def aobjs_relation_def) + apply (intro conjI impI allI iffI) + apply (fastforce dest: pspace_relation_tcbs_relation) + apply (fastforce dest: pspace_relation_caps_relation) + apply (fastforce dest: pspace_relation_scs_relation) + apply (fastforce dest: pspace_relation_eps_relation) + apply (fastforce dest: pspace_relation_ntfns_relation) + apply (fastforce dest: pspace_relation_replies_relation) + apply (fastforce dest: pspace_relation_KOKernelData) + apply (fastforce dest: pspace_relation_data_pages_relation) + apply (fastforce dest: pspace_relation_ptes_relation) + apply (fastforce dest: pspace_relation_asid_pools_relation) + apply (clarsimp simp: pspace_relation_def) + apply (rule conjI) + apply (clarsimp simp: pspace_dom_def) + apply (simp add: set_eq_subset) + apply (intro conjI impI) + apply clarsimp + apply (rename_tac ptr x rel ako) + apply (case_tac ako; clarsimp simp: ko_relations split: if_splits) + apply (frule heap_pspace_relation_caps_relation) + apply (clarsimp simp: caps_relation_def cnode_to_cte_ptrs_def) + apply (subgoal_tac "cte_map (ptr, y) \ dom (ctes_of' s')") + apply (force simp: opt_map_def projectKO_opts_defs split: option.splits) + apply (fastforce simp: opt_map_def) + apply (fastforce dest: heap_pspace_relation_caps_relation + simp: caps_relation_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_tcbs_relation) + apply (fastforce simp: map_relation_def tcbs_of_kh_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_eps_relation) + apply (fastforce simp: map_relation_def eps_of_kh_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_ntfns_relation) + apply (fastforce dest: dom_eq_All simp: map_relation_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_scs_relation) + apply (fastforce simp: scs_relation_def scs_of_kh_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_scs_relation) + apply (fastforce simp: scs_relation_def scs_of_kh_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_replies_relation) + apply (fastforce simp: map_relation_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_aobjs_relation) + apply (rename_tac ako, case_tac ako; clarsimp) + apply (frule aobjs_relation_asid_pools_relation) + apply (fastforce simp: map_relation_def opt_map_def split: option.splits) + apply (frule aobjs_relation_ptes_relation) + apply (clarsimp simp: ptes_relation_def ptr_to_pte_ptrs_def) + apply (subgoal_tac "ptr + (UCAST(9 \ 64) y << pteBits) \ dom (ptes_of' s')") + apply (force simp: opt_map_def projectKO_opts_defs split: option.splits) + apply (fastforce simp: opt_map_def) + apply (frule aobjs_relation_data_pages_relation) + apply (clarsimp simp: data_pages_relation_def vmpage_size_to_ptrs_def) + apply (subgoal_tac "ptr + (n << pageBits) + \ {p. userDataDevice_at s' p} \ {p. userData_at s' p}") + apply (force simp: opt_map_def projectKO_opts_defs split: option.splits) + apply (fastforce simp: page_of_def opt_map_def) + apply clarsimp + apply (rename_tac ptr ko) + apply (case_tac ko; clarsimp) + apply (frule heap_pspace_relation_eps_relation) + apply (clarsimp simp: map_relation_def) + apply (force dest!: dom_eq_All simp: eps_of_kh_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_ntfns_relation) + apply (clarsimp simp: map_relation_def) + apply (force dest!: dom_eq_All simp: opt_map_def split: option.splits) + apply (fastforce dest: heap_pspace_relation_KOKernelData) + apply (frule heap_pspace_relation_aobjs_relation) + apply (frule aobjs_relation_data_pages_relation) + apply (clarsimp simp: data_pages_relation_def) + apply (prop_tac "ptr \ (\p\dom (page_sizes_of s). + vmpage_size_to_ptrs p (the (page_sizes_of s p)))") + apply fastforce + apply (frule Union_iff[THEN iffD1]) + apply (clarsimp, rename_tac i sz) + apply (rule_tac x=i in bexI) + apply (force simp: opt_map_def image_def page_of_def vmpage_size_to_ptrs_def + split: arch_kernel_obj.split_asm option.splits) + apply (fastforce simp: opt_map_def split: option.splits) + apply (frule heap_pspace_relation_aobjs_relation) + apply (frule aobjs_relation_data_pages_relation) + apply (clarsimp simp: data_pages_relation_def) + apply (prop_tac "ptr \ (\p\dom (page_sizes_of s). + vmpage_size_to_ptrs p (the (page_sizes_of s p)))") + apply fastforce + apply (frule Union_iff[THEN iffD1]) + apply (clarsimp, rename_tac i sz) + apply (rule_tac x=i in bexI) + apply (force simp: opt_map_def image_def page_of_def vmpage_size_to_ptrs_def + split: arch_kernel_obj.split_asm option.splits) + apply (fastforce simp: opt_map_def split: option.splits) + apply (frule heap_pspace_relation_tcbs_relation) + apply (clarsimp simp: map_relation_def) + apply (force dest!: dom_eq_All simp: tcbs_of_kh_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_caps_relation) + apply (clarsimp simp: caps_relation_def) + apply (prop_tac "ptr \ (\p\dom (cnode_contents_of s). cnode_to_cte_ptrs p (the (cnode_contents_of s p)))") + apply (fastforce simp: cnode_of_def opt_map_red) + apply (frule Union_iff[THEN iffD1]) + apply clarsimp + apply (rename_tac i cte cnode_contents) + apply (rule_tac x=i in bexI) + apply (force simp: opt_map_def image_def cnode_to_cte_ptrs_def cnode_of_def + split: Structures_A.kernel_object.splits option.splits) + apply (fastforce simp: opt_map_def split: option.splits) + apply (drule heap_pspace_relation_aobjs_relation) + apply (rename_tac ako, case_tac ako; clarsimp) + apply (frule aobjs_relation_asid_pools_relation) + apply (clarsimp simp: map_relation_def) + apply (rule_tac x=ptr in bexI) + apply (fastforce dest: dom_eq_All simp: asid_pool_of'_def opt_map_def aobj_of'_def + split: option.splits) + apply (fastforce simp: asid_pool_of'_def opt_map_def aobj_of'_def split: option.splits) + apply (frule aobjs_relation_ptes_relation) + apply (clarsimp simp: ptes_relation_def) + apply (prop_tac "ptr \ \ (ptr_to_pte_ptrs ` dom (pts_of s))") + apply (fastforce simp: aobj_of'_def pte_of'_def opt_map_def split: option.splits) + apply (frule Union_iff[THEN iffD1]) + apply clarsimp + apply (rename_tac i pte pt) + apply (rule_tac x=i in bexI) + apply (force simp: opt_map_def image_def ptr_to_pte_ptrs_def split: option.splits) + apply (fastforce simp: opt_map_def split: option.splits) + apply (frule heap_pspace_relation_scs_relation) + apply (clarsimp simp: scs_relation_def) + subgoal by (force dest!: dom_eq_All simp: scs_of_kh_def opt_map_def split: option.splits) + apply (frule heap_pspace_relation_replies_relation) + apply (clarsimp simp: map_relation_def) + apply (force dest!: dom_eq_All simp: opt_map_def split: option.splits) + apply clarsimp + apply (rename_tac ptr x rel ko) + apply (clarsimp simp: obj_relation_cuts_def2) + apply (case_tac ko; clarsimp split: if_splits) + apply (rename_tac sz cnode_contents cnode_index cap) + apply (drule heap_pspace_relation_caps_relation) + apply (clarsimp simp: caps_relation_def cte_relation_def) + apply (drule_tac x=ptr in bspec, force simp: opt_map_red) + apply (drule_tac x=cnode_contents in spec) + apply (drule_tac x=sz in spec) + apply clarsimp + apply (elim impE) + apply (force simp: opt_map_red) + apply (drule_tac x=cnode_index in bspec, fastforce) + apply (clarsimp simp: cnode_to_cte_ptrs_def) + apply (fastforce simp: opt_map_def split: option.splits) + apply (drule heap_pspace_relation_caps_relation) + apply (clarsimp simp: caps_relation_def cte_relation_def) + apply (fastforce simp: opt_map_def split: option.splits) + apply (drule heap_pspace_relation_tcbs_relation) + apply (fastforce simp: map_relation_def tcb_relation_cut_def opt_map_def tcbs_of_kh_def + split: option.splits) + apply (drule heap_pspace_relation_eps_relation) + apply (fastforce simp: map_relation_def ep_relation_cut_def opt_map_def eps_of_kh_def + split: option.splits) + apply (drule heap_pspace_relation_ntfns_relation) + apply (fastforce simp: map_relation_def ntfn_relation_cut_def opt_map_def + split: option.splits) + apply (drule heap_pspace_relation_scs_relation) + apply (fastforce simp: scs_relation_def opt_map_def scs_of_kh_def split: option.splits) + apply (drule heap_pspace_relation_scs_relation) + apply (fastforce simp: scs_relation_def opt_map_def scs_of_kh_def split: option.splits) + apply (drule heap_pspace_relation_replies_relation) + apply (fastforce simp: map_relation_def opt_map_def split: option.splits) + apply (drule heap_pspace_relation_aobjs_relation) + apply (rename_tac ako, case_tac ako; clarsimp) + apply (drule aobjs_relation_asid_pools_relation) + apply (clarsimp simp: map_relation_def) + apply (prop_tac "ptr \ dom (asid_pools_of' s')", fastforce simp: opt_map_red) + apply (force simp: opt_map_def other_aobj_relation_def aobj_of'_def asid_pool_of'_def + split: option.splits kernel_object.splits arch_kernel_object.splits) + apply (drule aobjs_relation_ptes_relation) + apply (clarsimp simp: ptes_relation_def pte_relation_def) + apply (drule_tac x=ptr in bspec, force simp: opt_map_red) + apply (drule_tac x=x2 in spec) + apply (drule_tac x=y in spec) + apply (prop_tac "(ptr + (UCAST(9 \ 64) y << pteBits)) \ dom (ptes_of' s')") + apply (force simp: ptr_to_pte_ptrs_def opt_map_def) + apply (fastforce simp: opt_map_def aobj_of'_def pte_of'_def + split: option.splits kernel_object.splits arch_kernel_object.splits) + apply (rename_tac n) + apply (drule aobjs_relation_data_pages_relation) + apply (clarsimp simp: data_pages_relation_def) + apply (drule_tac x=ptr in bspec, force simp: opt_map_def page_of_def) + apply (drule_tac x="ptr + (n << pageBits)" in bspec) + apply (force simp: vmpage_size_to_ptrs_def page_of_def opt_map_red) + apply (clarsimp simp: page_of_def opt_map_def) + done + +lemma data_pages_relation_lift_rcorres: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (aobjs_of s) \ Q s s'\ f \\_ s. P (aobjs_of s)\; + \P s. \\s'. P (aobjs_of' s') \ Q s s'\ f' \\_ s'. P (aobjs_of' s')\; + \P s. \\s'. P (userDataDevice_at s') \ Q s s'\ f' \\_ s'. P (userDataDevice_at s')\; + \P s. \\s'. P (userData_at s') \ Q s s'\ f' \\_ s'. P (userData_at s')\\ + \ rcorres (\s s'. data_pages_relation s s' \ Q s s') f f' (\_ _. data_pages_relation)" + apply (rule rcorres_lift_abs[where p=aobjs_of]) + apply (rule rcorres_lift_conc) + apply (rule rcorres_prop_fwd) + apply (fastforce intro: no_fail_pre) + apply fastforce + apply fastforce + apply (rule hoare_weaken_pre) + apply (rule hoare_lift_Pf2_pre_conj[where f=userData_at]) + by (fastforce intro: hoare_weaken_pre)+ + +lemma ptes_relation_lift_rcorres: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (aobjs_of s) \ Q s s'\ f \\_ s. P (aobjs_of s)\; + \P s. \\s'. P (aobjs_of' s') \ Q s s'\ f' \\_ s'. P (aobjs_of' s')\\ + \ rcorres (\s s'. ptes_relation s s' \ Q s s') f f' (\_ _. ptes_relation)" + apply (rule rcorres_lift_abs[where p=aobjs_of]) + apply (rule rcorres_lift_conc) + apply (rule rcorres_prop_fwd) + by (fastforce intro: no_fail_pre hoare_weaken_pre)+ + +lemma asid_pools_relation_lift_rcorres: + "\\s'. no_fail (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (aobjs_of s) \ Q s s'\ f \\_ s. P (aobjs_of s)\; + \P s. \\s'. P (aobjs_of' s') \ Q s s'\ f' \\_ s'. P (aobjs_of' s')\\ + \ rcorres (\s s'. asid_pools_relation s s' \ Q s s') f f' (\_ _. asid_pools_relation)" + apply (rule rcorres_lift_abs[where p=aobjs_of]) + apply (rule rcorres_lift_conc) + apply (rule rcorres_prop_fwd) + by (fastforce intro: no_fail_pre hoare_weaken_pre)+ + +lemma aobjs_relation_lift_rcorres: + "\\s'. det_wp (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (aobjs_of s) \ Q s s'\ f \\_ s. P (aobjs_of s)\; + \P s. \\s'. P (aobjs_of' s') \ Q s s'\ f' \\_ s'. P (aobjs_of' s')\; + \P s. \\s'. P (userDataDevice_at s') \ Q s s'\ f' \\_ s'. P (userDataDevice_at s')\; + \P s. \\s'. P (userData_at s') \ Q s s'\ f' \\_ s'. P (userData_at s')\\ + \ rcorres (\s s'. aobjs_relation s s' \ Q s s') f f' (\_ _. aobjs_relation)" + unfolding aobjs_relation_def + apply (intro rcorres_conj_lift_fwd) + apply (fastforce elim: det_wp_pre) + apply (rule rcorres_weaken_pre) + apply (rule data_pages_relation_lift_rcorres) + apply (fastforce intro: det_wp_no_fail) + apply fastforce + apply (fastforce intro: hoare_weaken_pre) + apply (fastforce intro: hoare_weaken_pre) + apply wpsimp+ + apply (fastforce elim: det_wp_pre) + apply (rule rcorres_weaken_pre) + apply (rule ptes_relation_lift_rcorres) + apply (fastforce intro: det_wp_no_fail) + apply (fastforce intro: hoare_weaken_pre) + apply (fastforce intro: hoare_weaken_pre) + apply (fastforce intro: hoare_weaken_pre) + apply wpsimp + apply (rule rcorres_weaken_pre) + apply (rule asid_pools_relation_lift_rcorres) + by (fastforce intro: det_wp_no_fail)+ + +lemma ghost_relation_heap_ghost_relation[HeapStateRelation_R_assms]: + "ghost_relation_wrapper s s' \ heap_ghost_relation_wrapper s s'" + apply (clarsimp simp: ghost_relation_def heap_ghost_relation_def) + apply (rule cnf.conj_cong) + apply (intro iffI; clarsimp) + apply (force simp: page_of_def opt_map_def + split: option.splits arch_kernel_obj.splits) + apply (rename_tac a sz, drule_tac x=a in spec) + apply (force simp: page_of_def opt_map_def split: option.splits arch_kernel_obj.splits) + apply (intro iffI; clarsimp) + apply (force simp: cnode_of_def opt_map_def + split: option.splits Structures_A.kernel_object.splits) + apply (rename_tac a sz, drule_tac x=a in spec) + apply (force simp: cnode_of_def opt_map_def + split: Structures_A.kernel_object.splits option.splits) + done + +lemma heap_ghost_relation_lift_rcorres: + "\\s'. det_wp (\s. Q s s') f; empty_fail f; + \P s'. \\s. P (page_sizes_of s) \ Q s s'\ f \\_ s. P (page_sizes_of s)\; + \P s'. \\s. P (cnode_sizes_of s) \ Q s s'\ f \\_ s. P (cnode_sizes_of s)\; + \P s'. \\s. P (cnodes_of s) \ Q s s'\ f \\_ s. P (cnodes_of s)\; + \P s. \\s'. P (gsUserPages s') \ Q s s'\ f' \\_ s'. P (gsUserPages s')\; + \P s. \\s'. P (gsCNodes s') \ Q s s'\ f' \\_ s'. P (gsCNodes s')\\ + \ rcorres + (\s s'. heap_ghost_relation_wrapper s s' \ Q s s') + f f' + (\_ _ s s'. heap_ghost_relation_wrapper s s')" + apply (clarsimp simp: heap_ghost_relation_def) + apply (rule rcorres_conj_lift_fwd) + apply (fastforce intro: det_wp_pre) + apply (intro rcorres_allI_fwd) + apply (fastforce intro: det_wp_pre) + apply (fastforce intro: det_wp_pre) + apply (rule rcorres_lift_abs[where p=page_sizes_of]) + apply (rule rcorres_lift_conc) + apply (rule rcorres_prop_fwd) + apply (rule no_fail_pre) + apply (fastforce intro!: det_wp_no_fail) + apply fastforce + apply fastforce + apply force + apply (fastforce intro: hoare_weaken_pre) + apply (fastforce intro: hoare_weaken_pre) + apply (rule rcorres_allI_fwd) + apply (fastforce intro: det_wp_pre) + apply (rename_tac p) + apply (rule rcorres_allI_fwd) + apply (fastforce intro: det_wp_pre) + apply (rename_tac n) + apply (rule rcorres_weaken_pre) + apply (rule_tac R="\s x _. (cnode_sizes_of s p = Some n + \ (\cs. cnode_contents_of s p = Some cs \ well_formed_cnode_n n cs)) + = x" + in rcorres_lift_conc[where Q=Q]) + apply (rule rcorres_weaken_pre) + apply (rule_tac R="\x' s s'. (x' = Some n + \ (\cs. cnode_contents_of s p = Some cs \ well_formed_cnode_n n cs)) + = x" + and p="\s. cnode_sizes_of s p" + in rcorres_lift_abs[where Q=Q]) + apply (rule_tac rcorres_lift_abs) + apply (rule rcorres_prop_fwd) + apply (rule no_fail_pre) + apply (fastforce intro: det_wp_no_fail) + apply fastforce + apply fastforce + apply fastforce + by (fastforce intro: hoare_weaken_pre)+ + +end + +global_interpretation HeapStateRelation_R?: HeapStateRelation_R +proof goal_cases + interpret Arch . + case 1 show ?case by (intro_locales; (unfold_locales; fact HeapStateRelation_R_assms)?) +qed + +end diff --git a/proof/refine/RISCV64/ArchInvsDefs_H.thy b/proof/refine/RISCV64/ArchInvsDefs_H.thy index 497f38e3af..c051613fe4 100644 --- a/proof/refine/RISCV64/ArchInvsDefs_H.thy +++ b/proof/refine/RISCV64/ArchInvsDefs_H.thy @@ -208,5 +208,19 @@ lemma valid_sz_simps: pteBits_def wordSizeCase_def wordBits_def replySizeBits_def split: arch_kernel_object.splits) +text \Heap projections:\ + +definition asid_pool_of' :: "arch_kernel_object \ asidpool" where + "asid_pool_of' ko \ case ko of KOASIDPool pool \ Some pool | _ \ None" + +abbreviation asid_pools_of' :: "kernel_state \ obj_ref \ asidpool" where + "asid_pools_of' \ \s. aobjs_of' s |> asid_pool_of'" + +definition pte_of' :: "arch_kernel_object \ pte" where + "pte_of' ko \ case ko of KOPTE pte \ Some pte | _ \ None" + +abbreviation ptes_of' :: "kernel_state \ obj_ref \ pte" where + "ptes_of' \ \s. aobjs_of' s |> pte_of'" + end end diff --git a/proof/refine/RISCV64/ArchInvsLemmas_H.thy b/proof/refine/RISCV64/ArchInvsLemmas_H.thy index 473a3163bf..cbe7eaaf46 100644 --- a/proof/refine/RISCV64/ArchInvsLemmas_H.thy +++ b/proof/refine/RISCV64/ArchInvsLemmas_H.thy @@ -50,8 +50,8 @@ lemma valid_obj'_pspaceI[Invariants_H_pspaceI_assms]: "valid_obj' obj s \ ksPSpace s = ksPSpace s' \ valid_obj' obj s'" unfolding valid_obj'_def by (cases obj) - (auto simp: valid_ep'_def valid_ntfn'_def valid_tcb'_def valid_cte'_def - valid_tcb_state'_def valid_bound_obj'_def valid_sched_context'_def valid_reply'_def + (auto simp: valid_ntfn'_def valid_ntfn'_def valid_tcb'_def valid_cte'_def + valid_bound_obj'_def valid_sched_context'_def valid_reply'_def valid_arch_tcb'_def split: Structures_H.endpoint.splits Structures_H.notification.splits Structures_H.thread_state.splits ntfn.splits option.splits @@ -374,7 +374,6 @@ lemmas typ_at_lifts_strong = typ_at_lift_tcb'_strong typ_at_lift_ep'_strong typ_at_lift_ntfn'_strong typ_at_lift_cte'_strong typ_at_lift_reply'_strong typ_at_lift_sc'_strong - typ_at_lift_valid_tcb_state'_strong typ_at_lift_page_table_at'_strong typ_at_lift_frame_at'_strong valid_arch_tcb_lift'_strong @@ -467,15 +466,8 @@ lemma typ_at'_valid_obj'_lift: shows "\\s. valid_obj' obj s\ f \\rv s. valid_obj' obj s\" supply raw_tcb_cte_cases_simps[simp] (* FIXME arch-split: legacy, try use tcb_cte_cases_neqs *) apply (cases obj; simp add: valid_obj'_def hoare_TrueI) - apply (rename_tac endpoint) - apply (case_tac endpoint; simp add: valid_ep'_def, wp) - apply (rename_tac notification) - apply (case_tac "ntfnObj notification"; - simp add: valid_ntfn'_def split: option.splits; - (wpsimp|rule conjI)+) - apply (rename_tac tcb) - apply (case_tac "tcbState tcb"; - simp add: valid_tcb'_def valid_tcb_state'_def split_def opt_tcb_at'_def; + apply wpsimp + apply (simp add: valid_tcb'_def split_def opt_tcb_at'_def; wpsimp wp: sz hoare_case_option_wp) apply (wpsimp simp: valid_cte'_def sz) apply (rename_tac arch_kernel_object) diff --git a/proof/refine/RISCV64/ArchKHeap_R.thy b/proof/refine/RISCV64/ArchKHeap_R.thy index e57a31ef95..00b3f867ec 100644 --- a/proof/refine/RISCV64/ArchKHeap_R.thy +++ b/proof/refine/RISCV64/ArchKHeap_R.thy @@ -100,95 +100,17 @@ lemma obj_relation_cut_same_type: \ (\sz sz'. a_type ko = AArch (ADeviceData sz) \ a_type ko' = AArch (ADeviceData sz'))" apply (rule ccontr) apply (simp add: obj_relation_cuts_def2 a_type_def) - apply (auto simp: other_obj_relation_def tcb_relation_cut_def cte_relation_def pte_relation_def - other_aobj_relation_def - split: Structures_A.kernel_object.split_asm if_split_asm - Structures_H.kernel_object.split_asm - arch_kernel_obj.split_asm) - done + by (auto simp: tcb_relation_cut_def + ep_relation_cut_def ntfn_relation_cut_def other_aobj_relation_def + cte_relation_def pte_relation_def + ep_relation_def ntfn_relation_def + split: Structures_A.kernel_object.split_asm if_split_asm + Structures_H.kernel_object.split_asm + arch_kernel_obj.split_asm) lemmas obj_at_simps = gen_obj_at_simps is_other_obj_relation_type_def objBits_simps pageBits_def -lemma setObject_other_corres: - fixes ob' :: "'a :: pspace_storable" - assumes x: "updateObject ob' = updateObject_default ob'" - assumes z: "\s. obj_at' P ptr s - \ map_to_ctes ((ksPSpace s) (ptr \ injectKO ob')) = map_to_ctes (ksPSpace s)" - assumes t: "is_other_obj_relation_type (a_type ob)" - assumes b: "\ko. P ko \ objBits ko = objBits ob'" - assumes P: "\v::'a::pspace_storable. (1 :: machine_word) < 2 ^ objBits v" - assumes a: "\ is_ArchObj ob" - shows "other_obj_relation ob (injectKO (ob' :: 'a :: pspace_storable)) \ - corres dc (obj_at (\ko. a_type ko = a_type ob) ptr and obj_at (same_caps ob) ptr) - (obj_at' (P :: 'a \ bool) ptr) - (set_object ptr ob) (setObject ptr ob')" - supply image_cong_simp [cong del] projectKOs[simp del] - apply (rule corres_no_failI) - apply (rule no_fail_pre) - apply wp - apply (rule x) - apply (clarsimp simp: b elim!: obj_at'_weakenE) - apply (unfold set_object_def setObject_def) - apply (clarsimp simp: in_monad split_def bind_def gets_def get_def Bex_def - put_def return_def modify_def get_object_def x - projectKOs obj_at_def - updateObject_default_def in_magnitude_check [OF _ P]) - apply (rename_tac ko) - apply (clarsimp simp add: state_relation_def z) - apply (clarsimp simp add: caps_of_state_after_update cte_wp_at_after_update - swp_def fun_upd_def obj_at_def) - apply (subst conj_assoc[symmetric]) - apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) - apply (clarsimp simp add: ghost_relation_def) - apply (erule_tac x=ptr in allE)+ - apply (clarsimp simp: obj_at_def a_type_def - split: Structures_A.kernel_object.splits if_split_asm) - apply (simp split: arch_kernel_obj.splits if_splits) - apply (fold fun_upd_def) - apply (simp only: pspace_relation_def pspace_dom_update dom_fun_upd2 simp_thms) - apply (elim conjE) - apply (frule bspec, erule domI) - apply (prop_tac "typ_at' (koTypeOf (injectKO ob')) ptr b") - subgoal - by (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def projectKO_opts_defs - a_type_def other_obj_relation_def a - split: Structures_A.kernel_object.split_asm if_split_asm - kernel_object.split_asm) - apply (insert a) - apply (frule a_type_eq_is_ArchObj) - apply (rule conjI) - apply (rule conjI) - apply (rule ballI, drule(1) bspec) - apply (drule domD) - apply (clarsimp simp: is_other_obj_relation_type t a) - apply (drule(1) bspec) - apply clarsimp - apply (frule_tac ko'=ko and x'=ptr in obj_relation_cut_same_type, - (fastforce simp add: is_other_obj_relation_type t)+) - apply (insert t) - apply ((erule disjE - | clarsimp simp: is_other_obj_relation_type is_other_obj_relation_type_def a_type_def)+)[1] - (* sc_replies_relation *) - apply (simp add: sc_replies_relation_def) - apply (clarsimp simp: sc_replies_of_scs_def map_project_def scs_of_kh_def) - apply (drule_tac x=p in spec) - apply (rule conjI; clarsimp split: Structures_A.kernel_object.split_asm if_split_asm) - apply (clarsimp simp: a_type_def is_other_obj_relation_type_def) - apply (rename_tac sc n) - apply (drule replyPrevs_of_non_reply_update[simplified]) - subgoal - by (clarsimp simp: other_obj_relation_def; cases ob; cases "injectKO ob'"; - simp) - apply (clarsimp simp: opt_map_def) - \ \ready_queues_relation and release_queue_relation\ - apply (prop_tac "koTypeOf (injectKO ob') \ TCBT") - subgoal - by (clarsimp simp: other_obj_relation_def; cases ob; cases "injectKO ob'"; - simp split: arch_kernel_obj.split_asm) - by (fastforce dest: tcbs_of'_non_tcb_update) - -(* analogous to setObject_other_corres, but for arch objects *) lemma setObject_other_arch_corres: fixes ob' :: "'a :: pspace_storable" assumes x: "updateObject ob' = updateObject_default ob'" @@ -214,7 +136,7 @@ lemma setObject_other_arch_corres: put_def return_def modify_def get_object_def x projectKOs obj_at_def updateObject_default_def in_magnitude_check [OF _ P]) - apply (rename_tac ko) + apply (rename_tac s s' ko' psp_storable_obj ko) apply (clarsimp simp add: state_relation_def z) apply (clarsimp simp add: caps_of_state_after_update cte_wp_at_after_update swp_def fun_upd_def obj_at_def) @@ -230,10 +152,24 @@ lemma setObject_other_arch_corres: apply (elim conjE) apply (frule bspec, erule domI) apply (prop_tac "is_ArchObj ko", clarsimp simp: a dest!: a_type_eq_is_ArchObj) - apply (prop_tac "typ_at' (koTypeOf (injectKO ob')) ptr b") + apply (prop_tac "typ_at' (koTypeOf (injectKO ob')) ptr s'") + subgoal + by (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def projectKO_opts_defs + is_other_obj_relation_type_def a_type_def other_aobj_relation_def + split: Structures_A.kernel_object.split_asm if_split_asm + arch_kernel_obj.split_asm kernel_object.split_asm + arch_kernel_object.split_asm) + apply (prop_tac "tcb_of' (injectKO ob') = None") + subgoal + by (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def projectKO_opts_defs + is_other_obj_relation_type_def a_type_def other_aobj_relation_def + split: Structures_A.kernel_object.split_asm if_split_asm + arch_kernel_obj.split_asm kernel_object.split_asm) + apply (prop_tac "tcbs_of' s' ptr = None") subgoal by (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def projectKO_opts_defs is_other_obj_relation_type_def a_type_def other_aobj_relation_def + opt_map_def split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm kernel_object.split_asm arch_kernel_object.split_asm) @@ -249,7 +185,10 @@ lemma setObject_other_arch_corres: apply (insert t) apply ((erule disjE | clarsimp simp: is_other_obj_relation_type is_other_obj_relation_type_def a_type_def)+)[1] - (* sc_replies_relation *) + apply (clarsimp simp: ep_queues_relation_def eps_of_kh_def opt_map_def split: option.splits) + apply (extract_conjunct \match conclusion in "ntfn_queues_relation_2 _ _ _ _" \ -\) + apply (clarsimp simp: ntfn_queues_relation_def typ_at'_def opt_map_def split: option.splits) + apply (extract_conjunct \match conclusion in "sc_replies_relation_2 _ _ _" \ -\) apply (simp add: sc_replies_relation_def) apply (clarsimp simp: sc_replies_of_scs_def map_project_def scs_of_kh_def) apply (drule_tac x=p in spec) @@ -262,16 +201,8 @@ lemma setObject_other_arch_corres: simp split: arch_kernel_obj.split_asm) apply (clarsimp simp: opt_map_def) \ \ready_queues_relation and release_queue_relation\ - apply (prop_tac "koTypeOf (injectKO ob') \ TCBT") - subgoal - by (clarsimp simp: other_aobj_relation_def; cases ob; cases "injectKO ob'"; - simp split: arch_kernel_obj.split_asm) by (fastforce dest: tcbs_of'_non_tcb_update) -lemmas [KHeap_R_assms] = - setObject_other_corres[where 'a=endpoint] - setObject_other_corres[where 'a=notification] - lemma dmo_storeWordVM' [simp]: "doMachineOp (storeWordVM x y) = return ()" by (simp add: storeWordVM_def) @@ -338,7 +269,7 @@ lemma st_tcb_at_coerce_abstract[KHeap_R_assms]: apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def objBits_simps) apply (erule(1) pspace_dom_relatedE) apply (erule(1) obj_relation_cutsE, simp_all) - apply (fastforce simp: st_tcb_at_def obj_at_def other_obj_relation_def tcb_relation_def + apply (fastforce simp: st_tcb_at_def obj_at_def tcb_relation_def split: Structures_A.kernel_object.split_asm if_split_asm RISCV64_A.arch_kernel_obj.split_asm)+ done @@ -356,7 +287,7 @@ lemma st_tcb_at_coerce_concrete[KHeap_R_assms]: apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def) apply (erule (1) pspace_dom_relatedE) apply (erule (1) obj_relation_cutsE, simp_all) - apply (fastforce simp: st_tcb_at'_def obj_at'_def other_obj_relation_def tcb_relation_def + apply (fastforce simp: st_tcb_at'_def obj_at'_def tcb_relation_def split: Structures_A.kernel_object.split_asm if_split_asm)+ done @@ -370,7 +301,6 @@ qed (* requalify interface lemmas which can't be locale assumptions due to free type variable *) arch_requalify_facts - setObject_other_corres setObject_pspace_in_kernel_mappings' valid_global_refs_lift' @@ -462,35 +392,12 @@ lemmas set_ntfn_valid_pspace'[wp] = lemmas set_sc_valid_pspace'[wp] = set_sc'.valid_pspace'[simplified valid_obj'_def pred_conj_def, simplified] -lemma setSchedContext_iflive'[wp]: - "\if_live_then_nonz_cap' and (\s. live_sc' sc \ ex_nonz_cap_to' p s)\ - setSchedContext p sc - \\_. if_live_then_nonz_cap'\" - unfolding setSchedContext_def - by (wpsimp wp: setObject_iflive'[where P="\"] - simp: updateObject_default_def in_monad scBits_pos_power2 - gen_objBits_simps bind_def live'_def) - -lemma setReply_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' p\ - setReply p reply - \\_. if_live_then_nonz_cap'\" - unfolding setReply_def - by (wpsimp wp: setObject_iflive'[where P="\"] - simp: updateObject_default_def in_monad - gen_objBits_simps bind_def live'_def) - lemmas valid_globals_cte_wpD'_idleThread = valid_globals_cte_wpD'[OF _ _ idle_is_global] lemmas valid_globals_cte_wpD'_idleSC = valid_globals_cte_wpD'[OF _ _ idle_sc_is_global] - - - (*FIXME arch-split RT: everything after this*) lemma set_ntfn_minor_invs': - "\invs' - and valid_ntfn' val - and (\s. live' (KONotification val) \ ex_nonz_cap_to' ptr s)\ + "\invs' and valid_ntfn' val\ setNotification ptr val \\_. invs'\" apply (clarsimp simp add: invs'_def cteCaps_of_def valid_dom_schedule'_def) @@ -508,7 +415,8 @@ lemma reply_at'_cross: apply (clarsimp simp: obj_at'_def) apply (erule (1) pspace_dom_relatedE) by (clarsimp simp: obj_relation_cuts_def2 obj_at_def is_reply cte_relation_def - other_obj_relation_def other_aobj_relation_def pte_relation_def tcb_relation_cut_def + pte_relation_def tcb_relation_cut_def + ep_relation_cut_def ntfn_relation_cut_def other_aobj_relation_def split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -583,7 +491,9 @@ proof - \ \ready_queues_relation and release_queue_relation\ apply (prop_tac "typ_at' (koTypeOf (injectKO ae')) ptr b") apply (simp add: typ_at'_def ko_wp_at'_def) - by (fastforce dest: tcbs_of'_non_tcb_update) + apply (simp add: eps_of_kh_def) + apply (fastforce simp: opt_map_def projectKO_opts_defs) + done qed lemma setReply_not_queued_corres: (* for reply updates on replies not in fst ` replies_with_sc *) @@ -663,7 +573,8 @@ proof - \ \ready_queues_relation and release_queue_relation\ apply (prop_tac "typ_at' (koTypeOf (injectKO r2)) ptr b") apply (simp add: typ_at'_def ko_wp_at'_def) - by (fastforce dest!: tcbs_of'_non_tcb_update) + apply (simp add: eps_of_kh_def) + by (fastforce simp: opt_map_def projectKO_opts_defs) qed lemma sc_at'_cross: @@ -673,7 +584,8 @@ lemma sc_at'_cross: apply (clarsimp simp: obj_at'_def) apply (erule (1) pspace_dom_relatedE) by (clarsimp simp: obj_relation_cuts_def2 obj_at_def is_sc_obj cte_relation_def - other_obj_relation_def other_aobj_relation_def pte_relation_def tcb_relation_cut_def + pte_relation_def tcb_relation_cut_def + ep_relation_cut_def ntfn_relation_cut_def other_aobj_relation_def split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -684,8 +596,9 @@ lemma sc_obj_at'_cross: apply (clarsimp simp: obj_at'_def) apply (erule (1) pspace_dom_relatedE) by (clarsimp simp: obj_relation_cuts_def2 obj_at_def is_sc_obj cte_relation_def - objBits_simps scBits_simps other_obj_relation_def - other_aobj_relation_def pte_relation_def sc_relation_def tcb_relation_cut_def + objBits_simps scBits_simps + pte_relation_def sc_relation_def tcb_relation_cut_def + ep_relation_cut_def ntfn_relation_cut_def other_aobj_relation_def split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -757,10 +670,8 @@ lemma setSchedContext_corres: subgoal by (auto simp: typ_at'_def ko_wp_at'_def opt_map_def projectKO_opts_defs split: if_splits) - apply (prop_tac "typ_at' (koTypeOf (injectKO sc')) ptr s'") - apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def) - apply (prop_tac "koTypeOf (injectKO sc') \ TCBT", simp) - by (fastforce dest: tcbs_of'_non_tcb_update) + apply (simp add: eps_of_kh_def) + by (fastforce simp: opt_map_def projectKO_opts_defs) qed lemma setSchedContext_update_corres_Q: @@ -866,8 +777,8 @@ lemma tcb_at'_cross: using assms apply (clarsimp simp: obj_at'_def) apply (erule (1) pspace_dom_relatedE) - by (clarsimp simp: obj_relation_cuts_def2 obj_at_def cte_relation_def - other_obj_relation_def pte_relation_def is_tcb_def + by (clarsimp simp: obj_relation_cuts_def2 obj_at_def cte_relation_def + pte_relation_def is_tcb_def ep_relation_cut_def ntfn_relation_cut_def split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) lemma st_tcb_at_runnable_cross: @@ -895,7 +806,7 @@ lemma bound_sc_tcb_at_cross: apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def opt_map_red) apply (erule (1) pspace_dom_relatedE) apply (erule (1) obj_relation_cutsE, simp_all) - apply (clarsimp simp: st_tcb_at'_def obj_at'_def other_obj_relation_def tcb_relation_def + apply (clarsimp simp: st_tcb_at'_def obj_at'_def tcb_relation_def split: Structures_A.kernel_object.split_asm if_split_asm)+ done @@ -912,7 +823,7 @@ lemma bound_yt_tcb_at_cross: apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def) apply (erule (1) pspace_dom_relatedE) apply (erule (1) obj_relation_cutsE, simp_all) - apply (fastforce simp: st_tcb_at'_def obj_at'_def other_obj_relation_def tcb_relation_def + apply (fastforce simp: st_tcb_at'_def obj_at'_def tcb_relation_def split: Structures_A.kernel_object.split_asm if_split_asm)+ done @@ -971,21 +882,12 @@ lemma ep_at_cross: shows "ep_at' ptr s'" using assms apply (clarsimp simp: obj_at_def is_ep) - apply (drule (1) pspace_relation_absD, clarsimp simp: other_obj_relation_def) - 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_ep[where P="\_. True"]) - apply (corresKsimp wp: get_object_ret get_object_wp)+ - by (fastforce simp: is_ep gen_obj_at_simps objBits_defs partial_inv_def) + apply (drule (1) pspace_relation_absD, clarsimp) + apply (rename_tac ko, case_tac ko; + fastforce dest!: aligned_distinct_ko_at'I[where 'a=endpoint] + elim: obj_at'_weakenE + simp: ep_relation_cut_def) + done lemma ntfn_at_cross: assumes p: "pspace_relation (kheap s) (ksPSpace s')" @@ -994,9 +896,12 @@ lemma ntfn_at_cross: shows "ntfn_at' ptr s'" using assms apply (clarsimp simp: obj_at_def is_ntfn) - apply (drule (1) pspace_relation_absD, clarsimp simp: other_obj_relation_def) - apply (case_tac z; simp) - by (fastforce dest!: aligned_distinct_ko_at'I[where 'a=notification] elim: obj_at'_weakenE) + apply (drule (1) pspace_relation_absD, clarsimp) + apply (rename_tac ko, case_tac ko; + fastforce dest!: aligned_distinct_ko_at'I[where 'a=notification] + elim: obj_at'_weakenE + simp: ntfn_relation_cut_def) + done lemma sc_at_cross: assumes p: "pspace_relation (kheap s) (ksPSpace s')" @@ -1051,80 +956,102 @@ lemma real_cte_at_cross: using assms apply (clarsimp simp: obj_at_def is_ntfn) apply (drule (1) pspace_relation_absD) - apply (clarsimp simp: is_cap_table other_obj_relation_def well_formed_cnode_n_def) + apply (clarsimp simp: is_cap_table well_formed_cnode_n_def) apply (prop_tac "\z. ksPSpace s' (cte_map (fst ptr, snd ptr)) = Some z \ cte_relation (snd ptr) (CNode (length (snd ptr)) cs) z") apply fastforce apply (clarsimp split: kernel_object.split_asm simp: cte_relation_def) by (fastforce dest!: aligned_distinct_ko_at'I[where 'a=cte] elim: obj_at'_weakenE) -lemma valid_tcb_state_cross: - assumes "pspace_relation (kheap s) (ksPSpace s')" - "thread_state_relation ts ts'" - "pspace_aligned s" - "pspace_distinct s" - "valid_tcb_state ts s" - shows "valid_tcb_state' ts' s'" using assms - by (fastforce dest: ep_at_cross reply_at_cross ntfn_at_cross - simp: valid_bound_obj'_def valid_tcb_state_def valid_tcb_state'_def - split: Structures_A.thread_state.split_asm option.split_asm) - -lemma state_refs_of_cross_eq: - "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s\ - \ state_refs_of' s' = state_refs_of s" - apply (rule sym) - apply (rule ext, rename_tac p) +lemma sym_refs_cross: + "\sym_refs (state_refs_of s); (s, s') \ state_relation; pspace_aligned s; pspace_distinct s\ + \ sym_refs (state_refs_of' s')" apply (frule state_relation_pspace_relation) apply (frule (2) pspace_distinct_cross) apply (frule (1) pspace_aligned_cross) - apply (clarsimp simp: state_refs_of_def state_refs_of'_def - split: option.split) - apply (rule conjI; clarsimp) - apply (rename_tac ko') - apply (erule (1) pspace_dom_relatedE) - apply (rename_tac ko P; case_tac ko; clarsimp split: if_split_asm simp: cte_relation_def) - apply (rename_tac ako; case_tac ako; clarsimp simp: pte_relation_def) - apply (rule conjI; clarsimp) - apply (drule (1) pspace_relation_None; clarsimp) - apply (rule conjI[rotated]; clarsimp) - apply (frule pspace_relation_pspace_bounded'[OF state_relation_pspace_relation]) - apply (frule pspace_alignedD'; frule pspace_boundedD'; clarsimp dest!: pspace_distinctD') - apply (rename_tac ko ko') - apply (frule (1) pspace_relation_absD) - apply (case_tac ko; clarsimp split: if_split_asm) - apply (rename_tac n sz, drule_tac x=p and y="cte_relation (replicate n False)" in spec2) - apply (fastforce simp: cte_relation_def cte_map_def well_formed_cnode_n_def) - apply (find_goal \match premises in "_ = Some (ArchObj _)" \ -\) - apply (rename_tac ako; case_tac ako; simp) - apply (case_tac ko'; clarsimp simp: other_aobj_relation_def) - apply ((drule_tac x=0 in spec, clarsimp simp: pte_relation_def)+)[1] - apply (drule_tac x=p in spec) - apply (rename_tac b sz) - apply (drule_tac x="\_ obj. obj = (if b then KOUserDataDevice else KOUserData)" in spec, clarsimp) - apply (simp only: imp_ex) - apply (drule_tac x=0 in spec, clarsimp simp: pageBitsForSize_def ptTranslationBits_def - split: vmpage_size.split_asm) - apply (all \case_tac ko'; clarsimp simp: other_obj_relation_def tcb_relation_cut_def\) - apply (rename_tac tcb tcb'; - clarsimp simp: tcb_relation_def arch_tcb_relation_def fault_rel_optionation_def - thread_state_relation_def tcb_st_refs_of_def tcb_st_refs_of'_def; - rename_tac tcb'; case_tac "tcb_state tcb"; case_tac "tcbState tcb'"; - clarsimp simp: tcb_bound_refs'_def get_refs_def2 split: option.splits) - apply (clarsimp simp: ep_q_refs_of_def ep_relation_def split: Structures_A.endpoint.splits) - apply (clarsimp simp: ntfn_q_refs_of_def ntfn_relation_def split: Structures_A.ntfn.splits) + apply (frule pspace_relation_pspace_bounded') + apply (clarsimp simp: pspace_relation_heap_pspace_relation) + apply (clarsimp simp: state_refs_of_def state_refs_of'_def sym_refs_def refs_of'_def + split: option.split kernel_object.splits) + apply (rename_tac ptr ko) + apply (drule_tac x=ptr in spec) + apply (intro conjI impI allI) + apply (frule heap_pspace_relation_ntfns_relation) + apply (frule (1) ntfns_relation_ntfn_relation_conc) + apply (clarsimp simp: ntfn_relation_def) + apply (elim disjE) + apply (force dest!: tcbs_relation_tcb_relation_abs_obj_at' + simp: refs_of_def get_refs_def2 tcb_bound_refs'_def tcb_relation_def obj_at'_def + split: Structures_A.kernel_object.splits option.splits) + apply (force dest!: scs_relation_sc_relation_abs_obj_at' + simp: refs_of_def get_refs_def2 sc_relation_def obj_at'_def + split: Structures_A.kernel_object.splits option.splits) + apply (frule heap_pspace_relation_tcbs_relation) + apply (frule (1) tcbs_relation_tcb_relation_conc) + apply (clarsimp simp: tcb_relation_def split: option.splits) + apply (rename_tac ref tp) + apply (elim disjE) + apply (clarsimp simp: tcb_st_refs_of'_def) + apply (drule_tac x="(ref, TCBReply)" in bspec) + apply (force simp: tcb_st_refs_of_def split: Structures_A.thread_state.splits if_splits) + apply (force dest!: replies_relation_reply_relation_abs_obj_at' + simp: refs_of_def get_refs_def2 obj_at'_def reply_relation_def + split: Structures_A.kernel_object.splits option.splits thread_state.splits + if_splits) + apply (clarsimp simp: tcb_bound_refs'_def) + subgoal + by (elim disjE; + force dest!: scs_relation_sc_relation_abs_obj_at' + ntfns_relation_ntfn_relation_abs_obj_at' + simp: ntfn_relation_def sc_relation_def refs_of_def get_refs_def2 obj_at'_def + split: Structures_A.kernel_object.splits option.splits) + apply (frule heap_pspace_relation_scs_relation) + apply (frule (1) scs_relation_sc_relation_conc) + apply (clarsimp simp: sc_relation_def split: option.splits) + apply (elim disjE) + apply (force dest!: ntfns_relation_ntfn_relation_abs_obj_at' + simp: ntfn_relation_def refs_of_def get_refs_def2 obj_at'_def + split: Structures_A.kernel_object.splits option.splits) + apply (force dest!: tcbs_relation_tcb_relation_abs_obj_at' + simp: refs_of_def get_refs_def2 tcb_bound_refs'_def tcb_relation_def obj_at'_def + split: Structures_A.kernel_object.splits option.splits) + apply (force dest!: tcbs_relation_tcb_relation_abs_obj_at' + simp: refs_of_def get_refs_def2 tcb_bound_refs'_def tcb_relation_def obj_at'_def + split: Structures_A.kernel_object.splits option.splits) apply (clarsimp simp: sc_relation_def get_refs_def2) apply (drule state_relation_sc_replies_relation) - apply (frule sc_replies_relation_scReplies_of) - apply (fastforce simp: obj_at_def is_sc_obj_def) - apply (clarsimp simp: opt_map_def) - apply (clarsimp simp: opt_map_def sc_replies_of_scs_def map_project_def scs_of_kh_def) - apply (clarsimp simp: reply_relation_def split: Structures_A.ntfn.splits) - done - -lemma state_refs_of_cross: - "\P (state_refs_of s); (s, s') \ state_relation; pspace_aligned s; pspace_distinct s\ - \ P (state_refs_of' s')" - by (clarsimp simp: state_refs_of_cross_eq elim!: rsubst[where P=P]) + apply (frule_tac sc_ptr=ptr in sc_replies_relation_scReplies_of) + apply (force simp: scs_relation_def obj_at_def is_sc_obj_def opt_map_def scs_of_kh_def + hd_opt_def + split: option.splits) + apply (clarsimp simp: obj_at'_def opt_map_def) + apply (force dest!: replies_relation_reply_relation_abs_obj_at' + simp: get_refs_def2 obj_at'_def reply_relation_def opt_map_def + sc_replies_of_scs_def map_project_def scs_of_kh_def refs_of_def hd_opt_def + split: Structures_A.kernel_object.splits option.splits) + apply (frule heap_pspace_relation_replies_relation) + apply (frule (1) replies_relation_reply_relation_conc) + apply (clarsimp simp: reply_relation_def split: option.splits) + apply (rename_tac ref tp) + apply (elim disjE) + apply (clarsimp simp: refs_of_def get_refs_def2 + split: Structures_A.kernel_object.splits option.splits) + apply (frule heap_pspace_relation_scs_relation) + apply (frule (4) scs_relation_sc_relation_abs_obj_at') + apply (intro context_conjI impI allI) + apply (clarsimp simp: get_refs_def2 refs_of_def refs_of'_def obj_at'_def split: option.splits) + apply (clarsimp simp: get_refs_def2 obj_at'_def) + apply (drule state_relation_sc_replies_relation) + apply (frule_tac sc_ptr=ref in sc_replies_relation_scReplies_of) + apply (clarsimp simp: scs_relation_def obj_at_def is_sc_obj_def) + apply (clarsimp simp: opt_map_def) + apply (clarsimp simp: opt_map_def sc_replies_of_scs_def map_project_def scs_of_kh_def) + apply (force simp: obj_at'_def) + apply (clarsimp simp: get_refs_def2 refs_of_def refs_of'_def + split: Structures_A.kernel_object.splits option.splits) + by (force dest!: tcbs_relation_tcb_relation_abs_obj_at' + simp: tcb_st_refs_of_def obj_at'_def tcb_relation_def + split: if_splits Structures_A.thread_state.splits) lemma ct_not_inQ_cross: "\(s, s') \ state_relation; ct_not_in_q s; cur_tcb s; pspace_aligned s; @@ -1184,7 +1111,6 @@ lemma sch_act_wf_cross: apply (clarsimp simp: pspace_relation_def) apply (drule_tac x=target in bspec, fastforce) apply (drule_tac x="(target, tcb_relation_cut)" in bspec, fastforce) - apply (clarsimp simp: other_obj_relation_def) apply (intro conjI) apply (fastforce intro!: st_tcb_at_runnable_cross simp: obj_at_def pred_tcb_at_def) @@ -1266,11 +1192,258 @@ lemma ready_qs_runnable_cross: simp: obj_at'_def st_tcb_at'_def) done +lemma live'_tcb_cross: + "\live' (KOTCB tcb'); kheap s ptr = Some (TCB tcb); ksPSpace s' ptr = Some (KOTCB tcb'); + tcbs_relation s s'; ready_queues_relation s s'; release_queue_relation s s'; + ready_queues_runnable s; in_correct_ready_q s; release_q_runnable s; valid_sched_pointers s'; + pspace_aligned' s'; pspace_distinct' s'\ + \ live (TCB tcb)" + apply (frule (1) tcbs_relation_tcb_relation_abs) + apply (clarsimp simp: live'_def) + apply (elim disjE) + apply (clarsimp simp: tcb_relation_def live_def) + apply (clarsimp simp: tcb_relation_def live_def) + apply (clarsimp simp: tcb_relation_def live_def) + apply (clarsimp simp: valid_sched_pointers_def) + apply (fastforce intro!: sched_flag_set_live simp: opt_map_def split: option.splits) + apply (clarsimp simp: valid_sched_pointers_def) + apply (fastforce intro!: sched_flag_set_live simp: opt_map_def split: option.splits) + apply (fastforce intro!: sched_flag_set_live[where s'=s'] simp: opt_pred_def opt_map_red) + apply (fastforce intro!: sched_flag_set_live[where s'=s'] simp: opt_pred_def opt_map_red) + apply (prop_tac "st_tcb_at' (\st. st \ Inactive \ st \ IdleThreadState) ptr s'") + apply (fastforce intro: aligned'_distinct'_obj_at'_propI simp: st_tcb_at'_def) + apply (fastforce dest: st_tcb_at_coerce_abstract' simp: pred_tcb_at_def obj_at_def live_def) + apply (fastforce simp: hyp_live'_def) + done + +lemma tcb_cases_related2: + "tcb_cte_cases (v - x) = Some (getF, setF) \ + \getF' setF' restr. tcb_cap_cases (tcb_cnode_index (unat ((v - x) >> cte_level_bits))) + = Some (getF', setF', restr) + \ cte_map (x, tcb_cnode_index (unat ((v - x) >> cte_level_bits))) = v + \ (\tcb tcb'. tcb_relation tcb tcb' \ cap_relation (getF' tcb) (cteCap (getF tcb'))) + \ (\tcb tcb' cap cte. tcb_relation tcb tcb' \ cap_relation cap (cteCap cte) + \ tcb_relation (setF' (\x. cap) tcb) (setF (\x. cte) tcb'))" + apply (clarsimp simp: tcb_cte_cases_def tcb_relation_def cte_level_bits_def cteSizeBits_def + tcb_cap_cases_simps[simplified] + split: if_split_asm) + apply (simp_all add: tcb_cnode_index_def cte_level_bits_def cte_map_def field_simps to_bl_1) + done + +lemma pspace_relation_cte_wp_atI': + "\pspace_relation (kheap s) (ksPSpace s'); cte_wp_at' ((=) cte) x s'; valid_objs s\ + \ \c slot. cte_wp_at ((=) c) slot s \ cap_relation c (cteCap cte) \ x = cte_map slot" + apply (simp add: cte_wp_at_cases') + apply (elim disjE conjE exE) + apply (erule(1) pspace_dom_relatedE) + apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm)[1] + apply (intro exI, rule conjI[OF _ conjI [OF _ refl]]) + apply (simp add: cte_wp_at_cases domI well_formed_cnode_invsI) + apply (simp split: if_split_asm) + apply (erule(1) pspace_dom_relatedE) + apply (erule(1) obj_relation_cutsE, simp_all split: if_split_asm) + apply (subgoal_tac "n = x - y", clarsimp) + apply (drule tcb_cases_related2, clarsimp) + apply (intro exI, rule conjI) + apply (erule(1) cte_wp_at_tcbI[where t="(a, b)" for a b, simplified]) + apply fastforce + apply simp + apply clarsimp + done + +lemma pspace_relation_cte_wp_atI: + "\pspace_relation (kheap s) (ksPSpace s'); ctes_of (s' :: kernel_state) x = Some cte; + valid_objs s\ + \ \c slot. cte_wp_at ((=) c) slot s \ cap_relation c (cteCap cte) \ x = cte_map slot" + apply (erule pspace_relation_cte_wp_atI'[where x=x]) + apply (simp add: cte_wp_at_ctes_of) + apply assumption + done + +lemma tcb_cases_related: + "tcb_cap_cases ref = Some (getF, setF, restr) + \ \getF' setF'. + (\x. tcb_cte_cases (cte_map (x, ref) - x) = Some (getF', setF')) + \ (\tcb tcb'. tcb_relation tcb tcb' \ cap_relation (getF tcb) (cteCap (getF' tcb')))" + by (clarsimp simp: tcb_relation_def cte_map_def tcb_cap_cases_def tcb_cte_cases_neqs + tcb_cte_cases_def tcb_cnode_index_def + to_bl_1 + simp flip: cteSizeBits_cte_level_bits + split: if_split_asm) + +lemma pspace_relation_cte_wp_at: + "\pspace_relation (kheap s) (ksPSpace s'); cte_wp_at ((=) c) (cref, oref) s; pspace_aligned' s'; + pspace_distinct' s'\ + \ cte_wp_at' (\cte. cap_relation c (cteCap cte)) (cte_map (cref, oref)) s'" + apply (simp add: cte_wp_at_cases) + apply (erule disjE) + apply clarsimp + apply (drule(1) pspace_relation_absD) + apply (simp add: unpleasant_helper) + apply (drule spec, drule mp, erule domI) + apply (clarsimp simp: cte_relation_def) + apply (drule(2) aligned'_distinct'_ko_at'I[where 'a=cte], simp) + apply simp + apply (drule ko_at_imp_cte_wp_at') + apply (clarsimp elim!: cte_wp_at_weakenE') + apply clarsimp + apply (drule(1) pspace_relation_absD) + apply (clarsimp simp: tcb_relation_cut_def) + apply (simp split: kernel_object.split_asm) + apply (drule(2) aligned'_distinct'_ko_at'I[where 'a=tcb], simp) + apply simp + apply (drule tcb_cases_related) + apply (clarsimp simp: obj_at'_def gen_objBits_simps) + apply (erule(2) cte_wp_at_tcbI') + apply fastforce + apply simp + done + +lemma ex_nonz_cap_to_ep_at_cross: + "\ex_nonz_cap_to ptr s; ep_at ptr s; valid_objs s; pspace_relation (kheap s) (ksPSpace s'); + pspace_aligned' s'; pspace_distinct' s'\ + \ ex_nonz_cap_to' ptr s'" + apply (clarsimp simp: ex_nonz_cap_to_def cte_wp_at_caps_of_state ex_nonz_cap_to'_def) + apply (rename_tac oref cref cap) + apply (frule (1) caps_of_state_valid_cap) + apply (frule set_mp[OF zobj_refs_subseteq_obj_refs]) + apply (frule (2) valid_cap_ep_at_ep_cap) + apply (rule_tac x="cte_map (oref, cref)" in exI) + apply (simp add: caps_of_state_Some_simp) + apply (frule (3) pspace_relation_cte_wp_at) + apply (drule cte_wp_at_norm') + apply clarsimp + apply (erule cte_wp_at_weakenE') + apply (case_tac cap; clarsimp) + done + +lemma ex_nonz_cap_to_ntfn_at_cross: + "\ex_nonz_cap_to ptr s; ntfn_at ptr s; valid_objs s; pspace_relation (kheap s) (ksPSpace s'); + pspace_aligned' s'; pspace_distinct' s'\ + \ ex_nonz_cap_to' ptr s'" + apply (clarsimp simp: ex_nonz_cap_to_def cte_wp_at_caps_of_state ex_nonz_cap_to'_def) + apply (rename_tac oref cref cap) + apply (frule (1) caps_of_state_valid_cap) + apply (frule set_mp[OF zobj_refs_subseteq_obj_refs]) + apply (frule (2) valid_cap_ntfn_at_ntfn_cap) + apply (rule_tac x="cte_map (oref, cref)" in exI) + apply (simp add: caps_of_state_Some_simp) + apply (frule (3) pspace_relation_cte_wp_at) + apply (drule cte_wp_at_norm') + apply clarsimp + apply (erule cte_wp_at_weakenE') + apply (case_tac cap; clarsimp) + done + +lemma ex_nonz_cap_to_sc_at_cross: + "\ex_nonz_cap_to ptr s; sc_at ptr s; valid_objs s; pspace_relation (kheap s) (ksPSpace s'); + pspace_aligned' s'; pspace_distinct' s'\ + \ ex_nonz_cap_to' ptr s'" + apply (frule pspace_relation_pspace_bounded') + apply (clarsimp simp: ex_nonz_cap_to_def cte_wp_at_caps_of_state ex_nonz_cap_to'_def) + apply (rename_tac oref cref cap) + apply (frule (1) caps_of_state_valid_cap) + apply (frule set_mp[OF zobj_refs_subseteq_obj_refs]) + apply (frule (2) valid_cap_sc_at_sc_cap) + apply (rule_tac x="cte_map (oref, cref)" in exI) + apply (simp add: caps_of_state_Some_simp) + apply (frule (3) pspace_relation_cte_wp_at) + apply (drule cte_wp_at_norm') + apply clarsimp + apply (erule cte_wp_at_weakenE') + apply (case_tac cap; clarsimp) + done + +lemma ex_nonz_cap_to_reply_at_cross: + "\ex_nonz_cap_to ptr s; reply_at ptr s; valid_objs s; pspace_relation (kheap s) (ksPSpace s'); + pspace_aligned' s'; pspace_distinct' s'\ + \ ex_nonz_cap_to' ptr s'" + apply (clarsimp simp: ex_nonz_cap_to_def cte_wp_at_caps_of_state ex_nonz_cap_to'_def) + apply (rename_tac oref cref cap) + apply (frule (1) caps_of_state_valid_cap) + apply (frule set_mp[OF zobj_refs_subseteq_obj_refs]) + apply (frule (2) valid_cap_reply_at_reply_cap) + apply (rule_tac x="cte_map (oref, cref)" in exI) + apply (simp add: caps_of_state_Some_simp) + apply (frule (3) pspace_relation_cte_wp_at) + apply (drule cte_wp_at_norm') + apply clarsimp + apply (erule cte_wp_at_weakenE') + apply (case_tac cap; clarsimp simp: is_reply_cap_def) + done + +lemma ex_nonz_cap_to_tcb_at_cross: + "\ex_nonz_cap_to ptr s; tcb_at ptr s; valid_objs s; pspace_relation (kheap s) (ksPSpace s'); + pspace_aligned' s'; pspace_distinct' s'\ + \ ex_nonz_cap_to' ptr s'" + apply (clarsimp simp: ex_nonz_cap_to_def cte_wp_at_caps_of_state ex_nonz_cap_to'_def) + apply (rename_tac oref cref cap) + apply (frule (1) caps_of_state_valid_cap) + apply (frule set_mp[OF zobj_refs_subseteq_obj_refs]) + apply (frule (2) obj_ref_is_tcb) + apply (rule_tac x="cte_map (oref, cref)" in exI) + apply (simp add: caps_of_state_Some_simp) + apply (frule (3) pspace_relation_cte_wp_at) + apply (drule cte_wp_at_norm') + apply clarsimp + apply (erule cte_wp_at_weakenE') + apply (case_tac cap; clarsimp simp: is_zombie_def) + done + +lemma if_live_then_nonz_cap_to_cross: + "\if_live_then_nonz_cap s; (s, s') \ state_relation; valid_objs s; ready_queues_runnable s; + in_correct_ready_q s; release_q_runnable s; pspace_aligned s; pspace_distinct s; + valid_replies' s'; valid_sched_pointers s'\ + \ if_live_then_nonz_cap' s'" + apply (frule state_relation_pspace_relation) + apply (frule (1) pspace_aligned_cross) + apply (frule (2) pspace_distinct_cross) + apply (frule pspace_relation_pspace_bounded') + apply (clarsimp simp: pspace_relation_heap_pspace_relation) + apply (clarsimp simp: if_live_then_nonz_cap'_def live'_def ko_wp_at'_def) + apply (rename_tac ko, case_tac ko; clarsimp) + apply (frule eps_relation_ep_relation_conc; fastforce?) + apply clarsimp + apply (rule ex_nonz_cap_to_ep_at_cross; fastforce?) + apply (erule (1) if_live_then_nonz_capD2) + apply (clarsimp simp: ep_relation_def obj_at_def live_def) + apply (clarsimp simp: obj_at_def is_ep_def) + apply (frule ntfns_relation_ntfn_relation_conc; fastforce?) + apply clarsimp + apply (rule ex_nonz_cap_to_ntfn_at_cross; fastforce?) + apply (erule (1) if_live_then_nonz_capD2) + apply (clarsimp simp: ntfn_relation_def obj_at_def + live_def live_ntfn_def live'_def live_ntfn'_def + split: ntfn.splits) + apply (clarsimp simp: obj_at_def is_ntfn_def) + apply (rename_tac tcb') + apply (frule tcbs_relation_tcb_relation_conc; fastforce?) + apply clarsimp + apply (rule ex_nonz_cap_to_tcb_at_cross; fastforce?) + apply (erule (1) if_live_then_nonz_capD2) + apply (rule_tac tcb'=tcb' in live'_tcb_cross, (fastforce simp: live'_def)+)[1] + apply (clarsimp simp: obj_at_def is_tcb_def) + apply (clarsimp simp: hyp_live'_def) + apply (frule scs_relation_sc_relation_conc; (fastforce simp: live'_def)?) + apply clarsimp + apply (rule ex_nonz_cap_to_sc_at_cross; fastforce?) + apply (erule (1) if_live_then_nonz_capD2) + apply (rule live'_sc_cross; fastforce?) + apply (fastforce intro: state_relation_sc_replies_relation) + apply (force intro!: sc_at_pred_n_sc_at simp: sc_at_pred_n_def obj_at_def) + apply (frule replies_relation_reply_relation_conc; fastforce?) + apply clarsimp + apply (rule ex_nonz_cap_to_reply_at_cross; fastforce?) + apply (erule (1) if_live_then_nonz_capD2) + apply (force intro: live'_reply_cross) + apply (clarsimp simp: obj_at_def is_reply_def) + done + lemma replyTCBs_of_cross: "\(s, s') \ state_relation; reply_tcb_reply_at P rptr s\ \ P (replyTCBs_of s' rptr)" apply (clarsimp simp: reply_at_ppred_def obj_at_def state_relation_def) - apply (drule (1) pspace_relation_absD, clarsimp simp: other_obj_relation_def) + apply (drule (1) pspace_relation_absD, clarsimp) apply (case_tac z; simp) apply (clarsimp simp: opt_map_def reply_relation_def) done @@ -1279,7 +1452,7 @@ lemma replySCs_of_cross: "\(s, s') \ state_relation; reply_sc_reply_at P rptr s\ \ P (replySCs_of s' rptr)" apply (clarsimp simp: reply_at_ppred_def obj_at_def is_tcb state_relation_def) - apply (drule (1) pspace_relation_absD, clarsimp simp: other_obj_relation_def) + apply (drule (1) pspace_relation_absD, clarsimp) apply (case_tac z; simp) apply (clarsimp simp: opt_map_def reply_relation_def) done @@ -1371,12 +1544,13 @@ lemma getObject_sc_wp: dest!: readObject_misc_ko_at') lemma getRefillNext_wp: - "\\s. sc_at' scPtr s \ (\t. ko_at' t scPtr s \ P (refillNext t index) s)\ + "\\s. \sc. scs_of' s scPtr = Some sc \ P (refillNext sc index) s\ getRefillNext scPtr index \P\" apply (simp add: getRefillNext_def readRefillNext_def readSchedContext_def flip: getObject_def) apply (wpsimp wp: getObject_sc_wp) + apply (clarsimp simp: obj_at'_def opt_map_def) done lemma readRefillSize_SomeD: @@ -1734,8 +1908,10 @@ lemma updateSchedContext_no_stack_update_corres: "\\sc n sc'. sc_relation sc n sc' \ sc_relation (f sc) n (f' sc'); \sc. sc_replies sc = sc_replies (f sc); \sc'. objBits sc' = objBits (f' sc'); \sc'. scReply sc' = scReply (f' sc')\ \ - corres dc (sc_at ptr) (sc_at' ptr) + corres dc (sc_at ptr and pspace_aligned and pspace_distinct) \ (update_sched_context ptr f) (updateSchedContext ptr f')" + apply (rule_tac Q'="sc_at' ptr" in corres_cross_add_guard) + apply (fastforce intro: sc_at_cross) apply (corres corres: updateSchedContext_no_stack_update_corres_Q [where f=f and f'=f' and Q=\ and Q'=\]) apply (clarsimp simp: obj_at_def is_sc_obj_def) @@ -1753,8 +1929,8 @@ lemma ko_at_sc_cross: apply (clarsimp simp: obj_at'_def) apply (erule (1) pspace_dom_relatedE) by (clarsimp simp: obj_relation_cuts_def2 obj_at_def is_sc_obj cte_relation_def - other_obj_relation_def other_aobj_relation_def pte_relation_def tcb_relation_cut_def - scBits_simps sc_relation_def gen_objBits_simps + pte_relation_def tcb_relation_cut_def ep_relation_cut_def ntfn_relation_cut_def + other_aobj_relation_def scBits_simps sc_relation_def objBits_simps split: Structures_A.kernel_object.split_asm if_split_asm RISCV64_A.arch_kernel_obj.split_asm) @@ -1836,9 +2012,7 @@ lemma injective_ref_SCTcb[simp]: apply (rename_tac p0 ko p1 p2) apply (prop_tac "\z. ko = KOSchedContext z") apply (clarsimp split: kernel_object.splits) - apply (clarsimp split: Structures_H.endpoint.splits simp: ep_q_refs_of'_def) - apply (clarsimp split: Structures_H.ntfn.splits option.splits - simp: ntfn_q_refs_of'_def get_refs_def) + apply (clarsimp split: option.splits simp: get_refs_def) apply (clarsimp simp: tcb_st_refs_of'_def tcb_bound_refs'_def get_refs_def split: Structures_H.thread_state.splits if_splits option.splits) apply (clarsimp simp: get_refs_def split: option.splits) @@ -1866,15 +2040,6 @@ lemma scheduler_act_sane_cross: apply (cases "scheduler_action s"; clarsimp) done -lemma valid_tcb_state'_simps[simp]: - "valid_tcb_state' Running = \" - "valid_tcb_state' Inactive = \" - "valid_tcb_state' Restart = \" - "valid_tcb_state' IdleThreadState = \" - "valid_tcb_state' (BlockedOnSend ref b c d e) = ep_at' ref" - "valid_tcb_state' (BlockedOnReply r) = valid_bound_reply' r" - by (rule ext, simp add: valid_tcb_state'_def)+ - lemma tcb_at'_ex1_ko_at': "tcb_at' t s \ \!tcb. ko_at' (tcb::tcb) t s" by (fastforce simp: obj_at'_def) @@ -1940,17 +2105,6 @@ lemma setObject_tcb_tcbs_of': \\_ s. P' (tcbs_of' s)\" by (setObject_easy_cases) -lemma setObject_other_tcbs_of'[wp]: - "setObject c (r::reply) \\s. P' (tcbs_of' s)\" - "setObject c (e::endpoint) \\s. P' (tcbs_of' s)\" - "setObject c (n::notification) \\s. P' (tcbs_of' s)\" - "setObject c (sc::sched_context) \\s. P' (tcbs_of' s)\" - by setObject_easy_cases+ - -lemma setObject_cte_tcbSCs_of[wp]: - "setObject c (reply::cte) \\s. P' (tcbSCs_of s)\" - by setObject_easy_cases - lemma threadSet_tcbSCs_of_inv: "\x. tcbSchedContext (f x) = tcbSchedContext x \ threadSet f t \\s. P (tcbSCs_of s)\" @@ -2135,7 +2289,7 @@ lemma refillSingle_equiv: lemma refillSingle_corres: "scp = scp' \ - corres (=) (sc_at scp) (obj_at' sc_valid_refills' scp') + corres (=) (sc_at scp and pspace_aligned and pspace_distinct) (obj_at' sc_valid_refills' scp') (refill_single scp) (refillSingle scp')" apply (simp add: refill_single_def readRefillSingle_def refillSingle_def @@ -2216,6 +2370,8 @@ defs tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt_def: (tcbInReleaseQueue |< tcbs_of' s') tcbPtr \ (tcb_at' tcbPtr s' \ active_sc_tcb_at' tcbPtr s')" +declare tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt_def[simp] + lemma release_queue_active_sc_tcb_at_cross: "\(s, s') \ state_relation; valid_release_q s; pspace_aligned s; pspace_distinct s; valid_objs s\ @@ -2230,25 +2386,6 @@ lemma release_queue_active_sc_tcb_at_cross: apply (fastforce elim: active_sc_tcb_at_cross) done -lemma in_release_q_tcbInReleaseQueue_eq: - "release_queue_relation s s' \ in_release_queue t s \ (tcbInReleaseQueue |< tcbs_of' s') t" - by (clarsimp simp: release_queue_relation_def list_queue_relation_def in_release_q_def) - -lemma in_set_ready_queues_inQ_eq: - "ready_queues_relation s s' \ t \ set (ready_queues s d p) \ (inQ d p |< tcbs_of' s') t" - by (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) - -lemma in_ready_q_tcbQueued_eq: - "ready_queues_relation s s' \ in_ready_q t s \ (tcbQueued |< tcbs_of' s') t" - apply (intro iffI) - apply (clarsimp simp: in_ready_q_def) - apply (frule in_set_ready_queues_inQ_eq) - apply (fastforce simp: inQ_def opt_map_def opt_pred_def split: option.splits) - apply (fastforce simp: ready_queues_relation_def ready_queue_relation_def Let_def inQ_def - opt_pred_def in_ready_q_def - split: option.splits) - done - lemma obj_at'_prop: "obj_at' P p s \ \ko obj. ksPSpace s p = Some ko \ projectKO ko s = Some obj \ P obj" by (fastforce simp: obj_at'_def') @@ -2268,7 +2405,7 @@ method add_sym_refs = (clarsimp simp: pred_conj_def)?, (elim conjE)?, (frule invs_sym_refs)?, (frule invs_psp_aligned)?, (frule invs_distinct)?, - fastforce dest: state_refs_of_cross_eq + fastforce dest: sym_refs_cross method add_ct_not_inQ = rule_tac Q'="\s'. ct_not_inQ s'" in corres_cross_add_guard, diff --git a/proof/refine/RISCV64/ArchRetype_R.thy b/proof/refine/RISCV64/ArchRetype_R.thy index 203e67e04d..a1e209e17f 100644 --- a/proof/refine/RISCV64/ArchRetype_R.thy +++ b/proof/refine/RISCV64/ArchRetype_R.thy @@ -51,6 +51,18 @@ lemma APIType_map2_TCBObject[Retype_R_assms, simp]: split: sum.split object_type.split kernel_object.split arch_kernel_object.splits apiobject_type.split) +lemma APIType_map2_EndpointObject[Retype_R_assms, simp]: + "(APIType_map2 tp = Structures_A.EndpointObject) = (tp = Inr (APIObjectType ArchTypes_H.EndpointObject))" + by (simp add: APIType_map2_def + split: sum.split object_type.split kernel_object.split arch_kernel_object.splits + apiobject_type.split) + +lemma APIType_map2_NotificationObject[Retype_R_assms, simp]: + "(APIType_map2 tp = Structures_A.NotificationObject) = (tp = Inr (APIObjectType ArchTypes_H.NotificationObject))" + by (simp add: APIType_map2_def + split: sum.split object_type.split kernel_object.split arch_kernel_object.splits + apiobject_type.split) + lemma APIType_map2_generic[Retype_R_assms, simp]: "APIType_map2 (Inr (APIObjectType api)) = APIType_map2_gen api" by (simp add: APIType_map2_raw_def) @@ -120,6 +132,10 @@ lemma makeObjectKO_eq[Retype_R_assms]: (tp = Inr (APIObjectType ArchTypes_H.TCBObject) \ tcb = (tcbDomain_update (\_. d) makeObject))" "(v = KOReply reply) = (tp = Inr (APIObjectType ArchTypes_H.ReplyObject) \ reply = makeObject)" + "(v = KOEndpoint endpoint) = + (tp = Inr (APIObjectType ArchTypes_H.EndpointObject) \ endpoint = makeObject)" + "(v = KONotification ntfn) = + (tp = Inr (APIObjectType ArchTypes_H.NotificationObject) \ ntfn = makeObject)" using x by (simp add: makeObjectKO_def eq_commute split: apiobject_type.split_asm sum.split_asm kernel_object.split_asm @@ -136,19 +152,6 @@ lemma objBits_le_obj_bits_api[Retype_R_assms]: Structures_H.kernel_object.splits arch_kernel_object.splits apiobject_type.splits if_split_asm) -lemma obj_relation_retype_other_obj[Retype_R_assms]: - "\ is_other_obj_relation_type (a_type ko); other_obj_relation ko ko' \ - \ obj_relation_retype ko ko'" - apply (simp add: obj_relation_retype_def) - apply (subgoal_tac "objBitsKO ko' = obj_bits ko") - apply (clarsimp simp: is_other_obj_relation_type other_obj_relation_not_aobj) - apply (fastforce simp: other_obj_relation_def objBits_simps' - split: Structures_A.kernel_object.split_asm - Structures_H.kernel_object.split_asm - Structures_H.kernel_object.split - arch_kernel_obj.split_asm arch_kernel_object.split) - done - definition update_gs :: "Structures_A.apiobject_type \ nat \ machine_word set \ kernel_state \ kernel_state" where @@ -806,36 +809,6 @@ lemma arch_live'_KOPTE[simp]: "arch_live' (KOPTE makeObject) = False" by (simp add: makeObject_pte arch_live'_def) -lemma createNewCaps_iflive'[Retype_R_assms, wp]: - assumes cover: "range_cover ptr sz (APIType_capBits ty us) n" - and not_0: "n \ 0" - and tysc : "ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us" - shows - "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s - \ if_live_then_nonz_cap' s\ - createNewCaps ty ptr n us dev - \\rv s. if_live_then_nonz_cap' s\" - unfolding createNewCaps_def - apply (insert cover tysc) - apply (clarsimp simp: toAPIType_def) - apply (cases ty, simp_all add: createNewCaps_def Arch_createNewCaps_def - split del: if_split) - apply (rename_tac apiobject_type) - apply (case_tac apiobject_type, simp_all split del: if_split)[1] - apply (rule hoare_pre, wp, simp) - by (wp mapM_x_wp' createObjects_iflive' threadSet_iflive' - | simp add: not_0 pspace_no_overlap'_def createObjects_def live'_def hyp_live'_def - valid_pspace'_def makeObject_tcb makeObject_endpoint - makeObject_notification makeObject_reply makeObject_sc objBitsKO_def - live_ntfn'_def live_sc'_def live_reply'_def scBits_simps - APIType_capBits_def APIType_capBits_gen_def objBits_def - archObjSize_def field_simps mult_2_right bit_simps - curDomain_def - split del:if_split - | simp split: if_split - | fastforce)+ - crunch createNewCaps for qs[wp]: "\s. P (ksReadyQueues s)" and qsL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" @@ -1074,7 +1047,7 @@ lemma retype_state_relation[Retype_R_2_assms]: (is "(s\kheap := ?ps\, update_gs _ _ _ (s'\ksPSpace := ?ps'\)) \ state_relation" is "(?t, ?t') \ state_relation") - proof (rule state_relation_null_filterE[OF sr refl _ _ _ _ _ _ _ _ _ _ vs'], + proof (rule state_relation_null_filterE[OF sr refl _ _ _ _ _ _ _ _ _ _ _ _ vs'], simp_all add: trans_state_update[symmetric] del: trans_state_update) (* FIXME: don't simp here *) have cover':"range_cover ptr sz (objBitsKO ko) m" @@ -1297,6 +1270,23 @@ lemma retype_state_relation[Retype_R_2_assms]: using retype_sc_replies_relation [OF _ pspr vs vs' pn pn' ko tysc cover orr num_r] by clarsimp + have epqsrel: "ep_queues_relation s s'" + using sr by (simp add: state_relation_def) + + thus "ep_queues_relation_2 (eps_of_kh ?ps ||> ep_queue) (?ps' |> ep_of' ||> epQueue) + (?ps' |> tcb_of' |> tcbSchedNext) (?ps' |> tcb_of' |> tcbSchedPrev)" + using retype_ep_queues_relation[OF _ pspr vs' pn' ko tysc cover orr num_r] + by (clarsimp simp: ep_queues_relation_def) + + have ntfnqsrel: "ntfn_queues_relation s s'" + using sr by (simp add: state_relation_def) + + thus "ntfn_queues_relation_2 (?ps |> ntfn_of ||> ntfn_obj ||> ntfn_queue) + (?ps' |> ntfn_of' ||> ntfnQueue) + (?ps' |> tcb_of' |> tcbSchedNext) (?ps' |> tcb_of' |> tcbSchedPrev)" + using retype_ntfn_queues_relation[OF _ pspr vs' pn' ko tysc cover orr num_r] + by (clarsimp simp: ep_queues_relation_def) + have rdyqrel: "ready_queues_relation s s'" using sr by (simp add: state_relation_def) @@ -1377,8 +1367,6 @@ proof - apply (drule bspec, erule ranI) apply (subst mult.commute) apply (case_tac obj; simp add: valid_obj'_def) - apply (rename_tac endpoint) - apply (case_tac endpoint; simp add: valid_ep'_def obj_at_disj') apply (rename_tac notification) apply (case_tac notification; simp add: valid_ntfn'_def valid_bound_tcb'_def obj_at_disj') apply (rename_tac ntfn xa xb) @@ -1398,9 +1386,9 @@ proof - apply simp apply (rename_tac thread_state mcp priority inQ inRQ option vptr boundntfn tcbsc tcbyt tcbprev tcbnext tcbflags tcbarch) - apply (case_tac thread_state, simp_all add: valid_tcb_state'_def valid_bound_tcb'_def + apply (case_tac thread_state, simp_all add: valid_bound_obj'_def obj_at_disj' opt_tcb_at'_def - split: option.splits)[6] + split: option.splits)[5] apply (clarsimp simp add: valid_arch_tcb'_def typ_at_to_obj_at_arches obj_at_disj') apply (simp add: valid_cte'_def) apply (frule pspace_alignedD' [OF _ ad(1)]) @@ -1419,27 +1407,6 @@ proof - done qed -lemma createNewCaps_idle'[Retype_R_2_assms, wp]: - "\valid_idle' and valid_pspace' and pspace_no_overlap' ptr sz - and K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) - and K (range_cover ptr sz (APIType_capBits ty us) n \ n \ 0)\ - createNewCaps ty ptr n us d - \\rv. valid_idle'\" - apply (rule hoare_gen_asm) - apply (clarsimp simp: createNewCaps_def RISCV64_H.toAPIType_def - split del: if_split) - apply (cases ty, simp_all add: Arch_createNewCaps_def - split del: if_split) - apply (rename_tac apiobject_type) - apply (case_tac apiobject_type, simp_all split del: if_split)[1] - apply (wpsimp wp: createObjects_idle'[where sz=sz] mapM_x_wp' split_del: if_split - simp: curDomain_def APIType_capBits_def createObjects_def - | simp add: projectKO_opt_tcb projectKO_opt_cte mult_2 makeObject_cte makeObject_tcb - archObjSize_def tcb_cte_cases_def objBitsKO_def APIType_capBits_gen_def - objBits_def createObjects_def tcb_cte_cases_neqs bit_simps scBits_simps)+ - done - lemma createNewCaps_valid_arch_state[Retype_R_2_assms]: "\(\s. valid_arch_state' s \ valid_pspace' s \ pspace_no_overlap' ptr sz s \ (tp = APIObjectType ArchTypes_H.CapTableObject \ us > 0) @@ -1629,7 +1596,7 @@ lemma createObjects_no_cte_invs: apply (wp assms | simp add: objBits_def)+ apply (rule hoare_vcg_conj_lift) apply (simp add: createObjects_def) - apply (wp createObjects_sch createObjects_valid_bitmaps) + apply (wp createObjects_valid_bitmaps) apply (rule hoare_vcg_conj_lift) apply (simp add: createObjects_def) apply (wp createObjects_state_refs_of'') @@ -1640,21 +1607,17 @@ lemma createObjects_no_cte_invs: apply (rule hoare_vcg_conj_lift) apply (simp add: createObjects_def) apply (wpsimp wp: createObjects_valid_sched_pointers) - apply (rule hoare_vcg_conj_lift) - apply (simp add: createObjects_def) - apply (wp createObjects_iflive') apply (wp createObjects_no_cte_ifunsafe' irqs_masked_lift - createObjects_idle' createObjects_no_cte_valid_global + createObjects_no_cte_valid_global createObjects_valid_arch createObjects_irq_state - createObjects_no_cte_irq_handlers createObjects_cur' + createObjects_no_cte_irq_handlers assms | simp add: objBits_def)+ apply (rule hoare_vcg_conj_lift) apply (wp createObjects_no_cte_ifunsafe' irqs_masked_lift - createObjects_idle' createObjects_no_cte_valid_global + createObjects_no_cte_valid_global createObjects_valid_arch createObjects_irq_state - createObjects_no_cte_irq_handlers createObjects_cur' + createObjects_no_cte_irq_handlers createObjects_pspace_domain_valid - createObjects_ct_idle_or_in_cur_domain' createObjects_untyped_ranges_zero'[OF moKO] assms | simp)+ @@ -1802,23 +1765,24 @@ lemma corres_retype_region_createNewCaps: apply simp apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 objBits_simps allRights_def APIType_map2_def) - \ \EP, NTFN\ + \ \EP\ apply (simp add: liftM_def[symmetric] split del: if_split) apply (rule corres_rel_imp) apply (rule corres_guard_imp) apply (rule corres_retype[where 'a = endpoint], simp_all add: obj_bits_api_def objBits_simps' pageBits_def APIType_map2_def makeObjectKO_def - other_objs_default_relation)[1] + ep_relation_retype)[1] apply ((simp add: range_cover_def APIType_map2_def list_all2_same list_all2_map1 list_all2_map2)+)[4] + \ \NTFN\ apply (simp add: liftM_def[symmetric] split del: if_split) apply (rule corres_rel_imp) apply (rule corres_guard_imp) apply (rule corres_retype[where 'a = notification], simp_all add: obj_bits_api_def objBits_simps' pageBits_def APIType_map2_def makeObjectKO_def - other_objs_default_relation)[1] + ntfn_relation_retype)[1] apply ((simp add: range_cover_def APIType_map2_def list_all2_same list_all2_map1 list_all2_map2)+)[4] \ \SchedContext\ diff --git a/proof/refine/RISCV64/ArchStateRelation.thy b/proof/refine/RISCV64/ArchStateRelation.thy index f4de902c77..3a32061aa2 100644 --- a/proof/refine/RISCV64/ArchStateRelation.thy +++ b/proof/refine/RISCV64/ArchStateRelation.thy @@ -55,7 +55,10 @@ definition pte_relation :: "pt_index \ Structures_A.kernel_object \< "pte_relation y \ \ko ko'. \pt pte. ko = ArchObj (PageTable pt) \ ko' = KOArch (KOPTE pte) \ pte_relation' (pt y) pte" -(* this is the arch version of other_obj_relation *) +\ \ + A pair of objects @{term "(obj, obj')"} should satisfy the following relation when, under further + mild assumptions, a @{term corres_underlying} lemma for @{term "set_object obj"} + and @{term "setObject obj'"} can be stated: see setObject_other_arch_corres in ArchKHeap_R.\ definition other_aobj_relation :: "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" where "other_aobj_relation obj obj' \ @@ -79,6 +82,8 @@ definition is_other_obj_relation_type :: "a_type \ bool" where | ASchedContext n \ False | AReply \ False | ATCB \ False + | AEndpoint \ False + | ANTFN \ False | AArch APageTable \ False | AArch (AUserData _) \ False | AArch (ADeviceData _) \ False diff --git a/proof/refine/RISCV64/ArchStateRelationLemmas.thy b/proof/refine/RISCV64/ArchStateRelationLemmas.thy index fbe57e4740..c2fb7e030a 100644 --- a/proof/refine/RISCV64/ArchStateRelationLemmas.thy +++ b/proof/refine/RISCV64/ArchStateRelationLemmas.thy @@ -26,12 +26,13 @@ lemma obj_relation_cuts_def2: if valid_sched_context_size n then {(x, sc_relation_cut)} else {(x, \\)} | Structures_A.Reply reply \ {(x, reply_relation_cut)} | TCB tcb \ {(x, tcb_relation_cut)} + | Structures_A.Endpoint endpoint \ {(x, ep_relation_cut)} + | Structures_A.Notification notification \ {(x, ntfn_relation_cut)} | ArchObj (PageTable pt) \ (\y. (x + (ucast y << pteBits), pte_relation y)) ` UNIV | ArchObj (DataPage dev sz) \ {(x + (n << pageBits), \_ obj. obj =(if dev then KOUserDataDevice else KOUserData)) | n . n < 2 ^ (pageBitsForSize sz - pageBits) } - | ArchObj _ \ {(x, other_aobj_relation)} - | _ \ {(x, other_obj_relation)})" + | ArchObj _ \ {(x, other_aobj_relation)})" by (simp split: Structures_A.kernel_object.split RISCV64_A.arch_kernel_obj.split) @@ -43,14 +44,15 @@ lemma obj_relation_cuts_def3: if valid_sched_context_size n then {(x, sc_relation_cut)} else {(x, \\)} | AReply \ {(x, reply_relation_cut)} | ATCB \ {(x, tcb_relation_cut)} + | AEndpoint \ {(x, ep_relation_cut)} + | ANTFN \ {(x, ntfn_relation_cut)} | AArch APageTable \ (\y. (x + (ucast y << pteBits), pte_relation y)) ` UNIV | AArch (AUserData sz) \ {(x + (n << pageBits), \_ obj. obj = KOUserData) | n . n < 2 ^ (pageBitsForSize sz - pageBits) } | AArch (ADeviceData sz) \ {(x + (n << pageBits), \_ obj. obj = KOUserDataDevice ) | n . n < 2 ^ (pageBitsForSize sz - pageBits) } | AArch _ \ {(x, other_aobj_relation)} - | AGarbage _ \ {(x, \\)} - | _ \ {(x, other_obj_relation)})" + | AGarbage _ \ {(x, \\)})" by (simp add: obj_relation_cuts_def2 a_type_def well_formed_cnode_n_def length_set_helper split: Structures_A.kernel_object.split RISCV64_A.arch_kernel_obj.split) @@ -68,17 +70,22 @@ lemma obj_relation_cutsE: \ R; \tcb tcb'. \ y = x; ko = TCB tcb; ko' = KOTCB tcb'; tcb_relation tcb tcb' \ \ R; + \ep ep'. \ y = x; ko = Structures_A.Endpoint ep; ko' = KOEndpoint ep'; ep_relation ep ep' \ + \ R; + \ntfn ntfn'. \ y = x; ko = Structures_A.Notification ntfn; ko' = KONotification ntfn'; + ntfn_relation ntfn ntfn' \ + \ R; \pt (z :: pt_index) pte'. \ ko = ArchObj (PageTable pt); y = x + (ucast z << pteBits); ko' = KOArch (KOPTE pte'); pte_relation' (pt z) pte' \ \ R; \sz dev n. \ ko = ArchObj (DataPage dev sz); ko' = (if dev then KOUserDataDevice else KOUserData); y = x + (n << pageBits); n < 2 ^ (pageBitsForSize sz - pageBits) \ \ R; - \ako. \ ko \ ArchObj ako; y = x; other_obj_relation ko ko'; is_other_obj_relation_type (a_type ko) \ \ R; \ako. \ ko = ArchObj ako; y = x; other_aobj_relation ko ko'; is_other_obj_relation_type (a_type ko) \ \ R \ \ R" by (force simp: obj_relation_cuts_def2 is_other_obj_relation_type_def a_type_def - tcb_relation_cut_def cte_relation_def pte_relation_def + tcb_relation_cut_def ep_relation_cut_def ntfn_relation_cut_def + cte_relation_def pte_relation_def split: Structures_A.kernel_object.splits kernel_object.splits if_splits RISCV64_A.arch_kernel_obj.splits) @@ -87,8 +94,8 @@ lemma is_other_obj_relation_type_gen[simp, StateRelation_R_assms]: "\n. \ is_other_obj_relation_type (ASchedContext n)" "\ is_other_obj_relation_type AReply" "\ is_other_obj_relation_type ATCB" - "is_other_obj_relation_type AEndpoint" - "is_other_obj_relation_type ANTFN" + "\ is_other_obj_relation_type AEndpoint" + "\ is_other_obj_relation_type ANTFN" "\n. \ is_other_obj_relation_type (AGarbage n)" by (auto simp: is_other_obj_relation_type_def) @@ -155,7 +162,7 @@ lemmas isCap_defs = lemma is_other_obj_relation_type: "is_other_obj_relation_type (a_type ko) - \ obj_relation_cuts ko x = {(x, if is_ArchObj ko then other_aobj_relation else other_obj_relation)}" + \ obj_relation_cuts ko x = {(x, other_aobj_relation)}" by (clarsimp simp add: obj_relation_cuts_def3 is_other_obj_relation_type_def split: a_type.splits aa_type.splits) diff --git a/proof/refine/RISCV64/ArchTcbAcc_R.thy b/proof/refine/RISCV64/ArchTcbAcc_R.thy index 838f4e1cf6..353324a969 100644 --- a/proof/refine/RISCV64/ArchTcbAcc_R.thy +++ b/proof/refine/RISCV64/ArchTcbAcc_R.thy @@ -116,7 +116,9 @@ lemma setObject_update_TCB_corres'[TcbAcc_R_assms]: apply (fastforce simp: opt_map_def) apply (prop_tac "(tcbSchedPrevs_of s')(ptr := tcbSchedPrev new_tcb') = tcbSchedPrevs_of s'") apply (fastforce simp: opt_map_def) - by (clarsimp simp: ready_queue_relation_def opt_pred_def opt_map_def split: option.splits) + by (clarsimp simp: ready_queue_relation_def ep_queues_relation_def ntfn_queues_relation_def + eps_of_kh_def opt_pred_def opt_map_def + split: option.splits) lemma setObject_tcb_refs'[TcbAcc_R_assms, wp]: "\\s. P (global_refs' s)\ setObject t (v::tcb) \\rv s. P (global_refs' s)\" @@ -132,52 +134,6 @@ lemma threadSet_state_hyp_refs_of': simp: gen_objBits_simps obj_at'_def state_hyp_refs_of'_def) done -lemma threadSet_iflive'T: - assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - shows - "\\s. if_live_then_nonz_cap' s - \ ((\tcb. \ bound (tcbBoundNotification tcb) \ bound (tcbBoundNotification (F tcb)) - \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) - \ ((\tcb. \ bound (tcbYieldTo tcb) \ bound (tcbYieldTo (F tcb)) - \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) - \ ((\tcb. (\ bound (tcbSchedContext tcb) \ tcbSchedContext tcb = Some idle_sc_ptr) - \ bound (tcbSchedContext (F tcb)) \ tcbSchedContext (F tcb) \ Some idle_sc_ptr - \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) - \ ((\tcb. tcbSchedNext tcb = None \ tcbSchedNext (F tcb) \ None - \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) - \ ((\tcb. tcbSchedPrev tcb = None \ tcbSchedPrev (F tcb) \ None - \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) - \ ((\tcb. (tcbState tcb = Inactive \ tcbState tcb = IdleThreadState) - \ tcbState (F tcb) \ Inactive - \ tcbState (F tcb) \ IdleThreadState - \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) - \ ((\tcb. \ tcbQueued tcb \ tcbQueued (F tcb) - \ ko_at' tcb t s) \ ex_nonz_cap_to' t s) - \ ((\tcb. \ tcbInReleaseQueue tcb \ tcbInReleaseQueue (F tcb) - \ ko_at' tcb t s) \ ex_nonz_cap_to' t s)\ - threadSet F t - \\rv. if_live_then_nonz_cap'\" - apply (simp add: threadSet_def) - apply (wp setObject_tcb_iflive' getObject_tcb_wp) - apply (clarsimp simp: obj_at'_def live'_def hyp_live'_def) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) - apply (subst conj_assoc[symmetric], subst imp_disjL[symmetric]) - apply (rule conjI) - apply (rule impI, clarsimp) - apply (erule if_live_then_nonz_capE') - apply (clarsimp simp: ko_wp_at'_def live'_def hyp_live'_def) - apply (intro conjI) - apply (clarsimp, clarsimp elim!: notE if_live_then_nonz_capE' simp: ko_wp_at'_def live'_def) - apply (clarsimp, clarsimp elim!: notE if_live_then_nonz_capE' simp: ko_wp_at'_def live'_def) - apply (clarsimp, clarsimp elim!: if_live_then_nonz_capE' simp: ko_wp_at'_def live'_def) - apply (clarsimp simp: bspec_split [OF spec [OF x]]) - done - -lemmas threadSet_iflive' = - threadSet_iflive'T [OF all_tcbI, OF ball_tcb_cte_casesI] - lemmas threadSet_typ_at_lifts[wp] = typ_at_lifts[OF threadSet_typ_at'] lemma zobj_refs'_capRange[TcbAcc_R_assms]: @@ -313,7 +269,6 @@ lemma threadSet_invs_trivialT: apply (simp add: invs'_def split del: if_split) apply (wp threadSet_valid_pspace'T threadSet_state_hyp_refs_of' - threadSet_iflive'T threadSet_ifunsafe'T threadSet_global_refsT irqs_masked_lift @@ -323,11 +278,10 @@ lemma threadSet_invs_trivialT: threadSet_valid_dom_schedule' untyped_ranges_zero_lift sym_heap_sched_pointers_lift threadSet_valid_sched_pointers - threadSet_tcbInReleaseQueue threadSet_tcbQueued - threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of valid_bitmaps_lift + threadSet_field_opt_pred threadSet_field_inv valid_bitmaps_lift | clarsimp simp: assms cteCaps_of_def valid_arch_tcb'_def | rule refl)+ apply (clarsimp simp: o_def) - by (auto simp: assms obj_at'_def) + done lemmas threadSet_invs_trivial = threadSet_invs_trivialT [OF all_tcbI all_tcbI all_tcbI all_tcbI, OF ball_tcb_cte_casesI] @@ -416,7 +370,7 @@ lemma user_getreg_inv'[TcbAcc_R_2_assms, wp]: done lemma asUser_invs[wp]: - "\invs' and tcb_at' t\ asUser t m \\rv. invs'\" + "asUser t m \invs'\" apply (simp add: asUser_def split_def) apply (wpsimp wp: threadSet_invs_trivial threadGet_wp) done @@ -441,11 +395,6 @@ lemma asUser_st_hyp_refs_of'[wp]: unfolding asUser_def by (wpsimp wp: threadSet_state_hyp_refs_of' hoare_drop_imps simp: atcbContextSet_def) -lemma asUser_iflive'[wp]: - "asUser t m \if_live_then_nonz_cap'\ " - unfolding asUser_def - by (wpsimp wp: threadSet_iflive' hoare_drop_imps, auto) - lemma asUser_setRegister_corres[TcbAcc_R_2_assms]: "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t (setRegister r v)) @@ -984,49 +933,6 @@ lemma setBoundNotification_state_hyp_refs_of'[wp]: by (simp add: setBoundNotification_def fun_upd_def | wp threadSet_state_hyp_refs_of')+ -lemma tcbSchedNext_update_iflive'[TcbAcc_R_2_assms]: - "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ - threadSet (tcbSchedNext_update f) t - \\_. if_live_then_nonz_cap'\" - by (wpsimp wp: threadSet_iflive'T simp: update_tcb_cte_cases) - -lemma tcbSchedPrev_update_iflive'[TcbAcc_R_2_assms]: - "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ - threadSet (tcbSchedPrev_update f) t - \\_. if_live_then_nonz_cap'\" - by (wpsimp wp: threadSet_iflive'T simp: update_tcb_cte_cases) - -lemma tcbInReleaseQueue_update_iflive'[TcbAcc_R_2_assms, wp]: - "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ - threadSet (tcbInReleaseQueue_update f) t - \\_. if_live_then_nonz_cap'\" - by (wpsimp wp: threadSet_iflive'T simp: update_tcb_cte_cases) - -lemma tcbQueued_update_iflive'[TcbAcc_R_2_assms, wp]: - "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ - threadSet (tcbQueued_update f) t - \\_. if_live_then_nonz_cap'\" - by (wpsimp wp: threadSet_iflive'T simp: update_tcb_cte_cases) - -lemma sbn_iflive'[wp]: - "\\s. if_live_then_nonz_cap' s - \ (bound ntfn \ ex_nonz_cap_to' t s)\ - setBoundNotification ntfn t - \\_. if_live_then_nonz_cap'\" - apply (simp add: setBoundNotification_def) - apply (rule hoare_pre) - apply (wp threadSet_iflive' | simp)+ - apply auto - done - -lemma tcbSchedNext_None_if_live_then_nonz_cap'[wp]: - "threadSet (tcbSchedNext_update (\_. None)) tcbPtr \if_live_then_nonz_cap'\" - by (wpsimp wp: threadSet_iflive'T; fastforce simp: update_tcb_cte_cases) - -lemma tcbSchedPrev_None_if_live_then_nonz_cap'[wp]: - "threadSet (tcbSchedPrev_update (\_. None)) tcbPtr \if_live_then_nonz_cap'\" - by (wpsimp wp: threadSet_iflive'T; fastforce simp: update_tcb_cte_cases) - lemma storeWord_invs'[TcbAcc_R_2_assms, wp]: "\pointerInUserData p and invs'\ doMachineOp (storeWord p w) \\rv. invs'\" proof - @@ -1062,30 +968,11 @@ qed context Arch begin arch_global_naming -named_theorems TcbAcc_R_3_assms - -lemma sts_iflive'[TcbAcc_R_3_assms, wp]: - "\\s. if_live_then_nonz_cap' s - \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) - \ pspace_aligned' s \ pspace_distinct' s\ - setThreadState st t - \\_. if_live_then_nonz_cap'\" - apply (simp add: setThreadState_def setQueue_def) - apply (wpsimp wp: threadSet_iflive')+ - apply auto - done - lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] end (* Arch *) -interpretation TcbAcc_R_3?: TcbAcc_R_3 -proof goal_cases - interpret Arch . - case 1 show ?case by (intro_locales; (unfold_locales; (fact TcbAcc_R_3_assms)?)?) -qed - (* requalify interface lemmas which can't be locale assumptions due to free type variable *) arch_requalify_facts asUser_corres' diff --git a/proof/refine/RISCV64/ArchVSpace_R.thy b/proof/refine/RISCV64/ArchVSpace_R.thy index f73a2726e1..e841ddfa72 100644 --- a/proof/refine/RISCV64/ArchVSpace_R.thy +++ b/proof/refine/RISCV64/ArchVSpace_R.thy @@ -82,9 +82,10 @@ proof - by corres show ?thesis - unfolding set_vm_root_def setVMRoot_def catchFailure_def withoutFailure_def throw_def + unfolding set_vm_root_def setVMRoot_def catchFailure_def withoutFailure_def throw_def K_bind_def apply (rule corres_cross_over_guard[where Q="no_0_obj' and pspace_distinct' and pspace_aligned'"]) apply (clarsimp simp add: pspace_distinct_cross pspace_aligned_cross state_relation_def) + apply (rule corres_stateAssert_ignore, fastforce intro!: tcb_at_cross simp: assms) apply (rule corres_guard_imp) apply (rule corres_split[where r'="(=) \ cte_map" and P=\ and P'=\]) apply (simp add: getThreadVSpaceRoot_def locateSlotTCB_def locateSlotBasic_def @@ -295,11 +296,6 @@ crunch unmapPageTable, unmapPage (simp: crunch_simps wp: crunch_wps getObject_inv) -crunch storePTE - for no_0_obj'[wp]: no_0_obj' - and valid_arch'[wp]: valid_arch_state' - and cur_tcb'[wp]: cur_tcb' - lemma no_fail_sfence[intro!,simp,wp]: "no_fail \ sfence" by (simp add: sfence_def) @@ -402,7 +398,7 @@ definition | PageGetAddr ptr \ \" lemma set_mrs_invs'[wp]: - "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" + "setMRs receiver recv_buf mrs \invs'\" apply (simp add: setMRs_def) apply (wp dmo_invs' no_irq_mapM no_irq_storeWord crunch_wps| simp add: zipWithM_x_mapM split_def)+ @@ -672,15 +668,6 @@ crunch deleteASID (simp: crunch_simps loadObject_default_def updateObject_default_def wp: getObject_inv) -lemma storePTE_iflive [wp]: - "\if_live_then_nonz_cap'\ storePTE p pte \\rv. if_live_then_nonz_cap'\" - apply (simp add: storePTE_def) - apply (rule hoare_pre) - apply (rule setObject_iflive' [where P=\], simp) - apply (simp add: objBits_simps) - apply (auto simp: updateObject_default_def in_monad live'_def hyp_live'_def) - done - method valid_idle'_setObject uses simp = simp add: valid_idle'_def, rule hoare_lift_Pf [where f="ksIdleThread"]; wpsimp?; (wpsimp wp: obj_at_setObject2[where P="idle_tcb'", simplified] hoare_drop_imp @@ -711,11 +698,9 @@ lemma storePTE_invs[wp]: "storePTE p pte \invs'\" apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) apply (rule hoare_pre) - apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift - valid_arch_state_lift' valid_irq_node_lift - cur_tcb_lift valid_irq_handlers_lift'' - untyped_ranges_zero_lift sym_heap_sched_pointers_lift - | simp add: cteCaps_of_def o_def)+ + apply (wp valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift + valid_irq_handlers_lift'' untyped_ranges_zero_lift sym_heap_sched_pointers_lift + | simp add: cteCaps_of_def o_def)+ apply (clarsimp simp: valid_arch_obj'_def) done @@ -737,23 +722,14 @@ lemma setASIDPool_state_refs' [wp]: apply (simp split: option.split) done -lemma setASIDPool_iflive [wp]: - "\if_live_then_nonz_cap'\ setObject p (ap::asidpool) \\rv. if_live_then_nonz_cap'\" - apply (rule hoare_pre) - apply (rule setObject_iflive' [where P=\], simp) - apply (simp add: objBits_simps) - apply (auto simp: updateObject_default_def in_monad pageBits_def live'_def hyp_live'_def) - done - lemma setASIDPool_invs [wp]: "setObject p (ap::asidpool) \invs'\" apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) - apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift - valid_arch_state_lift' valid_irq_node_lift - cur_tcb_lift valid_irq_handlers_lift'' - untyped_ranges_zero_lift updateObject_default_inv sym_heap_sched_pointers_lift - | simp add: cteCaps_of_def - | rule setObject_ksPSpace_only)+ + apply (wp valid_global_refs_lift' irqs_masked_lift valid_arch_state_lift' valid_irq_node_lift + valid_irq_handlers_lift'' untyped_ranges_zero_lift updateObject_default_inv + sym_heap_sched_pointers_lift + | simp add: cteCaps_of_def + | rule setObject_ksPSpace_only)+ apply (clarsimp simp: o_def) done diff --git a/proof/refine/RISCV64/Arch_R.thy b/proof/refine/RISCV64/Arch_R.thy index 453ab60923..f17bc6e40d 100644 --- a/proof/refine/RISCV64/Arch_R.thy +++ b/proof/refine/RISCV64/Arch_R.thy @@ -997,12 +997,7 @@ context begin interpretation Arch . crunch setThreadState for pspace_no_overlap'[wp]: "pspace_no_overlap' w s" - (simp: unless_def wp: crunch_wps) - - -crunch setThreadState - for sc_at'_n[wp]: "sc_at'_n n p" - (simp: crunch_simps wp: crunch_wps) + (simp: unless_def crunch_simps wp: crunch_wps) lemma sts_valid_arch_inv': "\valid_arch_inv' ai\ setThreadState st t \\rv. valid_arch_inv' ai\" diff --git a/proof/refine/RISCV64/CNodeInv_R.thy b/proof/refine/RISCV64/CNodeInv_R.thy index 343b9a4acd..f1ace06432 100644 --- a/proof/refine/RISCV64/CNodeInv_R.thy +++ b/proof/refine/RISCV64/CNodeInv_R.thy @@ -4852,26 +4852,6 @@ lemma cteSwap_ifunsafe'[wp]: apply fastforce done -lemma cteSwap_iflive'[wp]: - "\if_live_then_nonz_cap' - and cte_wp_at' (\cte. zobj_refs' (cteCap cte) = zobj_refs' c) c1 - and cte_wp_at' (\cte. zobj_refs' (cteCap cte) = zobj_refs' c') c2\ - cteSwap c c1 c' c2 - \\rv. if_live_then_nonz_cap'\" - apply (simp add: cteSwap_def) - apply (wp | simp)+ - apply (rule hoare_post_imp, - simp only: if_live_then_nonz_cap'_def imp_conv_disj - ex_nonz_cap_to'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - hoare_vcg_ex_lift updateCap_cte_wp_at_cases hoare_weak_lift_imp)+ - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (drule(1) if_live_then_nonz_capE') - apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) - apply (rule_tac x="(id (c1 := c2, c2 := c1)) cref" in exI) - apply auto - done - crunch updateMDB, updateCap for valid_replies'[wp]: valid_replies' (wp: valid_replies'_lift) @@ -4892,8 +4872,7 @@ lemma cteSwap_valid_pspace'[wp]: apply wp apply (wp getCTE_inv getCTE_wp) apply (strengthen imp_consequent, strengthen ctes_of_strng) - apply ((wp sch_act_wf_lift updateCap_no_0 updateCap_ctes_of_wp - hoare_vcg_ex_lift getCTE_wp + apply ((wp updateCap_no_0 updateCap_ctes_of_wp hoare_vcg_ex_lift getCTE_wp | simp add: cte_wp_at_ctes_ofI o_def | rule hoare_drop_imps)+)[6] apply (clarsimp simp: valid_pspace_no_0[unfolded valid_pspace'_def valid_mdb'_def] @@ -4949,14 +4928,6 @@ crunch cteSwap and ksIdleSC[wp]: "\s. P (ksIdleSC s)" and tcbDomain_obj_at'[wp]: "obj_at' (\tcb. x = tcbDomain tcb) t" -lemma cteSwap_idle'[wp]: - "\valid_idle'\ - cteSwap c c1 c' c2 - \\rv s. valid_idle' s\" - apply (simp add: cteSwap_def) - apply (wp updateCap_idle' | simp)+ - done - lemma weak_derived_zobj: "weak_derived' c c' \ zobj_refs' c' = zobj_refs' c" apply (clarsimp simp: weak_derived'_def) @@ -5053,7 +5024,6 @@ crunch cteSwap and st_tcb_at'[wp]: "st_tcb_at' P t" and vms'[wp]: "valid_machine_state'" and pspace_domain_valid[wp]: "pspace_domain_valid" - and ct_not_inQ[wp]: "ct_not_inQ" and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and replies_of'[wp]: "\s. P (replies_of' s)" and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers @@ -5064,12 +5034,6 @@ crunch cteSwap and valid_bitmaps[wp]: valid_bitmaps (wp: valid_bitmaps_lift) -crunch cteSwap - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (rule: valid_bitmaps_lift) - lemma cteSwap_invs'[wp]: "\invs' and valid_cap' c and valid_cap' c' and ex_cte_cap_to' c1 and ex_cte_cap_to' c2 and @@ -5082,9 +5046,7 @@ lemma cteSwap_invs'[wp]: \\rv. invs'\" apply (simp add: invs'_def valid_dom_schedule'_def pred_conj_def) apply (rule hoare_pre) - apply (wp hoare_vcg_conj_lift sch_act_wf_lift - valid_irq_node_lift irqs_masked_lift tcb_in_cur_domain'_lift - ct_idle_or_in_cur_domain'_lift2) + apply (wp hoare_vcg_conj_lift valid_irq_node_lift irqs_masked_lift) apply (clarsimp simp: cte_wp_at_ctes_of weak_derived_zobj weak_derived_cte_refs weak_derived_capRange_capBits o_def) done @@ -5522,10 +5484,6 @@ lemma updateCap_untyped_ranges_zero_simple: apply (simp add: fun_eq_iff map_comp_def) done -crunch updateCap - for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - (wp: crunch_wps simp: crunch_simps rule: tcb_in_cur_domain'_lift) - crunch updateCap for valid_bitmaps[wp]: valid_bitmaps (rule: valid_bitmaps_lift) @@ -5554,7 +5512,7 @@ lemma make_zombie_invs': \\rv. invs'\" apply (simp add: invs'_def valid_pspace'_def valid_mdb'_def valid_irq_handlers'_def irq_issued'_def valid_dom_schedule'_def) - apply (wp updateCap_ctes_of_wp sch_act_wf_lift updateCap_iflive' updateCap_ifunsafe' + apply (wp updateCap_ctes_of_wp updateCap_ifunsafe' valid_arch_state_lift' valid_irq_node_lift updateCap_untyped_ranges_zero_simple valid_bitmaps_lift | simp)+ @@ -5583,18 +5541,6 @@ lemma make_zombie_invs': apply (drule bspec[where x=sl], simp) apply (clarsimp simp: isCap_simps) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (subgoal_tac "st_tcb_at' ((=) Inactive) p' s - \ obj_at' (Not \ tcbQueued) p' s - \ bound_tcb_at' ((=) None) p' s - \ bound_sc_tcb_at' (\sco. sco = None \ sco = Some idle_sc_ptr) p' s - \ bound_yt_tcb_at' ((=) None) p' s - \ obj_at' (\tcb. tcbSchedNext tcb = None - \ tcbSchedPrev tcb = None) p' s - \ obj_at' (\tcb. \ tcbInReleaseQueue tcb) p' s") - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def ko_wp_at'_def live'_def hyp_live'_def) - subgoal by (auto dest!: isCapDs) - apply (simp only: fold_list_refs_of_replies') apply (clarsimp simp: cte_wp_at_ctes_of disj_ac @@ -5833,8 +5779,8 @@ lemma cteDeleteOne_cap_to'[wp]: done crunch cancelSignal - for cap_to'[wp]: "ex_cte_cap_wp_to' P p" - (simp: crunch_simps wp: crunch_wps) + for ex_cte_cap_wp_to'[wp]: "ex_cte_cap_wp_to' P p" + (simp: crunch_simps wp: ex_cte_cap_to'_pres crunch_wps) lemma emptySlot_deletes [wp]: "\\\ emptySlot p opt \\rv s. cte_wp_at' (\c. cteCap c = NullCap) p s\" @@ -6139,24 +6085,6 @@ crunch schedContextCompleteYieldTo, unbindMaybeNotification, schedContextMaybeUn setQueue for ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" -lemma cancelAllIPC_sch_act_simple: - "\\s. obj_at' ((=) IdleEP) ep_ptr s \ sch_act_simple s\ - cancelAllIPC ep_ptr - \\_. sch_act_simple\" - unfolding cancelAllIPC_def - apply (wpsimp wp: getEndpoint_wp) - apply (clarsimp simp: obj_at'_def) - done - -lemma cancelAllSignals_sch_act_simple: - "\\s. obj_at' ((isIdleNtfn or isActiveNtfn) o ntfnObj) ntfn_ptr s \ sch_act_simple s\ - cancelAllSignals ntfn_ptr - \\_. sch_act_simple\" - unfolding cancelAllSignals_def - apply (wpsimp wp: getNotification_wp) - apply (case_tac "ntfnObj ko"; clarsimp simp: isIdleNtfn_def isActiveNtfn_def obj_at'_def) - done - lemma finaliseSlot_invs': assumes finaliseCap: "\cap final sl. \no_cte_prop Pr and invs' @@ -6249,7 +6177,7 @@ proof (induct arbitrary: P p rule: finalise_spec_induct2) \ cte_wp_at' (\cte. cteCap cte = cteCap rv) sl s \ (q = sl \ exp \ cte_wp_at' (?P) q s)" in hoare_vcg_conj_lift) - apply (wp hoare_vcg_disj_lift finaliseCap finaliseCap_invs[where sl=sl]) + apply (wp hoare_vcg_disj_lift finaliseCap finaliseCap_invs) apply (rule finaliseCap_zombie_cap') apply (rule hoare_vcg_conj_lift) apply (rule finaliseCap_cte_refs) @@ -7107,7 +7035,7 @@ next \ (exposed \ ex_cte_cap_to' (cte_map slot) s) \ cte_wp_at' (\cte. cteCap cte = cteCap rv') (cte_map slot) s" in hoare_vcg_conj_lift) - apply (wp hoare_vcg_disj_lift finaliseCap_invs[where sl="cte_map slot"])[1] + apply (wp hoare_vcg_disj_lift finaliseCap_invs)[1] apply (rule hoare_vcg_conj_lift) apply (rule finaliseCap_replaceable[where slot="cte_map slot"]) apply (rule finaliseCap_cte_refs) @@ -7131,7 +7059,7 @@ next apply (clarsimp simp: invs_def valid_state_def valid_pspace_def cte_wp_at_def) apply (subst split_paired_Ex[symmetric]) apply (solves \auto\)[1] - apply (clarsimp simp: cte_wp_at_ctes_of invs'_def valid_pspace'_def sch_act_wf_weak) + apply (clarsimp simp: cte_wp_at_ctes_of invs'_def valid_pspace'_def) apply (frule(1) ctes_of_valid') apply fastforce done @@ -8411,28 +8339,6 @@ end context begin interpretation Arch . (*FIXME: arch-split*) -lemma cteMove_iflive'[wp]: - "\\s. if_live_then_nonz_cap' s - \ cte_wp_at' (\c. weak_derived' (cteCap c) cap) src s - \ cte_wp_at' (\c. cteCap c \ NullCap) src s - \ cte_wp_at' (\c. cteCap c = NullCap) dest s\ - cteMove cap src dest - \\rv. if_live_then_nonz_cap'\" - unfolding cteMove_def - apply simp - apply wp - apply (simp only: if_live_then_nonz_cap'_def imp_conv_disj - ex_nonz_cap_to'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - hoare_vcg_ex_lift updateCap_cte_wp_at_cases - getCTE_wp hoare_weak_lift_imp)+ - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (drule(1) if_live_then_nonz_capE') - apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) - apply (drule_tac x="(id (src := dest, dest := src)) cref" in spec) - apply (clarsimp dest!: weak_derived_zobj split: if_split_asm) - done - lemma cteMove_valid_pspace' [wp]: "\\x. valid_pspace' x \ cte_wp_at' (\c. weak_derived' (cteCap c) capability) word1 x \ @@ -8444,7 +8350,7 @@ lemma cteMove_valid_pspace' [wp]: \\y. valid_pspace'\" unfolding cteMove_def apply (simp add: pred_conj_def valid_pspace'_def valid_mdb'_def) - apply (wp sch_act_wf_lift updateCap_no_0 updateCap_ctes_of_wp getCTE_wp | simp)+ + apply (wp updateCap_no_0 updateCap_ctes_of_wp getCTE_wp | simp)+ apply (clarsimp simp: invs'_def)+ apply (clarsimp dest!: cte_at_cte_wp_atD) apply (rule_tac x = cte in exI) @@ -8490,16 +8396,6 @@ lemma cteMove_ifunsafe': apply simp+ done -lemma cteMove_idle'[wp]: - "\\s. valid_idle' s\ - cteMove cap src dest - \\rv. valid_idle'\" - apply (simp add: cteMove_def) - apply (wp updateCap_idle' | simp)+ - apply (wp getCTE_wp') - apply (clarsimp simp: valid_idle'_def cte_wp_at_ctes_of weak_derived'_def) - done - crunch cteMove for ksInterrupt[wp]: "\s. P (ksInterruptState s)" (wp: crunch_wps) @@ -8771,21 +8667,15 @@ lemma updateCap_noop_irq_handlers: add: modify_map_apply fun_upd_idem) done -crunch updateCap - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and cur_tcb'[wp]: "cur_tcb'" - (rule: ct_idle_or_in_cur_domain'_lift2) - lemma updateCap_noop_invs: "\invs' and cte_wp_at' (\cte. cteCap cte = cap) slot\ - updateCap slot cap - \\rv. invs'\" + updateCap slot cap + \\_. invs'\" apply (simp add: invs'_def valid_dom_schedule'_def valid_pspace'_def valid_mdb'_def) apply (rule hoare_pre) - apply (wp updateCap_ctes_of_wp updateCap_iflive' - updateCap_ifunsafe' updateCap_idle' + apply (wp updateCap_ctes_of_wp updateCap_ifunsafe' valid_arch_state_lift' valid_irq_node_lift - updateCap_noop_irq_handlers sch_act_wf_lift + updateCap_noop_irq_handlers untyped_ranges_zero_lift) apply (clarsimp simp: cte_wp_at_ctes_of modify_map_apply) apply (strengthen untyped_ranges_zero_delta[where xs=Nil, mk_strg I E]) diff --git a/proof/refine/RISCV64/Detype_R.thy b/proof/refine/RISCV64/Detype_R.thy index c304fdb398..b8a7317ac3 100644 --- a/proof/refine/RISCV64/Detype_R.thy +++ b/proof/refine/RISCV64/Detype_R.thy @@ -115,6 +115,7 @@ lemma deleteObjects_def2: deleteObjects ptr bits = do stateAssert sym_refs_asrt []; stateAssert valid_idle'_asrt []; + stateAssert if_live_then_nonz_cap' []; stateAssert (deletionIsSafe ptr bits) []; doMachineOp (freeMemory ptr bits); stateAssert (\s. \ cNodePartialOverlap (gsCNodes s) (\x. x \ mask_range ptr bits)) []; @@ -148,6 +149,7 @@ lemma deleteObjects_def3: do stateAssert sym_refs_asrt []; stateAssert valid_idle'_asrt []; + stateAssert if_live_then_nonz_cap' []; assert (is_aligned ptr bits); stateAssert (deletionIsSafe ptr bits) []; doMachineOp (freeMemory ptr bits); @@ -475,6 +477,7 @@ locale delete_locale = and invs: "invs' s'" and sym_refs: "sym_refs (state_refs_of' s')" and valid_idle': "valid_idle' s'" + and iflive: "if_live_then_nonz_cap' s'" and ct_act: "ct_active' s'" and sa_simp: "sch_act_simple s'" and al: "is_aligned base bits" @@ -493,7 +496,6 @@ lemma valid_objs: "valid_objs' s'" and sym_sched: "sym_heap_sched_pointers s'" and vsp: "valid_sched_pointers s'" and list_refs: "sym_refs (list_refs_of_replies' s')" - and iflive: "if_live_then_nonz_cap' s'" and ifunsafe: "if_unsafe_then_cap' s'" and dlist: "valid_dlist (ctes_of s')" and no_0: "no_0 (ctes_of s')" @@ -712,7 +714,7 @@ proof - apply (simp add:pageBitsForSize_def bit_simps split:vmpage_size.splits) apply (subgoal_tac "6 \ obj_bits koa") apply (simp add: unat_mask_word64 mask_2pm1[symmetric] le_diff_iff) - apply (case_tac koa, simp_all add: other_obj_relation_def + apply (case_tac koa, simp_all add: ep_relation_cut_def ntfn_relation_cut_def objBits_simps cte_relation_def split: if_splits) apply (rename_tac ako, @@ -849,6 +851,42 @@ lemma detype_sc_replies_relation: split: if_splits Structures_A.kernel_object.splits) done +lemma detype_ep_queues_relation: + "\pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; + \p. p \ {lower..upper} \ \ ko_wp_at' live' p s'; + ep_queues_relation s s'; upper = upper'\ + \ ep_queues_relation_2 (ep_queues_of (detype {lower..upper'} s)) + ((\x. if lower \ x \ x \ upper + then None else ksPSpace s' x) |> ep_of' ||> epQueue) + ((\x. if lower \ x \ x \ upper + then None else ksPSpace s' x) |> tcb_of' |> tcbSchedNext) + ((\x. if lower \ x \ x \ upper + then None else ksPSpace s' x) |> tcb_of' |> tcbSchedPrev)" + apply (clarsimp simp: ep_queues_relation_def detype_def) + apply (frule detype_tcbSchedNexts_of[where S="{lower..upper}"]; simp) + apply (frule detype_tcbSchedPrevs_of[where S="{lower..upper}"]; simp) + apply (clarsimp simp: vs_all_heap_simps opt_map_def + split: if_splits option.splits) + done + +lemma detype_ntfn_queues_relation: + "\pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; + \p. p \ {lower..upper} \ \ ko_wp_at' live' p s'; + ntfn_queues_relation s s'; upper = upper'\ + \ ntfn_queues_relation_2 (ntfn_queues_of (detype {lower..upper'} s)) + ((\x. if lower \ x \ x \ upper + then None else ksPSpace s' x) |> ntfn_of' ||> ntfnQueue) + ((\x. if lower \ x \ x \ upper + then None else ksPSpace s' x) |> tcb_of' |> tcbSchedNext) + ((\x. if lower \ x \ x \ upper + then None else ksPSpace s' x) |> tcb_of' |> tcbSchedPrev)" + apply (clarsimp simp: ntfn_queues_relation_def detype_def) + apply (frule detype_tcbSchedNexts_of[where S="{lower..upper}"]; simp) + apply (frule detype_tcbSchedPrevs_of[where S="{lower..upper}"]; simp) + apply (clarsimp simp: vs_all_heap_simps opt_map_def + split: if_splits option.splits ntfn.splits) + done + lemma detype_ready_queues_relation: "\pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; \p. p \ {lower..upper} \ \ ko_wp_at' live' p s'; @@ -910,19 +948,19 @@ lemma deleteObjects_corres: \ s' \' (UntypedCap d base magnitude idx)) (delete_objects base magnitude) (deleteObjects base magnitude)" (is "_ \ _ \ corres _ _ ?conc_guard _ _") - apply add_sym_refs apply add_valid_idle' + apply add_sym_refs apply (simp add: deleteObjects_def2) + apply (rule corres_stateAssert_add_assertion[rotated], clarsimp) + apply (rule corres_stateAssert_add_assertion[rotated], clarsimp) apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: sym_refs_asrt_def) + apply (clarsimp simp: valid_sched_def) + apply (frule invs_iflive) + apply (frule (1) if_live_then_nonz_cap_to_cross, fastforce+)[1] apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (rule corres_stateAssert_add_assertion) - prefer 2 - apply clarsimp apply (rule delete_locale.deletionIsSafe_holds; - (fastforce simp: delete_locale_def valid_cap_simps sch_act_simple_def state_relation_def - sched_act_relation_def pred_conj_def)?) + fastforce simp: delete_locale_def valid_cap_simps sch_act_simple_def state_relation_def + sched_act_relation_def pred_conj_def) apply (simp add: bind_assoc[symmetric]) apply (rule corres_stateAssert_implied2) defer @@ -957,40 +995,41 @@ lemma deleteObjects_corres: apply (simp add: valid_pspace'_def) apply (rule state_relation_null_filterE, assumption, simp_all add: pspace_aligned'_cut pspace_distinct'_cut)[1] - apply (simp add: detype_def) + apply (simp add: detype_def) + apply clarsimp + (* unification can't guess we want identity update on ksArchState s' *) + apply (repeat 3 \rule exI\, rule_tac x=id in exI) + apply fastforce + apply (rule ext, clarsimp simp add: null_filter_def) + apply (rule sym, rule ccontr, clarsimp) + apply (drule(4) cte_map_not_null_outside') + apply (fastforce simp add: cte_wp_at_caps_of_state) + apply simp + apply (rule ext, + clarsimp simp: null_filter'_def map_to_ctes_delete[simplified field_simps]) + apply (rule sym, rule ccontr, clarsimp) + apply (frule(2) pspace_relation_cte_wp_atI[OF state_relation_pspace_relation]) + apply (elim exE) + apply (frule(4) cte_map_not_null_outside') + apply (rule cte_wp_at_weakenE, erule conjunct1) + apply (case_tac y, clarsimp) + apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def valid_nullcaps_def) apply clarsimp - (* unification can't guess we want identity update on ksArchState s' *) - apply (repeat 3 \rule exI\, rule_tac x=id in exI) - apply fastforce - apply (rule ext, clarsimp simp add: null_filter_def) - apply (rule sym, rule ccontr, clarsimp) - apply (drule(4) cte_map_not_null_outside') - apply (fastforce simp add: cte_wp_at_caps_of_state) - apply simp - apply (rule ext, clarsimp simp add: null_filter'_def - map_to_ctes_delete[simplified field_simps]) - apply (rule sym, rule ccontr, clarsimp) - apply (frule (2) pspace_relation_cte_wp_atI[OF state_relation_pspace_relation]) - apply (elim exE) - apply (frule (4) cte_map_not_null_outside') - apply (rule cte_wp_at_weakenE, erule conjunct1) - apply (case_tac y, clarsimp) - apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def - valid_nullcaps_def) - apply clarsimp - apply (frule_tac cref="(aa, ba)" in cte_map_untyped_range, - erule cte_wp_at_weakenE[OF _ TrueI], assumption+) - apply (simp add: add_mask_fold) - apply (simp add: add_mask_fold) - apply (rule detype_pspace_relation[simplified], - simp_all add: state_relation_pspace_relation valid_pspace_def)[1] - apply (simp add: valid_cap'_def capAligned_def) - apply (clarsimp simp: valid_cap_def, assumption) - apply (rule detype_sc_replies_relation; blast?) - apply (clarsimp simp: deletionIsSafe_def) - apply (fastforce simp: add_mask_fold) - apply (erule state_relation_sc_replies_relation) - apply (fastforce simp add: detype_def add_mask_fold) + apply (frule_tac cref="(aa, ba)" in cte_map_untyped_range, + erule cte_wp_at_weakenE[OF _ TrueI], assumption+) + apply (simp add: add_mask_fold) + apply (simp add: add_mask_fold) + apply (rule detype_pspace_relation[simplified], + simp_all add: state_relation_pspace_relation valid_pspace_def)[1] + apply (simp add: valid_cap'_def capAligned_def) + apply (clarsimp simp: valid_cap_def, assumption) + apply (rule detype_sc_replies_relation; blast?) + apply (clarsimp simp: deletionIsSafe_def) + apply (fastforce simp: add_mask_fold) + apply (erule state_relation_sc_replies_relation) + apply (fastforce simp add: detype_def add_mask_fold) + apply (fastforce intro!: detype_ep_queues_relation simp: deletionIsSafe_def add_mask_fold) + apply (fastforce intro!: detype_ntfn_queues_relation simp: deletionIsSafe_def add_mask_fold) apply (rule detype_ready_queues_relation; blast?) apply (clarsimp simp: deletionIsSafe_def) apply (fastforce simp: add_mask_fold) @@ -1081,8 +1120,6 @@ lemma valid_obj': pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'\ \ valid_obj' obj state'" apply (case_tac obj, simp_all add: valid_obj'_def valid_arch_obj'_def) - apply (clarsimp dest!: refs_of' simp flip: injectKO_ep) - apply (fastforce simp: valid_ep'_def split: endpoint.splits) apply (clarsimp dest!: refs_of' simp flip: injectKO_ntfn) apply (fastforce simp: valid_ntfn'_def valid_bound_obj'_def split: option.splits ntfn.splits) apply (clarsimp simp flip: injectKO_tcb) @@ -1096,11 +1133,10 @@ lemma valid_obj': apply fastforce apply simp apply (intro conjI) - subgoal - by (clarsimp simp: valid_tcb_state'_def valid_bound_tcb'_def tcb_bound_refs'_def - split: option.splits thread_state.splits) - apply (clarsimp simp: valid_bound_ntfn'_def tcb_bound_refs'_def split: option.splits) - apply (clarsimp simp: valid_bound_sc'_def tcb_bound_refs'_def split: option.splits) + subgoal + by (clarsimp simp: valid_bound_tcb'_def tcb_bound_refs'_def + split: option.splits thread_state.splits) + apply (clarsimp simp: valid_bound_ntfn'_def tcb_bound_refs'_def split: option.splits) apply (clarsimp simp: valid_bound_sc'_def tcb_bound_refs'_def split: option.splits) apply (clarsimp simp: none_top_bool_cases) apply (rename_tac prev) @@ -1198,8 +1234,7 @@ lemma state_refs: apply (clarsimp simp: state_refs_of'_def split: option.splits) apply (rename_tac ko) apply (case_tac ko; simp) - apply (fastforce simp: ep_q_refs_of'_def ko_wp_at'_def live'_def) - apply (fastforce simp: ntfn_q_refs_of'_def ko_wp_at'_def live'_def live_ntfn'_def state_refs_of'_def + apply (fastforce simp: ko_wp_at'_def live'_def live_ntfn'_def state_refs_of'_def split: ntfn.splits) apply (insert refs valid_objs valid_idle' iflive pspace) apply (frule (8) thread_not_idle_implies_sc_not_idle') @@ -1505,16 +1540,6 @@ proof (simp add: invs'_def valid_pspace'_def apply (insert pa pd bd pspace_distinct'_state' list_refs) by (subst list_refs_of_reply'_state'; blast?) - show "if_live_then_nonz_cap' ?s" using iflive - apply (clarsimp simp: if_live_then_nonz_cap'_def) - apply (drule spec, drule(1) mp) - apply (clarsimp simp: ex_nonz_cap_to'_def) - apply (rule exI, rule conjI, assumption) - apply (drule non_null_present [OF cte_wp_at_weakenE']) - apply clarsimp - apply simp - done - from ifunsafe show "if_unsafe_then_cap' ?s" by (clarsimp simp: if_unsafe_then_cap'_def intro!: cte_cap) @@ -1707,10 +1732,12 @@ proof (simp add: invs'_def valid_pspace'_def apply simp done - from vsp show "valid_sched_pointers_2 (pspace' |> tcb_of' |> tcbSchedPrev) - (pspace' |> tcb_of' |> tcbSchedNext) - (tcbQueued |< (pspace' |> tcb_of')) - (tcbInReleaseQueue |< (pspace' |> tcb_of'))" + from vsp show "valid_sched_pointers_2 + (pspace' |> tcb_of' |> tcbSchedPrev) + (pspace' |> tcb_of' |> tcbSchedNext) + (\t. (tcbQueued |< (pspace' |> tcb_of')) t + \ (tcbInReleaseQueue |< (pspace' |> tcb_of')) t + \ (inIPCQueueThreadState |< (pspace' |> tcb_of' ||> tcbState)) t)" by (clarsimp simp: valid_sched_pointers_def opt_pred_def opt_map_def) qed (clarsimp simp: valid_dom_schedule'_def) @@ -1830,7 +1857,7 @@ lemma deleteObjects_invs': apply (simp cong: if_cong) apply (subgoal_tac "is_aligned ptr bits \ 3 \ bits \ bits < word_bits",simp) apply clarsimp - apply (frule delete_locale.intro; simp add: deletionIsSafe_def sym_refs_asrt_def valid_idle'_asrt_def) + apply (frule delete_locale.intro; simp add: deletionIsSafe_def) apply (rule subst[rotated, where P=invs'], erule delete_locale.delete_invs') apply (clarsimp simp: deletionIsSafe_def) apply (simp add: field_simps mask_def) @@ -1895,7 +1922,7 @@ lemma deleteObjects_st_tcb_at': field_simps ko_wp_at'_def ps_clear_def cong:if_cong split: option.splits) - apply (simp add: delete_locale_def deletionIsSafe_def sym_refs_asrt_def valid_idle'_asrt_def) + apply (simp add: delete_locale_def deletionIsSafe_def) done lemma deleteObjects_cap_to': @@ -1921,7 +1948,7 @@ lemma deleteObjects_cap_to': else ksPSpace s x\)",erule ssubst) apply (simp add: field_simps ex_cte_cap_wp_to'_def cong:if_cong) apply simp - apply (simp add: delete_locale_def deletionIsSafe_def sym_refs_asrt_def valid_idle'_asrt_def) + apply (simp add: delete_locale_def deletionIsSafe_def) done lemma valid_untyped_no_overlap: diff --git a/proof/refine/RISCV64/Finalise_R.thy b/proof/refine/RISCV64/Finalise_R.thy index fc87fee126..f53030e190 100644 --- a/proof/refine/RISCV64/Finalise_R.thy +++ b/proof/refine/RISCV64/Finalise_R.thy @@ -19,9 +19,6 @@ crunch copyGlobalMappings for ifunsafe'[wp]: "if_unsafe_then_cap'" and pred_tcb_at'[wp]: "pred_tcb_at' proj P t" and vms'[wp]: "valid_machine_state'" - and ct_not_inQ[wp]: "ct_not_inQ" - and tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - and ct__in_cur_domain'[wp]: ct_idle_or_in_cur_domain' and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" and valid_irq_states'[wp]: "valid_irq_states'" @@ -105,7 +102,7 @@ crunch emptySlot and ksRQL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" and tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" - and inQ_tcbs_of'[wp]: "\s. P (inQ d p |< tcbs_of' s)" + and inQ_opt_pred[wp]: "\s. P (inQ d p |< tcbs_of' s)" and tcbDomain[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" crunch clearUntypedFreeIndex @@ -1117,13 +1114,6 @@ lemma emptySlot_mdb [wp]: done end -lemma if_live_then_nonz_cap'_def2: - "if_live_then_nonz_cap' = - (\s. \ptr. ko_wp_at' live' ptr s \ - (\p zr. (option_map zobj_refs' o cteCaps_of s) p = Some zr \ ptr \ zr))" - by (fastforce simp: if_live_then_nonz_cap'_def ex_nonz_cap_to'_def cte_wp_at_ctes_of - cteCaps_of_def) - lemma updateMDB_ko_wp_at_live[wp]: "\\s. P (ko_wp_at' live' p' s)\ updateMDB p m @@ -1189,35 +1179,6 @@ lemma clearUntypedFreeIndex_cteCaps_of[wp]: clearUntypedFreeIndex sl \\y s. P (cteCaps_of s)\" by (simp add: cteCaps_of_def, wp) -lemma emptySlot_iflive'[wp]: - "\\s. if_live_then_nonz_cap' s \ cte_wp_at' (\cte. removeable' sl s (cteCap cte)) sl s\ - emptySlot sl opt - \\rv. if_live_then_nonz_cap'\" - apply (simp add: emptySlot_def case_Null_If if_live_then_nonz_cap'_def2 - del: comp_apply) - apply (rule hoare_pre) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - getCTE_wp opt_return_pres_lift - clearUntypedFreeIndex_ctes_of - clearUntypedFreeIndex_cteCaps_of - hoare_vcg_ex_lift - | wp (once) hoare_vcg_imp_lift - | simp add: cte_wp_at_ctes_of del: comp_apply)+ - apply (clarsimp simp: modify_map_same imp_conjR[symmetric]) - apply (drule spec, drule(1) mp) - apply (clarsimp simp: cte_wp_at_ctes_of modify_map_def split: if_split_asm) - apply (case_tac "p \ sl") - apply blast - apply (simp add: removeable'_def cteCaps_of_def) - apply (erule disjE) - apply (clarsimp simp: cte_wp_at_ctes_of modify_map_def - dest!: capMaster_same_refs) - apply fastforce - apply clarsimp - apply (drule(1) bspec) - apply (clarsimp simp: ko_wp_at'_def) - done - lemma setIRQState_irq_node'[wp]: "\\s. P (irq_node' s)\ setIRQState state irq \\_ s. P (irq_node' s)\" apply (simp add: setIRQState_def setInterruptState_def getInterruptState_def) @@ -1434,13 +1395,6 @@ crunch emptySlot crunch deletedIRQHandler for tcbQueued[wp]: "obj_at' (\tcb. P (tcbQueued tcb)) t" -crunch emptySlot - for tcbDomain[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" - -lemma emptySlot_ct_idle_or_in_cur_domain'[wp]: - "\ct_idle_or_in_cur_domain'\ emptySlot sl opt \\_. ct_idle_or_in_cur_domain'\" - by (wp ct_idle_or_in_cur_domain'_lift2 tcb_in_cur_domain'_lift | simp)+ - crunch postCapDeletion for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" (wp: crunch_wps simp: crunch_simps) @@ -2269,51 +2223,30 @@ global_interpretation unbindFromSC: typ_at_all_props' "unbindFromSC t" global_interpretation finaliseCap: typ_at_all_props' "finaliseCap cap final x" by typ_at_props' -lemma ntfn_q_refs_of'_mult: - "ntfn_q_refs_of' ntfn = (case ntfn of Structures_H.WaitingNtfn q \ set q | _ \ {}) \ {NTFNSignal}" - by (cases ntfn, simp_all) - lemma tcb_st_not_Bound: "(p, NTFNBound) \ tcb_st_refs_of' ts" "(p, TCBBound) \ tcb_st_refs_of' ts" by (auto simp: tcb_st_refs_of'_def split: Structures_H.thread_state.split) -lemma get_refs_NTFNSchedContext_not_Bound: - "(tcb, NTFNBound) \ get_refs NTFNSchedContext (ntfnSc ntfn)" - by (clarsimp simp: get_refs_def split: option.splits) - crunch setBoundNotification for valid_bitmaps[wp]: valid_bitmaps - and tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" - and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" and tcbQueued[wp]: "\s. P (tcbQueued |< tcbs_of' s)" and valid_sched_pointers[wp]: valid_sched_pointers - (wp: valid_bitmaps_lift) + (wp: valid_bitmaps_lift threadSet_field_inv threadSet_field_opt_pred threadSet_valid_sched_pointers + ignore: threadSet) context begin interpretation Arch . (*FIXME: arch-split*) lemma unbindNotification_invs[wp]: "unbindNotification tcb \invs'\" apply (simp add: unbindNotification_def invs'_def valid_dom_schedule'_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ gbn_sp'], rename_tac ntfnPtr) - apply (case_tac ntfnPtr, clarsimp, wp, clarsimp) - apply clarsimp - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule hoare_pre) - apply (wp sbn'_valid_pspace'_inv sbn_sch_act' valid_irq_node_lift - irqs_masked_lift setBoundNotification_ct_not_inQ - sym_heap_sched_pointers_lift - untyped_ranges_zero_lift | clarsimp simp: cteCaps_of_def o_def)+ - apply (rule conjI) - apply (frule obj_at_valid_objs', clarsimp+) - apply (simp add: valid_ntfn'_def valid_obj'_def - split: ntfn.splits) - apply (rule conjI) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (clarsimp simp: pred_tcb_at' conj_comms) - apply (erule if_live_then_nonz_capE') - apply (clarsimp simp: obj_at'_def ko_wp_at'_def live'_def live_ntfn'_def) + apply (rule bind_wp[OF _ gbn_sp'], rename_tac ntfnPtrOpt) + apply (case_tac ntfnPtrOpt, clarsimp, wp, clarsimp) + apply (clarsimp simp: updateNotification_def) + apply (wpsimp wp: getNotification_wp sbn'_valid_pspace'_inv valid_irq_node_lift irqs_masked_lift + sym_heap_sched_pointers_lift untyped_ranges_zero_lift + | clarsimp simp: cteCaps_of_def o_def)+ + apply (fastforce dest!: ntfn_ko_at_valid_objs_valid_ntfn' simp: valid_ntfn'_def valid_obj'_def) done lemma ntfn_bound_tcb_at': @@ -2332,32 +2265,28 @@ lemma ntfn_bound_tcb_at': lemma unbindMaybeNotification_invs[wp]: "unbindMaybeNotification ntfnptr \invs'\" apply (simp add: unbindMaybeNotification_def invs'_def valid_dom_schedule'_def) - apply (rule bind_wp[OF _ stateAssert_sp]) apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (wpsimp wp: sbn'_valid_pspace'_inv sbn_sch_act' - valid_irq_node_lift irqs_masked_lift setBoundNotification_ct_not_inQ + apply (wpsimp wp: getNotification_wp sbn'_valid_pspace'_inv valid_irq_node_lift irqs_masked_lift untyped_ranges_zero_lift sym_heap_sched_pointers_lift - simp: cteCaps_of_def) + simp: updateNotification_def cteCaps_of_def) by (auto simp: pred_tcb_at' valid_pspace'_def valid_obj'_def - valid_ntfn'_def ko_wp_at'_def live'_def live_ntfn'_def o_def + valid_ntfn'_def ko_wp_at'_def live_ntfn'_def o_def elim!: obj_atE' if_live_then_nonz_capE' split: option.splits ntfn.splits) end lemma setNotification_invs': - "\invs' - and (\s. live_ntfn' ntfn \ ex_nonz_cap_to' ntfnPtr s) - and valid_ntfn' ntfn\ + "\invs' and valid_ntfn' ntfn\ setNotification ntfnPtr ntfn \\_. invs'\" apply (simp add: invs'_def valid_dom_schedule'_def) - apply (wpsimp wp: untyped_ranges_zero_lift simp: cteCaps_of_def o_def live'_def) + apply (wpsimp wp: untyped_ranges_zero_lift simp: cteCaps_of_def o_def) done lemma schedContextUnbindNtfn_valid_objs'[wp]: "schedContextUnbindNtfn scPtr \valid_objs'\" - unfolding schedContextUnbindNtfn_def updateSchedContext_def + unfolding schedContextUnbindNtfn_def updateSchedContext_def updateNotification_def apply (wpsimp wp: getNotification_wp hoare_vcg_all_lift hoare_vcg_imp_lift') apply normalise_obj_at' apply (rename_tac ntfnPtr ntfn sc) @@ -2371,7 +2300,7 @@ lemma schedContextUnbindNtfn_invs'[wp]: "schedContextUnbindNtfn scPtr \invs'\" unfolding invs'_def valid_pspace'_def valid_dom_schedule'_def apply wpsimp \ \this handles valid_objs' separately\ - unfolding schedContextUnbindNtfn_def updateSchedContext_def + unfolding schedContextUnbindNtfn_def updateSchedContext_def updateNotification_def apply (wpsimp wp: getNotification_wp hoare_vcg_all_lift hoare_vcg_imp_lift' valid_ntfn_lift') by (auto simp: ko_wp_at'_def obj_at'_def live'_def live_sc'_def live_ntfn'_def o_def @@ -2381,13 +2310,6 @@ crunch schedContextMaybeUnbindNtfn for invs'[wp]: invs' (simp: crunch_simps wp: crunch_wps ignore: setReply) -lemma replyUnlink_invs'[wp]: - "\invs' and (\s. replyTCBs_of s replyPtr = Some tcbPtr \ \ is_reply_linked replyPtr s)\ - replyUnlink replyPtr tcbPtr - \\_. invs'\" - unfolding invs'_def valid_dom_schedule'_def valid_pspace'_def - by wpsimp - crunch replyRemove for if_unsafe_then_cap'[wp]: if_unsafe_then_cap' and valid_global_refs'[wp]: valid_global_refs' @@ -2397,16 +2319,15 @@ crunch replyRemove and valid_irq_states'[wp]: valid_irq_states' and valid_machine_state'[wp]: valid_machine_state' and irqs_masked'[wp]: irqs_masked' - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' and pspace_domain_valid[wp]: pspace_domain_valid and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and untyped_ranges_zero'[wp]: untyped_ranges_zero' - and cur_tcb'[wp]: cur_tcb' and no_0_obj'[wp]: no_0_obj' + and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" and valid_dom_schedule'[wp]: valid_dom_schedule' - and pspace_bounded'[wp]: pspace_bounded' and pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' - (simp: crunch_simps wp: crunch_wps) + (simp: crunch_simps wp: crunch_wps valid_dom_schedule'_lift) context begin interpretation Arch . (*FIXME: arch-split*) @@ -2419,6 +2340,12 @@ end global_interpretation replyRemove: typ_at_all_props' "replyRemove replyPtr tcbPtr" by typ_at_props' +global_interpretation unbindNotification: typ_at_all_props' "unbindNotification tcbPtr" + by typ_at_props' + +global_interpretation unbindMaybeNotification: typ_at_all_props' "unbindMaybeNotification ntfnPtr" + by typ_at_props' + lemma replyNext_update_valid_objs': "\valid_objs' and (\s. ((\r. next_opt = Some (Next r) \ reply_at' r s) \ @@ -2435,14 +2362,11 @@ lemma replyPrev_update_valid_objs'[wp]: by (case_tac prev_opt; wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def) lemma replyPop_valid_objs'[wp]: - "\valid_objs' and valid_sched_pointers and sym_heap_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - replyPop replyPtr tcbPtr - \\_. valid_objs'\" + "replyPop replyPtr tcbPtr \valid_objs'\" unfolding replyPop_def supply if_split[split del] apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp wp: schedContextDonate_valid_objs' hoare_vcg_if_lift_strong threadGet_wp) + apply (wpsimp wp: hoare_vcg_if_lift_strong threadGet_wp) apply (clarsimp simp: obj_at'_def) apply (wpsimp wp: replyNext_update_valid_objs' hoare_vcg_if_lift2 hoare_vcg_all_lift @@ -2453,10 +2377,7 @@ lemma replyPop_valid_objs'[wp]: done lemma replyRemove_valid_objs'[wp]: - "\valid_objs' and valid_sched_pointers and sym_heap_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - replyRemove replyPtr tcbPtr - \\_. valid_objs'\" + "replyRemove replyPtr tcbPtr \valid_objs'\" apply (clarsimp simp: replyRemove_def) apply (wpsimp wp: updateReply_valid_objs' hoare_vcg_all_lift hoare_drop_imps simp: valid_reply'_def @@ -2466,6 +2387,9 @@ lemma replyRemove_valid_objs'[wp]: crunch schedContextDonate, updateSchedContext for ko_at'_reply[wp]: "\s. Q (ko_at' (reply :: reply) scPtr s)" +crunch updateSchedContext, updateReply + for ko_at'_tcb[wp]: "\s. Q (ko_at' (tcb :: tcb) tcbPtr s)" + lemma replyPop_valid_replies'[wp]: "\\s. valid_replies' s \ pspace_aligned' s \ pspace_distinct' s \ sym_refs (list_refs_of_replies' s)\ @@ -2498,9 +2422,7 @@ lemma replyRemove_valid_replies'[wp]: lemma replyPop_valid_mdb'[wp]: "replyPop replyPtr tcbPtr \valid_mdb'\" unfolding replyPop_def - apply (wpsimp wp: schedContextDonate_valid_mdb' hoare_vcg_if_lift_strong threadGet_const) - apply (clarsimp simp: obj_at'_def) - by (wpsimp wp: gts_wp')+ + by (wpsimp wp: schedContextDonate_valid_mdb' hoare_vcg_all_lift hoare_drop_imps threadGet_wp) lemma replyRemove_valid_mdb'[wp]: "replyRemove replyPtr tcbPtr \valid_mdb'\" @@ -2508,8 +2430,7 @@ lemma replyRemove_valid_mdb'[wp]: by (wpsimp wp: gts_wp')+ lemma replyRemove_valid_pspace'[wp]: - "\\s. valid_pspace' s \ sym_refs (list_refs_of_replies' s) - \ valid_sched_pointers s \ sym_heap_sched_pointers s\ + "\\s. valid_pspace' s \ sym_refs (list_refs_of_replies' s)\ replyRemove replyPtr tcbPtr \\_. valid_pspace'\" by (wpsimp simp: valid_pspace'_def) @@ -2523,7 +2444,7 @@ lemma replyPop_list_refs_of_replies'[wp]: \\_ s. sym_refs (list_refs_of_replies' s)\" unfolding replyPop_def decompose_list_refs_of_replies' apply (wpsimp wp: cleanReply_list_refs_of_replies' hoare_vcg_if_lift hoare_vcg_imp_lift' gts_wp' - haskell_assert_wp + haskell_assert_wp threadGet_wp hoare_vcg_all_lift split_del: if_split) apply (intro conjI impI) apply (all \normalise_obj_at'\) @@ -2574,8 +2495,7 @@ lemma replyRemove_list_refs_of_replies'[wp]: lemma live'_HeadScPtr: "\replyNext reply = Some reply_next; sym_refs (state_refs_of' s); ko_at' reply replyPtr s; - isHead (Some reply_next); ko_at' sc (theHeadScPtr (Some reply_next)) s; - valid_bound_ntfn' (scNtfn sc) s\ + valid_reply' reply s; isHead (Some reply_next); ko_at' sc (theHeadScPtr (Some reply_next)) s\ \ ko_wp_at' live' (theHeadScPtr (Some reply_next)) s" apply (clarsimp simp: theHeadScPtr_def getHeadScPtr_def isHead_def split: reply_next.splits) @@ -2584,117 +2504,60 @@ lemma live'_HeadScPtr: apply (clarsimp simp: state_refs_of'_def get_refs_def2 obj_at'_def) apply (prop_tac "(replyPtr, SCReply) \ state_refs_of' s head") apply (fastforce simp: sym_refs_def) - apply (clarsimp simp: state_refs_of'_def get_refs_def2 obj_at'_def ko_wp_at'_def - live'_def live_sc'_def) - done - -lemma replyPop_iflive: - "\if_live_then_nonz_cap' and valid_objs' and ex_nonz_cap_to' tcbPtr - and sym_heap_sched_pointers and valid_sched_pointers - and (\s. sym_refs (list_refs_of_replies' s)) - and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - replyPop replyPtr tcbPtr - \\_. if_live_then_nonz_cap'\" - (is "\?pre\ _ \_\") - unfolding replyPop_def updateSchedContext_def - apply (wpsimp wp: updateReply_iflive' updateReply_valid_objs') - apply (wpsimp wp: setSchedContext_iflive' schedContextDonate_if_live_then_nonz_cap' - threadGet_inv hoare_vcg_if_lift2 - | wp (once) hoare_drop_imps)+ - apply (wpsimp wp: updateReply_iflive' updateReply_valid_objs') - apply (wpsimp wp: updateReply_iflive'_strong updateReply_valid_objs' - simp: valid_reply'_def) - apply (rule_tac Q'="\_. ?pre - and ex_nonz_cap_to' scPtr - and (\s. prevReplyPtrOpt \ Nothing - \ ex_nonz_cap_to' (fromJust prevReplyPtrOpt) s) - and valid_reply' reply" - in hoare_post_imp) - apply (force simp: valid_reply'_def live_reply'_def) - apply (wpsimp wp: hoare_vcg_imp_lift')+ - apply normalise_obj_at' - apply (rename_tac s reply sched_context tcb) - apply (frule (1) sc_ko_at_valid_objs_valid_sc') - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (case_tac "replyNext reply") - apply (clarsimp simp: isHead_def split: option.splits) - apply (frule (2) live'_HeadScPtr) - apply (clarsimp simp: isHead_def) - apply fastforce - apply (clarsimp simp: valid_sched_context'_def) - apply (frule (1) if_live_then_nonz_capE') - apply clarsimp - apply (intro conjI impI allI) - apply (clarsimp simp: valid_sched_context'_def refillSize_def valid_reply'_def) - apply clarsimp - apply (rename_tac replyPrevPtr) - apply (frule reply_sym_heap_Next_Prev) - apply (frule_tac p'=replyPtr and p=replyPrevPtr and hp'="replyPrevs_of s" in sym_heapD2) - apply (clarsimp simp: opt_map_def obj_at'_def) - apply (fastforce intro: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def live'_def live_reply'_def opt_map_def valid_reply'_def) - done - -lemma replyRemove_if_live_then_nonz_cap': - "\if_live_then_nonz_cap' and valid_objs' and ex_nonz_cap_to' tcbPtr - and sym_heap_sched_pointers and valid_sched_pointers - and (\s. sym_refs (list_refs_of_replies' s)) - and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - replyRemove replyPtr tcbPtr - \\_. if_live_then_nonz_cap'\" - apply (clarsimp simp: replyRemove_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (intro bind_wp[OF _ get_reply_sp'] - bind_wp[OF _ assert_sp] - bind_wp[OF _ assert_opt_sp] - bind_wp[OF _ gts_sp']) - apply (rule hoare_if) - apply (wpsimp wp: replyPop_iflive) - apply (clarsimp simp: when_def) - apply (intro conjI impI; (solves wpsimp)?) - apply (clarsimp simp: theReplyNextPtr_def) - apply (rename_tac prev_reply next_reply) - apply (wpsimp wp: updateReply_iflive'_strong hoare_drop_imps) - apply (frule_tac rp'=replyPtr and rp=prev_reply in sym_refs_replyNext_replyPrev_sym) - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (fastforce elim: if_live_then_nonz_capE' - simp: valid_reply'_def ko_wp_at'_def obj_at'_def live'_def live_reply'_def opt_map_def) - apply (wpsimp wp: updateReply_iflive'_strong) - apply (fastforce simp: live_reply'_def) - apply (wpsimp wp: updateReply_iflive'_strong) - apply (fastforce simp: live_reply'_def) + apply (clarsimp simp: state_refs_of'_def get_refs_def2 obj_at'_def live'_def ko_wp_at'_def + live_sc'_def valid_reply'_def) done crunch replyRemove for valid_bitmaps[wp]: valid_bitmaps and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers (simp: crunch_simps wp: crunch_wps) -lemma replyPop_invs': - "\invs' and obj_at' (\reply. replyNext reply \ None) replyPtr - and ex_nonz_cap_to' tcbPtr\ +lemma replyUnlink_thread_state_valid_sched_pointers: + "\valid_sched_pointers and st_tcb_at' (not inIPCQueueThreadState) tcbPtr\ + replyUnlink replyPtr tcbPtr + \\_. valid_sched_pointers\" + unfolding replyUnlink_def + apply (wpsimp wp: setThreadState_not_queued_valid_sched_pointers gts_wp') + apply (clarsimp simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_def) + done + +lemma replyPop_valid_sched_pointers: + "\valid_sched_pointers and sym_heap_sched_pointers + and st_tcb_at' (not inIPCQueueThreadState) tcbPtr\ replyPop replyPtr tcbPtr - \\_. invs'\" - unfolding invs'_def - by (wpsimp wp: replyPop_iflive simp: valid_pspace'_def) + \\_. valid_sched_pointers\" + unfolding replyPop_def + apply (wpsimp wp: replyUnlink_thread_state_valid_sched_pointers threadGet_wp hoare_vcg_all_lift + hoare_drop_imps hoare_vcg_if_lift2) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) + done + +lemma replyRemove_valid_sched_pointers: + "\valid_sched_pointers and sym_heap_sched_pointers + and st_tcb_at' (not inIPCQueueThreadState) tcbPtr\ + replyRemove replyPtr tcbPtr + \\_. valid_sched_pointers\" + unfolding replyRemove_def + apply (wpsimp wp: replyPop_valid_sched_pointers replyUnlink_thread_state_valid_sched_pointers + hoare_drop_imps hoare_vcg_if_lift2) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) + done lemma replyRemove_invs': - "\invs' and ex_nonz_cap_to' tcbPtr\ + "\invs' and st_tcb_at' (not inIPCQueueThreadState) tcbPtr\ replyRemove replyPtr tcbPtr \\_. invs'\" unfolding invs'_def - apply (wpsimp wp: replyRemove_if_live_then_nonz_cap') - apply fastforce - done + by (wpsimp wp: replyRemove_valid_sched_pointers) lemma replyClear_invs'[wp]: "replyClear replyPtr tcbPtr \invs'\" unfolding replyClear_def apply (wpsimp wp: replyRemove_invs' gts_wp') - apply (rule if_live_then_nonz_capE') - apply fastforce - by (fastforce simp: pred_tcb_at'_def obj_at'_def ko_wp_at'_def live'_def) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (rename_tac tcb, case_tac "tcbState tcb"; clarsimp) + done (* Ugh, required to be able to split out the abstract invs *) lemma finaliseCap_True_invs'[wp]: @@ -2901,13 +2764,12 @@ lemma unbindNotification_valid_objs'_helper': split: option.splits ntfn.splits) lemma unbindNotification_valid_objs'[wp]: - "\valid_objs'\ - unbindNotification t - \\rv. valid_objs'\" - apply (simp add: unbindNotification_def) - apply (rule hoare_pre) + "unbindNotification t \valid_objs'\" + unfolding unbindNotification_def apply (wp threadSet_valid_objs' gbn_wp' set_ntfn_valid_objs' hoare_vcg_all_lift getNotification_wp - | wpc | clarsimp simp: setBoundNotification_def unbindNotification_valid_objs'_helper)+ + | wpc + | clarsimp simp: setBoundNotification_def updateNotification_def + unbindNotification_valid_objs'_helper)+ apply (clarsimp elim!: obj_atE') apply (rule valid_objsE', assumption+) apply (clarsimp simp: valid_obj'_def unbindNotification_valid_objs'_helper') @@ -2916,30 +2778,22 @@ lemma unbindNotification_valid_objs'[wp]: lemma unbindMaybeNotification_valid_tcbs'[wp]: "unbindMaybeNotification t \valid_tcbs'\" unfolding unbindMaybeNotification_def - by (wp threadSet_valid_tcbs' - | wpc | clarsimp simp: setBoundNotification_def unbindNotification_valid_objs'_helper)+ + by (wp threadSet_valid_tcbs' getNotification_wp + | wpc + | clarsimp simp: setBoundNotification_def updateNotification_def + unbindNotification_valid_objs'_helper)+ lemma unbindMaybeNotification_valid_objs'[wp]: - "\valid_objs'\ - unbindMaybeNotification t - \\rv. valid_objs'\" + "unbindMaybeNotification t \valid_objs'\" apply (simp add: unbindMaybeNotification_def) - apply (rule bind_wp[OF _ stateAssert_sp]) apply (rule bind_wp[OF _ get_ntfn_sp']) apply (rule hoare_pre) apply (wp threadSet_valid_objs' gbn_wp' set_ntfn_valid_objs' hoare_vcg_all_lift getNotification_wp - | wpc | clarsimp simp: setBoundNotification_def unbindNotification_valid_objs'_helper)+ - apply (clarsimp elim!: obj_atE') - apply (rule valid_objsE', assumption+) - apply (clarsimp simp: valid_obj'_def unbindNotification_valid_objs'_helper') - done - -lemma unbindMaybeNotification_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ unbindMaybeNotification t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: unbindMaybeNotification_def) - apply (rule hoare_pre) - apply (wp sbn_sch_act' | wpc | simp)+ + | wpc + | clarsimp simp: setBoundNotification_def updateNotification_def + unbindNotification_valid_objs'_helper)+ + apply (fastforce dest!: ntfn_ko_at_valid_objs_valid_ntfn' + simp: unbindNotification_valid_objs'_helper') done lemma valid_cong: @@ -2952,30 +2806,26 @@ lemma unbindMaybeNotification_obj_at'_ntfnBound: "\\\ unbindMaybeNotification r \\_ s. obj_at' (\ntfn. ntfnBoundTCB ntfn = None) r s\" - apply (simp add: unbindMaybeNotification_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule hoare_pre) - apply (wp obj_at_setObject2 - | wpc - | simp add: setBoundNotification_def threadSet_def updateObject_default_def in_monad)+ - apply (simp add: setNotification_def obj_at'_real_def cong: valid_cong) - apply (wp setObject_ko_wp_at, (simp add: objBits_simps')+) + unfolding unbindMaybeNotification_def + apply (wp + | wpc + | simp add: setBoundNotification_def updateNotification_def)+ + apply (simp add: setNotification_def obj_at'_real_def) + apply (wp setObject_ko_wp_at, (simp add: objBits_simps')+) + apply (wpsimp wp: getNotification_wp)+ apply (clarsimp simp: obj_at'_def ko_wp_at'_def) done lemma unbindMaybeNotification_obj_at'_no_change: "\ntfn tcb. P ntfn = P (ntfn \ntfnBoundTCB := tcb\) \ unbindMaybeNotification r \obj_at' P r'\" - apply (simp add: unbindMaybeNotification_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule hoare_pre) - apply (wp obj_at_setObject2 + unfolding unbindMaybeNotification_def + apply (wp | wpc - | simp add: setBoundNotification_def threadSet_def updateObject_default_def in_monad)+ - apply (simp add: setNotification_def obj_at'_real_def cong: valid_cong) - apply (wp setObject_ko_wp_at, (simp add: objBits_simps')+) + | simp add: setBoundNotification_def updateNotification_def)+ + apply (simp add: setNotification_def obj_at'_real_def cong: valid_cong) + apply (wp setObject_ko_wp_at, (simp add: objBits_simps')+) + apply (wpsimp wp: getNotification_wp)+ apply (clarsimp simp: obj_at'_def ko_wp_at'_def) done @@ -2991,54 +2841,19 @@ crunch cancelSignal, cancelAllIPC (wp: sts_bound_tcb_at' threadSet_cteCaps_of crunch_wps getObject_inv ignore: threadSet) -lemma scTCB_update_Nothing_valid_objs': - "\valid_objs' and sc_at' scPtr\ - updateSchedContext scPtr (scTCB_update (\_. Nothing)) - \\_. valid_objs'\" - apply wpsimp - by (clarsimp simp: valid_obj'_def opt_pred_def opt_map_def obj_at'_def valid_sched_context'_def - refillSize_def objBits_simps valid_sched_context_size'_def) - - lemma schedContextUnbindTCB_valid_objs'[wp]: - "\valid_objs' and pspace_aligned' and pspace_distinct'\ - schedContextUnbindTCB scPtr - \\_. valid_objs'\" - unfolding schedContextUnbindTCB_def - by (wpsimp wp: scTCB_update_Nothing_valid_objs') - - lemma schedContextUnbindTCB_valid_mdb'[wp]: - "schedContextUnbindTCB scPtr \valid_mdb'\" - unfolding schedContextUnbindTCB_def - by (wpsimp wp: valid_mdb'_lift threadSet_ctes_of) - - lemma tcbSchedContext_update_update_tcb_cte_cases: - "(a, b) \ ran tcb_cte_cases \ a (tcbSchedContext_update f tcb) = a tcb" - unfolding tcb_cte_cases_def - by (case_tac tcb; fastforce simp: objBits_simps') +lemma schedContextUnbindTCB_valid_objs'[wp]: + "schedContextUnbindTCB scPtr \valid_objs'\" + unfolding schedContextUnbindTCB_def + by (wpsimp wp: scTCB_update_Nothing_valid_objs') -crunch schedContextUnbindTCB - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" - and if_unsafe_then_cap'[wp]: if_unsafe_then_cap' - (wp: threadSet_ifunsafe'T threadSet_cap_to simp: tcbSchedContext_update_update_tcb_cte_cases) - -lemma scTCB_update_Nothing_if_live_then_nonz_cap'[wp]: - "updateSchedContext scPtr (scTCB_update (\_. Nothing)) \if_live_then_nonz_cap'\" - unfolding updateSchedContext_def - apply (wpsimp wp: setSchedContext_iflive') - by (fastforce elim: if_live_then_nonz_capE' simp: live'_def live_sc'_def ko_wp_at'_def obj_at'_def) - -lemma tcbSchedContext_update_Nothing_if_live_then_nonz_cap'[wp]: - "threadSet (tcbSchedContext_update (\_. Nothing)) tptr \if_live_then_nonz_cap'\" - apply (wpsimp wp: threadSet_iflive') - by (fastforce simp: live_sc'_def ko_wp_at'_def obj_at'_def) - -lemma schedContextUnbindTCB_if_live_then_nonz_cap'[wp]: - "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct' and valid_objs' - and sym_heap_sched_pointers and valid_sched_pointers\ - schedContextUnbindTCB scPtr - \\_. if_live_then_nonz_cap'\" +lemma schedContextUnbindTCB_valid_mdb'[wp]: + "schedContextUnbindTCB scPtr \valid_mdb'\" unfolding schedContextUnbindTCB_def - by wpsimp + by (wpsimp wp: valid_mdb'_lift threadSet_ctes_of) + +crunch schedContextUnbindTCB + for if_unsafe_then_cap'[wp]: if_unsafe_then_cap' + (wp: threadSet_ifunsafe'T threadSet_cap_to simp: update_tcb_cte_cases) crunch schedContextUnbindTCB for valid_bitmaps[wp]: valid_bitmaps @@ -3064,7 +2879,7 @@ crunch schedContextUnbindTCB and valid_sched_pointers[wp]: valid_sched_pointers and untyped_ranges_zero'[wp]: untyped_ranges_zero' (wp: crunch_wps threadSet_sched_pointers threadSet_valid_sched_pointers threadSet_urz - ignore: threadSet) + ignore: threadSet simp: crunch_simps) lemma schedContextUnbindTCB_invs'[wp]: "schedContextUnbindTCB scPtr \invs'\" @@ -3144,7 +2959,7 @@ crunch schedContextCancelYieldTo for tcbSchedNext_tcbSchedPrev[wp]: "\s. obj_at' (\tcb. Q (tcbSchedNext tcb) (tcbSchedPrev tcb)) ptr s" -crunch cancelIPC, updateRestartPC +crunch updateRestartPC for valid_sched_pointers[wp]: valid_sched_pointers and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers (wp: crunch_wps threadSet_valid_sched_pointers threadSet_sched_pointers ignore: threadSet) @@ -3157,35 +2972,32 @@ lemma tcbSchedDequeue_tcbQueued_False[wp]: apply (force simp: obj_at'_def opt_pred_def opt_map_def) done -lemma tcbQueueRemove_tcbSchedNext_tcbSchedPrev_None: - "\\s. \ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\ - tcbQueueRemove q t - \\_ s. obj_at' (\tcb. tcbSchedNext tcb = None \ tcbSchedPrev tcb = None) t s\" - apply (clarsimp simp: tcbQueueRemove_def) - apply (wpsimp wp: threadSet_wp getTCB_wp) - by (fastforce dest!: heap_ls_last_None - simp: list_queue_relation_def prev_queue_head_def queue_end_valid_def - obj_at'_def opt_map_def ps_clear_def objBits_simps - split: if_splits) - -lemma tcbReleaseRemove_tcbSchedNext_tcbSchedPrev_None: - "\\s. valid_sched_pointers s \ \ (tcbQueued |< tcbs_of' s) t\ +lemma tcbReleaseRemove_tcbSchedPrev_tcbSchedNext_None: + "\\s. valid_sched_pointers s + \ \ (tcbQueued |< tcbs_of' s) t \ \ (inIPCQueueThreadState |< tcbStates_of' s) t\ tcbReleaseRemove t - \\_. obj_at' (\tcb. tcbSchedNext tcb = None \ tcbSchedPrev tcb = None) t\" - apply (clarsimp simp: tcbReleaseRemove_def) - apply (wpsimp wp: tcbQueueRemove_tcbSchedNext_tcbSchedPrev_None inReleaseQueue_wp - hoare_vcg_ex_lift threadSet_sched_pointers) - apply (clarsimp simp: valid_sched_pointers_def) - apply (drule_tac x=t in spec) - apply (fastforce simp: ksReleaseQueue_asrt_def opt_pred_def obj_at'_def opt_map_def) - done - -lemma suspend_tcbSchedNext_tcbSchedPrev_None: - "\invs'\ suspend t \\_ s. obj_at' (\tcb. tcbSchedNext tcb = None \ tcbSchedPrev tcb = None) t s\" - apply (clarsimp simp: suspend_def) - apply (wpsimp wp: tcbQueueRemove_tcbSchedNext_tcbSchedPrev_None - tcbReleaseRemove_tcbSchedNext_tcbSchedPrev_None hoare_drop_imps - | strengthen invs_sym_heap_sched_pointers)+ + \\_. obj_at' (\tcb. tcbSchedPrev tcb = None \ tcbSchedNext tcb = None) t\" + unfolding tcbReleaseRemove_def + apply (wpsimp wp: tcbQueueRemove_not_sched_linked inReleaseQueue_wp) + apply (fastforce dest: valid_sched_pointersD simp: opt_pred_def obj_at'_def opt_map_def) + done + +crunch setThreadState + for obj_at'_tcbSchedPrev_tcbSchedNext[wp]: + "\s. obj_at' (\tcb. P (tcbSchedPrev tcb) (tcbSchedNext tcb)) tcbPtr s" + +crunch tcbSchedDequeue, updateRestartPC + for tcbStates_of'[wp]: "\s. P (tcbStates_of' s)" + (wp: crunch_wps threadSet_field_inv) + +lemma suspend_tcbSchedPrev_tcbSchedNext_None: + "\invs'\ suspend t \\_ s. obj_at' (\tcb. tcbSchedPrev tcb = None \ tcbSchedNext tcb = None) t s\" + unfolding suspend_def + apply (wpsimp wp: tcbReleaseRemove_tcbSchedPrev_tcbSchedNext_None) + apply (rule_tac Q'="\_. invs' and st_tcb_at' simple' t" in hoare_post_imp) + apply (fastforce simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_def + split: thread_state.splits) + apply wpsimp+ done crunch schedContextCompleteYieldTo @@ -3237,18 +3049,6 @@ crunch unbindNotification, unbindMaybeNotification for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" (wp: weak_sch_act_wf_lift) -lemma unbindNotification_tcb_at'[wp]: - "\tcb_at' t'\ unbindNotification t \\rv. tcb_at' t'\" - apply (simp add: unbindNotification_def) - apply (wp gbn_wp' | wpc | simp)+ - done - -lemma unbindMaybeNotification_tcb_at'[wp]: - "\tcb_at' t'\ unbindMaybeNotification t \\rv. tcb_at' t'\" - apply (simp add: unbindMaybeNotification_def) - apply (wp gbn_wp' | wpc | simp)+ - done - crunch prepareThreadDelete for cte_wp_at'[wp]: "cte_wp_at' P p" crunch prepareThreadDelete @@ -3268,25 +3068,11 @@ lemma ntfnSc_sym_refsD: apply (auto simp: state_refs_of'_def ko_wp_at'_def obj_at'_def refs_of_rev') done -lemma scNtfn_sym_refsD: - "\obj_at' (\sc. scNtfn sc = Some ntfnPtr) scPtr s; - valid_objs' s; sym_refs (state_refs_of' s)\ - \ obj_at' (\ntfn. ntfnSc ntfn = Some scPtr) ntfnPtr s" - apply (frule obj_at_valid_objs', assumption) - apply (clarsimp simp: valid_obj'_def valid_sched_context'_def) - apply (frule_tac p=ntfnPtr in obj_at_valid_objs', assumption) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) - apply (frule_tac p=scPtr in sym_refs_obj_atD', assumption) - apply (frule_tac p=ntfnPtr in sym_refs_obj_atD', assumption) - apply (clarsimp simp: ko_wp_at'_def obj_at'_def get_refs_def2 ntfn_q_refs_of'_def - split: Structures_H.ntfn.splits) - done - lemma schedContextUnbindNtfn_obj_at'_ntfnSc: "\obj_at' (\ntfn. ntfnSc ntfn = Some scPtr) ntfnPtr\ schedContextUnbindNtfn scPtr \\_ s. obj_at' (\ntfn. ntfnSc ntfn = None) ntfnPtr s\" - unfolding schedContextUnbindNtfn_def updateSchedContext_def + unfolding schedContextUnbindNtfn_def updateSchedContext_def updateNotification_def apply (wpsimp wp: stateAssert_wp set_ntfn'.obj_at'_strongest getNotification_wp hoare_vcg_all_lift hoare_vcg_imp_lift') apply (drule ntfnSc_sym_refsD; assumption?) @@ -3403,9 +3189,6 @@ crunch setConsumed for ksQ[wp]: "\s. P (ksReadyQueues s p)" (simp: crunch_simps wp: crunch_wps) -crunch schedContextUnbindTCB - for valid_sched_pointers[wp]: valid_sched_pointers - lemma valid_tcbs'_ksMachineState_update[simp]: "valid_tcbs' (ksMachineState_update f s) = valid_tcbs' s" by (auto simp: valid_tcbs'_def) @@ -3491,7 +3274,7 @@ lemma schedContextUnbindReply_obj_at'_reply_None: lemma schedContextUnbindNtfn_obj_at'_not_ntfn: "(\ko f. P (scNtfn_update f ko) = P ko) \ schedContextUnbindNtfn scPtr \obj_at' P p\" - unfolding schedContextUnbindNtfn_def updateSchedContext_def + unfolding schedContextUnbindNtfn_def updateSchedContext_def updateNotification_def apply (wpsimp wp: set_sc'.obj_at'_strongest set_ntfn'.set_wp getNotification_wp) by (auto simp: obj_at'_def) @@ -3517,23 +3300,15 @@ lemmas schedContextSetInactive_removeable' [where p=scPtr and scPtr=scPtr for scPtr]] crunch schedContextMaybeUnbindNtfn - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - and valid_tcbs'[wp]: valid_tcbs' + for valid_tcbs'[wp]: valid_tcbs' global_interpretation schedContextUnbindTCB: typ_at_all_props' "schedContextUnbindTCB scPtr" by typ_at_props' lemma unbindFromSC_invs'[wp]: "unbindFromSC t \invs'\" - apply (clarsimp simp: unbindFromSC_def) - apply (wpsimp split_del: if_split) - apply (rule_tac Q'="\_. sc_at' y and invs'" in hoare_post_imp) - apply (fastforce simp: valid_obj'_def valid_sched_context'_def - dest!: ko_at_valid_objs') - apply (wpsimp wp: threadGet_wp)+ - apply (drule obj_at_ko_at', clarsimp) - apply (frule ko_at_valid_objs'; clarsimp simp: valid_obj'_def valid_tcb'_def) - done + unfolding unbindFromSC_def + by (wpsimp wp: hoare_drop_imps) lemma (in delete_one_conc_pre) finaliseCap_replaceable: "\\s. invs' s \ cte_wp_at' (\cte. cteCap cte = cap) slot s @@ -3556,7 +3331,7 @@ lemma (in delete_one_conc_pre) finaliseCap_replaceable: \ bound_tcb_at' ((=) None) p s \ bound_sc_tcb_at' ((=) None) p s \ bound_yt_tcb_at' ((=) None) p s - \ obj_at' (\tcb. tcbSchedNext tcb = None \ tcbSchedPrev tcb = None) p s))\" + \ obj_at' (\tcb. tcbSchedPrev tcb = None \ tcbSchedNext tcb = None) p s))\" apply (simp add: finaliseCap_def Let_def getThreadCSpaceRoot cong: if_cong split del: if_split) apply (rule hoare_pre) @@ -3565,27 +3340,26 @@ lemma (in delete_one_conc_pre) finaliseCap_replaceable: unbindMaybeNotification_obj_at'_ntfnBound unbindMaybeNotification_obj_at'_no_change simp: isZombie_Null) - apply (strengthen invs_valid_objs') - apply (wpsimp wp: schedContextMaybeUnbindNtfn_obj_at'_ntfnSc - prepares_delete_helper'' [OF replyClear_makes_unlive] - hoare_vcg_if_lift_strong simp: isZombie_Null)+ - apply (clarsimp simp: obj_at'_def) - apply (wpsimp wp: schedContextSetInactive_removeable' - prepareThreadDelete_unqueued - prepareThreadDelete_inactive - suspend_makes_inactive - suspend_flag_not_set - suspend_tcbSchedNext_tcbSchedPrev_None - suspend_bound_yt_tcb_at'_None - unbindNotification_bound_tcb_at' - unbindFromSC_bound_sc_tcb_at'_None - schedContextUnbindYieldFrom_makes_unlive - schedContextUnbindReply_obj_at'_reply_None - schedContextUnbindReply_obj_at'_not_reply - schedContextUnbindNtfn_obj_at'_ntfn_None - schedContextUnbindNtfn_obj_at'_not_ntfn - schedContextUnbindAllTCBs_obj_at'_tcb_None - simp: isZombie_Null isThreadCap_threadCapRefs_tcbptr)+ + apply (wpsimp wp: schedContextMaybeUnbindNtfn_obj_at'_ntfnSc + prepares_delete_helper'' [OF replyClear_makes_unlive] + hoare_vcg_if_lift_strong simp: isZombie_Null)+ + apply (clarsimp simp: obj_at'_def) + apply (wpsimp wp: schedContextSetInactive_removeable' + prepareThreadDelete_unqueued + prepareThreadDelete_inactive + suspend_makes_inactive + suspend_flag_not_set + suspend_tcbSchedPrev_tcbSchedNext_None + suspend_bound_yt_tcb_at'_None + unbindNotification_bound_tcb_at' + unbindFromSC_bound_sc_tcb_at'_None + schedContextUnbindYieldFrom_makes_unlive + schedContextUnbindReply_obj_at'_reply_None + schedContextUnbindReply_obj_at'_not_reply + schedContextUnbindNtfn_obj_at'_ntfn_None + schedContextUnbindNtfn_obj_at'_not_ntfn + schedContextUnbindAllTCBs_obj_at'_tcb_None + simp: isZombie_Null isThreadCap_threadCapRefs_tcbptr)+ apply (rule hoare_strengthen_post [OF arch_finaliseCap_removeable[where slot=slot]], clarsimp simp: gen_isCap_simps) apply (wpsimp wp: deletingIRQHandler_removeable' @@ -3596,13 +3370,6 @@ lemma (in delete_one_conc_pre) finaliseCap_replaceable: final_matters'_def gen_objBits_simps not_Final_removeable finaliseCap_def, simp_all add: removeable'_def) - (* ThreadCap *) - apply (frule capAligned_capUntypedPtr [OF valid_capAligned], simp) - apply (clarsimp simp: valid_cap'_def) - apply (drule valid_globals_cte_wpD'_idleThread[rotated], clarsimp) - apply (fastforce simp: invs'_def valid_pspace'_def valid_idle'_asrt_def valid_idle'_def) - (* EndpointCap *) - apply (fastforce simp: sch_act_wf_asrt_def valid_cap'_def) (* ArchObjectCap *) apply (fastforce simp: obj_at'_def sch_act_wf_asrt_def) (* ReplyCap *) @@ -3794,23 +3561,6 @@ crunch isFinalCapability context begin interpretation Arch . -lemma setQueue_after_removeFromBitmap: - "(setQueue d p q >>= (\rv. (when P (removeFromBitmap d p)) >>= (\rv. threadSet f t))) = - (when P (removeFromBitmap d p) >>= (\rv. (threadSet f t) >>= (\rv. setQueue d p q)))" - supply bind_assoc[simp add] - apply (case_tac P, simp_all) - prefer 2 - apply (simp add: setQueue_after) - apply (simp add: setQueue_def when_def) - apply (subst oblivious_modify_swap) - apply (fastforce simp: threadSet_def getObject_def setObject_def readObject_def - loadObject_default_def bitmap_fun_defs gets_the_def obind_def - split_def projectKO_def alignCheck_assert read_magnitudeCheck_assert - magnitudeCheck_assert updateObject_default_def omonad_defs - intro: oblivious_bind split: option.splits) - apply clarsimp - done - crunch isFinalCapability for valid_objs'[wp]: valid_objs' (wp: crunch_wps simp: crunch_simps) @@ -3888,46 +3638,36 @@ lemma schedContextSetInactive_invs'[wp]: lemma schedContextUnbindYieldFrom_invs'[wp]: "schedContextUnbindYieldFrom scPtr \invs'\" unfolding schedContextUnbindYieldFrom_def updateSchedContext_def - apply wpsimp - by (fastforce dest: invs'_ko_at_valid_sched_context' simp: valid_sched_context'_def) + by wpsimp lemma schedContextUnbindReply_invs'[wp]: "schedContextUnbindReply scPtr \invs'\" unfolding schedContextUnbindReply_def updateSchedContext_def apply (wpsimp wp: setSchedContext_invs' updateReply_replyNext_None_invs' hoare_vcg_all_lift hoare_vcg_imp_lift) - apply (clarsimp simp: invs'_def valid_pspace'_def sym_refs_asrt_def) + apply (clarsimp simp: invs'_def valid_pspace'_def) apply (frule (1) ko_at_valid_objs', clarsimp) apply (frule (3) sym_refs_scReplies) apply normalise_obj_at' apply (frule (1) sc_ko_at_valid_objs_valid_sc') apply (intro conjI) - apply (fastforce simp: obj_at'_def opt_map_def sym_heap_def split: option.splits) - apply (fastforce elim: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def live'_def live_sc'_def) + apply (fastforce simp: obj_at'_def opt_map_def sym_heap_def split: option.splits) apply (auto simp: valid_obj'_def valid_sched_context'_def valid_sched_context_size'_def gen_objBits_simps refillSize_def) done lemma schedContextUnbindAllTCBs_invs'[wp]: - "\invs' and K (scPtr \ idle_sc_ptr)\ - schedContextUnbindAllTCBs scPtr - \\rv. invs'\" + "schedContextUnbindAllTCBs scPtr \invs'\" apply (clarsimp simp: schedContextUnbindAllTCBs_def) by wpsimp lemma finaliseCap_invs: - "\invs' and valid_cap' cap and cte_wp_at' (\cte. cteCap cte = cap) sl\ + "\invs' and valid_cap' cap\ finaliseCap cap fin flag \\_. invs'\" - apply (simp add: finaliseCap_def Let_def - cong: if_cong split del: if_split) + apply (simp add: finaliseCap_def Let_def split del: if_split) apply (wpsimp wp: hoare_vcg_all_lift) apply (case_tac cap; clarsimp simp: gen_isCap_simps) - apply (frule valid_capAligned, drule capAligned_capUntypedPtr) - apply clarsimp - apply (frule invs_valid_global', drule(1) valid_globals_cte_wpD'_idleSC) - apply clarsimp done lemma finaliseCap_zombie_cap[wp]: @@ -4076,154 +3816,206 @@ lemma arch_finaliseCap_corres: apply (simp add: invs_no_0_obj') done +lemma setNotification_no_queue_update_corres: + "\ntfn_ptr = ntfnPtr; ntfn_relation ntfn ntfn'\ \ + corres dc + (obj_at (\ko. \n. ko = kernel_object.Notification n + \ ntfn_queue_of n = ntfn_queue_of ntfn) ntfn_ptr + and pspace_aligned and pspace_distinct) + (obj_at' (\notification. ntfnQueue notification = ntfnQueue ntfn') ntfnPtr) + (set_notification ntfn_ptr ntfn) (setNotification ntfnPtr ntfn')" + (is "\_; _\ \ corres _ ?abs ?conc _ _") + supply heap_ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + apply (rule_tac Q="ntfn_at ntfn_ptr" in corres_cross_add_abs_guard) + apply (clarsimp simp: obj_at_def is_ntfn_def) + apply (rule_tac Q'="ntfn_at' ntfnPtr" in corres_cross_add_guard, fastforce) + apply (rule corres_underlying_from_rcorres) + apply wpsimp + apply (clarsimp simp: objBits_simps) + apply (simp only: state_relation_def ghost_relation_heap_ghost_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation heap_pspace_relation_def) + apply (rcorres_conj_lift \fastforce\)+ + apply (rule rcorres_conj_lift_fwd) + apply wpsimp + apply (rule rcorres_from_valid_det) + apply wpsimp + apply (wpsimp wp: set_ntfn'.set_wp) + apply (frule in_set_notification) + apply (fold fun_upd_def) + apply (clarsimp simp: map_relation_def dom_insert_absorb projectKO_opts_defs) + apply (rcorres_conj_lift \fastforce\)+ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ntfn_relation\ + apply (rule rcorres_weaken_pre) + apply (rule_tac Q="\s s'. ?abs s \ ?conc s'" in ntfn_queues_relation_lift_rcorres; + (solves wpsimp)?) + apply wpsimp + apply (clarsimp simp: obj_at_def is_ntfn_def) + apply (wpsimp wp: set_simple_ko_wp) + apply (rename_tac P s s', erule_tac P=P in rsubst) + apply (fastforce simp: opt_map_def obj_at_def) + apply (wpsimp wp: set_ntfn'.set_wp) + apply (rename_tac P s s', erule_tac P=P in rsubst) + apply (fastforce simp: opt_map_def obj_at'_def projectKO_opts_defs split: option.splits) + apply fastforce + by (rcorres_conj_lift \fastforce\)+ + lemma unbindNotification_corres: "corres dc - (invs and tcb_at t) - invs' - (unbind_notification t) - (unbindNotification t)" + (invs and tcb_at t) invs' + (unbind_notification t) (unbindNotification t)" supply option.case_cong_weak[cong] - apply add_sym_refs apply (simp add: unbind_notification_def unbindNotification_def) - apply (rule corres_stateAssert_ignore, simp) apply (rule corres_cross[where Q' = "tcb_at' t", OF tcb_at'_cross_rel]) apply (simp add: invs_psp_aligned invs_distinct) - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF getBoundNotification_corres]) apply (simp add: maybeM_def) apply (rule corres_option_split) apply simp apply (rule corres_return_trivial) - apply (simp add: update_sk_obj_ref_def bind_assoc) + apply (simp add: update_sk_obj_ref_def bind_assoc updateNotification_def) apply (rule corres_split[OF getNotification_corres]) - apply (rule corres_split[OF setNotification_corres]) + apply (rule corres_split[OF setNotification_no_queue_update_corres], simp) apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) apply (rule setBoundNotification_corres) - apply (wpsimp wp: gbn_wp' gbn_wp get_ntfn_ko' simp: obj_at_def split: option.split)+ + apply (wpsimp wp: gbn_wp' gbn_wp get_simple_ko_wp getNotification_wp + simp: obj_at_def + split: option.split)+ apply (frule invs_valid_objs) apply (clarsimp simp: is_tcb) apply (frule_tac thread=t and y=tcb in valid_tcb_objs) apply (simp add: get_tcb_rev) - apply (clarsimp simp: valid_tcb_def cteSizeBits_def invs_def valid_state_def valid_pspace_def) - apply (metis obj_at_simps(1) valid_bound_obj_Some) - apply (clarsimp dest!: obj_at_valid_objs' invs_valid_objs' - simp: valid_obj'_def valid_tcb'_def valid_bound_ntfn'_def pred_tcb_at'_def - split: option.splits) + apply (fastforce simp: valid_tcb_def valid_state_def obj_at_def) + apply (fastforce simp: obj_at'_def split: option.splits) done lemma unbindMaybeNotification_corres: "corres dc - (invs and ntfn_at ntfnptr) - invs' - (unbind_maybe_notification ntfnptr) - (unbindMaybeNotification ntfnptr)" - apply add_sym_refs - apply (simp add: unbind_maybe_notification_def unbindMaybeNotification_def) - apply (rule corres_stateAssert_ignore, simp) - apply (rule corres_cross[where Q' = "ntfn_at' ntfnptr", OF ntfn_at'_cross_rel]) - apply (simp add: invs_psp_aligned invs_distinct) - apply (rule corres_guard_imp) - apply (clarsimp simp: maybeM_def get_sk_obj_ref_def) - apply (rule corres_split[OF getNotification_corres]) - apply (rename_tac ntfnA ntfnH) - apply (rule corres_option_split) - apply (simp add: ntfn_relation_def) - apply (rule corres_return_trivial) - apply (rename_tac tcbPtr) - apply (simp add: bind_assoc) - apply (rule corres_split) - apply (simp add: update_sk_obj_ref_def) - apply (rule_tac P="ko_at (Notification ntfnA) ntfnptr" in corres_symb_exec_l) - apply (rename_tac ntfnA') - apply (rule_tac F="ntfnA = ntfnA'" in corres_gen_asm) - apply (rule setNotification_corres) - apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) - apply (wpsimp simp: obj_at_def is_ntfn wp: get_simple_ko_wp)+ - apply (rule setBoundNotification_corres) - apply (wpsimp simp: obj_at_def wp: get_simple_ko_wp getNotification_wp)+ - apply (frule invs_valid_objs) - apply (erule (1) pspace_valid_objsE) - apply (fastforce simp: valid_obj_def valid_ntfn_def obj_at_def split: option.splits) + (invs and ntfn_at ntfnptr) invs' + (unbind_maybe_notification ntfnptr) (unbindMaybeNotification ntfnptr)" + supply if_split[split del] + apply (simp add: unbind_maybe_notification_def unbindMaybeNotification_def + maybeM_def get_sk_obj_ref_def) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ntfn_sp']) + apply (corres corres: getNotification_corres) + apply fastforce + apply fastforce + apply (rename_tac ntfn ntfn') + apply (simp add: case_option_If2) + apply (rule corres_if_strong') + apply (simp add: ntfn_relation_def) + apply clarsimp + apply (rename_tac bound_tcb boundTCB) + apply (rule_tac F="boundTCB = bound_tcb" in corres_req) + apply (simp add: ntfn_relation_def) + apply (clarsimp simp: update_sk_obj_ref_def bind_assoc) + apply (rule corres_symb_exec_l[OF _ _ get_simple_ko_sp, rotated]; (solves wpsimp)?) + apply wpsimp + apply (clarsimp simp: obj_at_def) + apply simp + apply (rename_tac new_ntfn) + apply (rule_tac F="new_ntfn = ntfn" in corres_req) + apply (fastforce dest: ko_at_obj_congD) + apply (clarsimp simp: updateNotification_def bind_assoc) + apply (rule corres_symb_exec_r[OF _ get_ntfn_sp']; (solves wpsimp)?) + apply (rename_tac new_ntfn) + apply (rule_tac F="new_ntfn = ntfn'" in corres_req) + apply normalise_obj_at' + apply clarsimp + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF setNotification_no_queue_update_corres], simp) + apply (simp add: ntfn_relation_def split: ntfn.splits) + apply (rule setBoundNotification_corres) + apply (wpsimp simp: obj_at_def wp: get_simple_ko_wp getNotification_wp)+ + apply (frule invs_valid_objs) + apply (erule (1) pspace_valid_objsE) + apply (fastforce simp: valid_obj_def valid_ntfn_def obj_at_def) + apply (fastforce dest: ntfn_ko_at_valid_objs_valid_ntfn' simp: obj_at'_def) apply clarsimp - apply (frule invs_valid_objs') - apply (frule (1) ko_at_valid_objs'_pre) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split: option.splits) done lemma schedContextUnbindNtfn_corres: "corres dc - (invs and sc_at sc) - invs' - (sched_context_unbind_ntfn sc) - (schedContextUnbindNtfn sc)" + (invs and sc_at sc) invs' + (sched_context_unbind_ntfn sc) (schedContextUnbindNtfn sc)" apply (simp add: sched_context_unbind_ntfn_def schedContextUnbindNtfn_def) apply (clarsimp simp: maybeM_def get_sk_obj_ref_def liftM_def) apply (rule corres_cross[where Q' = "sc_at' sc", OF sc_at'_cross_rel]) apply (simp add: invs_psp_aligned invs_distinct) apply add_sym_refs - apply (rule corres_stateAssert_implied[where P'=\, simplified, rotated], simp) + apply (rule corres_stateAssert_ignore, simp) apply (simp add: get_sc_obj_ref_def) - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF get_sc_corres]) apply (rule corres_option_split) apply (simp add: sc_relation_def) apply (rule corres_return_trivial) - apply (simp add: update_sk_obj_ref_def bind_assoc) + apply (simp add: update_sk_obj_ref_def updateNotification_def bind_assoc) apply (rule corres_split[OF getNotification_corres]) - apply (rule corres_split[OF setNotification_corres]) + apply (rule corres_split[OF setNotification_no_queue_update_corres]) + apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) apply (rule updateSchedContext_no_stack_update_corres) apply (clarsimp simp: sc_relation_def objBits_def objBitsKO_def refillSize_def)+ - apply wpsimp+ - apply (frule invs_valid_objs) - apply (frule (1) valid_objs_ko_at) - apply (clarsimp simp: invs_psp_aligned valid_obj_def valid_sched_context_def - split: option.splits) - apply (fastforce dest: scNtfn_sym_refsD[OF ko_at_obj_at', simplified] split: option.splits) + apply (wpsimp wp: get_simple_ko_wp getNotification_wp)+ + apply (fastforce dest: invs_valid_objs + simp: valid_obj_def valid_sched_context_def obj_at_def + split: option.splits) + apply (fastforce simp: obj_at'_def split: option.splits) done -lemma sched_context_maybe_unbind_ntfn_corres: +lemma schedContextMaybeUnbindNtfn_corres: "corres dc - (invs and ntfn_at ntfn_ptr) - invs' + (invs and ntfn_at ntfn_ptr) invs' (sched_context_maybe_unbind_ntfn ntfn_ptr) (schedContextMaybeUnbindNtfn ntfn_ptr)" - apply (clarsimp simp: sched_context_maybe_unbind_ntfn_def schedContextMaybeUnbindNtfn_def) - apply (clarsimp simp: maybeM_def get_sk_obj_ref_def liftM_def) - apply (rule corres_cross[where Q' = "ntfn_at' ntfn_ptr", OF ntfn_at'_cross_rel]) - apply (simp add: invs_psp_aligned invs_distinct) + supply if_split[split del] + apply (clarsimp simp: sched_context_maybe_unbind_ntfn_def schedContextMaybeUnbindNtfn_def + maybeM_def get_sk_obj_ref_def liftM_def) + apply (rule corres_cross[where Q' = "ntfn_at' ntfn_ptr", OF ntfn_at'_cross_rel], fastforce) apply add_sym_refs - apply (rule corres_guard_imp) - apply (rule corres_split[OF getNotification_corres]) - apply (rename_tac ntfnA ntfnH) - apply (rule corres_option_split) - apply (simp add: ntfn_relation_def) - apply (rule corres_return_trivial) - apply (rename_tac scAPtr) - apply (clarsimp simp: schedContextUnbindNtfn_def update_sk_obj_ref_def bind_assoc) - apply (rule corres_stateAssert_implied[where P'=\, simplified]) - apply (rule_tac P="invs and ko_at (Notification ntfnA) ntfn_ptr" - and P'="invs' and ko_at' ntfnH ntfn_ptr and (\s. sym_refs (state_refs_of' s))" - and Q'1=\ - in corres_symb_exec_r'[THEN corres_guard_imp]) - apply (rule_tac F="scNtfn rv = Some ntfn_ptr" in corres_gen_asm2) - apply clarsimp - apply (rule corres_split[OF getNotification_corres]) - apply (rule corres_split[OF setNotification_corres]) - apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) - apply (rule updateSchedContext_no_stack_update_corres) - apply (clarsimp simp: sc_relation_def objBits_def objBitsKO_def refillSize_def)+ - apply wpsimp+ - apply (frule invs_valid_objs) - apply (frule (1) valid_objs_ko_at) - apply (clarsimp simp: invs_psp_aligned valid_obj_def valid_ntfn_def obj_at_def is_ntfn_def) - apply (clarsimp simp: valid_ntfn'_def ntfn_relation_def split: option.splits) - apply (drule_tac s="Some scAPtr" in sym) - apply (clarsimp simp: valid_ntfn'_def ntfn_relation_def sym_refs_asrt_def) - apply (frule (1) ntfnSc_sym_refsD[OF ko_at_obj_at', simplified]) - apply clarsimp+ - apply normalise_obj_at' - apply (wpsimp wp: get_simple_ko_wp getNotification_wp split: option.splits)+ + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ntfn_sp']) + apply (corres corres: getNotification_corres; fastforce) + apply (rename_tac ntfn ntfn') + apply (simp add: case_option_If2) + apply (rule corres_if_strong') + apply (simp add: ntfn_relation_def) + apply (clarsimp simp: schedContextUnbindNtfn_def update_sk_obj_ref_def bind_assoc) + apply (rename_tac sc_ptr scPtr) + apply (rule_tac F="scPtr = sc_ptr" in corres_req) + apply (clarsimp simp: ntfn_relation_def) + apply clarsimp + apply (rule_tac Q="sc_at sc_ptr" in corres_cross_add_abs_guard) + apply (fastforce dest: valid_objs_ko_at[OF invs_valid_objs] simp: valid_obj_def valid_ntfn_def) + apply (rule corres_symb_exec_l[OF _ _ get_simple_ko_sp]; (solves wpsimp)?) + apply (find_goal \match conclusion in "\_\ _ \\_\" \ -\) + apply wpsimp + apply (clarsimp simp: obj_at_def is_ntfn_def) + apply fastforce + apply (rename_tac new_ntfn) + apply (rule_tac F="new_ntfn = ntfn" in corres_req) + apply (clarsimp simp: obj_at_def) + apply (rule corres_stateAssert_implied[where P'=\, simplified, rotated], simp) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ get_sc_sp']; (solves wpsimp)?) + apply (rule_tac F="scNtfn sc = Some ntfn_ptr" in corres_req) + apply (fastforce dest: ntfnSc_sym_refsD[OF ko_at_obj_at', simplified] simp: obj_at'_def) + apply (clarsimp simp: updateNotification_def bind_assoc) + apply (rule corres_symb_exec_r[OF _ get_ntfn_sp']; (solves wpsimp)?) + apply (rename_tac new_ntfn') + apply (rule_tac F="new_ntfn' = ntfn'" in corres_req) + apply normalise_obj_at' + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF setNotification_no_queue_update_corres], simp) + apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) + apply (rule updateSchedContext_no_stack_update_corres) + apply (clarsimp simp: sc_relation_def objBits_def objBitsKO_def refillSize_def)+ + apply (wpsimp | wpsimp wp: set_simple_ko_wp)+ + apply (fastforce simp: obj_at_def is_sc_obj_def) + apply (clarsimp simp: obj_at'_def) + apply wpsimp + apply (fastforce intro: sc_at_cross simp: ex_abs_def) + apply clarsimp done lemma replyClear_corres: @@ -4289,7 +4081,7 @@ lemma fast_finaliseCap_corres: apply clarsimp apply (rule corres_stateAssert_assume; (simp add: sch_act_wf_asrt_def)?) apply (rule corres_guard_imp) - apply (rule corres_split[OF sched_context_maybe_unbind_ntfn_corres]) + apply (rule corres_split[OF schedContextMaybeUnbindNtfn_corres]) apply (rule corres_split[OF unbindMaybeNotification_corres]) apply (rule cancelAllSignals_corres) apply (wpsimp wp: unbind_maybe_notification_invs abs_typ_at_lifts typ_at_lifts)+ @@ -4370,104 +4162,109 @@ lemma schedContextUnbindTCB_corres: "corres dc (invs and valid_sched and sc_tcb_sc_at bound sc_ptr) (invs' and obj_at' (\sc. bound (scTCB sc)) sc_ptr) (sched_context_unbind_tcb sc_ptr) (schedContextUnbindTCB sc_ptr)" - apply (clarsimp simp: sched_context_unbind_tcb_def schedContextUnbindTCB_def) + apply (clarsimp simp: sched_context_unbind_tcb_def schedContextUnbindTCB_def + sym_refs_asrt_def valid_idle'_asrt_def cur_tcb'_asrt_def) apply add_sym_refs apply add_valid_idle' apply add_cur_tcb' - apply (rule corres_stateAssert_ignore, solves simp)+ - apply (rule corres_stateAssert_ignore) - apply (fastforce intro: weak_sch_act_wf_cross) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_sc_corres]) - apply (rename_tac sc sc') - apply (rule corres_assert_opt_assume_l) - apply (rule corres_assert_assume_r) - apply (prop_tac "scTCB sc' = sc_tcb sc"; clarsimp) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split[OF corres_when], clarsimp simp: sc_relation_def) - apply (rule rescheduleRequired_corres) - apply (rule corres_split[OF tcbSchedDequeue_corres], simp) - apply (rule corres_split[OF tcbReleaseRemove_corres]) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_split[OF set_tcb_obj_ref_corres]; - clarsimp simp: tcb_relation_def inQ_def) - apply (rule updateSchedContext_no_stack_update_corres) - apply (clarsimp simp: sc_relation_def objBits_def objBitsKO_def refillSize_def)+ - apply wpsimp+ - apply (case_tac sc'; clarsimp) - apply (wpfix add: sched_context.sel) - apply wpsimp+ - apply (frule invs_valid_objs) - apply (frule valid_sched_valid_release_q) - apply (fastforce dest: valid_sched_valid_ready_qs - simp: sc_at_pred_n_def obj_at_def is_obj_defs valid_obj_def - valid_sched_context_def) - apply normalise_obj_at' - apply (fastforce simp: valid_obj'_def valid_sched_context'_def - dest!: ko_at_valid_objs') + apply (rule corres_stateAssert_implied[where P'=\, simplified]) + apply (rule corres_stateAssert_add_assertion[rotated], simp)+ + apply (fastforce intro: weak_sch_act_wf_cross) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF get_sc_corres]) + apply (rename_tac sc sc') + apply (rule corres_assert_opt_assume_l) + apply (rule corres_assert_assume_r) + apply (rule corres_stateAssert_r) + apply (prop_tac "scTCB sc' = sc_tcb sc"; clarsimp) + apply (clarsimp simp: sc_relation_def) + apply (rule corres_split[OF getCurThread_corres]) + apply (rule corres_split[OF corres_when], clarsimp simp: sc_relation_def) + apply (rule rescheduleRequired_corres) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF tcbReleaseRemove_corres]) + apply (clarsimp simp: sc_relation_def) + apply (rule corres_split[OF set_tcb_obj_ref_corres]; + clarsimp simp: tcb_relation_def inQ_def) + apply (rule updateSchedContext_no_stack_update_corres) + apply (clarsimp simp: sc_relation_def objBits_def objBitsKO_def refillSize_def)+ + apply (wpsimp wp: release_q_runnable_lift)+ + apply (case_tac sc'; clarsimp) + apply (wpfix add: sched_context.sel) + apply wpsimp+ + apply (frule invs_valid_objs) + apply (frule invs_sym_refs) + apply (frule valid_sched_valid_release_q) + apply (fastforce dest: valid_sched_valid_ready_qs + simp: sc_at_pred_n_def obj_at_def is_obj_defs valid_obj_def + valid_sched_context_def) + apply normalise_obj_at' + apply (fastforce simp: valid_obj'_def valid_sched_context'_def + dest!: ko_at_valid_objs') + apply clarsimp done lemma unbindFromSC_corres: - "corres dc (einvs and tcb_at t and K (t \ idle_thread_ptr)) (invs' and tcb_at' t) - (unbind_from_sc t) (unbindFromSC t)" + "corres dc + (einvs and tcb_at t and K (t \ idle_thread_ptr)) (invs' and tcb_at' t) + (unbind_from_sc t) (unbindFromSC t)" apply (clarsimp simp: unbind_from_sc_def unbindFromSC_def maybeM_when) apply (rule corres_gen_asm) apply add_sym_refs - apply (rule corres_stateAssert_implied[where P'=\, simplified]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_tcb_obj_ref_corres[where r="(=)"]]) - apply (clarsimp simp: tcb_relation_def) - apply (rename_tac sc_ptr_opt sc_ptr_opt') - apply clarsimp - apply (rule_tac R="bound sc_ptr_opt'" in corres_cases'; clarsimp) - apply wpfix - apply (rule corres_split[OF schedContextUnbindTCB_corres]) - apply (rule corres_split[OF get_sc_corres]) - apply (rule corres_when2; clarsimp simp: sc_relation_def) - apply (case_tac rv, case_tac rv', simp) - apply (wpfix add: Structures_A.sched_context.select_convs sched_context.sel) - apply (rule schedContextCompleteYieldTo_corres) - apply (wpsimp wp: abs_typ_at_lifts)+ - apply (rule_tac Q'="\_. invs" in hoare_post_imp) - apply (auto simp: valid_obj_def valid_sched_context_def - dest!: invs_valid_objs valid_objs_ko_at)[1] - apply wpsimp - apply (rule_tac Q'="\_. sc_at' y and invs'" in hoare_post_imp) - apply (fastforce simp: valid_obj'_def valid_sched_context'_def - dest!: ko_at_valid_objs') - apply (wpsimp wp: get_tcb_obj_ref_wp threadGet_wp)+ - apply (frule invs_psp_aligned, frule invs_distinct) - apply clarsimp - apply (frule invs_valid_objs, frule invs_sym_refs, frule invs_valid_global_refs) - apply (frule sym_ref_tcb_sc; (fastforce simp: obj_at_def is_tcb_def)?) - apply (frule (1) valid_objs_ko_at) - apply (subgoal_tac "ex_nonz_cap_to y s") - apply (fastforce dest!: idle_sc_no_ex_cap - simp: obj_at_def sc_at_pred_n_def valid_obj_def valid_tcb_def) - apply (fastforce elim!: if_live_then_nonz_cap_invs simp: live_def live_sc_def) + apply (rule corres_stateAssert_ignore, simp) + apply (rule corres_guard_imp) + apply (rule corres_split[OF get_tcb_obj_ref_corres[where r="(=)"]]) + apply (clarsimp simp: tcb_relation_def) + apply (rename_tac sc_ptr_opt sc_ptr_opt') + apply clarsimp + apply (rule_tac R="bound sc_ptr_opt'" in corres_cases'; clarsimp) + apply wpfix + apply (rule corres_split[OF schedContextUnbindTCB_corres]) + apply (rule corres_split[OF get_sc_corres]) + apply (rule corres_when2; clarsimp simp: sc_relation_def) + apply (case_tac rv, case_tac rv', simp) + apply (wpfix add: Structures_A.sched_context.select_convs sched_context.sel) + apply (rule schedContextCompleteYieldTo_corres) + apply (wpsimp wp: abs_typ_at_lifts)+ + apply (rule_tac Q'="\_. invs" in hoare_post_imp) + apply (frule invs_valid_objs) + apply (frule invs_psp_aligned) + apply (frule invs_distinct) + apply (force simp: valid_obj_def valid_sched_context_def + dest!: valid_objs_ko_at) + apply wpsimp + apply (rule_tac Q'="\_. sc_at' y and invs'" in hoare_post_imp) + apply (fastforce simp: valid_obj'_def valid_sched_context'_def + dest!: ko_at_valid_objs') + apply (wpsimp wp: get_tcb_obj_ref_wp threadGet_wp)+ + apply (frule invs_psp_aligned, frule invs_distinct) apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (frule sym_refs_tcbSchedContext; assumption?) - apply (subgoal_tac "ex_nonz_cap_to' y s") - apply (fastforce simp: invs'_def obj_at'_def global'_sc_no_ex_cap) - apply (fastforce intro!: if_live_then_nonz_capE' - simp: obj_at'_def ko_wp_at'_def live'_def live_sc'_def) - apply (clarsimp simp: sym_refs_asrt_def) + apply (frule invs_valid_objs, frule invs_sym_refs, frule invs_valid_global_refs) + apply (frule sym_ref_tcb_sc; (fastforce simp: obj_at_def is_tcb_def)?) + apply (frule (1) valid_objs_ko_at) + apply (subgoal_tac "ex_nonz_cap_to y s") + apply (fastforce dest!: idle_sc_no_ex_cap + simp: obj_at_def sc_at_pred_n_def valid_obj_def valid_tcb_def) + apply (fastforce elim!: if_live_then_nonz_cap_invs simp: live_def live_sc_def) + apply clarsimp + apply (drule obj_at_ko_at', clarsimp) + apply (frule sym_refs_tcbSchedContext; assumption?) + apply (fastforce simp: invs'_def obj_at'_def global'_sc_no_ex_cap) done lemma schedContextUnbindAllTCBs_corres: - "corres dc (einvs and sc_at scPtr and K (scPtr \ idle_sc_ptr)) (invs' and sc_at' scPtr) - (sched_context_unbind_all_tcbs scPtr) (schedContextUnbindAllTCBs scPtr)" + "corres dc + (einvs and sc_at scPtr and K (scPtr \ idle_sc_ptr)) invs' + (sched_context_unbind_all_tcbs scPtr) (schedContextUnbindAllTCBs scPtr)" apply (clarsimp simp: sched_context_unbind_all_tcbs_def schedContextUnbindAllTCBs_def) apply (rule corres_gen_asm, clarsimp) - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF get_sc_corres]) apply (rule corres_when) apply (clarsimp simp: sc_relation_def) apply (rule schedContextUnbindTCB_corres) apply wpsimp+ - apply (clarsimp simp: sc_at_pred_n_def obj_at_def) + apply (fastforce simp: sc_at_pred_n_def obj_at_def) apply (clarsimp simp: obj_at'_def) done @@ -4483,65 +4280,75 @@ lemma replyNext_update_corres_empty: apply (clarsimp simp: obj_at'_def replyPrev_same_def) done +lemma reply_at'_scReply: + "\scReply sc' = Some replyPtr; ksPSpace s' scPtr = Some (KOSchedContext sc'); + sc_replies_relation s s'; pspace_relation (kheap s) (ksPSpace s'); + valid_objs s; pspace_aligned s; pspace_distinct s\ + \ reply_at' replyPtr s'" + apply (rule reply_at_cross, fastforce+) + apply (clarsimp simp: pspace_relation_heap_pspace_relation) + apply (frule heap_pspace_relation_scs_relation) + apply (frule (1) scs_relation_sc_relation_conc) + apply (clarsimp simp: sc_replies_relation_def) + apply (drule_tac x=scPtr in spec) + apply (drule_tac x="sc_replies sc" in spec) + apply (prop_tac "sc_replies sc \ []") + apply (clarsimp simp: vs_all_heap_simps obj_at_def opt_map_def obj_at'_def) + apply (elim impE) + apply (clarsimp simp: vs_all_heap_simps obj_at_def) + apply (frule (1) heap_path_head) + apply (fastforce dest!: valid_objs_valid_sched_context + simp: valid_sched_context_def list_all_iff opt_map_def) + done + lemma schedContextUnbindReply_corres: - "corres dc (einvs and sc_at scPtr and K (scPtr \ idle_sc_ptr)) (invs' and sc_at' scPtr) - (sched_context_unbind_reply scPtr) (schedContextUnbindReply scPtr)" + "corres dc + (einvs and sc_at scPtr and K (scPtr \ idle_sc_ptr)) (invs' and sc_at' scPtr) + (sched_context_unbind_reply scPtr) (schedContextUnbindReply scPtr)" apply (clarsimp simp: sched_context_unbind_reply_def schedContextUnbindReply_def liftM_def unless_def) apply add_sym_refs - apply (rule corres_stateAssert_implied[where P'=\, simplified]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_sc_corres, where R'="\sc. ko_at' sc scPtr"]) - apply (rename_tac sc sc') - apply (rule_tac Q'="ko_at' sc' scPtr - and K (scReply sc' = hd_opt (sc_replies sc)) - and (\s. scReply sc' \ None \ reply_at' (the (scReply sc')) s) - and (\s. heap_ls (replyPrevs_of s) (scReply sc') (sc_replies sc))" + apply (rule corres_stateAssert_ignore, simp) + apply (rule corres_split_forwards'[OF _ get_sched_context_sp get_sc_sp']) + apply (corres corres: get_sc_corres) + apply fastforce + apply simp + apply clarsimp + apply (rename_tac sc sc' n) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply (clarsimp simp: valid_bound_obj'_def split: option.splits) + apply (frule state_relation_sc_replies_relation) + apply (fastforce elim: reply_at'_scReply simp: obj_at'_def) + apply (rule_tac Q'="ko_at' sc' scPtr + and (\s. heap_ls (replyPrevs_of s) (scReply sc') (sc_replies sc)) + and valid_bound_reply' (scReply sc')" and Q="sc_at scPtr - and pspace_aligned and pspace_distinct and valid_objs - and (\s. \n. ko_at (Structures_A.SchedContext sc n) scPtr s)" - in stronger_corres_guard_imp) - apply (rule corres_guard_imp) - apply (rule_tac F="(sc_replies sc \ []) = (\y. scReply sc' = Some y)" in corres_gen_asm2) - apply (rule corres_when) - apply clarsimp - apply (rule_tac F="scReply sc' = Some (hd (sc_replies sc))" in corres_gen_asm2) + and pspace_aligned and pspace_distinct and valid_objs + and (\s. \n. ko_at (Structures_A.SchedContext sc n) scPtr s)" + in stronger_corres_guard_imp) + apply (rule corres_guard_imp) + apply (rule_tac F="(sc_replies sc \ []) = (\y. scReply sc' = Some y)" in corres_gen_asm2) + apply (rule corres_when) + apply clarsimp + apply (rule_tac F="scReply sc' = Some (hd (sc_replies sc))" in corres_gen_asm2) + apply clarsimp + apply (rule corres_split[OF replyNext_update_corres_empty]) + apply (clarsimp simp: updateSchedContext_def) + apply (rule corres_symb_exec_r') + apply (rename_tac new_sc') + apply (rule_tac F="new_sc' = sc'" in corres_gen_asm2) apply clarsimp - apply (rule corres_split[OF replyNext_update_corres_empty]) - apply (clarsimp simp: updateSchedContext_def) - apply (rule corres_symb_exec_r') - apply (rename_tac new_sc') - apply (rule_tac F="new_sc' = sc'" in corres_gen_asm2) - apply clarsimp - apply (rule update_sc_reply_stack_update_ko_at'_corres[unfolded dc_def]) - apply (wpsimp wp: get_sc_inv' hoare_vcg_all_lift)+ - apply (clarsimp simp: obj_at_def) - apply (frule (1) valid_sched_context_objsI) - apply (clarsimp simp: valid_sched_context_def list_all_def obj_at_def) - apply clarsimp - apply (case_tac "sc_replies sc"; simp) - apply normalise_obj_at' - apply assumption - apply (clarsimp simp: obj_at_def) - apply (frule state_relation_sc_replies_relation) - apply (subgoal_tac "scReply sc' = hd_opt (sc_replies sc)") - apply (intro conjI) - apply clarsimp - apply clarsimp - apply (erule (1) reply_at_cross[rotated]) - apply (frule (1) valid_sched_context_objsI) - apply (clarsimp simp: valid_sched_context_def list_all_def obj_at_def) - apply fastforce - apply (erule (1) sc_replies_relation_prevs_list) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKO_sc) - apply (frule state_relation_sc_replies_relation) - apply (frule sc_replies_relation_scReplies_of[symmetric]) - apply (fastforce simp: obj_at_def is_sc_obj_def obj_at'_def) - apply (fastforce simp: obj_at'_def opt_map_def) - apply (fastforce simp: obj_at'_real_def opt_map_def ko_wp_at'_def sc_replies_of_scs_def - map_project_def scs_of_kh_def) - apply wpsimp+ - apply (fastforce simp: sym_refs_asrt_def)+ + apply (rule update_sc_reply_stack_update_ko_at'_corres[unfolded dc_def]) + apply (wpsimp wp: get_sc_inv' hoare_vcg_all_lift)+ + apply (clarsimp simp: obj_at_def) + apply (frule (1) valid_sched_context_objsI) + apply (clarsimp simp: valid_sched_context_def list_all_def obj_at_def) + apply (case_tac "sc_replies sc"; simp) + apply normalise_obj_at' + apply fastforce + apply (frule state_relation_sc_replies_relation) + apply (fastforce simp: sc_replies_relation_def vs_all_heap_simps obj_at_def opt_map_def + obj_at'_def) done lemma schedContextUnbindYieldFrom_corres: @@ -4561,15 +4368,16 @@ lemma schedContextUnbindYieldFrom_corres: apply (clarsimp simp: sc_relation_def) apply (rule schedContextCompleteYieldTo_corres) apply wpsimp+ - apply (fastforce dest!: invs_valid_objs valid_objs_ko_at + apply (intro conjI impI allI; + fastforce dest!: invs_valid_objs valid_objs_ko_at simp: valid_obj_def valid_sched_context_def) apply (fastforce dest!: sc_ko_at_valid_objs_valid_sc' simp: valid_obj'_def valid_sched_context'_def) - apply (clarsimp simp: sym_refs_asrt_def) + apply clarsimp done lemma schedContextSetInactive_corres: - "corres dc (\s. sc_at scPtr s) (sc_at' scPtr) + "corres dc (sc_at scPtr and pspace_aligned and pspace_distinct) \ (sched_context_set_inactive scPtr) (schedContextSetInactive scPtr)" apply (clarsimp simp: sched_context_set_inactive_def schedContextSetInactive_def) apply (rule corres_guard_imp) @@ -4584,15 +4392,15 @@ lemma schedContextSetInactive_corres: apply (rule updateSchedContext_no_stack_update_corres) apply (clarsimp simp: sc_relation_def refills_map_def) apply (fastforce dest: state_relation_sc_replies_relation sc_replies_relation_prevs_list - simp: sc_relation_def opt_map_def + simp: sc_relation_def opt_map_def gen_obj_at_simps is_sc_obj_def split: Structures_A.kernel_object.splits) - apply clarsimp+ + apply (clarsimp simp: gen_objBits_simps)+ apply (rule updateSchedContext_no_stack_update_corres) apply (clarsimp simp: sc_relation_def) apply (fastforce dest: state_relation_sc_replies_relation sc_replies_relation_prevs_list - simp: sc_relation_def opt_map_def + simp: sc_relation_def opt_map_def gen_obj_at_simps is_sc_obj_def split: Structures_A.kernel_object.splits) - apply clarsimp + apply (clarsimp simp: gen_objBits_simps) apply (wpsimp wp: get_sched_context_wp getSchedContext_wp)+ done @@ -4610,6 +4418,12 @@ lemma can_fast_finalise_finaliseCap: context begin interpretation Arch . (*FIXME: arch-split*) +crunch sched_context_unbind_yield_from, sched_context_unbind_reply, sched_context_unbind_ntfn, + sched_context_unbind_all_tcbs + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + (wp: crunch_wps) + lemma finaliseCap_corres: "\ final_matters' cap' \ final = final'; cap_relation cap cap'; flag \ can_fast_finalise cap \ @@ -4671,7 +4485,8 @@ lemma finaliseCap_corres: apply clarsimp apply (frule(1) valid_global_refsD[OF invs_valid_global_refs _ idle_sc_global]) apply (clarsimp dest!: invs_valid_idle simp: valid_idle_def cap_range_def) - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) + apply (rule corres_stateAssert_r) apply (rule corres_split[OF schedContextUnbindAllTCBs_corres]) apply (rule corres_split[OF schedContextUnbindNtfn_corres]) apply (rule corres_split[OF schedContextUnbindReply_corres]) @@ -4679,8 +4494,9 @@ lemma finaliseCap_corres: apply (clarsimp simp: o_def dc_def[symmetric]) apply (rule schedContextSetInactive_corres) apply (wpsimp wp: abs_typ_at_lifts typ_at_lifts)+ - apply (clarsimp simp: valid_cap_def) + apply (fastforce simp: valid_cap_def) apply (clarsimp simp: valid_cap'_def sc_at'_n_sc_at') + apply (fastforce intro!: cross_relF[OF _ sch_act_simple_cross_rel]) (* IRQHandlerCap *) apply (clarsimp simp: final_matters'_def liftM_def[symmetric] o_def dc_def[symmetric]) @@ -4700,20 +4516,6 @@ lemma finaliseCap_corres: apply (rule corres_guard_imp [OF arch_finaliseCap_corres], (fastforce simp: valid_sched_def)+)[1] done -lemma threadSet_ct_idle_or_in_cur_domain': - "\ct_idle_or_in_cur_domain' - and (\s. \tcb. tcbDomain tcb = ksCurDomain s \ tcbDomain (F tcb) = ksCurDomain s)\ - threadSet F t - \\_. ct_idle_or_in_cur_domain'\" - apply (simp add: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) - apply (wp hoare_vcg_disj_lift hoare_vcg_imp_lift) - apply wps - apply wp - apply wps - apply wp - apply (auto simp: obj_at'_def) - done - context begin interpretation Arch . (*FIXME: arch-split*) lemmas final_matters'_simps = final_matters'_def [split_simps capability.split arch_capability.split] @@ -4732,11 +4534,8 @@ lemma set_ntfn_ct_in_state'[wp]: apply (wp_pre, wps, wp, clarsimp) done -lemma unbindMaybeNotification_ct_in_state'[wp]: - "\ct_in_state' P\ unbindMaybeNotification t \\_. ct_in_state' P\" - apply (simp add: unbindMaybeNotification_def) - apply (wp | wpc | simp)+ - done +crunch unbindMaybeNotification + for ct_in_state'[wp]: "ct_in_state' P" lemma setNotification_sch_act_sane: "\sch_act_sane\ setNotification a ntfn \\_. sch_act_sane\" diff --git a/proof/refine/RISCV64/Init_R.thy b/proof/refine/RISCV64/Init_R.thy index 7bbbaee4ee..321d2a2fe3 100644 --- a/proof/refine/RISCV64/Init_R.thy +++ b/proof/refine/RISCV64/Init_R.thy @@ -110,13 +110,15 @@ lemma non_empty_refine_state_relation: "(zeroed_abstract_state, zeroed_intermediate_state) \ state_relation" apply (clarsimp simp: state_relation_def zeroed_state_defs state.defs) apply (intro conjI) - apply (clarsimp simp: pspace_relation_def pspace_dom_def) - apply (clarsimp simp: sc_replies_relation_def sc_replies_of_scs_def scs_of_kh_def map_project_def) - apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def - queue_end_valid_def opt_pred_def list_queue_relation_def - emptyHeadEndPtrs_def headEndPtrsEmpty_def prev_queue_head_def) - apply (clarsimp simp: release_queue_relation_def queue_end_valid_def opt_pred_def - list_queue_relation_def emptyHeadEndPtrs_def prev_queue_head_def) + apply (clarsimp simp: pspace_relation_def pspace_dom_def) + apply (clarsimp simp: ep_queues_relation_def) + apply (clarsimp simp: ntfn_queues_relation_def) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def + queue_end_valid_def opt_pred_def list_queue_relation_def + emptyHeadEndPtrs_def headEndPtrsEmpty_def prev_queue_head_def) + apply (clarsimp simp: release_queue_relation_def queue_end_valid_def opt_pred_def + list_queue_relation_def emptyHeadEndPtrs_def prev_queue_head_def) + apply (clarsimp simp: sc_replies_relation_def sc_replies_of_scs_def scs_of_kh_def map_project_def) apply (clarsimp simp: ghost_relation_def) apply (fastforce simp: cdt_relation_def swp_def dest: cte_wp_at_domI) apply (clarsimp simp: cdt_list_relation_def map_to_ctes_def) diff --git a/proof/refine/RISCV64/InterruptAcc_R.thy b/proof/refine/RISCV64/InterruptAcc_R.thy index f2efe09c35..bfb90e8094 100644 --- a/proof/refine/RISCV64/InterruptAcc_R.thy +++ b/proof/refine/RISCV64/InterruptAcc_R.thy @@ -163,6 +163,46 @@ lemma no_ofail_readRefillSufficient[wp]: lemmas no_fail_getRefillSufficient[wp] = no_ofail_gets_the[OF no_ofail_readRefillSufficient, simplified getRefillSufficient_def[symmetric]] +lemma getRefillHead_rcorres: + "sc_ptr = scPtr \ + rcorres + (\s s'. is_active_sc sc_ptr s \ sc_refills_sc_at (\refills. refills \ []) sc_ptr s + \ valid_objs s \ scs_relation s s') + (get_refill_head sc_ptr) (getRefillHead scPtr) + (\rv rv' _ _. refill_map rv' = rv)" + apply (clarsimp simp: get_refill_head_def getRefillHead_def read_refill_head_def + readRefillHead_def read_sched_context_get_sched_context + readSchedContext_def ohaskell_state_assert_def gets_the_ostate_assert + simp flip: getObject_def) + apply (rule rcorres_symb_exec_l[OF get_sched_context_sp]) + apply (rule get_sched_context_exs_valid) + apply (clarsimp simp: vs_all_heap_simps) + apply (rule rcorres_stateAssert_r_fwd[simplified HaskellLib_H.stateAssert_def])+ + apply (rule rcorres_assert_l_fwd) + apply (clarsimp simp: sc_at_ppred_def obj_at_def is_sc_obj_def) + apply (rule rcorres_symb_exec_r[OF set_sc'.getObject_sp]) + apply (rule rcorres_return) + apply clarsimp + apply (rename_tac n) + apply (rule_tac n=n in refill_hd_relation[symmetric]) + apply (clarsimp simp: obj_at_def) + apply (frule (1) scs_relation_sc_relation_abs) + apply (clarsimp simp: obj_at'_def) + apply (frule valid_objs'_valid_refills'[where scp=scPtr]) + apply (fastforce intro: active_sc_at'_cross_valid_objs active_sc_at'_imp_is_active_sc') + apply (clarsimp simp: obj_at'_def in_omonad valid_refills'_def) + done + +lemmas no_fail_getRefillHead[wp] = + no_ofail_gets_the[OF no_ofail_readRefillHead, simplified getRefillHead_def[symmetric]] + +lemma get_refill_heap_det_wp[wp]: + "det_wp (sc_refills_sc_at (\refills. refills \ []) sc_ptr) (get_refill_head sc_ptr)" + unfolding get_refill_head_def + apply wpsimp + apply (fastforce intro: no_ofailD[OF no_ofail_read_refill_head]) + done + lemma getRefillHead_corres: "sc_ptr = scPtr \ corres (\rv rv'. refill_map rv' = rv) @@ -170,27 +210,19 @@ lemma getRefillHead_corres: and is_active_sc sc_ptr and sc_at sc_ptr and sc_refills_sc_at (\refills. refills \ []) sc_ptr) valid_objs' (get_refill_head sc_ptr) (getRefillHead scPtr)" + supply ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + heap_ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) apply (add_active_sc_at' scPtr) - apply (clarsimp simp: get_refill_head_def getRefillHead_def read_refill_head_def - readRefillHead_def read_sched_context_get_sched_context - readSchedContext_def ohaskell_state_assert_def gets_the_ostate_assert - simp flip: getSchedContext_def getObject_def) - apply (rule corres_stateAssert_ignore[simplified HaskellLib_H.stateAssert_def], simp)+ - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[OF get_sc_corres]) - apply (rule corres_assert_assume_l) - apply clarsimp - apply (rule refill_hd_relation[symmetric]) - apply simp - apply simp - apply wpsimp - apply wpsimp - apply (clarsimp simp: sc_at_ppred_def obj_at_def is_sc_obj_def) - apply (fastforce intro: valid_objs_valid_sched_context_size) + apply (rule_tac Q'=pspace_bounded' in corres_cross_add_guard) + apply (fastforce intro: pspace_relation_pspace_bounded') + apply (rule corres_underlying_from_rcorres) + apply wpsimp + apply (clarsimp simp: state_relation_def ghost_relation_heap_ghost_relation + pspace_relation_heap_pspace_relation heap_pspace_relation_def) + apply (rcorres_conj_lift \fastforce\)+ + apply (rcorres rcorres: getRefillHead_rcorres) apply clarsimp - apply (frule (4) active_sc_at'_cross_valid_objs) - by (fastforce dest: valid_objs'_valid_refills' - simp: active_sc_at'_def obj_at'_def is_active_sc'_def in_omonad valid_refills'_def) + done lemma getRefillCapacity_corres: "sc_ptr = scPtr \ diff --git a/proof/refine/RISCV64/Interrupt_R.thy b/proof/refine/RISCV64/Interrupt_R.thy index 4360a92d06..e4f3776ec9 100644 --- a/proof/refine/RISCV64/Interrupt_R.thy +++ b/proof/refine/RISCV64/Interrupt_R.thy @@ -733,13 +733,12 @@ lemma hint_invs[wp]: apply (simp add: handleInterrupt_def getSlotCap_def cong: irqstate.case_cong) apply (rule conjI; rule impI) apply (wp dmo_maskInterrupt_True getCTE_wp' - | wpc | simp add: doMachineOp_bind maskIrqSignal_def )+ - apply (rule_tac Q'="\rv. invs'" in hoare_post_imp) - apply (clarsimp simp: cte_wp_at_ctes_of ex_nonz_cap_to'_def) - apply fastforce + | wpc | simp add: doMachineOp_bind maskIrqSignal_def)+ + apply (rule_tac Q'="\_. invs'" in hoare_post_imp) + apply clarsimp apply (wp threadSet_invs_trivial | simp add: inQ_def handleReservedIRQ_def)+ apply (wp hoare_post_comb_imp_conj hoare_drop_imp getIRQState_inv) - apply (assumption)+ + apply fastforce done end diff --git a/proof/refine/RISCV64/IpcCancel_R.thy b/proof/refine/RISCV64/IpcCancel_R.thy index 191d4c10ea..11043517bd 100644 --- a/proof/refine/RISCV64/IpcCancel_R.thy +++ b/proof/refine/RISCV64/IpcCancel_R.thy @@ -14,24 +14,72 @@ begin arch_requalify_facts valid_global_refs_lift' -context begin interpretation Arch . (*FIXME: arch-split*) +crunch updateEndpoint, updateNotification, tcbNTFNDequeue, tcbNTFNAppend, tcbEPDequeue, tcbEPAppend, + removeAndRestartEPQueuedThread, removeAndRestartNTFNQueuedThread, + cancelBadgedSends, cancelAllSignals, cancelAllIPC, cancelIPC, cancelSignal + for typ_at'[wp]: "\s. P (typ_at' T p s)" + and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" + (wp: crunch_wps) + +global_interpretation updateEndpoint: typ_at_all_props' "updateEndpoint epPtr f" + by typ_at_props' + +global_interpretation updateNotification: typ_at_all_props' "updateNotification ntfnPtr f" + by typ_at_props' + +global_interpretation tcbNTFNDequeue: typ_at_all_props' "tcbNTFNDequeue tcbPtr ntfnPtr" + by typ_at_props' + +global_interpretation tcbNTFNAppend: typ_at_all_props' "tcbNTFNAppend tcbPtr ntfnPtr" + by typ_at_props' + +global_interpretation tcbEPDequeue: typ_at_all_props' "tcbEPDequeue tcbPtr epPtr" + by typ_at_props' + +global_interpretation tcbEPAppend: typ_at_all_props' "tcbEPAppend tcbPtr epPtr state" + by typ_at_props' + +global_interpretation tcbQueueRemove: typ_at_all_props' "tcbQueueRemove queue tcbPtr" + by typ_at_props' + +global_interpretation removeAndRestartEPQueuedThread: + typ_at_all_props' "removeAndRestartEPQueuedThread t epptr" + by typ_at_props' + +global_interpretation removeAndRestartNTFNQueuedThread: + typ_at_all_props' "removeAndRestartNTFNQueuedThread t ntfnPtr" + by typ_at_props' + +global_interpretation removeAndRestartBadgedThread: + typ_at_all_props' "removeAndRestartBadgedThread t epptr badge" + by typ_at_props' + +global_interpretation cancelBadgedSends: typ_at_all_props' "cancelBadgedSends epptr badge" + by typ_at_props' + +global_interpretation cancelAllSignals: typ_at_all_props' "cancelAllSignals ntfnPtr" + by typ_at_props' + +global_interpretation cancelAllIPC: typ_at_all_props' "cancelAllIPC epptr" + by typ_at_props' + +global_interpretation cancelIPC: typ_at_all_props' "cancelIPC tptr" + by typ_at_props' + +global_interpretation cancelSignal: typ_at_all_props' "cancelSignal threadPtr ntfnPtr" + by typ_at_props' (* FIXME RT: remove *) declare if_weak_cong [cong] -crunch cancelAllIPC - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps mapM_x_wp' simp: unless_def crunch_simps) -crunch cancelAllIPC - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps mapM_x_wp' simp: unless_def crunch_simps) - -crunch cancelAllSignals +crunch cancelAllIPC, cancelAllSignals for aligned'[wp]: pspace_aligned' - (wp: crunch_wps mapM_x_wp') -crunch cancelAllSignals - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps mapM_x_wp') + and distinct'[wp]: pspace_distinct' + (wp: crunch_wps) + +crunch tcbNTFNDequeue, tcbNTFNAppend, tcbEPDequeue, tcbEPAppend + for pred_tcb_at'[wp]: "\s. Q (pred_tcb_at' proj P t s)" + (wp: crunch_wps) lemma cancelSignal_st_tcb_at'_cases: "\\s. (t = t' \ Q (P Inactive)) \ (t \ t' \ Q (st_tcb_at' P t s))\ @@ -52,26 +100,22 @@ lemma cancelSignal_pred_tcb_at': apply (wp sts_pred_tcb_neq' getNotification_wp | wpc | clarsimp)+ done -lemma cancelSignal_tcb_at': - "cancelSignal tptr ntfnptr \\s. P (tcb_at' tptr' s)\" - unfolding cancelSignal_def Let_def - apply (wpsimp wp: hoare_drop_imp) - done - crunch cancelIPC, cancelSignal (* FIXME RT: VER-1016 *) - for tcb_at'_better[wp]: "\s. P (tcb_at' p s)" - and it'[wp]: "\s. P (ksIdleThread s)" - (wp: hoare_vcg_all_lift crunch_wps cancelSignal_tcb_at' simp: crunch_simps pred_tcb_at'_def) + for it'[wp]: "\s. P (ksIdleThread s)" + (wp: crunch_wps) + +context begin interpretation Arch . (*FIXME: arch-split*) crunch emptySlot - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" + for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" + and typ_at'[wp]: "\s. P (typ_at' T p s)" (wp: setCTE_pred_tcb_at') defs capHasProperty_def: "capHasProperty ptr P \ cte_wp_at' (\c. P (cteCap c)) ptr" -end +end (* end Arch interpretation *) lemma blockedCancelIPC_st_tcb_at: "\\s. (t = t' \ Q (P Inactive)) \ (t \ t' \ Q (st_tcb_at' P t s))\ @@ -133,11 +177,6 @@ lemma cancelSignal_st_tcb_at': apply (wpsimp wp: setThreadState_st_tcb_at'_cases) done -context begin interpretation Arch . -crunch emptySlot - for typ_at'[wp]: "\s. P (typ_at' T p s)" -end - sublocale delete_one_conc_pre < delete_one: typ_at_all_props' "cteDeleteOne slot" by typ_at_props' @@ -168,12 +207,15 @@ lemma replyUnlinkTcb_corres: valid_tcbs' (reply_unlink_tcb t rp) (replyUnlink rp t)" (is "corres _ _ ?conc_guard _ _") apply (rule_tac Q="?conc_guard - and st_tcb_at' (\st. (\ep pl. st = BlockedOnReceive ep (receiver_can_grant pl) (Some rp)) - \ st = BlockedOnReply (Some rp)) t" - in corres_cross_over_guard) + and st_tcb_at' (\st. (\ep pl. st = BlockedOnReceive ep (receiver_can_grant pl) (Some rp)) + \ st = BlockedOnReply (Some rp)) t + and reply_at' rp" + in corres_cross_over_guard) apply clarsimp apply (drule (1) st_tcb_at_coerce_concrete; clarsimp simp: state_relation_def) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def) + apply (rule conjI) + apply (fastforce simp: pred_tcb_at'_def obj_at'_def) + apply (fastforce intro!: reply_at_cross simp: reply_tcb_reply_at_def obj_at_def is_reply_def) apply (simp add: reply_unlink_tcb_def replyUnlink_def liftM_def) apply (rule corres_guard_imp) apply (rule corres_split[OF get_reply_corres]) @@ -194,9 +236,6 @@ lemma replyUnlinkTcb_corres: apply (wpsimp wp: hoare_vcg_disj_lift gts_wp get_simple_ko_wp)+ apply (clarsimp simp: sk_obj_at_pred_def obj_at_def is_reply pred_tcb_at_def is_tcb) apply (clarsimp simp: obj_at'_def st_tcb_at'_def) - apply (prop_tac "reply_at' rp s") - apply (fastforce simp: valid_tcbs'_def valid_tcb'_def valid_tcb_state'_def) - apply (clarsimp simp: obj_at'_def) done lemma setNotification_valid_tcbs'[wp]: @@ -212,41 +251,426 @@ lemma setEndpoint_valid_tcbs'[wp]: simp: setEndpoint_def) lemma replyUnlink_valid_tcbs'[wp]: - "\valid_tcbs' and pspace_aligned' and pspace_distinct'\ - replyUnlink replyPtr tcbPtr - \\_. valid_tcbs'\" - apply (clarsimp simp: replyUnlink_def getReply_def updateReply_def) - apply (wpsimp wp: set_reply'.getObject_wp set_reply'.getObject_wp gts_wp' - simp: valid_tcb_state'_def) + "replyUnlink replyPtr tcbPtr \valid_tcbs'\" + unfolding replyUnlink_def getReply_def updateReply_def + by (wpsimp wp: set_reply'.getObject_wp gts_wp') + +lemma updateEndpoint_wp: + "\\s. \ep :: endpoint. ko_at' ep epPtr s \ P (set_obj' epPtr (f ep) s)\ + updateEndpoint epPtr f + \\_. P\" + unfolding updateEndpoint_def setEndpoint_def + by (wpsimp wp: set_ep'.setObject_wp getEndpoint_wp) + +lemma updateNotification_wp: + "\\s. \ntfn :: notification. ko_at' ntfn ntfnPtr s \ P (set_obj' ntfnPtr (f ntfn) s)\ + updateNotification ntfnPtr f + \\_. P\" + unfolding updateNotification_def setNotification_def + by (wpsimp wp: set_ntfn'.setObject_wp getNotification_wp) + +lemma updateEndpoint_dom_eps_of'[wp]: + "updateEndpoint a b \\s. P (dom (eps_of' s))\" + apply (wpsimp wp: updateEndpoint_wp) + apply (fastforce elim!: rsubst[where P=P] simp: projectKO_opts_defs obj_at'_def opt_map_red) + done + +lemma set_endpoint_dom_eps_of[wp]: + "set_endpoint ep_ptr ep \\s. P (dom (eps_of s))\" + apply (wpsimp wp: set_simple_ko_wp) + apply (fastforce elim: rsubst[where P=P] simp: opt_map_red eps_of_kh_def ep_at_pred_def) + done + +lemma set_endpoint_det_wp[wp]: + "det_wp (ep_at ep_ptr) (set_endpoint ep_ptr ep)" + apply (wpsimp wp: get_object_wp simp: set_simple_ko_def) + apply (clarsimp simp: gen_obj_at_simps is_ep_def) + apply (rename_tac ko, case_tac ko; clarsimp) + done + +lemmas set_endpoint_no_fail[wp] = det_wp_no_fail[OF set_endpoint_det_wp] + +method set_simple_ko_heaps_inv = + wpsimp wp: set_simple_ko_wp, + erule rsubst[where P=P], + clarsimp simp: aobj_of_def ep_at_pred_def ntfn_at_pred_def opt_map_def + +lemma set_endpoint_scs_fields_of[wp]: + "set_endpoint ep_ptr ep \\s. P (scs_fields_of s)\" + by set_simple_ko_heaps_inv + +lemma set_notification_scs_fields_of[wp]: + "set_notification ntfn_ptr ntfn \\s. P (scs_fields_of s)\" + by set_simple_ko_heaps_inv + +lemma set_endpoint_cnodes_of[wp]: + "set_endpoint ep_ptr ep \\s. P (cnodes_of s)\" + by set_simple_ko_heaps_inv + +lemma set_endpoint_replies_of[wp]: + "set_endpoint ep_ptr ep \\s. P (replies_of s)\" + by set_simple_ko_heaps_inv + +lemma set_notification_cnodes_of[wp]: + "set_notification ntfn_ptr ntfn \\s. P (cnodes_of s)\" + by set_simple_ko_heaps_inv + +lemma set_notification_replies_of[wp]: + "set_notification ntfn_ptr ntfn \\s. P (replies_of s)\" + by set_simple_ko_heaps_inv + +lemma no_fail_setEndpoint[wp]: + "no_fail (ep_at' ptr) (setEndpoint ptr new)" + unfolding setEndpoint_def + apply (wpsimp wp: no_fail_setObject_other) + apply (clarsimp simp: gen_objBits_simps) + done + +lemma no_fail_updateEndpoint[wp]: + "no_fail (ep_at' ptr) (updateEndpoint ptr f)" + by (wpsimp wp: getEndpoint_wp simp: updateEndpoint_def) + +crunch updateEndpoint + for ntfns_of'[wp]: "\s. P (ntfns_of' s)" + (wp: crunch_wps) + +crunch updateNotification + for eps_of'[wp]: "\s. P (eps_of' s)" + (wp: crunch_wps) + +lemma set_endpoint_aobjs_of[wp]: + "set_endpoint ep_ptr ep \\s. P (aobjs_of s)\" + by (set_simple_ko_heaps_inv) + +lemma set_notification_aobjs_of[wp]: + "set_notification ntfn_ptr ntfn \\s. P (aobjs_of s)\" + by (set_simple_ko_heaps_inv) + +crunch updateEndpoint, updateNotification + for dom_tcbs_of'[wp]: "\s. P (dom (tcbs_of' s))" + and tcbs_of'[wp]: "\s. P (tcbs_of' s)" + +lemma updateEndpoint_list_queue_relation[wp]: + "updateEndpoint epPtr f \\s. list_queue_relation ls q (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + by (rule hoare_lift_Pf2[where f=tcbSchedNexts_of]; wpsimp) + +lemma updateNotification_list_queue_relation[wp]: + "updateNotification epPtr f \\s. list_queue_relation ls q (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" + by (rule hoare_lift_Pf2[where f=tcbSchedNexts_of]; wpsimp) + +lemma updateEndpoint_epQueues_of_other: + "\\s. P (epQueues_of s p) \ p \ epPtr\ + updateEndpoint epPtr F + \\_ s. P (epQueues_of s p)\" + apply (wpsimp wp: updateEndpoint_wp) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: opt_map_def) + done + +lemmas corres_assert_gen_asm_cross_forwards = + corres_assert_gen_asm_cross[where P=P' and P'=P' for P', where Q=Q' and Q'=Q' for Q', simplified] + +lemma set_endpoint_cdt_list[wp]: + "set_endpoint ptr ep \\s. P (cdt_list s)\" + by (wpsimp wp: set_simple_ko_wp) + +lemma set_notification_cdt_list[wp]: + "set_notification ptr ntfn \\s. P (cdt_list s)\" + by (wpsimp wp: set_simple_ko_wp) + +lemma in_ep_queue_sched_flag_set: + "\ep_queues_blocked s; (s, s') \ state_relation; pspace_aligned s; pspace_distinct s; + ep_queues_of s p = Some q\ + \ \t \ set q. tcb_at' t s' \ sched_flag_set s' t" + apply (clarsimp simp: ep_queues_blocked_def ep_blocked_def) + apply (drule_tac x=p in spec) + apply clarsimp + apply (drule_tac x=t in bspec, fastforce) + apply (frule (3) st_tcb_at_coerce_concrete) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_def) + apply (rename_tac st, case_tac st; clarsimp) + done + +abbreviation in_queue_at_2 :: "obj_ref \ obj_ref \ (obj_ref \ obj_ref list) \ bool" where + "in_queue_at_2 t p qs \ \q. qs p = Some q \ t \ set q" + +definition in_ep_queue_at :: "obj_ref \ obj_ref \ 'z::state_ext state \ bool" where + "in_ep_queue_at t p s \ in_queue_at_2 t p (ep_queues_of s)" + +definition ep_queued :: "obj_ref \ 'z::state_ext state \ bool" where + "ep_queued t s \ \p. in_ep_queue_at t p s" + +lemma ep_queued_lift: + "(\P. f \\s. P (ep_queues_of s)\) \ (\P. f \\s. P (ep_queued t s)\)" + apply (clarsimp simp: ep_queued_def in_ep_queue_at_def) + by (rule hoare_lift_Pf2; wpsimp) + +definition in_ntfn_queue_at :: "obj_ref \ obj_ref \ 'z::state_ext state \ bool" where + "in_ntfn_queue_at t p s \ in_queue_at_2 t p (ntfn_queues_of s)" + +definition ntfn_queued :: "obj_ref \ 'z::state_ext state \ bool" where + "ntfn_queued t s \ \p. in_ntfn_queue_at t p s" + +lemma ntfn_queued_lift: + "(\P. f \\s. P (ntfn_queues_of s)\) \ (\P. f \\s. P (ntfn_queued t s)\)" + apply (clarsimp simp: ntfn_queued_def in_ntfn_queue_at_def) + by (rule hoare_lift_Pf2; wpsimp) + +lemma ep_queues_relationD: + "\ep_queues_of s p = Some ls; epQueues_of s' p = Some q; ep_queues_relation s s'\ + \ list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + by (clarsimp simp: ep_queues_relation_def) + +crunch tcbAppend + for eps_of'[wp]: "\s. P (eps_of' s)" + and ntfns_of'[wp]: "\s. P (ntfns_of' s)" + (wp: crunch_wps) + +crunch tcbEPAppend, tcbEPDequeue, tcbNTFNAppend, tcbNTFNDequeue + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" + and inQ_opt_pred[wp]: "\s. P (inQ d p |< tcbs_of' s)" + and tcbInReleaseQueue_tcbs_of'[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" + and ksArchState[wp]: "\s. P (ksArchState s)" + and ksInterruptState[wp]: "\s. P (ksInterruptState s)" + and ksCurThread[wp]: "\s. P (ksCurThread s)" + and ksIdleThread[wp]: "\s. P (ksIdleThread s)" + and ksIdleSC[wp]: "\s. P (ksIdleSC s)" + and ksMachineState[wp]: "\s. P (ksMachineState s)" + and ksWorkUnitsCompleted[wp]: "\s. P (ksWorkUnitsCompleted s)" + and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + and ksCurDomain[wp]: "\s. P (ksCurDomain s)" + and ksDomainTime[wp]: "\s. P (ksDomainTime s)" + and ksConsumedTime[wp]: "\s. P (ksConsumedTime s)" + and ksCurTime[wp]: "\s. P (ksCurTime s)" + and ksCurSc[wp]: "\s. P (ksCurSc s)" + and ksReprogramTimer[wp]: "\s. P (ksReprogramTimer s)" + and ctes_of[wp]: "\s. P (ctes_of s)" + and gsUserPages[wp]: "\s. P (gsUserPages s)" + and gsCNodes[wp]: "\s. P (gsCNodes s)" + and ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" + and replies_of'[wp]: "\s. P (replies_of' s)" + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + and pspace_bounded'[wp]: pspace_bounded' + and pspace_canonical'[wp]: pspace_canonical' + and pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' + and no_0_obj'[wp]: no_0_obj' + and valid_mdb'[wp]: valid_mdb' + and valid_bitmaps[wp]: valid_bitmaps + and if_unsafe_then_cap'[wp]: if_unsafe_then_cap' + and valid_global_refs'[wp]: valid_global_refs' + and valid_arch_state'[wp]: valid_arch_state' + and irq_node'[wp]: "\s. P (irq_node' s)" + and valid_irq_states'[wp]: valid_irq_states' + and valid_machine_state'[wp]: valid_machine_state' + and pspace_domain_valid[wp]: pspace_domain_valid + (wp: crunch_wps) + +lemma tcbEPDequeue_corres: + "\tcb_ptr = tcbPtr; ep_ptr = epPtr\ \ + corres dc + (in_ep_queue_at tcb_ptr ep_ptr + and ep_queues_blocked and ntfn_queues_blocked and release_q_runnable + and valid_objs and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable + and ready_or_release and pspace_aligned and pspace_distinct) + (sym_heap_sched_pointers and valid_objs') + (tcb_ep_dequeue tcb_ptr ep_ptr) (tcbEPDequeue tcbPtr epPtr)" + supply if_split[split del] + return_bind[simp del] + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest!: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest!: pspace_distinct_cross) + apply (rule_tac Q="ep_at ep_ptr" in corres_cross_add_abs_guard) + apply (clarsimp simp: obj_at_def is_ep_def in_ep_queue_at_def eps_of_kh_def opt_map_def + split: option.splits) + apply (rule_tac Q'="ep_at' epPtr" in corres_cross_add_guard, fastforce intro!: ep_at_cross) + apply (clarsimp simp: tcb_ep_dequeue_def tcbEPDequeue_def) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ep_sp']) + apply (corres corres: getEndpoint_corres) + apply (rename_tac ep ep') + apply (rule_tac F="ep_queue ep \ []" in corres_req) + apply (fastforce simp: obj_at_def in_ep_queue_at_def eps_of_kh_def opt_map_def) + apply (rule corres_symb_exec_l[OF _ _ return_sp, rotated]; (solves wpsimp)?) + apply (rule corres_assert_assume_l_forward) + apply (clarsimp simp: in_ep_queue_at_def obj_at_def eps_of_kh_def opt_map_def) + apply clarsimp + apply (rename_tac ep' q) + apply (rule_tac Q="\s. ep_queues_of s ep_ptr = Some (ep_queue ep) \ valid_ep ep s" + in corres_cross_add_abs_guard) + apply (intro context_conjI) + apply (fastforce simp: obj_at_def in_ep_queue_at_def eps_of_kh_def opt_map_def) + apply (fastforce dest: valid_objs_valid_ep simp: obj_at_def) + apply (rule_tac Q'="\s'. list_queue_relation + (ep_queue ep) (epQueue ep') (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in corres_cross_add_guard) + apply (fastforce intro!: ep_queues_relationD simp: opt_map_red obj_at'_def) + apply (rule corres_underlying_from_rcorres) + apply (wpsimp wp: tcbQueueRemove_no_fail hoare_vcg_if_lift2 hoare_drop_imps) + apply (rule_tac x="ep_queue ep" in exI) + apply (force dest!: in_ep_queue_sched_flag_set[where p=ep_ptr]) + apply (clarsimp simp: state_relation_def ghost_relation_heap_ghost_relation + pspace_relation_heap_pspace_relation heap_pspace_relation_def) + apply (rcorres_conj_lift \fastforce\)+ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \eps_relation\ + apply (rule_tac Q="\ls q s s'. eps_relation s s' + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ ep_at epPtr s \ ko_at' ep' epPtr s'" + in rcorres_split) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (clarsimp simp: return_bind) + apply (drule in_set_endpoint) + apply (wpsimp wp: updateEndpoint_wp) + apply (frule list_queue_relation_Nil) + apply (clarsimp simp: eps_of_kh_def projectKO_opts_defs map_relation_def ep_relation_def + obj_at'_def + split: if_splits list.splits Structures_A.endpoint.splits) + apply (rcorres rcorres: tcbQueueRemove_rcorres) + apply blast + apply (rcorres_conj_lift \fastforce\)+ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ep_queues_relation\ + apply (simp only: ep_queues_relation_def) + apply (rule rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac p) + apply (case_tac "p \ epPtr") + apply (rule_tac Q="\_ _ s s'. ep_at epPtr s + \ (\ls q. ep_queues_of s p = Some ls + \ epQueues_of s' p = Some q + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + in rcorres_split[rotated]) + apply clarsimp + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply (metis ep_queues_disjoint) + apply (rcorres rcorres: rcorres_op_lifts + wp: set_endpoint_ep_queues_of_other + updateEndpoint_epQueues_of_other hoare_vcg_if_lift2) + apply clarsimp + \ \p = epPtr\ + apply (rule_tac Q="\ls q s s'. ep_at epPtr s + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in rcorres_split) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: valid_from_rcorres_det_return[OF tcbQueueRemove_rcorres] updateEndpoint_wp) + apply (clarsimp simp: return_bind) + apply (drule in_set_endpoint) + apply (clarsimp simp: projectKO_opts_defs split: if_splits) + subgoal + by (fastforce simp: eps_of_kh_def opt_map_def obj_at'_def projectKO_opts_defs + split: list.splits kernel_object.splits) + apply (rcorres rcorres: tcbQueueRemove_rcorres) + apply blast + apply (rule rcorres_add_return_l) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ntfn_queues_relation\ + apply (simp add: ntfn_queues_relation_def bind_assoc) + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply (fast dest!: ep_queues_ntfn_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ready_queues_relation\ + apply (simp add: ready_queues_relation_def ready_queue_relation_def Let_def bind_assoc) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac d p) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply (auto dest!: ep_queues_ready_queues_disjoint)[1] + apply wpsimp + apply wpsimp + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \release_queue_relation\ + apply (simp only: release_queue_relation_def bind_assoc fun_app_def) + apply (rule_tac p=release_queue in rcorres_lift_abs) + apply (rule_tac p=ksReleaseQueue in rcorres_lift_conc) + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply (blast dest!: ep_queues_release_queue_disjoint) + apply wpsimp + apply wpsimp + by (rcorres_conj_lift \fastforce\)+ + +crunch tcb_ep_dequeue, tcb_ntfn_dequeue + for ready_queues_runnable[wp]: ready_queues_runnable + and in_correct_ready_q[wp]: in_correct_ready_q + and ready_qs_distinct[wp]: ready_qs_distinct + and release_q_runnable[wp]: release_q_runnable + (wp: crunch_wps ready_queues_runnable_lift in_correct_ready_q_lift ready_qs_distinct_lift + release_q_runnable_lift) + +crunch tcbEPDequeue + for valid_objs'[wp]: valid_objs' + +lemma valid_ntfn'_ntfnQueue_update[simp]: + "valid_obj' (KONotification (ntfnQueue_update f ntfn)) s = valid_obj' (KONotification ntfn) s" + by (clarsimp simp: valid_obj'_def valid_ntfn'_def) + +lemma updateNotification_ntfnQueue_update_valid_objs'[wp]: + "updateNotification ntfnPtr (ntfnQueue_update f) \valid_objs'\" + unfolding updateNotification_def + apply (wpsimp wp: getNotification_wp) + apply (fastforce dest!: ntfn_ko_at_valid_objs_valid_ntfn' simp: valid_ntfn'_def) + done + +lemma updateNotification_valid_objs'[wp]: + "\\s. valid_objs' s + \ (\ntfn'. ko_at' ntfn' ntfnPtr s \ valid_obj' (injectKO ntfn') s + \ valid_obj' (injectKO (f ntfn')) s)\ + updateNotification ntfnPtr f + \\_. valid_objs'\" + apply (wpsimp simp: updateNotification_def wp: set_ntfn'.valid_objs' getNotification_wp) + apply (fastforce simp: valid_obj'_def valid_sched_context'_def valid_sched_context_size'_def + obj_at'_def opt_map_red) + done + +lemma tcbNTFNDequeue_valid_objs'[wp]: + "tcbNTFNDequeue tcbPtr ntfnPtr \valid_objs'\" + supply if_split[split del] + unfolding tcbNTFNDequeue_def + apply wpsimp + apply (rule_tac Q'="\_. valid_objs'" in hoare_post_imp) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split: if_splits) + apply (wpsimp wp: getNotification_wp)+ done lemma blocked_cancelIPC_corres: - "\ st = Structures_A.BlockedOnReceive epPtr reply_opt p' \ - st = Structures_A.BlockedOnSend epPtr p; thread_state_relation st st'; - st = Structures_A.BlockedOnSend epPtr p \ reply_opt = None \ \ - corres dc (valid_objs and pspace_aligned and pspace_distinct - and st_tcb_at ((=) st) t and (\s. sym_refs (state_refs_of s))) - (valid_objs' and st_tcb_at' ((=) st') t - and pspace_aligned' and pspace_distinct') - (blocked_cancel_ipc st t reply_opt) - (blockedCancelIPC st' t reply_opt)" (is "\ _ ; _ ; _ \ \ corres _ (?abs_guard and _) _ _ _") - apply add_sym_refs + "\st = Structures_A.BlockedOnReceive epPtr reply_opt p' + \ st = Structures_A.BlockedOnSend epPtr p; + thread_state_relation st st'; st = Structures_A.BlockedOnSend epPtr p \ reply_opt = None\ \ + corres dc + (valid_objs and ready_qs_distinct and in_correct_ready_q and ready_queues_runnable + and release_q_runnable and ready_or_release + and pspace_aligned and pspace_distinct + and st_tcb_at ((=) st) t and (\s. sym_refs (state_refs_of s))) + (valid_objs' and sym_heap_sched_pointers and valid_sched_pointers + and st_tcb_at' ((=) st') t) + (blocked_cancel_ipc st t reply_opt) + (blockedCancelIPC st' t reply_opt)" + (is "\ _ ; _ ; _ \ \ corres _ (?abs_guard and _) _ _ _") + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest!: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest!: pspace_distinct_cross) apply (prop_tac "getBlockingObject st' = return epPtr") apply (case_tac st; clarsimp simp: getBlockingObject_def epBlocked_def) + apply (rule_tac Q="valid_tcb_state st " in corres_cross_add_abs_guard) + apply (force intro!: st_tcb_at_valid_st2) apply (simp add: blocked_cancel_ipc_def blockedCancelIPC_def gbep_ret) + apply (rule corres_stateAssert_ignore) + apply (fastforce intro!: reply_at_cross simp: valid_bound_obj'_def split: option.splits) + apply (rule corres_stateAssert_ignore) + apply (force intro!: ep_at_cross simp: valid_tcb_state_def split: option.splits) apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres]) - apply (rule_tac F="ep \ IdleEP" in corres_gen_asm2) - apply (rule corres_assert_assume[rotated]) - apply (clarsimp split: endpoint.splits) - \\drop sym_refs assumtions; add reply_tcb link\ - apply (rule_tac P="?abs_guard and (\s. bound reply_opt \ reply_tcb_reply_at ((=) (Some t)) (the reply_opt) s) - and valid_ep rv - and (\_. (st = Structures_A.BlockedOnSend epPtr p - \ (\list. rv = Structures_A.SendEP list)) - \ (st = Structures_A.thread_state.BlockedOnReceive epPtr reply_opt p' - \ (\list. rv = Structures_A.RecvEP list)))" - and P'="valid_objs' and st_tcb_at' ((=) st') t and valid_ep' ep + apply (rule corres_split[OF tcbEPDequeue_corres], simp, simp) + \\drop sym_refs assumtions; add reply_tcb link\ + apply (rule_tac P="?abs_guard + and (\s. bound reply_opt + \ reply_tcb_reply_at ((=) (Some t)) (the reply_opt) s)" + and P'="valid_objs' and st_tcb_at' ((=) st') t and pspace_aligned' and pspace_distinct'" in corres_inst) \\cross over replyTCB\ @@ -257,7 +681,7 @@ lemma blocked_cancelIPC_corres: apply (frule_tac s'=s' in pspace_aligned_cross, simp) apply (frule_tac s'=s' in pspace_distinct_cross, simp, simp) apply (clarsimp simp: obj_at_def sk_obj_at_pred_def) - apply (rename_tac rp list reply) + apply (rename_tac rp reply) apply (drule_tac x=rp in pspace_relation_absD, simp) apply (clarsimp simp: obj_relation_cuts_def obj_at'_def reply_relation_def) apply (rename_tac ko) @@ -268,21 +692,11 @@ lemma blocked_cancelIPC_corres: apply (drule_tac x=rp in pspace_boundedD'[OF _ pspace_relation_pspace_bounded'], simp) apply (clarsimp simp: reply_relation_def) \\main corres proof\ - apply (rule corres_gen_asm) - 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 (erule disjE; clarsimp simp: ep_relation_def split del: if_split) apply (cases reply_opt; simp split del: if_split add: bind_assoc cong: if_cong) \\reply_opt = None\ apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) apply (rule setThreadState_corres) apply simp apply wpsimp+ @@ -293,52 +707,14 @@ lemma blocked_cancelIPC_corres: apply clarsimp \\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" - and R'="\_. ep_at' epPtr and obj_at' (\r. replyTCB r = Some t) a - and valid_objs' - and st_tcb_at' ((=) st') t - and pspace_aligned' and pspace_distinct'" - in corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) - apply (rule corres_guard_imp) apply (rule corres_split[OF replyUnlinkTcb_corres]) apply (rule setThreadState_corres, simp) apply wpsimp apply (wpsimp wp: replyUnlink_valid_objs') apply (fastforce simp: pred_tcb_at_def obj_at_def is_tcb) apply (fastforce simp: obj_at'_def pred_tcb_at'_def) - apply (wpsimp wp: set_simple_ko_wp) - apply wpsimp - apply clarsimp - apply (frule (1) Reply_or_Receive_reply_at[rotated], fastforce) - apply (frule (1) Receive_or_Send_ep_at[rotated], fastforce) - apply (clarsimp simp: st_tcb_at_tcb_at) - apply (rule conjI, clarsimp simp: obj_at_def is_ep) - apply (rule conjI, clarsimp simp: sk_obj_at_pred_def obj_at_def) - apply (intro conjI) - apply (fastforce elim!: valid_objs_ep_update intro!: valid_ep_remove1_RecvEP) - apply (clarsimp elim!: pspace_aligned_obj_update dest!: invs_psp_aligned - simp: a_type_def is_ep) - apply (clarsimp elim!: pspace_distinct_same_type dest!: invs_distinct - simp: a_type_def is_ep obj_at_def) - apply (clarsimp simp: pred_tcb_at_def obj_at_def is_ep) - apply (clarsimp split del: if_split) - apply (frule (1) Receive_or_Send_ep_at'[rotated], blast) - apply (clarsimp split del: if_split) - apply (case_tac "remove1 t list"; - clarsimp simp: valid_ep'_def obj_at'_def; - metis distinct.simps(2) distinct_remove1 list.set_intros(1) list.set_intros(2) - 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) apply (rule setThreadState_corres) apply simp apply (simp add: valid_tcb_state_def pred_conj_def) @@ -349,107 +725,244 @@ lemma blocked_cancelIPC_corres: intro!: valid_ep_remove1_SendEP) apply (clarsimp split del: if_split) 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) - apply (drule (1) st_tcb_recv_reply_state_refs) - apply (clarsimp simp: sk_obj_at_pred_def obj_at_def) + apply (frule sym_refs_ep_queues_blocked) + apply (frule sym_refs_ntfn_queues_blocked) apply (rule conjI) - apply (clarsimp simp: obj_at_def) - apply (erule (1) valid_objsE[where x=epPtr]) - apply (clarsimp simp: valid_obj_def) - apply (erule disjE; clarsimp simp: obj_at_def pred_tcb_at_def) - apply (frule (2) sym_ref_BlockedOnReceive_RecvEP[OF _ _ sym], simp) - apply (frule (2) sym_ref_BlockedOnSend_SendEP[OF _ _ sym], simp) + apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply (elim disjE) + apply (fastforce dest!: sym_ref_BlockedOnReceive_RecvEP + simp: in_ep_queue_at_def eps_of_kh_def opt_map_def split: option.splits) + apply (fastforce dest!: sym_ref_BlockedOnSend_SendEP + simp: in_ep_queue_at_def eps_of_kh_def opt_map_def split: option.splits) + apply clarsimp + apply (drule (1) st_tcb_recv_reply_state_refs) + apply (clarsimp simp: sk_obj_at_pred_def obj_at_def) apply clarsimp - apply (rule context_conjI) - apply (erule (1) Receive_or_Send_ep_at'[rotated]) - apply (fastforce simp: thread_state_relation_def) - apply (clarsimp simp: obj_at'_def) - apply (rule conjI) - apply (erule (1) valid_objsE', clarsimp simp: valid_obj'_def) - apply (erule disjE) - apply (fastforce dest!: sym_ref_BlockedOnReceive_RecvEP' simp: ko_wp_at'_def) - 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) +lemma sym_ref_BlockedOnNotification: + "\sym_refs (state_refs_of s); kheap s tcb_ptr = Some (TCB tcb); + tcb_state tcb = Structures_A.BlockedOnNotification ntfn_ptr\ + \ in_ntfn_queue_at tcb_ptr ntfn_ptr s" + apply (drule sym_refs_obj_atD[rotated, where p=tcb_ptr]) + apply (clarsimp simp: obj_at_def, simp) + apply (clarsimp simp: state_refs_of_def) + apply (drule_tac x="(ntfn_ptr, TCBSignal)" in bspec) + apply (fastforce split: if_split_asm) + apply (clarsimp simp: obj_at_def ntfn_at_pred_def) + by (rename_tac ko'; case_tac ko'; + clarsimp simp: in_ntfn_queue_at_def ntfn_q_refs_of_def opt_map_def get_refs_def2 + split: ntfn.splits) + +lemma no_fail_setNotification[wp]: + "no_fail (ntfn_at' ptr) (setNotification ptr new)" + unfolding setNotification_def + apply (wpsimp wp: no_fail_setObject_other) + apply (clarsimp simp: gen_objBits_simps) + done + +lemma no_fail_updateNotification[wp]: + "no_fail (ntfn_at' ptr) (updateNotification ptr f)" + by (wpsimp wp: getNotification_wp simp: updateNotification_def) + +lemma in_ntfn_queue_sched_flag_set: + "\ntfn_queues_blocked s; (s, s') \ state_relation; pspace_aligned s; pspace_distinct s; + ntfn_queues_of s p = Some q\ + \ \t \ set q. tcb_at' t s' \ sched_flag_set s' t" + apply (clarsimp simp: ntfn_queues_blocked_def ntfn_blocked_def) + apply (drule_tac x=p in spec) + apply clarsimp + apply (drule_tac x=t in bspec, fastforce) + apply (frule (3) st_tcb_at_coerce_concrete) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_def split: option.splits) + apply (rename_tac st ntfn, case_tac st; clarsimp) + done + +lemma set_notification_det_wp[wp]: + "det_wp (ntfn_at ntfn_ptr) (set_notification ntfn_ptr ntfn)" + apply (wpsimp wp: get_object_wp simp: set_simple_ko_def) + apply (safe; clarsimp simp: gen_obj_at_simps is_ntfn_def) + apply (rename_tac ko, case_tac ko; clarsimp) done +lemmas set_notification_no_fail[wp] = det_wp_no_fail[OF set_notification_det_wp] + +lemma updateNotification_ntfnQueues_of_other: + "\\s. P (ntfnQueues_of s p) \ p \ ntfnPtr\ + updateNotification ntfnPtr F + \\_ s. P (ntfnQueues_of s p)\" + apply (wpsimp wp: updateNotification_wp) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: opt_map_def) + done + +lemma set_notification_ntfn_queues_of_other: + "\\s. P (ntfn_queues_of s p) \ p \ ntfn_ptr\ + set_notification ntfn_ptr ntfn + \\_ s. P (ntfn_queues_of s p)\" + by (wpsimp wp: set_simple_ko_wp) + +lemma ntfn_queues_relationD: + "\ntfn_queues_of s p = Some ls; ntfnQueues_of s' p = Some q; ntfn_queues_relation s s'\ + \ list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + by (clarsimp simp: ntfn_queues_relation_def) + +lemma tcbNTFNDequeue_corres: + "\tcb_ptr = tcbPtr; ntfn_ptr = ntfnPtr\ \ + corres dc + (in_ntfn_queue_at tcb_ptr ntfn_ptr + and ep_queues_blocked and ntfn_queues_blocked and release_q_runnable + and valid_objs and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable + and ready_or_release and pspace_aligned and pspace_distinct) + (sym_heap_sched_pointers and valid_objs') + (tcb_ntfn_dequeue tcb_ptr ntfn_ptr) (tcbNTFNDequeue tcbPtr ntfnPtr)" + supply if_split[split del] return_bind[simp del] + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest!: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest!: pspace_distinct_cross) + apply (rule_tac Q="ntfn_at ntfn_ptr" in corres_cross_add_abs_guard) + apply (clarsimp simp: obj_at_def is_ntfn_def in_ntfn_queue_at_def opt_map_def + split: option.splits) + apply (rule_tac Q'="ntfn_at' ntfnPtr" in corres_cross_add_guard) + apply (fastforce intro!: ntfn_at_cross) + apply (clarsimp simp: tcb_ntfn_dequeue_def tcbNTFNDequeue_def) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ntfn_sp']) + apply (corres corres: getNotification_corres) + apply (rename_tac ntfn ntfn') + apply (rule_tac F="ntfn_queue (ntfn_obj ntfn) \ []" in corres_req) + apply (fastforce simp: obj_at_def in_ntfn_queue_at_def opt_map_def) + apply (rule corres_symb_exec_l[OF _ _ return_sp]; (solves wpsimp)?) + apply (rule corres_assert_assume_l_forward) + apply (clarsimp simp: in_ntfn_queue_at_def obj_at_def opt_map_red) + apply (rule corres_underlying_from_rcorres) + apply (wpsimp wp: tcbQueueRemove_no_fail hoare_vcg_if_lift2 hoare_drop_imps) + apply (rule_tac x="ntfn_queue (ntfn_obj ntfn)" in exI) + apply (frule (3) in_ntfn_queue_sched_flag_set[where p=ntfn_ptr]) + apply (fastforce simp: opt_map_def obj_at_def) + apply (force dest!: spec[where x=ntfnPtr] state_relation_ntfn_queues_relation + simp: ntfn_queues_relation_def in_ntfn_queue_at_def opt_map_red + obj_at'_def obj_at_def) + apply (rule_tac Q="\s s'. valid_ntfn ntfn s + \ ntfn_queues_of s ntfn_ptr = Some (ntfn_queue (ntfn_obj ntfn)) + \ tcbPtr \ set (ntfn_queue (ntfn_obj ntfn)) + \ list_queue_relation + (ntfn_queue (ntfn_obj ntfn)) (ntfnQueue ntfn') + (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in rcorres_add_to_pre) + apply (intro context_conjI) + apply (fastforce dest: valid_objs_valid_ntfn simp: obj_at_def) + apply (fastforce simp: obj_at_def in_ntfn_queue_at_def opt_map_def) + apply (clarsimp simp: in_ntfn_queue_at_def) + apply (fastforce intro!: ntfn_queues_relationD simp: opt_map_red obj_at'_def) + apply (simp only: state_relation_def ghost_relation_heap_ghost_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation heap_pspace_relation_def) + apply (rcorres_conj_lift \fastforce\)+ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ntfns_relation\ + apply (rule_tac Q="\ls q s s'. ntfns_relation s s' + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ ntfn_at ntfnPtr s \ ko_at' ntfn' ntfnPtr s'" + in rcorres_split) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (clarsimp simp: return_bind) + apply (drule in_set_notification) + apply (wpsimp wp: updateNotification_wp) + apply (frule list_queue_relation_Nil) + apply (clarsimp simp: projectKO_opts_defs map_relation_def ntfn_relation_def obj_at'_def + split: if_splits list.splits ntfn.splits) + apply (rcorres rcorres: tcbQueueRemove_rcorres) + apply blast + apply (rcorres_conj_lift \fastforce\)+ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ep_queues_relation\ + apply (simp only: ep_queues_relation_def fun_app_def) + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply (fast dest!: ep_queues_ntfn_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ntfn_queues_relation\ + apply (simp only: ntfn_queues_relation_def) + apply (rule rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac p) + apply (case_tac "p \ ntfnPtr") + apply (rule_tac Q="\_ _ s s'. ntfn_at ntfnPtr s + \ (\ls q. ntfn_queues_of s p = Some ls + \ ntfnQueues_of s' p = Some q + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + in rcorres_split[rotated]) + apply clarsimp + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply (metis ntfn_queues_disjoint) + apply (rcorres rcorres: rcorres_op_lifts + wp: set_notification_ntfn_queues_of_other + updateNotification_ntfnQueues_of_other hoare_vcg_if_lift2) + apply clarsimp + \ \p = ntfnPtr\ + apply (rule_tac Q="\ls q s s'. ntfn_at ntfnPtr s + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in rcorres_split) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: valid_from_rcorres_det_return[OF tcbQueueRemove_rcorres] updateNotification_wp) + apply (clarsimp simp: return_bind) + apply (drule in_set_notification) + apply (clarsimp simp: projectKO_opts_defs split: if_splits) + apply (clarsimp simp: opt_map_def obj_at'_def; + fastforce simp: projectKO_opts_defs split: list.splits) + apply (rcorres rcorres: tcbQueueRemove_rcorres) + apply blast + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ready_queues_relation\ + apply (simp add: ready_queues_relation_def ready_queue_relation_def Let_def bind_assoc) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac d p) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply (auto dest!: ntfn_queues_ready_queues_disjoint)[1] + apply wpsimp + apply wpsimp + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \release_queue_relation\ + apply (simp only: release_queue_relation_def bind_assoc fun_app_def) + apply (rule_tac p=release_queue in rcorres_lift_abs) + apply (rule_tac p=ksReleaseQueue in rcorres_lift_conc) + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply (blast dest!: ntfn_queues_release_queue_disjoint) + apply wpsimp + apply wpsimp + by (rcorres_conj_lift \fastforce\)+ + +lemma tcb_ntfn_dequeue_valid_tcbs[wp]: + "tcb_ntfn_dequeue tcb_ptr ntfn_ptr \valid_tcbs\" + unfolding tcb_ntfn_dequeue_def + by (wpsimp wp: get_simple_ko_wp) + lemma cancelSignal_corres: "corres dc - (invs and valid_ready_qs and st_tcb_at ((=) (Structures_A.BlockedOnNotification ntfnPtr)) t) - (invs' and st_tcb_at' ((=) (BlockedOnNotification ntfnPtr)) t) + (invs and valid_ready_qs and release_q_runnable and ready_or_release + and st_tcb_at ((=) (Structures_A.BlockedOnNotification ntfnPtr)) t) + invs' (cancel_signal t ntfnPtr) (cancelSignal t ntfnPtr)" - apply add_sym_refs apply add_ready_qs_runnable + apply add_sym_refs 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_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 (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) - apply (rule conjI) - 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 (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 (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) + apply (fastforce dest: st_tcb_at_valid_st2 simp: valid_tcb_state_def) + apply (simp add: cancel_signal_def cancelSignal_def) + apply (rule corres_stateAssert_add_assertion[rotated], fastforce dest!: sym_refs_cross) + apply (rule corres_stateAssert_add_assertion[rotated], fastforce) + apply (rule corres_guard_imp) + apply (rule corres_split[OF tcbNTFNDequeue_corres], simp, simp) + apply (fastforce intro: setThreadState_corres) + apply (wpsimp | strengthen valid_objs'_valid_tcbs')+ + apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply (frule invs_sym_refs) + apply (frule (1) sym_ref_BlockedOnNotification) + apply (erule sym) + apply (fastforce simp: is_tcb_def) + apply fastforce done lemma cte_map_tcb_2: @@ -638,7 +1151,6 @@ lemma no_fail_sc_wtih_reply_None_helper: (\s'. (s, s') \ state_relation \ (valid_objs' and (\s'. sym_refs (list_refs_of_replies' s')) and - (\s. sym_refs (state_refs_of' s)) and ko_at' reply' rp and ((\s'. sc_with_reply' rp s' = None) and pspace_aligned' and pspace_distinct' and pspace_bounded')) @@ -666,17 +1178,21 @@ lemma no_fail_sc_wtih_reply_None_helper: done lemma replyRemoveTCB_corres: - "corres dc (valid_objs and pspace_aligned and pspace_distinct and valid_replies - and st_tcb_at ((=) (Structures_A.thread_state.BlockedOnReply rp)) t and (\s. sym_refs (state_refs_of s))) - (valid_objs' and (\s'. sym_refs (list_refs_of_replies' s')) and sym_heap_sched_pointers) - (reply_remove_tcb t rp) (replyRemoveTCB t)" + "corres dc + (valid_objs and pspace_aligned and pspace_distinct and valid_replies + and st_tcb_at ((=) (Structures_A.thread_state.BlockedOnReply rp)) t + and (\s. sym_refs (state_refs_of s))) + (valid_objs' and (\s'. sym_refs (list_refs_of_replies' s')) and sym_heap_sched_pointers) + (reply_remove_tcb t rp) (replyRemoveTCB t)" (is "corres _ ?abs_guard ?conc_guard _ _") apply add_sym_refs apply (rule_tac Q'="st_tcb_at' ((=) (thread_state.BlockedOnReply (Some rp))) t" in corres_cross_add_guard) apply (fastforce dest!: st_tcb_at_coerce_concrete elim!: pred_tcb'_weakenE) + apply (rule_tac Q="reply_at rp" in corres_cross_add_abs_guard) + apply (fastforce dest: st_tcb_at_valid_st2) apply (clarsimp simp: reply_remove_tcb_def replyRemoveTCB_def isReply_def) apply (rule corres_stateAssert_ignore, simp) - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF getThreadState_corres]) apply (rule corres_assert_gen_asm_l) apply (rule corres_assert_gen_asm2) @@ -973,9 +1489,7 @@ lemma replyRemoveTCB_corres: apply (clarsimp simp: st_tcb_at_tcb_at pred_tcb_at_def obj_at_def is_tcb) apply clarsimp apply (rule context_conjI; clarsimp) - apply (prop_tac "reply_at' rp s") - apply (fastforce dest: tcb_in_valid_state' simp: valid_tcb_state'_def) - using fold_list_refs_of_replies' apply metis + apply (fastforce intro: reply_at_cross) apply (clarsimp simp: st_tcb_at'_def obj_at'_def) apply (rename_tac tcb reply) apply (case_tac "tcbState tcb"; simp) @@ -1108,6 +1622,11 @@ lemma setSchedContext_local_sym_refs: apply (clarsimp simp: opt_map_red) done +crunch sched_context_donate, set_reply_obj_ref, update_sched_context + for ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queus_blocked[wp]: ntfn_queues_blocked + (wp: ep_queues_blocked_lift ntfn_queues_blocked_lift) + lemma replyPop_corres: "\st = Structures_A.thread_state.BlockedOnReply rp; st' = Structures_H.thread_state.BlockedOnReply (Some rp)\ \ @@ -1149,7 +1668,8 @@ lemma replyPop_corres: apply (fastforce simp: opt_map_red obj_at'_def dest!: sc_replies_relation_scReplies_of state_relation_sc_replies_relation) apply (simp add: reply_unlink_sc_def replyPop_def bind_assoc liftM_def) - apply (rule_tac Q="\sc. ?abs_guard and reply_tcb_reply_at ((=) (Some t)) rp + apply (rule_tac Q="\sc. ?abs_guard and ep_queues_blocked and ntfn_queues_blocked + and reply_tcb_reply_at ((=) (Some t)) rp and (\s. \n. ko_at (Structures_A.SchedContext sc n) scp s) and bound_sc_tcb_at ((=) tcbsc) t and K (\ls. sc_replies sc = rp#ls \ distinct (rp#ls))" @@ -1161,7 +1681,8 @@ lemma replyPop_corres: apply (rule corres_guard_imp) apply (rule corres_split[OF get_reply_corres]) apply (rename_tac r r') - apply (rule_tac P="?abs_guard and reply_tcb_reply_at ((=) (Some t)) rp + apply (rule_tac P="?abs_guard and ep_queues_blocked and ntfn_queues_blocked + and reply_tcb_reply_at ((=) (Some t)) rp and ko_at (Structures_A.Reply r) rp and bound_sc_tcb_at ((=) tcbsc) t and (\s. \n. ko_at (Structures_A.SchedContext sc n) scp s)" and P'="?conc_guard and (\s'. sym_refs (list_refs_of_replies' s')) @@ -1184,7 +1705,8 @@ lemma replyPop_corres: apply (rule corres_symb_exec_l) (* assert reply_sc r = Some scp *) apply (rule corres_symb_exec_r) (* get threadState for t *) apply (rename_tac state) - apply (rule_tac P="?abs_guard and reply_tcb_reply_at ((=) (Some t)) rp + apply (rule_tac P="?abs_guard and ep_queues_blocked and ntfn_queues_blocked + and reply_tcb_reply_at ((=) (Some t)) rp and ko_at (Structures_A.Reply r) rp and bound_sc_tcb_at ((=) tcbsc) t and (\s. \n. ko_at (Structures_A.SchedContext sc n) scp s)" @@ -1204,7 +1726,9 @@ lemma replyPop_corres: apply (rule corres_split[where r'=dc]) apply (case_tac list; simp) apply (rename_tac a ls) - apply (rule_tac P="?abs_guard and reply_tcb_reply_at ((=) (Some t)) rp + apply (rule_tac P="?abs_guard + and ep_queues_blocked and ntfn_queues_blocked + and reply_tcb_reply_at ((=) (Some t)) rp and sc_replies_sc_at ((=) (a#ls)) scp and ko_at (Structures_A.Reply r) rp and bound_sc_tcb_at ((=) tcbsc) t" @@ -1229,7 +1753,8 @@ lemma replyPop_corres: apply (rule corres_guard_imp) apply (rule corres_split[OF updateReply_replyNext_not_head_corres]) apply (clarsimp simp: isHead_def) - apply (rule_tac P="?abs_guard and reply_tcb_reply_at ((=) (Some t)) rp + apply (rule_tac P="?abs_guard and ep_queues_blocked and ntfn_queues_blocked + and reply_tcb_reply_at ((=) (Some t)) rp and bound_sc_tcb_at ((=) tcbsc) t and sc_replies_sc_at (\ls. rp \ set ls) scp and reply_sc_reply_at ((=) None) rp " @@ -1256,7 +1781,9 @@ lemma replyPop_corres: apply (rule corres_split[OF corres_when2]) apply simp apply (rule schedContextDonate_corres) (* donate *) - apply (rule_tac P="?abs_guard and reply_tcb_reply_at ((=) (Some t)) rp" + apply (rule_tac P="?abs_guard + and ep_queues_blocked and ntfn_queues_blocked + and reply_tcb_reply_at ((=) (Some t)) rp" and P'="valid_objs' and sym_heap_sched_pointers and valid_sched_pointers @@ -1347,7 +1874,7 @@ lemma replyPop_corres: refillSize_def split: if_splits) apply (fold fun_upd_def) - apply (clarsimp simp: obj_at'_def opt_map_red ps_clear_upd + apply (clarsimp simp: obj_at'_def opt_map_red ps_clear_upd gen_objBits_simps split: if_split) apply (fastforce dest!: sym_refs_replyNext_replyPrev_sym[where rp'=rp and rp=rp, THEN iffD2] simp: gen_obj_at_simps opt_map_red) @@ -1383,6 +1910,7 @@ lemma replyPop_corres: apply wpsimp apply (prop_tac "distinct (sc_replies sc)") apply (fastforce simp: valid_obj_def obj_at_def is_sc_obj valid_sched_context_def) + apply (frule sym_refs_ep_queues_blocked) apply (clarsimp simp: gen_obj_at_simps opt_map_red vs_all_heap_simps) apply wpsimp apply (clarsimp simp: obj_at_def is_sc_obj) @@ -1410,10 +1938,11 @@ lemma replyRemove_corres: apply add_sym_refs apply (rule_tac Q'="st_tcb_at' ((=) st') t" in corres_cross_add_guard) apply (fastforce dest!: st_tcb_at_coerce_concrete elim!: pred_tcb'_weakenE) + apply (rule_tac Q="reply_at rp" in corres_cross_add_abs_guard) + apply (fastforce dest: st_tcb_at_valid_st2) apply (clarsimp simp: reply_remove_def replyRemove_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: sym_refs_asrt_def) - apply (rule corres_guard_imp) + apply (rule corres_stateAssert_add_assertion[rotated], clarsimp) + apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF get_reply_corres]) apply (rename_tac reply reply') apply (rule_tac P="?abs_guard and ko_at (Structures_A.Reply reply) rp" @@ -1698,20 +2227,19 @@ lemma replyRemove_corres: apply (wpsimp wp: get_simple_ko_ko_at) apply wpsimp apply clarsimp - apply (fastforce dest!: st_tcb_at_valid_st2 simp: valid_tcb_state_def) - apply (fastforce dest: tcb_in_valid_state' simp: valid_tcb_state'_def) + apply (fastforce intro!: reply_at_cross) done lemma cancel_ipc_corres: - "corres dc (invs and valid_ready_qs and tcb_at t) invs' - (cancel_ipc t) (cancelIPC t)" + "corres dc + (invs and valid_ready_qs and valid_release_q and ready_or_release and tcb_at t) invs' + (cancel_ipc t) (cancelIPC t)" apply add_sym_refs apply add_ready_qs_runnable apply (rule_tac Q'="tcb_at' t" in corres_cross_add_guard) apply (fastforce dest!: state_relationD elim!: tcb_at_cross) apply (simp add: cancel_ipc_def cancelIPC_def Let_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: sym_refs_asrt_def) + apply (rule corres_stateAssert_add_assertion[rotated], clarsimp) apply (rule corres_stateAssert_add_assertion[rotated]) apply clarsimp apply (rule corres_guard_imp) @@ -1719,7 +2247,8 @@ lemma cancel_ipc_corres: apply (rule corres_split[OF ]) apply (rule threadset_corres; (simp add: inQ_def)?) apply (clarsimp simp: tcb_relation_def fault_rel_optionation_def) - apply (rule_tac P="invs and valid_ready_qs and st_tcb_at ((=) state) t" and + apply (rule_tac P="invs and valid_release_q and valid_ready_qs and ready_or_release + and st_tcb_at ((=) state) t" and P'="invs' and st_tcb_at' ((=) statea) t" in corres_inst) apply (case_tac state, simp_all add: isTS_defs list_case_If gbep_ret')[1] apply (rule corres_guard_imp) @@ -1729,7 +2258,7 @@ lemma cancel_ipc_corres: apply simp apply (clarsimp simp: thread_state_relation_def) apply simp+ - apply (clarsimp simp: invs_implies) + apply fastforce apply (clarsimp simp: invs'_implies) apply (rule corres_guard_imp) apply (rename_tac epPtr data) @@ -1737,8 +2266,7 @@ lemma cancel_ipc_corres: in blocked_cancelIPC_corres[where reply_opt=None, simplified]) apply simp apply (clarsimp simp: thread_state_relation_def) - apply simp - apply (clarsimp simp: invs_implies) + apply (fastforce simp: invs_implies) apply (clarsimp simp: invs'_implies) apply (rule corres_guard_imp) apply (rule replyRemoveTCB_corres) @@ -1748,8 +2276,10 @@ lemma cancel_ipc_corres: apply (clarsimp simp: invs'_implies) apply (rule corres_guard_imp) apply (rule cancelSignal_corres) - apply simp+ - apply (wpsimp wp: thread_set_invs_fault_None thread_set_valid_ready_qs thread_set_no_change_tcb_state) + apply fastforce + apply simp + apply (wpsimp wp: thread_set_invs_fault_None thread_set_valid_ready_qs + thread_set_no_change_tcb_state) apply (wpsimp wp: threadSet_pred_tcb_no_state RISCV64.threadSet_invs_trivial)+ (*FIXME arch-split RT*) apply (wp gts_sp[where P="\", simplified])+ apply (rule hoare_strengthen_post) @@ -1765,59 +2295,50 @@ declare cart_singleton_empty2[simp] lemma sch_act_simple_not_t[simp]: "sch_act_simple s \ sch_act_not t s" by (clarsimp simp: sch_act_simple_def) -context begin interpretation Arch . (*FIXME: arch-split*) +crunch tcbNTFNDequeue, tcbEPDequeue + for valid_replies'[wp]: valid_replies' + and valid_irq_handlers'[wp]: valid_irq_handlers' + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + (wp: crunch_wps simp: crunch_simps) -crunch setNotification - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - and valid_bitmaps[wp]: valid_bitmaps - (wp: valid_bitmaps_lift) +crunch tcbEPAppend, tcbNTFNAppend + for valid_replies'[wp]: valid_replies' + (wp: crunch_wps valid_irq_handlers_lift' simp: crunch_simps) + +lemma tcbNTFNDequeue_valid_sched_pointers[wp]: + "tcbNTFNDequeue tcbPtr ntfnPtr \valid_sched_pointers\" + unfolding tcbNTFNDequeue_def + apply (wpsimp wp: tcbQueueRemove_valid_sched_pointers hoare_drop_imps) + apply (clarsimp simp: valid_sched_pointers_except_def) + done + +lemma tcbNTFNDequeue_not_sched_linked[wp]: + "\\\ tcbNTFNDequeue t ntfn \\_ s. \ is_sched_linked t s\" + unfolding tcbNTFNDequeue_def + by (wpsimp wp: tcbQueueRemove_not_sched_linked[simplified]) + +crunch tcbNTFNDequeue, tcbNTFNAppend, tcbEPDequeue, tcbEPAppend + for untyped_ranges_zero'[wp]: untyped_ranges_zero' + (wp: threadSet_urz crunch_wps ignore: threadSet) + +lemma setThreadState_sched_pointers_valid_sched_pointers: + "\\s. valid_sched_pointers s \ \ is_sched_linked t s\ + setThreadState st t + \\_. valid_sched_pointers\" + unfolding setThreadState_def + by (wpsimp wp: tcbState_update_valid_sched_pointers) lemma cancelSignal_invs': "\invs' and st_tcb_at' (\st. st = BlockedOnNotification ntfn) t\ cancelSignal t ntfn \\_. invs'\" - apply (simp add: cancelSignal_def invs'_def Let_def valid_dom_schedule'_def) + apply (simp add: cancelSignal_def invs'_def valid_pspace'_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) + apply (wp valid_irq_node_lift irqs_masked_lift hoare_vcg_all_lift hoare_vcg_imp_lift' + setThreadState_sched_pointers_valid_sched_pointers sts'_valid_replies') + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) done -lemma ep_redux_simps3: - "ep_q_refs_of' (case xs of [] \ IdleEP | y # ys \ RecvEP (y # ys)) - = (set xs \ {EPRecv})" - "ep_q_refs_of' (case xs of [] \ IdleEP | y # ys \ SendEP (y # ys)) - = (set xs \ {EPSend})" - by (fastforce split: list.splits simp: valid_ep_def valid_ntfn_def)+ - -end - crunch cancelIPC for ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" @@ -1830,30 +2351,10 @@ crunch cancelIPC and valid_arch'[wp]: "valid_arch_state'" and typ_at'[wp]: "\s. P (typ_at' T p s)" and vms'[wp]: "valid_machine_state'" - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' and pspace_domain_valid[wp]: pspace_domain_valid and ntfn_at'[wp]: "ntfn_at' t" (wp: hoare_vcg_all_lift crunch_wps simp: crunch_simps) -crunch cancelSignal, replyRemoveTCB - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps sts_sch_act') - -lemma blockedCancelIPC_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s \ sch_act_not tptr s\ - blockedCancelIPC st tptr rptrOpt - \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding blockedCancelIPC_def getBlockingObject_def epBlocked_def - apply (wpsimp wp: hoare_vcg_imp_lift' getEndpoint_wp haskell_assert_wp sts_sch_act') - done - -lemma nonempty_epQueue_remove1_valid_ep': - "\valid_ep' ep s; remove1 tptr (epQueue ep) = x # xs; ep \ IdleEP\ - \ valid_ep' (epQueue_update (\_. x # xs) ep) s" - by (case_tac ep; clarsimp simp: valid_ep'_def; - metis (full_types) distinct.simps(2) distinct_remove1 list.set_intros(1) - list.set_intros(2) notin_set_remove1) - lemma blockedCancelIPC_valid_pspace'[wp]: "\valid_pspace' and st_tcb_at' ((=) st) tptr\ blockedCancelIPC st tptr rptrOpt @@ -1862,15 +2363,7 @@ lemma blockedCancelIPC_valid_pspace'[wp]: unfolding valid_pspace'_def blockedCancelIPC_def getBlockingObject_def 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 ep')"; clarsimp) - apply (clarsimp simp: valid_ep'_def) - apply (fastforce dest: nonempty_epQueue_remove1_valid_ep'[rotated]) + simp: epBlocked_def) apply (case_tac "rptrOpt"; clarsimp simp: pred_tcb_at'_eq_commute) apply (fastforce simp: pred_tcb_at'_def obj_at'_def) apply (rename_tac rptr reply) @@ -1879,50 +2372,52 @@ lemma blockedCancelIPC_valid_pspace'[wp]: apply (fastforce simp: pred_tcb_at'_def obj_at'_def) done -lemma cancelIPC_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s \ sch_act_not tptr s\ - cancelIPC tptr - \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding cancelIPC_def - apply (wpsimp wp: gts_wp' hoare_vcg_imp_lift' threadSet_sch_act hoare_vcg_all_lift - replyRemoveTCB_sch_act_wf) - done - crunch getBlockingObject for inv: P -lemma blockedCancelIPC_if_live'[wp]: - "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - blockedCancelIPC st tptr epptr - \\_. if_live_then_nonz_cap'\" - unfolding blockedCancelIPC_def getBlockingObject_def - apply (wpsimp wp: getEndpoint_wp haskell_assert_wp hoare_vcg_imp_lift') - apply (clarsimp simp: if_live_then_nonz_cap'_def endpoint.disc_eq_case endpoint_live') - done - -lemma blockedCancelIPC_valid_idle': - "\valid_idle' and (\s. tptr \ ksIdleThread s)\ - blockedCancelIPC st tptr epptr - \\_. valid_idle'\" - unfolding blockedCancelIPC_def getBlockingObject_def - apply (wpsimp wp: getEndpoint_wp) - done - crunch blockedCancelIPC - for ct_not_inQ[wp]: ct_not_inQ - and cur_tcb'[wp]: "cur_tcb'" - and ctes_of[wp]: "\s. P (ctes_of s)" + for ctes_of[wp]: "\s. P (ctes_of s)" and untyped_ranges_zero'[wp]: "untyped_ranges_zero'" and tcbInReleaseQueue[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" (wp: crunch_wps) -crunch setEndpoint - for valid_sched_pointers[wp]: valid_sched_pointers - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers +lemma tcbEPDequeue_valid_sched_pointers[wp]: + "tcbEPDequeue tcbPtr epPtr \valid_sched_pointers\" + unfolding tcbEPDequeue_def updateEndpoint_def + apply (wpsimp wp: tcbQueueRemove_valid_sched_pointers hoare_drop_imps hoare_vcg_if_lift2) + apply (clarsimp simp: valid_sched_pointers_def) + done + +lemma tcbEPDequeue_not_sched_linked[wp]: + "\\\ tcbEPDequeue tcbPtr epPtr \\_ s. \ is_sched_linked tcbPtr s\" + unfolding tcbEPDequeue_def + by (wpsimp wp: tcbQueueRemove_not_sched_linked[simplified]) + +lemmas tcbEPDequeue_tcbSchedNexts_of[wp] = + tcbEPDequeue_not_sched_linked[simplified, THEN hoare_conjD1[simplified pred_conj_def]] + +lemmas tcbEPDequeue_tcbSchedPrevs_of[wp] = + tcbEPDequeue_not_sched_linked[simplified, THEN hoare_conjD2[simplified pred_conj_def]] + +lemma blockedCancelIPC_valid_sched_pointers: + "\valid_sched_pointers and tcb_at' tptr\ + blockedCancelIPC st tptr rptrOpt + \\_. valid_sched_pointers\" + unfolding blockedCancelIPC_def replyUnlink_def getBlockingObject_def + apply (cases rptrOpt; clarsimp) + apply (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers) + apply wpsimp + apply (wpsimp wp: setThreadState_not_queued_valid_sched_pointers) + apply (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers) + apply (rule_tac Q'="\_ s. \ st_tcb_at' inIPCQueueThreadState tptr s \ tcb_at' tptr s" + in hoare_post_imp) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_red) + apply (wpsimp wp: sts_st_tcb_at'_cases_strong) + apply (wpsimp wp: gts_wp' hoare_vcg_all_lift hoare_drop_imps)+ + done crunch blockedCancelIPC - for valid_sched_pointers[wp]: valid_sched_pointers - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers and valid_bitmaps[wp]: valid_bitmaps (wp: crunch_wps) @@ -1938,17 +2433,11 @@ lemma blockedCancelIPC_invs': "\invs' and st_tcb_at' ((=) st) tptr\ blockedCancelIPC st tptr rptrOpt \\_. invs'\" - apply (rule hoare_strengthen_pre_via_assert_backward[ - where E="obj_at' ((\) IdleEP) (the (epBlocked st)) - and K (\x. epBlocked st = Some x)"]) - apply (simp add: blockedCancelIPC_def getBlockingObject_def) - apply (wpsimp wp: getEndpoint_wp) - apply (clarsimp simp: obj_at'_def) unfolding invs'_def valid_dom_schedule'_def - apply (wpsimp wp: valid_irq_node_lift - valid_irq_handlers_lift' valid_irq_states_lift' irqs_masked_lift - simp: cteCaps_of_def pred_tcb_at'_def) - apply fastforce + apply (wpsimp wp: blockedCancelIPC_valid_sched_pointers + valid_irq_node_lift valid_irq_handlers_lift' valid_irq_states_lift' + irqs_masked_lift + simp: cteCaps_of_def) done lemma threadSet_fault_invs': @@ -2028,27 +2517,12 @@ lemma setBoundNotification_not_ntfn: text \The suspend operation, significant as called from delete\ -lemma setBoundNotification_tcb_in_cur_domain'[wp]: - "setBoundNotification st t \tcb_in_cur_domain' t'\" - apply (simp add: tcb_in_cur_domain'_def) - apply (rule hoare_pre) - apply wps - apply (wp setBoundNotification_not_ntfn | simp)+ - done - lemma sbn_weak_sch_act_wf[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setBoundNotification ntfn t \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" by (wp weak_sch_act_wf_lift) -lemma set_ep_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - setEndpoint epptr ep - \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (wp weak_sch_act_wf_lift) - done - lemma setObject_ntfn_sa_unchanged[wp]: "\\s. P (ksSchedulerAction s)\ setObject ptr (ntfn::Structures_H.notification) @@ -2057,11 +2531,6 @@ lemma setObject_ntfn_sa_unchanged[wp]: apply (wp | simp add: updateObject_default_def)+ done -lemma setNotification_weak_sch_act_wf[wp]: - "setNotification ntfnptr ntfn \\s. weak_sch_act_wf (ksSchedulerAction s) s\" - by (wpsimp wp: hoare_vcg_all_lift hoare_convert_imp hoare_vcg_conj_lift - simp: weak_sch_act_wf_def)+ - lemmas ipccancel_weak_sch_act_wfs = weak_sch_act_wf_lift[OF _ setCTE.typ_at_lifts_all'(1)] @@ -2080,57 +2549,52 @@ lemma asUser_tcbQueued_inv[wp]: unfolding asUser_def by (wpsimp wp: threadSet_obj_at'_no_state threadGet_wp) -crunch setThreadState - for valid_sched_pointers[wp]: valid_sched_pointers - (simp: crunch_simps wp: crunch_wps) - crunch asUser for valid_sched_pointers[wp]: valid_sched_pointers and pspace_bounded'[wp]: pspace_bounded' (rule: sym_heap_sched_pointers_lift wp: crunch_wps) -crunch set_thread_state_act +crunch set_thread_state, as_user for in_correct_ready_q[wp]: in_correct_ready_q and ready_qs_distinct[wp]: ready_qs_distinct - (wp: set_object_wp) - -lemma set_thread_state_in_correct_ready_q[wp]: - "set_thread_state ref ts \in_correct_ready_q\" - unfolding set_thread_state_def - apply (wpsimp wp: set_object_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps - in_correct_ready_q_def) - apply (fastforce simp: pred_map_def map_project_def opt_map_def tcbs_of_kh_def) + (wp: crunch_wps in_correct_ready_q_lift ready_qs_distinct_lift) + +lemma set_thread_state_ep_queues_blocked_not_queued: + "\\s. ep_queues_blocked s \ \ ep_queued t s\ + set_thread_state t st + \\_. ep_queues_blocked\" + unfolding ep_queues_blocked_def + apply (wpsimp wp: sts_st_tcb_at_cases_strong hoare_vcg_all_lift hoare_vcg_imp_lift' + hoare_vcg_ball_lift) + apply (clarsimp simp: in_ep_queue_at_def ep_queued_def) done -lemma set_thread_state_ready_qs_distinct[wp]: - "set_thread_state ref ts \ready_qs_distinct\" - unfolding set_thread_state_def - apply (wpsimp wp: set_object_wp) - by (clarsimp simp: ready_qs_distinct_def) - -lemma as_user_ready_qs_distinct[wp]: - "as_user tptr f \ready_qs_distinct\" - unfolding as_user_def - apply (wpsimp wp: set_object_wp) - by (clarsimp simp: ready_qs_distinct_def) - -lemma as_user_in_correct_ready_q[wp]: - "as_user tptr f \in_correct_ready_q\" - unfolding as_user_def - apply (wpsimp wp: set_object_wp) - apply (fastforce simp: vs_all_heap_simps obj_at_kh_kheap_simps in_correct_ready_q_def) +lemma set_thread_state_ntfn_queues_blocked_not_queued: + "\\s. ntfn_queues_blocked s \ \ ntfn_queued t s\ + set_thread_state t st + \\_. ntfn_queues_blocked\" + unfolding ntfn_queues_blocked_def + apply (wpsimp wp: sts_st_tcb_at_cases_strong hoare_vcg_all_lift hoare_vcg_imp_lift' + hoare_vcg_ball_lift) + apply (clarsimp simp: in_ntfn_queue_at_def ntfn_queued_def) done -lemma (in delete_one) suspend_corres: +crunch as_user + for ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + and ready_queues_runnable[wp]: ready_queues_runnable + and release_q_runnable[wp]: release_q_runnable + (wp: crunch_wps ep_queues_blocked_lift ntfn_queues_blocked_lift ready_queues_runnable_lift + release_q_runnable_lift) + +lemma suspend_corres: "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) (SchedContext_A.suspend t) (ThreadDecls_H.suspend t)" apply (simp add: SchedContext_A.suspend_def Thread_H.suspend_def) apply add_sym_refs - apply (rule corres_stateAssert_ignore, simp) - apply (rule corres_stateAssert_ignore) - apply (fastforce intro: weak_sch_act_wf_cross) + apply (rule corres_stateAssert_add_assertion[rotated], clarsimp)+ + apply (fastforce intro!: weak_sch_act_wf_cross) apply (rule corres_guard_imp) apply (rule corres_split_nor[OF cancel_ipc_corres]) apply (rule corres_split[OF getThreadState_corres], rename_tac state state') @@ -2147,25 +2611,30 @@ lemma (in delete_one) suspend_corres: apply (rule corres_rel_imp) apply (rule corres_return_trivial) apply simp - apply (rule corres_split[OF setThreadState_corres], simp) - apply (rule corres_split[OF tcbSchedDequeue_corres], simp) - apply (rule corres_split[OF tcbReleaseRemove_corres], simp) - apply (rule schedContextCancelYieldTo_corres) - apply wpsimp+ - apply (wpsimp simp: update_restart_pc_def updateRestartPC_def wp: as_user_valid_tcbs)+ - apply (rule hoare_post_imp[where Q'="\_ s. invs s \ tcb_at t s \ valid_sched s"]) - apply (fastforce dest: valid_sched_valid_release_q valid_sched_valid_ready_qs) - apply wp - apply wpsimp - apply (wpsimp | strengthen invs_psp_aligned invs_distinct)+ - apply (rule hoare_post_imp[where Q'="\rv s. invs' s \ tcb_at' t s"]) - apply (fastforce simp: invs'_def) - apply wp - apply (clarsimp simp: updateRestartPC_def) - apply wpsimp + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF tcbReleaseRemove_corres], simp) + apply (rule corres_split[OF schedContextCancelYieldTo_corres], simp) + apply (rule setThreadState_corres) + apply wpsimp+ + apply (rule hoare_post_imp[where Q'="\_ s. invs s \ tcb_at t s"]) + apply fastforce + apply (wpsimp wp: sched_context_cancel_yield_to_invs) + apply (rule hoare_post_imp[where Q'="\_. valid_objs'"]) + apply fastforce + apply (wpsimp wp: schedContextCancelYieldTo_invs' tcbReleaseRemove_invs')+ + apply (wpsimp simp: update_restart_pc_def | strengthen invs_implies)+ + apply (clarsimp simp: updateRestartPC_def) + apply (wpsimp wp: gts_wp hoare_vcg_all_lift hoare_drop_imps + | strengthen invs_implies valid_ready_qs_in_correct_ready_q + valid_ready_qs_ready_qs_distinct + valid_sched_valid_ready_qs valid_sched_valid_release_q invs'_implies + sym_refs_ep_queues_blocked sym_refs_ntfn_queues_blocked + valid_ready_qs_ready_queues_runnable valid_release_q_release_q_runnable)+ + apply (fastforce dest: valid_sched_valid_release_q) + apply clarsimp done -lemma (in delete_one) prepareThreadDelete_corres: +lemma prepareThreadDelete_corres: "corres dc \ \ (prepare_thread_delete t) (ArchRetypeDecls_H.RISCV64_H.prepareThreadDelete t)" by (simp add: RISCV64_A.prepare_thread_delete_def RISCV64_H.prepareThreadDelete_def) @@ -2182,7 +2651,7 @@ crunch updateRestartPC and tcb_at'[wp]: "\s. P (tcb_at' t s)" and invs'[wp]: invs' -lemma (in delete_one_conc) suspend_invs'[wp]: +lemma suspend_invs'[wp]: "suspend t \invs'\" apply (simp add: suspend_def updateRestartPC_def) apply (wpsimp wp: tcbReleaseRemove_invs' schedContextCancelYieldTo_invs' sts_invs_minor' gts_wp') @@ -2191,15 +2660,7 @@ lemma (in delete_one_conc) suspend_invs'[wp]: apply wpsimp+ done -lemma (in delete_one_conc) suspend_objs': - "\invs' and tcb_at' t\ - suspend t \\rv. valid_objs'\" - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post) - apply (wp suspend_invs') - apply fastforce+ - done - -lemma (in delete_one_conc_pre) suspend_st_tcb_at': +lemma suspend_st_tcb_at': assumes x[simp]: "\st. simple' st \ P st" shows "\st_tcb_at' P t\ suspend thread @@ -2212,8 +2673,7 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at': apply clarsimp done -lemmas (in delete_one_conc_pre) suspend_makes_simple' = - suspend_st_tcb_at' [where P=simple', simplified] +lemmas suspend_makes_simple' = suspend_st_tcb_at' [where P=simple', simplified] lemma suspend_makes_inactive: "\K (t = t')\ suspend t \\rv. st_tcb_at' ((=) Inactive) t'\" @@ -2263,9 +2723,12 @@ lemma threadSet_valid_refills'[wp]: crunch setThreadState for valid_refills'[wp]: "valid_refills' scp" + (wp: getSchedulable_wp simp: crunch_simps) crunch ifCondRefillUnblockCheck for valid_tcbs'[wp]: valid_tcbs' + and tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + 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 (wp: hoare_vcg_if_lift2 crunch_wps simp: crunch_simps) @@ -2273,17 +2736,38 @@ crunch ifCondRefillUnblockCheck crunch refill_unblock_check for in_correct_ready_q[wp]: in_correct_ready_q and ready_qs_distinct[wp]: ready_qs_distinct - (rule: in_correct_ready_q_lift ready_qs_distinct_lift) + and ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + and ready_queues_runnable[wp]: ready_queues_runnable + (rule: in_correct_ready_q_lift ready_qs_distinct_lift + ep_queues_blocked_lift ntfn_queues_blocked_lift ready_queues_runnable_lift) + +lemma set_thread_state_ready_queues_runnable_not_queued: + "\ready_queues_runnable and not_queued t\ + set_thread_state t st + \\_. ready_queues_runnable\" + unfolding ready_queues_runnable_def + apply (intro hoare_allI, rename_tac d p) + apply (rule hoare_weaken_pre) + apply (rule_tac Q="\x s. \t'\set x. t' \ {} \ st_tcb_at runnable t' s \ t \ set x" + and g="\s. ready_queues s d p" + in hoare_lift_Pf_pre_conj) + apply (wpsimp wp: hoare_vcg_ball_lift sts_st_tcb_at_other) + apply wpsimp + apply (fastforce simp: not_queued_def) + done -lemma restart_thread_if_no_fault_corres: +lemma restartThreadIfNoFault_corres: "corres dc - (valid_sched_action and tcb_at t and pspace_aligned and pspace_distinct + (not ep_queued t and not ntfn_queued t and not_queued t + and valid_sched_action and tcb_at t and pspace_aligned and pspace_distinct and valid_objs and active_scs_valid and current_time_bounded - and in_correct_ready_q and ready_qs_distinct and ready_or_release) - (valid_objs' and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded') + and in_correct_ready_q and ready_qs_distinct and ready_or_release + and ep_queues_blocked and ntfn_queues_blocked and ready_queues_runnable) + (valid_objs' and valid_sched_pointers + and pspace_aligned' and pspace_distinct' and pspace_bounded' + and (\s. \ is_sched_linked t s)) (restart_thread_if_no_fault t) (restartThreadIfNoFault t)" - (is "corres _ _ ?conc_guard _ _") apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) apply (fastforce intro: tcb_at_cross) apply (clarsimp simp: restart_thread_if_no_fault_def restartThreadIfNoFault_def) @@ -2302,283 +2786,797 @@ lemma restart_thread_if_no_fault_corres: apply (wpsimp simp: if_cond_refill_unblock_check_def wp: refill_unblock_check_active_scs_valid) apply wpsimp - apply (rule_tac Q'="\scopt s. case_option True (\p. sc_at p s) scopt \ - st_tcb_at runnable t s \ valid_sched_action s \ - pspace_aligned s \ pspace_distinct s \ valid_objs s \ - active_scs_valid s \ current_time_bounded s \ - in_correct_ready_q s \ ready_qs_distinct s \ - ready_or_release s" - in hoare_strengthen_post[rotated]) + apply (rule_tac Q'="\scopt s. case_option True (\p. sc_at p s) scopt + \ st_tcb_at runnable t s \ valid_sched_action s + \ pspace_aligned s \ pspace_distinct s \ valid_objs s + \ active_scs_valid s \ current_time_bounded s + \ in_correct_ready_q s \ ready_qs_distinct s + \ ready_or_release s \ ep_queues_blocked s + \ ntfn_queues_blocked s \ ready_queues_runnable s" + in hoare_post_imp) apply (fastforce split: option.splits simp: obj_at_def is_sc_obj opt_map_red opt_pred_def) apply (wpsimp wp: thread_get_wp' simp: get_tcb_obj_ref_def) apply (clarsimp simp: bool.case_eq_if option.case_eq_if) apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\scopt s. st_tcb_at runnable t s \ valid_sched_action s \ - pspace_aligned s \ pspace_distinct s \ valid_objs s \ - active_scs_valid s \ current_time_bounded s \ - in_correct_ready_q s \ ready_qs_distinct s \ ready_or_release s" - in hoare_strengthen_post[rotated]) + apply (rule_tac Q'="\scopt s. st_tcb_at runnable t s \ valid_sched_action s + \ pspace_aligned s \ pspace_distinct s \ valid_objs s + \ active_scs_valid s \ current_time_bounded s + \ in_correct_ready_q s \ ready_qs_distinct s + \ ready_or_release s \ ep_queues_blocked s + \ ntfn_queues_blocked s \ ready_queues_runnable s" + in hoare_post_imp) apply (fastforce dest: valid_objs_ko_at simp: valid_bound_obj_def valid_obj_def valid_tcb_def) - apply (wpsimp wp: sts_typ_ats set_thread_state_valid_sched_action) + apply (wpsimp wp: sts_typ_ats set_thread_state_valid_sched_action + set_thread_state_ep_queues_blocked_not_queued + set_thread_state_ntfn_queues_blocked_not_queued + set_thread_state_ready_queues_runnable_not_queued) apply (rule hoare_strengthen_post[where Q'="\_ s. tcb_at' t s \ valid_objs' s - \ sym_heap_sched_pointers s - \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s - \ pspace_bounded' s", rotated]) + \ valid_sched_pointers s + \ pspace_aligned' s \ pspace_distinct' s + \ pspace_bounded' s", rotated]) apply (clarsimp simp: gen_obj_at_simps) - apply (wpsimp wp: sts_st_tcb_at'_cases) + apply (wpsimp wp: sts_st_tcb_at'_cases setThreadState_sched_pointers_valid_sched_pointers) apply (rule setThreadState_corres) apply clarsimp apply (wpsimp wp: thread_get_wp threadGet_wp)+ apply (clarsimp simp: obj_at_def is_tcb_def) apply (rename_tac ko, case_tac ko; clarsimp) - apply (clarsimp simp: obj_at'_def valid_tcb_state'_def) + apply (clarsimp simp: in_ep_queue_at_def) done -crunch possibleSwitchTo - for sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - global_interpretation possibleSwitchTo: typ_at_all_props' "possibleSwitchTo target" by typ_at_props' crunch ifCondRefillUnblockCheck for pred_tcb_at'[wp]: "pred_tcb_at' proj P p" - and weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (simp: crunch_simps wp: whileLoop_wp wp_comb: hoare_weaken_pre) - -lemma cancelAllIPC_loop_body_st_tcb_at'_other: - "\\s. st_tcb_at' P t' s \ tcb_at' t' s \ t' \ t\ - cancelAllIPC_loop_body t - \\_. st_tcb_at' P t'\" - apply (clarsimp simp: cancelAllIPC_loop_body_def restartThreadIfNoFault_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp_fwd_skip, wpsimp wp: replyUnlink_st_tcb_at') - apply (wpsimp wp: threadGet_wp) - apply (rule hoare_strengthen_post[where Q'="\_. st_tcb_at' P t'", rotated]) - apply (clarsimp simp: obj_at'_def) - apply (wpsimp wp: sts_st_tcb_at'_cases threadGet_wp)+ - done - -crunch cancelAllIPC_loop_body - for valid_objs'[wp]: valid_objs' - and typ_at'[wp]: "\s. P (typ_at' T p s)" + (simp: crunch_simps wp: whileLoop_wp crunch_wps ignore: threadSet) + +crunch removeAndRestartEPQueuedThread, removeAndRestartNTFNQueuedThread + for typ_at'[wp]: "\s. P (typ_at' T p s)" and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - and valid_sched_pointers[wp]: valid_sched_pointers and pspace_bounded'[wp]: pspace_bounded' - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - (simp: valid_tcb_state'_def crunch_simps wp: whileLoop_wp ignore: updateSchedContext + (simp: crunch_simps wp: whileLoop_wp ignore: updateSchedContext wp: crunch_wps) -global_interpretation cancelAllIPC_loop_body: typ_at_all_props' "cancelAllIPC_loop_body t" - by typ_at_props' - crunch reply_unlink_tcb for in_correct_ready_q[wp]: in_correct_ready_q and ready_qs_distinct[wp]: ready_qs_distinct (rule: in_correct_ready_q_lift ready_qs_distinct_lift) -lemma blocked_on_send_recv_tcb_at_not_runnable: - "blocked_on_send_recv_tcb_at t s \ st_tcb_at (Not \ runnable) t s" +lemma blocked_on_send_not_runnable: + "st_tcb_at is_blocked_on_send t s \ st_tcb_at (Not \ runnable) t s" by (fastforce simp: pred_tcb_at_def obj_at_def vs_all_heap_simps runnable_eq_active) -lemma cancelAllIPC_corres_helper: - "distinct list \ - corres dc - ((\s. \t \ set list. blocked_on_send_recv_tcb_at t s \ t \ idle_thread s - \ reply_unlink_ts_pred t s) - and (valid_sched and valid_objs and pspace_aligned and pspace_distinct - and current_time_bounded and (\s. heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s)))) - ((\s. \t \ set list. tcb_at' t s) - and (valid_objs' and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded')) - (mapM_x cancel_all_ipc_loop_body list) - (mapM_x cancelAllIPC_loop_body list)" - unfolding cancel_all_ipc_loop_body_def cancelAllIPC_loop_body_def - apply (rule_tac S="{t. (fst t = snd t) \ fst t \ set list}" in corres_mapM_x_scheme) - apply clarsimp - apply (rename_tac t) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres], rename_tac st st') - apply (rule_tac P="\s. blocked_on_send_recv_tcb_at t s \ t \ idle_thread s - \ reply_unlink_ts_pred t s \ valid_sched s \ valid_objs s - \ pspace_aligned s \ pspace_distinct s - \ st_tcb_at ((=) st) t s \ current_time_bounded s" - and P'="\s. valid_objs' s - \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s" - in corres_inst) - apply (case_tac "\ep r_opt pl. - st = Structures_A.thread_state.BlockedOnReceive ep r_opt pl") - apply (clarsimp simp: when_def split: option.splits) - apply (intro conjI impI allI; clarsimp simp: isReceive_def) - apply (corresKsimp corres: restart_thread_if_no_fault_corres) - apply (fastforce simp: pred_tcb_at_def obj_at_def is_tcb valid_sched_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF replyUnlinkTcb_corres]) - apply (rule corres_guard_imp) - apply (rule restart_thread_if_no_fault_corres) - apply simp - apply simp - apply (wpsimp wp: reply_unlink_tcb_valid_sched_action) - apply wpsimp - apply clarsimp - apply (frule blocked_on_send_recv_tcb_at_not_runnable) - apply (frule valid_sched_valid_release_q) - apply (frule (1) valid_release_q_not_in_release_q_not_runnable) - apply (fastforce dest: valid_sched_valid_ready_qs - simp: vs_all_heap_simps pred_tcb_at_def obj_at_def - reply_unlink_ts_pred_def) - apply fastforce - apply (prop_tac "\ isReceive st'") - apply (case_tac st; clarsimp simp: isReceive_def) - apply (case_tac st; clarsimp simp: isReceive_def; - (corresKsimp corres: restart_thread_if_no_fault_corres, - frule blocked_on_send_recv_tcb_at_not_runnable, - frule valid_sched_valid_release_q, - frule (1) valid_release_q_not_in_release_q_not_runnable, - fastforce dest: valid_sched_valid_ready_qs)) - apply (wpsimp wp: gts_wp) - apply (wpsimp wp: gts_wp') - apply (clarsimp simp: vs_all_heap_simps obj_at_def is_tcb_def) - apply clarsimp - apply (fold cancel_all_ipc_loop_body_def) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \wpsimp wp: gts_wp simp: cancel_all_ipc_loop_body_def\)?) - apply (wpsimp wp: restart_thread_if_no_fault_tcb_sts_of_other - reply_unlink_tcb_tcb_sts_of_other gts_wp - simp: cancel_all_ipc_loop_body_def) - apply (wpsimp wp: cancel_all_ipc_loop_body_reply_unlink_ts_pred_other) - apply (wpsimp simp: restartThreadIfNoFault_def) - apply (wpsimp wp: cancel_all_ipc_loop_body_valid_sched gts_wp - simp: cancel_all_ipc_loop_body_def) - apply (fold cancelAllIPC_loop_body_def) - apply wpsimp - apply fastforce+ - done +lemma blocked_on_send_recv_not_runnable: + "st_tcb_at is_blocked_on_send_recv t s \ st_tcb_at (Not \ runnable) t s" + by (fastforce simp: pred_tcb_at_def obj_at_def vs_all_heap_simps runnable_eq_active) + +lemma is_blocked_on_ntfn_not_runnable: + "st_tcb_at is_blocked_on_ntfn t s \ st_tcb_at (Not \ runnable) t s" + by (fastforce simp: pred_tcb_at_def obj_at_def vs_all_heap_simps runnable_eq_active) lemmas reply_unlink_tcb_typ_at_lifts[wp] = abs_typ_at_lifts[OF reply_unlink_tcb_typ_at] -lemma in_send_ep_queue_TCBBlockedSend: - "\kheap s epptr = Some (Endpoint (Structures_A.SendEP queue)); t \ set queue; invs s\ - \ (epptr, TCBBlockedSend) \ state_refs_of s t" - apply (prop_tac "valid_ep (Structures_A.SendEP queue) s") - apply (fastforce simp: valid_objs_def valid_obj_def dest!: invs_valid_objs) - apply (clarsimp simp: state_refs_of_def valid_ep_def split: option.splits) - apply (intro conjI impI allI; (fastforce simp: obj_at_def)?) - apply (prop_tac "(t, EPSend) \ state_refs_of s epptr", clarsimp simp: state_refs_of_def) - apply (clarsimp simp: sym_refs_def dest!: invs_sym_refs) - apply (fastforce simp: state_refs_of_def) +lemma endpoint_IdleEPState_split: + "(case epState ep of IdleEPState \ f | _ \ g) = (if epState ep = IdleEPState then f else g)" + apply (cases ep; clarsimp) + by (rename_tac state queue, case_tac state; clarsimp) + +lemma set_endpoint_ep_queues_blocked[wp]: + "\\s. (\p\set (ep_queue ep). st_tcb_at (\st. ep_blocked st = Some ep_ptr) p s) + \ ep_queues_blocked s\ + set_endpoint ep_ptr ep + \\_. ep_queues_blocked\" + apply (wpsimp wp: set_simple_ko_wp) + apply (fastforce simp: ep_queues_blocked_def eps_of_kh_def ep_at_pred_def st_tcb_at_def obj_at_def) done -crunch setEndpoint - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers +crunch set_endpoint + for ready_qs_distinct[wp]: ready_qs_distinct + and ready_queues_runnable[wp]: ready_queues_runnable + (wp: ready_qs_distinct_lift ready_queues_runnable_lift) + +lemma in_ep_queue_at_unique: + "\in_ep_queue_at t ep_ptr s; ep_queues_blocked s\ \ \p. p \ ep_ptr \ \ in_ep_queue_at t p s" + apply (clarsimp simp: in_ep_queue_at_def ep_queued_def obj_at_def ep_queues_blocked_def + st_tcb_at_def) + apply (frule_tac x=ep_ptr in spec) + apply fastforce + done + +lemma tcb_ep_dequeue_not_ep_queued: + "\in_ep_queue_at t ep_ptr and ep_queues_blocked\ + tcb_ep_dequeue t ep_ptr + \\_ s. \ ep_queued t s\" + unfolding tcb_ep_dequeue_def + apply (wpsimp wp: set_simple_ko_wp get_simple_ko_wp) + apply (frule (1) in_ep_queue_at_unique) + apply (clarsimp simp: in_ep_queue_at_def ep_queued_def eps_of_kh_def list.case_eq_if + split: if_splits) + done + +lemma threadGet_return_tcbSchedNexts_of: + "monadic_rewrite False True (tcb_at' t) + (threadGet tcbSchedNext t) (gets (\s. tcbSchedNexts_of s t))" + apply (rule monadic_rewrite_add_return_l) + apply (rule monadic_rewrite_add_return_r) + apply monadic_rewrite_symb_exec_l + apply monadic_rewrite_symb_exec_r + apply (fastforce intro: monadic_rewrite_guard_arg_cong) + apply (wpsimp wp: threadGet_wp)+ + apply (clarsimp simp: obj_at'_def opt_map_red) + done + +lemma reply_unlink_tcb_ep_queues_blocked[wp]: + "\ep_queues_blocked and not ep_queued t\ reply_unlink_tcb t r \\_. ep_queues_blocked\" + unfolding reply_unlink_tcb_def + by (wpsimp wp: set_thread_state_ep_queues_blocked_not_queued gts_wp get_simple_ko_wp + simp: ep_queued_def in_ep_queue_at_def) + +lemma reply_unlink_tcb_ntfn_queues_blocked[wp]: + "\ntfn_queues_blocked and not ntfn_queued t\ reply_unlink_tcb t r \\_. ntfn_queues_blocked\" + unfolding reply_unlink_tcb_def + by (wpsimp wp: set_thread_state_ntfn_queues_blocked_not_queued gts_wp get_simple_ko_wp + simp: ntfn_queued_def in_ntfn_queue_at_def) + +lemma set_reply_ready_queues_runnable[wp]: + "set_reply reply_ptr reply \ready_queues_runnable\" + by (wpsimp wp: ready_queues_runnable_lift) + +lemma reply_unlink_tcb_ready_queues_runnable[wp]: + "\ready_queues_runnable and not_queued t\ reply_unlink_tcb t r \\_. ready_queues_runnable\" + unfolding reply_unlink_tcb_def update_sk_obj_ref_def + by (wpsimp wp: set_thread_state_ready_queues_runnable_not_queued gts_wp wp: get_simple_ko_wp) + +lemma replyUnlink_valid_sched_pointers: + "\\s. valid_sched_pointers s \ \ is_sched_linked tcbPtr s\ + replyUnlink replyPtr tcbPtr + \\_. valid_sched_pointers\" + unfolding replyUnlink_def + by (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers gts_wp') + +lemma set_reply_obj_ref_ep_queued[wp]: + "set_reply_obj_ref update ref new \\s. P (ep_queued t s)\" + by (wpsimp wp: ep_queued_lift) + +crunch reply_unlink_tcb + for ep_queued[wp]: "\s. P (ep_queued t s)" + and ntfn_queued[wp]: "\s. P (ntfn_queued t s)" + (wp: crunch_wps ep_queued_lift simp: ntfn_queued_def in_ntfn_queue_at_def) + +lemma set_endpoint_ntfn_queued[wp]: + "set_endpoint ep_ptr ep \\s. P (ntfn_queued t s)\" + by (wpsimp wp: ntfn_queued_lift) + +lemma tcb_ep_dequeue_ep_queues_blocked[wp]: + "tcb_ep_dequeue t ep_ptr \ep_queues_blocked\" + unfolding tcb_ep_dequeue_def + apply (wpsimp wp: set_endpoint_ep_queues_blocked get_simple_ko_wp) + apply (rename_tac ep p) + apply (clarsimp simp: ep_queues_blocked_def eps_of_kh_def obj_at_def opt_map_def + split: option.splits list.splits) + apply (prop_tac "set (filter ((\) t) (ep_queue ep)) \ set (ep_queue ep)") + apply (rule filter_is_subset) + apply (fastforce simp: removeAll_filter_not_eq) + done + +crunch tcb_ep_dequeue + for ntfn_queued[wp]: "\s. P (ntfn_queued t s)" + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (wp: ntfn_queues_blocked_lift crunch_wps ignore: set_simple_ko) + +lemma is_blocked_on_send_isSend: + "\is_blocked_on_send st; thread_state_relation st st'\ \ isSend st'" + by (cases st; cases st'; clarsimp simp: thread_state_relation_def isSend_def) + +lemma is_blocked_on_receive_isReceive: + "\is_blocked_on_receive st; thread_state_relation st st'\ \ isReceive st'" + by (cases st; cases st'; clarsimp simp: thread_state_relation_def isReceive_def) + +lemma removeAndRestartEPQueuedThread_corres: + "corres dc + (in_ep_queue_at t epptr and not ntfn_queued t and not_queued t and not_in_release_q t + and st_tcb_at is_blocked_on_send_recv t + and reply_unlink_ts_pred t and valid_objs and valid_sched and current_time_bounded + and ep_queues_blocked and ntfn_queues_blocked + and pspace_aligned and pspace_distinct) + (valid_objs' and valid_sched_pointers and sym_heap_sched_pointers) + (remove_and_restart_ep_queued_thread t epptr) + (removeAndRestartEPQueuedThread t epptr)" + supply if_split[split del] + apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) + apply (fastforce intro!: tcb_at_cross) + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) + apply (rule_tac Q'=pspace_bounded' in corres_cross_add_guard) + apply (fastforce intro!: pspace_relation_pspace_bounded') + apply (clarsimp simp: remove_and_restart_ep_queued_thread_def removeAndRestartEPQueuedThread_def) + apply (rule corres_symb_exec_r[OF _ gts_sp']; (solves wpsimp)?) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (fastforce dest!: st_tcb_at_coerce_concrete + is_blocked_on_send_isSend is_blocked_on_receive_isReceive + simp: ep_queues_blocked_def in_ep_queue_at_def st_tcb_at'_def obj_at'_def) + apply (clarsimp simp: maybeM_def) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF tcbEPDequeue_corres], simp, simp) + apply (rule corres_split[OF getThreadState_corres]) + apply (rule corres_stateAssert_r) + apply (rename_tac st st') + apply (rule corres_split[where r'=dc]) + apply (rule corres_option_split) + apply (case_tac st; + clarsimp simp: isReceive_def thread_state_relation_def is_blocked_on_receive_def) + apply (rule corres_return_trivial) + apply (rule replyUnlinkTcb_corres) + apply (rule restartThreadIfNoFault_corres) + apply (wpsimp wp: reply_unlink_tcb_valid_sched_action) + apply (wpsimp wp: replyUnlink_valid_sched_pointers) + apply (wpsimp wp: gts_wp) + apply (wpsimp wp: gts_wp') + apply ((wpsimp wp: tcb_ep_dequeue_not_ep_queued hoare_vcg_imp_lift' hoare_case_option_wp + hoare_vcg_all_lift + | strengthen valid_objs_valid_tcbs)+)[1] + apply (rule_tac Q'="\_ s. valid_objs' s \ valid_sched_pointers s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ \ is_sched_linked t s + \ (\st. st_tcb_at' ((=) st) t s + \ valid_bound_reply' + (if isReceive st then replyObject st else Nothing) s)" + in hoare_post_imp) + apply (clarsimp simp: valid_bound_obj'_def split: if_splits option.splits) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (wpsimp wp: hoare_drop_imps) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (intro conjI impI allI; clarsimp?) + subgoal + by (fastforce simp: is_blocked_on_receive_def vs_all_heap_simps pred_tcb_at_def obj_at_def + reply_unlink_ts_pred_def + split: option.splits if_splits) + apply clarsimp + apply (frule (1) st_tcb_at_coerce_abstract) + apply (clarsimp simp: isReceive_def pred_tcb_at'_def obj_at'_def pred_tcb_at_def obj_at_def) + apply (rename_tac tcb tcb') + apply (case_tac "tcb_state tcb"; clarsimp) + apply (prop_tac "valid_tcb_state (tcb_state tcb) s") + apply (rule st_tcb_at_valid_st2) + apply (fastforce simp: pred_tcb_at_def obj_at_def) + apply fastforce + apply (clarsimp simp: valid_bound_obj'_def split: option.splits) + apply (fastforce intro!: reply_at_cross simp: pred_tcb_at'_def obj_at'_def) + done + +lemma remove_and_restart_ep_queued_thread_valid_idle[wp]: + "\valid_idle and K (t \ idle_thread_ptr)\ + remove_and_restart_ep_queued_thread t epptr + \\_. valid_idle\" + unfolding remove_and_restart_ep_queued_thread_def + apply forward_inv_step + apply (wpsimp wp: gts_wp) + apply (fastforce simp: valid_idle_def) + done + +lemma remove_and_restart_ep_queued_thread_not_queued_other: + "\\s. not_queued t s \ scheduler_act_not t s \ t' \ t\ + remove_and_restart_ep_queued_thread t' epptr + \\_. not_queued t\" + unfolding remove_and_restart_ep_queued_thread_def + apply forward_inv_step + apply (wpsimp wp: gts_wp) + done + +crunch remove_and_restart_ep_queued_thread, remove_and_restart_ntfn_queued_thread, + remove_and_restart_badged_thread + for not_queued[wp]: "not_queued t" + and tcb_at[wp]: "tcb_at t" + (wp: crunch_wps simp: crunch_simps) + +crunch removeAndRestartEPQueuedThread, removeAndRestartNTFNQueuedThread, + removeAndRestartBadgedThread + for valid_objs'[wp]: valid_objs' + (wp: crunch_wps simp: crunch_simps) + +lemma restartThreadIfNoFault_valid_sched_pointers[wp]: + "\\s. valid_sched_pointers s \ \ is_sched_linked t s\ + restartThreadIfNoFault t + \\_. valid_sched_pointers\" + unfolding restartThreadIfNoFault_def + by (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers) + +lemma removeAndRestartEPQueuedThread_valid_sched_pointers[wp]: + "removeAndRestartEPQueuedThread t epptr \valid_sched_pointers\" + unfolding removeAndRestartEPQueuedThread_def + by (wpsimp wp: replyUnlink_valid_sched_pointers hoare_drop_imps) + +lemma removeAndRestartNTFNQueuedThread_valid_sched_pointers[wp]: + "removeAndRestartNTFNQueuedThread t epptr \valid_sched_pointers\" + unfolding removeAndRestartNTFNQueuedThread_def + by (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers hoare_drop_imps) + +lemma removeAndRestartBadgedThread_valid_sched_pointers[wp]: + "removeAndRestartBadgedThread t epptr badge \valid_sched_pointers\" + unfolding removeAndRestartBadgedThread_def + by (wpsimp wp: restartThreadIfNoFault_valid_sched_pointers gts_wp') + +lemma set_endpoint_reply_unlink_ts_pred[wp]: + "set_endpoint ep_ptr ep \reply_unlink_ts_pred p\" + apply (wpsimp wp: set_simple_ko_wp) + apply (fastforce simp: reply_unlink_ts_pred_def reply_at_ppred_def obj_at_def ep_at_pred_def) + done + +lemma set_endpoint_ntfn_queues_blocked[wp]: + "set_endpoint ep_ptr ep \ntfn_queues_blocked\" + by (wpsimp wp: ntfn_queues_blocked_lift) + +lemma tcb_ep_dequeue_in_ep_queue_at_other: + "\\s. P (in_ep_queue_at t epptr s) \ t' \ t\ + tcb_ep_dequeue t' epptr' + \\_ s. P (in_ep_queue_at t epptr s)\" + unfolding tcb_ep_dequeue_def + apply (wpsimp wp: set_simple_ko_wp get_simple_ko_wp) + apply (erule rsubst[where P=P]) + apply (clarsimp simp: removeAll_filter_not_eq in_ep_queue_at_def obj_at_def eps_of_kh_def + opt_map_def + split: list.splits) + apply (rename_tac ep) + apply (intro conjI impI allI) + apply (fastforce dest: empty_filter_conv[THEN iffD1, OF sym]) + apply (intro iffI) + apply (fastforce dest: in_filter_neq) + apply (cut_tac xs="ep_queue ep" and P="(\) t'" in filter_is_subset) + apply fastforce + done + +lemma tcb_ep_dequeue_ep_queued_other: + "\\s. P (ep_queued t s) \ t' \ t\ + tcb_ep_dequeue t' epptr + \\_ s. P (ep_queued t s)\" + unfolding ep_queued_def + apply (insert bool_function_four_cases[where f=P]) + apply (elim disjE; clarsimp; (solves wpsimp)?) + apply (rule hoare_allI) + apply (wpsimp wp: hoare_allI tcb_ep_dequeue_in_ep_queue_at_other[where P=Not]) + apply (rule hoare_ex_pre_conj) + apply (wpsimp wp: hoare_exI tcb_ep_dequeue_in_ep_queue_at_other[where P=id, simplified]) + done + +lemma in_ep_queue_at_lift: + "(\P. f \\s. P (ep_queues_of s)\) \ (\P. f \\s. P (in_ep_queue_at t ep_ptr s)\)" + apply (clarsimp simp: in_ep_queue_at_def) + by (rule hoare_lift_Pf2; wpsimp) + +lemma in_ntfn_queue_at_lift: + "(\P. f \\s. P (ntfn_queues_of s)\) \ (\P. f \\s. P (in_ntfn_queue_at t ep_ptr s)\)" + apply (clarsimp simp: in_ntfn_queue_at_def) + by (rule hoare_lift_Pf2; wpsimp) + +crunch restart_thread_if_no_fault, reply_unlink_tcb + for in_ep_queue_at[wp]: "\s. P (in_ep_queue_at t epptr s)" + and in_ntfn_queue_at[wp]: "\s. P (in_ntfn_queue_at t epptr s)" + and ntfns_of[wp]: "\s. P (ntfns_of s)" + (wp: in_ep_queue_at_lift in_ntfn_queue_at_lift) + +lemma remove_and_restart_ep_queued_thread_in_ep_queue_at_other: + "\\s. in_ep_queue_at t epptr s \ t' \ t\ + remove_and_restart_ep_queued_thread t' epptr + \\_ s. in_ep_queue_at t epptr s\" + unfolding remove_and_restart_ep_queued_thread_def + by (wpsimp wp: tcb_ep_dequeue_in_ep_queue_at_other gts_wp hoare_vcg_all_lift hoare_drop_imps) + +crunch tcb_ep_dequeue, tcb_ep_append + for ntfns_of[wp]: "\s. P (ntfns_of s)" + (wp: crunch_wps ignore: set_simple_ko) + +crunch remove_and_restart_ep_queued_thread, remove_and_restart_badged_thread + for ntfn_queued[wp]: "\s. P (ntfn_queued t s)" + (wp: ntfn_queued_lift crunch_wps) + +crunch if_cond_refill_unblock_check + for ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (wp: ep_queues_blocked_lift ntfn_queues_blocked_lift) + +lemma remove_and_restart_ep_queued_thread_ep_queues_blocked: + "\ep_queues_blocked and in_ep_queue_at t ep_ptr\ + remove_and_restart_ep_queued_thread t ep_ptr + \\_. ep_queues_blocked\" + unfolding remove_and_restart_ep_queued_thread_def restart_thread_if_no_fault_def + by (wpsimp wp: set_thread_state_ep_queues_blocked_not_queued tcb_ep_dequeue_not_ep_queued gts_wp + hoare_vcg_all_lift hoare_drop_imps) + +lemma remove_and_restart_ep_queued_thread_ntfn_queues_blocked: + "\ntfn_queues_blocked and not ntfn_queued t\ + remove_and_restart_ep_queued_thread t ep_ptr + \\_. ntfn_queues_blocked\" + unfolding remove_and_restart_ep_queued_thread_def restart_thread_if_no_fault_def + by (wpsimp wp: set_thread_state_ntfn_queues_blocked_not_queued tcb_ep_dequeue_not_ep_queued gts_wp + hoare_vcg_all_lift hoare_drop_imps) + +lemma removeAndRestartEPQueuedThread_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + removeAndRestartEPQueuedThread t ep_ptr + \\_. sym_heap_sched_pointers\" + unfolding removeAndRestartEPQueuedThread_def restartThreadIfNoFault_def + by (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers + replyUnlink_valid_sched_pointers threadGet_wp hoare_drop_imps hoare_vcg_all_lift) + +lemma removeAndRestartNTFNQueuedThread_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + removeAndRestartNTFNQueuedThread t ep_ptr + \\_. sym_heap_sched_pointers\" + unfolding removeAndRestartNTFNQueuedThread_def + by (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers hoare_drop_imps) + +lemma removeAndRestartBadgedThread_sym_heap_sched_pointers[wp]: + "\sym_heap_sched_pointers and valid_sched_pointers\ + removeAndRestartBadgedThread t ep_ptr badge + \\_. sym_heap_sched_pointers\" + unfolding removeAndRestartBadgedThread_def restartThreadIfNoFault_def + by (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers hoare_drop_imps gts_wp') + +lemma tcbSchedPrev_update_tcbSchedNexts_of[wp]: + "threadSet (tcbSchedPrev_update f) t' \\s. P (tcbSchedNexts_of s t)\" + by (wpsimp wp: threadSet_field_inv) + +lemma tcbSchedNext_update_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t) \ t' \ t\ + threadSet (tcbSchedNext_update f) t' + \\_ s. P (tcbSchedNexts_of s t)\" + by (wpsimp wp: threadSet_wp) + +lemma tcbQueuePrepend_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t) \ t' \ t\ + tcbQueuePrepend q t' + \\_ s. P (tcbSchedNexts_of s t)\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: tcbSchedNext_update_tcbSchedNexts_of_other) + +lemma tcbQueueRemove_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t') \ t \ t' + \ (\ls. heap_ls (tcbSchedNexts_of s) (Some t) ls \ t' \ set ls)\ + tcbQueueRemove q t + \\_ s. P (tcbSchedNexts_of s t')\" + supply heap_path_append[simp del] if_split[split del] + apply (subst conj_assoc[symmetric])+ + apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac ls) + apply (clarsimp simp: tcbQueueRemove_def) + apply (intro bind_wp[OF _ stateAssert_sp]) + apply (clarsimp simp: pred_conj_def) + apply (subst conj_assoc[symmetric])+ + apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac ts) + apply (rule bind_wp[OF _ get_tcb_sp']) + apply (rule hoare_if) + \ \q is a singleton\ + apply wpsimp + apply (rule hoare_if) + \ \t is the head of q\ + apply (wpsimp wp: tcbSchedNext_update_tcbSchedNexts_of_other) + \ \t is not the head of q\ + apply (rule_tac S="\pfx. ts = pfx @ t # tl ls" in hoare_gen_asm_spec) + apply (prop_tac "ls \ []", fastforce) + apply (clarsimp simp: list_queue_relation_def) + apply (frule_tac xs=ls and ys=ts in heap_ls_suffix) + apply fastforce + apply fastforce + apply (force dest!: heap_path_head simp: suffix_def) + apply (clarsimp, rename_tac pfx) + apply (rule_tac P'1="\s. \ptr. tcbSchedPrevs_of s t = Some ptr \ ptr \ set pfx" + in hoare_pre_add[THEN iffD2]) + apply (clarsimp simp: list_queue_relation_def) + apply (frule (1) heap_path_sym_heap_non_nil_lookup_prev) + apply fastforce + apply (fastforce intro: last_in_set simp: opt_map_red) + apply (rule_tac S="t' \ set (tl ls)" in hoare_gen_asm_spec) + apply (clarsimp simp: list_queue_relation_def) + apply (frule_tac xs=ls in heap_path_head) + apply fastforce + apply (case_tac ls; clarsimp) + apply (wpsimp wp: tcbSchedNext_update_tcbSchedNexts_of_other) + apply (fastforce dest: heap_ls_distinct simp: list_queue_relation_def opt_map_def obj_at'_def) + done + +lemma tcbEPDequeue_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t') \ t' \ t + \ (\ls. heap_ls (tcbSchedNexts_of s) (Some t) ls \ t' \ set ls)\ + tcbEPDequeue t epptr + \\_ s. P (tcbSchedNexts_of s t')\" + apply (clarsimp simp: tcbEPDequeue_def) + apply (wpsimp wp: tcbQueueRemove_tcbSchedNexts_of_other getEndpoint_wp) + done + +lemma tcbNTFNDequeue_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t') \ t' \ t + \ ((\ls. heap_ls (tcbSchedNexts_of s) (Some t) ls \ t' \ set ls))\ + tcbNTFNDequeue t ntfnPtr + \\_ s. P (tcbSchedNexts_of s t')\" + apply (clarsimp simp: tcbNTFNDequeue_def) + apply (wpsimp wp: tcbQueueRemove_tcbSchedNexts_of_other getNotification_wp) + done + +lemma tcbSchedEnqueue_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t) \ t' \ t\ + tcbSchedEnqueue t' + \\_ s. P (tcbSchedNexts_of s t)\" + unfolding tcbSchedEnqueue_def + by (wpsimp wp: tcbQueuePrepend_tcbSchedNexts_of_other threadSet_field_inv threadGet_wp) + +lemma rescheduleRequired_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t) \ sch_act_not t s\ + rescheduleRequired + \\_ s. P (tcbSchedNexts_of s t)\" + unfolding rescheduleRequired_def + by (wpsimp wp: tcbSchedEnqueue_tcbSchedNexts_of_other getSchedulable_wp) + +lemma possibleSwitchTo_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t) \ t' \ t \ sch_act_not t s\ + possibleSwitchTo t' + \\_ s. P (tcbSchedNexts_of s t)\" + unfolding possibleSwitchTo_def + by (wpsimp wp: tcbSchedEnqueue_tcbSchedNexts_of_other threadGet_wp + rescheduleRequired_tcbSchedNexts_of_other inReleaseQueue_wp) + +lemma restartThreadIfNoFault_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t) \ t' \ t \ sch_act_not t s\ + restartThreadIfNoFault t' + \\_ s. P (tcbSchedNexts_of s t)\" + unfolding restartThreadIfNoFault_def ifCondRefillUnblockCheck_def + by (wpsimp wp: possibleSwitchTo_tcbSchedNexts_of_other hoare_drop_imps) + +lemma removeAndRestartEPQueuedThread_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t') \ sch_act_not t' s \ t' \ t + \ (\ls. heap_ls (tcbSchedNexts_of s) (Some t) ls \ t' \ set ls)\ + removeAndRestartEPQueuedThread t epptr + \\_ s. P (tcbSchedNexts_of s t')\" + unfolding removeAndRestartEPQueuedThread_def + apply (wpsimp wp: restartThreadIfNoFault_tcbSchedNexts_of_other + tcbEPDequeue_tcbSchedNexts_of_other hoare_drop_imps) + apply fastforce + done + +lemma removeAndRestartNTFNQueuedThread_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t') \ sch_act_not t' s \ t' \ t + \ (\ls. heap_ls (tcbSchedNexts_of s) (Some t) ls \ t' \ set ls)\ + removeAndRestartNTFNQueuedThread t epptr + \\_ s. P (tcbSchedNexts_of s t')\" + unfolding removeAndRestartNTFNQueuedThread_def + apply (wpsimp wp: possibleSwitchTo_tcbSchedNexts_of_other + tcbNTFNDequeue_tcbSchedNexts_of_other hoare_drop_imps) + apply fastforce + done + +lemma removeAndRestartBadgedThread_tcbSchedNexts_of_other: + "\\s. P (tcbSchedNexts_of s t') \ sch_act_not t' s \ t' \ t + \ (\ls. heap_ls (tcbSchedNexts_of s) (Some t) ls \ t' \ set ls)\ + removeAndRestartBadgedThread t epptr badge + \\_ s. P (tcbSchedNexts_of s t')\" + unfolding removeAndRestartBadgedThread_def + apply (wpsimp wp: restartThreadIfNoFault_tcbSchedNexts_of_other + tcbEPDequeue_tcbSchedNexts_of_other gts_wp') + apply fastforce + done lemma cancelAllIPC_corres: - "corres dc (invs and valid_sched and ep_at ep_ptr and current_time_bounded) - (invs' and ep_at' ep_ptr) - (cancel_all_ipc ep_ptr) (cancelAllIPC ep_ptr)" -proof - - have P: - "\list. distinct list \ - corres dc - ((\s. \t \ set list. blocked_on_send_recv_tcb_at t s \ t \ idle_thread s - \ reply_unlink_ts_pred t s) - and (valid_sched and valid_objs and pspace_aligned and pspace_distinct and ep_at ep_ptr - and current_time_bounded and (\s. heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s)))) - ((\s. \t \ set list. tcb_at' t s) - and (valid_objs' and ep_at' ep_ptr - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded')) - (do set_endpoint ep_ptr Structures_A.IdleEP; - mapM_x cancel_all_ipc_loop_body list; - reschedule_required - od) - (do setEndpoint ep_ptr IdleEP; - mapM_x cancelAllIPC_loop_body list; - rescheduleRequired - od)" (is "\list. _ \ corres _ (?abs_guard list) (?conc_guard list) _ _") - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def) + "corres dc + (invs and valid_sched and ep_at ep_ptr and current_time_bounded) invs' + (cancel_all_ipc ep_ptr) (cancelAllIPC ep_ptr)" + apply add_sym_refs + apply add_sch_act_wf + apply (clarsimp simp: cancel_all_ipc_def cancelAllIPC_def) + apply (rule corres_stateAssert_ignore, solves simp)+ + apply (rule corres_stateAssert_ignore) + apply (fastforce intro: ksReadyQueues_asrt_cross) + apply (rule_tac Q'="ep_at' ep_ptr" in corres_cross_add_guard) + apply (fastforce intro!: ep_at_cross) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ep_sp']) + apply (corres corres: getEndpoint_corres) + apply (rename_tac ep ep') + apply (subst endpoint_IdleEP_split) + apply (subst endpoint_IdleEPState_split) + apply (rule corres_if_strong') + apply (clarsimp simp: ep_relation_def split: Structures_A.endpoint.splits) + apply clarsimp + apply (rule_tac F="ep_queue ep \ []" in corres_req) + apply (fastforce dest!: valid_objs_ko_at invs_valid_objs + simp: valid_obj_def valid_ep_def split: Structures_A.endpoint.splits) + apply (rule_tac Q'="\s. list_queue_relation (ep_queue ep) (epQueue ep') + (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + in corres_cross_add_guard) + apply (frule state_relation_ep_queues_relation) + apply (fastforce simp: ep_queues_relation_def opt_map_def eps_of_kh_def obj_at_def obj_at'_def + split: option.splits) + apply (rule_tac F="distinct (ep_queue ep)" in corres_req) + apply (fastforce intro: heap_ls_distinct simp: list_queue_relation_def) + apply (rule corres_symb_exec_l[OF _ _ return_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_r[OF _ return_sp]; (solves wpsimp)?) + apply clarsimp + apply (rule corres_stateAssert_ignore) + apply clarsimp + apply (rule list_queue_relation_tcb_queue_head_end_valid) + apply fastforce + apply (fastforce dest: in_ep_queue_sched_flag_set[rotated] + elim: sym_refs_ep_queues_blocked[OF invs_sym_refs] + simp: eps_of_kh_def opt_map_def obj_at_def + split: option.splits) + apply (rule_tac Q="\_ s. ep_at_pred (\ep. ep = IdleEP) ep_ptr s + \ ep_queues_blocked s \ ntfn_queues_blocked s + \ valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_sched s + \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) + \ current_time_bounded s" + and Q'="\_. valid_tcbs' and valid_sched_pointers" + in corres_split_forwards'[where r'=dc]) + apply (rule stronger_corres_guard_imp) + apply (clarsimp simp: threadGet_def) + apply (subst bind_dummy_ret_val)+ + apply (rule_tac P="\ls s. ep_at_pred (\ep. ep_queue ep = ls) ep_ptr s + \ distinct ls + \ (ls \ [] + \ (\p \ set ls. in_ep_queue_at p ep_ptr s \ \ ntfn_queued p s + \ not_queued p s \ not_in_release_q p s + \ st_tcb_at is_blocked_on_send_recv p s + \ reply_unlink_ts_pred p s)) + \ valid_objs s \ valid_idle s + \ ep_queues_blocked s \ ntfn_queues_blocked s + \ pspace_aligned s \ pspace_distinct s + \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) + \ valid_sched s \ current_time_bounded s" + and P'="\_. valid_objs' and valid_sched_pointers and sym_heap_sched_pointers + and pspace_aligned' and pspace_distinct' and pspace_bounded' + and ep_at' ep_ptr" + in corres_mapM_x_whileLoop[where nexts_of=tcbSchedNexts_of]) + apply (corres corres: removeAndRestartEPQueuedThread_corres) + apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) + apply (wpsimp wp: remove_and_restart_ep_queued_thread_dequeues_head) + apply (clarsimp simp: ep_at_pred_def, rename_tac obj) + apply (case_tac "ep_queue obj"; clarsimp) + apply wpsimp + apply (fastforce elim: distinct_tl) + apply (wpsimp wp: remove_and_restart_ep_queued_thread_dequeues_head + remove_and_restart_ep_queued_thread_other + remove_and_restart_ep_queued_thread_reply_unlink_ts_pred_other + remove_and_restart_ep_queued_thread_in_ep_queue_at_other + hoare_vcg_const_imp_lift hoare_vcg_ball_lift hoare_vcg_all_lift) + apply (fastforce dest!: list.set_sel(2) distinct_hd_not_in_tl + intro: weak_valid_sched_action_scheduler_action_not + blocked_on_send_recv_not_runnable) + apply wpsimp + apply (frule_tac t="hd ls" in not_idle_thread') + apply (fastforce dest: hd_in_set) + apply fastforce + apply (clarsimp simp: valid_idle_def) + apply (wpsimp wp: remove_and_restart_ep_queued_thread_valid_sched + remove_and_restart_ep_queued_thread_ep_queues_blocked + remove_and_restart_ep_queued_thread_ntfn_queues_blocked)+ + apply (rule conjI) + apply (clarsimp simp: obj_at_kh_kheap_simps) + apply (erule not_idle_thread') + apply fastforce + apply fastforce + apply wpsimp + apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_ball_lift + removeAndRestartEPQueuedThread_sym_heap_sched_pointers) + apply wpsimp + apply (rule monadic_rewrite_guard_imp) + apply (rule threadGet_return_tcbSchedNexts_of[simplified threadGet_def]) + apply (force intro!: tcb_at_cross simp: ex_abs_def) + apply wpsimp + apply (force intro!: tcb_at_cross simp: ex_abs_def) + apply (wpsimp wp: removeAndRestartEPQueuedThread_tcbSchedNexts_of_other) + apply (clarsimp simp: ex_abs_def) + apply (rename_tac s' s) + apply (rule conjI) apply clarsimp - apply (rule corres_split) - apply (erule cancelAllIPC_corres_helper) - apply (rule rescheduleRequired_corres) - apply (rule_tac P'="?abs_guard list" in hoare_weaken_pre) - apply (rule hoare_strengthen_post) - apply (rule ball_mapM_x_scheme) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \wpsimp wp: gts_wp simp: cancel_all_ipc_loop_body_def\)?) - apply (wpsimp wp: restart_thread_if_no_fault_tcb_sts_of_other - reply_unlink_tcb_tcb_sts_of_other gts_wp - simp: cancel_all_ipc_loop_body_def) - apply (wpsimp wp: cancel_all_ipc_loop_body_reply_unlink_ts_pred_other) - apply (wpsimp wp: cancel_all_ipc_loop_body_valid_sched gts_wp - simp: cancel_all_ipc_loop_body_def) - apply fastforce - apply (fastforce dest: valid_sched_valid_ready_qs) - apply simp - apply (rule_tac P'="?conc_guard list" in hoare_weaken_pre) - apply (rule hoare_strengthen_post) - apply (rule ball_mapM_x_scheme) - apply (wpsimp wp: cancelAllIPC_loop_body_st_tcb_at'_other) - 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) - done - - show ?thesis - apply (clarsimp simp: cancel_all_ipc_def[folded cancel_all_ipc_loop_body_def] - cancelAllIPC_def[folded restartThreadIfNoFault_def - , folded cancelAllIPC_loop_body_def]) - apply (subst forM_x_def fun_app_def)+ - apply add_sym_refs - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: pred_conj_def sym_refs_asrt_def) - apply add_sch_act_wf - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: sch_act_wf_asrt_def) - apply (rule corres_stateAssert_ignore) - apply (fastforce intro: ksReadyQueues_asrt_cross) - apply (rule corres_underlying_split[OF _ _ get_simple_ko_sp get_ep_sp']) - apply (rule corres_guard_imp [OF getEndpoint_corres]; - simp add: ep_relation_def get_ep_queue_def) - apply (rename_tac ep ep') - apply (case_tac "ep = Structures_A.IdleEP \ ep' = Structures_H.IdleEP") - apply (case_tac ep; case_tac ep'; simp add: ep_relation_def get_ep_queue_def) - apply (simp add: endpoint.case_eq_if Structures_A.endpoint.case_eq_if del: K_bind_def) - apply (simp add: get_ep_queue_def Structures_A.endpoint.case_eq_if) - apply (rule_tac F="epQueue ep' = ep_queue ep \ distinct (ep_queue ep)" in corres_req) - apply (rule conjI; clarsimp) - apply (case_tac ep; clarsimp simp: ep_relation_def) - apply (drule (1) valid_objs_ko_at[OF invs_valid_objs]) - apply (case_tac ep; clarsimp simp: valid_obj_def valid_ep_def) - apply simp - apply (rule corres_guard_imp) - apply (rule P[simplified]) - apply simp - apply (clarsimp; rule conjI; (fastforce simp: invs_def)?) - apply clarsimp - apply (prop_tac "t \ idle_thread s") - apply (case_tac ep; - fastforce simp: obj_at_def invs_def valid_state_def valid_pspace_def - dest!: not_idle_tcb_in_SendEp not_idle_tcb_in_RecvEp) - apply (prop_tac "st_tcb_at is_blocked_on_send_recv t s") - apply (case_tac ep; erule_tac t=t in ep_queued_st_tcb_at; (fastforce simp: invs_def)?) - apply (clarsimp simp: pred_tcb_at_disj tcb_at_kh_simps[symmetric] reply_unlink_ts_pred_def - conj_disj_distribR is_blocked_on_receive_def is_blocked_on_send_def) - apply (fastforce simp: pred_tcb_at_def obj_at_def - elim!: st_tcb_recv_reply_state_refs[OF _ invs_sym_refs, simplified op_equal]) - apply (clarsimp simp: invs'_def valid_pspace'_def valid_objs'_valid_tcbs') - apply (fastforce dest!: ep_ko_at_valid_objs_valid_ep' simp: valid_ep'_def split: endpoint.split_asm) - done -qed + apply (prop_tac "scheduler_action s = switch_thread t'") + apply (drule state_relation_sched_act_relation) + apply (clarsimp simp: sched_act_relation_def) + apply (case_tac "scheduler_action s"; clarsimp) + apply (fastforce dest!: valid_sched_weak_valid_sched_action + weak_valid_sched_action_scheduler_action_not + intro: blocked_on_send_recv_not_runnable simp: scheduler_act_not_def) + apply (frule state_relation_ep_queues_relation) + apply (clarsimp simp: ep_queues_relation_def) + apply (fastforce simp: list_queue_relation_def) + apply clarsimp + apply (rename_tac s s') + apply (frule invs_sym_refs) + apply (frule sym_refs_ep_queues_blocked) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (prop_tac "ep_queues_of s ep_ptr = Some (ep_queue ep)") + apply (fastforce simp: opt_map_def eps_of_kh_def obj_at_def split: option.splits) + apply (prop_tac "\p \ set (ep_queue ep). st_tcb_at is_blocked_on_send_recv p s") + apply (clarsimp simp: ep_queues_blocked_def) + apply (drule_tac x=ep_ptr in spec) + apply (drule_tac x="ep_queue ep" in spec) + apply (fastforce elim!: st_tcb_weakenE simp: ep_blocked_def + split: Structures_A.thread_state.splits) + apply (intro conjI impI allI; fastforce?) + apply (force simp: ep_at_pred_def obj_at_def) + apply (clarsimp simp: in_ep_queue_at_def) + apply (intro conjI impI allI) + apply (force dest: ep_queues_ntfn_queues_disjoint + simp: in_ntfn_queue_at_def ntfn_queued_def) + apply (clarsimp simp: not_queued_def) + apply (force dest!: ep_queues_ready_queues_disjoint) + apply (clarsimp simp: not_in_release_q_def) + apply (fastforce dest!: ep_queues_release_queue_disjoint) + apply (fastforce simp: reply_unlink_ts_pred_def simp flip: tcb_at_kh_simps + elim!: st_tcb_recv_reply_state_refs[OF _ invs_sym_refs, simplified op_equal]) + apply (fastforce simp: list_queue_relation_def) + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule hoare_weaken_pre) + apply (rule mapM_x_inv_wp2[ + where I=valid_objs + and V="\xs. ep_at_pred (\ep. ep_queue ep = xs) ep_ptr"]) + apply (force simp: ep_at_pred_def valid_obj_def valid_ep_def + split: Structures_A.endpoint.splits) + apply (wpsimp wp: remove_and_restart_ep_queued_thread_dequeues_head) + apply (force simp: ep_at_pred_def valid_obj_def valid_ep_def + split: Structures_A.endpoint.splits) + apply (fastforce simp: ep_at_pred_def obj_at_def) + apply (rule_tac S="distinct queue" in hoare_gen_asm_spec, fastforce) + apply (rule hoare_weaken_pre) + apply (rule_tac Q="\t s. in_ep_queue_at t ep_ptr s \ \ ntfn_queued t s + \ not_queued t s \ not_in_release_q t s \ scheduler_act_not t s + \ st_tcb_at is_blocked_on_send_recv t s \ t \ idle_thread s" + in ball_mapM_x_scheme) + apply (wpsimp wp: remove_and_restart_ep_queued_thread_other remove_and_restart_ep_queued_thread_in_ep_queue_at_other) + apply ((wpsimp wp: remove_and_restart_ep_queued_thread_other + remove_and_restart_ep_queued_thread_valid_sched + remove_and_restart_ep_queued_thread_ep_queues_blocked + remove_and_restart_ep_queued_thread_ntfn_queues_blocked + | strengthen valid_objs_valid_tcbs)+)[1] + apply (clarsimp simp: obj_at_kh_kheap_simps) + apply fastforce + apply (clarsimp simp: valid_ep_def cong: conj_cong) + apply (rename_tac s) + apply (frule invs_sym_refs) + apply (frule sym_refs_ep_queues_blocked) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (prop_tac "ep_queues_of s ep_ptr = Some (ep_queue ep)") + apply (fastforce simp: opt_map_def eps_of_kh_def obj_at_def split: option.splits) + apply (prop_tac "\p \ set (ep_queue ep). st_tcb_at is_blocked_on_send_recv p s") + apply (clarsimp simp: ep_queues_blocked_def) + apply (drule_tac x=ep_ptr in spec) + apply (drule_tac x="ep_queue ep" in spec) + apply (fastforce elim!: st_tcb_weakenE simp: ep_blocked_def + split: Structures_A.thread_state.splits) + apply (intro conjI impI allI ballI; fastforce?) + apply (force simp: in_ep_queue_at_def ep_at_pred_def obj_at_def) + apply (clarsimp simp: in_ep_queue_at_def) + apply (force dest: ep_queues_ntfn_queues_disjoint + simp: in_ntfn_queue_at_def ntfn_queued_def) + apply (clarsimp simp: not_queued_def) + apply (force dest!: ep_queues_ready_queues_disjoint) + apply (clarsimp simp: not_in_release_q_def) + apply (fastforce dest!: ep_queues_release_queue_disjoint) + apply (fastforce intro: weak_valid_sched_action_scheduler_action_not + blocked_on_send_recv_not_runnable) + apply (rule not_idle_thread', fastforce+) + apply (rule_tac Q'="\_. pspace_aligned' and pspace_distinct' and pspace_bounded' + and valid_objs' and valid_sched_pointers and sym_heap_sched_pointers" + in hoare_post_imp) + apply fastforce + apply (wpsimp wp: whileLoop_valid_inv) + apply fastforce + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ get_ep_sp', rotated]; (solves wpsimp)?) + apply wpsimp + apply (force intro: ep_at_cross simp: ex_abs_def ep_at_pred_def obj_at_def is_ep_def) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (frule state_relation_pspace_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation heap_pspace_relation_def + map_relation_def eps_of_kh_def opt_map_def obj_at'_def ep_at_pred_def + ep_relation_def + split: option.splits Structures_A.endpoint.splits) + apply (corres corres: rescheduleRequired_corres) + apply (frule valid_sched_valid_ready_qs) + apply (fastforce dest: valid_sched_valid_release_q) + apply fastforce + done lemma blocked_on_recv_ntfn_tcb_at_not_runnable: "blocked_on_recv_ntfn_tcb_at t s \ st_tcb_at (Not \ runnable) t s" @@ -2588,117 +3586,124 @@ lemma valid_tcbs_ko_at: "valid_tcbs s \ ko_at (TCB tcb) ptr s \ valid_tcb ptr tcb s" by (auto simp: valid_tcbs_def obj_at_def) -lemma ntfn_cancel_corres_helper: +crunch tcb_ntfn_dequeue + for ep_queued[wp]: "\s. P (ep_queued t s)" + and ep_queues_blocked[wp]: ep_queues_blocked + (wp: ep_queues_blocked_lift ep_queued_lift crunch_wps ignore: set_simple_ko) + +lemma set_notification_ntfn_queues_blocked[wp]: + "\\s. (\p\set (ntfn_queue (ntfn_obj ntfn)). st_tcb_at (\st. ntfn_blocked st = Some ntfn_ptr) p s) + \ ntfn_queues_blocked s\ + set_notification ntfn_ptr ntfn + \\_. ntfn_queues_blocked\" + apply (wpsimp wp: set_simple_ko_wp) + apply (fastforce simp: ntfn_queues_blocked_def ntfn_at_pred_def st_tcb_at_def obj_at_def) + done + +lemma tcb_ntfn_dequeue_ntfn_queues_blocked[wp]: + "tcb_ntfn_dequeue t ntfn_ptr \ntfn_queues_blocked\" + unfolding tcb_ntfn_dequeue_def + apply (wpsimp wp: get_simple_ko_wp) + apply (clarsimp simp: ntfn_queues_blocked_def obj_at_def opt_map_def split: list.splits) + apply (rename_tac ntfn p head tail) + apply (cut_tac xs="ntfn_queue (ntfn_obj ntfn)" and P="(\) t" in filter_is_subset) + apply (fastforce simp: removeAll_filter_not_eq split: ntfn.splits) + done + +lemma in_ntfn_queue_at_unique: + "\in_ntfn_queue_at t ntfn_ptr s; ntfn_queues_blocked s\ + \ \p. p \ ntfn_ptr \ \ in_ntfn_queue_at t p s" + apply (clarsimp simp: in_ntfn_queue_at_def obj_at_def ntfn_queues_blocked_def st_tcb_at_def) + apply (frule_tac x=ntfn_ptr in spec) + apply fastforce + done + +lemma tcb_ntfn_dequeue_not_ntfn_queued: + "\in_ntfn_queue_at t ntfn_ptr and ntfn_queues_blocked\ + tcb_ntfn_dequeue t ntfn_ptr + \\_ s. \ ntfn_queued t s\" + unfolding tcb_ntfn_dequeue_def + apply (wpsimp wp: set_simple_ko_wp get_simple_ko_wp) + apply (frule (1) in_ntfn_queue_at_unique) + apply (force simp: in_ntfn_queue_at_def ntfn_queued_def list.case_eq_if split: if_splits) + done + +lemma is_blocked_on_ntfn_isBlockedOnNtfn: + "\is_blocked_on_ntfn st; thread_state_relation st st'\ \ isBlockedOnNtfn st'" + by (cases st; cases st'; clarsimp simp: thread_state_relation_def isBlockedOnNtfn_def) + +lemma removeAndRestartNTFNQueuedThread_corres: "corres dc - ((\s. \t \ set list. tcb_at t s \ t \ idle_thread s - \ blocked_on_recv_ntfn_tcb_at t s) - and valid_sched - and valid_objs - and pspace_aligned - and pspace_distinct and (\s. heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s)) - and cur_tcb and current_time_bounded - and K (distinct list)) - ((\s. \t \ set list. tcb_at' t s) - and valid_objs' and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded') - (mapM_x (\t. do y \ set_thread_state t Structures_A.Restart; - sc_opt <- get_tcb_obj_ref tcb_sched_context t; - y <- if_sporadic_cur_sc_assert_refill_unblock_check sc_opt; - possible_switch_to t - od) list) - (mapM_x (\t. do y \ setThreadState Structures_H.thread_state.Restart t; - scOpt <- threadGet tcbSchedContext t; - y <- ifCondRefillUnblockCheck scOpt (Some False) (Some True); - possibleSwitchTo t - od) list)" - (is "corres _ _ ?conc_guard _ _") - apply (rule corres_gen_asm') - apply (rule corres_cross_over_guard[where Q="?conc_guard and cur_tcb'"]) - apply (fastforce simp: cur_tcb_cross) - apply (subst pred_conj_assoc[symmetric])+ - apply (rule_tac S="{t. (fst t = snd t) \ fst t \ set list}" in corres_mapM_x_scheme; - ((subst pred_conj_assoc)+)?) - apply clarsimp - apply (rule corres_guard_imp) - apply (rename_tac tp) - apply (rule corres_split[OF setThreadState_corres]) - apply clarsimp - apply (rule corres_split_eqr[OF get_tcb_obj_ref_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split[OF ifCondRefillUnblockCheck_corres]) - apply (rule possibleSwitchTo_corres, simp) - apply (wpsimp simp: if_cond_refill_unblock_check_def - wp: refill_unblock_check_active_scs_valid) - apply wpsimp - apply (wpsimp wp: get_tcb_obj_ref_wp) - apply (wpsimp wp: threadGet_wp) - apply (clarsimp cong: conj_cong imp_cong all_cong) - apply (rule_tac Q'="\_. pspace_aligned and pspace_distinct and current_time_bounded - and active_scs_valid and valid_objs - and in_correct_ready_q and ready_qs_distinct - and ready_or_release - and valid_sched_action and tcb_at tp and st_tcb_at runnable tp" + (in_ntfn_queue_at t ntfnPtr and not ep_queued t and not_queued t and not_in_release_q t + and tcb_at t and valid_objs and valid_sched and current_time_bounded + and ep_queues_blocked and ntfn_queues_blocked + and pspace_aligned and pspace_distinct) + (valid_objs' and valid_sched_pointers and sym_heap_sched_pointers and pspace_bounded') + (remove_and_restart_ntfn_queued_thread t ntfnPtr) + (removeAndRestartNTFNQueuedThread t ntfnPtr)" + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest!: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest!: pspace_distinct_cross) + apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) + apply (fastforce intro!: tcb_at_cross) + apply (clarsimp simp: remove_and_restart_ntfn_queued_thread_def removeAndRestartNTFNQueuedThread_def) + apply (rule corres_symb_exec_r[OF _ gts_sp']; (solves wpsimp)?) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (clarsimp simp: ntfn_queues_blocked_def in_ntfn_queue_at_def st_tcb_at'_def obj_at'_def) + apply (rename_tac q tcb) + apply (drule_tac x=ntfnPtr in spec) + apply (drule_tac x=q in spec) + apply clarsimp + apply (drule_tac x=t in bspec, fastforce) + apply (frule (3) st_tcb_at_coerce_concrete) + apply (clarsimp simp: st_tcb_at_def obj_at_def st_tcb_at'_def obj_at'_def ntfn_blocked_def) + apply (rule_tac st=st in is_blocked_on_ntfn_isBlockedOnNtfn) + apply (fastforce split: Structures_A.thread_state.splits) + apply (fastforce simp: st_tcb_at_def obj_at_def ntfn_queues_blocked_def in_ntfn_queue_at_def) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF tcbNTFNDequeue_corres], simp, simp) + apply (rule corres_split[OF setThreadState_corres]) + apply clarsimp + apply (rule corres_split_eqr[OF get_tcb_obj_ref_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_split[OF ifCondRefillUnblockCheck_corres]) + apply (rule possibleSwitchTo_corres, simp) + apply (wpsimp simp: if_cond_refill_unblock_check_def + wp: refill_unblock_check_active_scs_valid) + apply wpsimp + apply (wpsimp wp: get_tcb_obj_ref_wp) + apply (wpsimp wp: threadGet_wp) + apply (clarsimp cong: conj_cong imp_cong all_cong) + apply (rule_tac Q'="\_. pspace_aligned and pspace_distinct and current_time_bounded + and active_scs_valid and valid_objs + and in_correct_ready_q and ready_qs_distinct + and ready_or_release + and valid_sched_action and tcb_at t and st_tcb_at runnable t + and ep_queues_blocked and ntfn_queues_blocked + and ready_queues_runnable" in hoare_strengthen_post[rotated]) - apply clarsimp - apply (frule valid_objs_valid_tcbs) - apply (frule (1) valid_tcbs_ko_at) - apply (fastforce dest: valid_tcbs_ko_at - simp: is_sc_obj obj_at_def opt_map_red valid_tcb_def opt_pred_def - split: option.splits) - apply (wp set_thread_state_valid_sched_action) - apply (simp add: option.case_eq_if bool.case_eq_if) - apply (rule_tac Q'="\_. valid_objs' and tcb_at' tp - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded'" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_objs'_valid_tcbs' obj_at'_def) - apply (wp setThreadState_st_tcb) - apply (fastforce dest: valid_sched_valid_ready_qs) - apply (clarsimp simp: in_release_q_def) - apply (clarsimp simp: valid_tcb_state'_def) - apply (wpsimp wp: set_thread_state_pred_map_tcb_sts_of) - apply wpsimp - apply (clarsimp simp: pred_conj_def) - apply (rename_tac tp) - apply (wpsimp wp: get_tcb_obj_ref_wp possible_switch_to_valid_sched_weak hoare_vcg_imp_lift') - apply (rule_tac Q'="\_ s. tcb_at tp s \ - (bound (tcb_scps_of s tp) \ not_in_release_q tp s) - \ current_time_bounded s - \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) - \ (pred_map (\a. \y. a = Some y) (tcb_scps_of s) tp - \ not_in_release_q tp s - \ pred_map runnable (tcb_sts_of s) tp - \ released_sc_tcb_at tp s - \ active_scs_valid s - \ tp \ idle_thread s) - \ pspace_distinct s \ cur_tcb s \ valid_objs s - \ pspace_aligned s - \ valid_sched_except_blocked s - \ valid_blocked_except tp s" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: obj_at_def is_tcb vs_all_heap_simps opt_map_red) - apply (rename_tac scp t tcb' sc n) - apply (clarsimp simp: heap_refs_inv_def2) - apply (frule_tac x=tp and y=scp in spec2) - apply (drule_tac x=t and y=scp in spec2) - apply (clarsimp simp: pred_map_eq vs_all_heap_simps opt_map_red) - apply (wpsimp wp: set_thread_state_pred_map_tcb_sts_of possible_switch_to_valid_sched_weak - set_thread_state_break_valid_sched[simplified pred_conj_def] - hoare_vcg_imp_lift') - apply clarsimp - apply (rule conjI, clarsimp simp: tcb_at_kh_simps[symmetric]) - apply (drule valid_release_q_not_in_release_q_not_runnable[OF valid_sched_valid_release_q]) - apply (erule pred_tcb_weakenE) - apply (clarsimp simp: is_blocked_thread_state_defs) - apply (case_tac "itcb_state tcb"; simp) apply clarsimp + apply (frule valid_objs_valid_tcbs) + apply (frule (1) valid_tcbs_ko_at) + apply (fastforce simp: is_sc_obj obj_at_def opt_map_red valid_tcb_def opt_pred_def + split: option.splits) + apply (wp set_thread_state_valid_sched_action set_thread_state_ep_queues_blocked_not_queued + set_thread_state_ntfn_queues_blocked_not_queued + set_thread_state_ready_queues_runnable_not_queued) + apply (simp add: option.case_eq_if) + apply (rule_tac Q'="\_. valid_objs' and tcb_at' t + and sym_heap_sched_pointers and valid_sched_pointers + and pspace_aligned' and pspace_distinct' and pspace_bounded'" + in hoare_strengthen_post[rotated]) apply clarsimp - apply (rule conjI) - apply (frule valid_sched_released_ipc_queues) - apply (fastforce simp: released_ipc_queues_defs vs_all_heap_simps) - apply (erule valid_sched_active_scs_valid) - apply (wpsimp wp: hoare_vcg_const_Ball_lift sts_st_tcb') - apply (auto simp: valid_tcb_state'_def) + apply (wp setThreadState_st_tcb setThreadState_sched_pointers_valid_sched_pointers) + apply (wpsimp wp: set_thread_state_pred_map_tcb_sts_of tcb_ntfn_dequeue_not_ntfn_queued) + apply (wp | strengthen valid_objs'_valid_tcbs')+ + apply clarsimp + apply (frule valid_sched_valid_ready_qs) + apply (fastforce dest: valid_sched_valid_release_q) + apply clarsimp done lemma refill_unblock_check_weak_valid_sched_action[wp]: @@ -2715,84 +3720,268 @@ crunch if_cond_refill_unblock_check and ready_qs_distinct[wp]: ready_qs_distinct (simp: crunch_simps) +crunch tcb_ntfn_dequeue, tcb_ntfn_append + for eps_of[wp]: "\s. P (eps_of s)" + (wp: crunch_wps ignore: set_simple_ko) + +crunch remove_and_restart_ntfn_queued_thread + for ep_queued[wp]: "\s. P (ep_queued t s)" + (wp: ep_queued_lift) + +lemma in_ntfn_queue_at_in_ntfn_queue_at_other: + "\\s. in_ntfn_queue_at t ntfn_ptr s \ t' \ t\ + tcb_ntfn_dequeue t' ntfn_ptr + \\_ s. in_ntfn_queue_at t ntfn_ptr s\" + unfolding tcb_ntfn_dequeue_def + apply (wpsimp wp: set_simple_ko_wp get_simple_ko_wp) + apply (clarsimp simp: removeAll_filter_not_eq in_ntfn_queue_at_def obj_at_def opt_map_def + split: list.splits) + apply (intro conjI impI allI) + using empty_filter_conv apply fastforce + apply (fastforce dest: in_filter_neq[where t=t and t'=t']) + done + +lemma remove_and_restart_ntfn_queued_thread_in_ntfn_queue_at_other: + "\\s. in_ntfn_queue_at t ntfn_ptr s \ t' \ t\ + remove_and_restart_ntfn_queued_thread t' ntfn_ptr + \\_. in_ntfn_queue_at t ntfn_ptr\" + unfolding remove_and_restart_ntfn_queued_thread_def + by (wpsimp wp: in_ntfn_queue_at_in_ntfn_queue_at_other) + +lemma remove_and_restart_ntfn_queued_thread_ep_queues_blocked: + "\ep_queues_blocked and not ep_queued t\ + remove_and_restart_ntfn_queued_thread t ep_ptr + \\_. ep_queues_blocked\" + unfolding remove_and_restart_ntfn_queued_thread_def restart_thread_if_no_fault_def + by (wpsimp wp: set_thread_state_ep_queues_blocked_not_queued) + +lemma remove_and_restart_ntfn_queued_thread_ntfn_queues_blocked: + "\ntfn_queues_blocked and in_ntfn_queue_at t ntfn_ptr\ + remove_and_restart_ntfn_queued_thread t ntfn_ptr + \\_. ntfn_queues_blocked\" + unfolding remove_and_restart_ntfn_queued_thread_def restart_thread_if_no_fault_def + by (wpsimp wp: set_thread_state_ntfn_queues_blocked_not_queued tcb_ntfn_dequeue_not_ntfn_queued) + +lemma tcb_ntfn_dequeue_isActive[wp]: + "tcb_ntfn_dequeue tcb_ptr ntfn_ptr \ntfn_at_pred (\ntfn. P (isActive ntfn)) ntfn_ptr\" + unfolding tcb_ntfn_dequeue_def + apply (wpsimp wp: set_simple_ko_wp get_simple_ko_wp) + apply (fastforce simp: isActive_def ntfn_at_pred_def obj_at_def split: ntfn.splits list.splits) + done + +lemma remove_and_restart_ntfn_queued_thread_isActive[wp]: + "remove_and_restart_ntfn_queued_thread tcb_ptr ntfn_ptr \ntfn_at_pred (\ntfn. P (isActive ntfn)) ntfn_ptr\" + by (wpsimp simp: remove_and_restart_ntfn_queued_thread_def) + lemma cancelAllSignals_corres: - "corres dc (invs and valid_sched and ntfn_at ntfn and current_time_bounded) - (invs' and ntfn_at' ntfn) - (cancel_all_signals ntfn) (cancelAllSignals ntfn)" + "corres dc + (invs and valid_sched and ntfn_at ntfn_ptr and current_time_bounded) invs' + (cancel_all_signals ntfn_ptr) (cancelAllSignals ntfn_ptr)" apply add_sch_act_wf - 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_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. 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 - set_notification_valid_sched)+ - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) + apply (rule corres_cross_add_guard[where Q'="ntfn_at' ntfn_ptr"]) + apply (fastforce intro!: ntfn_at_cross) + apply (simp add: cancel_all_signals_def cancelAllSignals_def) + apply (rule corres_stateAssert_ignore, solves simp)+ + apply (rule corres_stateAssert_ignore) + apply (fastforce intro: ksReadyQueues_asrt_cross) + apply (rule corres_underlying_split[OF _ _ get_simple_ko_sp get_ntfn_sp']) + apply (corres corres: getNotification_corres) + apply fastforce + apply fastforce + apply (rename_tac ntfn ntfn') + apply (case_tac "ntfn_obj ntfn", simp_all add: ntfn_relation_def) + apply (rule_tac F="ntfn_queue (ntfn_obj ntfn) \ []" in corres_req) + apply (fastforce dest!: valid_objs_ko_at invs_valid_objs simp: valid_obj_def valid_ntfn_def) + apply (rename_tac queue) + apply (rule_tac Q'="\s. list_queue_relation + queue (ntfnQueue ntfn') (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + in corres_cross_add_guard) + apply (frule state_relation_ntfn_queues_relation) + apply (fastforce simp: ntfn_queues_relation_def opt_map_def obj_at_def obj_at'_def + split: option.splits) + apply (rule_tac F="distinct queue" in corres_req) + apply (fastforce intro: heap_ls_distinct simp: list_queue_relation_def) + apply (rule corres_stateAssert_ignore) + apply (rule list_queue_relation_tcb_queue_head_end_valid) + apply fastforce + apply (fastforce dest: in_ntfn_queue_sched_flag_set[rotated] + elim: sym_refs_ntfn_queues_blocked[OF invs_sym_refs] + simp: eps_of_kh_def opt_map_def obj_at_def + split: option.splits) + apply (rule_tac Q="\_ s. ntfn_at_pred (\ntfn. ntfn_obj ntfn = IdleNtfn) ntfn_ptr s + \ ep_queues_blocked s \ ntfn_queues_blocked s + \ valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_sched s + \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) + \ current_time_bounded s" + and Q'="\_. valid_tcbs' and valid_sched_pointers" + in corres_split_forwards'[where r'=dc]) + apply (rule stronger_corres_guard_imp) + apply (clarsimp simp: threadGet_def) + apply (subst bind_dummy_ret_val)+ + apply (rule_tac P="\ls s. ntfn_at_pred (\ntfn. ntfn_queue (ntfn_obj ntfn) = ls) ntfn_ptr s + \ distinct ls + \ (ls \ [] + \ (\p \ set ls. in_ntfn_queue_at p ntfn_ptr s + \ \ ep_queued p s + \ not_queued p s \ not_in_release_q p s + \ st_tcb_at is_blocked_on_ntfn p s)) + \ valid_objs s \ valid_idle s + \ ep_queues_blocked s \ ntfn_queues_blocked s + \ pspace_aligned s \ pspace_distinct s + \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) + \ valid_sched s \ current_time_bounded s" + and P'="\_. valid_objs' and valid_sched_pointers and sym_heap_sched_pointers + and pspace_aligned' and pspace_distinct' and pspace_bounded' + and ntfn_at' ntfn_ptr" + in corres_mapM_x_whileLoop[where nexts_of=tcbSchedNexts_of]) + apply (rule corres_guard_imp) + apply (rule removeAndRestartNTFNQueuedThread_corres) + apply (fastforce dest: valid_sched_valid_release_q) + apply fastforce + apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) + apply (wpsimp wp: remove_and_restart_ntfn_queued_thread_dequeues_head) + apply (clarsimp simp: ntfn_at_pred_def, rename_tac obj) + apply (case_tac "ntfn_queue (ntfn_obj obj)"; clarsimp) + apply wpsimp + apply (fastforce elim: distinct_tl) + apply (wpsimp wp: remove_and_restart_ntfn_queued_thread_dequeues_head + remove_and_restart_ntfn_queued_thread_other + remove_and_restart_ntfn_queued_thread_in_ntfn_queue_at_other + hoare_vcg_const_imp_lift hoare_vcg_ball_lift) + apply (fastforce dest!: list.set_sel(2) distinct_hd_not_in_tl + intro: weak_valid_sched_action_scheduler_action_not + is_blocked_on_ntfn_not_runnable) + apply wpsimp + apply (frule_tac t="hd ls" in not_idle_thread') + apply (fastforce dest: hd_in_set) + apply fastforce + apply (clarsimp simp: valid_idle_def) + apply (wpsimp wp: remove_and_restart_ntfn_queued_thread_valid_sched + remove_and_restart_ntfn_queued_thread_ep_queues_blocked + remove_and_restart_ntfn_queued_thread_ntfn_queues_blocked)+ + apply (rule conjI) + apply (force simp: obj_at_kh_kheap_simps vs_all_heap_simps) + apply (erule not_idle_thread') + apply fastforce + apply fastforce + apply wpsimp + apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_ball_lift) + apply wpsimp + apply (rule monadic_rewrite_guard_imp) + apply (rule threadGet_return_tcbSchedNexts_of[simplified threadGet_def]) + apply (force intro!: tcb_at_cross simp: ex_abs_def) + apply wpsimp + apply (force intro!: tcb_at_cross simp: ex_abs_def) + apply (wpsimp wp: removeAndRestartNTFNQueuedThread_tcbSchedNexts_of_other) + apply (clarsimp simp: ex_abs_def) + apply (rename_tac s) + apply (rule conjI) + apply clarsimp + apply (prop_tac "scheduler_action s = switch_thread t'") + apply (drule state_relation_sched_act_relation) + apply (clarsimp simp: sched_act_relation_def) + apply (case_tac "scheduler_action s"; clarsimp) + apply (fastforce dest!: valid_sched_weak_valid_sched_action + weak_valid_sched_action_scheduler_action_not + intro: is_blocked_on_ntfn_not_runnable simp: scheduler_act_not_def) + apply (frule state_relation_ntfn_queues_relation) + apply (clarsimp simp: ntfn_queues_relation_def) + apply (drule_tac x=ntfn_ptr in spec) + apply (fastforce simp: list_queue_relation_def) + apply (clarsimp cong: conj_cong) + apply (rename_tac s s') + apply (frule invs_sym_refs) + apply (frule sym_refs_ntfn_queues_blocked) + apply (frule sym_refs_ep_queues_blocked) 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 (frule valid_sched_valid_release_q) + apply (prop_tac "ntfn_queues_of s ntfn_ptr = Some queue") + apply (fastforce simp: opt_map_def obj_at_def split: option.splits) + apply (prop_tac "\p \ set queue. st_tcb_at is_blocked_on_ntfn p s") + apply (clarsimp simp: ntfn_queues_blocked_def) + apply (drule_tac x=ntfn_ptr in spec) + apply (drule_tac x=queue in spec) + apply (fastforce elim!: st_tcb_weakenE simp: ntfn_blocked_def + split: Structures_A.thread_state.splits) + apply (intro conjI impI allI ballI; fastforce?) + apply (force simp: ntfn_at_pred_def obj_at_def) + apply (force dest: ep_queues_ntfn_queues_disjoint simp: in_ntfn_queue_at_def ntfn_queued_def) + apply (force dest: ep_queues_ntfn_queues_disjoint simp: in_ep_queue_at_def ep_queued_def) + apply (clarsimp simp: not_queued_def) + apply (force dest!: ntfn_queues_ready_queues_disjoint) + apply (clarsimp simp: not_in_release_q_def) + apply (fastforce dest!: ntfn_queues_release_queue_disjoint) + apply (fastforce simp: list_queue_relation_def) + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (rule hoare_weaken_pre) + apply (rule mapM_x_inv_wp2[ + where I="valid_objs and ntfn_at_pred (\ntfn. \ isActive ntfn) ntfn_ptr" + and V="\xs. ntfn_at_pred (\ntfn. ntfn_queue (ntfn_obj ntfn) = xs) ntfn_ptr"]) + apply (clarsimp simp: ntfn_at_pred_def) + apply (force simp: valid_obj_def valid_ntfn_def isActive_def split: ntfn.splits) + apply (wpsimp wp: remove_and_restart_ntfn_queued_thread_dequeues_head) + apply (force simp: ntfn_at_pred_def valid_obj_def valid_ntfn_def + split: Structures_A.ntfn.splits) + apply (fastforce simp: ntfn_at_pred_def obj_at_def isActive_def) + apply (rule hoare_weaken_pre) + apply (rule_tac Q="\t s. in_ntfn_queue_at t ntfn_ptr s \ \ ep_queued t s + \ not_queued t s \ not_in_release_q t s \ scheduler_act_not t s + \ st_tcb_at is_blocked_on_ntfn t s \ t \ idle_thread s" + in ball_mapM_x_scheme) + apply (wpsimp wp: remove_and_restart_ntfn_queued_thread_other + remove_and_restart_ntfn_queued_thread_in_ntfn_queue_at_other) + apply (wpsimp wp: remove_and_restart_ntfn_queued_thread_other + remove_and_restart_ntfn_queued_thread_valid_sched + remove_and_restart_ntfn_queued_thread_ep_queues_blocked + remove_and_restart_ntfn_queued_thread_ntfn_queues_blocked) + apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps) + apply fastforce + apply clarsimp + apply (rename_tac s) + apply (frule invs_sym_refs) + apply (frule sym_refs_ntfn_queues_blocked) + apply (frule sym_refs_ep_queues_blocked) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (prop_tac "ntfn_queues_of s ntfn_ptr = Some queue") + apply (fastforce simp: opt_map_def obj_at_def split: option.splits) + apply (prop_tac "\p \ set queue. st_tcb_at is_blocked_on_ntfn p s") + apply (clarsimp simp: ntfn_queues_blocked_def) + apply (drule_tac x=ntfn_ptr in spec) + apply (drule_tac x=queue in spec) + apply (fastforce elim!: st_tcb_weakenE simp: ntfn_blocked_def + split: Structures_A.thread_state.splits) + apply (intro conjI impI allI ballI; fastforce?) + apply (force dest: ep_queues_ntfn_queues_disjoint simp: in_ntfn_queue_at_def ntfn_queued_def) + apply (force dest: ep_queues_ntfn_queues_disjoint simp: in_ep_queue_at_def ep_queued_def) + apply (clarsimp simp: not_queued_def) + apply (force dest!: ntfn_queues_ready_queues_disjoint) + apply (clarsimp simp: not_in_release_q_def) + apply (fastforce dest!: ntfn_queues_release_queue_disjoint) + apply (fastforce intro: weak_valid_sched_action_scheduler_action_not + is_blocked_on_ntfn_not_runnable) + apply (rule not_idle_thread', fastforce+) + apply (rule_tac Q'="\_. pspace_aligned' and pspace_distinct' and pspace_bounded' + and valid_objs' and valid_sched_pointers and sym_heap_sched_pointers" + in hoare_post_imp) + apply fastforce + apply (wpsimp wp: whileLoop_valid_inv) + apply fastforce + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ get_ntfn_sp', rotated]; (solves wpsimp)?) + apply wpsimp + apply (force intro!: ntfn_at_cross simp: ex_abs_def ntfn_at_pred_def obj_at_def is_ntfn_def) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (frule state_relation_pspace_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation heap_pspace_relation_def + map_relation_def opt_map_def obj_at'_def ntfn_at_pred_def ntfn_relation_def + split: option.splits Structures_A.ntfn.splits) + apply (corres corres: rescheduleRequired_corres) + apply (frule valid_sched_valid_ready_qs) + apply (fastforce dest: valid_sched_valid_release_q) + apply fastforce done -lemma ep'_Idle_case_helper: - "(case ep of IdleEP \ a | _ \ b) = (if (ep = IdleEP) then a else b)" - by (cases ep, simp_all) - lemma replyUnlink_valid_irq_node'[wp]: "replyUnlink r t \\ s. valid_irq_node' (irq_node' s) s\" unfolding replyUnlink_def @@ -2851,26 +4040,17 @@ lemma refillPopHead_refs_of'[wp]: done crunch ifCondRefillUnblockCheck - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' t" - and valid_pspace'[wp]: valid_pspace' + for valid_pspace'[wp]: valid_pspace' and list_refs_of_replies'[wp]: "\s. P (list_refs_of_replies' s)" - and if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' and irq_node'[wp]: "\s. P (irq_node' s)" and valid_machine_state'[wp]: valid_machine_state' and ksInterrupt[wp]: "\s. P (ksInterruptState s)" - and unlive[wp]: "ko_wp_at' (Not \ live') p" and refs_of'[wp]: "\s. P (state_refs_of' s)" - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers and valid_replies'[wp]: valid_replies' and valid_mdb'[wp]: valid_mdb' and valid_bitmaps[wp]: valid_bitmaps (wp: crunch_wps simp: crunch_simps valid_pspace'_def ignore: threadSet) -crunch replyUnlink - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - lemma valid_mdb'_ksSchedulerAction_update[simp]: "valid_mdb' (ksSchedulerAction_update f s) = valid_mdb' s" by (clarsimp simp: valid_mdb'_def) @@ -2910,293 +4090,135 @@ end arch_requalify_facts tcbSchedEnqueue_valid_pspace' (* FIXME arch-split: interface *) lemmas [wp] = tcbSchedEnqueue_valid_pspace' -lemma cancel_all_invs'_helper: - "\invs' - and (\s. (\x \ set q. - 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) - \ distinct q)\ - mapM_x (\t. do st <- getThreadState t; - y <- case if isReceive st then replyObject st else None of None \ return () | Some x \ replyUnlink x t; - fault <- threadGet tcbFault t; - if fault = None then do y <- setThreadState Structures_H.thread_state.Restart t; - scOpt <- threadGet tcbSchedContext t; - y \ ifCondRefillUnblockCheck scOpt (Some False) (Some True); - possibleSwitchTo t - od - else setThreadState Structures_H.thread_state.Inactive t - od) q - \\rv. invs'\" - supply if_split[split del] comp_apply[simp del] - unfolding valid_dom_schedule'_def invs'_def - apply (rule mapM_x_inv_wp2) - (* FIXME arch-split: this helper lemma has different definition on hyp platforms *) - apply (clarsimp simp: RISCV64.non_hyp_state_hyp_refs_of') - apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift - hoare_vcg_const_Ball_lift sts_st_tcb' - possibleSwitchTo_sch_act_not_other) - apply (wpsimp wp: valid_irq_node_lift hoare_vcg_const_Ball_lift sts_st_tcb' sts_sch_act' - split: if_splits) - apply (wp hoare_drop_imp) - apply (wpsimp wp: hoare_vcg_const_Ball_lift hoare_vcg_all_lift gts_wp' hoare_vcg_imp_lift - replyUnlink_valid_objs' replyUnlink_st_tcb_at' - simp: valid_tcb_state'_def)+ - apply (clarsimp split: if_splits) - by (intro conjI impI allI; - fastforce dest!: valid_replies'_other_state - simp: global'_no_ex_cap pred_tcb_at'_def obj_at'_def) - -lemma not_in_epQueue: - assumes ko_at: "ko_at' r ep_ptr s" and - srefs: "sym_refs (state_refs_of' s)" and - nidle: "r \ IdleEP" and - st_act: "st_tcb_at' simple' t s" - shows "t \ set (epQueue r)" -proof - assume t_epQ: "t \ set (epQueue r)" - - with ko_at nidle - have "(t, EPRecv) \ state_refs_of' s ep_ptr - \ (t, EPSend) \ state_refs_of' s ep_ptr" - by - (drule ko_at_state_refs_ofD', case_tac r, (clarsimp)+) - - with ko_at srefs - have "(ep_ptr, TCBBlockedRecv) \ state_refs_of' s t - \ (ep_ptr, TCBBlockedSend) \ state_refs_of' s t" - apply - - apply (frule(1) sym_refs_ko_atD') - apply (drule ko_at_state_refs_ofD') - apply (case_tac r) - apply (clarsimp simp: st_tcb_at_refs_of_rev' - | drule(1) bspec | drule st_tcb_at_state_refs_ofD')+ - done - - with ko_at have "st_tcb_at' (Not \ simple') t s" - apply - - apply (erule disjE) - apply (drule state_refs_of'_elemD) - apply (simp add: st_tcb_at_refs_of_rev') - apply (erule pred_tcb'_weakenE) - apply (clarsimp simp: isBlockedOnReply_def) - apply (drule state_refs_of'_elemD) - apply (simp add: st_tcb_at_refs_of_rev') - apply (erule pred_tcb'_weakenE) - apply (clarsimp simp: isBlockedOnReply_def) - done - - with st_act show False - by (rule pred_tcb'_neq_contra) simp -qed - -lemma ct_not_in_epQueue: - assumes "ko_at' r ep_ptr s" and - "sym_refs (state_refs_of' s)" and - "r \ IdleEP" and - "ct_in_state' simple' s" - shows "ksCurThread s \ set (epQueue r)" - using assms unfolding ct_in_state'_def - by (rule not_in_epQueue) - -lemma not_in_ntfnQueue: - assumes ko_at: "ko_at' r ntfn_ptr s" and - srefs: "sym_refs (state_refs_of' s)" and - nidle: "ntfnObj r \ IdleNtfn \ (\b m. ntfnObj r \ ActiveNtfn b)" and - st_act: "st_tcb_at' simple' t s" - shows "t \ set (ntfnQueue (ntfnObj r))" -proof - assume t_epQ: "t \ set (ntfnQueue (ntfnObj r))" - - with ko_at nidle - have "(t, NTFNSignal) \ state_refs_of' s ntfn_ptr" - by - (drule ko_at_state_refs_ofD', case_tac "ntfnObj r", (clarsimp)+) - with ko_at srefs - have "(ntfn_ptr, TCBSignal) \ state_refs_of' s t" - apply - - apply (frule(1) sym_refs_ko_atD') - apply (drule ko_at_state_refs_ofD') - apply (case_tac "ntfnObj r") - apply (clarsimp simp: st_tcb_at_refs_of_rev' ntfn_bound_refs'_def - | drule st_tcb_at_state_refs_ofD')+ - apply (drule_tac x="(t, NTFNSignal)" in bspec, clarsimp) - apply (clarsimp simp: st_tcb_at_refs_of_rev' sym_refs_def dest!: st_tcb_at_state_refs_ofD') - apply (fastforce simp: st_tcb_at_refs_of_rev' sym_refs_def dest!: st_tcb_at_state_refs_ofD') - by (metis sym_refs_simp symreftype.simps(7)) - - with ko_at have "st_tcb_at' (Not \ simple') t s" - apply - - apply (drule state_refs_of'_elemD) - apply (simp add: st_tcb_at_refs_of_rev') - apply (erule pred_tcb'_weakenE) - apply (clarsimp simp: isBlockedOnReply_def) - done - - with st_act show False - by (rule pred_tcb'_neq_contra) simp -qed +crunch removeAndRestartEPQueuedThread, removeAndRestartNTFNQueuedThread, + removeAndRestartBadgedThread + for pspace_canonical'[wp]: pspace_canonical' + and ctes_of[wp]: "\s. P (ctes_of s)" + and pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' + and no_0_obj'[wp]: no_0_obj' + and valid_mdb'[wp]: valid_mdb' + and valid_bitmaps[wp]: valid_bitmaps + and if_unsafe_then_cap'[wp]: if_unsafe_then_cap' + and valid_global_refs'[wp]: valid_global_refs' + and valid_arch_state'[wp]: valid_arch_state' + and irq_node'[wp]: "\s. P (irq_node' s)" + and valid_irq_handlers'[wp]: valid_irq_handlers' + and valid_irq_states'[wp]: valid_irq_states' + and valid_machine_state'[wp]: valid_machine_state' + and ksInterruptState[wp]: "\s. P (ksInterruptState s)" + and pspace_domain_valid[wp]: pspace_domain_valid + and ksCurDomain[wp]: "\s. P (ksCurDomain s)" + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and list_refs_of_replies'[wp]: "\s. P (list_refs_of_replies' s)" + and irqs_masked'[wp]: irqs_masked' + and valid_dom_schedule'[wp]: valid_dom_schedule' + and untyped_ranges_zero'[wp]: untyped_ranges_zero' + (wp: crunch_wps valid_mdb'_lift valid_dom_schedule'_lift threadSet_urz simp: crunch_simps + ignore: threadSet) + +lemma restartThreadIfNoFault_valid_replies': + "\valid_replies' and st_tcb_at' (\st. \ isBlockedOnReply st) t\ + restartThreadIfNoFault t + \\_. valid_replies'\" + unfolding restartThreadIfNoFault_def + apply (wpsimp wp: sts'_valid_replies' threadGet_wp hoare_drop_imps) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def isBlockedOnReply_def split: thread_state.splits) + done -lemma ct_not_in_ntfnQueue: - assumes ko_at: "ko_at' r ntfn_ptr s" and - srefs: "sym_refs (state_refs_of' s)" and - nidle: "ntfnObj r \ IdleNtfn \ (\b m. ntfnObj r \ ActiveNtfn b)" and - st_act: "ct_in_state' simple' s" - shows "ksCurThread s \ set (ntfnQueue (ntfnObj r))" - using assms unfolding ct_in_state'_def - by (rule not_in_ntfnQueue) - -lemma sch_act_wf_weak[elim!]: - "sch_act_wf sa s \ weak_sch_act_wf sa s" - by (clarsimp simp: weak_sch_act_wf_def) +lemma removeAndRestartEPQueuedThread_valid_replies': + "\valid_replies' and pspace_aligned' and pspace_distinct'\ + removeAndRestartEPQueuedThread t epptr + \\_. valid_replies'\" + apply (clarsimp simp: removeAndRestartEPQueuedThread_def) + apply (rule bind_wp[OF _ gts_sp']) + apply (rule bind_wp[OF _ assert_sp]) + \ \step over tcbEPDequeue\ + apply forward_inv_step + apply (rule bind_wp[OF _ gts_sp']) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (wpsimp wp: restartThreadIfNoFault_valid_replies' replyUnlink_st_tcb_at' + hoare_vcg_all_lift hoare_vcg_imp_lift' gts_wp') + by (elim disjE; + fastforce dest!: valid_replies'_other_state + simp: st_tcb_at'_def obj_at'_def isSend_def isReceive_def isBlockedOnReply_def + split: thread_state.splits) + +lemma removeAndRestartNTFNQueuedThread_valid_replies': + "\valid_replies' and pspace_aligned' and pspace_distinct'\ + removeAndRestartNTFNQueuedThread t ntfnPtr + \\_. valid_replies'\" + apply (clarsimp simp: removeAndRestartNTFNQueuedThread_def) + apply (rule bind_wp[OF _ gts_sp']) + apply (wpsimp wp: sts'_valid_replies' hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (fastforce dest!: valid_replies'_other_state + simp: st_tcb_at'_def obj_at'_def isBlockedOnNtfn_def isBlockedOnReply_def + split: thread_state.splits) + done -crunch setEndpoint, setNotification - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers +lemma removeAndRestartEPQueuedThread_invs'[wp]: + "removeAndRestartEPQueuedThread t ep_ptr \invs'\" + apply (clarsimp simp: invs'_def valid_pspace'_def) + apply (wpsimp wp: removeAndRestartEPQueuedThread_valid_replies' valid_irq_node_lift) + done -(* 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] - unfolding cancelAllIPC_def cancelAllIPC_loop_body_def restartThreadIfNoFault_def - apply (simp add: ep'_Idle_case_helper cong del: if_cong) - apply (intro bind_wp[OF _ stateAssert_sp]) - apply (wpsimp wp: rescheduleRequired_invs' cancel_all_invs'_helper - hoare_vcg_const_Ball_lift - valid_global_refs_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 (frule obj_at_valid_objs', fastforce) - apply (clarsimp simp: valid_obj'_def) - apply (rule conjI) - 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: - "\ko_at' ntfn ntfnPtr s; ntfnObj ntfn = Structures_H.ntfn.WaitingNtfn q; valid_objs' s; - sym_refs (state_refs_of' s); if_live_then_nonz_cap' s; t \ set q\ - \ ex_nonz_cap_to' t s" - apply (clarsimp simp: sym_refs_def) - apply (erule_tac x = ntfnPtr in allE) - apply (drule_tac x = "(t, NTFNSignal)" in bspec) - apply (clarsimp simp: state_refs_of'_def obj_at'_def refs_of'_def) - apply (fastforce intro: if_live_state_refsE) - done - -lemma cancelAllSignals_invs'_helper: - "\invs' - and (\s. (\x \ set q. st_tcb_at' (\st. \ref. st = BlockedOnNotification ref) x s - \ ex_nonz_cap_to' x s)) - and K (distinct q)\ - mapM_x (\t. do y <- setThreadState Structures_H.thread_state.Restart t; - scOpt <- threadGet tcbSchedContext t; - y \ ifCondRefillUnblockCheck scOpt (Some False) (Some True); - possibleSwitchTo t - od) q +lemma replyUnlink_invs'[wp]: + "\invs' and (\s. replyTCBs_of s replyPtr = Some tcbPtr \ \ is_reply_linked replyPtr s) + and (\s. \ is_sched_linked tcbPtr s)\ + replyUnlink replyPtr tcbPtr \\_. invs'\" - unfolding valid_dom_schedule'_def invs'_def - apply (rule hoare_gen_asm) - apply (rule mapM_x_inv_wp2) - apply clarsimp - apply (wpsimp wp: sts_st_tcb_at'_cases valid_irq_node_lift irqs_masked_lift - hoare_vcg_const_Ball_lift hoare_vcg_all_lift hoare_vcg_imp_lift' - simp: cteCaps_of_def o_def) - apply (fastforce simp: valid_tcb_state'_def global'_no_ex_cap - pred_tcb_at'_def obj_at'_def distinct_imply_not_in_tail) - done - -lemma ntfn_queued_st_tcb_at': - "\P. \ko_at' ntfn ptr s; (t, rt) \ ntfn_q_refs_of' (ntfnObj ntfn); - valid_objs' s; sym_refs (state_refs_of' s); - \ref. P (BlockedOnNotification ref) \ - \ st_tcb_at' P t s" - apply (case_tac "ntfnObj ntfn", simp_all) - apply (frule(1) sym_refs_ko_atD') - apply (clarsimp) - apply (erule_tac y="(t,NTFNSignal)" in my_BallE) - apply (clarsimp simp: refs_of_rev' pred_tcb_at'_def obj_at'_def ko_wp_at'_def)+ - done - -lemma cancelAllSignals_invs'[wp]: - "cancelAllSignals ntfnPtr \invs'\" - apply (simp add: cancelAllSignals_def) - apply (intro bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (case_tac "ntfnObj ntfn"; simp) - apply wpsimp - apply wpsimp - apply (wpsimp wp: rescheduleRequired_invs' sts_st_tcb_at'_cases - cancelAllSignals_invs'_helper hoare_vcg_const_Ball_lift - 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 (clarsimp simp: invs'_def valid_pspace'_def valid_ntfn'_def - valid_dom_schedule'_def) - apply (prop_tac "valid_ntfn' ntfn s") - apply (frule (2) ntfn_ko_at_valid_objs_valid_ntfn') - apply (clarsimp simp: valid_ntfn'_def) - apply (intro conjI impI) - apply (clarsimp simp: list_refs_of_replies'_def opt_map_def o_def split: option.splits) - apply (fastforce intro: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def live'_def live_ntfn'_def) - apply (fastforce elim!: ex_nonz_cap_to'_tcb_in_WaitingNtfn'_q ntfn_queued_st_tcb_at' - simp: sym_refs_asrt_def sch_act_wf_asrt_def)+ + unfolding invs'_def valid_dom_schedule'_def valid_pspace'_def + by (wpsimp wp: replyUnlink_valid_sched_pointers) + +lemma removeAndRestartNTFNQueuedThread_invs'[wp]: + "removeAndRestartNTFNQueuedThread t ntfnPtr \invs'\" + apply (clarsimp simp: invs'_def valid_pspace'_def) + apply (wpsimp wp: removeAndRestartNTFNQueuedThread_valid_replies' valid_irq_node_lift) done -lemma cancelAllIPC_st_tcb_at: +crunch cancelAllIPC, cancelAllSignals + for invs'[wp]: invs' + (wp: crunch_wps) + +lemma removeAndRestartEPQueuedThread_st_tcb_at: "\st_tcb_at' P t and K (P Inactive \ P Restart)\ - cancelAllIPC epptr + removeAndRestartEPQueuedThread t' epptr \\_. st_tcb_at' P t\" - unfolding cancelAllIPC_def cancelAllIPC_loop_body_def restartThreadIfNoFault_def - apply (rule hoare_gen_asm) - apply simp - apply (intro bind_wp[OF _ stateAssert_sp]) - apply (intro bind_wp[OF _ get_ep_sp']) - apply (clarsimp simp: endpoint.case_eq_if) - apply (rule conjI) - 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+ + unfolding removeAndRestartEPQueuedThread_def restartThreadIfNoFault_def + by (wpsimp wp: sts_st_tcb_at'_cases hoare_drop_imps replyUnlink_st_tcb_at') + +lemma cancelAllIPC_st_tcb_at: + "\st_tcb_at' P t and K (P Inactive \ P Restart)\ cancelAllIPC epptr \\_. st_tcb_at' P t\" + apply (clarsimp simp: cancelAllIPC_def) + apply (intro bind_wp[OF _ stateAssert_inv] bind_wp[OF _ get_ep_sp']) + apply (subst endpoint_IdleEPState_split) + apply (rule hoare_if; (solves wpsimp)?) + apply wpsimp + apply (rule hoare_drop_imps) + apply (rule get_ep_inv') + apply (rule_tac Q'="\_ _. P Inactive \ P Restart" in hoare_post_add) + apply (wpsimp wp: whileLoop_valid_inv removeAndRestartEPQueuedThread_st_tcb_at hoare_drop_imps)+ done lemmas cancelAllIPC_makes_simple[wp] = cancelAllIPC_st_tcb_at [where P=simple', simplified] +lemma removeAndRestartNTFNQueuedThread_st_tcb_at: + "\st_tcb_at' P t and K (P Restart)\ removeAndRestartNTFNQueuedThread t' epptr \\_. st_tcb_at' P t\" + unfolding removeAndRestartNTFNQueuedThread_def restartThreadIfNoFault_def + by (wpsimp wp: sts_st_tcb_at'_cases hoare_drop_imps replyUnlink_st_tcb_at') + lemma cancelAllSignals_st_tcb_at: - "\st_tcb_at' P t and K (P Restart)\ - cancelAllSignals epptr - \\_. st_tcb_at' P t\" - unfolding cancelAllSignals_def - apply (rule hoare_gen_asm) - apply (wpsimp wp: mapM_x_wp' sts_st_tcb_at'_cases getNotification_wp) + "\st_tcb_at' P t and K (P Restart)\ cancelAllSignals epptr \\_. st_tcb_at' P t\" + apply (clarsimp simp: cancelAllSignals_def) + apply (intro bind_wp[OF _ stateAssert_inv] bind_wp[OF _ get_ntfn_sp']) + apply (rename_tac ntfn) + apply (case_tac "ntfnState ntfn"; clarsimp; (solves wpsimp)?) + apply wpsimp + apply (rule hoare_drop_imps) + apply (rule get_ntfn_inv') + apply (rule_tac Q'="\_ _. P Restart" in hoare_post_add) + apply (wpsimp wp: whileLoop_valid_inv removeAndRestartNTFNQueuedThread_st_tcb_at hoare_drop_imps)+ done lemmas cancelAllSignals_makes_simple[wp] = @@ -3209,33 +4231,39 @@ lemma threadSet_unlive_other: by (clarsimp simp: threadSet_def valid_def getObject_def setObject_def in_monad loadObject_default_def ko_wp_at'_def split_def in_magnitude_check - updateObject_default_def + gen_objBits_simps updateObject_default_def ps_clear_upd RISCV64_H.fromPPtr_def) -lemma tcbSchedEnqueue_unlive_other: +lemma tcbQueuePrepend_unlive_other: "\ko_wp_at' (Not \ live') p and K (p \ t)\ - tcbSchedEnqueue t + tcbQueuePrepend q t \\_. ko_wp_at' (Not \ live') p\" - apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def) + supply if_split[split del] + apply (simp add: tcbQueuePrepend_def) apply (wpsimp wp: threadGet_wp threadSet_unlive_other hoare_vcg_imp_lift') - apply (normalise_obj_at', rename_tac tcb) - apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply clarsimp - apply (frule (1) tcbQueueHead_ksReadyQueues) - apply (fastforce dest!: inQ_implies_tcbQueueds_of - simp: obj_at'_def ko_wp_at'_def opt_pred_def opt_map_def live'_def - split: option.splits) + apply (clarsimp simp: tcbQueueEmpty_def list_queue_relation_def) + apply (rename_tac ts) + apply (prop_tac "ts \ []", fastforce) + apply (frule (1) heap_path_head) + apply (drule_tac x="hd ts" in bspec, fastforce) + apply (force simp: live'_def ko_wp_at'_def obj_at'_def opt_pred_def opt_map_def + split: option.splits thread_state.splits) done +lemma tcbSchedEnqueue_unlive_other: + "\ko_wp_at' (Not \ live') p and K (p \ t)\ + tcbSchedEnqueue t + \\_. ko_wp_at' (Not \ live') p\" + unfolding tcbSchedEnqueue_def + by (wpsimp wp: threadGet_wp threadSet_unlive_other tcbQueuePrepend_unlive_other) + lemma rescheduleRequired_unlive[wp]: "rescheduleRequired \ko_wp_at' (Not \ live') p\" supply comp_apply[simp del] unfolding rescheduleRequired_def apply (wpsimp wp: getSchedulable_wp tcbSchedEnqueue_unlive_other) - apply (fastforce simp: schedulable'_def opt_pred_def obj_at'_def ko_wp_at'_def opt_map_def o_def - live'_def) + apply (fastforce simp: schedulable'_def opt_pred_def obj_at'_def + live'_def ko_wp_at'_def opt_map_def o_def) done crunch scheduleTCB @@ -3251,8 +4279,6 @@ lemma setThreadState_unlive_other: apply (fastforce simp: ko_wp_at'_def obj_at'_def) done -context begin interpretation Arch . (*FIXME: arch-split*) - lemma possibleSwitchTo_unlive_other: "\ko_wp_at' (Not \ live') p and K (p \ t) and valid_tcbs'\ possibleSwitchTo t @@ -3260,11 +4286,14 @@ lemma possibleSwitchTo_unlive_other: unfolding possibleSwitchTo_def inReleaseQueue_def by (wpsimp wp: tcbSchedEnqueue_unlive_other threadGet_wp rescheduleRequired_unlive)+ +context begin interpretation Arch . (*FIXME: arch-split*) + lemma setThreadState_Inactive_unlive: "setThreadState Inactive tptr \ko_wp_at' (Not o live') p\" apply (clarsimp simp: setThreadState_def) apply (wpsimp wp: threadSet_wp) - apply (fastforce simp: ko_wp_at'_def obj_at'_def objBits_simps live'_def hyp_live'_def) + apply (clarsimp simp: live'_def ko_wp_at'_def obj_at'_def gen_objBits_simps ps_clear_upd + hyp_live'_def) done lemma replyUnlink_unlive: @@ -3272,398 +4301,367 @@ lemma replyUnlink_unlive: supply fun_upd_apply[simp del] apply (clarsimp simp: replyUnlink_def updateReply_def) apply (wpsimp wp: setThreadState_Inactive_unlive set_reply'.set_wp gts_wp') - apply (clarsimp simp: ko_wp_at'_def live'_def live_reply'_def obj_at'_def ps_clear_upd fun_upd_apply) + apply (clarsimp simp: live'_def ko_wp_at'_def live_reply'_def obj_at'_def ps_clear_upd fun_upd_apply) done -lemma set_Idle_unlive[wp]: - "\ep_at' ep\ setEndpoint ep IdleEP \\_. ko_wp_at' (Not \ live') ep\" - apply (wpsimp wp: set_ep'.set_wp) - apply (clarsimp simp: ko_wp_at'_def obj_at'_def objBits_simps ps_clear_upd live'_def) +lemma cancelAllIPC_unlive[wp]: + "\\\ cancelAllIPC epPtr \\_. ko_wp_at' (Not \ live') epPtr\" + apply (clarsimp simp: cancelAllIPC_def) + apply (rule bind_wp[OF _ stateAssert_sp])+ + apply (subst endpoint_IdleEPState_split) + apply wpsimp + apply (rule_tac Q'="\ep. ko_at' ep epPtr" in hoare_post_imp) + apply (clarsimp simp: live'_def ko_wp_at'_def obj_at'_def) + apply (wpsimp wp: getEndpoint_wp)+ + apply (clarsimp simp: live'_def ko_wp_at'_def obj_at'_def) done -lemma cancelAllIPC_unlive: - "\valid_objs' and ep_at' ep and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - cancelAllIPC ep - \\_. ko_wp_at' (Not \ live') ep\" - unfolding cancelAllIPC_def cancelAllIPC_loop_body_def restartThreadIfNoFault_def - apply (simp add: ep'_Idle_case_helper) - apply wpsimp - apply (rule_tac Q'="\_. ko_wp_at' (Not \ live') ep and ep_at' ep - and valid_objs' - and pspace_aligned' and pspace_distinct' and pspace_bounded'" - in hoare_post_imp, fastforce) - apply (rule mapM_x_wp_inv) - apply (wpsimp wp: possibleSwitchTo_unlive_other setThreadState_unlive_other - possibleSwitchTo_sch_act_not_other replyUnlink_unlive hoare_drop_imps) - apply (fastforce simp: ko_wp_at'_def st_tcb_at'_def obj_at'_def isReceive_def) - apply (wpsimp wp: getEndpoint_wp)+ - apply (fastforce simp: ko_wp_at'_def st_tcb_at'_def obj_at'_def valid_ep'_def live'_def) - done - -lemma cancelAllSignals_unlive_helper: - "\\s. (\x\set xs. tcb_at' x s) \ ko_wp_at' (Not \ live') p s - \ p \ set xs \ valid_tcbs' s - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - scOpt <- threadGet tcbSchedContext t; - y <- ifCondRefillUnblockCheck scOpt (Some False) (Some True); - possibleSwitchTo t - od) xs - \\rv s. (\x\set xs. tcb_at' x s) \ ko_wp_at' (Not \ live') p s\" - apply (rule hoare_strengthen_post) - apply (rule mapM_x_wp') - apply (wpsimp wp: hoare_vcg_const_Ball_lift setThreadState_unlive_other - possibleSwitchTo_unlive_other) - apply clarsimp +lemma tcbNTFNDequeue_ntfnBoundTCB[wp]: + "tcbNTFNDequeue tcbPtr ntfnPtr \obj_at' (\ntfn. P (ntfnBoundTCB ntfn)) ntfnPtr\" + apply (clarsimp simp: tcbNTFNDequeue_def) + apply forward_inv_step+ + apply (wpsimp wp: updateNotification_wp hoare_drop_imps hoare_vcg_all_lift) + apply (fastforce simp: obj_at'_def ps_clear_upd objBits_simps) + done + +lemma tcbNTFNDequeue_ntfnSc[wp]: + "tcbNTFNDequeue tcbPtr ntfnPtr \obj_at' (\ntfn. P (ntfnSc ntfn)) ntfnPtr\" + apply (clarsimp simp: tcbNTFNDequeue_def) + apply forward_inv_step+ + apply (wpsimp wp: updateNotification_wp hoare_drop_imps hoare_vcg_all_lift) + apply (fastforce simp: obj_at'_def ps_clear_upd objBits_simps) done +crunch possibleSwitchTo, ifCondRefillUnblockCheck + for obj_at'_ntfn[wp]: "\s. P (obj_at' (Q :: notification \ bool) p s)" + (wp: crunch_wps simp: crunch_simps) + +lemma removeAndRestartNTFNQueuedThread_ntfnBoundTCB[wp]: + "removeAndRestartNTFNQueuedThread tcbPtr ntfnPtr \obj_at' (\ntfn. P (ntfnBoundTCB ntfn)) ntfnPtr\" + unfolding removeAndRestartNTFNQueuedThread_def + by (wpsimp wp: gts_wp') + +lemma removeAndRestartNTFNQueuedThread_ntfnSc[wp]: + "removeAndRestartNTFNQueuedThread tcbPtr ntfnPtr \obj_at' (\ntfn. P (ntfnSc ntfn)) ntfnPtr\" + unfolding removeAndRestartNTFNQueuedThread_def + by (wpsimp wp: gts_wp') + lemma cancelAllSignals_unlive: - "\\s. valid_objs' s - \ obj_at' (\ko. ntfnBoundTCB ko = None) ntfnptr s - \ obj_at' (\ko. ntfnSc ko = None) ntfnptr s - \ valid_tcbs' s \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ + "\obj_at' (\ntfn. ntfnBoundTCB ntfn = None) ntfnptr and obj_at' (\ntfn. ntfnSc ntfn = None) ntfnptr\ cancelAllSignals ntfnptr - \\rv. ko_wp_at' (Not \ live') ntfnptr\" - apply (simp add: cancelAllSignals_def) - apply (repeat_unless \rule bind_wp[OF _ get_ntfn_sp']\ - \rule bind_wp_fwd_skip, wpsimp\) - apply (case_tac "ntfnObj ntfn"; simp) - apply wp - apply (fastforce simp: obj_at'_real_def live'_def live_ntfn'_def ko_wp_at'_def) - apply wp - apply (fastforce simp: obj_at'_real_def live'_def live_ntfn'_def ko_wp_at'_def) - apply (wp rescheduleRequired_unlive) - apply (rule cancelAllSignals_unlive_helper[THEN hoare_strengthen_post]) + \\_. ko_wp_at' (Not \ live') ntfnptr\" + (is "\?pre\ _ \_\") + apply (clarsimp simp: cancelAllSignals_def) + apply (rule bind_wp[OF _ stateAssert_sp])+ + apply (rule bind_wp[OF _ get_ntfn_sp']) + apply (rename_tac ntfn) + apply (case_tac "ntfnState ntfn"; clarsimp) + apply wpsimp + apply (clarsimp simp: live'_def ko_wp_at'_def obj_at'_def live_ntfn'_def) + apply wpsimp + apply (clarsimp simp: live'_def ko_wp_at'_def obj_at'_def live_ntfn'_def) + apply wpsimp + apply (rule_tac Q'="\ntfn. ko_at' ntfn ntfnptr and ?pre" in hoare_post_imp) + apply (clarsimp simp: live'_def ko_wp_at'_def obj_at'_def live_ntfn'_def) + apply (wpsimp wp: getNotification_wp)+ + apply (rule_tac Q'="\_. ?pre" in hoare_post_imp) 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) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (clarsimp simp: live_ntfn'_def ko_wp_at'_def obj_at'_def live'_def) + apply (wpsimp wp: whileLoop_valid_inv)+ done declare if_cong[cong] -lemma insert_eqD: - "A = insert a B \ a \ A" - by blast - -crunch setSchedulerAction - for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' p" - (simp: tcb_in_cur_domain'_def wp_del: ssa_wp) - crunch possibleSwitchTo for ksCurThread[wp]: "\s. P (ksCurThread s)" (wp: crunch_wps) -lemma cancelBadgedSends_filterM_helper': - notes if_cong[cong del] - shows - "\ys. - \\s. invs' s - \ ex_nonz_cap_to' epptr s \ ep_at' epptr s - \ sym_refs ((state_refs_of' s) (epptr := set (xs @ ys) \ {EPSend})) - \ (\y \ set (xs @ ys). state_refs_of' s y = {(epptr, TCBBlockedSend)} - \ tcb_non_st_state_refs_of' s y) - \ distinct (xs @ ys)\ - filterM (\t. do st \ getThreadState t; - if blockingIPCBadge st = badge - then - do restartThreadIfNoFault t; - return False - od - else return True - od) xs - \\rv s. invs' s - \ ex_nonz_cap_to' epptr s \ ep_at' epptr s - \ sym_refs ((state_refs_of' s) (epptr := (set rv \ set ys) \ {EPSend})) - \ (\y \ set ys. state_refs_of' s y = {(epptr, TCBBlockedSend)} - \ tcb_non_st_state_refs_of' s y) - \ distinct rv \ distinct (xs @ ys) \ set rv \ set xs \ (\x \ set xs. tcb_at' x s)\" - supply valid_dom_schedule'_def[simp] - unfolding restartThreadIfNoFault_def - apply (simp only: invs'_def) - apply (rule_tac xs=xs in rev_induct) - apply clarsimp - apply wp - apply clarsimp - 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 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) +crunch cancelBadgedSends + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + and pspace_bounded'[wp]: pspace_bounded' + (wp: crunch_wps) + +lemma removeAndRestartBadgedThread_valid_replies': + "\valid_replies' and valid_sched_pointers and sym_heap_sched_pointers + and pspace_aligned' and pspace_distinct'\ + removeAndRestartBadgedThread t epptr badge + \\_. valid_replies'\" + unfolding removeAndRestartBadgedThread_def + apply (wpsimp wp: gts_wp' hoare_vcg_imp_lift' restartThreadIfNoFault_valid_replies') + apply (fastforce simp: isBlockedOnReply_def isSend_def st_tcb_at'_def obj_at'_def + split: thread_state.splits) + done + +lemma removeAndRestartBadgedThread_invs'[wp]: + "removeAndRestartBadgedThread t epptr badge \invs'\" + apply (clarsimp simp: invs'_def valid_pspace'_def) + apply (wpsimp wp: removeAndRestartBadgedThread_valid_replies' valid_irq_node_lift) + done + +crunch cancelBadgedSends + for invs'[wp]: invs' + (wp: crunch_wps) + +lemma removeAndRestartBadgedThread_corres: + "corres dc + (in_ep_queue_at t ep_ptr and not ntfn_queued t and not_queued t and not_in_release_q t + and st_tcb_at is_blocked_on_send t + and valid_objs and valid_sched and current_time_bounded + and ep_queues_blocked and ntfn_queues_blocked + and pspace_aligned and pspace_distinct) + (valid_objs' and valid_sched_pointers and sym_heap_sched_pointers and pspace_bounded') + (remove_and_restart_badged_thread t ep_ptr badge) + (removeAndRestartBadgedThread t ep_ptr badge)" + supply if_split[split del] + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest!: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest!: pspace_distinct_cross) + apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) + apply (fastforce intro!: tcb_at_cross) + apply (clarsimp simp: remove_and_restart_badged_thread_def removeAndRestartBadgedThread_def) + apply (rule corres_split_forwards'[OF _ gts_sp gts_sp']) + apply (corres corres: getThreadState_corres) + apply (rename_tac st st') + apply (rule corres_assert_gen_asm_cross_forwards) + apply (force dest!: st_tcb_at_coerce_concrete is_blocked_on_send_isSend + simp: ep_queues_blocked_def in_ep_queue_at_def st_tcb_at'_def obj_at'_def) + apply (clarsimp simp: when_def) + apply (rule corres_if_strong') + apply (clarsimp simp: thread_state_relation_def isSend_def; case_tac st; case_tac st'; clarsimp) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF tcbEPDequeue_corres], simp, simp) + apply (rule restartThreadIfNoFault_corres) + apply (wpsimp wp: tcb_ep_dequeue_not_ep_queued) + apply wpsimp + apply clarsimp + apply (frule valid_sched_valid_ready_qs) + apply (fastforce dest: valid_sched_valid_release_q) + apply fastforce 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') - apply (rule conjI[rotated], blast) - apply (clarsimp cong: conj_cong) - apply (thin_tac "sym_refs _") \ \this removes the list_refs_of_reply' sym_refs premise\ - apply (intro conjI) - apply (find_goal \match conclusion in "sym_refs _" \ \-\\) - apply (erule delta_sym_refs) - apply (fastforce split: if_split_asm) - subgoal (* this takes approximately 15s *) - by (auto simp: state_refs_of'_def symreftype_inverse' - tcb_bound_refs'_def obj_at'_def get_refs_def2 tcb_st_refs_of'_def - split: option.splits if_splits thread_state.splits) - by (fastforce simp: valid_pspace'_def valid_tcb'_def pred_tcb_at'_def obj_at'_def subsetD - elim!: valid_objs_valid_tcbE' st_tcb_ex_cap'')+ - -lemmas cancelBadgedSends_filterM_helper - = spec [where x=Nil, OF cancelBadgedSends_filterM_helper', simplified] - -lemma cancelBadgedSends_invs'[wp]: - notes if_cong[cong del] - shows - "cancelBadgedSends epptr badge \invs'\" - apply (simp add: cancelBadgedSends_def) - apply (intro bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp [OF _ get_ep_sp'], rename_tac ep) - apply (case_tac ep, simp_all) - apply ((wp | simp)+)[2] - apply (subst bind_assoc [where g="\_. rescheduleRequired", - symmetric])+ - apply (rule bind_wp - [OF rescheduleRequired_invs']) - apply (simp add: list_case_return invs'_def valid_dom_schedule'_def cong: list.case_cong) - apply (rule hoare_pre, wp valid_irq_node_lift irqs_masked_lift) - apply (rule hoare_strengthen_post, - rule cancelBadgedSends_filterM_helper[where epptr=epptr]) - apply (clarsimp simp: ep_redux_simps3 fun_upd_def[symmetric] o_def) - apply (clarsimp simp add: valid_ep'_def invs'_def valid_dom_schedule'_def comp_def - split: list.split) - apply blast - apply (simp add: list_case_return invs'_def valid_dom_schedule'_def) - apply (wp valid_irq_node_lift irqs_masked_lift | wp (once) sch_act_sane_lift)+ - apply (clarsimp simp: valid_ep'_def fun_upd_def[symmetric] - obj_at'_weakenE[OF _ TrueI]) - apply (frule obj_at_valid_objs', clarsimp) - apply (clarsimp simp: valid_obj'_def valid_ep'_def ) - apply (frule if_live_then_nonz_capD', simp add: obj_at'_real_def) - apply (clarsimp simp: live'_def) - apply (clarsimp simp: sym_refs_asrt_def) - apply (frule(1) sym_refs_ko_atD') - apply (clarsimp simp add: fun_upd_idem st_tcb_at_refs_of_rev' o_def sch_act_wf_asrt_def) - apply (drule (1) bspec, drule st_tcb_at_state_refs_ofD', clarsimp) - apply (auto simp: tcb_bound_refs'_def get_refs_def - split: option.splits) - done - -lemma restart_thread_if_no_fault_valid_sched_blocked_on_send: - "\\s. valid_sched s \ tcb_at t s \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) - \ current_time_bounded s - \ (epptr, TCBBlockedSend) \ state_refs_of s t \ t \ idle_thread s\ - restart_thread_if_no_fault t - \\_. valid_sched\" - apply (wpsimp wp: restart_thread_if_no_fault_valid_sched gts_wp) - apply (frule valid_sched_released_ipc_queues) - apply (frule TCBBlockedSend_in_state_refs_of) - apply (prop_tac "blocked_on_send_tcb_at t s") - apply (fastforce simp: is_blocked_thread_state_defs vs_all_heap_simps obj_at_def pred_tcb_at_def) - apply (drule (1) released_ipc_queues_blocked_on_send_E1) - apply (intro conjI) - apply (clarsimp simp: pred_tcb_at_def obj_at_def vs_all_heap_simps) - apply (metis runnable.simps) - apply (clarsimp simp: is_timeout_fault_opt_def vs_all_heap_simps obj_at_def pred_tcb_at_def) - done - -lemma in_send_ep_queue_TCBBlockedSend': - "\ko_at' (Structures_H.SendEP queue) epptr s; x \ set queue; - sym_refs (state_refs_of' s); valid_objs' s\ - \ ko_wp_at' (\ko. (epptr, TCBBlockedSend) \ refs_of' ko) x s" - apply (prop_tac "valid_ep' (Structures_H.SendEP queue) s") - apply (fastforce simp: valid_objs'_def valid_obj'_def obj_at'_def - split: kernel_object.splits) - apply (clarsimp simp: valid_ep'_def) - apply (prop_tac "(x, EPSend) \ state_refs_of' s epptr") - apply (clarsimp simp: state_refs_of'_def obj_at'_def) - apply (clarsimp simp: sym_refs_def) - apply (fastforce simp: ko_wp_at'_def obj_at'_def state_refs_of'_def) - done - -lemma set_endpoint_in_correct_ready_q[wp]: - "set_endpoint ptr ep \in_correct_ready_q\" - unfolding set_simple_ko_def - apply (wpsimp wp: set_object_wp get_object_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps in_correct_ready_q_def) done +lemma remove_and_restart_badged_thread_ep_queues_blocked: + "\ep_queues_blocked and in_ep_queue_at t ep_ptr\ + remove_and_restart_badged_thread t ep_ptr badge + \\_. ep_queues_blocked\" + unfolding remove_and_restart_badged_thread_def restart_thread_if_no_fault_def + by (wpsimp wp: set_thread_state_ep_queues_blocked_not_queued tcb_ep_dequeue_not_ep_queued gts_wp) + +lemma remove_and_restart_badged_thread_ntfn_queues_blocked: + "\ntfn_queues_blocked and not ntfn_queued t\ + remove_and_restart_badged_thread t ep_ptr badge + \\_. ntfn_queues_blocked\" + unfolding remove_and_restart_badged_thread_def restart_thread_if_no_fault_def + by (wpsimp wp: set_thread_state_ntfn_queues_blocked_not_queued tcb_ep_dequeue_not_ep_queued gts_wp) + +lemma remove_and_restart_badged_thread_other: + "\\s. Q (st_tcb_at P t s) \ t' \ t\ + remove_and_restart_badged_thread t' epptr badge + \\_ s. Q (st_tcb_at P t s)\" + unfolding remove_and_restart_badged_thread_def + by (wpsimp wp: restart_thread_if_no_fault_other reply_unlink_tcb_st_tcb_at_other gts_wp + hoare_vcg_all_lift hoare_vcg_imp_lift') + +lemma remove_and_restart_badged_thread_in_ep_queue_at_other: + "\\s. in_ep_queue_at t epptr s \ t' \ t\ + remove_and_restart_badged_thread t' epptr badge + \\_ s. in_ep_queue_at t epptr s\" + unfolding remove_and_restart_badged_thread_def + by (wpsimp wp: tcb_ep_dequeue_in_ep_queue_at_other gts_wp) + lemma cancelBadgedSends_corres: - "corres dc (invs and valid_sched and ep_at epptr and current_time_bounded) - (invs' and ep_at' epptr) - (cancel_badged_sends epptr bdg) (cancelBadgedSends epptr bdg)" + "corres dc + (invs and valid_sched and ep_at epptr and current_time_bounded) invs' + (cancel_badged_sends epptr bdg) (cancelBadgedSends epptr bdg)" apply add_sym_refs apply add_sch_act_wf + apply (rule_tac Q'="ep_at' epptr" in corres_cross_add_guard) + apply (fastforce intro!: ep_at_cross) apply (clarsimp simp: cancel_badged_sends_def cancelBadgedSends_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: sym_refs_asrt_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: sch_act_wf_asrt_def) - apply (rule corres_stateAssert_add_assertion[rotated]) + apply (rule corres_stateAssert_ignore, solves simp)+ + apply (rule corres_stateAssert_ignore) apply (fastforce intro: ksReadyQueues_asrt_cross) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getEndpoint_corres _ get_simple_ko_sp get_ep_sp', - where Q="invs and valid_sched and current_time_bounded" - and Q'="invs' and (\s. sym_refs (state_refs_of' s))"]) - apply simp_all + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ep_sp']) + apply (corres corres: getEndpoint_corres) + apply (rename_tac ep ep') 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) - apply (rule_tac F="distinct queue" in corres_gen_asm) - apply (rule corres_split_eqr) - apply (rule_tac P="\s. valid_sched s \ pspace_aligned s \ pspace_distinct s \ valid_objs s - \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) \ current_time_bounded s" - and Q="\t s. tcb_at t s \ (epptr, TCBBlockedSend) \ state_refs_of s t - \ t \ idle_thread s" - and P'="\s. valid_objs' s - \ valid_tcbs' s \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s" - and Q'="\t s. tcb_at' t s \ st_tcb_at' (not runnable') t s" - and S="{t. (fst t = snd t) \ fst t \ set queue}" - and r="(=)" - and r'="(=)" - in corres_mapM_scheme; (solves fastforce)?) - apply (clarsimp simp: liftM_def[symmetric]) + apply (rule_tac Q'="\s. list_queue_relation + queue (epQueue ep') (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + in corres_cross_add_guard) + apply (frule state_relation_ep_queues_relation) + apply (fastforce simp: ep_queues_relation_def opt_map_def eps_of_kh_def obj_at_def obj_at'_def + split: option.splits) + apply (rule_tac F="distinct queue" in corres_req) + apply (fastforce intro: heap_ls_distinct simp: list_queue_relation_def) + apply (rule corres_stateAssert_ignore) + apply (rule list_queue_relation_tcb_queue_head_end_valid) + apply fastforce + apply (fastforce dest: in_ep_queue_sched_flag_set[rotated] + elim: sym_refs_ep_queues_blocked[OF invs_sym_refs] + simp: eps_of_kh_def opt_map_def obj_at_def + split: option.splits) + apply (rule_tac Q="\_ s. ep_queues_blocked s \ ntfn_queues_blocked s + \ valid_objs s \ pspace_aligned s \ pspace_distinct s \ valid_sched s + \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) + \ current_time_bounded s " + and Q'="\_. valid_tcbs' and valid_sched_pointers" + in corres_split_forwards'[where r'=dc]) + apply (rule stronger_corres_guard_imp) + apply (clarsimp simp: threadGet_def) + apply (subst bind_dummy_ret_val)+ + apply (rule_tac P="\ls s. distinct ls + \ (ls \ [] + \ (\p \ set ls. in_ep_queue_at p epptr s \ \ ntfn_queued p s + \ not_queued p s \ not_in_release_q p s + \ st_tcb_at is_blocked_on_send p s)) + \ valid_objs s \ valid_idle s + \ ep_queues_blocked s \ ntfn_queues_blocked s + \ pspace_aligned s \ pspace_distinct s + \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) + \ valid_sched s \ current_time_bounded s" + and P'="\_. valid_objs' and valid_sched_pointers and sym_heap_sched_pointers + and pspace_aligned' and pspace_distinct' and pspace_bounded' + and ep_at' epptr" + in corres_mapM_x_whileLoop[where nexts_of=tcbSchedNexts_of]) apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac F="\pl. st = Structures_A.BlockedOnSend epptr pl" - in corres_gen_asm) - apply (rule corres_if2[where Q=\ and Q'=\]) - apply (clarsimp simp: blocking_ipc_badge_def blockingIPCBadge_def - split: thread_state.splits) - apply (clarsimp simp: o_def dc_def[symmetric] liftM_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF restart_thread_if_no_fault_corres]) - unfolding restartThreadIfNoFault_def - apply (rule corres_return_eq_same, simp) - apply (rule wp_post_taut) - apply (rule wp_post_taut) - apply (simp add: comp_apply)+ - apply (wpsimp wp: gts_wp) - apply (wpsimp wp: gts_wp') - apply clarsimp - apply (frule valid_sched_valid_ready_qs) - apply (frule valid_ready_qs_in_correct_ready_q) - apply (frule valid_sched_valid_release_q) - apply (frule TCBBlockedSend_in_state_refs_of) - apply (fastforce dest!: valid_release_q_not_in_release_q_not_runnable - simp: pred_tcb_at_def obj_at_def runnable_eq_active) - apply (clarsimp simp: st_tcb_def2 st_tcb_at_refs_of_rev) - apply (wpsimp wp: gts_wp) - apply (wpsimp wp: sts_st_tcb_at'_cases threadGet_wp gts_wp' hoare_vcg_imp_lift - simp: obj_at_ko_at'_eq[where P=\, simplified]) - apply (clarsimp simp: obj_at'_def pred_neg_def) - apply (wpsimp wp: restart_thread_if_no_fault_valid_sched_blocked_on_send[where epptr=epptr] - gts_wp) - apply (wpsimp wp: sts_weak_sch_act_wf sts_st_tcb_at'_cases hoare_vcg_imp_lift - threadGet_wp gts_wp' - simp: obj_at_ko_at'_eq[where P=\, simplified]) - apply (clarsimp simp: valid_tcb_state'_def obj_at'_def st_tcb_at'_def - pred_neg_def weak_sch_act_wf_def) - apply (rule corres_split[OF ]) - apply (rule setEndpoint_corres) - apply (simp split: list.split add: ep_relation_def) - apply (rule rescheduleRequired_corres) - apply (wp weak_sch_act_wf_lift_linear ready_qs_distinct_lift)+ - apply (rule_tac Q'="\_ s. valid_objs s \ pspace_aligned s \ pspace_distinct s - \ ep_at epptr s \ valid_sched s - \ heap_refs_inv (tcb_scps_of s) (sc_tcbs_of s) - \ current_time_bounded s" - in hoare_strengthen_post) - apply (rule_tac Q="\t s. tcb_at t s \ (epptr, TCBBlockedSend) \ state_refs_of s t - \ t \ idle_thread s" - in ball_mapM_scheme) - apply (wpsimp wp: restart_thread_if_no_fault_tcb_sts_of_other gts_wp) - apply (wpsimp wp: restart_thread_if_no_fault_valid_sched_blocked_on_send[where epptr=epptr] - gts_wp) - apply simp - apply (fastforce dest: valid_sched_valid_ready_qs) - apply (rule_tac P'="(\s. \t\set queue. tcb_at' t s \ st_tcb_at' (not runnable') t s) - and (\s. valid_tcbs' s \ sym_heap_sched_pointers s \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s - \ ep_at' epptr s)" - in hoare_weaken_pre[rotated], clarsimp) - apply simp - apply (rule hoare_strengthen_post) - apply (rule_tac Q="\t s. tcb_at' t s \ st_tcb_at' (not runnable') t s" - in ball_mapM_scheme) - apply (wpsimp wp: sts_st_tcb_at'_cases threadGet_wp gts_wp' hoare_vcg_imp_lift - simp: obj_at_ko_at'_eq[where P=\, simplified]) - apply (clarsimp simp: obj_at'_def pred_neg_def) - apply (wpsimp wp: sts_st_tcb_at'_cases threadGet_wp gts_wp' hoare_vcg_imp_lift - simp: obj_at_ko_at'_eq[where P=\, simplified]) - apply (fastforce simp: valid_tcb_state'_def obj_at'_def st_tcb_at'_def - pred_neg_def weak_sch_act_wf_def) - apply simp - apply simp - 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") - apply (fastforce simp: valid_objs_def valid_obj_def - dest: invs_valid_objs) - apply (intro conjI impI allI ballI; (fastforce simp: valid_ep_def obj_at_def is_tcb_def)?) - apply (fastforce intro: in_send_ep_queue_TCBBlockedSend) - apply (rule not_idle_tcb_in_SendEp; fastforce) - apply (clarsimp cong: conj_cong) - apply (prop_tac "valid_ep' (Structures_H.SendEP queue) s") - apply (fastforce simp: valid_objs'_def valid_obj'_def obj_at'_def - dest: invs_valid_objs') - apply (intro conjI impI ballI; (fastforce simp: valid_ep'_def obj_at'_def)?) - apply (frule (2) in_send_ep_queue_TCBBlockedSend') + apply (rule removeAndRestartBadgedThread_corres) + apply (fastforce dest: valid_sched_valid_release_q) + apply clarsimp + apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) + apply wpsimp + apply (fastforce elim: distinct_tl) + apply (wpsimp wp: remove_and_restart_badged_thread_in_ep_queue_at_other + remove_and_restart_badged_thread_other + hoare_vcg_const_imp_lift hoare_vcg_ball_lift) + apply (fastforce dest!: list.set_sel(2) distinct_hd_not_in_tl + intro: weak_valid_sched_action_scheduler_action_not + blocked_on_send_not_runnable) + apply (wpsimp simp: remove_and_restart_badged_thread_def wp: gts_wp) + apply (fastforce dest!: not_idle_thread' hd_in_set + simp: st_tcb_at_def obj_at_def) + apply (wpsimp wp: remove_and_restart_badged_thread_ep_queues_blocked) + apply (wpsimp wp: remove_and_restart_badged_thread_ntfn_queues_blocked) + apply (wpsimp wp: remove_and_restart_badged_thread_valid_sched) + apply (intro conjI) + apply (clarsimp simp: obj_at_kh_kheap_simps) + apply (erule not_idle_thread') + apply fastforce + apply fastforce + apply wpsimp + apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_ball_lift + removeAndRestartBadgedThread_sym_heap_sched_pointers) + apply (rule monadic_rewrite_guard_imp) + apply (rule threadGet_return_tcbSchedNexts_of[simplified threadGet_def]) + apply (force intro!: tcb_at_cross simp: ex_abs_def) + apply wpsimp + apply (force intro!: tcb_at_cross simp: ex_abs_def) + apply (wpsimp wp: removeAndRestartBadgedThread_tcbSchedNexts_of_other) + apply (clarsimp simp: ex_abs_def) + apply (rename_tac s) + apply (rule conjI) + apply clarsimp + apply (prop_tac "scheduler_action s = switch_thread t'") + apply (drule state_relation_sched_act_relation) + apply (clarsimp simp: sched_act_relation_def) + apply (case_tac "scheduler_action s"; clarsimp) + apply (fastforce dest!: valid_sched_weak_valid_sched_action + weak_valid_sched_action_scheduler_action_not + intro: blocked_on_send_not_runnable simp: scheduler_act_not_def) + apply (frule state_relation_ep_queues_relation) + apply (clarsimp simp: ep_queues_relation_def) + apply (drule_tac x=epptr in spec) + apply (fastforce simp: list_queue_relation_def) + apply clarsimp + apply (rename_tac s s') + apply (frule invs_sym_refs) + apply (frule sym_refs_ep_queues_blocked) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (prop_tac "ep_queues_of s epptr = Some queue") + apply (fastforce simp: opt_map_def eps_of_kh_def obj_at_def split: option.splits) + apply (prop_tac "\p \ set queue. st_tcb_at is_blocked_on_send p s") + apply (fastforce dest: in_send_ep_queue_st_tcb_at simp: obj_at_def elim: st_tcb_weakenE) + apply (intro conjI impI allI; fastforce?) + apply (clarsimp simp: in_ep_queue_at_def) + apply (intro conjI impI allI) + apply (force dest: ep_queues_ntfn_queues_disjoint + simp: in_ntfn_queue_at_def ntfn_queued_def) + apply (clarsimp simp: not_queued_def) + apply (force dest!: ep_queues_ready_queues_disjoint) + apply (clarsimp simp: not_in_release_q_def) + apply (fastforce dest!: ep_queues_release_queue_disjoint) + apply (fastforce simp: list_queue_relation_def) + apply (rule hoare_weaken_pre) + apply (rule_tac Q="\t s. in_ep_queue_at t epptr s \ \ ntfn_queued t s + \ not_queued t s \ not_in_release_q t s \ scheduler_act_not t s + \ st_tcb_at is_blocked_on_send t s \ t \ idle_thread s" + in ball_mapM_x_scheme) + apply (wpsimp wp: remove_and_restart_badged_thread_other + remove_and_restart_badged_thread_in_ep_queue_at_other) + apply (wpsimp wp: remove_and_restart_badged_thread_valid_sched + remove_and_restart_badged_thread_ep_queues_blocked + remove_and_restart_badged_thread_ntfn_queues_blocked) + apply (clarsimp simp: obj_at_kh_kheap_simps) + apply fastforce + apply (clarsimp simp: valid_ep_def cong: conj_cong) + apply (rename_tac s ) + apply (frule invs_sym_refs) + apply (frule sym_refs_ep_queues_blocked) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (prop_tac "ep_queues_of s epptr = Some queue") + apply (fastforce simp: opt_map_def eps_of_kh_def obj_at_def split: option.splits) + apply (prop_tac "\p \ set queue. st_tcb_at is_blocked_on_send p s") + apply (fastforce dest: in_send_ep_queue_st_tcb_at simp: obj_at_def elim: st_tcb_weakenE) + apply (intro conjI impI allI ballI; fastforce?) + apply (force simp: in_ep_queue_at_def ep_at_pred_def obj_at_def) + apply (clarsimp simp: in_ep_queue_at_def) + apply (force dest: ep_queues_ntfn_queues_disjoint + simp: in_ntfn_queue_at_def ntfn_queued_def) + apply (clarsimp simp: not_queued_def) + apply (force dest!: ep_queues_ready_queues_disjoint) + apply (clarsimp simp: not_in_release_q_def) + apply (fastforce dest!: ep_queues_release_queue_disjoint) + apply (fastforce intro: weak_valid_sched_action_scheduler_action_not + blocked_on_send_not_runnable) + apply (rule not_idle_thread', fastforce+) + apply (rule_tac Q'="\_. pspace_aligned' and pspace_distinct' and pspace_bounded' + and valid_objs' and valid_sched_pointers and sym_heap_sched_pointers" + in hoare_post_imp) + apply fastforce + apply (wpsimp wp: whileLoop_valid_inv removeAndRestartBadgedThread_sym_heap_sched_pointers) apply fastforce - apply (fastforce simp: st_tcb_at_refs_of_rev' st_tcb_at'_def obj_at'_def pred_neg_def comp_apply) + apply (corres corres: rescheduleRequired_corres) + apply (frule valid_sched_valid_ready_qs) + apply (fastforce dest: valid_sched_valid_release_q) + apply fastforce done -crunch schedContextCancelYieldTo, tcbReleaseRemove +crunch schedContextCancelYieldTo, tcbReleaseRemove, setThreadState, updateRestartPC for tcbQueued[wp]: "obj_at' (\obj. P (tcbQueued obj)) t" - (wp: crunch_wps simp: crunch_simps setReleaseQueue_def setReprogramTimer_def getReleaseQueue_def) lemma suspend_unqueued: - "\\\ suspend t \\rv. obj_at' (Not \ tcbQueued) t\" - apply (simp add: suspend_def unless_def tcbSchedDequeue_def) - apply (wp hoare_vcg_if_lift hoare_vcg_conj_lift hoare_vcg_imp_lift) - apply (wpsimp simp: threadGet_getObject comp_def wp: getObject_tcb_wp)+ - apply (rule hoare_strengthen_post, rule hoare_TrueI) - apply (fastforce simp: obj_at'_def) - apply (rule hoare_TrueI) - apply wpsimp+ - done + "\\\ suspend t \\_. obj_at' (Not \ tcbQueued) t\" + unfolding suspend_def comp_def + by (wpsimp wp: tcbSchedDequeue_not_tcbQueued[simplified comp_def]) -crunch schedContextCancelYieldTo, tcbQueueRemove - for not_tcbInReleaseQueue[wp]: "obj_at' (\tcb. \ tcbInReleaseQueue tcb) t" +crunch schedContextCancelYieldTo, tcbQueueRemove, setThreadState + for not_tcbInReleaseQueue[wp]: "obj_at' (\tcb. P (tcbInReleaseQueue tcb)) t" (wp: crunch_wps) lemma tcbReleaseRemove_flag_not_set: - "\\\ tcbReleaseRemove t \\_. obj_at' (\tcb. \ tcbInReleaseQueue tcb) t\" + "\\\ tcbReleaseRemove t \\_. obj_at' (Not \ tcbInReleaseQueue) t\" apply (simp add: tcbReleaseRemove_def) apply (wpsimp wp: inReleaseQueue_wp) apply (clarsimp simp: obj_at'_def) done lemma suspend_flag_not_set: - "\\\ suspend t \\rv. obj_at' (\tcb. \ tcbInReleaseQueue tcb) t\" - apply (simp add: suspend_def) - apply (wpsimp wp: tcbReleaseRemove_flag_not_set) - done + "\\\ suspend t \\_. obj_at' (Not \ tcbInReleaseQueue) t\" + unfolding suspend_def comp_def + by (wpsimp wp: tcbReleaseRemove_flag_not_set[simplified comp_def]) crunch prepareThreadDelete for unqueued: "obj_at' (Not \ tcbQueued) t" diff --git a/proof/refine/RISCV64/Ipc_R.thy b/proof/refine/RISCV64/Ipc_R.thy index a0e2a31118..5f0c001890 100644 --- a/proof/refine/RISCV64/Ipc_R.thy +++ b/proof/refine/RISCV64/Ipc_R.thy @@ -785,12 +785,6 @@ crunch setExtraBadge and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" and inQ_tcbs_of'[wp]: "\s. P (inQ d p |< tcbs_of' s)" -lemma tcts_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - transferCapsToSlots ep buffer n caps slots mi - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift tcb_in_cur_domain'_lift transferCapsToSlots_pres1) - crunch setExtraBadge for state_refs_of'[wp]: "\s. P (state_refs_of' s)" @@ -800,17 +794,6 @@ lemma tcts_state_refs_of'[wp]: \\rv s. P (state_refs_of' s)\" by (wp transferCapsToSlots_pres1) -crunch setExtraBadge - for if_live'[wp]: if_live_then_nonz_cap' - -lemma tcts_iflive[wp]: - "\\s. if_live_then_nonz_cap' s \ distinct slots \ - (\x\set slots. - ex_cte_cap_to' x s \ cte_wp_at' (\cte. cteCap cte = capability.NullCap) x s)\ - transferCapsToSlots ep buffer n caps slots mi - \\rv. if_live_then_nonz_cap'\" - by (wp transferCapsToSlots_pres2 | simp)+ - crunch setExtraBadge for if_unsafe'[wp]: if_unsafe_then_cap' @@ -947,15 +930,6 @@ lemma transferCapsToSlots_vms[wp]: crunch setExtraBadge, transferCapsToSlots for pspace_domain_valid[wp]: "pspace_domain_valid" -crunch setExtraBadge - for ct_not_inQ[wp]: "ct_not_inQ" - -lemma tcts_ct_not_inQ[wp]: - "\ct_not_inQ\ - transferCapsToSlots ep buffer n caps slots mi - \\_. ct_not_inQ\" - by (wp transferCapsToSlots_pres1) - crunch setExtraBadge for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" crunch setExtraBadge @@ -984,8 +958,7 @@ lemma tcts_zero_ranges[wp]: done crunch setExtraBadge, transferCapsToSlots - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + for ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and replies_of'[wp]: "\s. P (replies_of' s)" @@ -1191,7 +1164,7 @@ global_interpretation copyMRs: typ_at_all_props' "copyMRs s sb r rb n" context begin interpretation Arch . (*FIXME: arch-split*) lemma copy_mrs_invs'[wp]: - "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" + "copyMRs s sb r rb n \invs'\" including classic_wp_pre apply (simp add: copyMRs_def) apply (wp dmo_invs' no_irq_mapM no_irq_storeWord| @@ -1238,16 +1211,11 @@ crunch copyMRs lemma setMRs_invs_bits[wp]: "\valid_pspace'\ setMRs t buf mrs \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ - setMRs t buf mrs \\rv s. sch_act_wf (ksSchedulerAction s) s\" "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setMRs t buf mrs \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" "\\s. P (state_refs_of' s)\ setMRs t buf mrs \\rv s. P (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ setMRs t buf mrs \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ setMRs t buf mrs \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ setMRs t buf mrs \\rv. cur_tcb'\" "\if_unsafe_then_cap'\ setMRs t buf mrs \\rv. if_unsafe_then_cap'\" by (simp add: setMRs_def zipWithM_x_mapM split_def storeWordUser_def | wp crunch_wps)+ @@ -1257,14 +1225,9 @@ crunch setMRs lemma copyMRs_invs_bits[wp]: "\valid_pspace'\ copyMRs s sb r rb n \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ copyMRs s sb r rb n - \\rv s. sch_act_wf (ksSchedulerAction s) s\" "\\s. P (state_refs_of' s)\ copyMRs s sb r rb n \\rv s. P (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ copyMRs s sb r rb n \\rv. if_live_then_nonz_cap'\" - "\ex_nonz_cap_to' p\ copyMRs s sb r rb n \\rv. ex_nonz_cap_to' p\" - "\cur_tcb'\ copyMRs s sb r rb n \\rv. cur_tcb'\" "\if_unsafe_then_cap'\ copyMRs s sb r rb n \\rv. if_unsafe_then_cap'\" by (simp add: copyMRs_def storeWordUser_def | wp mapM_wp' | wpc)+ @@ -1493,18 +1456,13 @@ global_interpretation doNormalTransfer: typ_at_all_props' "doNormalTransfer s sb by typ_at_props' lemma doNormal_invs'[wp]: - "\tcb_at' sender and tcb_at' receiver and invs'\ - doNormalTransfer sender send_buf ep badge - can_grant receiver recv_buf \\r. invs'\" - apply (simp add: doNormalTransfer_def) - apply (wp hoare_vcg_const_Ball_lift | simp)+ - done + "doNormalTransfer sender send_buf ep badge can_grant receiver recv_buf \invs'\" + unfolding doNormalTransfer_def + by (wpsimp wp: hoare_vcg_const_Ball_lift) crunch doNormalTransfer - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps) -crunch doNormalTransfer - for distinct'[wp]: pspace_distinct' + for pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' (wp: crunch_wps) lemma transferCaps_urz[wp]: @@ -1678,16 +1636,11 @@ lemma doFaultTransfer_corres: apply (wp | simp)+ done -crunch makeFaultMessage - for iflive[wp]: if_live_then_nonz_cap' - crunch makeFaultMessage for invs'[wp]: invs' lemma doFaultTransfer_invs'[wp]: - "\invs' and tcb_at' receiver and tcb_at' sender\ - doFaultTransfer badge sender receiver recv_buf - \\_. invs'\" + "doFaultTransfer badge sender receiver recv_buf \invs'\" by (wpsimp simp: doFaultTransfer_def split_def split: option.split) lemma doIPCTransfer_corres: @@ -1734,8 +1687,6 @@ lemma doIPCTransfer_corres: crunch doIPCTransfer for ifunsafe[wp]: "if_unsafe_then_cap'" - and iflive[wp]: "if_live_then_nonz_cap'" - and sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" and state_refs_of[wp]: "\s. P (state_refs_of' s)" and typ_at'[wp]: "\s. P (typ_at' T p s)" and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" @@ -1774,18 +1725,11 @@ crunch doIPCTransfer and irq_handlers'[wp]: "valid_irq_handlers'" and irq_states'[wp]: "valid_irq_states'" and irqs_masked'[wp]: "irqs_masked'" + and invs'[wp]: invs' (wp: crunch_wps hoare_vcg_const_Ball_lift simp: zipWithM_x_mapM ball_conj_distrib rule: irqs_masked_lift) -lemma doIPCTransfer_invs[wp]: - "\invs' and tcb_at' s and tcb_at' r\ - doIPCTransfer s ep bg grt r - \\rv. invs'\" - apply (simp add: doIPCTransfer_def) - apply (wpsimp wp: hoare_drop_imp) - done - lemma sanitise_register_corres: "foldl (\s (a, b). UserContext ((user_regs s)(a := sanitise_register x a b))) s (zip msg_template msg) = @@ -1853,44 +1797,10 @@ lemma doIPCTransfer_sch_act_simple [wp]: "\sch_act_simple\ doIPCTransfer sender endpoint badge grant receiver \\_. sch_act_simple\" by (simp add: sch_act_simple_def, wp) -crunch isFinalCapability - for cur' [wp]: "\s. P (cur_tcb' s)" - (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv) - -lemma finaliseCapTrue_standin_tcb_at' [wp]: - "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" - by (rule finaliseCapTrue_standin_tcbDomain_obj_at') - crunch finaliseCapTrue_standin for ct'[wp]: "\s. P (ksCurThread s)" (wp: crunch_wps simp: crunch_simps) -lemma finaliseCapTrue_standin_cur': - "\\s. cur_tcb' s\ finaliseCapTrue_standin cap v2 \\_ s'. cur_tcb' s'\" - unfolding cur_tcb'_def - by (wp_pre, wps, wp, assumption) - -lemma cteDeleteOne_cur' [wp]: - "\\s. cur_tcb' s\ cteDeleteOne slot \\_ s'. cur_tcb' s'\" - apply (simp add: cteDeleteOne_def unless_def when_def) - apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' - | simp add: split_def | wp (once) cur_tcb_lift)+ - done - -lemma handleFaultReply_cur' [wp]: - "\\s. cur_tcb' s\ handleFaultReply x0 thread label msg \\_ s'. cur_tcb' s'\" - apply (clarsimp simp add: cur_tcb'_def) - apply (rule hoare_lift_Pf2 [OF _ handleFaultReply_ct']) - apply (wp) - done - -lemma emptySlot_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - emptySlot slot irq - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp weak_sch_act_wf_lift tcb_in_cur_domain'_lift) - lemma cancelAllIPC_weak_sch_act_wf[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ cancelAllIPC epptr @@ -1912,19 +1822,10 @@ crunch unbindMaybeNotification, schedContextMaybeUnbindNtfn, isFinalCapability, for sch_act_not[wp]: "sch_act_not t" (wp: crunch_wps simp: crunch_simps) -crunch replyRemove, replyRemoveTCB, cancelSignal, cancelIPC, replyClear, cteDeleteOne - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (simp: crunch_simps wp: crunch_wps) - context begin interpretation Arch . (*FIXME: arch-split*) crunch handleFaultReply for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - and tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - -crunch unbindNotification - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: sbn_sch_act') crunch handleFaultReply for valid_objs'[wp]: valid_objs' @@ -2024,30 +1925,28 @@ lemma bind_sc_reply_invs[wp]: lemma update_sk_obj_ref_in_correct_ready_q[wp]: "update_sk_obj_ref C f ref new \in_correct_ready_q\" - unfolding update_sk_obj_ref_def set_simple_ko_def get_simple_ko_def - apply (wpsimp wp: set_object_wp get_object_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps in_correct_ready_q_def) - apply (fastforce simp: pred_map_def map_project_def opt_map_def tcbs_of_kh_def) - done + by (wpsimp wp: in_correct_ready_q_lift) crunch update_sk_obj_ref for ready_qs_distinct[wp]: ready_qs_distinct (rule: ready_qs_distinct_lift) -lemma update_sched_context_in_correct_ready_q[wp]: - "update_sched_context ptr f \in_correct_ready_q\" - unfolding update_sched_context_def set_simple_ko_def get_simple_ko_def - apply (wpsimp wp: set_object_wp get_object_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps in_correct_ready_q_def) - apply (fastforce simp: pred_map_def map_project_def opt_map_def tcbs_of_kh_def) - done +crunch update_sched_context + for in_correct_ready_q[wp]: in_correct_ready_q + (wp: in_correct_ready_q_lift) crunch bind_sc_reply for release_queue[wp]: "\s. P (release_queue s)" and in_correct_ready_q[wp]: in_correct_ready_q and ready_queues[wp]: "\s. P (ready_queues s)" and ready_qs_distinct[wp]: ready_qs_distinct - (wp: crunch_wps ready_qs_distinct_lift) + and ready_queues_runnable [wp]: ready_queues_runnable + and release_q_runnable[wp]: release_q_runnable + and ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (wp: crunch_wps ready_qs_distinct_lift ready_queues_runnable_lift release_q_runnable_lift + ep_queues_blocked_lift ntfn_queues_blocked_lift + ignore: update_sk_obj_ref) crunch test_reschedule for in_correct_ready_q[wp]: in_correct_ready_q @@ -2082,16 +1981,86 @@ crunch bindScReply and valid_sched_pointers[wp]: valid_sched_pointers (simp: crunch_simps) +lemma set_thread_state_release_q_runnable_not_in_release_q: + "\release_q_runnable and not_in_release_q t\ set_thread_state t st \\_. release_q_runnable\" + unfolding release_q_runnable_def + apply (rule hoare_weaken_pre) + apply (rule_tac Q="\x s. \t'\set x. st_tcb_at runnable t' s \ t \ set x" + in hoare_lift_Pf_pre_conj[where g=release_queue]) + apply (wpsimp wp: hoare_vcg_ball_lift sts_st_tcb_at_other) + apply wpsimp + apply (fastforce simp: not_in_release_q_def) + done + +crunch set_reply_obj_ref + for ready_queues_runnable[wp]: ready_queues_runnable + and release_q_runnable[wp]: release_q_runnable + and ntfn_queued[wp]: "\s. P (ntfn_queued ntfn_ptr s)" + (wp: ready_queues_runnable_lift release_q_runnable_lift ntfn_queued_lift) + +lemma not_ep_blocked_not_ep_queued: + "\st_tcb_at (\ts. ep_blocked ts = None) tcbPtr s; ep_queues_blocked s\ \ \ ep_queued tcbPtr s" + apply (clarsimp simp: ep_queues_blocked_def opt_map_def ep_blocked_def eps_of_kh_def ep_queued_def + in_ep_queue_at_def st_tcb_at_def obj_at_def + split: option.splits) + apply (rename_tac p ep) + apply (drule_tac x=p in spec) + apply clarsimp + apply (fastforce split: Structures_A.thread_state.splits) + done + +lemma runnable_not_ep_queued: + "\st_tcb_at runnable tcbPtr s; ep_queues_blocked s\ \ \ ep_queued tcbPtr s" + apply (rule not_ep_blocked_not_ep_queued) + apply (force simp: pred_tcb_at_def obj_at_def ep_blocked_def + split: Structures_A.thread_state.splits) + apply fastforce + done + +lemma not_ntfn_blocked_not_ntfn_queued: + "\st_tcb_at (\ts. ntfn_blocked ts = None) tcbPtr s; ntfn_queues_blocked s\ + \ \ ntfn_queued tcbPtr s" + apply (clarsimp simp: ntfn_queues_blocked_def opt_map_def ntfn_blocked_def ntfn_queued_def + in_ntfn_queue_at_def st_tcb_at_def obj_at_def + split: option.splits) + apply (rename_tac p ntfn) + apply (drule_tac x=p in spec) + apply clarsimp + apply (fastforce split: Structures_A.thread_state.splits) + done + +lemma runnable_not_ntfn_queued: + "\st_tcb_at runnable tcbPtr s; ntfn_queues_blocked s\ \ \ ntfn_queued tcbPtr s" + apply (rule not_ntfn_blocked_not_ntfn_queued) + apply (force simp: pred_tcb_at_def obj_at_def ntfn_blocked_def + split: Structures_A.thread_state.splits) + apply fastforce + done + +defs not_sched_linked_asrt_def: + "not_sched_linked_asrt t \ \s. \ is_sched_linked t s" + +declare not_sched_linked_asrt_def[simp] + +defs reply_object_asrt_def: + "reply_object_asrt t \ \s. st_tcb_at' (\st. is_replyState st \ replyObject st = None) t s" + +declare reply_object_asrt_def[simp] + lemma replyPush_corres: "can_donate = can_donate' \ corres dc (valid_replies and pspace_aligned and pspace_distinct and valid_objs and K (caller \ idle_thread_ptr) and tcb_at callee and active_scs_valid and (\s. distinct (release_queue s)) and in_correct_ready_q and ready_qs_distinct + and ready_queues_runnable and release_q_runnable and ready_or_release + and ep_queues_blocked and ntfn_queues_blocked and st_tcb_at (\st. reply_object st = None) caller and ex_nonz_cap_to reply_ptr and reply_sc_reply_at (\tptr. tptr = None) reply_ptr and reply_tcb_reply_at (\tptr. tptr = None) reply_ptr and weak_valid_sched_action and scheduler_act_not caller + and not_queued caller and not_in_release_q caller + and not ep_queued caller and not ntfn_queued caller and (\s. reply_ptr \ fst ` replies_with_sc s) and (\s. sym_refs (\p. if p = caller then tcb_non_st_state_refs_of s caller @@ -2099,75 +2068,89 @@ lemma replyPush_corres: and valid_idle) (sym_heap_sched_pointers and valid_sched_pointers and valid_objs' and pspace_aligned' and pspace_distinct' and pspace_bounded' - and valid_replies'_sc_asrt reply_ptr) + and valid_replies'_sc_asrt reply_ptr + and (\s. \ is_sched_linked caller s)) (reply_push caller callee reply_ptr can_donate) (replyPush caller callee reply_ptr can_donate')" apply add_valid_idle' unfolding reply_push_def replyPush_def apply clarsimp - apply (rule corres_stateAssert_implied[where P'=\, simplified]) - apply (rule corres_stateAssert_implied[where P'=\, simplified, rotated],clarsimp) - apply (rule corres_stateAssert_ignore, simp) - apply (rule stronger_corres_guard_imp) - apply (simp add: get_tcb_obj_ref_def) - apply (rule corres_split_eqr[OF threadGet_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split_eqr[OF threadGet_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split [OF replyTCB_update_corres]) - apply (rule corres_split [OF setThreadState_corres]) - apply simp - apply (rule corres_when2, clarsimp) - apply (rule corres_split [OF bindScReply_corres schedContextDonate_corres]) - apply (wpsimp wp: sc_at_typ_at) - apply (wpsimp wp: sym_heap_sched_pointers_lift) - apply simp - apply (wpsimp wp: sts_valid_replies hoare_vcg_imp_lift' - hoare_vcg_all_lift sts_in_replies_blocked - set_thread_state_weak_valid_sched_action) - apply (wpsimp wp: hoare_vcg_imp_lift' sts_invs_minor') - apply clarsimp - apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - apply (clarsimp simp: valid_tcb_state'_def cong: conj_cong) - apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift updateReply_valid_objs') - apply (wpsimp wp: thread_get_wp) - apply (wpsimp wp: threadGet_wp) - apply (wpsimp wp: thread_get_wp') - apply (wpsimp wp: threadGet_wp) - apply clarsimp - apply (frule reply_tcb_reply_at) - apply (subgoal_tac "caller \ reply_ptr") - apply (subgoal_tac "caller \ idle_thread_ptr") - apply (clarsimp simp: st_tcb_at_tcb_at cong: conj_cong) - apply (erule obj_at_weakenE) - apply (frule valid_objs_valid_tcbs, clarsimp) - apply (clarsimp simp: is_tcb) - apply (frule (1) valid_objs_ko_at[where ptr=caller]) - apply (clarsimp simp: valid_obj_def valid_tcb_def) - apply (subst sc_at_ppred_exm; clarsimp) - apply (clarsimp simp: replies_with_sc_def image_def obj_at_def is_sc_obj) - apply (rule conjI) - apply (erule replies_blocked_upd_tcb_st_valid_replies_not_blocked; - fastforce intro!: not_BlockedOnReply_not_in_replies_blocked - elim!: st_tcb_weakenE) - subgoal for s s' tcb - by (erule delta_sym_refs; clarsimp split: if_splits; - fastforce dest: reply_tcb_reply_at_ReplyTCB_in_state_refs_of - st_tcb_at_TCBReply_in_state_refs_of) - apply (clarsimp simp: valid_obj_def valid_tcb_def) - apply (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def) - apply (clarsimp simp: obj_at_def is_tcb is_reply) + apply (rule corres_stateAssert_implied[where P'=\, simplified, rotated]) + apply (clarsimp simp: valid_reply'_def obj_at'_def) + apply (rule corres_stateAssert_implied[where P'=\, simplified, rotated],clarsimp) + apply (rule corres_stateAssert_ignore, simp) + apply (rule corres_stateAssert_ignore, simp) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ get_reply_sp', rotated]; (solves wpsimp)?) + apply wpsimp + apply (clarsimp simp: ex_abs_def) + apply (force intro!: reply_at_cross + simp: reply_at_ppred_def obj_at_def is_reply_def) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (clarsimp simp: obj_at'_def) + apply (frule state_relation_pspace_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation) + apply (force dest!: replies_relation_reply_relation_conc + simp: reply_at_ppred_def obj_at_def reply_relation_def) + apply (rule corres_stateAssert_ignore) + apply clarsimp + apply (frule (3) st_tcb_at_coerce_concrete) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def st_tcb_at_def pred_tcb_at_def obj_at_def + thread_state_relation_def) + apply (rename_tac st', case_tac "st'"; clarsimp simp: isReply_def) + apply (rule stronger_corres_guard_imp) + apply (simp add: get_tcb_obj_ref_def) + apply (rule corres_split_eqr[OF threadGet_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_split_eqr[OF threadGet_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_split [OF replyTCB_update_corres]) + apply (rule corres_split [OF setThreadState_corres]) + apply simp + apply (rule corres_when2, clarsimp) + apply (rule corres_split [OF bindScReply_corres schedContextDonate_corres]) + apply (wpsimp wp: sc_at_typ_at) + apply (wpsimp wp: sym_heap_sched_pointers_lift) + apply simp + apply (wpsimp wp: sts_valid_replies hoare_vcg_imp_lift' + hoare_vcg_all_lift sts_in_replies_blocked + set_thread_state_weak_valid_sched_action + set_thread_state_ready_queues_runnable_not_queued + set_thread_state_release_q_runnable_not_in_release_q + set_thread_state_ep_queues_blocked_not_queued + set_thread_state_ntfn_queues_blocked_not_queued) + apply (wpsimp wp: hoare_vcg_imp_lift' sts_invs_minor' + setThreadState_sched_pointers_valid_sched_pointers) + apply clarsimp + apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) + apply (clarsimp simp: cong: conj_cong) + apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift updateReply_valid_objs') + apply (wpsimp wp: thread_get_wp) + apply (wpsimp wp: threadGet_wp) + apply (wpsimp wp: thread_get_wp') + apply (wpsimp wp: threadGet_wp) apply clarsimp apply (frule reply_tcb_reply_at) - apply (frule valid_objs'_valid_tcbs') - apply (frule cross_relF[OF _ tcb_at'_cross_rel[where t=caller]], fastforce, clarsimp) - apply (frule cross_relF[OF _ reply_at'_cross_rel[where t=reply_ptr]], fastforce, clarsimp) - apply (prop_tac "obj_at' (\t. valid_bound_sc' (tcbSchedContext t) s') caller s'") - apply (erule valid_tcbs'_obj_at'[rotated]) - apply (clarsimp simp: valid_tcb'_def) - apply clarsimp - apply (clarsimp simp: valid_reply'_def obj_at'_def) - apply (clarsimp simp: sym_refs_asrt_def) + apply (subgoal_tac "caller \ reply_ptr") + apply (subgoal_tac "caller \ idle_thread_ptr") + apply (clarsimp simp: st_tcb_at_tcb_at cong: conj_cong) + apply (erule obj_at_weakenE) + apply (frule valid_objs_valid_tcbs, clarsimp) + apply (clarsimp simp: is_tcb) + apply (frule (1) valid_objs_ko_at[where ptr=caller]) + apply (clarsimp simp: valid_obj_def valid_tcb_def) + apply (subst sc_at_ppred_exm; clarsimp) + apply (clarsimp simp: replies_with_sc_def image_def obj_at_def is_sc_obj) + apply (rule conjI) + apply (erule replies_blocked_upd_tcb_st_valid_replies_not_blocked; + fastforce intro!: not_BlockedOnReply_not_in_replies_blocked + elim!: st_tcb_weakenE) + subgoal for s s' tcb + by (erule delta_sym_refs; clarsimp split: if_splits; + fastforce dest: reply_tcb_reply_at_ReplyTCB_in_state_refs_of + st_tcb_at_TCBReply_in_state_refs_of) + apply (fastforce dest: runnable_not_ep_queued) + apply (clarsimp simp: pred_tcb_at_def obj_at_def is_tcb is_reply) + apply (clarsimp simp: valid_reply'_def obj_at'_def) done crunch handle_fault_reply @@ -2251,27 +2234,14 @@ lemma isValidTimeoutHandler_sp: declare no_fail_getSlotCap [wp] -lemma cteInsert_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - cteInsert newCap srcSlot destSlot - \\_ s. sch_act_wf (ksSchedulerAction s) s\" -by (wp sch_act_wf_lift tcb_in_cur_domain'_lift) - crunch doIPCTransfer, possibleSwitchTo for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" (wp: mapM_wp' crunch_wps simp: zipWithM_x_mapM) -lemma setSchedulerAction_ct_in_domain: - "\\s. ct_idle_or_in_cur_domain' s - \ p \ ResumeCurrentThread \ setSchedulerAction p - \\_. ct_idle_or_in_cur_domain'\" - by (simp add:setSchedulerAction_def | wp)+ - crunch doIPCTransfer, possibleSwitchTo - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - (wp: crunch_wps setSchedulerAction_ct_in_domain simp: zipWithM_x_mapM) + (wp: crunch_wps simp: zipWithM_x_mapM) crunch doIPCTransfer for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" @@ -2305,68 +2275,257 @@ lemma reply_push_valid_objs: apply (clarsimp simp: obj_at_def is_tcb sk_obj_at_pred_def is_reply) done -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)" +lemma det_wp_ordered_insert[wp]: + "det_wp (\s. (\t \ set ts. \v. f t s = Some v) \ (\v. f t s = Some v)) (ordered_insert t ts f R)" + apply (clarsimp simp: ordered_insert_def) + apply wpsimp + done + +lemmas no_fail_ordered_insert[wp] = det_wp_no_fail[OF det_wp_ordered_insert] + +lemma det_wp_tcb_append[wp]: + "det_wp (\s. (\t \ set qs. tcb_at t s) \ tcb_at tptr s) (tcb_append tptr qs)" + unfolding tcb_append_def + apply wpsimp + apply (fastforce intro: no_ofailD[OF thread_read_no_ofail]) + done + +lemmas no_fail_tcb_append[wp] = det_wp_no_fail[OF det_wp_tcb_append] -defs priority_ordered'_asrt_def: - "priority_ordered'_asrt \ priority_ordered'" +lemma det_wp_tcb_append_set_endpoint[wp]: + "det_wp + (\s. (\t \ set qs. tcb_at t s) \ tcb_at tptr s \ ep_at epPtr s) + (do q' \ tcb_append tptr qs; set_endpoint epPtr (update_ep_queue ep q' isRecv) od)" + by wpsimp -declare priority_ordered'_asrt_def[simp] +lemmas no_fail_tcb_append_set_endpoint = det_wp_no_fail[OF det_wp_tcb_append_set_endpoint] -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) +lemma tcb_append_set_endpoint_empty_fail: + "empty_fail (do q' \ tcb_append tptr qs; set_endpoint epPtr (update_ep_queue ep q' isRecv) od)" + by wpsimp + +lemmas tcb_append_rules = + det_wp_tcb_append no_fail_tcb_append + det_wp_tcb_append_set_endpoint no_fail_tcb_append_set_endpoint + tcb_append_empty_fail tcb_append_set_endpoint_empty_fail + +crunch orderedInsert + for valid_objs'[wp]: valid_objs' + and obj_at'_endpoint[wp]: "\s. Q (obj_at' (\ep. (P :: endpoint \ bool) ep) epPtr s)" + and obj_at'_notification[wp]: "\s. Q (obj_at' (\ep. (P :: notification \ bool) ep) epPtr s)" + (wp: crunch_wps) + +method ipc_append = + (rule det_wp_pre no_fail_pre, rule tcb_append_rules, fastforce)[1] | wpsimp + +lemma threadGet_rcorres: + "(\tcb tcb'. tcb_relation tcb tcb' \ rrel (f tcb) (f' tcb')) + \ rcorres + (\s s'. tcbs_relation s s' \ tcb_at t s) + (gets_the (thread_read f t)) (gets_the (threadRead f' t)) + (\rv rv' _ _. rrel rv rv')" + apply (rule rcorres_gets_the_fwd) + apply (clarsimp simp: thread_read_Some_tcbs_of obj_at_def is_tcb_def) + apply (rename_tac ko, case_tac ko; clarsimp) + apply (frule threadRead_SomeD) + apply (fastforce simp: map_relation_def tcbs_of_kh_def opt_map_def obj_at'_def + split: option.splits) + apply wpsimp done -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)+ +lemma tcbAppend_rcorres: + "rcorres + (\s s'. (sorted_wrt (img_ord (prios_of s) (opt_ord_rel (\x y. y \ x))) ts) + \ list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ heap_pspace_relation s s' \ sym_heap_sched_pointers s' + \ pspace_aligned s \ pspace_distinct s + \ \ is_sched_linked t s' \ t \ set ts \ (\t \ set ts. tcb_at t s) \ tcb_at t s) + (tcb_append t ts) (tcbAppend t q) + (\ts' q' s s'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (clarsimp simp: tcb_append_def tcbAppend_def) + apply (rule rcorres_stateAssert_r_fwd) + apply (rcorres rcorres: orderedInsert_rcorres threadGet_rcorres + simp: tcb_relation_def) + apply (fastforce intro!: tcb_at_cross + simp: thread_read_Some_tcbs_of pspace_relation_heap_pspace_relation) + done + +lemma tcbAppend_rcorres_other: + "rcorres + (\s s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ heap_pspace_relation s s' \ sym_heap_sched_pointers s' + \ pspace_aligned s \ pspace_distinct s + \ t \ set ts \ set ts \ set ts' = {} \ tcb_at t s \ (\t \ set ts'. tcb_at t s)) + (tcb_append t ts') (tcbAppend t q') + (\_ _ s s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (clarsimp simp: tcb_append_def tcbAppend_def) + apply (rule rcorres_stateAssert_r_fwd) + apply (rcorres rcorres: orderedInsert_rcorres_other threadGet_rcorres + simp: tcb_relation_def) + apply (fastforce intro!: tcb_at_cross simp: pspace_relation_heap_pspace_relation) done -crunch tcbEPAppend - for ep_at'[wp]: "ep_at' epptr" - (wp: crunch_wps) +lemma tcbEPAppend_corres: + "\tcb_ptr = tcbPtr; ep_ptr = epPtr\ \ + corres dc + (not ep_queued tcbPtr and not ntfn_queued tcbPtr + and not_queued tcbPtr and not_in_release_q tcbPtr and ep_at ep_ptr and tcb_at tcb_ptr + and ep_queues_blocked and ntfn_queues_blocked and ready_queues_runnable and release_q_runnable + and valid_objs and sorted_ipc_queues and in_correct_ready_q and ready_qs_distinct + and ready_or_release and pspace_aligned and pspace_distinct + and K (state = (if is_recv then ReceiveEPState else SendEPState))) + (\s. sym_heap_sched_pointers s \ valid_objs' s \ \ is_sched_linked tcbPtr s + \ obj_at' (\ep. epState ep \ IdleEPState \ epState ep = state) epPtr s) + (tcb_ep_append tcb_ptr ep_ptr is_recv) (tcbEPAppend tcbPtr epPtr state)" + supply if_split[split del] tcb_append_rv_wf'[wp del] tcb_append_rv_wf''[wp del] + ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + heap_ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + apply (rule corres_gen_asm') + apply (rule_tac Q'="tcb_at' tcb_ptr" in corres_cross_add_guard, fastforce intro!: tcb_at_cross) + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest!: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest!: pspace_distinct_cross) + apply (rule_tac Q'="ep_at' epPtr" in corres_cross_add_guard, fastforce intro!: ep_at_cross) + apply (clarsimp simp: tcb_ep_append_def tcbEPAppend_def) + apply (rule corres_stateAssert_ignore, simp) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ep_sp']) + apply (corres corres: getEndpoint_corres) + apply (rename_tac ep ep') + apply (rule_tac Q="\s. ep_queues_of s ep_ptr = Some (ep_queue ep) + \ valid_ep ep s + \ (\t \ set (ep_queue ep). tcb_at t s) + \ sorted_wrt (img_ord (prios_of s) (opt_ord_rel (\))) (ep_queue ep)" + in corres_cross_add_abs_guard) + apply (intro context_conjI) + apply (fastforce simp: eps_of_kh_def obj_at_def opt_map_red) + apply (fastforce intro: valid_objs_valid_ep simp: obj_at_def) + apply (case_tac ep; clarsimp simp: valid_ep_def) + apply (fastforce intro!: sorted_ipc_queues_endpoint_priority_ordered) + apply (rule_tac Q'="\s'. tcb_ptr \ set (ep_queue ep) + \ (\t \ set (ep_queue ep). tcb_at' t s' \ sched_flag_set s' t) + \ list_queue_relation + (ep_queue ep) (epQueue ep') + (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ (ep_queue ep = [] \ epQueue ep' = emptyQueue) + \ sorted_wrt (img_ord (\t. threadRead tcbPriority t s') + (opt_ord_rel (\))) (ep_queue ep)" + in corres_cross_add_guard) + apply clarsimp + apply (frule (3) in_ep_queue_sched_flag_set[where p=ep_ptr]) + apply fastforce + apply (intro context_conjI) + apply (clarsimp simp: in_ep_queue_at_def ep_queued_def) + apply (fastforce intro!: tcb_at_cross) + apply (fastforce intro!: ep_queues_relationD simp: opt_map_red obj_at'_def) + apply (fastforce dest: list_queue_relation_Nil_iff_emptyHeadEndPtrs) + apply clarsimp + apply (frule (1) sorted_ipc_queues_endpoint_priority_ordered) + apply (erule sorted_wrt_img_ord_eq_lift[THEN iffD1, rotated]) + apply (rename_tac t) + apply (simp flip: thread_read_Some_tcbs_of) + apply (rule_tac f="thread_read tcb_priority t" and g="threadRead tcbPriority t" + in rcorres_rrel_eq) + apply (rule threadGet_rcorres[where rrel="(=)"]) + apply (clarsimp simp: tcb_relation_def) + apply (frule state_relation_pspace_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation) + apply (fastforce intro!: no_ofailD[OF thread_read_no_ofail]) + apply (fastforce intro!: no_ofailD[OF no_ofail_threadRead_tcb_at']) + apply (rule corres_stateAssert_ignore) + apply (fastforce dest!: list_queue_relation_tcb_queue_head_end_valid) + apply (rule corres_underlying_from_rcorres) + apply (clarsimp simp: tcbAppend_def) + apply (rule_tac R="\_. ep_at' epPtr" in no_fail_bind[where P=P and Q=P for P, simplified]) + apply (wpsimp wp: no_fail_stateAssert hoare_vcg_if_lift2 hoare_drop_imps) + apply wpsimp + apply (wpsimp wp: no_fail_orderedInsert no_fail_stateAssert) + apply (fast intro: no_ofailD[OF no_ofail_threadRead]) + apply (clarsimp simp: state_relation_def ghost_relation_heap_ghost_relation + pspace_relation_heap_pspace_relation heap_pspace_relation_def) + apply (rule_tac Q="\s s'. (s, s') \ state_relation" in rcorres_add_to_pre) + apply (clarsimp simp: state_relation_def pspace_relation_heap_pspace_relation + heap_pspace_relation_def ghost_relation_heap_ghost_relation) + apply (rcorres_conj_lift \fastforce\ rule: det_wp_tcb_append_set_endpoint simp: tcbAppend_def)+ + apply (rule rcorres_conj_lift_fwd; (solves ipc_append)?) + \ \eps_relation\ + apply (clarsimp simp: tcbAppend_def bind_assoc) + apply (rule rcorres_stateAssert_r_fwd) + apply (rule_tac Q="\ls q s s'. eps_relation s s' + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ ko_at (kernel_object.Endpoint ep) epPtr s + \ (epState ep' \ IdleEPState \ epState ep' = state)" + in rcorres_split[rotated]) + apply (rcorres rcorres: orderedInsert_rcorres threadGet_rcorres + simp: tcb_append_def tcbAppend_def tcb_relation_def) + apply (clarsimp simp: thread_read_Some_tcbs_of) + apply (force simp: obj_at'_def split: if_splits) + apply (rule rcorres_from_valid_det) + apply wpsimp + apply (clarsimp simp: obj_at_def is_ep_def) + apply (drule in_set_endpoint) + apply (wpsimp wp: updateEndpoint_wp) + apply (clarsimp simp: eps_of_kh_def projectKO_opts_defs map_relation_def ep_relation_def + obj_at_def is_ep_def obj_at'_def valid_ep_def + split: if_splits Structures_A.endpoint.splits) + apply (rcorres_conj_lift \fastforce\ rule: det_wp_tcb_append_set_endpoint simp: tcbAppend_def)+ + apply (rule rcorres_conj_lift_fwd; (solves ipc_append)?) + \ \ep_queues_relation\ + apply (simp only: ep_queues_relation_def) + apply (rule rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac p) + apply (case_tac "p \ epPtr") + apply (rcorres rcorres: tcbAppend_rcorres_other rcorres_allI rcorres_imp_lift + wp: set_endpoint_ep_queues_of_other updateEndpoint_epQueues_of_other) + apply (clarsimp simp: in_ep_queue_at_def ep_queued_def heap_pspace_relation_def) + apply (blast dest: ep_queues_disjoint) + \ \p = epPtr\ + apply (rule_tac Q="\ls q s s'. ep_at epPtr s + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in rcorres_split[rotated]) + apply (rcorres rcorres: tcbAppend_rcorres) + apply (clarsimp simp: heap_pspace_relation_def thread_read_Some_tcbs_of) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: updateEndpoint_wp) + apply (drule in_set_endpoint) + apply (clarsimp simp: obj_at'_def projectKO_opts_defs) + subgoal + by (fastforce simp: projectKO_opts_defs opt_map_def eps_of_kh_def split: kernel_object.splits) + apply (rule rcorres_conj_lift_fwd; (solves ipc_append)?) + \ \ntfn_queues\ + apply (simp only: ntfn_queues_relation_def) + apply (rcorres rcorres: tcbAppend_rcorres_other + rcorres_lift: rcorres_allI rcorres_imp_lift) + apply (clarsimp simp: heap_pspace_relation_def in_ntfn_queue_at_def ntfn_queued_def) + apply (blast dest: ep_queues_ntfn_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves ipc_append)?) + \ \ready_queues_relation\ + apply (simp only: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (intro rcorres_allI_fwd; (solves ipc_append)?) + apply (rename_tac d p) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rcorres rcorres: tcbAppend_rcorres_other + rcorres_lift: rcorres_allI rcorres_imp_lift) + apply (clarsimp simp: heap_pspace_relation_def not_queued_def) + apply (blast dest!: ep_queues_ready_queues_disjoint) + apply wpsimp + apply wpsimp + apply (rule rcorres_conj_lift_fwd; (solves ipc_append)?) + \ \release_queue_relation\ + apply (simp only: release_queue_relation_def) + apply (rule_tac p=release_queue in rcorres_lift_abs) + apply (rule_tac p=ksReleaseQueue in rcorres_lift_conc) + apply (rcorres rcorres: tcbAppend_rcorres_other + rcorres_lift: rcorres_allI rcorres_imp_lift) + apply (clarsimp simp: heap_pspace_relation_def not_in_release_q_def) + apply (blast dest!: ep_queues_release_queue_disjoint) + apply wpsimp + apply wpsimp + by (rcorres_conj_lift \fastforce\ rule: det_wp_tcb_append_set_endpoint simp: tcbAppend_def)+ crunch bindScReply for valid_tcbs'[wp]: valid_tcbs' @@ -2377,64 +2536,47 @@ crunch replyPush and pspace_distinct'[wp]: pspace_distinct' and pspace_bounded'[wp]: pspace_bounded' and pspace_canonical'[wp]: pspace_canonical' - and if_unsafe_then_cap'[wp]: "if_unsafe_then_cap'" - and valid_global_refs'[wp]: "valid_global_refs'" - and valid_arch_state'[wp]: "valid_arch_state'" + and if_unsafe_then_cap'[wp]: if_unsafe_then_cap' + and valid_global_refs'[wp]: valid_global_refs' + and valid_arch_state'[wp]: valid_arch_state' and valid_irq_node'[wp]: "\s. valid_irq_node' (irq_node' s) s" - and valid_irq_handlers'[wp]: "valid_irq_handlers'" - and valid_irq_states'[wp]: "valid_irq_states'" - and valid_machine_state'[wp]: "valid_machine_state'" - and ct_idle_or_in_cur_domain'[wp]: "ct_idle_or_in_cur_domain'" - and pspace_domain_valid[wp]: "pspace_domain_valid" + and valid_irq_handlers'[wp]: valid_irq_handlers' + and valid_irq_states'[wp]: valid_irq_states' + and valid_machine_state'[wp]: valid_machine_state' + and pspace_domain_valid[wp]: pspace_domain_valid and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and valid_dom_schedule'[wp]: "valid_dom_schedule'" - and cur_tcb'[wp]: "cur_tcb'" + and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + and valid_dom_schedule'[wp]: valid_dom_schedule' and no_0_obj'[wp]: no_0_obj' and valid_mdb'[wp]: valid_mdb' and tcb_at'[wp]: "tcb_at' t" and cte_wp_at'[wp]: "cte_wp_at' P p" and ctes_of[wp]: "\s. P (ctes_of s)" and pspace_in_kernel_mapping'[wp]: pspace_in_kernel_mappings' - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - (wp: crunch_wps hoare_vcg_all_lift valid_irq_node_lift simp: crunch_simps valid_mdb'_def) - -crunch setQueue - for valid_tcb_state'[wp]: "valid_tcb_state' ts" - -lemma tcbSchedEnqueue_valid_tcb_state'[wp]: - "tcbSchedEnqueue t \valid_tcb_state' ts\" - by (wpsimp simp: tcbSchedEnqueue_def tcbQueuePrepend_def wp: hoare_vcg_if_lift2 threadGet_wp) + (wp: crunch_wps hoare_vcg_all_lift valid_irq_node_lift valid_dom_schedule'_lift + simp: crunch_simps valid_mdb'_def) lemma replyPush_valid_objs'[wp]: - "\valid_objs' and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - replyPush callerPtr calleePtr replyPtr canDonate - \\_. valid_objs'\" - supply if_split [split del] - unfolding replyPush_def updateReply_def bind_assoc - apply (wpsimp wp: schedContextDonate_valid_objs' updateReply_valid_objs' + "replyPush callerPtr calleePtr replyPtr canDonate \valid_objs'\" + unfolding replyPush_def updateReply_def + apply (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers hoare_vcg_if_lift2 threadGet_wp hoare_vcg_imp_lift') - apply (clarsimp simp: obj_at'_def) - apply (intro conjI impI; (fastforce simp: obj_at'_def valid_tcb_state'_def)?) - by (insert reply_ko_at_valid_objs_valid_reply'; - fastforce simp: valid_reply'_def obj_at'_def valid_bound_obj'_def)+ + apply (force dest: reply_ko_at_valid_objs_valid_reply' + simp: valid_reply'_def) + done lemma replyPush_valid_replies'[wp]: - "\valid_replies' and pspace_distinct' and pspace_aligned' and pspace_bounded' - and st_tcb_at' (Not \ is_replyState) callerPtr\ + "\valid_replies' and pspace_distinct' and pspace_aligned' and pspace_bounded'\ replyPush callerPtr calleePtr replyPtr canDonate \\_. valid_replies'\" - apply (solves wp | simp (no_asm_use) add: replyPush_def split del: if_split cong: conj_cong | - wp hoare_vcg_if_lift hoare_vcg_imp_lift' hoare_vcg_ex_lift - sts'_valid_replies'_except_Blocked updateReply_valid_replies'_except - sts_st_tcb' threadGet_wp)+ - apply (auto simp: pred_tcb_at'_def obj_at'_def) - done + apply (clarsimp simp: replyPush_def) + by (wpsimp wp: hoare_vcg_if_lift hoare_vcg_imp_lift' hoare_vcg_ex_lift + sts'_valid_replies'_except_Blocked updateReply_valid_replies'_except + sts_st_tcb' threadGet_wp gts_wp') crunch reply_unlink_tcb for sc_replies_sc_at[wp]: "\s. Q (sc_replies_sc_at P scp s)" - and ready_qs_distinct[wp]: ready_qs_distinct (wp: crunch_wps simp: crunch_simps ignore: refill_unblock_check) crunch if_cond_refill_unblock_check @@ -2444,7 +2586,13 @@ crunch if_cond_refill_unblock_check crunch do_ipc_transfer for in_correct_ready_q[wp]: in_correct_ready_q and ready_qs_distinct[wp]: ready_qs_distinct - (rule: in_correct_ready_q_lift ready_qs_distinct_lift) + and ready_queues_runnable [wp]: ready_queues_runnable + and ep_queued[wp]: "\s. P (ep_queued t s)" + and ntfn_queued[wp]: "\s. P (ntfn_queued t s)" + and ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (rule: in_correct_ready_q_lift ready_qs_distinct_lift ready_queues_runnable_lift ep_queued_lift + ntfn_queued_lift ep_queues_blocked_lift ntfn_queues_blocked_lift) crunch doIPCTransfer for reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" @@ -2461,732 +2609,839 @@ crunch set_simple_ko for ready_qs_distinct[wp]: ready_qs_distinct (rule: ready_qs_distinct_lift) -lemma sendIPC_corres: -(* call is only true if called in handleSyscall SysCall, which is always blocking. *) - assumes "call \ bl" - shows - "corres dc (all_invs_but_fault_tcbs and fault_tcbs_valid_states_except_set {t} and valid_list - 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' - (send_ipc bl call bg cg cgr cd t ep) (sendIPC bl call bg cg cgr cd t ep)" - apply (insert assms) - apply add_sym_refs - apply add_valid_idle' - apply (clarsimp simp: send_ipc_def sendIPC_def Let_def split del: if_split) - apply (rule corres_stateAssert_add_assertion[rotated], solves clarsimp)+ - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (fastforce intro!: st_tcb_at_runnable_cross - simp flip: runnable_eq_active' simp: runnable_eq_active) +crunch set_thread_state + for ntfn_queued[wp]: "\s. P (ntfn_queued t s)" + (wp: ntfn_queued_lift) + +lemma send_ipc_blocked_corres: + "corres dc + (all_invs_but_fault_tcbs + and st_tcb_at runnable t and ep_at ep_ptr and not_queued t and not_in_release_q t + and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable and release_q_runnable + and ready_or_release and sorted_ipc_queues) + (invs' and obj_at' (\ep. epState ep \ IdleEPState \ epState ep = SendEPState) ep_ptr) + (send_ipc_blocked t ep_ptr bg cg cgr call) + (do setThreadState (BlockedOnSend ep_ptr bg cg cgr call) t; + tcbEPAppend t ep_ptr SendEPState + od)" + apply (rule_tac Q'="st_tcb_at' runnable' t" in corres_cross_add_guard) + apply (fastforce intro!: st_tcb_at_runnable_cross) + apply (rule_tac Q'="\s'. \ (tcbQueued |< tcbs_of' s') t" in corres_cross_add_guard) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=t]) + apply (clarsimp simp: not_queued_def in_ready_q_def) + apply (rule_tac Q'="\s'. \ (tcbInReleaseQueue |< tcbs_of' s') t" in corres_cross_add_guard) + apply (frule state_relation_release_queue_relation) + apply (frule in_release_q_tcbInReleaseQueue_eq[where t=t]) + apply (clarsimp simp: in_release_q_def) + apply (clarsimp simp: send_ipc_blocked_def) apply (rule stronger_corres_guard_imp) - 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 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 - and (\s. cd \ bound_sc_tcb_at (\a. \y. a = Some y) t s)" - and - R'="\rv'. invs' and tcb_at' t and sch_act_not t - and ep_at' ep and valid_ep' rv' - and ko_at' (rv' :: endpoint) ep - and (\s'. sym_refs (state_refs_of' s'))"]) - apply (rename_tac ep' rv) - apply (case_tac ep') - apply (case_tac bl; simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split [OF setThreadState_corres setEndpoint_corres]) - apply simp - apply (simp add: ep_relation_def) - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def - invs_def valid_state_def valid_pspace_def) - apply (clarsimp simp: invs'_def valid_pspace'_def) - \ \concludes IdleEP\ - apply (simp add: ep_relation_def) - apply (case_tac bl; simp add: ep_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split [OF setThreadState_corres], simp) - apply (rule corres_split [OF tcbEPAppend_corres]) - apply (rule setEndpoint_corres) - apply (simp add: ep_relation_def) - apply (wpsimp wp: hoare_vcg_ball_lift)+ - 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) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req, simp add: valid_ep_def) - apply (case_tac list, simp) - apply (clarsimp split del: if_split) - \ \start corres logic\ - apply (rename_tac t' tl) - apply (rule corres_guard_imp) - apply (rule corres_split [OF setEndpoint_corres]) - apply (clarsimp simp: ep_relation_def split: list.splits) - apply (simp add: isReceive_def split del:if_split) - apply (rule corres_split [OF getThreadState_corres]) - apply (rule stronger_corres_guard_imp) - apply (rule_tac - F="\reply_opt pl. recv_state = Structures_A.BlockedOnReceive ep reply_opt pl" - in corres_gen_asm) - apply (clarsimp simp: case_bool_If case_option_If if3_fold - simp del: dc_simp split del: if_split cong: if_cong) - apply (rule corres_split [OF doIPCTransfer_corres]) - apply (rule corres_split[where r'=dc]) - apply (clarsimp simp: maybeM_def) - apply (rule corres_option_split[OF refl corres_return_trivial]) - apply (rule replyUnlinkTcb_corres) - apply (simp only: get_tcb_obj_ref_def) - apply (rule corres_split [OF threadGet_corres[where r="(=)"]]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split [OF threadGet_corres[where r=fault_rel_optionation]]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split [OF corres_if[where r=dc], where r=dc]) - apply (clarsimp simp: fault_rel_optionation_def) - apply (rule corres_if, clarsimp) - apply (rule replyPush_corres, simp) - apply (rule setThreadState_corres, simp) - apply (rule corres_when, simp) - apply (rule corres_split [OF threadGet_corres[where r="(=)"]]) - apply (clarsimp simp: tcb_relation_def) - apply (simp, rule schedContextDonate_corres) - prefer 3 \ \deferring Hoare triples\ - apply (rule corres_split [OF setThreadState_corres]) - apply simp - apply (rule corres_split_eqr[OF threadGet_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split [OF ifCondRefillUnblockCheck_corres]) - apply (rule possibleSwitchTo_corres, simp) - \ \starting Hoare triples\ - apply wpsimp - apply wpsimp - apply (rule_tac Q'="\r. valid_sched_action and active_scs_valid - and bound_sc_tcb_at ((=) r) t' - and pspace_aligned - and pspace_distinct - and valid_objs - and active_scs_valid - and ready_or_release - and in_correct_ready_q and ready_qs_distinct - and st_tcb_at runnable t' - and not_in_release_q t' - and current_time_bounded" - in hoare_strengthen_post[rotated]) - apply (clarsimp, rename_tac rv s) - apply (case_tac rv; clarsimp simp: pred_tcb_at_def obj_at_def is_tcb option.case_eq_if) - apply (drule sym[of "Some _"]) - apply (frule valid_objs_ko_at) - apply (fastforce simp: obj_at_def) - apply (fastforce simp: valid_obj_def valid_tcb_def obj_at_def - is_sc_obj opt_map_red opt_pred_def) - apply (wpsimp wp: thread_get_wp') - apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\_. valid_sched_action and active_scs_valid - and tcb_at t' - and pspace_aligned - and pspace_distinct - and valid_objs - and active_scs_valid - and ready_or_release - and in_correct_ready_q and ready_qs_distinct - and st_tcb_at runnable t' - and not_in_release_q t' - and current_time_bounded" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_tcb_at_def obj_at_def) - apply (wpsimp wp: set_thread_state_valid_sched_action) - apply (rule_tac Q'="\_. tcb_at' t' and valid_objs' - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' - and pspace_bounded'" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: obj_at'_def valid_objs'_valid_tcbs' split: option.split) - apply wpsimp - apply (wpsimp wp: thread_get_wp') - apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct - and tcb_at t' and active_scs_valid - and valid_sched_action and ready_or_release - and in_correct_ready_q and ready_qs_distinct - and not_in_release_q t' and current_time_bounded" - in hoare_strengthen_post[rotated]) - apply clarsimp - apply (wpsimp wp: set_thread_state_valid_sched_action sched_context_donate_valid_sched_action - thread_get_wp' reply_push_valid_objs) - apply (rule_tac Q'="\_. valid_objs' and tcb_at' t' and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct' and pspace_bounded'" - in hoare_strengthen_post[rotated]) - apply clarsimp - apply (wpsimp wp: threadGet_wp schedContextDonate_valid_objs') - apply (wpsimp wp: thread_get_wp') - apply (wpsimp wp: threadGet_wp) - apply (wpsimp wp: thread_get_wp') - apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct and - scheduler_act_not t and valid_sched_action and valid_replies and - st_tcb_at active t and tcb_at t' and scheduler_act_not t' and - active_scs_valid and valid_release_q and - in_correct_ready_q and ready_qs_distinct and ready_or_release and - not_in_release_q t' and - (\s. reply_opt \ None \ reply_at (the reply_opt) s \ - ex_nonz_cap_to (the reply_opt) s \ - reply_tcb_reply_at (\tptr. tptr = None) (the reply_opt) s \ - reply_sc_reply_at (\tptr. tptr = None) (the reply_opt) s \ - the reply_opt \ fst ` replies_with_sc s \ - sym_refs (state_refs_of s)) and - K (t \ idle_thread_ptr) and current_time_bounded and - (\s. cd \ bound_sc_tcb_at (\a. \y. a = Some y) t s) and valid_idle" - in hoare_strengthen_post[rotated]) - apply (prop_tac "reply_opt \ None - \ sym_refs - (\p. if p = t - then tcb_non_st_state_refs_of s t - else state_refs_of s p)") - subgoal - apply clarsimp - apply (erule delta_sym_refs) - by (auto simp: state_refs_of_def get_refs_def2 - pred_tcb_at_def obj_at_def - split: if_split_asm option.splits) - apply (prop_tac "st_tcb_at (\st. reply_object st = None) t s") - apply (fastforce elim!: pred_tcb_weakenE) - apply (clarsimp simp: st_tcb_at_tcb_at cong: conj_cong) - apply (frule valid_sched_action_weak_valid_sched_action, simp) - apply (frule valid_objs_valid_tcbs, simp) - apply (subgoal_tac "(cd \ bound_sc_tcb_at (\a. sc_at (the a) s) t s)") - apply (clarsimp simp: obj_at_def is_tcb pred_tcb_at_def) - apply (frule valid_release_q_distinct) - apply clarsimp - apply (drule pred_tcb_at_ko_atD, clarsimp) - apply (frule (1) valid_objs_ko_at) - apply (clarsimp simp: pred_tcb_at_def obj_at_def valid_obj_def valid_tcb_def) - apply (wpsimp wp: reply_unlink_tcb_valid_sched_action - reply_unlink_tcb_valid_replies_BlockedOnReceive - reply_unlink_tcb_sym_refs_BlockedOnReceive - reply_unlink_tcb_reply_tcb_reply_at[where P=id, simplified] - reply_unlink_tcb_st_tcb_at' - replies_with_sc_lift) - apply (rule_tac Q'="\_. tcb_at' t and tcb_at' t' and valid_objs' and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct' and pspace_bounded' and - (\s. reply_opt \ None \ - reply_at' (the reply_opt) s \ - replySCs_of s (the reply_opt) = None)" - in hoare_strengthen_post[rotated]) - apply (clarsimp cong: conj_cong) - apply (frule valid_objs'_valid_tcbs') - apply (drule obj_at_ko_at')+ - apply (blast dest: no_replySC_valid_replies'_sc_asrt) - apply wpsimp - apply (wpfix add: reply_object.simps(1)) - apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct and - valid_replies and active_scs_valid and valid_release_q and - scheduler_act_not t and valid_sched_action - and in_correct_ready_q and ready_qs_distinct and ready_or_release - and not_in_release_q t' and st_tcb_at active t and tcb_at t' and - if_live_then_nonz_cap and scheduler_act_not t' and - K (t \ idle_thread_ptr) and current_time_bounded and - (\s. cd \ bound_sc_tcb_at (\a. \y. a = Some y) t s) and - (\s. reply_opt \ None - \ st_tcb_at ((=) (Structures_A.thread_state.BlockedOnReceive ep reply_opt pl)) t' s - \ ex_nonz_cap_to (the reply_opt) s - \ reply_tcb_reply_at ((=) (Some t')) (the reply_opt) s - \ reply_sc_reply_at (\a. a = None) (the reply_opt) s - \ the reply_opt \ fst ` replies_with_sc s) and - (\s. sym_refs - (\x. if x = t' - then {r \ state_refs_of s x. - snd r = TCBBound \ snd r = TCBSchedContext \ - snd r = TCBYieldTo \ snd r = TCBReply} - else state_refs_of s x)) and valid_idle" - in hoare_strengthen_post[rotated]) - apply (clarsimp split: option.splits cong: conj_cong) - apply (intro conjI) - apply (erule valid_objs_valid_tcbs) - apply (clarsimp simp: pred_tcb_at_def obj_at_def is_tcb, fastforce) - apply fastforce - apply (fastforce simp: reply_tcb_reply_at_def obj_at_def st_tcb_at_def) - apply (clarsimp simp: sk_obj_at_pred_def obj_at_def is_reply) - apply (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift simp: iff_conv_conj_imp) - apply (wpfix add: Structures_H.thread_state.sel) - apply (rule_tac Q'="\_. tcb_at' t and tcb_at' t' and valid_objs' and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct' and pspace_bounded' and - (\s. reply_opt \ None \ reply_at' (the reply_opt) s \ - replySCs_of s (the reply_opt) = None)" - in hoare_strengthen_post[rotated]) - apply (fastforce split: option.splits) - apply (wpsimp wp: hoare_vcg_imp_lift) - apply assumption - apply (prop_tac "(tcb_at' t and tcb_at' t' and valid_pspace' and - ep_at' ep and sym_heap_sched_pointers and - valid_sched_pointers and valid_objs' and - valid_mdb' and - pspace_aligned' and pspace_distinct' and pspace_bounded') s'", - assumption) - apply clarsimp - apply (case_tac reply_opt; clarsimp) - apply (subgoal_tac "reply_at' a s'", simp) - apply (frule (1) replySCs_of_cross, simp) - apply (erule cross_relF[OF _ reply_at'_cross_rel]) - apply (clarsimp simp: obj_at_def reply_sc_reply_at_def is_reply) - apply (wpsimp wp: gts_wp) - apply (wpsimp wp: gts_wp') - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) - \ \end of main Hoare triples\ - apply (subgoal_tac "tcb_at t' s") - apply (subgoal_tac "t' \ ep") - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def - valid_sched_action_def pred_tcb_at_eq_commute) - apply (prop_tac "(t', EPRecv) \ state_refs_of s ep") - apply (clarsimp simp: state_refs_of_def obj_at_def) - apply (frule (1) sym_refsD, simp) - apply (frule TCBBlockedRecv_in_state_refs_of) - apply (clarsimp simp: invs_def pred_tcb_at_eq_commute st_tcb_at_tcb_at cong: conj_cong) - apply (intro conjI impI) - apply (clarsimp simp: valid_ep_def split: list.splits) - apply (fastforce elim!: valid_release_q_not_in_release_q_not_runnable - simp: st_tcb_at_def obj_at_def runnable_eq_active) - apply (erule (1) if_live_then_nonz_capD) - apply (clarsimp simp: obj_at_def live_def) - apply (erule weak_valid_sched_action_scheduler_action_not) - apply (clarsimp simp: obj_at_def pred_tcb_at_def) - apply (clarsimp, erule (1) FalseI[OF idle_no_ex_cap], clarsimp simp: valid_idle_def) - apply (case_tac "reply_object x"; simp) - apply (subgoal_tac "data = Some a", simp) - apply (subgoal_tac "reply_tcb_reply_at ((=) (Some t')) a s", simp) - apply (subgoal_tac "reply_sc_reply_at (\a. a = None) a s", simp) - apply (intro conjI) - apply (clarsimp simp: sk_obj_at_pred_def obj_at_def) - apply (erule (1) if_live_then_nonz_capD2) - apply (clarsimp simp: live_def live_reply_def) - apply clarsimp - apply (frule (1) valid_repliesD1_simp, clarsimp simp: replies_blocked_def) - apply (subst (asm) identity_eq[where x="Structures_A.thread_state.BlockedOnReply aa" for aa, symmetric])+ - apply (frule (1) st_tcb_reply_state_refs) - apply (clarsimp simp: pred_tcb_at_def obj_at_def reply_tcb_reply_at_def) - apply (subst identity_eq) - apply (erule (1) valid_replies_ReceiveD[rotated]) - apply (subst identity_eq, assumption, simp) - apply (subst identity_eq) - apply (erule st_tcb_recv_reply_state_refs[rotated]) - apply (subst identity_eq, assumption) - apply (clarsimp simp: obj_at_def pred_tcb_at_def) - subgoal for t' _ s - apply (rule delta_sym_refs, assumption) - apply (fastforce simp: obj_at_def state_refs_of_def split: list.splits if_splits) - apply clarsimp - apply (intro conjI) - apply (fastforce simp: valid_obj_def valid_ep_def is_tcb obj_at_def - split: list.splits if_splits) - apply (clarsimp, intro conjI) - apply (clarsimp simp: obj_at_def split: if_splits) - apply (erule (1) pspace_valid_objsE) - apply (fastforce simp: state_refs_of_def) - apply (clarsimp simp: obj_at_def split: if_splits) - apply (subgoal_tac "st_tcb_at (\st. \r pl. st = Structures_A.BlockedOnReceive ep r pl) t' s") - apply (clarsimp simp: st_tcb_at_def obj_at_def state_refs_of_def get_refs_def2 - split: if_splits) - apply (erule (1) valid_objsE) - apply (clarsimp simp: valid_obj_def valid_ep_def st_tcb_at_def obj_at_def) - apply (clarsimp simp: sym_refs_ko_atD obj_at_def split: list.splits) - done - apply (clarsimp simp: obj_at_def pred_tcb_at_def) - apply (clarsimp simp: obj_at_def is_tcb) - apply (clarsimp simp: valid_ep_def) - apply (subgoal_tac "tcb_at' t' s") - apply (clarsimp simp: invs'_def valid_pspace'_def) - apply (clarsimp simp: valid_ep'_def split: list.splits) - apply (clarsimp simp: valid_ep'_def) - \ \concludes RecvEP\ - apply wpsimp - apply (wpsimp wp: get_ep_ko') - apply (clarsimp simp: obj_at_def is_ep) - apply simp - apply (frule cross_relF[OF _ tcb_at'_cross_rel[where t=t]]; clarsimp) - apply (frule cross_relF[OF _ ep_at'_cross_rel[where t=ep]]; clarsimp) - apply (frule cross_relF[OF _ sch_act_not_cross_rel[where t=t]]; clarsimp) + apply (rule corres_split[OF setThreadState_corres]) + apply (clarsimp simp: thread_state_relation_def) + apply (rule tcbEPAppend_corres, simp, simp, simp) + apply (wpsimp wp: set_thread_state_ep_queues_blocked_not_queued + set_thread_state_ntfn_queues_blocked_not_queued + set_thread_state_ready_queues_runnable_not_queued + set_thread_state_release_q_runnable_not_in_release_q) + apply (wpsimp wp: setThreadState_not_queued_valid_sched_pointers) + apply (clarsimp simp: valid_tcb_state_def) + apply (frule st_tcb_at_tcb_at[where t=t]) + apply (clarsimp cong: conj_cong) + apply (intro conjI impI allI; clarsimp?) + apply (fastforce dest!: runnable_not_ep_queued) + apply (fastforce dest!: runnable_not_ntfn_queued) + apply clarsimp + apply (frule runnable'_not_inIPCQueueThreadState) + apply (frule invs_valid_sched_pointers) + apply (fastforce dest!: valid_sched_pointersD) done -end - -crunch maybeReturnSc - for typ_at'[wp]: "\s. P (typ_at' T p' s)" - and sc_at'_n[wp]: "\s. Q (sc_at'_n n p s)" - (wp: crunch_wps) - -global_interpretation maybeReturnSc: typ_at_all_props' "maybeReturnSc ntfnPtr tcbPtr" - by typ_at_props' +crunch if_cond_refill_unblock_check + for ready_queues_runnable[wp]: ready_queues_runnable -global_interpretation setMessageInfo: typ_at_all_props' "setMessageInfo t info" - by typ_at_props' +lemma set_thread_state_ready_queues_runnable_runnable: + "\ready_queues_runnable and K (runnable st)\ set_thread_state t st \\_. ready_queues_runnable\" + apply (rule hoare_gen_asm) + unfolding ready_queues_runnable_def + apply (wpsimp wp: sts_st_tcb_at_cases hoare_vcg_all_lift hoare_vcg_ball_lift2) + done -context begin interpretation Arch . (*FIXME: arch-split*) +lemma sched_context_donate_ready_queues_runnable[wp]: + "sched_context_donate y callee \ready_queues_runnable\" + unfolding sched_context_donate_def test_reschedule_def set_tcb_obj_ref_thread_set + by (wpsimp wp: thread_set_ready_queues_runnable) -crunch cancel_ipc - for cur[wp]: "cur_tcb" - and ntfn_at[wp]: "ntfn_at t" - (wp: crunch_wps simp: crunch_simps ignore: set_object) +lemma reply_push_ready_queues_runnable[wp]: + "\ready_queues_runnable and not_queued caller\ + reply_push caller callee reply_ptr can_donate + \\_. ready_queues_runnable\" + unfolding reply_push_def + by (wpsimp wp: set_thread_state_ready_queues_runnable_not_queued) -lemma valid_sched_weak_strg: - "valid_sched s \ weak_valid_sched_action s" - by (simp add: valid_sched_def valid_sched_action_def) +lemma reply_push_ep_queues_blocked_not_queued: + "\ep_queues_blocked and not ep_queued caller\ + reply_push caller callee reply_ptr can_donate + \\_. ep_queues_blocked\" + unfolding reply_push_def + by (wpsimp wp: set_thread_state_ep_queues_blocked_not_queued) -lemma idle_tsr: - "thread_state_relation ts ts' \ idle' ts' = idle ts" - by (case_tac ts, auto) +lemma reply_push_ntfn_queues_blocked_not_queued: + "\ntfn_queues_blocked and not ntfn_queued caller\ + reply_push caller callee reply_ptr can_donate + \\_. ntfn_queues_blocked\" + unfolding reply_push_def + by (wpsimp wp: set_thread_state_ntfn_queues_blocked_not_queued) -crunch cancelIPC - for cur[wp]: cur_tcb' - (wp: crunch_wps gts_wp' simp: crunch_simps) +crunch reply_push, sched_context_donate + for ep_queued[wp]: "\s. P (ep_queued ep_ptr s)" + and ntfn_queued[wp]: "\s. P (ntfn_queued ep_ptr s)" + (wp: ep_queued_lift ntfn_queued_lift) -lemma setCTE_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - setCTE c cte - \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: weak_sch_act_wf_def) - apply (wp hoare_vcg_all_lift hoare_convert_imp setCTE_pred_tcb_at' setCTE_tcb_in_cur_domain') - done - -\ \ tcbReleaseEnqueue_corres \ - -\ \Work on a monadic_rewrite rule for tcb_release_enqueue\ - -definition read_ready_time :: "obj_ref \ (time, 'z::state_ext) r_monad" where - "read_ready_time sc_ptr \ do { - head \ read_refill_head sc_ptr; - oreturn (r_time head) - }" - -definition read_tcb_ready_time :: "obj_ref \ (time, 'z::state_ext) r_monad" where - "read_tcb_ready_time tcb_ptr \ do { - sc_ptr_opt \ thread_read tcb_sched_context tcb_ptr; - oassert (sc_ptr_opt \ None); - read_ready_time (the sc_ptr_opt) - }" - -definition get_tcb_ready_time :: "obj_ref \ (time, 'z::state_ext) s_monad" where - "get_tcb_ready_time tcb_ptr = gets_the (read_tcb_ready_time tcb_ptr)" - -definition sorted_release_q' :: "'z::state_ext state \ bool" where - "sorted_release_q' s \ - (\tcb_ptr \ set (release_queue s). read_tcb_ready_time tcb_ptr s \ None) - \ sorted (map (\ptr. the (read_tcb_ready_time ptr s)) (release_queue s))" - -lemma read_tcb_ready_time_tcb_ready_times_of: - "read_tcb_ready_time tcb_ptr s \ None - \ (tcb_ready_times_of s) tcb_ptr = read_tcb_ready_time tcb_ptr s" - by (auto simp: read_tcb_ready_time_def obind_def in_omonad thread_read_def get_tcb_def oliftM_def - read_ready_time_def read_sched_context_def tcb_ready_times_defs - map_project_def map_join_def map_option_Some_eq2 vs_heap_simps read_refill_head_def - split: option.splits Structures_A.kernel_object.splits) - -lemma read_ready_time_no_ofail: - "no_ofail (valid_objs and is_active_sc sc_ptr and active_scs_valid) - (read_ready_time sc_ptr)" - unfolding read_ready_time_def - apply (wpsimp wp: read_sched_context_wp) - apply (fastforce dest: active_scs_validE valid_refills_nonempty_refills - simp: sc_at_pred_n_def obj_at_def) - done - -lemma read_tcb_ready_time_no_ofail: - "no_ofail (valid_objs and active_sc_tcb_at tcb_ptr and active_scs_valid) - (read_tcb_ready_time tcb_ptr)" - supply no_ofail_pre_imp[rotated, wp_pre] - unfolding read_tcb_ready_time_def - apply (wpsimp wp: read_ready_time_no_ofail oassert_wp thread_read_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps is_tcb_def) - done - -lemmas get_tcb_ready_time_no_fail[wp] = - no_ofail_gets_the[OF read_tcb_ready_time_no_ofail, simplified get_tcb_ready_time_def[symmetric]] - -lemma sorted_release_q'_imp: - "\valid_release_q s; active_scs_valid s; valid_objs s\ \ sorted_release_q' s" - supply not_None_eq[simp del] - apply (clarsimp simp: sorted_release_q'_def) - apply (rule context_conjI) - apply (clarsimp simp: valid_release_q_def sorted_release_q_def) - apply (drule_tac x=tcb_ptr in bspec, blast) - apply (rule_tac m="read_tcb_ready_time tcb_ptr" in no_ofailD) - apply (rule read_tcb_ready_time_no_ofail) - apply fastforce - apply (clarsimp simp: valid_release_q_def sorted_release_q_def) - apply (rule sorted_map[THEN iffD2]) - apply (simp add: img_ord_def) - apply (rule_tac P="\x y. opt_ord (tcb_ready_times_of s x) (tcb_ready_times_of s y)" - in sorted_wrt_mono_rel) - apply (frule_tac x=x in bspec, fastforce) - apply (fastforce dest!: bspec simp: read_tcb_ready_time_tcb_ready_times_of) - apply fastforce +lemma setThreadState_not_queued_valid_sched_pointers': + "\valid_sched_pointers and st_tcb_at' (not inIPCQueueThreadState) t\ + setThreadState st t + \\_. valid_sched_pointers\" + apply (rule hoare_weaken_pre[OF setThreadState_valid_sched_pointers]) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_def split: option.splits) done -definition time_after :: "obj_ref list \ ticks \ (bool, 'z::state_ext) r_monad" where - "time_after ls new_time \ do { - if ls \ [] - then do { time \ read_tcb_ready_time (hd ls); - oreturn (time \ new_time) } - else oreturn False - }" - -definition find_time_after :: "obj_ref list \ ticks \ (obj_ref list, 'z::state_ext) s_monad" - where - "find_time_after ls new_time \ - whileLoop (\ls s. the (time_after ls new_time s)) - (\ls. do assert (ls \ []); return (tl ls) od) - ls" - -definition tcb_release_enqueue' :: "obj_ref \ (unit, 'z::state_ext) s_monad" where - "tcb_release_enqueue' tcb_ptr \ do - new_time \ get_tcb_ready_time tcb_ptr; - rlq \ gets release_queue; - ifM (orM (return (rlq = [])) - (do head_time \ get_tcb_ready_time (hd rlq); - return (new_time < head_time) - od)) - (do set_release_queue (tcb_ptr # rlq); - modify (\s. s\reprogram_timer := True\) - od) - (do last_time \ get_tcb_ready_time (last rlq); - if last_time \ new_time - then set_release_queue (rlq @ [tcb_ptr]) - else do sfx \ find_time_after rlq new_time; - set_release_queue (list_insert_before rlq (hd sfx) tcb_ptr) - od - od) - od" - -lemma get_tcb_ready_time_wp: - "\\s. \rt. read_tcb_ready_time t s = Some rt \ P rt s\ get_tcb_ready_time t \P\" - by (wpsimp simp: get_tcb_ready_time_def) - -lemma mapM_get_tcb_ready_time_wp: - "\\s. \rt. map (\t. read_tcb_ready_time t s) ts = map Some rt \ P rt s\ - mapM get_tcb_ready_time ts - \P\" - by (wpsimp wp: mapM_wp_lift get_tcb_ready_time_wp simp: list_all2_eq_iff_map_eq_map) - -lemma get_tcb_ready_time_sp: - "\P\ get_tcb_ready_time t \\rv s. P s \ read_tcb_ready_time t s = Some rv\" - by (wpsimp wp: get_tcb_ready_time_wp) - -lemma get_tcb_ready_time_sp': - "\P\ get_tcb_ready_time t \\rv s. P s \ rv = the (read_tcb_ready_time t s)\" - by (wpsimp wp: get_tcb_ready_time_wp) - -lemma mapM_get_tcb_ready_time_sp: - "\P\ mapM get_tcb_ready_time ts \\rv s. P s \ map (\t. read_tcb_ready_time t s) ts = map Some rv\" - by (wpsimp wp: mapM_get_tcb_ready_time_wp) - -lemma mapM_get_tcb_ready_time_sp': - "\P\ mapM get_tcb_ready_time ts \\rv s. P s \ rv = map (\t. the (read_tcb_ready_time t s)) ts\" - by (wpsimp wp: mapM_get_tcb_ready_time_wp) (auto dest!: map_Some_implies_map_the) - -lemma list_length_wf_helper: - "wf {((r :: 'b list, s :: 'a), (r', s')). length r < length r'}" - apply (insert wf_inv_image[where r="{(m, n). m < n}" and f="\(r :: 'b list, s :: 'a). length r"]) - apply (fastforce intro: wf simp: inv_image_def wf_def) - done - -lemma insort_partition_read_tcb_ready_time: - "sorted_release_q' s \ - insort_filter (\x. the (read_tcb_ready_time x s) \ the (read_tcb_ready_time y s)) - new (release_queue s) - = insort_partition (\x. the (read_tcb_ready_time x s) \ the (read_tcb_ready_time y s)) - new (release_queue s)" - apply (clarsimp simp: sorted_release_q'_def) - apply (rule_tac cmp="\t t'. the (read_tcb_ready_time t s) \ the (read_tcb_ready_time t' s)" - in sorted_insort_filter_eq_insort_partition) - apply (fastforce simp: transp_def) - apply (fastforce simp: sorted_map) - done - -(* FIXME RT: use new oblivious framework for this lemma *) -lemma monadic_rewrite_reprogram_timer_set_release_queue: - "monadic_rewrite F E \ - (do modify (reprogram_timer_update (\_. True)); - set_release_queue q - od) - (do set_release_queue q; - modify (reprogram_timer_update (\_. True)) - od)" - by (clarsimp simp: monadic_rewrite_def bind_def modify_def get_def put_def) - -(* FIXME RT: use new oblivious framework for this? *) -lemma read_tcb_ready_time_reprogram_timer_update[simp]: - "read_tcb_ready_time t (reprogram_timer_update f s) = read_tcb_ready_time t s" - by (clarsimp simp: read_tcb_ready_time_def obind_def thread_read_def read_ready_time_def - read_sched_context_def oliftM_def get_tcb_def read_refill_head_def - split: option.splits Structures_A.kernel_object.splits) - -lemma release_queue_reprogram_timer_update[simp]: - "release_queue (reprogram_timer_update f s) = release_queue s" - by clarsimp - -lemma sorted_release_q'_reprogram_timer_update[simp]: - "sorted_release_q' (reprogram_timer_update f s) = sorted_release_q' s" - by (clarsimp simp: sorted_release_q'_def) - -lemma get_sc_time_no_fail[wp]: - "no_fail (active_sc_tcb_at tcb_ptr) (get_sc_time tcb_ptr)" - apply (clarsimp simp: get_sc_time_def get_tcb_sc_def get_tcb_obj_ref_def) - apply (wpsimp wp: thread_get_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps is_tcb_def) - done - -crunch get_tcb_ready_time - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma find_time_after_sfx_nonempty: - "\\s. \last_time. read_tcb_ready_time (last queue) s = Some last_time - \ queue \ [] \ \ last_time \ new_time\ - find_time_after queue new_time - \\rv _. rv \ []\" - (is "\?pre\ _ \_\") - apply (clarsimp simp: find_time_after_def) - apply (rule_tac P="\rv . ?pre" - and I="\rv s. suffix rv queue \ rv \ [] \ ?pre s" - in valid_whileLoop) - apply fastforce - apply (intro hoare_vcg_conj_lift_pre_fix; (solves \wpsimp wp: whileLoop_valid_inv\)?) - apply wpsimp - apply (fastforce simp: suffix_tl) - apply wpsimp - apply (fastforce simp: suffix_def tl_Nil time_after_def obind_def) - apply fastforce - done +lemma replyPush_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s \ valid_sched_pointers s\ + replyPush callerPtr calleePtr replyPtr canDonate + \\_. sym_heap_sched_pointers\" + apply (clarsimp simp: replyPush_def) + apply (intro bind_wp[OF _ stateAssert_sp]) + by (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers hoare_vcg_if_lift2 + hoare_drop_imp) -lemma find_time_after_sfx_proper: - "\\s. release_queue s = queue \ queue \ [] - \ (\head_time. read_tcb_ready_time (hd queue) s = Some head_time \ \ new_time < head_time)\ - find_time_after queue new_time - \\rv s. rv \ release_queue s\" - (is "\?pre\ _ \_\") - apply (clarsimp simp: find_time_after_def) - apply (rule_tac P="\rv. ?pre" and I="\rv. ?pre" in valid_whileLoop) - apply fastforce - apply wpsimp - apply wpsimp - apply (fastforce simp: time_after_def obind_def) - done +lemma replyPush_valid_sched_pointers: + "replyPush callerPtr calleePtr replyPtr canDonate \valid_sched_pointers\" + unfolding replyPush_def + by (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers) -lemma find_time_after_sfx_sfx: - "\\s. queue = release_queue s\ find_time_after queue time \\rv s. suffix rv (release_queue s)\" - apply (clarsimp simp: find_time_after_def) - apply (wpsimp wp: whileLoop_valid_inv) - apply (fastforce simp: suffix_tl) - apply fastforce - done +crunch bindScReply + for st_tcb_at[wp]: "\s. Q (st_tcb_at' P t s)" + and bound_sc_tcb_at'[wp]: "\s. Q (bound_sc_tcb_at' P t s)" + and tcbs_of'[wp]: "\s. P (tcbs_of' s)" + and sch_act_not[wp]: "sch_act_not t" + (simp: crunch_simps) -lemma find_time_after_pfx: - "\\s. sorted_release_q' s \ release_queue s = rlq \ rlq \ [] - \ read_tcb_ready_time tcb_ptr s = Some new_time - \ (\last_time. read_tcb_ready_time (last rlq) s = Some last_time \ \ last_time \ new_time)\ - find_time_after rlq new_time - \\rv s. \pfx v. pfx @ rv = release_queue s \ v \ set pfx - \ the (read_tcb_ready_time v s) \ the (read_tcb_ready_time tcb_ptr s)\" - (is "\?pre\ _ \\rv s. ?post rv s\") - apply (clarsimp simp: find_time_after_def) - apply (rule hoare_pre) - apply (rule_tac P="\rv s. ?pre s \ ?post rv s" - and I="\rv s. ?pre s \ suffix rv (release_queue s) \ rv \ [] \ ?post rv s" - in valid_whileLoop; - fastforce?) - apply (rename_tac rv) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves \wpsimp wp: whileLoop_valid_inv\)?) - apply wpsimp - apply (fastforce simp: suffix_tl) - apply wpsimp - apply (fastforce simp: suffix_def tl_Nil time_after_def obind_def) - apply wpsimp - apply (rename_tac pfx v last_time) - apply (drule_tac x=pfx in spec) - apply (drule_tac x=v in spec) - apply (clarsimp simp: suffix_def) - apply (rule_tac y="the (read_tcb_ready_time (hd rv) s)" in order_trans[rotated]) - apply (clarsimp simp: time_after_def obind_def sorted_release_q'_def - split: option.splits) - apply (metis Un_iff list.set_sel(1) option.simps(3)) - apply (prop_tac "release_queue s = zs @ [hd rv] @ tl rv") - apply fastforce - apply (prop_tac "pfx = zs @ [hd rv]") - apply (metis append.assoc append_same_eq) - apply (fastforce simp: sorted_release_q'_def sorted_wrt_append) +lemma replyPush_st_tcb_at'_other: + "\st_tcb_at' P t and K (callerPtr \ t)\ + replyPush callerPtr calleePtr replyPtr canDonate + \\_ s. st_tcb_at' P t s\" + unfolding replyPush_def + by (wpsimp wp: sts_st_tcb_at'_cases) + +lemma valid_objs_valid_tcb: + "\kheap s t = Some (kernel_object.TCB tcb); valid_objs s\ \ valid_tcb t tcb s" + by (fastforce simp: valid_objs_def valid_obj_def valid_ep_def) + +lemma tcbSchedPrev_update_tcbSchedPrevs_of_other: + "\\s. P (tcbSchedPrevs_of s t) \ t' \ t\ + threadSet (tcbSchedPrev_update f) t' + \\_ s. P (tcbSchedPrevs_of s t)\" + by (wpsimp wp: threadSet_wp) + +lemma tcbQueuePrepend_tcbSchedPrevs_of_other: + "\\s. P (tcbSchedPrevs_of s t) \ (\head. tcbQueueHead q = Some head \ t \ head)\ + tcbQueuePrepend q t' + \\_ s. P (tcbSchedPrevs_of s t)\" + unfolding tcbQueuePrepend_def + apply (wpsimp wp: tcbSchedPrev_update_tcbSchedPrevs_of_other threadSet_field_inv)+ + apply (clarsimp simp: tcbQueueEmpty_def) + done + +lemma tcbSchedEnqueue_tcbSchedPrevs_of_other: + "\\s. P (tcbSchedPrevs_of s t) \ t' \ t \ \ (tcbQueued |< tcbs_of' s) t\ + tcbSchedEnqueue t' + \\_ s. P (tcbSchedPrevs_of s t)\" + unfolding tcbSchedEnqueue_def + apply (wpsimp wp: tcbQueuePrepend_tcbSchedPrevs_of_other threadGet_wp threadSet_field_inv)+ + apply (clarsimp simp: ksReadyQueues_asrt_def ready_queue_relation_def) + apply normalise_obj_at' + apply (drule_tac x="tcbDomain tcb" in spec) + apply (drule_tac x="tcbPriority tcb" in spec) + apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_head) + apply fastforce + apply (fastforce intro: hd_in_set) + done + +lemma rescheduleRequired_tcbSchedPrevs_of_other: + "\\s. P (tcbSchedPrevs_of s t) \ sch_act_not t s \ \ (tcbQueued |< tcbs_of' s) t\ + rescheduleRequired + \\_ s. P (tcbSchedPrevs_of s t)\" + unfolding rescheduleRequired_def + by (wpsimp wp: tcbSchedEnqueue_tcbSchedPrevs_of_other getSchedulable_wp) + +lemma tcbSchedNext_update_tcbSchedPrevs_of[wp]: + "threadSet (tcbSchedNext_update f) t' \\s. P (tcbSchedPrevs_of s t)\" + apply (wpsimp wp: threadSet_wp) + by (clarsimp simp: opt_map_def obj_at'_def) + +lemma tcbQueueRemove_tcbSchedPrevs_of_not_in_list: + "\\s. P (tcbSchedPrevs_of s t) + \ (\ls. list_queue_relation ls q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) \ t \ set ls)\ + tcbQueueRemove q t' + \\_ s. P (tcbSchedPrevs_of s t)\" + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: tcbSchedPrev_update_tcbSchedPrevs_of_other getTCB_wp) + apply (clarsimp simp: list_queue_relation_def) + apply (drule (1) heap_ls_unique) + apply (force dest!: heap_ls_next_in_list simp: opt_map_def obj_at'_def) + done + +lemma tcbQueueRemove_tcbSchedNexts_of_not_in_list: + "\\s. P (tcbSchedNexts_of s t) + \ (\ls. list_queue_relation ls q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) \ t \ set ls)\ + tcbQueueRemove q t' + \\_ s. P (tcbSchedNexts_of s t)\" + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: tcbSchedNext_update_tcbSchedNexts_of_other getTCB_wp) + apply (clarsimp simp: list_queue_relation_def) + apply (drule (1) heap_ls_unique) + by (fastforce intro: sym_heapD2 dest!: heap_ls_prev_cases simp: opt_map_def obj_at'_def) + +lemma tcbReleaseRemove_tcbSchedPrevs_of_not_in_list: + "\\s. P (tcbSchedPrevs_of s t) \ \ (tcbInReleaseQueue |< tcbs_of' s) t\ + tcbReleaseRemove t' + \\_ s. P (tcbSchedPrevs_of s t)\" + unfolding tcbReleaseRemove_def + apply (wpsimp wp: tcbQueueRemove_tcbSchedPrevs_of_not_in_list hoare_vcg_ex_lift inReleaseQueue_wp + threadSet_field_inv threadSet_sched_pointers) + by (fastforce simp: ksReleaseQueue_asrt_def) + +lemma tcbReleaseRemove_tcbSchedNexts_of_not_in_list: + "\\s. P (tcbSchedNexts_of s t) \ \ (tcbInReleaseQueue |< tcbs_of' s) t\ + tcbReleaseRemove t' + \\_ s. P (tcbSchedNexts_of s t)\" + unfolding tcbReleaseRemove_def + apply (wpsimp wp: tcbQueueRemove_tcbSchedNexts_of_not_in_list hoare_vcg_ex_lift inReleaseQueue_wp + threadSet_field_inv threadSet_sched_pointers) + by (fastforce simp: ksReleaseQueue_asrt_def) + +lemma tcbSchedDequeue_tcbSchedPrevs_of: + "\\s. P (tcbSchedPrevs_of s t) \ \ (tcbQueued |< tcbs_of' s) t\ + tcbSchedDequeue t' + \\_ s. P (tcbSchedPrevs_of s t)\" + unfolding tcbSchedDequeue_def + apply (wpsimp wp: tcbQueueRemove_tcbSchedPrevs_of_not_in_list hoare_vcg_ex_lift inReleaseQueue_wp + threadGet_wp threadSet_field_inv threadSet_sched_pointers) + by (force simp: ksReadyQueues_asrt_def ready_queue_relation_def) + +lemma tcbSchedDequeue_tcbSchedNexts_of: + "\\s. P (tcbSchedNexts_of s t) \ \ (tcbQueued |< tcbs_of' s) t\ + tcbSchedDequeue t' + \\_ s. P (tcbSchedNexts_of s t)\" + unfolding tcbSchedDequeue_def + apply (wpsimp wp: tcbQueueRemove_tcbSchedNexts_of_not_in_list hoare_vcg_ex_lift inReleaseQueue_wp + threadGet_wp threadSet_field_inv threadSet_sched_pointers) + by (force simp: ksReadyQueues_asrt_def ready_queue_relation_def) + +crunch tcbReleaseRemove + for tcbQueued_opt_pred[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + (wp: threadSet_field_opt_pred) + +lemma tcbSchedDequeue_tcbQueued_other: + "\\s. P ((tcbQueued |< tcbs_of' s) t) \ t' \ t\ + tcbSchedDequeue t' + \\_ s. P ((tcbQueued |< tcbs_of' s) t)\" + unfolding tcbSchedDequeue_def + by (wpsimp wp: threadSet_opt_pred_other threadGet_wp) + +lemma schedContextDonate_tcbSchedPrevs_of_None: + "\\s. tcbSchedPrevs_of s tcbPtr = None \ sch_act_not tcbPtr s + \ sym_heap_tcbSCs s \ bound_sc_tcb_at' ((=) None) tcbPtr s + \ \ (tcbQueued |< tcbs_of' s) tcbPtr \ \ (tcbInReleaseQueue |< tcbs_of' s) tcbPtr\ + schedContextDonate scPtr tcbPtr + \\_ s. tcbSchedPrevs_of s tcbPtr = None\" + unfolding schedContextDonate_def + apply (wpsimp wp: threadSet_field_inv threadSet_field_opt_pred + rescheduleRequired_tcbSchedPrevs_of_other + tcbReleaseRemove_tcbSchedPrevs_of_not_in_list + tcbSchedDequeue_tcbSchedPrevs_of tcbSchedDequeue_tcbSchedNexts_of + tcbSchedDequeue_tcbQueued_other hoare_drop_imp )+ + by (force dest!: sym_heapD2[where p'=scPtr] simp: obj_at'_def opt_map_def pred_tcb_at'_def) + +lemma schedContextDonate_tcbSchedNexts_of_None: + "\\s. tcbSchedNexts_of s tcbPtr = None \ sch_act_not tcbPtr s + \ sym_heap_tcbSCs s \ bound_sc_tcb_at' ((=) None) tcbPtr s + \ \ (tcbQueued |< tcbs_of' s) tcbPtr \ \ (tcbInReleaseQueue |< tcbs_of' s) tcbPtr\ + schedContextDonate scPtr tcbPtr + \\_ s. tcbSchedNexts_of s tcbPtr = None\" + unfolding schedContextDonate_def + apply (wpsimp wp: threadSet_field_inv rescheduleRequired_tcbSchedNexts_of_other + tcbReleaseRemove_tcbSchedNexts_of_not_in_list + tcbSchedDequeue_tcbSchedPrevs_of tcbSchedDequeue_tcbSchedNexts_of + tcbSchedDequeue_tcbQueued_other hoare_drop_imps) + by (force dest!: sym_heapD2[where p'=scPtr] simp: obj_at'_def opt_map_def pred_tcb_at'_def) + +crunch setThreadState, replyUnlink, doIPCTransfer, tcbEPDequeue + for tcbQueued_opt_pred[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + and tcbInReleaseQueue_opt_pred[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" + and replySCs_of[wp]: "\s. P (replySCs_of s)" + (wp: crunch_wps threadSet_field_opt_pred threadSet_field_inv simp: crunch_simps) + +lemma updateSchedContext_field_inv: + "(\sc. f (F sc) = f sc) \ updateSchedContext scPtr F \\s. P (scs_of' s |> f)\" + apply (wpsimp wp: updateSchedContext_wp) + by (fastforce elim!: rsubst[where P=P] simp: opt_map_def obj_at'_def) + +crunch updateReply, scheduleTCB, setThreadState, doIPCTransfer + for scTCBs_of[wp]: "\s. P (scTCBs_of s)" + and tcbSchedContexts_of[wp]: "\s. P (tcbSchedContexts_of s)" + (wp: threadSet_field_inv updateSchedContext_field_inv crunch_wps simp: crunch_simps + ignore: updateSchedContext threadSet) + +lemma sym_heap_tcbSCs_lift: + "\\P. f \\s. P (scTCBs_of s)\; \P. f \\s. P (tcbSCs_of s)\\ \ f \sym_heap_tcbSCs\" + by (rule_tac f=tcbSCs_of in hoare_lift_Pf2; wpsimp) + +crunch bindScReply, scheduleTCB, setThreadState, replyUnlink, doIPCTransfer, tcbEPDequeue + for sym_heap_tcbSCs[wp]: sym_heap_tcbSCs + (wp: sym_heap_tcbSCs_lift updateSchedContext_field_inv crunch_wps + simp: crunch_simps ignore: updateSchedContext) + +lemma replyPush_tcbSchedNexts_of_None[wp]: + "\\s. tcbSchedNexts_of s calleePtr = None \ sch_act_not calleePtr s \ sym_heap_tcbSCs s + \ \ (tcbQueued |< tcbs_of' s) calleePtr \ \ (tcbInReleaseQueue |< tcbs_of' s) calleePtr\ + replyPush callerPtr calleePtr replyPtr canDonate + \\_ s. tcbSchedNexts_of s calleePtr = None\" + unfolding replyPush_def + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift' schedContextDonate_tcbSchedNexts_of_None + threadGet_wp) + by normalise_obj_at' + +lemma replyPush_tcbSchedPrevs_of_None[wp]: + "\\s. tcbSchedPrevs_of s calleePtr = None \ sch_act_not calleePtr s \ sym_heap_tcbSCs s + \ \ (tcbQueued |< tcbs_of' s) calleePtr \ \ (tcbInReleaseQueue |< tcbs_of' s) calleePtr\ + replyPush callerPtr calleePtr replyPtr canDonate + \\_ s. tcbSchedPrevs_of s calleePtr = None\" + unfolding replyPush_def + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift' schedContextDonate_tcbSchedPrevs_of_None + threadGet_wp) + by normalise_obj_at' + +crunch tcb_ep_dequeue + for ep_at[wp]: "ep_at ep_ptr" + (wp: crunch_wps) + +lemma ready_queues_runnable_not_queued: + "\ready_queues_runnable s; st_tcb_at (Not \ runnable) t s\ \ not_queued t s" + apply (clarsimp simp: ready_queues_runnable_def st_tcb_at_def obj_at_def not_queued_def) apply fastforce done -lemma find_time_after_hd_relation: - "\\s. sorted_release_q' s \ release_queue s = rlq \ rlq \ [] - \ read_tcb_ready_time tcb_ptr s = Some new_time - \ (\last_time. read_tcb_ready_time (last rlq) s = Some last_time \ \ last_time \ new_time)\ - find_time_after rlq new_time - \\rv s. the (read_tcb_ready_time tcb_ptr s) < the (read_tcb_ready_time (hd rv) s)\" - (is "\?pre\ _ \_\") - apply (clarsimp simp: find_time_after_def) - apply (rule hoare_pre) - apply (rule_tac P="\rv s. ?pre s" - and I="\rv s. ?pre s \ suffix rv (release_queue s) \ rv \ []" - in valid_whileLoop; - fastforce?) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves \wpsimp wp: whileLoop_valid_inv\)?) - apply wpsimp - apply (fastforce simp: suffix_tl) - apply wpsimp - apply (fastforce simp: suffix_def tl_Nil time_after_def obind_def) - apply (clarsimp simp: suffix_def) - apply (case_tac r; fastforce simp: time_after_def obind_def sorted_release_q'_def) - apply fastforce +lemma sendIPC_corres_sym_refs_helper: + "\ko_at (kernel_object.Endpoint (RecvEP (dest # ls))) ep_ptr s; + valid_objs s; sym_refs (state_refs_of s); valid_ep (RecvEP (dest # ls)) s; + st_tcb_at (\x. x = Structures_A.thread_state.BlockedOnReceive ep_ptr data pl) dest s; + ko_at (kernel_object.Endpoint obj) ep_ptr s\ + \ sym_refs + (\x. if x = dest + then {r \ state_refs_of s dest. snd r = TCBBound \ snd r = TCBSchedContext + \ snd r = TCBYieldTo \ snd r = TCBReply} + else if x = ep_ptr + then ep_q_refs_of (case removeAll dest (ep_queue obj) of + [] \ IdleEP + | a # list \ update_ep_queue obj (removeAll dest (ep_queue obj)) True) + else state_refs_of s x)" + unfolding removeAll_filter_not_eq + apply (prop_tac "filter ((\) dest) ls = ls", fastforce simp: valid_ep_def filter_id_conv) + apply (rule delta_sym_refs, assumption) + apply (fastforce simp: obj_at_def state_refs_of_def split: list.splits if_splits) + apply clarsimp + apply (intro conjI) + apply (fastforce simp: valid_obj_def valid_ep_def is_tcb obj_at_def split: list.splits if_splits) + apply (clarsimp, intro conjI) + apply (clarsimp simp: obj_at_def split: if_splits) + apply (fastforce simp: state_refs_of_def) + apply (clarsimp simp: obj_at_def split: if_splits) + apply (clarsimp simp: st_tcb_at_def obj_at_def state_refs_of_def get_refs_def2 split: if_splits) + apply (clarsimp simp: sym_refs_ko_atD obj_at_def split: list.splits) done -crunch find_time_after - for (empty_fail) empty_fail[intro!, wp, simp] +crunch getSchedulerAction + for (no_fail) no_fail[wp] -lemma find_time_after_no_fail: - "no_fail (\s. release_queue s \ []) (find_time_after rlq time)" - apply (simp add: no_fail_def find_time_after_def) - apply (intro impI allI) - apply (rule_tac I="\rv s. release_queue s \ []" - and R="{((r', s'), (r, s)). length r' < length r}" - in not_snd_whileLoop) +lemma bound_sc_tcb_at_cross': + "\bound_sc_tcb_at P t s; (s, s') \ state_relation; pspace_aligned s; pspace_distinct s\ + \ bound_sc_tcb_at' P t s'" + by (fastforce dest!: bound_sc_tcb_at_cross simp: pred_tcb_at'_def obj_at'_def opt_map_red) + +lemma sendIPC_corres: +(* call is only true if called in handleSyscall SysCall, which is always blocking. *) + assumes "call \ bl" + shows + "corres dc + (all_invs_but_fault_tcbs and fault_tcbs_valid_states_except_set {t} and valid_list + and active_scs_valid and valid_release_q + and current_time_bounded + and st_tcb_at runnable t and not_queued t and not_in_release_q t + and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable and release_q_runnable + and ready_or_release and sorted_ipc_queues + and valid_sched_action and ep_at ep_ptr + and scheduler_act_not t and (\s. cd \ bound_sc_tcb_at (\a. \y. a = Some y) t s)) + invs' + (send_ipc bl call bg cg cgr cd t ep_ptr) (sendIPC bl call bg cg cgr cd t ep_ptr)" + apply (insert assms) + apply add_sym_refs + apply add_valid_idle' + apply (clarsimp simp: send_ipc_def sendIPC_def Let_def split del: if_split) + apply (rule corres_stateAssert_add_assertion[rotated], simp) + apply (rule corres_stateAssert_add_assertion[rotated], simp) + apply (rule corres_stateAssert_add_assertion[rotated], simp) + apply (rule_tac Q'="ep_at' ep_ptr" in corres_cross_add_guard, fastforce intro!: ep_at_cross) + apply (rule_tac Q'="st_tcb_at' runnable' t" in corres_cross_add_guard) + apply (fastforce intro!: st_tcb_at_runnable_cross) + apply (rule corres_stateAssert_add_assertion[rotated], simp add: runnable_eq_active') + apply (rule_tac Q'="\s'. \ (tcbQueued |< tcbs_of' s') t" in corres_cross_add_guard) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=t]) + apply (clarsimp simp: not_queued_def in_ready_q_def) + apply (rule_tac Q'="\s'. \ (tcbInReleaseQueue |< tcbs_of' s') t" in corres_cross_add_guard) + apply (frule state_relation_release_queue_relation) + apply (frule in_release_q_tcbInReleaseQueue_eq[where t=t]) + apply (clarsimp simp: in_release_q_def) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ep_sp']) + apply (corres corres: getEndpoint_corres) + apply (rename_tac ep ep') + apply (rule_tac Q="\s. ep_queues_of s ep_ptr = Some (ep_queue ep)" in corres_cross_add_abs_guard) + apply (case_tac ep; clarsimp simp: eps_of_kh_def obj_at_def opt_map_def) + apply (rule_tac Q="valid_ep ep" in corres_cross_add_abs_guard) + apply (fastforce dest: valid_objs_valid_ep simp: obj_at_def) + apply (case_tac ep; clarsimp simp: ep_relation_def) + apply (subst bind_dummy_ret_val) + apply (corres corres: send_ipc_blocked_corres) + apply (clarsimp simp: obj_at'_def) + apply (subst bind_dummy_ret_val) + apply (corres corres: send_ipc_blocked_corres) + apply (clarsimp simp: obj_at'_def) + apply (rename_tac ep' ls) + apply (rule_tac F="ls \ []" in corres_req) + apply (clarsimp simp: valid_ep_def) + apply (case_tac ls; clarsimp) + apply (rename_tac dest tail) + apply (rule_tac Q'="\s'. list_queue_relation + (dest # tail) (epQueue ep') (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in corres_cross_add_guard) + apply (fastforce elim!: ep_queues_relationD + simp: obj_at_def opt_map_def obj_at'_def split: option.splits) + apply (rule corres_stateAssert_ignore) + apply (rule_tac ts="dest # tail" in list_queue_relation_tcb_queue_head_end_valid) apply fastforce - apply (clarsimp simp: validNF_def) - apply (rule conjI) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) - apply wpsimp - apply (fastforce simp: suffix_def tl_Nil time_after_def) - apply (fastforce intro: list_length_wf_helper) + apply (clarsimp simp: valid_ep_def) + apply (fastforce intro!: tcb_at_cross) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (fastforce dest: list_queue_relation_Nil) + apply (clarsimp simp: tcbQueueEmpty_def) + apply (rename_tac head) + apply (rule_tac F="head = dest" in corres_req) + apply (clarsimp simp: list_queue_relation_def) + apply clarsimp + apply (rule_tac Q="st_tcb_at (Not \ runnable) dest" in corres_cross_add_abs_guard) + apply (clarsimp simp: obj_at_def) + apply (frule_tac t=dest in in_receive_ep_queue_st_tcb_at) + apply force + apply fastforce + apply (erule st_tcb_weakenE) + subgoal for \ st by (case_tac st; clarsimp) + apply (rule corres_assert_gen_asm_cross_forwards; (solves wpsimp)?) + apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply simp + apply (rule in_ready_q_tcbQueued_eq[THEN arg_cong_Not, THEN iffD1]) + apply fastforce + apply (clarsimp elim!: ready_queues_runnable_not_queued) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply simp + apply (rule in_release_q_tcbInReleaseQueue_eq[THEN arg_cong_Not, THEN iffD1]) + apply fastforce + apply (fastforce dest!: valid_release_q_not_in_release_q_not_runnable) + apply (rule corres_symb_exec_r[OF _ getSchedulerAction_sp]; (solves wpsimp)?) + apply (rule corres_assert_gen_asm_cross_forwards; (solves wpsimp)?) + apply (frule cross_relF[OF _ sch_act_not_cross_rel]) + apply (rule weak_valid_sched_action_scheduler_action_not) + apply (fastforce intro: valid_sched_action_weak_valid_sched_action) + apply fastforce + apply clarsimp + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF tcbEPDequeue_corres], simp, simp) + apply clarsimp + apply (rule corres_split[OF getThreadState_corres]) + apply (rule stronger_corres_guard_imp) + apply (rule_tac F="\reply_opt pl. recv_state = Structures_A.BlockedOnReceive ep_ptr reply_opt pl" + in corres_gen_asm) + apply (clarsimp simp: case_bool_If case_option_If if3_fold + simp del: dc_simp split del: if_split cong: if_cong) + apply (clarsimp simp: isReceive_def split del: if_split) + apply (rule corres_split [OF doIPCTransfer_corres]) + apply (rule corres_stateAssert_r) + apply (rule corres_split[where r'=dc]) + apply (clarsimp simp: maybeM_def) + apply (rule corres_option_split[OF refl corres_return_trivial]) + apply clarsimp + apply (rule replyUnlinkTcb_corres) + apply (simp only: get_tcb_obj_ref_def) + apply (rule corres_split [OF threadGet_corres[where r="(=)"]]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_split [OF threadGet_corres[where r=fault_rel_optionation]]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_split [OF corres_if[where r=dc], where r=dc]) + apply (clarsimp simp: fault_rel_optionation_def) + apply (rule corres_if, clarsimp) + apply (rule replyPush_corres, simp) + apply (rule setThreadState_corres, simp) + apply (rule corres_when, simp) + apply (rule corres_split [OF threadGet_corres[where r="(=)"]]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_assert_assume_r) + apply (simp, rule schedContextDonate_corres) + apply (wpsimp wp: thread_get_wp) + apply (wpsimp wp: threadGet_wp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule corres_split_eqr[OF threadGet_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_split [OF ifCondRefillUnblockCheck_corres]) + apply (rule possibleSwitchTo_corres, simp) + apply wpsimp + apply wpsimp + apply clarsimp + apply (rule_tac Q'="\r. bound_sc_tcb_at ((=) r) dest + and active_scs_valid and valid_sched_action + and pspace_aligned and pspace_distinct + and valid_objs and ready_or_release + and in_correct_ready_q and ready_qs_distinct + and ready_queues_runnable and st_tcb_at runnable dest + and not_in_release_q dest and current_time_bounded + and ep_queues_blocked and ntfn_queues_blocked" + in hoare_post_imp) + apply clarsimp + apply (case_tac rv; clarsimp) + apply (clarsimp simp: pred_tcb_at_def obj_at_def is_tcb option.case_eq_if) + apply (frule (1) valid_objs_valid_tcb) + subgoal + by (fastforce simp: valid_obj_def valid_tcb_def obj_at_def + valid_bound_obj_def is_sc_obj opt_map_red opt_pred_def + split: option.splits) + apply (wpsimp wp: thread_get_wp') + apply (wpsimp wp: threadGet_wp) + apply (rule_tac Q'="\r. active_scs_valid and valid_sched_action + and pspace_aligned and pspace_distinct and valid_objs + and ready_or_release and in_correct_ready_q + and ready_qs_distinct and ready_queues_runnable + and st_tcb_at runnable dest and not_in_release_q dest + and current_time_bounded + and ep_queues_blocked and ntfn_queues_blocked" + in hoare_post_imp) + apply (clarsimp simp: pred_tcb_at_def obj_at_def is_tcb_def) + apply (wpsimp wp: set_thread_state_valid_sched_action + set_thread_state_ready_queues_runnable_runnable + set_thread_state_ep_queues_blocked_not_queued + set_thread_state_ntfn_queues_blocked_not_queued) + apply (rule_tac Q'="\_. tcb_at' dest and valid_objs' + and sym_heap_sched_pointers and valid_sched_pointers + and pspace_aligned' and pspace_distinct' + and pspace_bounded'" + in hoare_post_imp) + apply (clarsimp simp: obj_at'_def valid_objs'_valid_tcbs' split: option.split) + apply (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers) + apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct + and tcb_at dest and active_scs_valid + and valid_sched_action and ready_or_release + and in_correct_ready_q and ready_qs_distinct + and not_in_release_q dest and current_time_bounded + and ready_queues_runnable + and ep_queues_blocked and ntfn_queues_blocked + and not ep_queued dest and not ntfn_queued dest" + in hoare_post_imp) + apply fastforce + apply (wpsimp wp: set_thread_state_valid_sched_action + sched_context_donate_valid_sched_action + thread_get_wp' reply_push_valid_objs + reply_push_ep_queues_blocked_not_queued + reply_push_ntfn_queues_blocked_not_queued + set_thread_state_valid_sched_action + set_thread_state_ready_queues_runnable_not_queued + set_thread_state_ep_queues_blocked_not_queued + set_thread_state_ntfn_queues_blocked_not_queued) + apply ((wpsimp wp: replyPush_valid_objs' + replyPush_sym_heap_sched_pointers + replyPush_valid_sched_pointers + replyPush_st_tcb_at'_other + setThreadState_sched_pointers_valid_sched_pointers + sts_st_tcb_at'_cases schedContextDonate_valid_objs' + schedContextDonate_tcbSchedNexts_of_None + schedContextDonate_tcbSchedPrevs_of_None + | strengthen valid_objs'_valid_tcbs')+)[1] + apply (wpsimp wp: threadGet_wp) + apply (wpsimp wp: thread_get_wp') + apply (wpsimp wp: threadGet_wp) + apply (wpsimp wp: thread_get_wp') + apply (wpsimp wp: threadGet_wp) + apply (rule_tac + Q'="\_. valid_objs and pspace_aligned and pspace_distinct + and valid_replies and scheduler_act_not t + and K (t \ idle_thread_ptr) and valid_idle + and tcb_at dest and active_scs_valid + and valid_sched_action and ready_or_release + and in_correct_ready_q and ready_qs_distinct + and ready_queues_runnable and valid_release_q + and not_queued t and not_in_release_q t + and not ep_queued t and not ntfn_queued t + and st_tcb_at runnable t and st_tcb_at active t + and ep_queues_blocked and ntfn_queues_blocked + and not_in_release_q dest and current_time_bounded + and ep_queues_blocked and ntfn_queues_blocked + and not ep_queued dest and not ntfn_queued dest + and (\s. cd \ bound_sc_tcb_at (\a. \y. a = Some y) t s) + and (\s. reply_opt \ None + \ reply_at (the reply_opt) s + \ ex_nonz_cap_to (the reply_opt) s + \ reply_tcb_reply_at (\tptr. tptr = None) (the reply_opt) s + \ reply_sc_reply_at (\tptr. tptr = None) (the reply_opt) s + \ the reply_opt \ fst ` replies_with_sc s + \ sym_refs (state_refs_of s))" + in hoare_post_imp) + apply (prop_tac "reply_opt \ None + \ sym_refs + (\p. if p = t + then tcb_non_st_state_refs_of s t + else state_refs_of s p)") + subgoal + apply clarsimp + apply (erule delta_sym_refs) + by (auto simp: state_refs_of_def get_refs_def2 pred_tcb_at_def obj_at_def + split: if_split_asm option.splits) + apply (prop_tac "st_tcb_at (\st. reply_object st = None) t s") + apply (fastforce elim!: pred_tcb_weakenE) + apply (clarsimp simp: st_tcb_at_tcb_at cong: conj_cong) + apply (frule valid_sched_action_weak_valid_sched_action, simp) + apply (frule valid_objs_valid_tcbs, simp) + apply (subgoal_tac "cd \ bound_sc_tcb_at (\sc_ptr_opt. sc_at (the sc_ptr_opt) s) t s") + apply (clarsimp simp: obj_at_def is_tcb pred_tcb_at_def) + apply (frule valid_release_q_distinct) + apply (frule valid_release_q_release_q_runnable) + apply clarsimp + apply (drule pred_tcb_at_ko_atD, clarsimp) + apply (frule (1) valid_objs_ko_at) + apply (clarsimp simp: pred_tcb_at_def obj_at_def valid_obj_def valid_tcb_def) + apply (wpsimp wp: reply_unlink_tcb_valid_sched_action + reply_unlink_tcb_valid_replies_BlockedOnReceive + reply_unlink_tcb_sym_refs_BlockedOnReceive + reply_unlink_tcb_reply_tcb_reply_at[where P=id, simplified] + reply_unlink_tcb_st_tcb_at' replies_with_sc_lift) + apply (rule_tac + Q'="\_ s. tcb_at' t s \ tcb_at' dest s \ valid_objs' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ \ is_sched_linked t s + \ \ is_sched_linked dest s + \ \ (tcbQueued |< tcbs_of' s) dest + \ \ (tcbInReleaseQueue |< tcbs_of' s) dest + \ t \ dest + \ (reply_opt \ None + \ reply_at' (the reply_opt) s + \ replySCs_of s (the reply_opt) = None) + \ sym_heap_tcbSCs s \ sch_act_not dest s + \ (cd \ bound_sc_tcb_at' (\scOpt. scOpt \ None) t s)" + in hoare_post_imp) + apply (clarsimp cong: conj_cong) + apply (frule valid_objs'_valid_tcbs') + apply (drule obj_at_ko_at')+ + apply (prop_tac "reply_opt \ None \ valid_replies'_sc_asrt (the reply_opt) s") + apply (blast dest: no_replySC_valid_replies'_sc_asrt) + apply normalise_obj_at' + apply (wpsimp wp: replyUnlink_valid_sched_pointers replyUnlink_st_tcb_at' + hoare_vcg_const_imp_lift) + apply (wpfix add: reply_object.simps(1)) + apply (rule_tac + Q'="\_. valid_objs and pspace_aligned and pspace_distinct + and valid_replies and active_scs_valid and valid_release_q + and scheduler_act_not t and valid_sched_action + and ready_queues_runnable and not_queued t and not_in_release_q t + and not ep_queued t and not ntfn_queued t + and st_tcb_at runnable t and valid_idle + and ep_queues_blocked and ntfn_queues_blocked + and not ep_queued dest and not ntfn_queued dest and not_queued dest + and in_correct_ready_q and ready_qs_distinct and ready_or_release + and not_in_release_q dest and st_tcb_at active t and tcb_at dest + and if_live_then_nonz_cap and scheduler_act_not dest + and K (t \ idle_thread_ptr) and current_time_bounded + and (\s. cd \ bound_sc_tcb_at (\a. \y. a = Some y) t s) + and (\s. reply_opt \ None + \ st_tcb_at + ((=) (Structures_A.thread_state.BlockedOnReceive + ep_ptr reply_opt pl)) dest s + \ ex_nonz_cap_to (the reply_opt) s + \ reply_tcb_reply_at ((=) (Some dest)) (the reply_opt) s + \ reply_sc_reply_at (\a. a = None) (the reply_opt) s + \ the reply_opt \ fst ` replies_with_sc s) + and (\s. sym_refs + (\x. if x = dest + then {r \ state_refs_of s x. + snd r = TCBBound \ snd r = TCBSchedContext + \ snd r = TCBYieldTo \ snd r = TCBReply} + else state_refs_of s x))" + in hoare_post_imp) + apply (clarsimp split: option.splits cong: conj_cong) + apply (intro conjI) + apply (erule valid_objs_valid_tcbs) + apply (clarsimp simp: pred_tcb_at_def obj_at_def is_tcb, fastforce) + apply fastforce + apply (fastforce simp: reply_tcb_reply_at_def obj_at_def st_tcb_at_def) + apply (clarsimp simp: sk_obj_at_pred_def obj_at_def is_reply) + apply (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift simp: iff_conv_conj_imp) + apply (wpfix add: Structures_H.thread_state.sel) + apply (rule_tac Q'="\_ s. tcb_at' t s \ tcb_at' dest s \ valid_objs' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ (reply_opt \ None + \ reply_at' (the reply_opt) s + \ replySCs_of s (the reply_opt) = None) + \ \ is_sched_linked t s + \ \ is_sched_linked dest s + \ \ (tcbQueued |< tcbs_of' s) dest + \ \ (tcbInReleaseQueue |< tcbs_of' s) dest + \ t \ dest \ sym_heap_tcbSCs s \ sch_act_not dest s + \ (cd \ bound_sc_tcb_at' (\scOpt. scOpt \ None) t s)" + in hoare_post_imp) + apply (clarsimp split: option.splits) + apply (wpsimp wp: hoare_vcg_imp_lift) + apply assumption + apply (prop_tac "tcb_at' t s' \ tcb_at' dest s' \ ep_at' ep_ptr s' \ valid_pspace' s' + \ sym_heap_sched_pointers s' \ valid_sched_pointers s' + \ valid_objs' s' \ valid_mdb' s' + \ pspace_aligned' s' \ pspace_distinct' s' \ pspace_bounded' s' + \ \ is_sched_linked t s' + \ \ is_sched_linked dest s' + \ \ (tcbQueued |< tcbs_of' s') dest + \ \ (tcbInReleaseQueue |< tcbs_of' s') dest + \ t \ dest \ sym_heap_tcbSCs s' \ sch_act_not dest s' + \ (cd \ bound_sc_tcb_at' (\scOpt. scOpt \ None) t s')", assumption) + apply clarsimp + apply (case_tac reply_opt; clarsimp) + apply (rename_tac reply_ptr, subgoal_tac "reply_at' reply_ptr s'", simp) + apply (frule (1) replySCs_of_cross, simp) + apply (erule cross_relF[OF _ reply_at'_cross_rel]) + apply (clarsimp simp: obj_at_def reply_sc_reply_at_def is_reply) + apply (wpsimp wp: gts_wp) + apply (rule_tac Q'="\_ s'. tcb_at' t s' \ tcb_at' dest s' \ ep_at' ep_ptr s' \ valid_pspace' s' + \ sym_heap_sched_pointers s' \ valid_sched_pointers s' + \ valid_objs' s' \ valid_mdb' s' + \ pspace_aligned' s' \ pspace_distinct' s' \ pspace_bounded' s' + \ st_tcb_at' runnable' t s' + \ \ (tcbQueued |< tcbs_of' s') t + \ \ (tcbInReleaseQueue |< tcbs_of' s') t + \ \ is_sched_linked dest s' + \ \ (tcbQueued |< tcbs_of' s') dest + \ \ (tcbInReleaseQueue |< tcbs_of' s') dest + \ t \ dest \ sym_heap_tcbSCs s' \ sch_act_not dest s' + \ (cd \ bound_sc_tcb_at' (\scOpt. scOpt \ None) t s')" + in hoare_post_imp) + apply clarsimp + apply (frule (1) runnable'_Not_tcbInReleaseQueue_not_sched_linked[rotated]) + apply (clarsimp simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_red) + apply simp + apply (wpsimp wp: gts_wp') + apply ((wpsimp wp: tcb_ep_dequeue_ep_queued_other[where t=t] + tcb_ep_dequeue_not_ep_queued hoare_vcg_all_lift hoare_vcg_imp_lift' + | wpsimp simp: tcb_ep_dequeue_def + wp: get_simple_ko_wp hoare_vcg_all_lift hoare_vcg_imp_lift' + hoare_vcg_disj_lift)+)[1] + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift + simp: valid_pspace'_def) + apply clarsimp + apply (frule sym_refs_ep_queues_blocked) + apply (frule sym_refs_ntfn_queues_blocked) + apply (prop_tac "(dest, EPRecv) \ state_refs_of s ep_ptr") + apply (clarsimp simp: state_refs_of_def obj_at_def) + apply (frule (1) sym_refsD, simp) + apply (frule TCBBlockedRecv_in_state_refs_of) + apply (clarsimp simp: invs_def pred_tcb_at_eq_commute st_tcb_at_tcb_at cong: conj_cong) + apply (intro conjI impI allI) + apply (clarsimp simp: in_ep_queue_at_def obj_at_def) + apply (fastforce elim!: runnable_not_ep_queued) + apply (fastforce elim!: runnable_not_ntfn_queued) + apply (rule not_ntfn_blocked_not_ntfn_queued) + apply (clarsimp simp: pred_tcb_at_def obj_at_def opt_map_def split: option.splits) + subgoal for \ tcb' by (case_tac "tcb_state tcb'"; clarsimp simp: ntfn_blocked_def) + apply fastforce + apply (fastforce elim!: ready_queues_runnable_not_queued) + apply (force elim!: valid_release_q_not_in_release_q_not_runnable) + apply (simp add: runnable_eq_active) + apply (erule (1) if_live_then_nonz_capD) + apply (clarsimp simp: obj_at_def live_def) + apply (frule valid_sched_action_weak_valid_sched_action) + apply (force elim!: weak_valid_sched_action_scheduler_action_not) + apply (frule (1) not_idle_thread[simplified runnable_eq_active[symmetric]]) + apply (clarsimp simp: valid_idle_def) + apply (rename_tac st) + apply (case_tac "reply_object st"; simp) + apply (rename_tac reply_ptr) + apply (subgoal_tac "data = Some reply_ptr", simp) + apply (subgoal_tac "reply_tcb_reply_at ((=) (Some dest)) reply_ptr s", simp) + apply (subgoal_tac "reply_sc_reply_at (\a. a = None) reply_ptr s", simp) + apply (intro conjI) + apply (clarsimp simp: sk_obj_at_pred_def obj_at_def) + apply (erule (1) if_live_then_nonz_capD2) + apply (clarsimp simp: live_def live_reply_def) + apply clarsimp + apply (frule (1) valid_repliesD1_simp, clarsimp simp: replies_blocked_def) + apply (subst (asm) identity_eq[ + where x="Structures_A.thread_state.BlockedOnReply ptr" for ptr, + symmetric])+ + apply (frule (1) st_tcb_reply_state_refs) + apply (clarsimp simp: pred_tcb_at_def obj_at_def reply_tcb_reply_at_def) + apply (subst identity_eq) + apply (erule (1) valid_replies_ReceiveD[rotated]) + apply (subst identity_eq, assumption, simp) + apply (subst identity_eq) + apply (erule st_tcb_recv_reply_state_refs[rotated]) + apply (subst identity_eq, assumption) + apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply clarsimp + apply force + apply (fastforce intro!: sendIPC_corres_sym_refs_helper) + apply (clarsimp simp: obj_at_def pred_tcb_at_def) + apply (clarsimp simp: invs'_def valid_pspace'_def) + apply (intro conjI impI allI) + apply (fastforce intro: tcb_at_cross) + apply (fastforce intro: tcb_at_cross) + apply (clarsimp simp: pred_tcb_at_def obj_at_def) + apply (fastforce intro!: sym_refs_tcbSCs) + apply (fastforce dest!: bound_sc_tcb_at_cross') done -crunch get_tcb_ready_time - for inv[wp]: P +end -(* FIXME RT: use new oblivious framework for this lemma *) -lemma monadic_rewrite_when_reprogram_timer_set_release_queue: - "monadic_rewrite F E \ - (do when P (modify (reprogram_timer_update (\_. True))); - set_release_queue q - od) - (do set_release_queue q; - when P (modify (reprogram_timer_update (\_. True))) - od)" - apply (clarsimp simp: when_def) - apply (cases P; clarsimp simp: monadic_rewrite_refl) - apply (rule monadic_rewrite_reprogram_timer_set_release_queue[simplified]) - done +crunch maybeReturnSc + for typ_at'[wp]: "\s. P (typ_at' T p' s)" + and sc_at'_n[wp]: "\s. Q (sc_at'_n n p s)" + (wp: crunch_wps) + +global_interpretation maybeReturnSc: typ_at_all_props' "maybeReturnSc ntfnPtr tcbPtr" + by typ_at_props' + +global_interpretation setMessageInfo: typ_at_all_props' "setMessageInfo t info" + by typ_at_props' + +context begin interpretation Arch . (*FIXME: arch-split*) + +crunch cancel_ipc + for cur[wp]: "cur_tcb" + and ntfn_at[wp]: "ntfn_at t" + (wp: crunch_wps simp: crunch_simps ignore: set_object) + +lemma valid_sched_weak_strg: + "valid_sched s \ weak_valid_sched_action s" + by (simp add: valid_sched_def valid_sched_action_def) + +lemma idle_tsr: + "thread_state_relation ts ts' \ idle' ts' = idle ts" + by (case_tac ts, auto) lemma oblivious_getObject_ksPSpace_default: "\ \s. ksPSpace (f s) = ksPSpace s; @@ -3228,638 +3483,376 @@ lemma oblivious_getObject_ksPSpace_cte[simp]: read_typeError_def read_alignCheck_def read_magnitudeCheck_def read_alignError_def split: option.splits) -lemma oblivious_setReprogramTimer_threadSet: - "oblivious (ksReprogramTimer_update upd) (threadSet f t)" - by (fastforce simp: threadSet_def intro: oblivious_bind) - -(* FIXME RT: use new oblivious framework for this lemma *) -lemma monadic_rewrite_setReprogramTimer_threadSet: - "monadic_rewrite False True \ - (do r \ setReprogramTimer bool; threadSet f t od) - (do threadSet f t; setReprogramTimer bool od)" - apply (clarsimp simp: setReprogramTimer_def) - apply (subst bind_dummy_ret_val)+ - apply (rule oblivious_monadic_rewrite) - apply (rule oblivious_setReprogramTimer_threadSet) - done - -crunch find_time_after - for inv[wp]: P - (wp: crunch_wps) - -lemma set_gets_release_queue_simp[simplified]: - "do set_release_queue q; q' \ gets release_queue; f q' od = - do set_release_queue q; q' \ return q; f q' od" - by (rule ext) - (auto split: prod.split simp: simpler_gets_def bind_def return_def modify_def get_def put_def) - -lemma find_time_after_not_hd: - "\\s. sorted_release_q' s \ release_queue s = rlq \ not_in_release_q tcb_ptr s \ rlq \ [] - \ read_tcb_ready_time tcb_ptr s = Some new_time - \ (\head_time last_time. - read_tcb_ready_time (hd rlq) s = Some head_time - \ read_tcb_ready_time (last rlq) s = Some last_time - \ head_time \ new_time \ new_time < last_time) \ - find_time_after rlq new_time - \\rv s. hd rv \ hd rlq \" - (is "\?pre\ _ \_\") - apply (clarsimp simp: find_time_after_def) - apply (rule hoare_pre) - apply (rule_tac P="\rv s. ?pre s" - and I="\rv s. ?pre s \ suffix rv (release_queue s) \ rv \ []" - in valid_whileLoop; - fastforce?) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves \wpsimp wp: whileLoop_valid_inv\)?) - apply wpsimp - apply (fastforce simp: suffix_tl) - apply wpsimp - apply (fastforce simp: suffix_def tl_Nil time_after_def obind_def) - apply (simp add: suffix_def not_in_release_q_def time_after_def obind_def) - apply (case_tac r; clarsimp split: if_splits) - apply fastforce - done - -lemma tcb_release_enqueue_monadic_rewrite: - "monadic_rewrite False True - (valid_release_q and active_scs_valid and active_sc_tcb_at tcb_ptr and valid_objs - and not_in_release_q tcb_ptr) - (tcb_release_enqueue tcb_ptr) (tcb_release_enqueue' tcb_ptr)" - supply if_split[split del] - supply set_gets_release_queue_simp[simp] - unfolding tcb_release_enqueue_def tcb_release_enqueue'_def ifM_def orM_def - apply (monadic_rewrite_symb_exec_l, rename_tac time) - apply (monadic_rewrite_symb_exec_r_known time) - apply (rule monadic_rewrite_bind_tail) - apply monadic_rewrite_symb_exec_l - - apply (rule_tac P="qs = []" in monadic_rewrite_cases; clarsimp) - - (* qs empty *) - apply (rule monadic_rewrite_reprogram_timer_set_release_queue[simplified]) - - (* qs not empty *) - - (* times should therefore also not be empty *) - apply (rule_tac P="times \ []" in monadic_rewrite_gen_asm) - (* lhs is in inconvenient order: want set_release_queue first *) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_when_reprogram_timer_set_release_queue[simplified]) - (* symbolically execute up to set_release_queue part of non-map RHS *) - apply (monadic_rewrite_symb_exec_r_known "hd times") (* time of hd qs = hd times *) - apply (rule monadic_rewrite_trans[rotated]) - apply (rule monadic_rewrite_refl) - - (* rewrite rest of getters in if statement branches, except for compare_times_loop *) - apply (rule monadic_rewrite_trans[rotated]) - apply (rule monadic_rewrite_if[OF monadic_rewrite_refl]) - apply (monadic_rewrite_symb_exec_r_known "last times") (* time of last qs = last times *) - apply (rule monadic_rewrite_if[OF monadic_rewrite_refl]) - apply (rule monadic_rewrite_refl) - apply (wpsimp wp: get_tcb_ready_time_wp)+ - - (* split branches *) - - apply (rule_tac P="sorted times" in monadic_rewrite_gen_asm) - apply (rule_tac P="length times = length qs" in monadic_rewrite_gen_asm) - apply (rule_tac P="time < hd times" in monadic_rewrite_cases; clarsimp) - - (* prepend *) - - apply (prop_tac "filter (\(_, t). t \ time) (zip qs times) = []") - apply (rule filter_False, fastforce simp: neq_Nil_conv dest: in_set_zip2) - apply (prop_tac "filter (\(_, t). \ t \ time) (zip qs times) = (zip qs times)") - apply (rule filter_True, fastforce simp: neq_Nil_conv dest: in_set_zip2) - apply simp - (* set_release_queue is the same now *) - apply (rule monadic_rewrite_refl) - - apply (rule_tac P="last times \ time" in monadic_rewrite_cases; clarsimp) - - (* append *) - - apply (prop_tac "filter (\(_, t). t \ time) (zip qs times) = (zip qs times)") - apply (rule filter_True, fastforce simp: neq_Nil_conv dest!: sorted_last_leD in_set_zip2) - apply (prop_tac "filter (\(_, t). \ t \ time) (zip qs times) = []") - apply (rule filter_False, fastforce simp: neq_Nil_conv dest!: sorted_last_leD in_set_zip2) - apply simp - apply (rule monadic_rewrite_refl) - - (* insert in the middle *) - - (* get rid of reprogram timer reasoning on LHS *) - apply (prop_tac "filter (\(_, t). t \ time) (zip qs times) \ []") - apply (fastforce simp: neq_Nil_conv split: if_splits) - apply clarsimp - apply (monadic_rewrite_symb_exec_r \wpsimp wp: find_time_after_no_fail\) - apply (rename_tac sfx) - (* in order to use the compare_times_loop wp rules we need to link the two sides *) - apply (rule_tac P="\s. sorted_release_q' s \ valid_release_q s \ qs = release_queue s - \ times = (map (\ptr. the (read_tcb_ready_time ptr s)) (release_queue s)) - \ time = the (read_tcb_ready_time tcb_ptr s) - \ sfx \ [] \ suffix sfx (release_queue s) - \ (\pfx v. pfx @ sfx = release_queue s \ v \ set pfx - \ the (read_tcb_ready_time v s) - \ the (read_tcb_ready_time tcb_ptr s)) - \ (the (read_tcb_ready_time tcb_ptr s) - < the (read_tcb_ready_time (hd sfx) s))" - in monadic_rewrite_guard_arg_cong) - apply clarsimp - apply (cut_tac s=s and y="tcb_ptr" and new=tcb_ptr in insort_partition_read_tcb_ready_time) - apply fastforce - apply (clarsimp simp: insort_filter_def insort_partition_def) - apply (cut_tac f=read_tcb_ready_time - and ts="release_queue s" - and R=less_eq - and ptr="hd sfx" - and t=tcb_ptr - and val="the (read_tcb_ready_time tcb_ptr s)" - in takeWhile_dropWhile_insert_list_before) - apply fastforce - apply (clarsimp simp: suffix_def) - apply (fastforce simp: sorted_release_q'_def) - apply (fastforce simp: suffix_def sorted_release_q'_def map_fst_dropWhile_zip - map_fst_filter_zip) - apply (clarsimp simp: suffix_def valid_release_q_def) - apply (metis distinct_append distinct_inj_middle list.sel(1) min_list.cases) - apply fastforce - apply fastforce - apply (wpsimp wp: find_time_after_sfx_nonempty find_time_after_sfx_sfx - find_time_after_pfx find_time_after_hd_relation) - apply (wpsimp wp: get_tcb_ready_time_wp) - apply (wpsimp wp: mapM_wp') - apply (rule no_fail_mapM_wp, wp get_sc_time_no_fail) - apply (wpsimp wp: get_sc_time_wp) - apply (wpsimp wp: mapM_get_sc_time_wp get_tcb_ready_time_wp get_sc_time_wp)+ - - apply (frule (2) sorted_release_q'_imp) - apply (clarsimp simp: valid_release_q_active_sc sorted_release_q'_def not_in_release_q_def) - by (fastforce dest: map_Some_implies_map_the - elim!: rsubst[where P=sorted] - simp: hd_map last_map read_tcb_ready_time_tcb_ready_times_of - no_ofailD[OF read_tcb_ready_time_no_ofail]) - lemma gets_the_readReadyTime_corres: - "sc_ptr = scPtr \ - corres (=) - (pspace_aligned and pspace_distinct and valid_objs and is_active_sc scPtr and sc_at sc_ptr - and active_scs_valid) - valid_objs' - (gets_the (read_ready_time sc_ptr)) (gets_the (readReadyTime scPtr))" - apply (clarsimp simp: read_ready_time_def readReadyTime_def - simp flip: get_refill_head_def getRefillHead_def) - apply (corres corres: getRefillHead_corres) - apply (clarsimp simp: refill_map_def) - apply wpsimp+ + "rcorres + (\s s'. pspace_aligned s \ pspace_distinct s \ valid_objs s \ is_active_sc scPtr s + \ sc_at sc_ptr s \ active_scs_valid s \ valid_objs' s' \ scs_relation s s' + \ sc_ptr = scPtr) + (gets_the (read_ready_time sc_ptr)) (gets_the (readReadyTime scPtr)) + (\rv rv' _ _. rv = rv')" + apply (rule_tac F="sc_ptr = scPtr" in rcorres_req, simp) + apply (rule_tac Q="\s s'. sc_refills_sc_at (\refills. refills \ []) scPtr s" + in rcorres_add_to_pre) apply (fastforce intro: valid_refills_nonempty_refills elim: active_scs_validE) - apply fastforce - done - -lemma getTCBReadyTime_corres: - "tcb_ptr = tcbPtr \ - corres (=) - (pspace_aligned and pspace_distinct and valid_objs and active_sc_tcb_at tcbPtr - and active_scs_valid) - valid_objs' - (get_tcb_ready_time tcb_ptr) (getTCBReadyTime tcbPtr)" - apply (clarsimp simp: get_tcb_ready_time_def getTCBReadyTime_def - read_tcb_ready_time_def readTCBReadyTime_def - gets_the_thread_read gets_the_ohaskell_assert - simp flip: threadGet_def scActive_def) - apply (rule_tac r'="(=)" in corres_split_forwards'[OF _ thread_get_sp threadGet_sp]) - apply (rule corres_guard_imp) - apply (rule threadGet_corres) + apply (clarsimp simp: read_ready_time_def readReadyTime_def) + apply (rule rcorres_split_gets_the_fwd) + apply (simp flip: get_refill_head_def getRefillHead_def) + apply (rcorres rcorres: getRefillHead_rcorres) + apply clarsimp + apply wpsimp + apply (fastforce intro: rcorres_return simp: refill_map_def) + done + +lemma active_sc_tcb_at_cross': + "\active_sc_tcb_at tcbPtr s; tcbs_relation s s'; scs_relation s s'; + pspace_aligned s; pspace_distinct s; valid_objs s\ + \ active_sc_tcb_at' tcbPtr s'" + apply (clarsimp simp: vs_all_heap_simps) + apply (rename_tac sc_ptr tcb sc n) + apply (frule (1) tcbs_relation_tcb_relation_abs) + apply (frule (1) scs_relation_sc_relation_abs) + apply (clarsimp simp: active_sc_tcb_at'_def tcb_relation_def sc_relation_def active_sc_def + in_omonad) + apply metis + done + +lemma readTCBReadyTime_rcorres: + "rcorres + (\s s'. pspace_aligned s \ pspace_distinct s \ valid_objs s \ active_scs_valid s + \ active_sc_tcb_at tcbPtr s \ valid_objs' s' + \ tcbs_relation s s' \ scs_relation s s') + (gets_the (read_tcb_ready_time tcbPtr)) (gets_the (readTCBReadyTime tcbPtr)) + (\rv rv' _ _. rv = rv')" + apply (clarsimp simp: read_tcb_ready_time_def readTCBReadyTime_def + simp flip: scActive_def) + apply (rule rcorres_split_gets_the_fwd[where rrel="(=)"]) + apply (rcorres rcorres: threadGet_rcorres) apply (clarsimp simp: tcb_relation_def) apply (clarsimp simp: vs_all_heap_simps obj_at_def is_tcb_def) - apply fastforce - apply (rule corres_symb_exec_l[rotated, OF _ assert_sp]) - apply wpsimp - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps) apply wpsimp - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps) - apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp]) - apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ scActive_sp]) - apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp]) - apply (corres corres: gets_the_readReadyTime_corres) - apply (fastforce intro: valid_sched_context_size_objsI - simp: vs_all_heap_simps obj_at_kh_kheap_simps is_sc_obj_def) - apply fastforce - apply wpsimp - apply wpsimp - apply (clarsimp simp: ex_abs_def vs_all_heap_simps) - apply (frule_tac sc_ptr=ref' in active_sc_at'_cross) - apply fastforce - apply fastforce - apply (clarsimp simp: vs_all_heap_simps) - apply (fastforce intro: valid_objs_valid_sched_context_size simp: obj_at_def is_sc_obj_def) - apply (fastforce dest: pspace_relation_absD[OF _ state_relation_pspace_relation] - simp: tcb_relation_cut_def tcb_relation_def active_sc_at'_def obj_at'_def) - apply wpsimp - apply wpsimp - apply (clarsimp simp: ex_abs_def vs_all_heap_simps) - apply (frule state_relation_pspace_relation) - apply (frule_tac ptr=ref' in sc_at_cross) - apply fastforce - apply fastforce - apply (fastforce intro: valid_objs_valid_sched_context_size simp: obj_at_def is_sc_obj_def) - apply (fastforce dest: pspace_relation_absD[OF _ state_relation_pspace_relation] - simp: tcb_relation_cut_def tcb_relation_def obj_at'_def) - apply wpsimp - apply wpsimp - apply (clarsimp simp: ex_abs_def vs_all_heap_simps) - done - -lemma getTCBReadyTime_wp[wp]: - "\\s. \rt. readTCBReadyTime t s = Some rt \ P rt s\ getTCBReadyTime t \P\" - by (wpsimp simp: getTCBReadyTime_def) - -lemma timeAfter_corres: - "\new_time = newTime; - if ls = [] then tcbPtrOpt = None else tcbPtrOpt \ None \ hd ls = the tcbPtrOpt\ \ - corres (=) - (pspace_aligned and pspace_distinct and valid_objs and active_scs_valid - and (\s. ls \ [] \ active_sc_tcb_at (hd ls) s)) - valid_objs' - (gets_the (time_after ls new_time)) (gets_the (timeAfter tcbPtrOpt newTime))" - apply (clarsimp simp: time_after_def timeAfter_def gets_the_ohaskell_assert - simp flip: get_tcb_ready_time_def getTCBReadyTime_def threadGet_def scActive_def) - apply (corres corres: getTCBReadyTime_corres) - done - -lemma time_after_no_ofail: - "no_ofail (pspace_aligned and pspace_distinct and valid_objs and active_scs_valid - and (\s. ls \ [] \ active_sc_tcb_at (hd ls) s)) - (time_after ls new_time)" - supply if_split[split del] - unfolding time_after_def - apply (wpsimp wp: read_tcb_ready_time_no_ofail) - apply (clarsimp split: if_splits) - done - -lemma time_after_True_nonempty: - "the (time_after ls new_time s) \ ls \ []" - by (clarsimp simp: time_after_def split: if_splits) + apply (clarsimp simp: vs_all_heap_simps obj_at_def is_tcb_def) + apply (rule rcorres_assert_l_fwd) + apply (clarsimp simp: vs_all_heap_simps obj_at_def thread_read_def oliftM_def get_tcb_def) + apply (clarsimp simp: gets_the_ohaskell_assert) + apply (rule rcorres_assert_r_fwd) + apply (rule rcorres_symb_exec_r[OF scActive_sp]) + apply (rule rcorres_assert_r_fwd) + apply (rcorres rcorres: gets_the_readReadyTime_corres) + apply (fastforce dest: thread_read_SomeD + simp: vs_all_heap_simps obj_at_def is_sc_obj_def + intro: valid_objs_valid_sched_context_size) + done + +lemma no_ofail_readReadyTime[wp]: + "no_ofail (valid_objs' and active_sc_at' scPtr) (readReadyTime scPtr)" + unfolding readReadyTime_def + by wpsimp -lemma findTimeAfter_corres: - "new_time = newTime \ - corres (\ls ptrOpt. if ls = [] then ptrOpt = None else ptrOpt \ None \ hd ls = the ptrOpt) - (pspace_aligned and pspace_distinct and valid_objs - and active_scs_valid and valid_release_q - and (\s. \tcb_ptr \ set ls. active_sc_tcb_at tcb_ptr s) - and K (ls \ [] \ tcbPtrOpt \ None \ hd ls = the tcbPtrOpt \ distinct ls)) - (valid_objs' and (\s. heap_ls (tcbSchedNexts_of s) (tcbQueueHead q) ls)) - (find_time_after ls new_time) (findTimeAfter tcbPtrOpt newTime)" - (is "_ \ corres _ ?abs ?conc _ _") - apply (rule_tac Q'="pspace_distinct'" in corres_cross_add_guard) - apply (fastforce dest!: pspace_distinct_cross) - apply (rule_tac Q'="pspace_aligned'" in corres_cross_add_guard) - apply (fastforce dest!: pspace_aligned_cross) - apply (rule_tac Q'="pspace_bounded'" in corres_cross_add_guard) - apply (fastforce dest!: pspace_relation_pspace_bounded'[OF state_relation_pspace_relation]) - apply (rule corres_gen_asm') - apply (clarsimp simp: find_time_after_def findTimeAfter_def runReaderT_def) - apply (rule corres_stateAssert_implied[where P=P and P'=P for P, simplified, rotated]) - apply (fastforce simp: tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt_def - dest!: release_queue_active_sc_tcb_at_cross) - apply (rule stronger_corres_guard_imp) - apply (rule_tac P="\r s. ?abs s \ suffix r ls" - and P'="\_ _. ?conc" - in corres_whileLoop_abs_ret) - apply clarsimp - apply (rule_tac f="time_after r newTime" - and f'="timeAfter r' newTime" - in gets_the_corres_relation) - apply (rule time_after_no_ofail) - apply (rule timeAfter_corres) - apply fastforce - apply fastforce - apply (fastforce simp: suffix_def) - apply fastforce - apply fastforce - defer \ \defer the main corres goal\ - apply (clarsimp simp: list_queue_relation_def) - apply wpsimp - apply (fastforce dest: suffix_tl) - apply wpsimp - apply (rule whileLoop_terminates_inv[OF _ _ list_length_wf_helper, where I="\\", simplified]) - apply wpsimp - apply fastforce +lemma no_ofail_readTCBReadyTime: + "no_ofail + (\s'. \s. pspace_aligned s \ pspace_distinct s \ valid_objs s \ active_scs_valid s + \ active_sc_tcb_at tcbPtr s \ valid_objs' s' + \ heap_pspace_relation s s') + (readTCBReadyTime tcbPtr)" + unfolding readTCBReadyTime_def + apply (wpsimp wp: ovalid_threadRead) + apply (rename_tac s' s) + apply (frule pspace_aligned_cross) + apply (simp flip: pspace_relation_heap_pspace_relation) + apply (frule pspace_distinct_cross) apply fastforce + apply (simp flip: pspace_relation_heap_pspace_relation) + apply (prop_tac "pspace_bounded' s'") + apply (rule pspace_relation_pspace_bounded') + apply (simp flip: pspace_relation_heap_pspace_relation) + apply (frule active_sc_tcb_at_tcb_at) + apply (intro context_conjI impI allI) + apply (fastforce intro!: tcb_at_cross_tcbs_relation) + apply normalise_obj_at' + apply (frule active_sc_tcb_at_tcb_at) + apply (clarsimp simp: obj_at_def is_tcb_def) + apply (rename_tac ko') + apply (case_tac ko'; clarsimp) + apply (frule tcbs_relation_tcb_relation_abs) apply fastforce - apply (rule corres_symb_exec_l[rotated, OF _ assert_sp]) - apply wpsimp - apply (fastforce dest: time_after_True_nonempty) - apply wpsimp - apply (fastforce dest: time_after_True_nonempty) - apply (rule corres_symb_exec_r_conj_ex_abs_forwards[rotated, OF get_tcb_sp']) - apply wpsimp - apply wpsimp - apply (clarsimp simp: ex_abs_def) - apply (frule_tac xs=r in hd_in_set) - subgoal - by (force intro!: tcb_at_cross - simp: vs_all_heap_simps obj_at_def obj_at_kh_kheap_simps is_tcb_def suffix_def) - apply clarsimp - apply (rename_tac sfx tcb s s') - apply (rule conjI) - apply (clarsimp simp: tl_Nil) - apply (rename_tac x) - apply (prop_tac "x = last ls") - apply (clarsimp simp: suffix_def) - apply (fastforce dest: heap_ls_last_None simp: opt_map_def obj_at'_def) - apply (intro conjI impI allI) - apply (drule_tac p="hd sfx" in not_last_next_not_None) - apply (clarsimp simp: suffix_def) - apply (metis distinct_hd_not_in_tl distinct_suffix last_append last_in_set last_tl suffix_def) - apply (clarsimp simp: opt_map_def obj_at'_def) - apply (clarsimp simp: suffix_def) - apply (case_tac sfx; clarsimp) - apply (rename_tac a list) - apply (cut_tac xs=zs and z=a and ys=list and y=None in heap_path_non_nil_lookup_next) - apply fastforce - apply (clarsimp simp: obj_at'_def opt_map_def split: list.splits) + apply (clarsimp simp: heap_pspace_relation_def) + apply (frule (5) active_sc_tcb_at_cross') + apply (intro context_conjI impI allI) + apply (clarsimp simp: active_sc_tcb_at'_def obj_at'_def opt_pred_def opt_map_def + split: option.splits) + apply (fastforce intro!: sc_at_cross_scs_relation valid_objs_valid_sched_context_size + simp: vs_all_heap_simps obj_at_kh_kheap_simps tcb_relation_def + is_sc_obj_def obj_at'_def) + apply (fastforce simp: active_sc_tcb_at'_def obj_at'_def opt_pred_def opt_map_def) + apply (fastforce simp: active_sc_at'_def obj_at'_def opt_pred_def opt_map_def) done -lemma getTCBReadyTime_sp: - "\P\ getTCBReadyTime t \\rv s. P s \ readTCBReadyTime t s = Some rv\" - by wpsimp +crunch setReprogramTimer + for (no_fail) no_fail[wp] -crunch findTimeAfter - for inv[wp]: P +lemma set_gets_release_queue_simp: + "do _ \ set_release_queue q; f q od = do set_release_queue q; q' \ gets release_queue; f q' od" + by (simp add: simpler_gets_def bind_def modify_def get_def put_def) + +crunch orderedInsert + for tcbQueued[wp]: "\s. P (tcbQueued |< tcbs_of' s)" (wp: crunch_wps) -defs findTimeAfter_asrt_def: - "findTimeAfter_asrt \ \afterPtr s. obj_at' (\tcb. tcbInReleaseQueue tcb) afterPtr s" +lemma valid_release_queue_sorted_wrt': + "valid_release_q s \ sorted_wrt (img_ord (\t. read_tcb_ready_time t s) opt_ord) (release_queue s)" + by (simp add: valid_release_q_def sorted_release_q_def + tcb_ready_times_of_tcb_refill_ready_times_of + read_tcb_ready_time_read_tcb_ready_times_of) -crunch setReprogramTimer - for (no_fail) no_fail[wp] +lemma det_wp_ready_times_append: + "det_wp (\s. qs = release_queue s \ active_scs_valid s \ valid_release_q s \ active_sc_tcb_at t s) + (ready_times_append t qs)" + unfolding ready_times_append_def + apply wpsimp + by (fastforce intro: valid_release_q_active_sc no_ofailD[OF read_tcb_ready_time_no_ofail]) + +lemmas no_fail_ready_times_append = det_wp_no_fail[OF det_wp_ready_times_append] + +lemma det_wp_ready_times_append_set_release_queue: + "det_wp (\s. ls = release_queue s \ active_scs_valid s \ valid_release_q s \ active_sc_tcb_at t s) + (ready_times_append t ls >>= set_release_queue)" + by (wpsimp wp: det_wp_ready_times_append) + +lemmas no_fail_ready_times_append_set_release_queue = + det_wp_no_fail[OF det_wp_ready_times_append_set_release_queue] + +lemma ready_times_append_set_release_queue_empty_fail: + "empty_fail (ready_times_append t ls >>= set_release_queue)" + by wpsimp + +lemmas ready_times_append_rules = + no_fail_ready_times_append det_wp_ready_times_append no_fail_ready_times_append_set_release_queue + det_wp_ready_times_append_set_release_queue ready_times_append_set_release_queue_empty_fail + ready_times_append_empty_fail + +method rlq_append = + (rule det_wp_pre no_fail_pre, rule ready_times_append_rules, fastforce)[1] | wpsimp + +lemma orderedInsert_readTCBReadyTime_rcorres: + "rcorres + (\s s'. valid_release_q s \ ts = release_queue s + \ release_queue_relation s s' \ q = ksReleaseQueue s' + \ heap_pspace_relation s s' \ sym_heap_sched_pointers s' + \ pspace_aligned s \ pspace_distinct s + \ \ is_sched_linked t s' \ not_in_release_q t s \ active_sc_tcb_at t s + \ active_scs_valid s \ valid_objs s \ valid_objs' s') + (ready_times_append t ts) (orderedInsert t q readTCBReadyTime (\)) + (\ts' q' s s'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (rcorres rcorres: orderedInsert_rcorres readTCBReadyTime_rcorres + wp: read_tcb_ready_time_no_ofail no_ofail_readTCBReadyTime + simp: ready_times_append_def) + apply clarsimp + apply (frule pspace_aligned_cross) + apply (simp flip: pspace_relation_heap_pspace_relation) + apply (frule (1) pspace_distinct_cross) + apply (simp flip: pspace_relation_heap_pspace_relation) + apply (frule valid_release_queue_sorted_wrt') + apply (clarsimp simp: valid_release_q_def) + apply (fastforce intro!: tcb_at_cross_tcbs_relation active_sc_tcb_at_tcb_at + simp: heap_pspace_relation_def release_queue_relation_def not_in_release_q_def) + done + +lemma orderedInsert_readTCBReadyTime_rcorres_other: + "rcorres + (\s s'. valid_release_q s \ ts' = release_queue s \ q' = ksReleaseQueue s' + \ release_queue_relation s s' + \ list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ heap_pspace_relation s s' \ sym_heap_sched_pointers s' + \ pspace_aligned s \ pspace_distinct s + \ t' \ set ts \ set ts \ set (release_queue s) = {} + \ active_sc_tcb_at t' s \ active_scs_valid s \ valid_objs s \ valid_objs' s') + (ready_times_append t' ts') (orderedInsert t' q' readTCBReadyTime (\)) + (\_ _ s s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (clarsimp simp: ready_times_append_def) + apply (rcorres rcorres: orderedInsert_rcorres_other readTCBReadyTime_rcorres + wp: read_tcb_ready_time_no_ofail no_ofail_readTCBReadyTime) + apply (clarsimp simp: valid_release_q_def) + apply (frule pspace_aligned_cross) + apply (simp flip: pspace_relation_heap_pspace_relation) + apply (frule (1) pspace_distinct_cross) + apply (simp flip: pspace_relation_heap_pspace_relation) + by (fastforce intro!: tcb_at_cross_tcbs_relation active_sc_tcb_at_tcb_at + simp: heap_pspace_relation_def release_queue_relation_def) lemma tcbReleaseEnqueue_corres: "corres dc (valid_objs and pspace_aligned and pspace_distinct and valid_release_q and active_scs_valid and active_sc_tcb_at t and not_in_release_q t and not_queued t - and ready_or_release and (\s. pred_map runnable (tcb_sts_of s) t)) + and ready_or_release and st_tcb_at runnable t and ep_queues_blocked and ntfn_queues_blocked) (valid_objs' and sym_heap_sched_pointers and valid_sched_pointers) (tcb_release_enqueue t) (tcbReleaseEnqueue t)" supply if_split[split del] heap_path_append[simp del] heap_path.simps[simp del] + ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + heap_ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) apply (rule_tac Q'="tcb_at' t" in corres_cross_add_guard) - apply (fastforce intro!: tcb_at_cross simp: vs_all_heap_simps obj_at_def is_tcb_def) - apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) - apply (fastforce intro: monadic_rewrite_guard_imp[OF tcb_release_enqueue_monadic_rewrite]) - apply (clarsimp simp: tcb_release_enqueue'_def tcbReleaseEnqueue_def) + apply (fastforce intro!: tcb_at_cross) + apply (rule_tac Q'="\s'. \ (tcbInReleaseQueue |< tcbs_of' s') t" in corres_cross_add_guard) + apply (frule state_relation_release_queue_relation) + apply (frule in_release_q_tcbInReleaseQueue_eq[where t=t]) + apply (clarsimp simp: in_release_q_def) + apply (clarsimp simp: tcb_release_enqueue_def tcbReleaseEnqueue_def) + apply (rule corres_stateAssert_ignore) + apply (fastforce dest!: release_queue_active_sc_tcb_at_cross) apply (rule corres_stateAssert_add_assertion[rotated]) apply (fastforce intro: ready_or_release_cross) apply (rule corres_stateAssert_add_assertion[rotated]) apply (fastforce dest!: state_relation_ready_queues_relation in_ready_q_tcbQueued_eq simp: vs_all_heap_simps opt_map_def obj_at'_def) - apply (rule corres_stateAssert_ignore) - apply (fastforce intro: ksReadyQueues_asrt_cross) - apply (rule corres_stateAssert_ignore) - apply (fastforce intro: ksReleaseQueue_asrt_cross) + apply (rule corres_stateAssert_ignore, fastforce intro: ksReadyQueues_asrt_cross) + apply (rule corres_stateAssert_ignore, fastforce intro: ksReleaseQueue_asrt_cross) apply (rule corres_stateAssert_ignore, simp) apply (rule corres_symb_exec_r[rotated, OF isRunnable_sp]; wpsimp?) apply (rule corres_symb_exec_r_conj_ex_abs_forwards[rotated, OF assert_sp]; wpsimp) - apply (fastforce dest: st_tcb_at_runnable_cross - simp: ex_abs_def st_tcb_at'_def runnable_eq_active' obj_at'_def - simp flip: tcb_at_kh_simps) + apply (fastforce dest: st_tcb_at_runnable_cross simp: ex_abs_def) apply (rule corres_symb_exec_r[rotated, OF get_tcb_sp']; wpsimp?) apply (rule corres_symb_exec_r_conj_ex_abs_forwards[rotated, OF assert_sp]; wpsimp?) apply (fastforce dest: state_relation_release_queue_relation simp: ex_abs_def release_queue_relation_def opt_pred_def opt_map_def obj_at'_def not_in_release_q_def) - apply (rule corres_split_forwards'[OF _ get_tcb_ready_time_sp getTCBReadyTime_sp]) - apply (corres corres: getTCBReadyTime_corres) - apply (clarsimp, rename_tac new_time) apply (rule corres_split_forwards'[OF _ gets_sp getReleaseQueue_sp]) apply (corres corres: getReleaseQueue_corres) - apply clarsimp - - apply (clarsimp simp: ifM_to_top_of_bind) - apply (rule_tac R="A and (\s. tcbQueueHead queue \ None \ tcbQueueEnd queue \ None - \ (\head_time. read_tcb_ready_time (hd rlq) s = Some head_time - \ head_time \ new_time))" - and Q=A and A=A for A - in ifM_corres'[where Q'=A' and A'=A' and R'=A' for A', rotated 3]) - apply (wpsimp wp: get_tcb_ready_time_wp) - apply (wpsimp wp: get_tcb_ready_time_wp) - apply (fastforce simp: queue_end_valid_def) - apply wpsimp - apply wpsimp - apply (rule_tac R="A and K (\ tcbQueueEmpty queue)" and A=A for A - in orM_corres'[where R'=A' and A'=A' for A', simplified]) - apply corres - apply (rule corres_gen_asm') - apply (corres corres: getTCBReadyTime_corres) - apply (fastforce simp: valid_release_q_def) - apply fastforce - apply wpsimp + apply (rename_tac ls q) + apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) + apply (rule monadic_rewrite_bind_tail) + apply (rule monadic_rewrite_from_simple[where P=True, simplified]) + apply (rule set_gets_release_queue_simp) + apply wpsimp + \ \split off the reprogramming of the timer\ + apply (subst bind_assoc[symmetric]) + apply (subst bind_assoc_group3) + apply (rule corres_split_forwards'[where Q="\_ s. release_queue s \ []" and r'=dc, rotated]; + (solves wpsimp)?) + apply (clarsimp simp: ready_times_append_def) apply wpsimp - - \ \deal with the reprogramming of the timer\ - apply (simp add: bind_assoc) - apply (rule monadic_rewrite_corres_r[where P'=P' and Q=P' for P', simplified]) - apply (repeat_unless \rule monadic_rewrite_setReprogramTimer_threadSet\ - \rule monadic_rewrite_bind_tail\) - apply wpsimp+ - apply (simp flip: bind_assoc) - apply (rule corres_split_forwards'[where Q="\\" and Q'="\\" and r'=dc, rotated]; - (solves wpsimp)?) + apply clarsimp + apply (rule corres_split_forwards'[OF _ gets_sp getReleaseQueue_sp]) + apply (corres corres: getReleaseQueue_corres) + apply (clarsimp simp: when_def) + apply (rule corres_if_strong') + apply (fastforce simp: tcbQueueEmpty_def) apply (corres corres: setReprogramTimer_corres) - - \ \prepend t\ - apply (simp add: bind_assoc) - apply (rule corres_from_valid_det) - apply (fastforce intro: det_wp_modify det_wp_pre) - apply (wpsimp simp: tcbQueuePrepend_def wp: hoare_vcg_imp_lift' hoare_vcg_if_lift2) - apply (clarsimp simp: ex_abs_def) - apply (frule state_relation_release_queue_relation) - apply (clarsimp simp: release_queue_relation_def list_queue_relation_def) - subgoal - by (fastforce intro!: tcb_at_cross - simp: valid_release_q_def vs_all_heap_simps obj_at_kh_kheap_simps is_tcb_def - tcbQueueEmpty_def) - - apply (clarsimp simp: state_relation_def) - apply (frule singleton_eqD) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \frule set_release_queue_projs_inv, wpsimp simp: swp_def\)?) - - \ \ready_queues_relation\ - apply (drule set_release_queue_new_state) - apply (wpsimp wp: tcbQueuePrepend_list_queue_relation_other threadSet_sched_pointers - hoare_vcg_all_lift threadSet_inQ - simp: ready_queues_relation_def ready_queue_relation_def Let_def - | wps)+ - apply (rule_tac x="release_queue s" in exI) - subgoal - by (auto dest!: ready_or_release_disjoint simp: release_queue_relation_def not_queued_def) - - \ \release_queue_relation\ - apply (drule set_release_queue_new_state) - apply (clarsimp simp: release_queue_relation_def) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply ((wpsimp wp: tcbQueuePrepend_list_queue_relation threadSet_sched_pointers | wps)+)[1] - apply (frule (1) valid_sched_pointersD[where t=t]; - clarsimp simp: not_in_release_q_2_def in_opt_pred opt_map_red obj_at'_def) - apply (rule hoare_allI, rename_tac t') - apply (case_tac "t' = t"; clarsimp) - apply (wpsimp wp: threadSet_wp hoare_vcg_all_lift) - apply (wpsimp wp: threadSet_opt_pred_other) - - apply (simp add: bind_assoc) - apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp, rotated]; wpsimp?) - apply (clarsimp simp: queue_end_valid_def ex_abs_def) - apply (rule corres_split_forwards'[OF _ get_tcb_ready_time_sp getTCBReadyTime_sp]) - apply (corresKsimp corres: getTCBReadyTime_corres) - apply (drule state_relation_release_queue_relation) - apply (clarsimp simp: release_queue_relation_def list_queue_relation_def) - apply (fastforce simp: valid_release_q_def queue_end_valid_def dest!: last_in_set) - - apply (simp add: bind_assoc if_to_top_of_bind) - apply (rule corres_if_strong') + apply fastforce + \ \set the release queue\ + apply (rule corres_underlying_from_rcorres) + apply (wpsimp wp: no_fail_orderedInsert) + apply (rename_tac s' s) + apply (prop_tac "heap_pspace_relation s s'") + apply (simp flip: pspace_relation_heap_pspace_relation) apply fastforce - - \ \append t\ - apply (rule corres_from_valid_det) - apply (fastforce intro: det_wp_modify det_wp_pre) - apply (wpsimp simp: tcbQueueAppend_def wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') - apply (clarsimp simp: ex_abs_def) - apply (frule state_relation_release_queue_relation) - apply (fastforce intro!: tcb_at_cross dest!: last_in_set - simp: release_queue_relation_def list_queue_relation_def valid_release_q_def - vs_all_heap_simps obj_at_kh_kheap_simps is_tcb_def queue_end_valid_def - tcbQueueEmpty_def) - apply (clarsimp simp: state_relation_def) - apply (frule singleton_eqD) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \frule set_release_queue_projs_inv, wpsimp simp: swp_def\)?) - + apply (frule state_relation_release_queue_relation) + apply (clarsimp simp: release_queue_relation_def) + subgoal + by (fastforce intro!: no_ofailD[OF no_ofail_readTCBReadyTime] + tcb_at_cross active_sc_tcb_at_tcb_at + simp: valid_release_q_def) + apply (rule_tac Q="\s s'. (\t\set (release_queue s). active_sc_tcb_at t s) + \ t \ set (release_queue s) + \ list_queue_relation (release_queue s) (ksReleaseQueue s') + (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ (\t\set (release_queue s). tcb_at' t s')" + in rcorres_add_to_pre) + apply (intro context_conjI ballI) + apply (fastforce intro!: valid_release_q_active_sc) + apply (clarsimp simp: not_in_release_q_def) + apply (fastforce dest!: state_relation_release_queue_relation simp: release_queue_relation_def) + apply (force intro!: tcb_at_cross valid_release_q_active_sc dest: active_sc_tcb_at_tcb_at) + apply (clarsimp simp: state_relation_def pspace_relation_heap_pspace_relation + heap_pspace_relation_def ghost_relation_heap_ghost_relation) + apply (rcorres_conj_lift \fastforce\ + rule: ready_times_append_rules + wp: threadSet_field_inv + simp: ready_times_append_def)+ + apply (rule rcorres_conj_lift_fwd; (solves rlq_append)?) + \ \ep_queues_relation\ + apply (rule rcorres_add_return_l) + apply (simp only: ep_queues_relation_def bind_assoc) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation + orderedInsert_readTCBReadyTime_rcorres_other readTCBReadyTime_rcorres + rcorres_op_lifts + wp: det_wp_ready_times_append no_fail_ready_times_append) + apply (clarsimp simp: heap_pspace_relation_def) + apply (intro conjI) + apply (erule (2) runnable_not_in_ep_queue) + apply (frule valid_release_q_release_q_runnable) + apply (blast dest: ep_queues_release_queue_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves rlq_append)?) + \ \ntfn_queues_relation\ + apply (rule rcorres_add_return_l) + apply (simp only: ntfn_queues_relation_def bind_assoc) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation + orderedInsert_readTCBReadyTime_rcorres_other readTCBReadyTime_rcorres + rcorres_op_lifts + wp: det_wp_ready_times_append no_fail_ready_times_append) + apply (clarsimp simp: heap_pspace_relation_def) + apply (intro conjI) + apply (erule (2) runnable_not_in_ntfn_queue) + apply (frule valid_release_q_release_q_runnable) + apply (blast dest: ntfn_queues_release_queue_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves rlq_append)?) \ \ready_queues_relation\ - apply (drule set_release_queue_new_state) - apply (wpsimp wp: tcbQueueAppend_list_queue_relation_other threadSet_sched_pointers - hoare_vcg_all_lift threadSet_inQ - simp: ready_queues_relation_def ready_queue_relation_def Let_def - | wps)+ - apply (rule_tac x="release_queue s" in exI) - subgoal by (auto dest!: ready_or_release_disjoint simp: release_queue_relation_def not_queued_def) - - apply (drule set_release_queue_new_state) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (intro rcorres_allI_fwd; (solves rlq_append)?) + apply (rename_tac d p) + apply (rule rcorres_conj_lift_fwd; (solves rlq_append)?) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rule rcorres_add_return_l) + apply (simp only: bind_assoc) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation + rcorres_setReleaseQueue_list_queue_relation_other + orderedInsert_readTCBReadyTime_rcorres_other readTCBReadyTime_rcorres + wp: det_wp_ready_times_append no_fail_ready_times_append) + apply (clarsimp simp: heap_pspace_relation_def not_queued_def) + apply (blast dest: ready_or_release_disjoint) + apply wpsimp + apply wpsimp + apply (rule rcorres_conj_lift_fwd; (solves rlq_append)?) + apply (intro rcorres_allI_fwd; (solves rlq_append)?) + apply (rename_tac t') + apply (rule_tac p="\s. t' \ set (ready_queues s d p)" in rcorres_lift_abs) + apply (rule rcorres_lift_conc_only_fwd; (solves rlq_append)?) + apply (wpsimp wp: threadSet_inQ) + apply wpsimp + apply (rule rcorres_from_valid_det; rlq_append) + apply (rule rcorres_conj_lift_fwd; (solves rlq_append)?) + \ \release_queue_relation\ apply (clarsimp simp: release_queue_relation_def) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply ((wpsimp wp: tcbQueueAppend_list_queue_relation threadSet_sched_pointers | wps)+)[1] - apply (frule (1) valid_sched_pointersD[where t=t]; - clarsimp simp: not_in_release_q_2_def in_opt_pred opt_map_red obj_at'_def) - apply (rule hoare_allI, rename_tac t') - apply (case_tac "t' = t"; clarsimp) - apply (wpsimp wp: threadSet_wp hoare_vcg_all_lift) + apply (rule rcorres_conj_lift_fwd; (solves rlq_append)?) + apply (rule rcorres_add_return_l) + apply (simp only: bind_assoc) + apply (rcorres rcorres: orderedInsert_readTCBReadyTime_rcorres + rcorres_threadSet_release_queue_list_queue_relation) + apply (elim conjE) + apply (frule (2) valid_sched_pointersD[where t=t]) + apply (fastforce intro!: runnable'_not_inIPCQueueThreadState) + apply (clarsimp simp: heap_pspace_relation_def release_queue_relation_def) + apply (intro rcorres_allI_fwd; (solves rlq_append)?) + apply (rename_tac t') + apply (rule rcorres_from_valid_det; (solves rlq_append)?) + apply (clarsimp simp: ready_times_append_def in_monad) + apply (frule use_valid[OF _ ordered_insert_set], simp) + apply (case_tac "t' = t") + apply (wpsimp wp: threadSet_wp hoare_vcg_all_lift hoare_drop_imps) apply (wpsimp wp: threadSet_opt_pred_other) + by (rcorres_conj_lift \fastforce\ rule: ready_times_append_rules)+ - \ \insert t into the middle of the release queue\ - apply (rule corres_split_forwards' - [where r'="\ls ptrOpt. if ls = [] - then ptrOpt = None - else ptrOpt \ None \ hd ls = the ptrOpt", - where P=P and Q="\ls s. P s \ ls \ release_queue s \ ls \ [] - \ suffix ls (release_queue s)" for P, - where P'=P' and Q'="\_. P'" for P']) - apply (rule stronger_corres_guard_imp) - apply (rule_tac q=queue in findTimeAfter_corres[OF refl]) - subgoal - by (fastforce dest: state_relation_release_queue_relation heap_path_head - simp: release_queue_relation_def valid_release_q_def list_queue_relation_def - queue_end_valid_def) - apply (fastforce dest: state_relation_release_queue_relation - simp: release_queue_relation_def list_queue_relation_def) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \wpsimp simp: find_time_after_def wp: whileLoop_valid_inv\)?) - apply (wpsimp wp: find_time_after_sfx_proper simp: tcbQueueEmpty_def) - apply (wpsimp wp: find_time_after_sfx_nonempty simp: tcbQueueEmpty_def) - apply (wpsimp wp: find_time_after_sfx_sfx) - apply wpsimp - apply (rule corres_from_valid_det) - apply (fastforce intro: det_wp_modify det_wp_pre) - apply (wpsimp simp: tcbQueueInsert_def wp: getTCB_wp no_fail_stateAssert) - apply (clarsimp simp: ex_abs_def) - apply (rename_tac s head_time) - apply (frule state_relation_release_queue_relation) - apply (clarsimp simp: release_queue_relation_def list_queue_relation_def) - apply (prop_tac "hd sfx \ set (release_queue s)") - apply (fastforce dest: hd_in_set simp: suffix_def) - apply (prop_tac "tcb_at (hd sfx) s") - apply (fastforce simp: valid_release_q_def vs_all_heap_simps obj_at_def is_tcb_def) - apply (frule state_relation_pspace_relation) - apply (drule_tac t="hd sfx" in tcb_at_cross) - apply fastforce - apply fastforce - apply fastforce - apply (rule context_conjI) - apply (clarsimp simp: findTimeAfter_asrt_def opt_pred_def opt_map_def obj_at'_def - split: option.splits) - apply clarsimp - apply (rename_tac after_tcb) - apply (frule_tac sfx=sfx in nonempty_proper_suffix_split_distinct) - apply fastforce - apply fastforce - apply fastforce - apply clarsimp - apply (frule (2) heap_path_sym_heap_non_nil_lookup_prev) - apply (intro context_conjI impI) - apply (clarsimp simp: opt_map_def obj_at'_def) - apply (fastforce dest!: heap_ls_prev_no_loops simp: opt_map_def obj_at'_def) - apply (drule state_relation_pspace_relation) - apply (erule (2) tcb_at_cross) - apply (clarsimp simp: valid_release_q_def) - apply (drule_tac x="the (tcbSchedPrev after_tcb)" in bspec) - apply (clarsimp simp: opt_map_def obj_at'_def) - apply (force simp: opt_map_def vs_all_heap_simps obj_at_kh_kheap_simps is_tcb_def) - - apply (clarsimp simp: state_relation_def) - apply (frule singleton_eqD) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \frule set_release_queue_projs_inv, wpsimp simp: swp_def\)?) - - \ \ready_queues_relation\ - apply (drule set_release_queue_new_state) - apply (wpsimp wp: tcbQueueInsert_list_queue_relation_other threadSet_sched_pointers - hoare_vcg_all_lift threadSet_inQ - simp: ready_queues_relation_def ready_queue_relation_def Let_def - | wps)+ - apply (rename_tac s' tcb' d p) - apply (intro conjI) - apply (clarsimp simp: not_queued_def) - apply (rule_tac x="release_queue s" in exI) - apply (intro conjI) - apply (rule_tac x="ksReleaseQueue s'" in exI) - subgoal by (auto simp: release_queue_relation_def) - subgoal by (force dest!: set_mono_suffix hd_in_set) - subgoal by (auto dest!: ready_or_release_disjoint) - - \ \release_queue_relation\ - apply (drule set_release_queue_new_state) - apply (clarsimp simp: release_queue_relation_def) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: suffix_def) - apply (subst list_insert_before_distinct) - apply (clarsimp simp: valid_release_q_def) - apply fastforce - apply ((wpsimp wp: tcbQueueInsert_list_queue_relation threadSet_sched_pointers | wps)+)[1] - apply (frule (1) valid_sched_pointersD[where t=t]; - clarsimp simp: not_in_release_q_2_def in_opt_pred opt_map_red obj_at'_def) - apply (clarsimp simp: not_in_release_q_def) - apply (frule_tac before="hd sfx" in set_list_insert_before[where new=t]) - apply (force dest!: set_mono_suffix hd_in_set) - apply (rule hoare_allI, rename_tac t') - apply (case_tac "t' = t") - apply (wpsimp wp: threadSet_wp hoare_vcg_all_lift hoare_drop_imps) - apply (wpsimp wp: threadSet_opt_pred_other) - done +lemma tcbSchedDequeue_not_sched_linked: + "tcbSchedDequeue t \\s. \ is_sched_linked t s\" + unfolding tcbSchedDequeue_def + by (wpsimp wp: threadGet_wp threadSet_field_inv tcbQueueRemove_not_sched_linked[simplified]) lemma postpone_corres: "corres dc (\s. valid_objs s \ pspace_aligned s \ pspace_distinct s \ sym_refs (state_refs_of s) \ valid_release_q s \ in_correct_ready_q s \ ready_qs_distinct s \ ready_or_release s - \ active_scs_valid s \ is_active_sc ptr s + \ active_scs_valid s \ is_active_sc ptr s \ ready_queues_runnable s \ sc_tcb_sc_at (\sc. \t. sc = Some t \ not_queued t s \ not_in_release_q t s \ pred_map runnable (tcb_sts_of s) t) ptr s) (pspace_aligned' and pspace_distinct' and pspace_bounded' @@ -3867,45 +3860,28 @@ lemma postpone_corres: (SchedContext_A.postpone ptr) (postpone ptr)" apply (clarsimp simp: SchedContext_A.postpone_def postpone_def get_sc_obj_ref_def) apply (rule corres_stateAssert_ignore, simp) + apply (rule_tac Q="sc_at ptr" in corres_cross_add_abs_guard) + apply (fastforce intro: valid_objs_valid_sched_context_size + simp: vs_all_heap_simps obj_at_def is_obj_defs) + apply (rule corres_split_forwards'[OF _ get_sched_context_sp get_sc_sp']) + apply (corres corres: get_sc_corres) + apply (rule corres_assert_opt_assume_lhs[rotated]) + apply (clarsimp simp: obj_at_def sc_at_ppred_def) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (clarsimp simp: sc_relation_def) + apply (clarsimp simp: sc_relation_def) apply (rule stronger_corres_guard_imp) - apply (rule_tac r'="\sc sca. \n. sc_relation sc n sca" in corres_split) - apply (rule get_sc_corres) - apply (rule corres_assert_opt_assume_l) - apply (rule corres_assert_assume_r) - apply (rule corres_split) - apply (clarsimp simp: sc_relation_def) - apply (rule_tac P="tcb_at (the (sc_tcb rv)) - and in_correct_ready_q and ready_qs_distinct and ready_or_release - and pspace_aligned and pspace_distinct" - in corres_guard1_imp) - apply (rule tcbSchedDequeue_corres, simp) - apply clarsimp - apply (rule corres_split) - apply (clarsimp simp: sc_relation_def) - apply (rule tcbReleaseEnqueue_corres) - apply (rule setReprogramTimer_corres) - apply wp - apply wp - apply (prop_tac "scTCB rv' = sc_tcb rv") - apply (clarsimp simp: sc_relation_def) - apply (wpsimp wp: tcb_sched_dequeue_not_queued_inv)+ - apply (clarsimp simp: vs_all_heap_simps valid_obj_def obj_at_def is_obj_defs sc_at_ppred_def) - apply (drule_tac p=ptr in sym_refs_ko_atD[rotated]) - apply (simp add: obj_at_def) - apply (intro conjI) - apply (fastforce simp: valid_obj_def) - apply clarsimp - apply (force simp: valid_obj_def obj_at_def refs_of_rev) - apply clarsimp - apply (rule conjI) - apply (fastforce intro!: sc_at_cross - simp: sc_tcb_sc_at_def obj_at_def is_sc_obj_def valid_obj_def) - apply (clarsimp simp: sc_at_pred_n_def obj_at_def) - apply (drule state_relation_pspace_relation) - apply (frule (1) pspace_relation_absD) - apply (drule_tac x="(ptr, sc_relation_cut)" in bspec) - apply (fastforce dest: valid_objs_valid_sched_context_size) - apply (clarsimp simp: sc_relation_def obj_at'_def) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF tcbReleaseEnqueue_corres]) + apply (rule setReprogramTimer_corres) + apply wpsimp + apply wpsimp + apply (wpsimp wp: tcb_sched_dequeue_not_queued_inv) + apply (wpsimp wp: tcbSchedDequeue_not_sched_linked) + apply (force dest!: sym_ref_sc_tcb + simp: vs_all_heap_simps valid_obj_def obj_at_def is_obj_defs sc_at_ppred_def + obj_at_kh_kheap_simps) + apply fastforce done lemma schedContextResume_corres: @@ -3916,125 +3892,69 @@ lemma schedContextResume_corres: (pspace_aligned' and pspace_distinct' and pspace_bounded' and valid_objs' and sym_heap_sched_pointers and valid_sched_pointers) (sched_context_resume ptr) (schedContextResume ptr)" - apply (simp only: sched_context_resume_def schedContextResume_def) + apply (rule_tac Q="sc_at ptr" in corres_cross_add_abs_guard) + apply (fastforce intro: sc_at_pred_n_sc_at) + apply (clarsimp simp: sched_context_resume_def schedContextResume_def) apply (rule corres_stateAssert_ignore, simp) - apply (rule stronger_corres_guard_imp) - apply clarsimp - apply (rule_tac r'="\sc sca. \n. sc_relation sc n sca" in corres_split) - apply (rule get_sc_corres) - apply (rename_tac sc sca) - apply (rule corres_assert_opt_assume_l) - apply (rule corres_assert_assume_r) - apply (rule corres_split_eqr) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_guard_imp) - apply (rule getSchedulable_corres) - apply (prop_tac "(valid_objs and tcb_at (the (sc_tcb sc)) - and pspace_aligned and pspace_distinct) s") - apply assumption - apply clarsimp - apply assumption - apply (rule corres_when) - apply clarsimp - apply (rule corres_symb_exec_l) - apply (rule_tac F="runnable ts \ sc_active sc" in corres_gen_asm) - apply (rule corres_split_eqr) - apply (rule refillReady_corres, simp) - apply (rule corres_split_eqr) - apply (rule getRefillSufficient_corres, simp) - apply (rule corres_when) - apply clarsimp - apply (rule corres_symb_exec_l) - apply (rule corres_symb_exec_l) - apply (rule corres_symb_exec_l) - apply (rule corres_assert_assume_l) - apply (rule postpone_corres) - apply (wpsimp simp: get_tcb_queue_def) - apply wp - apply (clarsimp simp: no_fail_def get_tcb_queue_def gets_def get_def) - prefer 2 - apply (wp thread_get_wp) - apply (wp thread_get_exs_valid) - apply (clarsimp simp: obj_at_def is_tcb_def) - apply clarsimp - apply (clarsimp simp: no_fail_def obj_at_def thread_get_def - gets_the_def get_tcb_def gets_def get_def - assert_opt_def bind_def return_def) - prefer 2 - apply (wp thread_get_wp) - apply (wp thread_get_exs_valid) - apply (clarsimp simp: obj_at_def is_tcb_def) - apply clarsimp - apply (clarsimp simp: no_fail_def obj_at_def thread_get_def - gets_the_def get_tcb_def gets_def get_def - assert_opt_def bind_def return_def) - apply wp - apply (wpsimp simp: refillSufficient_def getRefills_def) - apply wp - apply (wpsimp simp: refillReady_def getCurTime_def) - apply (rule thread_get_exs_valid) - apply (erule conjunct1) - apply (wp thread_get_wp) - apply (clarsimp cong: conj_cong) - apply assumption - apply clarsimp - apply (rule no_fail_pre) - apply (wpsimp simp: thread_get_def) - apply (clarsimp simp: tcb_at_def) - apply wp - apply (wp getSchedulable_wp) - apply wp - apply wp - apply (subgoal_tac "sc_tcb_sc_at (\t. bound_sc_tcb_at (\sc. sc = Some ptr) (the t) s) ptr s ") - apply (clarsimp simp: sc_at_ppred_def obj_at_def is_sc_obj_def bound_sc_tcb_at_def is_tcb_def - cong: conj_cong) - - apply (intro conjI; (clarsimp simp: invs_def valid_state_def; fail)?) - apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_obj_def) - apply (clarsimp simp: schedulable_def2 get_tcb_def obj_at_kh_kheap_simps) - apply (rename_tac t; prop_tac "budget_sufficient t s") - apply (erule active_valid_budget_sufficient) - apply (clarsimp simp: schedulable_def2) - apply (prop_tac "is_active_sc ptr s") - apply (fastforce simp: vs_all_heap_simps) - apply clarsimp - apply (frule (1) active_scs_validE) - apply (frule valid_refills_nonempty_refills) - apply (intro conjI impI) - apply (fastforce simp: valid_refills_def vs_all_heap_simps rr_valid_refills_def) - apply fastforce - apply (fastforce simp: vs_all_heap_simps) - apply (fastforce simp: vs_all_heap_simps valid_ready_qs_2_def - valid_ready_queued_thread_2_def in_ready_q_def) - apply (fastforce simp: vs_all_heap_simps valid_ready_qs_2_def - valid_ready_queued_thread_2_def in_ready_q_def) - apply (fastforce simp: vs_all_heap_simps valid_ready_qs_2_def - valid_ready_queued_thread_2_def in_ready_q_def) - apply (fastforce simp: vs_all_heap_simps valid_ready_qs_2_def - valid_ready_queued_thread_2_def in_ready_q_def) + apply (rule corres_split_forwards'[OF _ get_sched_context_sp get_sc_sp']) + apply (corres corres: get_sc_corres) + apply (rule corres_assert_opt_assume_lhs[rotated]) apply (clarsimp simp: sc_at_ppred_def obj_at_def) - apply (drule sym_refs_ko_atD[rotated], simp add: obj_at_def) - apply (clarsimp simp: pred_tcb_at_def obj_at_def refs_of_rev) - apply (clarsimp simp: invs'_def valid_pspace'_def) - apply (rule context_conjI; clarsimp?) - apply (fastforce simp: sc_tcb_sc_at_def obj_at_def is_sc_obj_def valid_obj_def - dest: invs_valid_objs intro!: sc_at_cross) - apply (rule conjI, erule valid_objs'_valid_tcbs') - apply (clarsimp simp: sc_tcb_sc_at_def obj_at_def) - apply (frule (2) sym_ref_sc_tcb, clarsimp) - apply (prop_tac "scTCB ko = Some y") - apply (frule state_relation_sc_relation[where ptr=ptr]) - apply (clarsimp simp: obj_at_simps is_sc_obj) - apply (erule (1) valid_sched_context_size_objsI, simp) - apply (clarsimp simp: sc_relation_def projection_rewrites obj_at_simps opt_map_red) - apply (frule_tac x=y in pspace_relation_absD[OF _ state_relation_pspace_relation]; simp) - apply (clarsimp simp: obj_at'_def schedulable'_def projection_rewrites - tcb_relation_cut_def tcb_relation_def) - apply (drule sym[where s="Some ptr"]) - apply (clarsimp simp: projection_rewrites opt_map_red) - apply (erule (1) valid_objsE') - apply (clarsimp simp: valid_obj'_def valid_sched_context'_def sc_relation_def valid_refills'_def - opt_map_def opt_pred_def is_active_sc'_def active_sc_tcb_at'_def) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (clarsimp simp: sc_relation_def) + apply clarsimp + apply (rename_tac sctcb n scTcb) + apply (rule_tac F="scTcb = sctcb" in corres_req, clarsimp simp: sc_relation_def) + apply clarsimp + apply (rule_tac Q="tcb_at sctcb" in corres_cross_add_abs_guard) + apply (force dest: valid_objs_valid_sched_context + simp: valid_sched_context_def obj_at_def) + apply (rule corres_split_forwards'[where r'="(=)", OF _ gets_sp getSchedulable_sp]) + apply (corres corres: getSchedulable_corres) + apply (clarsimp simp: when_def) + apply (rule corres_symb_exec_l[OF _ _ thread_get_sp, rotated]; (solves wpsimp)?) + apply (rename_tac ts) + apply (rule_tac F="runnable ts" in corres_req) + apply (clarsimp simp: schedulable_def2 pred_tcb_at_def obj_at_def) + apply clarsimp + apply (rule_tac Q="\s. is_active_sc ptr s \ valid_refills ptr s + \ sc_refills_sc_at (\refills. refills \ []) ptr s" + in corres_cross_add_abs_guard) + apply (intro context_conjI) + apply (clarsimp simp: is_active_sc_rewrite schedulable_def) + apply (prop_tac "(tcb_scs_of s) sctcb = Some ptr") + apply (fastforce dest!: sym_ref_sc_tcb + simp: opt_map_def tcbs_of_kh_def obj_at_def) + apply (clarsimp simp: is_active_sc2_def opt_pred_def opt_map_red active_sc_def + vs_all_heap_simps + split: option.splits) + apply (fastforce elim: active_scs_validE) + apply (fastforce elim: valid_refills_nonempty_refills) + apply (rule corres_split_forwards'[OF _ get_sc_refill_ready_sp refillReady_sp]) + apply (corres corres: refillReady_corres) + apply (fastforce intro!: is_active_sc'2_cross valid_objs'_valid_refills') + apply (rule corres_split_forwards'[OF _ get_sc_refill_sufficient_sp refillSufficient_sp]) + apply (corres corres: getRefillSufficient_corres) + apply (rule corres_if_strong') + apply (clarsimp simp: active_sc_def vs_all_heap_simps sc_at_ppred_def obj_at_def) + apply (rule corres_symb_exec_l[OF _ _ thread_get_sp, rotated]; (solves wpsimp)?) + apply (rule corres_symb_exec_l[OF _ _ thread_get_sp, rotated]; (solves wpsimp)?) + apply (clarsimp simp: get_tcb_queue_def) + apply (rule corres_symb_exec_l[OF _ _ gets_sp, rotated]; (solves wpsimp)?) + apply (rule corres_assert_assume_l_forward) + apply (clarsimp simp: obj_at_def) + apply (frule valid_refills_refill_sufficient) + apply (fastforce dest: sym_ref_sc_tcb + simp: valid_ready_qs_def released_sc_tcb_at_def vs_all_heap_simps + sc_at_ppred_def obj_at_def) + apply (corres corres: postpone_corres) + apply (intro context_conjI impI allI; clarsimp?) + apply (clarsimp simp: vs_all_heap_simps sc_at_ppred_def obj_at_def schedulable_def + not_in_release_q_def in_ready_q_def) + apply (frule (2) in_correct_ready_qD) + apply clarsimp + apply clarsimp + apply clarsimp done lemma getCTE_cap_to_refs[wp]: @@ -4051,29 +3971,22 @@ lemma lookupCap_cap_to_refs[wp]: apply (wp | simp)+ done -crunch setVMRoot - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps) - -lemma arch_stt_objs' [wp]: - "Arch.switchToThread t \valid_objs'\" - apply (simp add: RISCV64_H.switchToThread_def) - apply wp - done - -lemma cteInsert_ct'[wp]: - "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" - by (wp sch_act_wf_lift cur_tcb_lift tcb_in_cur_domain'_lift) - lemma maybeDonateSc_corres: - "corres dc (tcb_at tcb_ptr and ntfn_at ntfn_ptr and weak_valid_sched_action - and valid_ready_qs and active_scs_valid and valid_release_q and ready_or_release - and valid_objs and pspace_aligned and pspace_distinct and (\s. sym_refs (state_refs_of s))) - (tcb_at' tcb_ptr and ntfn_at' ntfn_ptr - and pspace_aligned' and pspace_distinct' and pspace_bounded' - and valid_objs' and sym_heap_sched_pointers and valid_sched_pointers) - (maybe_donate_sc tcb_ptr ntfn_ptr) - (maybeDonateSc tcb_ptr ntfn_ptr)" + "corres dc + (tcb_at tcb_ptr and ntfn_at ntfn_ptr and weak_valid_sched_action + and valid_ready_qs and active_scs_valid and valid_release_q and ready_or_release + and valid_objs and pspace_aligned and pspace_distinct and (\s. sym_refs (state_refs_of s))) + (valid_objs' and sym_heap_sched_pointers and valid_sched_pointers) + (maybe_donate_sc tcb_ptr ntfn_ptr) + (maybeDonateSc tcb_ptr ntfn_ptr)" + apply (rule_tac Q'="tcb_at' tcb_ptr" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross) + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest!: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest!: pspace_distinct_cross) + apply (rule_tac Q'=pspace_bounded' in corres_cross_add_guard) + apply (fastforce intro!: pspace_relation_pspace_bounded') unfolding maybeDonateSc_def maybe_donate_sc_def apply (simp add: get_tcb_obj_ref_def get_sk_obj_ref_def liftM_def maybeM_def get_sc_obj_ref_def) apply add_sym_refs @@ -4113,9 +4026,7 @@ lemma maybeDonateSc_corres: apply (subgoal_tac "sc_at sc_ptr s", clarsimp) apply (subgoal_tac "pred_map_eq None (tcb_scps_of s) tcb_ptr", clarsimp) apply (intro conjI) - apply fastforce - apply fastforce - apply fastforce + apply fastforce+ apply (erule (1) weak_valid_sched_action_no_sc_sched_act_not) apply (erule (1) valid_release_q_no_sc_not_in_release_q) apply clarsimp @@ -4125,36 +4036,32 @@ lemma maybeDonateSc_corres: apply (frule valid_objs_ko_at[where ptr=ntfn_ptr, rotated], clarsimp) apply (clarsimp simp: valid_obj_def valid_ntfn_def) apply (clarsimp simp: tcb_at'_ex_eq_all split: option.splits) - apply (fastforce elim!: valid_objsE'[where x=ntfn_ptr] - simp: obj_at_simps valid_obj'_def valid_ntfn'_def) - apply (clarsimp simp: sym_refs_asrt_def) + apply fastforce done -lemma tcbInReleaseQueue_update_valid_objs'[wp]: - "threadSet (tcbInReleaseQueue_update f) tcbPtr \valid_objs'\" - by (wpsimp wp: threadSet_valid_objs') - lemma tcbReleaseEnqueue_valid_objs'[wp]: - "\valid_objs' and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - tcbReleaseEnqueue tcbPtr - \\_. valid_objs'\" - apply (clarsimp simp: tcbReleaseEnqueue_def) - apply (wpsimp wp: hoare_drop_imp[where f="threadSet f p" for f p] - hoare_drop_imp[where f="findTimeAfter f p" for f p] - getTCB_wp) - by (fastforce dest: obj_at'_tcbQueueHead_ksReleaseQueue obj_at'_tcbQueueEnd_ksReleaseQueue - simp: ksReleaseQueue_asrt_def tcbQueueEmpty_def) + "tcbReleaseEnqueue tcbPtr \valid_objs'\" + unfolding tcbReleaseEnqueue_def + by (wpsimp wp: getTCB_wp) + +lemma orderedInsert_sym_heap_sched_pointers[wp]: + "\\s. \ is_sched_linked t s\ + orderedInsert t q f R + \\_. sym_heap_sched_pointers\" + unfolding orderedInsert_def + by (wpsimp wp: tcbQueuePrepend_sym_heap_sched_pointers + tcbQueueAppend_sym_heap_sched_pointers + tcbQueueInsert_sym_heap_sched_pointers hoare_drop_imps) lemma tcbReleaseEnqueue_sym_heap_sched_pointers[wp]: - "\sym_heap_sched_pointers and valid_sched_pointers\ + "\valid_sched_pointers\ tcbReleaseEnqueue tcbPtr \\_. sym_heap_sched_pointers\" unfolding tcbReleaseEnqueue_def - apply (wpsimp wp: tcbQueuePrepend_sym_heap_sched_pointers tcbQueueAppend_sym_heap_sched_pointers - tcbQueueInsert_sym_heap_sched_pointers - hoare_drop_imp[where f="findTimeAfter f p" for f p] getTCB_wp) - apply (clarsimp simp: ksReleaseQueue_asrt_def valid_sched_pointers_def) - apply (force dest!: spec[where x=tcbPtr] simp: opt_pred_def obj_at'_def opt_map_def) + apply (wpsimp wp: getTCB_wp) + apply (erule (1) valid_sched_pointersD[simplified]) + apply (force simp: opt_pred_def obj_at'_def opt_map_red) + apply (fastforce intro!: runnable'_not_inIPCQueueThreadState) done crunch postpone, schedContextResume, maybeDonateSc @@ -4162,53 +4069,10 @@ crunch postpone, schedContextResume, maybeDonateSc and valid_objs'[wp]: valid_objs' (simp: crunch_simps wp: crunch_wps) -lemma refillPopHead_bound_tcb_sc_at[wp]: - "refillPopHead scPtr \obj_at' (\a. \y. scTCB a = Some y) t\" - supply if_split [split del] - unfolding refillPopHead_def - apply (wpsimp wp: updateSchedContext_sc_obj_at' getRefillNext_wp) - by (clarsimp simp: obj_at'_real_def ko_wp_at'_def split: if_split) - -lemma updateRefillHd_bound_tcb_sc_at[wp]: - "updateRefillHd scPtr f \obj_at' (\a. \y. scTCB a = Some y) t\" - supply if_split [split del] - unfolding updateRefillHd_def - apply (wpsimp wp: set_sc'.obj_at' simp: updateSchedContext_def) - by (clarsimp simp: obj_at'_real_def ko_wp_at'_def split: if_split) - crunch refillUnblockCheck for bound_tcb_sc_at[wp]: "obj_at' (\a. \y. scTCB a = Some y) t" (wp: crunch_wps simp: crunch_simps) -lemma tcbFault_update_ex_nonz_cap_to'[wp]: - "threadSet (tcbFault_update x) t' \ex_nonz_cap_to' t\" - unfolding ex_nonz_cap_to'_def - by (wpsimp wp: threadSet_cte_wp_at'T hoare_vcg_ex_lift; - fastforce simp: tcb_cte_cases_def cteSizeBits_def) - -crunch cancelIPC - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' t" - (wp: crunch_wps simp: crunch_simps ignore: threadSet) - -lemma thread_state_tcb_in_WaitingNtfn'_q: - "\ko_at' ntfn ntfnPtr s; ntfnObj ntfn = Structures_H.ntfn.WaitingNtfn q; valid_objs' s; - sym_refs (state_refs_of' s); t \ set q\ - \ st_tcb_at' ((=) (BlockedOnNotification ntfnPtr)) t s" - apply (clarsimp simp: sym_refs_def) - apply (erule_tac x = ntfnPtr in allE) - apply (drule_tac x = "(t, NTFNSignal)" in bspec) - apply (clarsimp simp: state_refs_of'_def obj_at'_def refs_of'_def) - apply (subgoal_tac "tcb_at' t s") - apply (clarsimp simp: state_refs_of'_def refs_of'_def obj_at'_real_def ko_wp_at'_def - tcb_st_refs_of'_def tcb_bound_refs'_def get_refs_def) - apply (erule disjE) - apply (case_tac "tcbState obj"; clarsimp split: if_splits) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def) - apply (clarsimp split: option.splits) - apply (drule (1) ntfn_ko_at_valid_objs_valid_ntfn') - apply (clarsimp simp: valid_ntfn'_def) - done - lemma in_correct_ready_q_reprogram_timer[simp]: "in_correct_ready_q (release_queue_update f s) = in_correct_ready_q s" by (clarsimp simp: in_correct_ready_q_def) @@ -4222,66 +4086,29 @@ crunch maybe_donate_sc and ready_qs_distinct[wp]: ready_qs_distinct (ignore: tcb_sched_action wp: crunch_wps simp: crunch_simps) +lemma tcbInReleaseQueue_True_valid_sched_pointers[wp]: + "\valid_sched_pointers_except tcbPtr\ + threadSet (tcbInReleaseQueue_update \) tcbPtr + \\_. valid_sched_pointers\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: valid_sched_pointers_def opt_pred_def) + done + +lemma orderedInsert_valid_sched_pointers_except: + "\\s. valid_sched_pointers s\ + orderedInsert t q f R + \\_. valid_sched_pointers_except t\" + unfolding orderedInsert_def + by (wpsimp wp: tcbQueuePrepend_valid_sched_pointers_except + tcbQueueAppend_valid_sched_pointers_except + tcbQueueInsert_valid_sched_pointers_except hoare_drop_imps) + lemma tcbReleaseEnqueue_valid_sched_pointers[wp]: "\valid_sched_pointers and sym_heap_sched_pointers\ tcbReleaseEnqueue tcbPtr \\_. valid_sched_pointers\" - supply if_split[split del] - apply (clarsimp simp: tcbReleaseEnqueue_def setReleaseQueue_def ifM_def orM_def) - apply (intro bind_wp[OF _ stateAssert_sp] bind_wp[OF _ isRunnable_sp] - bind_wp[OF _ assert_sp] bind_wp[OF _ get_tcb_sp'] - bind_wp[OF _ getTCBReadyTime_sp] bind_wp[OF _ getReleaseQueue_sp]) - apply (clarsimp simp: if_to_top_of_bind) - - \ \the release queue is empty\ - apply (rule hoare_if) - apply (clarsimp simp: tcbQueuePrepend_def setReprogramTimer_def) - apply (wpsimp wp: threadSet_wp) - apply (clarsimp simp: valid_sched_pointers_def tcbQueueEmpty_def opt_pred_def split: if_splits) - - apply (simp add: bind_assoc) - apply (intro bind_wp[OF _ getTCBReadyTime_sp]) - apply (clarsimp simp: if_to_top_of_bind) - - \ \prepend tcbPtr\ - apply (rule hoare_if) - apply (clarsimp simp: tcbQueuePrepend_def setReprogramTimer_def tcbQueueEmpty_def) - apply (wpsimp wp: threadSet_wp) - apply (clarsimp simp: valid_sched_pointers_def) - apply (drule obj_at'_prop)+ - apply (clarsimp simp: ksReleaseQueue_asrt_def list_queue_relation_def) - apply (case_tac "ts = []", fastforce) - apply (frule (1) heap_path_head) - apply (clarsimp simp: opt_pred_def opt_map_def split: if_splits option.splits) - - apply (simp add: bind_assoc) - apply (intro bind_wp[OF _ assert_sp] bind_wp[OF _ getTCBReadyTime_sp]) - apply (clarsimp simp: if_to_top_of_bind) - apply (rule hoare_if) - - \ \append tcbPtr\ - apply (wpsimp wp: threadSet_wp simp: tcbQueueAppend_def) - subgoal - by (auto dest: last_in_set - simp: valid_sched_pointers_def ksReleaseQueue_asrt_def list_queue_relation_def - queue_end_valid_def opt_pred_def opt_map_def obj_at'_def - split: if_splits option.splits) - - \ \insert tcbPtr into the middle of the release queue\ - apply (simp add: bind_assoc) - apply forward_inv_step - apply (clarsimp simp: tcbQueueInsert_def) - \ \forwards step in order to name afterPtr below\ - apply (rule bind_wp[OF _ assert_sp]) - apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac afterPtr) - apply (wpsimp wp: threadSet_wp getTCB_wp) - apply (drule obj_at'_prop)+ - apply (clarsimp simp: ksReleaseQueue_asrt_def findTimeAfter_asrt_def) - apply (frule_tac p=afterPtr in list_queue_relation_neighbour_in_set) - apply fastforce - apply (fastforce simp: opt_pred_def opt_map_def obj_at'_def) - by (auto simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def - split: if_splits option.splits) + unfolding tcbReleaseEnqueue_def + by (wpsimp wp: orderedInsert_valid_sched_pointers_except getTCB_wp) crunch maybeDonateSc for pspace_aligned'[wp]: pspace_aligned' @@ -4290,45 +4117,98 @@ crunch maybeDonateSc and valid_sched_pointers[wp]: valid_sched_pointers (simp: crunch_simps wp: crunch_wps) -lemma set_notification_in_correct_ready_q[wp]: - "set_notification ptr ep \in_correct_ready_q\" - unfolding set_simple_ko_def - apply (wpsimp wp: set_object_wp get_object_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps in_correct_ready_q_def) +lemma ntfnSetActive_corres: + "msg = msg' \ + corres dc + (obj_at (\ko. ko = kernel_object.Notification ntfn \ (ntfn_queue_of ntfn) = []) ntfn_ptr + and pspace_aligned and pspace_distinct) \ + (set_notification ntfn_ptr (ntfn_set_obj ntfn (ActiveNtfn msg))) + (ntfnSetActive ntfn_ptr msg')" + apply (rule_tac Q="ntfn_at ntfn_ptr" in corres_cross_add_abs_guard) + apply (fastforce simp: obj_at_def is_ntfn_def) + apply (rule_tac Q'="ntfn_at' ntfn_ptr" in corres_cross_add_guard) + apply (fastforce intro: ntfn_at_cross) + apply (clarsimp simp: ntfnSetActive_def) + apply (clarsimp simp: updateNotification_def) + apply (rule corres_symb_exec_r[OF _ get_ntfn_sp'], rename_tac ntfn') + apply (rule_tac F="ntfn_relation ntfn ntfn'" in corres_req) + apply (fastforce dest: state_relation_pspace_relation ntfns_relation_ntfn_relation_abs + simp: pspace_relation_heap_pspace_relation obj_at_def obj_at'_def) + apply (corres corres: setNotification_no_queue_update_corres) + apply (clarsimp simp: ntfn_relation_def) + apply (clarsimp simp: obj_at_def) + apply (clarsimp simp: obj_at'_def) + apply wpsimp + apply wpsimp + done + +crunch maybe_donate_sc + for ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (wp: ep_queues_blocked_lift ntfn_queues_blocked_lift crunch_wps) + +lemma cancelIPC_receiveBlocked_not_sched_linked: + "\st_tcb_at' receiveBlocked t\ cancelIPC t \\_ s. \ is_sched_linked t s\" + apply (clarsimp simp: cancelIPC_def) + apply (intro bind_wp[OF _ stateAssert_inv] bind_wp[OF _ gts_sp']) + apply (case_tac state; clarsimp simp: receiveBlocked_def) + apply (clarsimp simp: blockedCancelIPC_def) + apply wpsimp + apply (wpsimp wp: hoare_pre_cont, + clarsimp simp: st_tcb_at'_def obj_at'_def receiveBlocked_def)+ + done + +lemmas cancelIPC_receiveBlocked_tcbSchedNexts_of = + cancelIPC_receiveBlocked_not_sched_linked[simplified, THEN hoare_conjD1[simplified pred_conj_def]] + +lemmas cancelIPC_receiveBlocked_tcbSchedPrevs_of = + cancelIPC_receiveBlocked_not_sched_linked[simplified, THEN hoare_conjD2[simplified pred_conj_def]] + +crunch tcbNTFNDequeue + for tcbStates_of'[wp]: "\s. P (tcbStates_of' s)" + and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: crunch_wps) + +lemma tcbNTFNDequeue_invs'[wp]: + "tcbNTFNDequeue t ntfnPtr \invs'\" + apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (wpsimp wp: valid_irq_node_lift) done lemma sendSignal_corres: - "corres dc (einvs and ntfn_at ep and current_time_bounded) (invs' and ntfn_at' ep) - (send_signal ep bg) (sendSignal ep bg)" - apply (simp add: send_signal_def sendSignal_def Let_def) + "corres dc + (einvs and ntfn_at ntfn_ptr and current_time_bounded) invs' + (send_signal ntfn_ptr bg) (sendSignal ntfn_ptr bg)" apply add_sym_refs apply add_valid_idle' - apply (rule corres_stateAssert_assume) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getNotification_corres, - where - R = "\rv. einvs and ntfn_at ep and valid_ntfn rv and - ko_at (Structures_A.Notification rv) ep - and current_time_bounded" and - R' = "\rv'. invs' and valid_idle' and ntfn_at' ep and - valid_ntfn' rv' and ko_at' rv' ep"]) - defer - apply (wp get_simple_ko_ko_at get_ntfn_ko')+ - apply (simp add: invs_valid_objs invs_valid_objs')+ - apply add_sym_refs - apply (case_tac "ntfn_obj ntfn"; simp) + apply (rule_tac Q'="ntfn_at' ntfn_ptr" in corres_cross_add_guard) + apply (fastforce intro!: ntfn_at_cross) + apply (simp add: send_signal_def sendSignal_def Let_def) + apply (rule corres_stateAssert_assume[rotated], simp) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ntfn_sp']) + apply (corres corres: getNotification_corres) + apply fastforce + apply fastforce + apply (rename_tac ntfn nTFN) + apply (rule_tac Q="valid_ntfn ntfn" in corres_cross_add_abs_guard) + apply (fastforce dest: invs_valid_objs simp: valid_obj_def obj_at_def) + apply (rule_tac Q'="valid_ntfn' nTFN" in corres_cross_add_guard) + apply (fastforce elim!: ntfn_ko_at_valid_objs_valid_ntfn') + apply (case_tac "ntfn_obj ntfn"; clarsimp) \ \IdleNtfn\ - apply (clarsimp simp add: ntfn_relation_def) - apply (case_tac "ntfnBoundTCB nTFN"; simp) - apply (rule corres_guard_imp[OF setNotification_corres]) - apply (clarsimp simp add: ntfn_relation_def)+ + apply (clarsimp simp: ntfn_relation_def) + apply (case_tac "ntfnBoundTCB nTFN"; clarsimp) + \ \IdleNtfn and no bound TCB\ + apply (corres corres: ntfnSetActive_corres) + apply (fastforce simp: obj_at_def) + apply fastforce + \ \IdleNtfn with a bound TCB\ + apply (rename_tac t) apply (rule corres_guard_imp) apply (rule corres_split[OF getThreadState_corres]) apply (rule corres_if) - apply (fastforce simp: receive_blocked_def receiveBlocked_def - thread_state_relation_def - split: Structures_A.thread_state.splits - Structures_H.thread_state.splits) + apply (fastforce simp: receive_blocked_def receiveBlocked_def thread_state_relation_def + split: Structures_A.thread_state.splits thread_state.splits) apply (rule corres_split[OF cancel_ipc_corres]) apply (rule corres_split[OF setThreadState_corres], simp) apply (simp add: badgeRegister_def badge_register_def) @@ -4342,45 +4222,50 @@ lemma sendSignal_corres: apply (rule ifCondRefillUnblockCheck_corres) apply (wpsimp wp: get_tcb_obj_ref_wp) apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\_. tcb_at a and active_scs_valid and pspace_aligned - and pspace_distinct and valid_objs" - in hoare_strengthen_post[rotated]) + apply (rule_tac Q'="\_. tcb_at t and active_scs_valid and pspace_aligned + and pspace_distinct and valid_objs" + in hoare_strengthen_post[rotated]) apply (clarsimp, frule (1) valid_objs_ko_at) apply (fastforce simp: valid_obj_def valid_tcb_def valid_bound_obj_def obj_at_def is_sc_obj opt_map_def opt_pred_def split: option.split) apply wpsimp - apply (rule_tac Q'="\_. tcb_at' a and valid_objs'" in hoare_strengthen_post[rotated]) + apply (rule_tac Q'="\_. valid_objs' and pspace_bounded'" in hoare_post_imp) apply (clarsimp simp: obj_at'_def split: option.split) apply wpsimp apply wpsimp apply (wpsimp wp: getSchedulable_wp) - apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct and tcb_at a - and valid_sched_action and active_scs_valid - and in_correct_ready_q and ready_qs_distinct - and ready_or_release" + apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct and tcb_at t + and valid_sched_action and active_scs_valid + and in_correct_ready_q and ready_qs_distinct + and ready_queues_runnable + and ready_or_release + and ep_queues_blocked and ntfn_queues_blocked" in hoare_post_imp) apply (fastforce simp: schedulable_def2) - apply (wpsimp wp: hoare_drop_imps maybe_donate_sc_valid_sched_action abs_typ_at_lifts - | strengthen valid_objs_valid_tcbs)+ + apply ((wpsimp wp: hoare_drop_imps maybe_donate_sc_valid_sched_action + maybe_donate_sc_valid_ready_qs abs_typ_at_lifts + | strengthen valid_objs_valid_tcbs valid_ready_qs_ready_queues_runnable)+)[1] apply(wpsimp wp: hoare_drop_imp | strengthen valid_objs'_valid_tcbs')+ apply (strengthen valid_sched_action_weak_valid_sched_action) - apply (wpsimp wp: sts_cancel_ipc_Running_invs set_thread_state_valid_sched_action - set_thread_state_valid_ready_qs - set_thread_state_valid_release_q) - apply (wpsimp wp: sts_invs') + apply ((wpsimp wp: sts_cancel_ipc_Running_invs set_thread_state_valid_sched_action + set_thread_state_valid_ready_qs + set_thread_state_valid_release_q + | strengthen sym_refs_ep_queues_blocked sym_refs_ntfn_queues_blocked)+)[1] + apply ((wpsimp wp: sts_invs' | strengthen invs'_implies)+)[1] apply (rename_tac ntfn ntfn' tptr st st') - apply (rule_tac Q'="\_. invs and tcb_at tptr and ntfn_at ep and - st_tcb_at - ((=) Structures_A.thread_state.Running or - (=) Structures_A.thread_state.Inactive or - (=) Structures_A.thread_state.Restart or - (=) Structures_A.thread_state.IdleThreadState) tptr and - ex_nonz_cap_to tptr and fault_tcb_at ((=) None) tptr and - valid_sched and scheduler_act_not tptr and active_scs_valid - and current_time_bounded" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def pred_disj_def) + apply (rule_tac Q'="\_. invs and tcb_at tptr and ntfn_at ntfn_ptr + and st_tcb_at + ((=) Structures_A.thread_state.Running + or (=) Structures_A.thread_state.Inactive + or (=) Structures_A.thread_state.Restart + or (=) Structures_A.thread_state.IdleThreadState) tptr + and ex_nonz_cap_to tptr and fault_tcb_at ((=) None) tptr + and valid_sched and scheduler_act_not tptr and active_scs_valid + and current_time_bounded" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def + pred_disj_def) apply (rule conjI, fastforce) apply (prop_tac "tcb_non_st_state_refs_of s tptr = state_refs_of s tptr") apply (drule (1) sym_refs_st_tcb_atD) @@ -4388,45 +4273,59 @@ lemma sendSignal_corres: apply (prop_tac "tcb_st_refs_of ts = {}") apply (fastforce simp: tcb_st_refs_of_def) apply simp - apply (clarsimp simp add: get_refs_def2 split: option.splits; fastforce?) + subgoal by (clarsimp simp: get_refs_def2 split: option.splits; fastforce?) apply (fold fun_upd_def, fastforce) apply (wpsimp wp: cancel_ipc_simple_except_awaiting_reply cancel_ipc_ex_nonz_cap_to_tcb) - apply (clarsimp cong: conj_cong simp: pred_conj_def valid_tcb_state'_def pred_tcb_at'_eq_commute) - apply (rule_tac Q'="\_. invs' and tcb_at' a and ntfn_at' ep and - (\s. a \ ksIdleThread s) and ex_nonz_cap_to' a and - st_tcb_at' simple' a" - in hoare_strengthen_post[rotated]) + apply (clarsimp cong: conj_cong simp: pred_conj_def pred_tcb_at'_eq_commute) + apply (rule_tac Q'="\_ s. invs' s \ st_tcb_at' simple' t s \ \ is_sched_linked t s" + in hoare_strengthen_post[rotated]) apply (fastforce simp: invs'_def valid_pspace'_def pred_tcb_at'_def obj_at'_def) - apply (wpsimp wp: cancelIPC_invs') - apply (rule setNotification_corres, clarsimp simp: ntfn_relation_def) + apply (wpsimp wp: cancelIPC_invs' cancelIPC_receiveBlocked_not_sched_linked) + apply (rule ntfnSetActive_corres, clarsimp simp: ntfn_relation_def) apply (wpsimp wp: gts_wp gts_wp')+ apply (frule invs_psp_aligned, frule invs_distinct) - apply (frule (1) valid_objs_ko_at[OF invs_valid_objs]) - apply (clarsimp simp: valid_obj_def valid_ntfn_def receive_blocked_equiv - is_blocked_on_receive_def) - apply (frule (1) valid_sched_scheduler_act_not, simp) - apply (frule st_tcb_ex_cap; clarsimp) - apply (clarsimp simp: invs_def valid_sched_def valid_state_def valid_pspace_def) - apply (clarsimp simp: valid_ntfn'_def) - apply (intro conjI) - apply (clarsimp simp: valid_idle'_def invs'_def idle_tcb'_def obj_at'_def - pred_tcb_at'_def receiveBlocked_def) - apply (rule if_live_then_nonz_capE', clarsimp) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def live'_def) - apply (clarsimp simp: receiveBlocked_equiv is_BlockedOnReceive_def) + apply (clarsimp simp: valid_ntfn_def receive_blocked_equiv is_blocked_on_receive_def) + apply (rule conjI, intro impI) + apply (frule (1) valid_sched_scheduler_act_not) + apply (frule st_tcb_ex_cap; clarsimp) + apply (clarsimp simp: invs_def valid_sched_def valid_state_def valid_pspace_def) + subgoal by (force dest!: st_tcb_ex_cap) + apply (clarsimp simp: obj_at_def) + apply (fastforce simp: pred_tcb_at'_def obj_at'_def ko_wp_at'_def receiveBlocked_equiv + is_BlockedOnReceive_def) \ \WaitingNtfn\ apply (clarsimp simp: ntfn_relation_def Let_def update_waiting_ntfn_def) apply (rename_tac list) apply (rule corres_assert_assume_l_forward) apply (clarsimp simp: valid_ntfn_def) - apply (case_tac "list = []") - apply (fastforce intro: corres_fail) - apply (simp add: list_case_helper split del: if_split) - apply (rule corres_assert_gen_asm_cross[where P=P' and P'=P' for P', - where Q=Q' and Q'=Q' for Q', simplified]) - apply (fastforce simp: valid_ntfn_def distinct_hd_not_in_tl distinct_tl) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setNotification_corres]) + apply (rule_tac Q'="\s'. list_queue_relation + list (ntfnQueue nTFN) (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in corres_cross_add_guard) + apply (frule state_relation_ntfn_queues_relation) + apply (frule_tac s=s and s'=s' in ntfn_queues_relationD[rotated 2]) + apply (fastforce simp: obj_at_def opt_map_def obj_at'_def split: option.splits) + apply (fastforce simp: obj_at_def opt_map_def obj_at'_def split: option.splits) + apply fastforce + apply (rule corres_assert_gen_asm_cross_forwards) + apply (fastforce dest: list_queue_relation_Nil) + apply (clarsimp simp: tcbQueueEmpty_def) + apply (rename_tac head) + apply (rule_tac F="hd list = head" in corres_req) + apply (fastforce dest!: heap_path_head simp: list_queue_relation_def) + apply clarsimp + apply (rule_tac Q="st_tcb_at + (\st. st = Structures_A.thread_state.BlockedOnNotification ntfn_ptr) + (hd list)" + in corres_cross_add_abs_guard) + apply (fastforce dest: st_in_waitingntfn simp: obj_at_def) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ gts_sp', rotated]; (solves wpsimp)?) + apply wpsimp + apply (fastforce intro: tcb_at_cross simp: ex_abs_def) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (fastforce dest!: st_tcb_at_coerce_concrete + simp: thread_state_relation_def st_tcb_at'_def obj_at'_def isBlockedOnNtfn_def) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF tcbNTFNDequeue_corres], simp, simp) apply (clarsimp simp: ntfn_relation_def split: list.splits) apply (rule corres_split[OF setThreadState_corres], simp) apply (simp add: badgeRegister_def badge_register_def) @@ -4437,99 +4336,96 @@ lemma sendSignal_corres: apply (rule possibleSwitchTo_corres; (solves simp)?) apply (rule corres_split_eqr[OF get_tcb_obj_ref_corres]) apply (clarsimp simp: tcb_relation_def) - apply (rule ifCondRefillUnblockCheck_corres) + apply (rule ifCondRefillUnblockCheck_corres[simplified dc_def]) apply (wpsimp wp: get_tcb_obj_ref_wp) apply (wpsimp wp: threadGet_wp) apply (rule_tac Q'="\_. tcb_at (hd list) and active_scs_valid and pspace_aligned - and pspace_distinct and valid_objs" - in hoare_strengthen_post[rotated]) + and pspace_distinct and valid_objs" + in hoare_post_imp) apply (clarsimp, frule (1) valid_objs_ko_at) apply (fastforce simp: valid_tcb_def obj_at_def is_sc_obj opt_map_def opt_pred_def valid_obj_def split: option.split) apply wpsimp - apply (rule_tac Q'="\_. tcb_at' (hd list) and valid_objs'" in hoare_strengthen_post[rotated]) + apply (rule_tac Q'="\_. valid_objs' and pspace_bounded'" in hoare_post_imp) apply (clarsimp simp: obj_at'_def split: option.split) apply wpsimp apply wpsimp apply (wpsimp wp: getSchedulable_wp) - apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct and tcb_at (hd list) - and valid_sched_action and active_scs_valid - and in_correct_ready_q and ready_qs_distinct and ready_or_release" + apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct + and tcb_at (hd list) and valid_sched_action and active_scs_valid + and in_correct_ready_q and ready_qs_distinct and ready_or_release + and ep_queues_blocked and ntfn_queues_blocked and valid_ready_qs" in hoare_post_imp) apply (fastforce simp: schedulable_def2) - apply (wpsimp wp: hoare_drop_imp maybe_donate_sc_valid_sched_action abs_typ_at_lifts - | strengthen valid_objs_valid_tcbs)+ + apply ((wpsimp wp: hoare_drop_imp maybe_donate_sc_valid_sched_action + maybe_donate_sc_valid_ready_qs abs_typ_at_lifts + | strengthen valid_objs_valid_tcbs)+)[1] apply(wpsimp wp: hoare_drop_imp | strengthen valid_objs'_valid_tcbs')+ apply (strengthen valid_sched_action_weak_valid_sched_action) - apply (wpsimp simp: invs_def valid_state_def valid_pspace_def - wp: sts_valid_replies sts_only_idle sts_fault_tcbs_valid_states - set_thread_state_valid_sched_action - set_thread_state_valid_ready_qs set_thread_state_valid_release_q) - apply (wpsimp wp: sts_invs') - apply (clarsimp cong: conj_cong, wpsimp) - apply (clarsimp cong: conj_cong, wpsimp wp: set_ntfn_minor_invs' hoare_vcg_all_lift hoare_vcg_imp_lift) + apply ((wpsimp simp: invs_def valid_state_def valid_pspace_def + wp: sts_valid_replies sts_only_idle sts_fault_tcbs_valid_states + set_thread_state_valid_sched_action + set_thread_state_valid_ready_qs set_thread_state_valid_release_q + | strengthen sym_refs_ep_queues_blocked sym_refs_ntfn_queues_blocked)+)[1] + apply ((wpsimp wp: sts_invs' | strengthen invs'_implies)+)[1] + apply (clarsimp simp: tcb_ntfn_dequeue_def + cong: conj_cong, + wpsimp wp: get_simple_ko_wp) + apply (clarsimp cong: conj_cong) + apply ((wpsimp wp: tcbNTFNDequeue_not_sched_linked[simplified] hoare_vcg_all_lift + hoare_vcg_imp_lift hoare_vcg_disj_lift + | strengthen valid_objs'_valid_tcbs')+)[1] apply (clarsimp cong: conj_cong) - apply (frule valid_objs_ko_at[rotated], clarsimp) - apply (clarsimp simp: valid_obj_def valid_ntfn_def invs_def valid_state_def valid_pspace_def - valid_sched_def obj_at_def) - apply (frule valid_objs_valid_tcbs, simp) - apply (frule (3) st_in_waitingntfn) - apply (subgoal_tac "hd list \ ep", simp) - apply (rule conjI) - apply (clarsimp split: list.splits option.splits) - apply (case_tac list; fastforce) - apply (prop_tac "ex_nonz_cap_to (hd list) s") - apply (frule (4) ex_nonz_cap_to_tcb_in_waitingntfn, fastforce) - apply (drule_tac x="hd list" in bspec, simp)+ - apply clarsimp - apply (rule conjI) - apply (erule delta_sym_refs_remove_only[where tp=TCBSignal], clarsimp) - apply (rule subset_antisym, clarsimp) - apply (clarsimp simp: state_refs_of_def is_tcb get_refs_def tcb_st_refs_of_def pred_tcb_at_def - obj_at_def) - apply (force split: option.splits) - apply (rule subset_antisym) - apply (clarsimp simp: subset_remove ntfn_q_refs_of_def get_refs_def tcb_st_refs_of_def pred_tcb_at_def - obj_at_def state_refs_of_def) - apply (clarsimp split: list.splits option.splits) - apply (case_tac list; fastforce) - apply (clarsimp simp: subset_remove ntfn_q_refs_of_def get_refs_def tcb_st_refs_of_def pred_tcb_at_def - obj_at_def state_refs_of_def) - apply (clarsimp split: list.splits) - apply (case_tac list; fastforce) - apply (rule conjI) - apply (rule valid_sched_scheduler_act_not_better, clarsimp simp: valid_sched_def) - apply (clarsimp simp: st_tcb_at_def obj_at_def pred_neg_def) - apply fastforce - apply (clarsimp simp: st_tcb_at_def obj_at_def) - apply (drule_tac x="hd list" in bspec; clarsimp)+ - apply (clarsimp simp: invs'_def valid_pspace'_def valid_tcb_state'_def - cong: conj_cong) - apply (frule_tac t="hd list" in thread_state_tcb_in_WaitingNtfn'_q; assumption?) - apply (clarsimp simp: valid_ntfn'_def) - apply (intro conjI) - apply clarsimp - apply (clarsimp simp: valid_ntfn'_def) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def is_BlockedOnNotification_def) - apply (clarsimp simp: valid_ntfn'_def split: list.splits) - 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)) - \ \ActiveNtfn\ - apply (clarsimp simp add: ntfn_relation_def Let_def) - apply (rule corres_guard_imp) - apply (rule setNotification_corres) - apply (clarsimp simp: ntfn_relation_def combine_ntfn_badges_def)+ - done - -lemma possibleSwitchTo_if_live_then_nonz_cap'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and valid_tcbs' - and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - possibleSwitchTo t - \\_. if_live_then_nonz_cap'\" - apply (simp add: possibleSwitchTo_def curDomain_def inReleaseQueue_def) - apply (wpsimp wp: threadGet_wp) + apply (prop_tac "hd list \ ntfn_ptr") + apply (fastforce dest: hd_in_set simp: valid_ntfn_def obj_at_def is_tcb_def) + apply (clarsimp simp: valid_sched_def cong: conj_cong) + apply (frule invs_sym_refs) + apply (frule sym_refs_ep_queues_blocked) + apply (frule sym_refs_ntfn_queues_blocked) + apply clarsimp + apply (intro conjI impI allI; fastforce?) + apply (clarsimp simp: in_ntfn_queue_at_def obj_at_def opt_map_def) + apply (clarsimp simp: valid_ntfn_def obj_at_def + split: list.splits) + apply (prop_tac "set (filter ((\) (hd list)) list) \ set list") + apply (rule filter_is_subset) + apply (frule_tac P="(\) (hd list)" in distinct_filter) + subgoal by (auto simp: removeAll_filter_not_eq split: option.splits) + apply (clarsimp simp: removeAll_filter_not_eq pred_tcb_at_def obj_at_def) + apply (prop_tac "filter ((\) (hd list)) list = tl list") + apply (fastforce intro: filter_hd_equals_tl simp: valid_ntfn_def) + apply (erule delta_sym_refs_remove_only[where tp=TCBSignal], clarsimp) + apply (rule subset_antisym, clarsimp) + apply (clarsimp simp: state_refs_of_def is_tcb get_refs_def tcb_st_refs_of_def pred_tcb_at_def + obj_at_def) + apply (force split: option.splits) + apply (rule subset_antisym) + apply (clarsimp simp: subset_remove ntfn_q_refs_of_def get_refs_def) + apply (clarsimp split: option.splits) + apply (case_tac list) + apply fastforce + apply (force simp: state_refs_of_def split: list.splits) + apply (clarsimp split: list.splits) + apply (case_tac list; fastforce simp: state_refs_of_def) + apply (rule valid_sched_scheduler_act_not_better) + subgoal by (clarsimp simp: valid_sched_def) + apply (clarsimp simp: st_tcb_at_def obj_at_def valid_ntfn_def) + apply clarsimp + apply (frule invs_psp_aligned) + apply (frule invs_distinct) + apply (frule (3) st_tcb_at_coerce_concrete) + apply (clarsimp cong: conj_cong) + apply (intro conjI impI allI; clarsimp?) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (clarsimp simp: ntfn_relation_def updateNotification_def) + apply (rule corres_symb_exec_r[OF _ get_ntfn_sp']; (solves wpsimp)?) + apply (rename_tac nTFN', rule_tac F="nTFN' = nTFN" in corres_req, normalise_obj_at') + apply (corres corres: setNotification_no_queue_update_corres) + apply (clarsimp simp: ntfn_relation_def combine_ntfn_badges_def) + apply (fastforce simp: obj_at_def) + apply (fastforce simp: obj_at'_def) done lemma replyRemoveTCB_irqs_masked'[wp]: @@ -4555,16 +4451,17 @@ lemma ct_in_state_activatable_imp_simple'[simp]: done lemma setThreadState_nonqueued_state_update: - "\\s. invs' s \ st_tcb_at' simple' t s - \ simple' st - \ (st \ Inactive \ ex_nonz_cap_to' t s)\ + "\\s. invs' s \ st_tcb_at' simple' t s\ setThreadState st t \\_. invs'\" apply (simp add: invs'_def valid_dom_schedule'_def) - apply (rule hoare_pre, wp valid_irq_node_lift) + apply (rule hoare_pre, wp valid_irq_node_lift setThreadState_not_queued_valid_sched_pointers') + apply (clarsimp simp: valid_pspace'_def) apply (clarsimp simp: pred_tcb_at' pred_tcb_at'_eq_commute) - apply (rule conjI, fastforce simp: valid_tcb_state'_def) - apply (fastforce simp: list_refs_of_replies'_def o_def pred_tcb_at'_def obj_at'_def) + apply (intro conjI impI allI) + subgoal by (fastforce simp: list_refs_of_replies'_def o_def pred_tcb_at'_def obj_at'_def) + apply (erule pred_tcb'_weakenE) + apply (rename_tac state, case_tac state; clarsimp) done crunch possibleSwitchTo, asUser, doIPCTransfer @@ -4583,80 +4480,6 @@ crunch doIPCTransfer, possibleSwitchTo for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" (wp: crunch_wps simp: zipWithM_x_mapM) -crunch setThreadState - for not_rct[wp]: "\s. ksSchedulerAction s \ ResumeCurrentThread" - (simp: crunch_simps wp: crunch_wps) - -lemma cancelAllIPC_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllIPC epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllIPC_def) - apply (wpsimp wp: getEndpoint_wp) - done - -lemma cancelAllSignals_not_rct[wp]: - "\\s. ksSchedulerAction s \ ResumeCurrentThread \ - cancelAllSignals epptr - \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" - apply (simp add: cancelAllSignals_def) - apply (wpsimp wp: getNotification_wp) - done - -crunch finaliseCapTrue_standin - for not_rct[wp]: "\s. ksSchedulerAction s \ ResumeCurrentThread" - (simp: crunch_simps wp: crunch_wps) - -crunch cleanReply - for schedulerAction[wp]: "\s. P (ksSchedulerAction s)" - (simp: crunch_simps) - -crunch tcbEPAppend, tcbEPDequeue - for inv[wp]: P - (wp: crunch_wps) - -lemma tcbEPAppend_not_null[wp]: - "\\\ tcbEPAppend t q \\rv _. rv \ []\" - by (wpsimp simp: tcbEPAppend_def split_del: if_split) - -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 (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 (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': - "\valid_ep' (updateEpQueue ep (t#q)) and K (ep \ IdleEP \ t \ set q)\ - tcbEPAppend t q - \\q'. valid_ep' (updateEpQueue ep q')\" - by (cases ep) (wpsimp wp: tcbEPAppend_valid_SendEP tcbEPAppend_valid_RecvEP simp: updateEpQueue_def)+ - -lemma tcbEPDequeue_valid_SendEP: - "\valid_ep' (SendEP q) and K (t \ set q)\ tcbEPDequeue t q \\q'. valid_ep' (SendEP (t#q'))\" - 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'))\" - by (wpsimp simp: tcbEPDequeue_def valid_ep'_def) - -lemma tcbEPDequeue_valid_ep': - "\valid_ep' (updateEpQueue ep q) and K (ep \ IdleEP \ t \ set q)\ - tcbEPDequeue t q - \\q'. valid_ep' (updateEpQueue ep (t#q'))\" - by (cases ep) (wpsimp wp: tcbEPDequeue_valid_SendEP tcbEPDequeue_valid_RecvEP simp: updateEpQueue_def)+ - crunch doIPCTransfer for urz[wp]: "untyped_ranges_zero'" (ignore: threadSet wp: threadSet_urz crunch_wps simp: zipWithM_x_mapM) @@ -4670,8 +4493,7 @@ lemmas possibleSwitchToTo_cteCaps_of[wp] = cteCaps_of_ctes_of_lift[OF possibleSwitchTo_ctes_of] lemma setThreadState_Running_invs': - "\\s. invs' s \ tcb_at' t s \ ex_nonz_cap_to' t s - \ st_tcb_at' (Not \ is_BlockedOnReply) t s\ + "\\s. invs' s \ st_tcb_at' (Not \ is_BlockedOnReply) t s \ \ is_sched_linked t s\ setThreadState Running t \\rv. invs'\" apply (wpsimp wp: sts_invs') @@ -4681,62 +4503,21 @@ lemma setThreadState_Running_invs': done lemma setThreadState_BlockedOnReceive_invs': - "\\s. invs' s \ tcb_at' t s \ ep_at' eptr s \ ex_nonz_cap_to' t s \ - valid_bound_reply' rptr s \ - st_tcb_at' (Not \ is_BlockedOnReply) t s\ + "\\s. invs' s + \ st_tcb_at' (Not \ is_BlockedOnReply) t s \ st_tcb_at' (not inIPCQueueThreadState) t s\ setThreadState (BlockedOnReceive eptr cg rptr) t \\rv. invs'\" apply (simp add: invs'_def valid_dom_schedule'_def) - apply (wpsimp wp: sts_sch_act' setThreadState_ct_not_inQ valid_irq_node_lift simp: pred_tcb_at'_eq_commute) + apply (wpsimp wp: setThreadState_not_queued_valid_sched_pointers' valid_irq_node_lift + simp: pred_tcb_at'_eq_commute) apply (fastforce dest: global'_no_ex_cap - simp: valid_tcb_state'_def comp_def pred_tcb_at'_def obj_at'_def) + simp: comp_def pred_tcb_at'_def obj_at'_def) done -lemma ksReleaseQueue_ksReprogramTimer_update: - "ksReleaseQueue_update (\_. fv) (ksReprogramTimer_update (\_. gv) s) = - ksReprogramTimer_update (\_. gv) (ksReleaseQueue_update (\_. fv) s)" - by simp - -lemma ksPSpace_ksReprogramTimer_update: - "ksPSpace_update (\_. fv) (ksReprogramTimer_update (\_. gv) s) = - ksReprogramTimer_update (\_. gv) (ksPSpace_update (\_. fv) s)" - by simp - lemma tcbReleaseEnqueue_valid_mdb'[wp]: - "\valid_mdb' and valid_objs' and pspace_aligned' and pspace_distinct'\ - tcbReleaseEnqueue tcbPtr - \\_. valid_mdb'\" - apply (clarsimp simp: tcbReleaseEnqueue_def tcbQueueEmpty_def) - apply (wpsimp wp: tcbQueuePrepend_valid_mdb' tcbQueueAppend_valid_mdb' tcbQueueInsert_valid_mdb' - hoare_drop_imp[where f="threadSet f p" for f p] - hoare_drop_imp[where f="findTimeAfter f p" for f p] - getTCB_wp) - by (fastforce dest: obj_at'_tcbQueueHead_ksReleaseQueue obj_at'_tcbQueueEnd_ksReleaseQueue - simp: ksReleaseQueue_asrt_def tcbQueueEmpty_def) - -crunch tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" - (wp: threadSet_cap_to crunch_wps simp: tcb_cte_cases_def cteSizeBits_def) - -lemma tcbReleaseEnqueue_if_live_then_nonz_cap'[wp]: - "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - tcbReleaseEnqueue tcbPtr - \\_. if_live_then_nonz_cap'\" + "tcbReleaseEnqueue tcbPtr \valid_mdb'\" unfolding tcbReleaseEnqueue_def - apply (wpsimp wp: tcbQueuePrepend_if_live_then_nonz_cap' tcbQueueAppend_if_live_then_nonz_cap' - tcbQueueInsert_if_live_then_nonz_cap' - hoare_drop_imp[where f="threadSet f p" for f p] - hoare_drop_imp[where f="findTimeAfter f p" for f p] - getTCB_wp getTCBReadyTime_wp) - apply (drule (1) st_tcb_ex_cap'') - apply fastforce - apply (clarsimp simp: ksReleaseQueue_asrt_def) - apply (frule (3) obj_at'_tcbQueueHead_ksReleaseQueue) - apply (frule (3) obj_at'_tcbQueueEnd_ksReleaseQueue) - by (fastforce elim!: if_live_then_nonz_capE' - dest: heap_path_head intro: aligned'_distinct'_ko_wp_at'I - simp: tcbQueueEmpty_def opt_pred_def opt_map_def obj_at'_def live'_def)+ + by (wpsimp wp: getTCB_wp) crunch tcbReleaseEnqueue for valid_bitmaps[wp]: valid_bitmaps @@ -4744,10 +4525,8 @@ crunch tcbReleaseEnqueue lemma tcbReleaseEnqueue_invs'[wp]: "tcbReleaseEnqueue tcbPtr \invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) - apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift - untyped_ranges_zero_lift valid_replies'_lift - tcbReleaseEnqueue_valid_sched_pointers + apply (simp add: invs'_def valid_pspace'_def) + apply (wpsimp wp: valid_irq_node_lift untyped_ranges_zero_lift valid_replies'_lift simp: cteCaps_of_def o_def) done @@ -4755,74 +4534,78 @@ crunch postpone, schedContextResume for invs'[wp]: invs' (wp: crunch_wps simp: crunch_simps) -lemma maybeDonateSc_invs': - "\invs' and ex_nonz_cap_to' tptr\ maybeDonateSc tptr nptr \\_. invs'\" - apply (simp only: maybeDonateSc_def) - apply (wpsimp wp: schedContextDonate_invs' getNotification_wp threadGet_wp) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def sym_refs_asrt_def) - apply (erule if_live_then_nonz_capE'[OF invs_iflive']) - apply (drule_tac ko="ntfn :: notification" for ntfn in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def) - apply (auto simp: refs_of_rev' ko_wp_at'_def live'_def live_sc'_def) - done +lemma maybeDonateSc_invs'[wp]: + "maybeDonateSc tptr nptr \invs'\" + unfolding maybeDonateSc_def + by (wpsimp wp: schedContextDonate_invs' getNotification_wp threadGet_wp) lemma simple'_not_is_BlockedOnReply: "simple' st \ \ is_BlockedOnReply st" by (clarsimp simp: is_BlockedOnReply_def) +lemma ntfnSetActive_invs': + "\invs' and obj_at' (\ntfn. ntfnState ntfn = IdleNtfnState) ntfnptr\ + ntfnSetActive ntfnptr badge + \\_. invs'\" + apply (clarsimp simp: ntfnSetActive_def updateNotification_def) + apply (wpsimp wp: setNotification_invs' getNotification_wp hoare_vcg_all_lift) + apply (frule (1) ntfn_ko_at_valid_objs_valid_ntfn'[OF _ invs_valid_objs']) + apply (clarsimp simp: valid_ntfn'_def) + done + lemma sai_invs'[wp]: - "\invs' and ex_nonz_cap_to' ntfnptr\ sendSignal ntfnptr badge \\y. invs'\" - (is "valid ?pre _ _") + "sendSignal ntfnptr badge \invs'\" apply (simp add: sendSignal_def) apply (rule bind_wp[OF _ stateAssert_sp]) apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule_tac P'="?pre and ko_at' nTFN ntfnptr and valid_ntfn' nTFN and sym_refs_asrt - and (\s. sym_refs (state_refs_of' s))" in hoare_weaken_pre) - apply (case_tac "ntfnObj nTFN"; clarsimp) + apply (rule_tac P'="invs' and ko_at' nTFN ntfnptr and valid_ntfn' nTFN and sym_refs_asrt + and (\s. sym_refs (state_refs_of' s))" in hoare_weaken_pre) + apply (case_tac "ntfnState nTFN"; clarsimp) \ \IdleNtfn\ apply (case_tac "ntfnBoundTCB nTFN"; clarsimp) - apply (wp setNotification_invs') - apply (clarsimp simp: valid_ntfn'_def) + apply (wpsimp wp: ntfnSetActive_invs') + apply (clarsimp simp: obj_at'_def) apply (wp getSchedulable_wp) apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated]) apply (clarsimp simp: schedulable'_def) - apply (wpsimp wp: maybeDonateSc_invs' setThreadState_Running_invs' - setNotification_invs' gts_wp' cancelIPC_simple + apply (wpsimp wp: setThreadState_Running_invs' + setNotification_invs' getNotification_wp gts_wp' cancelIPC_simple + ntfnSetActive_invs' + cancelIPC_receiveBlocked_tcbSchedNexts_of + cancelIPC_receiveBlocked_tcbSchedPrevs_of simp: o_def | strengthen pred_tcb'_weakenE[mk_strg I _ O], rule simple'_not_is_BlockedOnReply, assumption)+ - apply (clarsimp simp: valid_ntfn'_def cong: conj_cong) - apply (erule if_live_then_nonz_capE'[OF invs_iflive']) - apply (drule_tac ko="ntfn :: notification" for ntfn in sym_refs_ko_atD'[rotated]) - apply fastforce - apply (fastforce simp: refs_of_rev' ko_wp_at'_def live'_def) + apply (clarsimp simp: valid_ntfn'_def st_tcb_at'_def obj_at'_def cong: conj_cong) \ \ActiveNtfn\ - apply (wpsimp wp: setNotification_invs' simp: valid_ntfn'_def) + apply (wpsimp wp: setNotification_invs' getNotification_wp + simp: updateNotification_def valid_ntfn'_def) + apply (clarsimp simp: valid_ntfn'_def st_tcb_at'_def obj_at'_def) \ \WaitingNtfn\ apply (rename_tac list) apply (case_tac list; clarsimp) apply (wp getSchedulable_wp) - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: schedulable'_def) - apply (wp maybeDonateSc_invs' setThreadState_Running_invs' setNotification_invs')+ - apply (clarsimp cong: conj_cong simp: valid_ntfn'_def) - apply (rule conjI) - apply (clarsimp split: option.splits list.splits) - apply (rule conjI) - apply (erule if_live_then_nonz_capE'[OF invs_iflive']) - apply (drule_tac ko="ntfn :: notification" for ntfn in sym_refs_ko_atD'[rotated]) - apply fastforce - apply (fastforce simp: refs_of_rev' ko_wp_at'_def live'_def) - apply (erule (1) thread_state_tcb_in_WaitingNtfn'_q[THEN pred_tcb'_weakenE]; fastforce?) - \ \resolve added preconditions\ - apply (clarsimp simp: sym_refs_asrt_def) - apply (erule_tac x=ntfnptr in valid_objsE'[OF invs_valid_objs']) - apply (fastforce simp: obj_at'_def) - apply (fastforce simp: valid_obj'_def valid_ntfn'_def) + apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated]) + apply (clarsimp simp: schedulable'_def) + apply (wp setThreadState_Running_invs' setNotification_invs' gts_wp')+ + apply (fastforce simp: ko_wp_at'_def st_tcb_at'_def obj_at'_def isBlockedOnNtfn_def + split: thread_state.splits) + apply (fastforce dest: ntfn_ko_at_valid_objs_valid_ntfn') done -crunch replyFromKernel - for nosch[wp]: "\s. P (ksSchedulerAction s)" +lemma replyFromKernel_corres: + "corres dc (tcb_at t and invs) invs' (reply_from_kernel t r) (replyFromKernel t r)" + apply (case_tac r) + apply (clarsimp simp: replyFromKernel_def reply_from_kernel_def + badge_register_def badgeRegister_def) + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF lookupIPCBuffer_corres]) + apply (rule corres_split[OF asUser_setRegister_corres]) + apply (rule corres_split_eqr[OF setMRs_corres], simp) + apply (rule setMessageInfo_corres) + apply (wp hoare_case_option_wp hoare_valid_ipc_buffer_ptr_typ_at' + | fastforce)+ + done crunch maybe_donate_sc for ntfn_at[wp]: "ntfn_at ntfnp" @@ -4832,130 +4615,118 @@ crunch maybe_donate_sc crunch maybeDonateSc for ntfn_at'[wp]: "ntfn_at' ntfnp" and tcb_at'[wp]: "\s. P (tcb_at' tp s)" - and pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - and pspace_bounded'[wp]: pspace_bounded' (simp: crunch_simps wp: crunch_wps) +crunch asUser + for obj_at'_notification[wp]: "\s. Q (obj_at' (P :: notification \ bool) p s)" + (wp: crunch_wps threadSet_obj_at'_ntfn) + lemma completeSignal_corres: "corres dc - (ntfn_at ntfnptr and tcb_at tcb and valid_objs and pspace_aligned and pspace_distinct + (ntfn_at ntfnptr and tcb_at tcbptr and valid_objs and pspace_aligned and pspace_distinct and (\s. sym_refs (state_refs_of s)) and (\s. (Ipc_A.isActive |< ntfns_of s) ntfnptr) and valid_sched and current_time_bounded) - (ntfn_at' ntfnptr and tcb_at' tcb and invs' and obj_at' isActive ntfnptr) - (complete_signal ntfnptr tcb) (completeSignal ntfnptr tcb)" + invs' + (complete_signal ntfnptr tcbptr) (completeSignal ntfnptr tcbptr)" supply opt_mapE[elim!] apply add_sym_refs + apply (rule_tac Q'="tcb_at' tcbptr" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross) apply (simp add: complete_signal_def completeSignal_def) - apply (rule corres_stateAssert_ignore, simp) - apply (rule corres_guard_imp) - apply (rule_tac R'="\ntfn. ntfn_at' ntfnptr and tcb_at' tcb and invs' - and valid_ntfn' ntfn and (\_. isActive ntfn)" - in corres_split[OF getNotification_corres]) - apply (rule corres_gen_asm2) - apply (case_tac "ntfn_obj rv") - apply (clarsimp simp: ntfn_relation_def isActive_def - split: ntfn.splits Structures_H.notification.splits)+ - apply (rule corres_guard2_imp) - apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split[OF setNotification_corres]) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ntfn_sp']) + apply (corres corres: getNotification_corres) + apply (rename_tac ntfn ntfn') + apply (case_tac "ntfn_obj ntfn"; clarsimp simp: ntfn_relation_def) + apply (corres corres: corres_underlying_fail_fail) + apply (clarsimp simp: opt_pred_def isActive_def obj_at_def split: option.splits ntfn.splits) + apply fastforce + apply (corres corres: corres_underlying_fail_fail) + apply (clarsimp simp: opt_pred_def isActive_def obj_at_def split: option.splits ntfn.splits) + apply fastforce + apply (rule stronger_corres_guard_imp) + apply (simp add: badgeRegister_def badge_register_def) + apply (rule corres_split[OF asUser_setRegister_corres]) + apply (clarsimp simp: updateNotification_def bind_assoc) + apply (rule corres_symb_exec_r'[where Q'="ntfn_at' ntfnptr"]) + apply (rename_tac ntfn'') + apply (rule_tac F="ntfn'' = ntfn'" in corres_gen_asm2) + apply (rule corres_split[OF setNotification_no_queue_update_corres], simp) apply (clarsimp simp: ntfn_relation_def) - apply (rule_tac P="tcb_at tcb and ntfn_at ntfnptr and valid_objs and pspace_aligned - and pspace_distinct and valid_sched - and (\s. sym_refs ((state_refs_of s)))" - and P'="tcb_at' tcb and ntfn_at' ntfnptr and valid_objs' - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded'" - in corres_inst) - apply (rule corres_guard_imp) - apply (rule corres_split[OF maybeDonateSc_corres]) - apply (rule corres_split_eqr[OF get_tcb_obj_ref_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (rule_tac P="bound_sc_tcb_at ((=) sc_opt) tcb and ntfn_at ntfnptr and valid_objs - and pspace_aligned and pspace_distinct - and active_scs_valid" - and P'="bound_sc_tcb_at' ((=) sc_opt) tcb and ntfn_at' ntfnptr and valid_objs' - and pspace_aligned' and pspace_distinct' and pspace_bounded'" - in corres_inst) - apply (rename_tac sc_opt; case_tac sc_opt; - simp add: maybeM_def liftM_def get_sk_obj_ref_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_sc_corres]) - apply (rename_tac scp sc sc') - apply (rule_tac P="sc_at scp and (\s. scs_of2 s scp = Some sc) and ntfn_at ntfnptr - and valid_objs and active_scs_valid - and pspace_aligned and pspace_distinct" - and P'="ko_at' sc' scp and ntfn_at' ntfnptr and valid_objs' - and pspace_aligned' and pspace_distinct' and pspace_bounded'" + apply (rule corres_split[OF maybeDonateSc_corres]) + apply (rule corres_split_eqr[OF get_tcb_obj_ref_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (rename_tac sc_opt) + apply (rule_tac P="bound_sc_tcb_at ((=) sc_opt) tcbptr and ntfn_at ntfnptr and valid_objs + and pspace_aligned and pspace_distinct + and active_scs_valid" + and P'="bound_sc_tcb_at' ((=) sc_opt) tcbptr and ntfn_at' ntfnptr and valid_objs' + and pspace_aligned' and pspace_distinct' and pspace_bounded'" in corres_inst) - apply (rule stronger_corres_guard_imp) - apply (rule corres_when2) - apply (clarsimp simp: sc_relation_def active_sc_def) - apply (rule corres_split[OF getNotification_corres]) - apply (rule corres_split[OF getCurSc_corres]) - apply (rule corres_when2) - apply (clarsimp simp: ntfn_relation_def) - apply (rule refillUnblockCheck_corres) - apply wpsimp - apply wpsimp - apply (wpsimp wp: get_simple_ko_wp) - apply (wpsimp wp: getNotification_wp) - apply (clarsimp simp: conj_commute) - apply (rule context_conjI) - apply (frule_tac sc_ptr=scp in sporadic_implies_active) - apply (clarsimp simp: projection_rewrites opt_pred_def opt_map_def) - apply (clarsimp simp: opt_pred_def opt_map_def vs_all_heap_simps - split: option.splits) - apply (fastforce dest: active_scs_validE[rotated] - simp: vs_all_heap_simps opt_map_red opt_pred_def - valid_refills_def rr_valid_refills_def) - apply (fastforce intro!: valid_objs'_valid_refills' - sporadic_implies_active_cross) - apply wpsimp - apply wpsimp - apply (clarsimp simp: pred_tcb_at_def obj_at_def valid_obj_def valid_tcb_def - dest!: sym[of "Some _"]) - apply (erule (1) valid_objsE[where x=tcb]) - apply (clarsimp simp: obj_at_def valid_obj_def valid_tcb_def is_sc_obj opt_map_red) - apply clarsimp - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def dest!: sym[of "Some _"]) - apply (erule (1) valid_objsE'[where x=tcb]) - apply (clarsimp simp: obj_at'_def valid_obj'_def valid_tcb'_def) - apply (wpsimp wp: get_tcb_obj_ref_wp threadGet_wp) - apply (wpsimp wp: get_tcb_obj_ref_wp threadGet_wp) - apply (rule_tac Q'="\_. tcb_at tcb and ntfn_at ntfnptr and valid_objs - and pspace_distinct and pspace_aligned and active_scs_valid" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_tcb_at_def obj_at_def opt_map_red) - apply (wpsimp wp: abs_typ_at_lifts) - apply (rule_tac Q'="\_. tcb_at' tcb and ntfn_at' ntfnptr and valid_objs' - and pspace_aligned' and pspace_distinct' and pspace_bounded'" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply wpsimp - 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 wp: set_notification_valid_sched) - apply wpsimp - apply (wpsimp simp: valid_ntfn_def) - apply (clarsimp simp: live_ntfn'_def valid_ntfn'_def) - apply wpsimp - apply (clarsimp simp: live_ntfn'_def valid_ntfn'_def invs'_def valid_pspace'_def) - apply (wpsimp wp: get_simple_ko_wp) - apply (wpsimp wp: getNotification_wp) - apply clarsimp - apply (clarsimp simp: valid_sched_def valid_sched_action_def invs_def valid_pspace_def valid_state_def) + apply (rename_tac sc_opt; case_tac sc_opt; + simp add: maybeM_def liftM_def get_sk_obj_ref_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF get_sc_corres]) + apply (rename_tac scp sc sc') + apply (rule_tac P="sc_at scp and (\s. scs_of2 s scp = Some sc) and ntfn_at ntfnptr + and valid_objs and active_scs_valid + and pspace_aligned and pspace_distinct" + and P'="ko_at' sc' scp and ntfn_at' ntfnptr and valid_objs' + and pspace_aligned' and pspace_distinct' and pspace_bounded'" + in corres_inst) + apply (rule stronger_corres_guard_imp) + apply (fold dc_def) + apply (rule corres_when2) + apply (clarsimp simp: sc_relation_def active_sc_def) + apply (rule corres_split[OF getNotification_corres]) + apply (rule corres_split[OF getCurSc_corres]) + apply (rule corres_when2) + apply (clarsimp simp: ntfn_relation_def) + apply (rule refillUnblockCheck_corres) + apply wpsimp + apply wpsimp + apply (wpsimp wp: get_simple_ko_wp) + apply (wpsimp wp: getNotification_wp) + apply (clarsimp simp: conj_commute) + apply (rule context_conjI) + apply (frule_tac sc_ptr=scp in sporadic_implies_active) + apply (clarsimp simp: projection_rewrites opt_pred_def opt_map_def) + apply (clarsimp simp: opt_pred_def opt_map_def vs_all_heap_simps + split: option.splits) + apply (fastforce dest: active_scs_validE[rotated] + simp: vs_all_heap_simps opt_map_red opt_pred_def + valid_refills_def rr_valid_refills_def) + apply (fastforce intro!: valid_objs'_valid_refills' + sporadic_implies_active_cross) + apply wpsimp + apply wpsimp + apply (clarsimp simp: pred_tcb_at_def obj_at_def valid_obj_def valid_tcb_def + dest!: sym[of "Some _"]) + apply (erule (1) valid_objsE[where x=tcbptr]) + apply (clarsimp simp: obj_at_def valid_obj_def valid_tcb_def is_sc_obj opt_map_red) + apply clarsimp + apply (clarsimp simp: obj_at'_def pred_tcb_at'_def dest!: sym[of "Some _"]) + apply (wpsimp wp: get_tcb_obj_ref_wp threadGet_wp) + apply (wpsimp wp: get_tcb_obj_ref_wp threadGet_wp) + apply (rule_tac Q'="\_. tcb_at tcbptr and ntfn_at ntfnptr and valid_objs + and pspace_distinct and pspace_aligned and active_scs_valid" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: pred_tcb_at_def obj_at_def opt_map_red) + apply (wpsimp wp: abs_typ_at_lifts) + apply (rule_tac Q'="\_. tcb_at' tcbptr and ntfn_at' ntfnptr and valid_objs' + and pspace_aligned' and pspace_distinct' and pspace_bounded'" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (wpsimp wp: getNotification_wp)+ + apply (wpsimp wp: as_user.tcb_agnostic_obj_at + simp: tcb_agnostic_pred_def is_tcb_def is_ntfn_def) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (clarsimp simp: valid_sched_def valid_sched_action_def invs_def) apply (drule (1) valid_objs_ko_at) - apply (clarsimp simp: valid_obj_def valid_ntfn_def fun_upd_def[symmetric]) - apply (clarsimp simp: state_refs_of_def get_refs_def2 obj_at_def ntfn_q_refs_of_def - Ipc_A.isActive_def fun_upd_idem - dest!: opt_predD split: Structures_A.ntfn.splits - elim!: opt_mapE) + apply (clarsimp simp: valid_obj_def valid_ntfn_def fun_upd_def[symmetric] + state_refs_of_def obj_at_def fun_upd_idem) apply (clarsimp simp: valid_pspace'_def invs'_def) apply (frule (1) ntfn_ko_at_valid_objs_valid_ntfn') - apply (clarsimp simp: obj_at'_def) + apply (clarsimp simp: obj_at'_def valid_ntfn'_def) done lemma ntfn_relation_par_inj: @@ -4980,7 +4751,7 @@ lemma maybeReturnSc_corres: and scheduler_act_not thread and active_scs_valid and pspace_distinct and weak_valid_sched_action and not_queued thread and not_in_release_q thread - and in_correct_ready_q and ready_qs_distinct and ready_or_release + and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable and ready_or_release and (\s. sym_refs (state_refs_of s))) (valid_tcbs' and sym_heap_sched_pointers and valid_sched_pointers and pspace_aligned' and pspace_distinct' and pspace_bounded') @@ -5009,7 +4780,9 @@ lemma maybeReturnSc_corres: apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_when [OF _ rescheduleRequired_corres], simp) apply (wpsimp wp: hoare_vcg_imp_lift')+ - apply (wpsimp wp: thread_set_in_correct_ready_q thread_set_weak_valid_sched_action2) + apply (wpsimp wp: thread_set_in_correct_ready_q thread_set_weak_valid_sched_action2 + thread_set_ep_queues_blocked thread_set_ntfn_queues_blocked + thread_set_ready_queues_runnable) apply (wpsimp wp: hoare_drop_imp threadSet_valid_tcbs' threadSet_sched_pointers threadSet_valid_sched_pointers) apply (wpsimp wp: thread_get_wp) @@ -5018,21 +4791,13 @@ lemma maybeReturnSc_corres: apply (wpsimp wp: threadGet_wp) apply (wpsimp wp: get_simple_ko_wp getNotification_wp)+ apply (rule valid_tcbs_valid_tcbE, simp, simp) - apply (clarsimp simp: valid_tcb_def valid_bound_obj_def split: option.splits) + apply (fastforce simp: valid_tcb_def valid_bound_obj_def split: option.splits) apply (rule cross_rel_srE [OF ntfn_at'_cross_rel [where t=ntfnPtr]], simp) - apply (fastforce dest: ko_at'_valid_tcbs'_valid_tcb' - simp: valid_tcb'_def valid_bound_obj'_def split: option.splits) - apply (clarsimp simp: sym_refs_asrt_def) + apply clarsimp + apply (fastforce dest: ko_at'_valid_tcbs'_valid_tcb' + simp: valid_tcb'_def valid_bound_obj'_def split: option.splits) done -lemma tcbEPDequeue_corres: - "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) \ (do_nbrecv_failed_transfer thread) (doNBRecvFailedTransfer thread)" @@ -5049,9 +4814,7 @@ crunch maybe_return_sc (wp: crunch_wps simp: crunch_simps) lemma maybeReturnSc_valid_objs'[wp]: - "\valid_objs' and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - maybeReturnSc ntfnPtr tcbPtr - \\_. valid_objs'\" + "maybeReturnSc ntfnPtr tcbPtr \valid_objs'\" apply (clarsimp simp: maybeReturnSc_def updateSchedContext_def) apply (wpsimp wp: threadSet_valid_objs' threadGet_wp getNotification_wp hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) @@ -5063,14 +4826,9 @@ lemma maybeReturnSc_valid_objs'[wp]: done lemma maybeReturnSc_valid_tcbs'[wp]: - "\valid_objs' and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - maybeReturnSc ntfnPtr tcbPtr - \\_. valid_tcbs'\" - apply (clarsimp simp: maybeReturnSc_def) - apply (wpsimp wp: threadSet_valid_tcbs' threadGet_wp getNotification_wp - hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift) - apply (fastforce simp: obj_at'_def) - done + "maybeReturnSc ntfnPtr tcbPtr \valid_tcbs'\" + unfolding maybeReturnSc_def + by (wpsimp wp: threadGet_wp getNotification_wp) lemma maybe_return_sc_weak_valid_sched_action: "\weak_valid_sched_action and scheduler_act_not tcb_ptr and tcb_at tcb_ptr\ @@ -5088,11 +4846,9 @@ lemma maybeReturnSc_invs': "maybeReturnSc nptr tptr \invs'\" apply (wpsimp wp: setSchedContext_invs' simp: maybeReturnSc_def updateSchedContext_def) apply (clarsimp simp add: invs'_def split del: if_split) - apply (wp threadSet_valid_pspace'T threadSet_sch_actT_P[where P=False, simplified] - threadSet_ctes_of threadSet_iflive'T threadSet_ifunsafe'T threadSet_idle'T - threadSet_not_inQ valid_irq_node_lift valid_irq_handlers_lift'' threadSet_cur - threadSet_ct_idle_or_in_cur_domain' untyped_ranges_zero_lift threadSet_cap_to' - threadGet_wp' getNotification_wp + apply (wp threadSet_valid_pspace'T threadSet_ctes_of threadSet_ifunsafe'T + valid_irq_node_lift valid_irq_handlers_lift'' + untyped_ranges_zero_lift threadGet_wp' getNotification_wp threadSet_sched_pointers threadSet_valid_sched_pointers hoare_vcg_imp_lift' hoare_vcg_all_lift valid_dom_schedule'_lift | clarsimp simp: tcb_cte_cases_def cteSizeBits_def cteCaps_of_def)+ @@ -5101,12 +4857,8 @@ lemma maybeReturnSc_invs': apply (rule_tac x=tcb in exI) apply (clarsimp simp: invs'_def inQ_def comp_def eq_commute[where a="Some _"]) apply (intro conjI impI allI; clarsimp?) - apply (clarsimp simp: untyped_ranges_zero_inv_def cteCaps_of_def comp_def) - apply (drule_tac ko="tcb" and p=tptr in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def) - apply (clarsimp simp: ko_wp_at'_def refs_of_rev') - apply (fastforce elim: if_live_then_nonz_capE' simp: ko_wp_at'_def live'_def live_sc'_def) - apply (fastforce simp: valid_pspace'_def valid_obj'_def valid_sched_context'_def refillSize_def) + apply (clarsimp simp: untyped_ranges_zero_inv_def cteCaps_of_def comp_def) + apply (fastforce simp: valid_obj'_def valid_sched_context'_def refillSize_def) apply (fastforce simp: valid_obj'_def valid_sched_context_size'_def objBits_def objBitsKO_def) done @@ -5146,16 +4898,12 @@ crunch receive_ipc_preamble and ex_nonz_cap_to[wp]: "ex_nonz_cap_to epptr" and idle_thread[wp]: "\s. P (idle_thread s)" and cte_wp_at[wp]: "cte_wp_at P x" + and scheduler_act_sane[wp]: scheduler_act_sane crunch receiveIPC_preamble for ep_at'[wp]: "ep_at' epptr" and tcb_at'[wp]: "tcb_at' t" and invs'[wp]: invs' - and cur_tcb'[wp]: cur_tcb' - -crunch maybeReturnSc - for cur_tcb'[wp]: cur_tcb' - (wp: crunch_wps threadSet_cur) lemma receiveIPC_preamble_vbreply'[wp]: "\\\ receiveIPC_preamble replyCap thread \valid_bound_reply'\" @@ -5165,7 +4913,10 @@ lemma receiveIPC_preamble_vbreply'[wp]: lemma receiveIPC_preamble_corres: assumes "cap_relation reply_cap replyCap" and "is_reply_cap reply_cap \ (reply_cap = cap.NullCap)" - shows "corres (=) (invs and valid_ready_qs and valid_cap reply_cap) invs' + shows + "corres (=) + (invs and valid_ready_qs and valid_release_q and ready_or_release and valid_cap reply_cap) + invs' (receive_ipc_preamble reply_cap thread) (receiveIPC_preamble replyCap thread)" supply if_split [split del] @@ -5232,44 +4983,122 @@ lemma receiveIPC_corres_helper: od)" by (case_tac replyCap; simp add: bind_assoc) -lemma maybeReturnSc_sch_act_wf_not_thread[wp]: - "maybeReturnSc ntnfnPtr tcbPtr \\s. sch_act_wf (ksSchedulerAction s) s\" - apply (clarsimp simp: maybeReturnSc_def) - apply (rule bind_wp_fwd_skip, solves wpsimp)+ - apply (rule hoare_when_cases, simp) - apply (rule bind_wp_fwd_skip, solves \wpsimp wp: threadSet_sch_act\)+ - apply wpsimp + +crunch ifCondRefillUnblockCheck + for reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" + (wp: crunch_wps simp: crunch_simps) + +crunch updateReply + for obj_at'_endpoint[wp]: "\s. Q (obj_at' (P :: endpoint \ bool) epPtr s)" + +lemma receiveIPCBlocked_corres: + "corres dc + (einvs and st_tcb_at runnable thread and not_queued thread and not_in_release_q thread + and not ep_queued thread and not ntfn_queued thread + and ep_at epptr and receive_ipc_preamble_rv reply_cap replyOpt) + (invs' and valid_bound_reply' replyOpt + and obj_at' (\ep. epState ep \ IdleEPState \ epState ep = ReceiveEPState) epptr) + (receive_ipc_blocked isBlocking thread epptr replyOpt) + (receiveIPCBlocked isBlocking thread epptr replyOpt)" + supply if_split[split del] + apply (rule_tac Q'="st_tcb_at' runnable' thread" in corres_cross_add_guard) + apply (fastforce intro: st_tcb_at_runnable_cross) + apply (rule_tac Q'="ep_at' epptr" in corres_cross_add_guard, fastforce intro!: ep_at_cross) + apply (rule_tac Q'="\s'. \ (tcbQueued |< tcbs_of' s') thread" in corres_cross_add_guard) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=thread]) + apply (clarsimp simp: not_queued_def in_ready_q_def) + apply (rule_tac Q'="\s'. \ (tcbInReleaseQueue |< tcbs_of' s') thread" in corres_cross_add_guard) + apply (frule state_relation_release_queue_relation) + apply (frule in_release_q_tcbInReleaseQueue_eq[where t=thread]) + apply (clarsimp simp: in_release_q_def) + apply (clarsimp simp: receive_ipc_blocked_def receiveIPCBlocked_def maybeM_def bool.case_eq_if) + apply (cases isBlocking; clarsimp) + apply (rule corres_guard_imp) + apply (rule corres_split[OF setThreadState_corres]) + apply (clarsimp simp: thread_state_relation_def) + apply (rule corres_split) + apply (clarsimp simp: when_def option.case_eq_if) + apply (subst if_swap) + apply (rule corres_if_strong[where R=\ and R'=\]) + apply fastforce + apply (rule replyTCB_update_corres) + apply (rule corres_return_trivial) + apply (rule tcbEPAppend_corres, simp, simp) + apply simp + apply (wpsimp wp: when_wp) + apply (wpsimp wp: when_wp updateReply_valid_objs') + apply (wpsimp wp: set_thread_state_ep_queues_blocked_not_queued + set_thread_state_ntfn_queues_blocked_not_queued + set_thread_state_ready_queues_runnable_not_queued + set_thread_state_release_q_runnable_not_in_release_q + hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (rule_tac Q'="\_ s. tcb_at' thread s \ \ is_sched_linked thread s + \ obj_at' (\ep. epState ep \ IdleEPState + \ epState ep = ReceiveEPState) + epptr s" + in hoare_post_imp) + apply (clarsimp simp: valid_reply'_def) + apply wpsimp + apply (wpsimp wp: hoare_vcg_imp_lift') + apply (clarsimp cong: conj_cong) + apply (frule invs_sym_refs) + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (cases replyOpt; fastforce simp: reply_at_ppred_def obj_at_def is_reply_def) + apply (fastforce dest!: runnable'_Not_tcbInReleaseQueue_not_sched_linked[rotated] + simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_red) + apply (corres corres: doNBRecvFailedTransfer_corres) + apply fastforce + apply fastforce done -lemma receiveIPC_preamble_sch_act_wf: - "\\s. sch_act_wf (ksSchedulerAction s) s \ sym_refs (state_refs_of' s)\ - receiveIPC_preamble replyCap thread - \\_ s. sch_act_wf (ksSchedulerAction s) s\" - apply (clarsimp simp: receiveIPC_preamble_def) - apply wpsimp - apply (fastforce dest: sym_ref_replyTCB_Receive_or_Reply - simp: st_tcb_at'_def obj_at_simps) - done +crunch refill_unblock_check + for ntfn_queued[wp]: "\s. P (ntfn_queued tcb_ptr s)" + and ep_queued[wp]: "\s. P (ep_queued tcb_ptr s)" + (wp: ntfn_queued_lift ep_queued_lift) -crunch ifCondRefillUnblockCheck - for reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" - (wp: crunch_wps simp: crunch_simps) +crunch maybeReturnSc + for obj_at'_endpoint[wp]: "\s. Q (obj_at' (P :: endpoint \ bool) p s)" + (wp: crunch_wps threadSet_obj_at'_ntfn) + +lemma receiveIPC_corres_sym_refs_helper: + "\sym_refs (state_refs_of s); ko_at (kernel_object.Endpoint (SendEP (sender # queue))) epptr s; + valid_ep (SendEP (sender # queue)) s; + st_tcb_at (\st. \data. st = Structures_A.thread_state.BlockedOnSend epptr data) sender s\ + \ sym_refs + (\p. if p = sender then tcb_non_st_state_refs_of s sender + else if p = epptr + then ep_q_refs_of + (case queue of + [] \ IdleEP + | a # list \ update_ep_queue + (SendEP (sender # queue)) + (removeAll sender (ep_queue (SendEP (sender # queue)))) True) + else state_refs_of s p)" + by (auto simp: ko_at_state_refs_ofD get_refs_def2 pred_tcb_at_def obj_at_def valid_ep_def + elim!: delta_sym_refs + split: list.splits if_splits) lemma receiveIPC_corres: - assumes "is_ep_cap cap" and "cap_relation cap cap'" and "cap_relation reply_cap replyCap" - and "is_reply_cap reply_cap \ (reply_cap = cap.NullCap)" + assumes "is_ep_cap cap" and "cap_relation cap cap'" + assumes "cap_relation reply_cap replyCap" + assumes "is_reply_cap reply_cap \ (reply_cap = cap.NullCap)" shows - "corres dc (einvs and valid_cap cap and current_time_bounded - and valid_cap reply_cap - and st_tcb_at active thread - and not_queued thread and not_in_release_q thread and scheduler_act_not thread - and tcb_at thread and ex_nonz_cap_to thread - and (\s. \r\zobj_refs reply_cap. ex_nonz_cap_to r s)) - (invs' and tcb_at' thread and valid_cap' cap' and valid_cap' replyCap) - (receive_ipc thread cap isBlocking reply_cap) (receiveIPC thread cap' isBlocking replyCap)" - (is "corres _ (_ and ?tat and ?tex and ?rrefs) _ _ _") + "corres dc + (einvs and valid_cap cap and current_time_bounded and valid_cap reply_cap + and st_tcb_at active thread and ex_nonz_cap_to thread + and not_queued thread and not_in_release_q thread + and scheduler_act_not thread and scheduler_act_sane + and (\s. \r\zobj_refs reply_cap. ex_nonz_cap_to r s)) + (invs' and valid_cap' cap' and valid_cap' replyCap) + (receive_ipc thread cap isBlocking reply_cap) + (receiveIPC thread cap' isBlocking replyCap)" + (is "corres _ (_ and _ and _ and ?rrefs) _ _ _") apply add_sch_act_wf apply add_valid_idle' + apply add_sym_refs supply if_split [split del] apply (insert assms) apply (rule corres_cross_add_abs_guard[where Q="K (thread \ idle_thread_ptr)"]) @@ -5277,336 +5106,354 @@ lemma receiveIPC_corres: apply (frule (1) idle_no_ex_cap) apply (clarsimp simp: valid_idle_def) apply (simp add: receive_ipc_def receiveIPC_def) - apply add_sym_refs apply (case_tac cap, simp_all add: isEndpointCap_def) apply (rename_tac epptr badge right) - apply (rule corres_stateAssert_assume) - apply (rule corres_stateAssert_assume[rotated]) - apply (clarsimp simp: sch_act_wf_asrt_def) - apply (rule corres_stateAssert_ignore) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (rule stronger_corres_guard_imp) - apply (subst receiveIPC_corres_helper) - apply (clarsimp simp: receive_ipc_preamble_def[symmetric] receiveIPC_preamble_def[symmetric]) - apply (rule corres_split[OF receiveIPC_preamble_corres], simp, simp) - apply (rule corres_split[OF getEndpoint_corres]) - apply (rename_tac ep ep') - apply (rule corres_split[OF getBoundNotification_corres]) - apply (rule_tac r'="ntfn_relation" in corres_split) - apply (rule corres_option_split[OF _ corres_returnTT getNotification_corres]; clarsimp) - apply (clarsimp simp: ntfn_relation_def default_notification_def default_ntfn_def) - apply (rule corres_if) - apply (clarsimp simp: ntfn_relation_def Ipc_A.isActive_def Endpoint_H.isActive_def - split: Structures_A.ntfn.splits Structures_H.notification.splits) - apply (simp only: ) - apply (rule completeSignal_corres) - apply (rule corres_split[where r'=dc]) - apply (rule corres_when; simp) - apply (rule maybeReturnSc_corres) - apply (rule_tac P="einvs and ?tat and ?tex and ep_at epptr - and valid_ep ep and ko_at (Endpoint ep) epptr - and current_time_bounded - and receive_ipc_preamble_rv reply_cap replyOpt and ?rrefs" and - P'="invs' and (\s. sch_act_wf (ksSchedulerAction s) s) - and tcb_at' thread and ep_at' epptr - and valid_ep' ep' and valid_bound_reply' replyOpt" - in corres_inst) - apply (rule_tac P'="valid_bound_obj' valid_replies'_sc_asrt replyOpt" and - P=\ in corres_add_guard) - apply (case_tac replyOpt; simp) - apply (erule valid_replies_sc_cross; clarsimp elim!: reply_at_ppred_reply_at) - apply (case_tac ep) - \ \IdleEP\ - apply (simp add: ep_relation_def) - apply (fold dc_def)[1] - apply (rule corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres], simp) - apply (rule corres_split[OF corres_when setEndpoint_corres], clarsimp) - apply (rule replyTCB_update_corres) - prefer 6 \ \ defer wp until corres complete \ - apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, clarsimp) - apply simp - apply (simp add: ep_relation_def) \ \ corres logic done \ - apply wpsimp+ - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def - valid_tcb_state_def st_tcb_at_tcb_at - split: option.splits) - apply (fastforce elim: ri_preamble_vbreply reply_at_ppred_reply_at) + apply (rule corres_stateAssert_assume[rotated], simp)+ + apply (rule corres_assert_gen_asm_cross_forwards) + apply (cases reply_cap; clarsimp simp: is_reply_cap_def isCap_simps) + apply (rule stronger_corres_guard_imp) + apply (subst receiveIPC_corres_helper) + apply (clarsimp simp: receive_ipc_preamble_def[symmetric] receiveIPC_preamble_def[symmetric]) + apply (rule corres_split[OF receiveIPC_preamble_corres], simp, simp) + apply (rule corres_stateAssert_r) + apply (rule corres_split[OF getEndpoint_corres]) + apply (rename_tac ep ep') + apply (rule corres_split[OF getBoundNotification_corres]) + apply (rule_tac r'="ntfn_relation" in corres_split) + apply (rule corres_option_split[OF _ corres_returnTT getNotification_corres]; clarsimp) + apply (clarsimp simp: ntfn_relation_def default_notification_def default_ntfn_def) + apply (rule corres_if) + apply (clarsimp simp: ntfn_relation_def Ipc_A.isActive_def + split: Structures_A.ntfn.splits Structures_H.notification.splits) + apply (simp only: ) + apply (rule completeSignal_corres) + apply (rule corres_split[where r'=dc]) + apply (rule corres_when; simp) + apply (rule maybeReturnSc_corres) + apply (rule_tac P="einvs and st_tcb_at runnable thread + and not_queued thread and not_in_release_q thread + and not ep_queued thread and not ntfn_queued thread + and ex_nonz_cap_to thread and ep_at epptr + and valid_ep ep and ko_at (kernel_object.Endpoint ep) epptr + and current_time_bounded + and receive_ipc_preamble_rv reply_cap replyOpt and ?rrefs" + and P'="invs' and tcb_at' thread and ko_at' ep' epptr + and valid_bound_reply' replyOpt" + in corres_inst) + apply (rule_tac P'="valid_bound_obj' valid_replies'_sc_asrt replyOpt" + in corres_add_guard[where P=\]) + apply (case_tac replyOpt; simp) + apply (erule valid_replies_sc_cross; clarsimp elim!: reply_at_ppred_reply_at) + apply (case_tac ep) + \ \IdleEP\ + apply (simp add: ep_relation_def) + apply (fold dc_def)[1] + apply (corres corres: receiveIPCBlocked_corres) apply fastforce + apply (clarsimp simp: obj_at'_def) \ \SendEP\ - apply (simp add: ep_relation_def get_tcb_obj_ref_def) - apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req) - apply (clarsimp simp: valid_ep_def) - apply (case_tac list, simp_all)[1] - apply (rename_tac sender queue) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setEndpoint_corres]) - apply (clarsimp simp: ep_relation_def split: list.splits) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule_tac F="\data. sender_state = Structures_A.thread_state.BlockedOnSend epptr data" - in corres_gen_asm) - apply (clarsimp simp: isSend_def case_bool_If - case_option_If if3_fold - cong: if_cong) - apply (rule corres_split[OF doIPCTransfer_corres]) - apply (rule corres_split_eqr[OF threadGet_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split[OF ifCondRefillUnblockCheck_corres]) - apply (rule corres_split[OF threadget_fault_corres]) - apply (simp cong: if_cong) - apply (fold dc_def)[1] - apply (rule_tac P="valid_objs and valid_mdb and valid_list and valid_arch_state - and valid_sched and valid_replies and valid_idle - and cur_tcb and current_time_bounded - and pspace_aligned and pspace_distinct - and st_tcb_at is_blocked_on_send sender and ?tat - and receive_ipc_preamble_rv reply_cap replyOpt - and valid_bound_obj (\r s. r \ fst ` replies_with_sc s) replyOpt - and (\s. sym_refs (\p. if p = sender - then tcb_non_st_state_refs_of s sender - else state_refs_of s p)) - and ?rrefs" - and P'="tcb_at' sender and tcb_at' thread - and sym_heap_sched_pointers - and valid_sched_pointers - and valid_objs' - and valid_bound_obj' valid_replies'_sc_asrt replyOpt - and pspace_aligned' and pspace_distinct' - and pspace_bounded' - and (\s. weak_sch_act_wf (ksSchedulerAction s) s)" - in corres_guard_imp [OF corres_if]) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_if2) - apply simp - apply (rule corres_split_eqr[OF threadGet_corres replyPush_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (clarsimp simp: fault_rel_optionation_def split: option.splits) - prefer 3 \ \ defer wp until corres complete \ - apply (rule setThreadState_corres, simp) + apply (simp add: ep_relation_def get_tcb_obj_ref_def) + apply (rename_tac list) + apply (rule_tac F="list \ []" in corres_req) + apply (clarsimp simp: valid_ep_def) + apply (case_tac list, simp_all)[1] + apply (rename_tac sender queue) + apply (rule_tac Q'="\s'. list_queue_relation + (sender # queue) (epQueue ep') + (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in corres_cross_add_guard) + apply (rule_tac p=epptr and s=s in ep_queues_relationD) + apply (clarsimp simp: eps_of_kh_def opt_map_red obj_at_def) + apply (clarsimp simp: opt_map_red obj_at'_def) + apply fastforce + apply (rule corres_stateAssert_ignore) + apply (rule list_queue_relation_tcb_queue_head_end_valid) + apply fastforce + apply (clarsimp simp: valid_ep_def) + apply (fastforce intro!: tcb_at_cross) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (fastforce dest: list_queue_relation_Nil) + apply (clarsimp simp: tcbQueueEmpty_def) + apply (rename_tac head) + apply (rule_tac F="head = sender" in corres_req) + apply clarsimp + apply (frule state_relation_ep_queues_relation) + apply (frule_tac p=epptr and ls="sender # queue" and q="epQueue ep'" + in ep_queues_relationD[rotated 2]) + apply (clarsimp simp: eps_of_kh_def obj_at_def opt_map_red) + apply (clarsimp simp: opt_map_def obj_at'_def split: option.splits) + apply (clarsimp simp: list_queue_relation_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF tcbEPDequeue_corres], simp, simp) + apply (clarsimp simp: ep_relation_def split: list.splits) + apply (rule corres_split[OF getThreadState_corres]) + apply (rule_tac F="\data. sender_state = Structures_A.BlockedOnSend epptr data" + in corres_gen_asm) + apply (clarsimp simp: isSend_def case_bool_If case_option_If if3_fold + cong: if_cong) + apply (rule corres_split[OF doIPCTransfer_corres]) + apply (rule corres_split_eqr[OF threadGet_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_split[OF ifCondRefillUnblockCheck_corres]) + apply (rule corres_split[OF threadget_fault_corres]) + apply (simp cong: if_cong) + apply (fold dc_def)[1] + apply (rule_tac P="valid_objs and valid_mdb and valid_list + and valid_sched and valid_replies and valid_idle + and cur_tcb and current_time_bounded + and ep_queues_blocked and ntfn_queues_blocked + and pspace_aligned and pspace_distinct + and st_tcb_at is_blocked_on_send sender + and tcb_at thread and not_queued sender + and not ep_queued sender and not ntfn_queued sender + and receive_ipc_preamble_rv reply_cap replyOpt + and valid_bound_obj + (\r s. r \ fst ` replies_with_sc s) replyOpt + and (\s. sym_refs + (\p. if p = sender + then tcb_non_st_state_refs_of s sender + else state_refs_of s p)) + and ?rrefs" + and P'="tcb_at' sender and tcb_at' thread + and (\s. \ is_sched_linked sender s) + and sym_heap_sched_pointers + and valid_sched_pointers + and valid_objs' + and valid_bound_obj' valid_replies'_sc_asrt replyOpt + and pspace_aligned' and pspace_distinct' + and pspace_bounded'" + in corres_guard_imp[OF corres_if]) + apply (simp add: fault_rel_optionation_def) + apply (rule corres_if2) + apply simp + apply (rule corres_split_eqr[OF threadGet_corres replyPush_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (clarsimp simp: fault_rel_optionation_def split: option.splits) prefer 3 \ \ defer wp until corres complete \ - apply (rule corres_split[OF setThreadState_corres], simp) - apply (rule possibleSwitchTo_corres, simp) - apply (wpsimp wp: set_thread_state_valid_sched_action) - apply wpsimp - apply wpsimp + apply (rule setThreadState_corres, simp) + prefer 3 \ \ defer wp until corres complete \ + apply (rule corres_split[OF setThreadState_corres], simp) + apply (rule possibleSwitchTo_corres, simp) + apply (wpsimp wp: set_thread_state_valid_sched_action + set_thread_state_ep_queues_blocked_not_queued + set_thread_state_ntfn_queues_blocked_not_queued + set_thread_state_ready_queues_runnable_not_queued) + apply (wpsimp wp: setThreadState_sched_pointers_valid_sched_pointers) apply wpsimp - apply clarsimp - apply (frule valid_objs_valid_tcbs) - apply (frule pred_tcb_at_tcb_at) - apply (frule (1) valid_sched_scheduler_act_not_better[OF _ st_tcb_weakenE]) - apply (clarsimp simp: is_blocked_on_send_def) - apply (frule (1) not_idle_thread', clarsimp simp: is_blocked_on_send_def) - apply (clarsimp simp: valid_sched_def valid_idle_def + apply wpsimp + apply clarsimp + apply (frule valid_objs_valid_tcbs) + apply (frule pred_tcb_at_tcb_at) + apply (frule (1) valid_sched_scheduler_act_not_better[OF _ st_tcb_weakenE]) + apply (clarsimp simp: is_blocked_on_send_def) + apply (frule (1) not_idle_thread', + clarsimp simp: is_blocked_on_send_def) + apply (clarsimp simp: valid_sched_def valid_idle_def + split: if_splits cong: conj_cong) + apply (prop_tac "not_in_release_q sender s") + apply (erule valid_release_q_not_in_release_q_not_runnable) + apply (fastforce simp: st_tcb_at_def obj_at_def runnable_eq_active) + apply (subgoal_tac "replyOpt \ None + \ the replyOpt \ fst ` replies_with_sc s") + apply (prop_tac "st_tcb_at (\st. reply_object st = None) sender s") + apply (fastforce elim!: pred_tcb_weakenE + simp: is_blocked_on_send_def) + apply (frule valid_sched_action_weak_valid_sched_action) + apply (clarsimp simp: valid_sched_def split: if_splits cong: conj_cong) - apply (prop_tac "not_in_release_q sender s") - apply (erule valid_release_q_not_in_release_q_not_runnable) - apply (fastforce simp: st_tcb_at_def obj_at_def runnable_eq_active) - apply (subgoal_tac "replyOpt \ None \ the replyOpt \ fst ` replies_with_sc s") - apply (prop_tac "st_tcb_at (\st. reply_object st = None) sender s") - apply (fastforce elim!: pred_tcb_weakenE simp: is_blocked_on_send_def) - apply (frule valid_sched_action_weak_valid_sched_action) - apply (clarsimp simp: valid_sched_def split: if_splits cong: conj_cong) - apply fastforce - apply (fastforce simp: image_def) - apply (clarsimp, frule valid_objs'_valid_tcbs') - apply (clarsimp simp: valid_sched_def split: if_splits - cong: conj_cong) - apply (case_tac replyOpt; simp) - apply wpsimp + subgoal by fastforce + apply (fastforce simp: image_def) + apply (clarsimp, frule valid_objs'_valid_tcbs') + apply (clarsimp simp: valid_sched_def split: if_splits + cong: conj_cong) + apply (case_tac replyOpt; simp) apply wpsimp - apply (wpsimp simp: if_cond_refill_unblock_check_def - wp: refill_unblock_check_valid_sched - valid_bound_obj_lift hoare_vcg_ball_lift) - apply (wpsimp wp: valid_bound_obj'_lift valid_replies'_sc_asrt_lift) - apply (rule_tac Q'="\rv. all_invs_but_sym_refs and valid_sched + apply wpsimp + apply (wpsimp simp: if_cond_refill_unblock_check_def + wp: refill_unblock_check_valid_sched + valid_bound_obj_lift hoare_vcg_ball_lift) + apply (wpsimp wp: valid_bound_obj'_lift valid_replies'_sc_asrt_lift) + apply (rule_tac Q'="\rv. all_invs_but_sym_refs and valid_sched + and ep_queues_blocked and ntfn_queues_blocked + and not_queued sender + and not ep_queued sender and not ntfn_queued sender and current_time_bounded and tcb_at sender - and tcb_at thread and st_tcb_at is_blocked_on_send sender + and tcb_at thread + and st_tcb_at is_blocked_on_send sender and (\s. \r\zobj_refs reply_cap. ex_nonz_cap_to r s) and valid_list and bound_sc_tcb_at ((=) rv) sender and (\s. sym_refs - (\p. if p = sender - then tcb_non_st_state_refs_of s sender - else state_refs_of s p)) - and valid_bound_obj (\r s. r \ fst ` replies_with_sc s) replyOpt + (\p. if p = sender + then tcb_non_st_state_refs_of s sender + else state_refs_of s p)) + and valid_bound_obj + (\r s. r \ fst ` replies_with_sc s) replyOpt and receive_ipc_preamble_rv reply_cap replyOpt" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_sched_active_scs_valid) - apply (rule conjI) - apply (rename_tac rv s; case_tac rv; simp) - apply (rule context_conjI) - apply (clarsimp simp: obj_at_def is_tcb pred_tcb_at_def) - apply (drule sym[of "Some _"]) - apply (erule_tac x=sender in valid_objsE, simp) - apply (clarsimp simp: obj_at_def is_sc_obj valid_tcb_def valid_obj_def) - apply (clarsimp simp: valid_sched_active_scs_valid - opt_map_red opt_pred_def obj_at_def is_sc_obj) - apply (clarsimp simp: obj_at_def is_tcb pred_tcb_at_def sc_tcb_sc_at_def - split: if_split) - apply (drule send_signal_WN_sym_refs_helper) - apply (prop_tac "heap_ref_eq x sender (tcb_scps_of s)") - apply (clarsimp simp: vs_all_heap_simps) - apply (drule_tac p=t and p'=sender in heap_refs_retract_inj_eq; simp) + in hoare_post_imp) + apply (clarsimp simp: valid_sched_active_scs_valid) + apply (rule conjI) + apply (rename_tac rv s; case_tac rv; simp) + apply (rule context_conjI) + apply (clarsimp simp: obj_at_def is_tcb pred_tcb_at_def) + apply (drule sym[of "Some _"]) + apply (erule_tac x=sender in valid_objsE, simp) + apply (clarsimp simp: obj_at_def is_sc_obj valid_tcb_def valid_obj_def) + apply (clarsimp simp: valid_sched_active_scs_valid + opt_map_red opt_pred_def obj_at_def is_sc_obj) + apply (clarsimp simp: obj_at_def is_tcb pred_tcb_at_def sc_tcb_sc_at_def + split: if_split) + apply (drule send_signal_WN_sym_refs_helper) + apply (prop_tac "heap_ref_eq x sender (tcb_scps_of s)") apply (clarsimp simp: vs_all_heap_simps) - apply (drule_tac t=t in valid_release_q_not_in_release_q_not_runnable - [OF valid_sched_valid_release_q]) - apply (clarsimp simp: is_blocked_on_send_def pred_tcb_at_def obj_at_def) - apply clarsimp - apply (wpsimp wp: thread_get_wp') - apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\rv. all_invs_but_sym_refs and valid_sched and valid_list - and current_time_bounded and tcb_at sender - and tcb_at thread and st_tcb_at is_blocked_on_send sender - and (\s. \r\zobj_refs reply_cap. ex_nonz_cap_to r s) - and (\s. sym_refs - (\p. if p = sender - then tcb_non_st_state_refs_of s sender - else state_refs_of s p)) - and valid_bound_obj (\r s. r \ fst ` replies_with_sc s) replyOpt - and receive_ipc_preamble_rv reply_cap replyOpt" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_sched_active_scs_valid) - apply (rename_tac opt; case_tac opt; clarsimp simp: obj_at_def is_tcb pred_tcb_at_def) - apply (wpsimp wp: do_ipc_transfer_tcb_caps hoare_vcg_ball_lift - valid_bound_obj_lift do_ipc_transfer_valid_arch) - apply (rule_tac Q'="\ya. (\s. tcb_at' sender s \ - tcb_at' thread s \ - sym_heap_sched_pointers s \ - valid_sched_pointers s \ - valid_objs' s \ - pspace_aligned' s \ pspace_distinct' s \ - pspace_bounded' s \ - valid_bound_obj' valid_replies'_sc_asrt replyOpt - s \ - sch_act_wf (ksSchedulerAction s) s)" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: sch_act_wf_weak obj_at'_def split: option.split) - 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 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 - valid_ep_def valid_pspace_def live_def) - apply (prop_tac "sender \ epptr") - apply (fastforce simp: valid_ep_def obj_at_def is_obj_defs) - apply (prop_tac "st_tcb_at (\st. \data. st = Structures_A.BlockedOnSend epptr data) sender s") - apply (drule (1) sym_refs_ko_atD) - apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) - apply (extract_conjunct \rule delta_sym_refs\) - subgoal - apply (erule delta_sym_refs) - 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 (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 (drule_tac p=t and p'=sender in heap_refs_retract_inj_eq; simp) + apply (clarsimp simp: vs_all_heap_simps) + apply (drule_tac t=t in valid_release_q_not_in_release_q_not_runnable[ + OF valid_sched_valid_release_q]) + apply (clarsimp simp: is_blocked_on_send_def pred_tcb_at_def obj_at_def) + apply clarsimp + apply (wpsimp wp: thread_get_wp') + apply (wpsimp wp: threadGet_wp) + apply (rule_tac Q'="\_. all_invs_but_sym_refs and valid_sched and valid_list + and ep_queues_blocked and ntfn_queues_blocked + and not_queued sender + and not ep_queued sender and not ntfn_queued sender + and current_time_bounded and tcb_at sender + and tcb_at thread and st_tcb_at is_blocked_on_send sender + and (\s. \r\zobj_refs reply_cap. ex_nonz_cap_to r s) + and (\s. sym_refs + (\p. if p = sender + then tcb_non_st_state_refs_of s sender + else state_refs_of s p)) + and valid_bound_obj + (\r s. r \ fst ` replies_with_sc s) replyOpt + and receive_ipc_preamble_rv reply_cap replyOpt" + in hoare_post_imp) + apply (clarsimp simp: valid_sched_active_scs_valid) + apply (rename_tac opt; case_tac opt; + clarsimp simp: obj_at_def is_tcb pred_tcb_at_def) + apply (wpsimp wp: do_ipc_transfer_tcb_caps hoare_vcg_ball_lift + valid_bound_obj_lift) + apply (rule_tac Q'="\_ s. tcb_at' sender s \ \ is_sched_linked sender s + \ tcb_at' thread s + \ sym_heap_sched_pointers s \ valid_sched_pointers s + \ valid_objs' s + \ pspace_aligned' s \ pspace_distinct' s + \ pspace_bounded' s + \ valid_bound_obj' valid_replies'_sc_asrt replyOpt s" + in hoare_post_imp) + apply (clarsimp simp: obj_at'_def split: option.split) + apply (wpsimp wp: valid_replies'_sc_asrt_lift valid_bound_obj'_lift) + apply (wpsimp wp: gts_st_tcb_at) + apply wpsimp + apply (wpsimp wp: tcb_ep_dequeue_not_ep_queued) + apply (wpsimp simp: tcb_ep_dequeue_def + wp: get_simple_ko_wp hoare_vcg_all_lift hoare_vcg_imp_lift' + hoare_vcg_ball_lift valid_bound_obj_lift) + apply (clarsimp simp: valid_pspace'_def 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 + valid_pspace_def live_def) + apply (prop_tac "sender \ epptr") + apply (fastforce simp: valid_ep_def obj_at_def is_obj_defs) + apply (prop_tac "st_tcb_at (\st. \data. st = Structures_A.BlockedOnSend epptr data) + sender s") + apply (force intro!: in_send_ep_queue_st_tcb_at simp: obj_at_def) + 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 (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (clarsimp cong: conj_cong) + apply (intro conjI impI allI; (solves clarsimp)?) + apply (clarsimp simp: in_ep_queue_at_def obj_at_def eps_of_kh_def opt_map_red) + apply (erule valid_ready_qs_not_queued_not_runnable) + apply (force elim!: st_tcb_weakenE) + apply (rule not_ntfn_blocked_not_ntfn_queued) + apply (force elim: st_tcb_weakenE + simp: ntfn_blocked_def split: thread_state.splits) + apply fastforce + apply (force elim: st_tcb_weakenE split: thread_state.splits) + apply (drule (1) ko_at_obj_congD) + apply clarsimp + apply (prop_tac "filter ((\) sender) queue = queue") + apply (fastforce simp: valid_ep_def filter_id_conv) + apply (force simp: removeAll_filter_not_eq intro!: receiveIPC_corres_sym_refs_helper) + 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 (fastforce simp: valid_ep'_def invs'_def split: list.split) - \ \RecvEP\ - apply (simp add: ep_relation_def) - apply (fold dc_def)[1] - apply (rule_tac corres_guard_imp) - apply (case_tac isBlocking; simp) - apply (rule corres_split[OF setThreadState_corres], simp) - apply (rule corres_split [where r=dc]) - apply (rule corres_when[OF _ replyTCB_update_corres], simp) - apply (rule corres_split[OF tcbEPAppend_corres setEndpoint_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 (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 (clarsimp simp: list_case_If split: if_splits) + apply (fastforce simp: invs'_def split: list.split) + \ \RecvEP\ + apply (simp add: ep_relation_def) + apply (fold dc_def)[1] + apply (corres corres: receiveIPCBlocked_corres) apply fastforce - \ \ end of ep cases \ - apply (rule_tac Q'="\_. einvs and ?tat and ?tex and - ko_at (Endpoint ep) epptr and current_time_bounded and - receive_ipc_preamble_rv reply_cap replyOpt and ?rrefs" - in hoare_strengthen_post[rotated]) - apply (clarsimp, intro conjI) - apply (clarsimp simp: obj_at_def is_ep) - apply (frule (1) valid_objs_ko_at[OF invs_valid_objs]) - apply (clarsimp simp: valid_obj_def) - apply (wpsimp wp: hoare_cte_wp_caps_of_state_lift valid_case_option_post_wp hoare_vcg_ball_lift) - apply (wpsimp wp: maybeReturnSc_invs' valid_case_option_post_wp) - apply simp - apply (wpsimp wp: get_simple_ko_wp) + apply (clarsimp simp: obj_at'_def) + \ \ end of ep cases \ + apply (rule_tac Q'="\_. einvs and st_tcb_at runnable thread + and not_queued thread and not_in_release_q thread + and ko_at (kernel_object.Endpoint ep) epptr + and current_time_bounded + and receive_ipc_preamble_rv reply_cap replyOpt and ?rrefs" + in hoare_post_imp) + apply clarsimp + apply (frule invs_sym_refs) + apply (intro conjI) + apply (rule not_ep_blocked_not_ep_queued) + apply (erule st_tcb_weakenE) + apply (case_tac st; clarsimp simp: ep_blocked_def) + apply fastforce + apply (rule not_ntfn_blocked_not_ntfn_queued) + apply (erule st_tcb_weakenE) + apply (case_tac st; clarsimp simp: ntfn_blocked_def) + apply fastforce + apply (fastforce elim: runnable_nonz_cap_to) + apply (clarsimp simp: obj_at_def is_ep) + apply (frule (1) valid_objs_ko_at[OF invs_valid_objs]) + apply (clarsimp simp: valid_obj_def) + apply (wpsimp wp: hoare_vcg_ball_lift) + apply (wpsimp wp: maybeReturnSc_invs' valid_case_option_post_wp) apply simp - apply (wpsimp wp: getNotification_wp) - apply (wpsimp wp: get_tcb_obj_ref_wp) - apply (wpsimp wp: gbn_wp') - apply (drule_tac s=reply in sym, simp) - apply (wpsimp wp: get_simple_ko_wp) - apply (wpsimp wp: getEndpoint_wp) - apply simp - apply (rule_tac Q'="\r. invs and ep_at epptr and valid_list and current_time_bounded - and scheduler_act_not thread and (\s. thread \ idle_thread s) - and valid_sched and ?tat and ?tex + apply (wpsimp wp: get_simple_ko_wp) + apply simp + apply (wpsimp wp: getNotification_wp) + apply (wpsimp wp: get_tcb_obj_ref_wp) + apply (wpsimp wp: gbn_wp') + apply (drule_tac s=reply in sym, simp) + apply (wpsimp wp: get_simple_ko_wp) + apply (wpsimp wp: getEndpoint_wp) + apply simp + apply (rule_tac Q'="\r. invs and ep_at epptr and valid_list and current_time_bounded + and scheduler_act_not thread and scheduler_act_sane + and (\s. thread \ idle_thread s) + and valid_sched and st_tcb_at runnable thread and receive_ipc_preamble_rv reply_cap r and not_queued thread and not_in_release_q thread and ?rrefs" - in hoare_strengthen_post[rotated]) - apply (subgoal_tac "\tcb. ko_at (TCB tcb) thread s \ - (case tcb_bound_notification tcb of - None \ \_. True - | Some x \ ntfn_at x) s") - apply clarsimp - 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 (clarsimp simp: invs_def valid_state_def valid_pspace_def obj_at_def is_ep is_tcb - is_ntfn opt_map_red opt_pred_def valid_sched_def valid_sched_action_def - valid_objs_valid_tcbs current_time_bounded_def - split: if_split) - apply (clarsimp, frule (1) valid_objs_ko_at[OF invs_valid_objs]) - apply (clarsimp simp: valid_obj_def valid_tcb_def valid_bound_obj_def case_option_ext) - apply (wpsimp wp: receive_ipc_preamble_invs receive_ipc_preamble_valid_sched - receive_ipc_preamble_rv hoare_vcg_ball_lift) - apply (rule_tac Q'="\replyOpt. ep_at' epptr and tcb_at' thread and invs' - and (\s. sch_act_wf (ksSchedulerAction s) s) and - (\_. thread \ idle_thread_ptr) and valid_bound_reply' replyOpt" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: invs'_def valid_pspace'_def split: if_split)[1] - apply (subgoal_tac "(\ko. ko_at' ko epptr s \ valid_ep' ko s) \ - (\ntfn. bound_tcb_at' ((=) ntfn) thread s \ valid_bound_ntfn' ntfn s)", - clarsimp) - apply (clarsimp simp: valid_bound_ntfn'_def case_option_ext) - apply (intro conjI; intro allI impI) - apply (intro conjI) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - apply fastforce - apply (intro conjI; clarsimp) - apply (erule ep_ko_at_valid_objs_valid_ep', clarsimp) - apply (clarsimp simp: pred_tcb_at'_def, frule obj_at_ko_at'[where p=thread], clarsimp) - apply (frule tcb_ko_at_valid_objs_valid_tcb', clarsimp) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def valid_tcb'_def) - apply (wpsimp wp: receiveIPC_preamble_sch_act_wf) - apply (clarsimp simp: valid_cap_def valid_idle_def invs_def valid_state_def valid_sched_def) - apply (clarsimp simp: valid_cap'_def) - apply (simp add: sym_refs_asrt_def) + in hoare_post_imp) + apply clarsimp + apply (intro conjI impI allI; clarsimp?) + apply (fastforce dest!: valid_objs_valid_tcb + simp: obj_at_def valid_tcb_def valid_bound_obj_def split: option.splits) + apply (rename_tac bound_ntfn ntfn) + apply (prop_tac "ntfn_at bound_ntfn s") + apply (clarsimp simp: obj_at_def is_ntfn_def) + apply (clarsimp split: if_splits) + apply (frule valid_sched_valid_ready_qs) + apply (fastforce simp: in_opt_pred opt_map_red obj_at_def) + apply (wpsimp wp: receive_ipc_preamble_invs receive_ipc_preamble_valid_sched + receive_ipc_preamble_st_tcb_at receive_ipc_preamble_rv hoare_vcg_ball_lift) + apply (rule_tac Q'="\replyOpt s. ep_at' epptr s \ tcb_at' thread s \ invs' s + \ thread \ idle_thread_ptr \ valid_bound_reply' replyOpt s" + in hoare_post_imp) + apply (fastforce split: if_split option.splits) + apply wpsimp + apply clarsimp + apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (frule valid_sched_ready_or_release) + apply (clarsimp simp: valid_cap_def valid_idle_def invs_def valid_state_def) + apply (erule st_tcb_weakenE) + apply (metis runnable_eq_active) + apply (fastforce intro!: tcb_at_cross simp: valid_cap'_def) done lemma as_user_refs_of[wp]: @@ -5619,142 +5466,444 @@ lemma as_user_refs_of[wp]: split: Structures_A.kernel_object.splits) done +lemma det_wp_tcb_append_set_notification[wp]: + "det_wp (\s. (\t \ set (ntfn_queue_of ntfn). tcb_at t s) + \ tcb_at tptr s \ ntfn_at ntfnPtr s) + (do qs' \ tcb_append tptr (ntfn_queue_of ntfn); + set_notification ntfnPtr (ntfn_set_obj ntfn (WaitingNtfn qs')) + od)" + by wpsimp + +lemmas no_fail_tcb_append_set_notification = det_wp_no_fail[OF det_wp_tcb_append_set_notification] + +lemma tcb_append_set_notification_empty_fail: + "empty_fail + (do q' \ tcb_append tptr qs; + set_notification ntfn_ptr (ntfn_set_obj notification (WaitingNtfn qs')) + od)" + by wpsimp + +lemmas tcb_append_ntfn_rules = + det_wp_tcb_append no_fail_tcb_append + det_wp_tcb_append_set_notification no_fail_tcb_append_set_notification + tcb_append_empty_fail tcb_append_set_notification_empty_fail + +method ipc_ntfn_append = + (rule det_wp_pre no_fail_pre, rule tcb_append_ntfn_rules, fastforce)[1] | wpsimp + +lemma tcbNTFNAppend_corres: + "\tcb_ptr = tcbPtr; ntfn_ptr = ntfnPtr\ \ + corres dc + (not ep_queued tcbPtr and not ntfn_queued tcbPtr + and not_queued tcbPtr and not_in_release_q tcbPtr and ntfn_at ntfn_ptr and tcb_at tcb_ptr + and ep_queues_blocked and ntfn_queues_blocked and ready_queues_runnable and release_q_runnable + and valid_objs and sorted_ipc_queues and in_correct_ready_q and ready_qs_distinct + and ready_or_release and pspace_aligned and pspace_distinct) + (\s. sym_heap_sched_pointers s \ valid_objs' s \ \ is_sched_linked tcbPtr s) + (tcb_ntfn_append tcb_ptr ntfn_ptr) (tcbNTFNAppend tcbPtr ntfnPtr)" + supply if_split[split del] tcb_append_rv_wf'[wp del] tcb_append_rv_wf''[wp del] + ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + heap_ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + apply (rule_tac Q'="tcb_at' tcb_ptr" in corres_cross_add_guard, fastforce intro!: tcb_at_cross) + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest!: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest!: pspace_distinct_cross) + apply (rule_tac Q'="ntfn_at' ntfnPtr" in corres_cross_add_guard, fastforce intro!: ntfn_at_cross) + apply (clarsimp simp: tcb_ntfn_append_def tcbNTFNAppend_def) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ntfn_sp']) + apply (corres corres: getNotification_corres) + apply (rename_tac ntfn ntfn') + apply (rule_tac Q="\s. ntfn_queues_of s ntfn_ptr = Some (ntfn_queue (ntfn_obj ntfn)) + \ valid_ntfn ntfn s + \ (\t \ set (ntfn_queue (ntfn_obj ntfn)). tcb_at t s) + \ sorted_wrt (img_ord (prios_of s) (opt_ord_rel (\))) (ntfn_queue (ntfn_obj ntfn))" + in corres_cross_add_abs_guard) + apply (intro context_conjI) + apply (fastforce simp: obj_at_def opt_map_red) + apply (fastforce intro: valid_objs_valid_ntfn simp: obj_at_def) + apply (case_tac "ntfn_obj ntfn"; clarsimp simp: valid_ntfn_def) + apply (fastforce intro!: sorted_ipc_queues_notification_priority_ordered) + apply (rule_tac Q'="\s'. tcb_ptr \ set (ntfn_queue (ntfn_obj ntfn)) + \ (\t \ set (ntfn_queue (ntfn_obj ntfn)). tcb_at' t s' + \ sched_flag_set s' t) + \ valid_ntfn' ntfn' s' + \ list_queue_relation + (ntfn_queue (ntfn_obj ntfn)) (ntfnQueue ntfn') + (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ (ntfn_queue (ntfn_obj ntfn) = [] \ ntfnQueue ntfn' = emptyQueue) + \ sorted_wrt (img_ord (\t. threadRead tcbPriority t s') + (opt_ord_rel (\))) (ntfn_queue (ntfn_obj ntfn))" + in corres_cross_add_guard) + apply clarsimp + apply (frule (3) in_ntfn_queue_sched_flag_set[where p=ntfn_ptr]) + apply force + apply (intro context_conjI) + apply (clarsimp simp: in_ntfn_queue_at_def ntfn_queued_def) + apply (fastforce dest: ntfn_ko_at_valid_objs_valid_ntfn') + apply (fastforce dest: ntfn_ko_at_valid_objs_valid_ntfn') + apply (fastforce intro!: ntfn_queues_relationD simp: opt_map_red obj_at'_def) + apply (fastforce dest: list_queue_relation_Nil_iff_emptyHeadEndPtrs) + apply clarsimp + apply (frule (1) sorted_ipc_queues_notification_priority_ordered) + apply (erule sorted_wrt_img_ord_eq_lift[THEN iffD1, rotated]) + apply (rename_tac t) + apply (simp flip: thread_read_Some_tcbs_of) + apply (rule_tac f="thread_read tcb_priority t" and g="threadRead tcbPriority t" + in rcorres_rrel_eq) + apply (rule threadGet_rcorres[where rrel="(=)"]) + apply (clarsimp simp: tcb_relation_def) + apply (frule state_relation_pspace_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation) + apply (fastforce intro!: no_ofailD[OF thread_read_no_ofail]) + apply (fastforce intro!: no_ofailD[OF no_ofail_threadRead_tcb_at']) + apply (rule corres_stateAssert_ignore) + apply (fastforce dest!: list_queue_relation_tcb_queue_head_end_valid) + apply (rule corres_underlying_from_rcorres) + apply (clarsimp simp: tcbAppend_def) + apply (rule_tac R="\_. ntfn_at' ntfnPtr" in no_fail_bind[where P=P and Q=P for P, simplified]) + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imps) + apply wpsimp + apply (wpsimp wp: no_fail_orderedInsert no_fail_stateAssert) + apply (meson no_ofailD[OF no_ofail_threadRead]) + apply (clarsimp simp: state_relation_def pspace_relation_heap_pspace_relation + heap_pspace_relation_def ghost_relation_heap_ghost_relation) + apply (rule_tac Q="\s s'. (\t \ set (ntfn_queue (ntfn_obj ntfn)). tcb_at t s) + \ (\t \ set (ntfn_queue (ntfn_obj ntfn)). tcb_at' t s') + \ (s, s') \ state_relation" + in rcorres_add_to_pre) + apply (intro context_conjI) + apply (case_tac "ntfn_obj ntfn"; clarsimp simp: valid_ntfn_def) + apply (fastforce intro: tcb_at_cross_tcbs_relation) + apply (clarsimp simp: state_relation_def pspace_relation_heap_pspace_relation + heap_pspace_relation_def ghost_relation_heap_ghost_relation) + apply (rcorres_conj_lift \fastforce\ + rule: det_wp_tcb_append_set_notification simp: tcbAppend_def)+ + apply (rule rcorres_conj_lift_fwd; (solves ipc_ntfn_append)?) + \ \ntfns_relation\ + apply (clarsimp simp: tcbAppend_def bind_assoc) + apply (rule rcorres_stateAssert_r_fwd) + apply (rule_tac Q="\ls q s s'. ntfns_relation s s' + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ ko_at (kernel_object.Notification ntfn) ntfnPtr s + \ ko_at' ntfn' ntfnPtr s'" + in rcorres_split) + apply (rule rcorres_from_valid_det) + apply wpsimp + apply (clarsimp simp: obj_at_def is_ntfn_def) + apply (drule in_set_notification) + apply (wpsimp wp: updateNotification_wp) + apply (clarsimp simp: projectKO_opts_defs map_relation_def ntfn_relation_def + obj_at_def is_ntfn_def obj_at'_def valid_ntfn'_def + split: if_splits ntfn.splits Structures_A.kernel_object.splits) + apply (rcorres rcorres: orderedInsert_rcorres threadGet_rcorres + simp: tcb_append_def tcbAppend_def tcb_relation_def) + apply (clarsimp simp: thread_read_Some_tcbs_of) + apply (rcorres_conj_lift \fastforce\ + rule: det_wp_tcb_append_set_notification simp: tcbAppend_def)+ + apply (rule rcorres_conj_lift_fwd; (solves ipc_ntfn_append)?) + \ \ep_queues_relation\ + apply (simp only: ep_queues_relation_def) + apply (rcorres rcorres: tcbAppend_rcorres_other rcorres_op_lifts) + apply (clarsimp simp: heap_pspace_relation_def in_ep_queue_at_def ep_queued_def) + apply (blast dest: ep_queues_ntfn_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves ipc_ntfn_append)?) + \ \ntfn_queues_relation\ + apply (clarsimp simp: bind_assoc) + apply (simp only: ntfn_queues_relation_def) + apply (rule rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac p) + apply (case_tac "p \ ntfnPtr") + apply (rule_tac Q="\_ _ s s'. ntfn_at ntfnPtr s + \ (\ls q. ntfn_queues_of s p = Some ls + \ ntfnQueues_of s' p = Some q + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + in rcorres_split) + apply (rcorres rcorres: rcorres_op_lifts + wp: set_notification_ntfn_queues_of_other + updateNotification_ntfnQueues_of_other) + apply fastforce + apply (rcorres rcorres: tcbAppend_rcorres_other rcorres_allI rcorres_imp_lift) + apply (clarsimp simp: in_ntfn_queue_at_def ntfn_queued_def heap_pspace_relation_def) + apply (blast dest: ntfn_queues_disjoint) + \ \p = ntfnPtr\ + apply (rule_tac Q="\ls q s s'. ntfn_at ntfnPtr s + \ list_queue_relation + ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in rcorres_split) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: updateNotification_wp) + apply (drule in_set_notification) + apply (clarsimp simp: obj_at'_def projectKO_opts_defs) + subgoal + by (fastforce simp: projectKO_opts_defs opt_map_def split: kernel_object.splits) + apply (rcorres rcorres: tcbAppend_rcorres) + apply (clarsimp simp: heap_pspace_relation_def thread_read_Some_tcbs_of) + apply (rule rcorres_conj_lift_fwd; (solves ipc_ntfn_append)?) + \ \ready_queues\ + apply (simp only: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (intro rcorres_allI_fwd; (solves ipc_ntfn_append)?) + apply (rename_tac d p) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rcorres rcorres: tcbAppend_rcorres_other rcorres_op_lifts) + apply (clarsimp simp: heap_pspace_relation_def not_queued_def) + apply (blast dest!: ntfn_queues_ready_queues_disjoint) + apply wpsimp + apply wpsimp + apply (rule rcorres_conj_lift_fwd; (solves ipc_ntfn_append)?) + \ \release_queue_relation\ + apply (simp only: release_queue_relation_def) + apply (rule_tac p=release_queue in rcorres_lift_abs) + apply (rule_tac p=ksReleaseQueue in rcorres_lift_conc) + apply (rcorres rcorres: tcbAppend_rcorres_other rcorres_op_lifts) + apply (clarsimp simp: heap_pspace_relation_def not_in_release_q_def) + apply (blast dest!: ntfn_queues_release_queue_disjoint) + apply wpsimp + apply wpsimp + by (rcorres_conj_lift \fastforce\ + rule: det_wp_tcb_append_set_notification + simp: tcbAppend_def)+ + +crunch tcb_ntfn_append, tcb_ep_append + for valid_tcbs[wp]: valid_tcbs + and pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + and weak_valid_sched_action[wp]: weak_valid_sched_action + and in_correct_ready_q[wp]: in_correct_ready_q + and ready_qs_distinct[wp]: ready_qs_distinct + and ready_queues_runnable[wp]: ready_queues_runnable + (wp: crunch_wps ready_queues_runnable_lift ignore: set_simple_ko) + +lemma tcbNTFNAppend_valid_objs'[wp]: + "\valid_objs' and tcb_at' tcbPtr\ tcbNTFNAppend tcbPtr ntfnPtr \\_. valid_objs'\" + unfolding tcbNTFNAppend_def updateNotification_def + apply (wpsimp wp: getNotification_wp hoare_vcg_all_lift hoare_vcg_imp_lift + simp: tcbAppend_def valid_ntfn'_def) + apply normalise_obj_at' + apply (frule (1) ntfn_ko_at_valid_objs_valid_ntfn') + apply (clarsimp simp: valid_ntfn'_def valid_bound_obj'_def split: option.splits) + done + +crunch tcbEPAppend + for valid_objs'[wp]: valid_objs' + (wp: crunch_wps) + +lemma tcbAppend_sym_heap_sched_pointers[wp]: + "\\s. \ is_sched_linked tcbPtr s\ tcbAppend tcbPtr q \\_. sym_heap_sched_pointers\" + unfolding tcbAppend_def + by (wpsimp wp: getNotification_wp) + +lemma tcbNTFNAppend_sym_heap_sched_pointers[wp]: + "\\s. \ is_sched_linked tcbPtr s\ tcbNTFNAppend tcbPtr ntfnPtr \\_. sym_heap_sched_pointers\" + unfolding tcbNTFNAppend_def + by (wpsimp wp: getNotification_wp) + +lemma tcbEPAppend_sym_heap_sched_pointers[wp]: + "tcbEPAppend tcbPtr epPtr isRecv \sym_heap_sched_pointers\" + unfolding tcbEPAppend_def + by (wpsimp wp: getEndpoint_wp) + +crunch tcbNTFNAppend, tcbEPAppend + for valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps) + +lemma setThreadState_inIPCQueueThreadState_valid_sched_pointers: + "\valid_sched_pointers_except tcbPtr and K (inIPCQueueThreadState st)\ + setThreadState st tcbPtr + \\_. valid_sched_pointers\" + unfolding setThreadState_def + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: valid_sched_pointers_def opt_pred_def) + done + +lemma inIPCQueueThreadState_sched_flag_set: + "\K (inIPCQueueThreadState st)\ setThreadState st tcbPtr \\_ s. sched_flag_set s tcbPtr\" + unfolding setThreadState_def scheduleTCB_def + by (wpsimp wp: threadSet_wp getSchedulable_wp) + +lemma receiveSignalBlocked_sym_refs_helper: + "\sym_refs (state_refs_of s); ntfn_obj ntfn = IdleNtfn \ (\q. ntfn_obj ntfn = WaitingNtfn q); + ko_at (kernel_object.Notification ntfn) ntfn_ptr s; st_tcb_at runnable thread s\ + \ sym_refs + (\a. if a = ntfn_ptr + then insert (thread, NTFNSignal) + (set (ntfn_queue (ntfn_obj ntfn)) \ {NTFNSignal} + \ get_refs NTFNBound (ntfn_bound_tcb ntfn) + \ get_refs NTFNSchedContext (ntfn_sc ntfn)) + else if a = thread + then insert (ntfn_ptr, TCBSignal) (tcb_non_st_state_refs_of s thread) + else state_refs_of s a)" + by (elim disjE; erule delta_sym_refs; clarsimp split: if_split_asm; + fastforce simp: state_refs_of_def get_refs_def2 tcb_st_refs_of_def pred_tcb_at_def obj_at_def + runnable_eq_active + split: if_split_asm option.splits) + +lemma receiveSignalBlocked_corres: + "ntfn_obj ntfn = IdleNtfn \ ntfn_obj ntfn = WaitingNtfn queue \ + corres dc + (ko_at (kernel_object.Notification ntfn) ntfn_ptr + and invs and weak_valid_sched_action and scheduler_act_not thread + and valid_ready_qs and valid_release_q and sorted_ipc_queues and ready_or_release + and active_scs_valid + and st_tcb_at runnable thread and not_queued thread and not_in_release_q thread) + invs' + (receive_signal_blocked thread ntfn_ptr isBlocking) + (receiveSignalBlocked thread ntfn_ptr isBlocking)" + apply (rule_tac Q'="st_tcb_at' runnable' thread" in corres_cross_add_guard) + apply (fastforce intro: st_tcb_at_runnable_cross) + apply (rule_tac Q'="\s'. \ (tcbQueued |< tcbs_of' s') thread" in corres_cross_add_guard) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=thread]) + apply (clarsimp simp: not_queued_def in_ready_q_def) + apply (rule_tac Q'="\s'. \ (tcbInReleaseQueue |< tcbs_of' s') thread" in corres_cross_add_guard) + apply (frule state_relation_release_queue_relation) + apply (frule in_release_q_tcbInReleaseQueue_eq[where t=thread]) + apply (clarsimp simp: in_release_q_def) + apply (clarsimp simp: receive_signal_blocked_def receiveSignalBlocked_def) + apply (cases isBlocking; simp) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF setThreadState_corres]) + apply (clarsimp simp: thread_state_relation_def) + apply (rule corres_split[OF tcbNTFNAppend_corres], simp, simp) + apply (rule maybeReturnSc_corres) + apply (wpsimp wp: abs_typ_at_lifts get_simple_ko_wp + simp: tcb_ntfn_append_def) + apply ((wpsimp | strengthen valid_objs'_valid_tcbs')+)[1] + apply (wpsimp wp: set_thread_state_ep_queues_blocked_not_queued + set_thread_state_ntfn_queues_blocked_not_queued + set_thread_state_ready_queues_runnable_not_queued + set_thread_state_release_q_runnable_not_in_release_q + set_thread_state_weak_valid_sched_action + hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (wpsimp wp: setThreadState_inIPCQueueThreadState_valid_sched_pointers + inIPCQueueThreadState_sched_flag_set) + apply clarsimp + apply (frule invs_sym_refs) + apply (clarsimp cong: conj_cong) + apply (intro conjI impI allI; fastforce?) + apply (clarsimp simp: valid_tcb_state_def obj_at_def is_ntfn_def) + apply (rule runnable_not_ep_queued; fastforce) + apply (rule runnable_not_ntfn_queued; fastforce) + apply (clarsimp simp: obj_at_def is_ntfn_def) + apply (drule (1) ko_at_obj_congD)+ + apply (force intro!: receiveSignalBlocked_sym_refs_helper) + apply (clarsimp cong: conj_cong) + apply (frule invs_valid_sched_pointers) + apply (frule (1) runnable'_Not_tcbInReleaseQueue_not_sched_linked[rotated]) + apply (fastforce simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_red) + apply (fastforce simp: valid_sched_pointers_except_def) + apply (corres corres: doNBRecvFailedTransfer_corres) + apply fastforce + apply fastforce + done + lemma receiveSignal_corres: - "\ is_ntfn_cap cap; cap_relation cap cap' \ \ + "\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 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') + (invs and weak_valid_sched_action and scheduler_act_not thread and valid_ready_qs + and st_tcb_at runnable thread and active_scs_valid and valid_release_q + and sorted_ipc_queues and current_time_bounded + 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' (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" - (is "\_;_\ \ corres _ (?pred and _) _ _ _") + apply (rule_tac Q'="tcb_at' thread" in corres_cross_add_guard, fastforce intro!: tcb_at_cross) + apply (rule_tac Q'="\s'. \ (tcbQueued |< tcbs_of' s') thread" in corres_cross_add_guard) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=thread]) + apply (clarsimp simp: not_queued_def in_ready_q_def) + apply (rule_tac Q'="\s'. \ (tcbInReleaseQueue |< tcbs_of' s') thread" in corres_cross_add_guard) + apply (frule state_relation_release_queue_relation) + apply (frule in_release_q_tcbInReleaseQueue_eq[where t=thread]) + apply (clarsimp simp: in_release_q_def) apply (simp add: receive_signal_def receiveSignal_def) apply add_sym_refs apply add_valid_idle' - apply (rule corres_stateAssert_assume) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (case_tac cap, simp_all add: isEndpointCap_def) - apply (rename_tac cap_ntfn_ptr badge rights) - apply (rule_tac Q="\rv. ?pred and tcb_at thread and ntfn_at cap_ntfn_ptr - and valid_ntfn rv and obj_at ((=) (Notification rv)) cap_ntfn_ptr" - and Q'="\rv'. invs' and ex_nonz_cap_to' thread - and tcb_at' thread and ntfn_at' cap_ntfn_ptr - and valid_ntfn' rv' and ko_at' rv' cap_ntfn_ptr" - in corres_underlying_split) - apply (corresKsimp corres: getNotification_corres - simp: ntfn_at_def2 valid_cap_def st_tcb_at_tcb_at valid_cap'_def) - defer - apply (wpsimp wp: get_simple_ko_wp) - apply (fastforce simp: valid_cap_def obj_at_def valid_obj_def - dest: invs_valid_objs) - apply (wpsimp wp: getNotification_wp) - apply (fastforce simp: obj_at'_def valid_obj'_def - dest: invs_valid_objs') - apply (clarsimp simp: sym_refs_asrt_def) - apply (case_tac "ntfn_obj rv"; clarsimp simp: ntfn_relation_def) - apply (case_tac isBlocking; simp) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setThreadState_corres]) - apply (clarsimp simp: thread_state_relation_def) - apply (rule corres_split[OF setNotification_corres]) - apply (wpsimp wp: maybe_return_sc_weak_valid_sched_action) - apply (clarsimp simp: ntfn_relation_def) - apply (rule maybeReturnSc_corres) - apply wpsimp - apply wpsimp - apply (wpsimp wp: set_thread_state_weak_valid_sched_action) - apply wpsimp - apply clarsimp - apply (rule conjI, fastforce simp: valid_tcb_state_def valid_ntfn_def)+ - 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 - split: if_split_asm option.splits)+ - apply (fastforce simp: valid_tcb_state'_def) - apply (corresKsimp corres: doNBRecvFailedTransfer_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) - apply (rule corres_split[OF tcbEPAppend_corres]) - apply (rule corres_split[OF setNotification_corres]) - apply (wpsimp wp: maybe_return_sc_weak_valid_sched_action) - apply (clarsimp simp: ntfn_relation_def) - apply (rule maybeReturnSc_corres) - apply wpsimp - apply wpsimp - apply wpsimp - apply wpsimp - 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 (rule corres_stateAssert_assume[rotated], solves simp)+ + apply (rule corres_symb_exec_r[OF _ isRunnable_sp]; (solves wpsimp)?) + apply (rule corres_assert_gen_asm_cross_forwards) + apply (fastforce intro: st_tcb_at_runnable_cross) + apply (rule corres_stateAssert_ignore) + apply clarsimp + apply (frule invs_valid_sched_pointers) + apply (erule (2) valid_sched_pointersD[simplified]) + apply (fastforce dest: runnable'_not_inIPCQueueThreadState) + apply (case_tac cap, simp_all add: isEndpointCap_def) + apply (rename_tac cap_ntfn_ptr badge rights) + apply (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ntfn_sp']) + apply (corres corres: getNotification_corres) + apply (fastforce simp: valid_cap_def) + apply fastforce + apply (rename_tac ntfn ntfn') + apply (case_tac "ntfn_obj ntfn"; clarsimp simp: ntfn_relation_def) + apply (corres corres: receiveSignalBlocked_corres) 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 - split: if_split_asm option.splits)+ - apply (fastforce simp: valid_tcb_state'_def valid_ntfn'_def) - apply (corresKsimp corres: doNBRecvFailedTransfer_corres) + apply fastforce + apply fastforce + apply (corres corres: receiveSignalBlocked_corres) + apply fastforce + apply fastforce apply fastforce \ \ActiveNtfn\ apply (rule corres_guard_imp) apply (clarsimp simp: badge_register_def badgeRegister_def) apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split[OF setNotification_corres]) - apply (clarsimp simp: ntfn_relation_def) - apply (rule corres_split[OF maybeDonateSc_corres]) - apply (rule corres_split_eqr[OF get_tcb_obj_ref_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (rule ifCondRefillUnblockCheck_corres) - apply (wpsimp wp: get_tcb_obj_ref_wp) - apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\_. tcb_at thread and active_scs_valid and pspace_distinct - and pspace_aligned and valid_objs" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: obj_at_def is_tcb) - apply (clarsimp split: option.splits) - apply (erule (1) valid_objsE) - apply (fastforce simp: valid_obj_def valid_tcb_def obj_at_def opt_map_def opt_pred_def - is_sc_obj) - apply (wpsimp wp: abs_typ_at_lifts) - apply (rule_tac Q'="\_. tcb_at' thread and valid_objs'" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: obj_at'_def split: option.split) - apply wpsimp - apply (wpsimp wp: set_ntfn_minor_invs) - apply (wpsimp wp: set_ntfn_minor_invs') - apply (wpsimp wp: hoare_vcg_imp_lift' simp: valid_ntfn_def) - apply (wpsimp wp: hoare_vcg_imp_lift') - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply (clarsimp simp: obj_at_def live_def live_ntfn_def valid_ntfn_def) + apply (clarsimp simp: updateNotification_def bind_assoc) + apply (rule_tac Q'="ntfn_at' cap_ntfn_ptr" in corres_symb_exec_r') + apply (rename_tac ntfn'') + apply (rule_tac F="ntfn'' = ntfn'" in corres_gen_asm2) + apply (rule corres_split[OF setNotification_no_queue_update_corres], simp) + apply (clarsimp simp: ntfn_relation_def) + apply (rule corres_split[OF maybeDonateSc_corres]) + apply (rule corres_split_eqr[OF get_tcb_obj_ref_corres]) + apply (clarsimp simp: tcb_relation_def) + apply (rule ifCondRefillUnblockCheck_corres[unfolded dc_def]) + apply (wpsimp wp: get_tcb_obj_ref_wp) + apply (wpsimp wp: threadGet_wp) + apply (rule_tac Q'="\_. tcb_at thread and active_scs_valid and pspace_distinct + and pspace_aligned and valid_objs" + in hoare_post_imp) + apply (clarsimp simp: obj_at_def is_tcb) + apply (clarsimp split: option.splits) + apply (erule (1) valid_objsE) + apply (fastforce simp: valid_obj_def valid_tcb_def obj_at_def opt_map_def opt_pred_def + is_sc_obj) + apply (wpsimp wp: abs_typ_at_lifts) + apply (rule_tac Q'="\_. tcb_at' thread and valid_objs' and pspace_bounded'" + in hoare_post_imp) + apply (clarsimp simp: obj_at'_def split: option.split) + apply wpsimp + apply (wpsimp wp: set_ntfn_minor_invs) + apply (wpsimp wp: set_ntfn_minor_invs') + apply (wpsimp wp: getNotification_wp) + apply wpsimp + apply wpsimp + apply (wpsimp wp: as_user.tcb_agnostic_obj_at simp: valid_ntfn_def) + apply (clarsimp simp: tcb_agnostic_pred_def) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') + apply (clarsimp cong: conj_cong) + apply (intro conjI impI allI; fastforce?) + apply (clarsimp simp: obj_at_def) + apply (clarsimp simp: valid_cap_def) + apply (frule invs_valid_objs) + apply (fastforce simp: valid_cap_def valid_objs_def valid_obj_def obj_at_def valid_ntfn_def) + apply (frule invs_sym_refs) apply (frule_tac p=cap_ntfn_ptr in sym_refs_ko_atD[rotated]) apply (fastforce simp: obj_at_def) apply clarsimp apply (fold fun_upd_def) apply (drule sym[of "state_refs_of _ _"]) apply simp - apply (fastforce intro!: if_live_then_nonz_capE' - simp: valid_ntfn'_def obj_at'_def live_ntfn'_def ko_wp_at'_def) + apply (clarsimp cong: conj_cong) + apply (intro conjI impI allI; fastforce?) + apply (clarsimp simp: obj_at'_def) + apply (frule (1) ntfn_ko_at_valid_objs_valid_ntfn'[OF _ invs_valid_objs']) + apply (clarsimp simp: valid_ntfn'_def obj_at'_def) + apply (fastforce simp: obj_at'_def) done declare lookup_cap_valid' [wp] @@ -5770,7 +5919,8 @@ lemma sendFaultIPC_corres: "corres (=) (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 st_tcb_at active thread and scheduler_act_not thread + and st_tcb_at runnable thread and scheduler_act_not thread + and not_queued thread and not_in_release_q thread and current_time_bounded and (\s. can_donate \ bound_sc_tcb_at (\sc. sc \ None) thread s) and valid_cap cap and K (valid_fault_handler cap) and K (valid_fault f)) @@ -5792,12 +5942,10 @@ lemma sendFaultIPC_corres: apply (wpsimp wp: threadSet_invs_trivial thread_set_invs_but_fault_tcbs thread_set_no_change_tcb_state thread_set_no_change_tcb_sched_context thread_set_cte_wp_at_trivial ex_nonz_cap_to_pres hoare_weak_lift_imp - thread_set_in_correct_ready_q + thread_set_in_correct_ready_q thread_set_ready_queues_runnable + thread_set_release_q_runnable simp: ran_tcb_cap_cases valid_cap_def)+ - apply (frule pred_tcb_at_tcb_at, clarsimp) - apply (rule conjI, fastforce?)+ - apply (erule (1) st_tcb_ex_cap[OF _ invs_iflive]) - apply (case_tac st; clarsimp) + apply fastforce apply (frule cross_relF[OF _ tcb_at'_cross_rel[where t=thread]], fastforce) apply (fastforce simp: invs'_def valid_tcb_def valid_cap'_def obj_at'_def inQ_def) done @@ -5856,7 +6004,6 @@ lemma st_tcb_idle': (t = ksIdleThread s) \ P IdleThreadState" by (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) - crunch setExtraBadge, receiveIPC for it[wp]: "\s. P (ksIdleThread s)" and irqs_masked' [wp]: "irqs_masked'" @@ -5869,48 +6016,24 @@ crunch copyMRs, doIPCTransfer and ct'[wp]: "\s. P (ksCurThread s)" (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) -lemma asUser_ct_not_inQ[wp]: - "\ct_not_inQ\ asUser tptr f \\rv. ct_not_inQ\" - apply (simp add: asUser_def split_def) - apply (wp hoare_drop_imps threadSet_not_inQ | simp)+ - done - -crunch copyMRs, doIPCTransfer - for ct_not_inQ[wp]: "ct_not_inQ" - (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) - -lemma ntfn_q_refs_no_bound_refs': - "rf : ntfn_q_refs_of' (ntfnObj ob) \ rf ~: ntfn_bound_refs' (ntfnBoundTCB ob')" - by (auto simp add: ntfn_q_refs_of'_def ntfn_bound_refs'_def - split: Structures_H.ntfn.splits) - lemma completeSignal_invs': - "\invs' and tcb_at' tcb and ex_nonz_cap_to' tcb\ - completeSignal ntfnptr tcb - \\_. invs'\" + "completeSignal ntfnptr tcb \invs'\" apply (simp add: completeSignal_def) - apply (rule bind_wp[OF _ stateAssert_sp]) apply (rule bind_wp[OF _ get_ntfn_sp']) apply (wpsimp wp: refillUnblockCheck_invs' threadGet_wp) - apply (rule hoare_strengthen_post[where Q'="\_. invs'"]) - apply (wpsimp wp: maybeDonateSc_invs') - apply (clarsimp simp: obj_at'_def) - apply (wpsimp wp: set_ntfn_minor_invs') - apply (wpsimp wp: hoare_vcg_ex_lift hoare_weak_lift_imp simp: valid_ntfn'_def) + apply (rule hoare_strengthen_post[where Q'="\_. invs'"]) + apply wpsimp + apply (clarsimp simp: obj_at'_def) + apply (wpsimp wp: set_ntfn_minor_invs' getNotification_wp simp: updateNotification_def) + apply (wpsimp wp: hoare_vcg_ex_lift hoare_weak_lift_imp hoare_vcg_all_lift + hoare_vcg_imp_lift') + apply wpsimp apply wpsimp - apply clarsimp - apply (intro conjI impI) - apply (fastforce dest: ntfn_ko_at_valid_objs_valid_ntfn' - simp: valid_ntfn'_def) - apply (fastforce intro: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def live'_def live_ntfn'_def) + apply normalise_obj_at' + apply (frule (1) ntfn_ko_at_valid_objs_valid_ntfn'[OF _ invs_valid_objs']) + apply (fastforce simp: valid_ntfn'_def) done -lemma maybeReturnSc_ex_nonz_cap_to'[wp]: - "maybeReturnSc nptr tptr \ex_nonz_cap_to' t\" - by (wpsimp wp: hoare_drop_imps threadSet_cap_to' - simp: maybeReturnSc_def tcb_cte_cases_def cteCaps_of_def) - lemma maybeReturnSc_st_tcb_at'[wp]: "maybeReturnSc nptr tptr \\s. P (st_tcb_at' Q t s)\" by (wpsimp wp: hoare_drop_imps threadSet_cap_to' threadSet_pred_tcb_no_state @@ -5918,70 +6041,63 @@ lemma maybeReturnSc_st_tcb_at'[wp]: crunch scheduleTCB for invs'[wp]: invs' - and ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' p" - and valid_ntfn'[wp]: "valid_ntfn' ntfn" - and valid_bound_tcb'[wp]: "valid_bound_tcb' tcb" - and valid_bound_sc'[wp]: "valid_bound_sc' sc" - (wp: hoare_drop_imps) 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) +crunch tcbNTFNAppend + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: crunch_wps) + +lemma tcbNTFNAppend_invs': + "\\s. invs' s \ tcb_at' tcbPtr s \ sched_flag_set s tcbPtr \ \ is_sched_linked tcbPtr s\ + tcbNTFNAppend tcbPtr ntfnPtr + \\_. invs'\" + apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift + simp: cteCaps_of_def o_def) done -(* t = ksCurThread s *) -lemma rai_invs'[wp]: - "\invs' and st_tcb_at' active' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) - and (\s. \ntfnptr. isNotificationCap cap - \ capNtfnPtr cap = ntfnptr - \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) ntfnptr s)\ - receiveSignal t cap isBlocking +lemma tcbEPAppend_invs': + "\\s. invs' s \ tcb_at' tcbPtr s \ sched_flag_set s tcbPtr\ + tcbEPAppend tcbPtr ntfnPtr isRecv \\_. invs'\" - apply (simp add: receiveSignal_def doNBRecvFailedTransfer_def valid_idle'_asrt_def) - apply (intro bind_wp [OF _ stateAssert_sp]) - apply (rule bind_wp [OF _ get_ntfn_sp']) - apply (rename_tac ep) - apply (case_tac "ntfnObj ep"; clarsimp) + apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift + simp: cteCaps_of_def o_def) + done + +(* t = ksCurThread s *) +lemma receiveSignal_invs'[wp]: + "receiveSignal t cap isBlocking \invs'\" + apply (simp add: receiveSignal_def doNBRecvFailedTransfer_def) + apply (intro bind_wp[OF _ stateAssert_sp]) + apply (intro bind_wp[OF _ isRunnable_sp]) + apply (intro bind_wp[OF _ assert_sp]) + apply (intro bind_wp[OF _ stateAssert_sp]) + apply (rule bind_wp [OF _ get_ntfn_sp'], rename_tac ntfn) + apply (case_tac "ntfnState ntfn"; clarsimp) \ \IdleNtfn\ - apply (wpsimp wp: setNotification_invs' maybeReturnSc_invs' sts_invs_minor' - simp: live'_def live_ntfn'_def) - apply (clarsimp simp: pred_tcb_at' cong: conj_cong) - apply (fastforce simp: valid_idle'_def idle_tcb'_def valid_tcb_state'_def valid_ntfn'_def - valid_bound_obj'_def valid_obj'_def valid_cap'_def isCap_simps - pred_tcb_at'_def obj_at'_def - dest: invs_valid_objs' split: option.splits) + apply (clarsimp simp: receiveSignalBlocked_def) + apply (wpsimp wp: inIPCQueueThreadState_sched_flag_set + setThreadState_nonqueued_state_update maybeReturnSc_invs' tcbNTFNAppend_invs') + apply (rule conjI) + apply (erule pred_tcb'_weakenE) + apply (rename_tac st, case_tac st; clarsimp) + apply fastforce \ \ActiveNtfn\ - apply (wpsimp wp: maybeDonateSc_invs' setNotification_invs' hoare_vcg_imp_lift') - apply (fastforce simp: valid_obj'_def valid_ntfn'_def isCap_simps - pred_tcb_at'_def obj_at'_def + apply (wpsimp wp: setNotification_invs' getNotification_wp hoare_vcg_imp_lift' hoare_vcg_all_lift + simp: updateNotification_def) + apply (fastforce simp: valid_obj'_def valid_ntfn'_def obj_at'_def dest: invs_valid_objs') \ \WaitingNtfn\ - apply (wpsimp wp: setNotification_invs' maybeReturnSc_invs') - apply (clarsimp simp: valid_ntfn'_def cong: conj_cong) - 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) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def valid_tcb_state'_def valid_cap'_def - isCap_simps sym_refs_asrt_def pred_tcb_at'_def obj_at'_def) - apply (rule conjI, clarsimp) - apply (rule conjI, clarsimp) - 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 (clarsimp simp: receiveSignalBlocked_def) + apply (wpsimp wp: inIPCQueueThreadState_sched_flag_set + setThreadState_nonqueued_state_update maybeReturnSc_invs' tcbNTFNAppend_invs') + apply (rule conjI) + apply (erule pred_tcb'_weakenE) + apply (rename_tac st, case_tac st; clarsimp) + apply fastforce done lemma updateReply_reply_at'_wp: @@ -6044,10 +6160,8 @@ crunch setEndpoint (wp: crunch_wps) lemma replyPush_sym_refs_list_refs_of_replies': - "\(\s. sym_refs (list_refs_of_replies' s)) - and valid_replies' - and valid_objs' - and (\s. replyTCBs_of s replyPtr = None) and sym_heap_scReplies\ + "\(\s. sym_refs (list_refs_of_replies' s)) and valid_replies' and valid_objs' + and sym_heap_scReplies\ replyPush callerPtr calleePtr replyPtr canDonate \\_ s. sym_refs (list_refs_of_replies' s)\" supply if_split [split del] @@ -6061,60 +6175,14 @@ lemma replyPush_sym_refs_list_refs_of_replies': \ is_reply_linked replyPtr s \ replySCs_of s replyPtr = None)" in hoare_strengthen_post[rotated]) apply (fastforce split: if_splits simp del: comp_apply) - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' updateReply_list_refs_of_replies'_inv threadGet_wp)+ + apply (prop_tac "replyTCBs_of s replyPtr = None") + apply (clarsimp simp: obj_at'_def opt_map_red) apply (frule valid_replies'_no_tcb_not_linked; clarsimp) apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def sym_heap_def pred_map_eq) done -lemma replyPush_if_live_then_nonz_cap': - "\ if_live_then_nonz_cap' and valid_objs' and - ex_nonz_cap_to' replyPtr and ex_nonz_cap_to' callerPtr and ex_nonz_cap_to' calleePtr and - sym_heap_tcbSCs and sym_heap_scReplies and (\s. callerPtr \ ksIdleThread s) and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct' and pspace_bounded'\ - replyPush callerPtr calleePtr replyPtr canDonate - \\_. if_live_then_nonz_cap'\" - supply if_split [split del] opt_mapE[elim!] - apply (clarsimp simp: replyPush_def bind_assoc) - apply (intro bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ threadGet_sp']) - apply (rule bind_wp[OF _ threadGet_sp']) - apply (wpsimp wp: schedContextDonate_if_live_then_nonz_cap' bindScReply_if_live_then_nonz_cap') - apply (rule_tac Q'="\_. if_live_then_nonz_cap' and ex_nonz_cap_to' replyPtr and - valid_objs' and reply_at' replyPtr and ex_nonz_cap_to' calleePtr and - sym_heap_sched_pointers and valid_sched_pointers and - pspace_aligned' and pspace_distinct' and pspace_bounded' and - (if (\y. scPtrOptDonated = Some y) \ scPtrOptCallee = None \ canDonate - then \s. ex_nonz_cap_to' (the scPtrOptDonated) s \ - (\rp. (scReplies_of s) (the scPtrOptDonated) = Some rp \ - (replySCs_of s) rp = Some (the scPtrOptDonated)) - else \)" in hoare_strengthen_post[rotated], clarsimp split: if_splits simp: pred_map_eq) - apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift' hoare_vcg_all_lift) - apply (clarsimp cong: conj_cong) - apply (wpsimp wp: updateReply_iflive'_weak updateReply_reply_at'_wp updateReply_valid_objs' - hoare_vcg_all_lift hoare_vcg_imp_lift' updateReply_obj_at') - apply clarsimp - apply (intro conjI) - apply (clarsimp simp: valid_reply'_def obj_at'_def) - apply (intro allI impI, clarsimp) - apply (rename_tac s scp) - apply (subgoal_tac "sc_at' scp s \ (scTCBs_of s) scp = Some callerPtr \ callerPtr \ idle_thread_ptr") - apply (intro conjI) - apply (erule if_live_then_nonz_capE') - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def pred_map_def pred_map_eq_def live'_def live_sc'_def) - apply (clarsimp simp: sym_heap_def) - apply (intro conjI) - apply (frule obj_at_ko_at'[where p=callerPtr], clarsimp) - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') - apply (clarsimp simp: valid_tcb'_def) - apply (subgoal_tac "(tcbSCs_of s) callerPtr = Some scp") - apply (clarsimp simp: sym_heap_def) - apply (clarsimp simp: opt_map_def obj_at'_real_def ko_wp_at'_def) - apply (clarsimp simp: valid_idle'_def valid_idle'_asrt_def) - done - lemma replyPush_untyped_ranges_zero'[wp]: "replyPush callerPtr calleePtr replyPtr canDonate \untyped_ranges_zero'\" apply (clarsimp simp: untyped_ranges_zero_inv_null_filter_cteCaps_of) @@ -6127,20 +6195,16 @@ crunch replyPush (simp: crunch_simps wp: crunch_wps) lemma replyPush_invs': - "\invs' and sym_heap_tcbSCs and sym_heap_scReplies and - st_tcb_at' (Not \ is_replyState) callerPtr and reply_at' replyPtr and - ex_nonz_cap_to' callerPtr and ex_nonz_cap_to' calleePtr and - ex_nonz_cap_to' replyPtr and (\s. replyTCBs_of s replyPtr = None)\ + "\invs' and sym_heap_scReplies\ replyPush callerPtr calleePtr replyPtr canDonate \\_. invs'\" unfolding invs'_def valid_pspace'_def - apply (wpsimp wp: replyPush_if_live_then_nonz_cap' replyPush_sym_refs_list_refs_of_replies' - simp: valid_pspace'_def) - apply (frule global'_no_ex_cap; clarsimp simp: valid_pspace'_def) - done + by (wpsimp wp: replyPush_sym_heap_sched_pointers replyPush_valid_sched_pointers + replyPush_sym_refs_list_refs_of_replies' + simp: valid_pspace'_def) lemma setEndpoint_invs': - "\invs' and valid_ep' ep and ex_nonz_cap_to' eptr\ setEndpoint eptr ep \\_. invs'\" + "setEndpoint eptr ep \invs'\" by (wpsimp simp: invs'_def valid_dom_schedule'_def comp_def) crunch maybeReturnSc, cancelIPC @@ -6204,23 +6268,6 @@ crunch cancelSignal, replyRemoveTCB, replyUnlink for ep_obj_at'[wp]: "obj_at' (P :: endpoint \ bool) eptr" (wp: crunch_wps simp: crunch_simps) -lemma blockedCancelIPC_notin_epQueue: - "\valid_objs' and obj_at' (\ep. ep \ IdleEP \ t \ set (epQueue ep)) eptr\ - blockedCancelIPC state tptr reply_opt - \\rv. obj_at' (\ep. ep \ IdleEP \ t \ set (epQueue ep)) eptr\" - unfolding blockedCancelIPC_def getBlockingObject_def - apply (wpsimp wp: set_ep'.obj_at' getEndpoint_wp) - apply (fastforce simp: valid_obj'_def valid_ep'_def obj_at'_def - intro: set_remove1[where y=tptr] split: endpoint.splits list.splits) - done - -lemma cancelIPC_notin_epQueue: - "\valid_objs' and obj_at' (\ep. ep \ IdleEP \ t \ set (epQueue ep)) eptr\ - cancelIPC tptr - \\rv. obj_at' (\ep. ep \ IdleEP \ t \ set (epQueue ep)) eptr\" - unfolding cancelIPC_def - by (wpsimp wp: blockedCancelIPC_notin_epQueue hoare_drop_imps threadSet_valid_objs') - crunch rescheduleRequired for scs_tcbs_of[wp]: "\s. P (tcbSCs_of s) (scTCBs_of s)" (wp: crunch_wps threadSet_tcbSCs_of_inv ignore: threadSet) @@ -6432,106 +6479,102 @@ crunch refillUnblockCheck crunch ifCondRefillUnblockCheck for sym_heap_tcbSCs[wp]: sym_heap_tcbSCs and sym_heap_scReplies[wp]: sym_heap_scReplies + and obj_at'_tcb[wp]: "\s. Q (obj_at' (P :: tcb \ bool) tcbPtr s)" (simp: crunch_simps wp: crunch_wps) +lemma tcbEPDequeue_invs'[wp]: + "tcbEPDequeue t epPtr \invs'\" + apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (wpsimp wp: valid_irq_node_lift) + done + +lemma getBoundNotification_tcb_at'[wp]: + "getBoundNotification t \\s. P (tcb_at' tcbPtr s)\" + by wpsimp + (* t = ksCurThread s *) lemma ri_invs' [wp]: - "\invs' and st_tcb_at' active' t - and ex_nonz_cap_to' t - and (\s. \r \ zobj_refs' replyCap. ex_nonz_cap_to' r s) - and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) - and valid_cap' replyCap\ - receiveIPC t cap isBlocking replyCap - \\_. invs'\" (is "\?pre\ _ \_\") - supply if_split [split del] - apply (clarsimp simp: receiveIPC_def sym_refs_asrt_def sch_act_wf_asrt_def valid_idle'_asrt_def + "\invs' and st_tcb_at' active' t\ + receiveIPC t cap isBlocking replyCap + \\_. invs'\" + apply (clarsimp simp: receiveIPC_def split: if_split) - apply (intro bind_wp[OF _ stateAssert_sp]) + apply (intro bind_wp[OF _ stateAssert_sp] bind_wp[OF _ assert_sp]) apply (rule bind_wp) apply (rule bind_wp) + apply (rule bind_wp) \ \After getEndpoint, the following holds regardless of the type of ep\ - apply (rule_tac Q'="\ep s. invs' s \ sch_act_wf (ksSchedulerAction s) s - \ ex_nonz_cap_to' t s \ ex_nonz_cap_to' (capEPPtr cap) s \ - sym_heap_tcbSCs s \ sym_heap_scReplies s \ - st_tcb_at' simple' t s \ t \ ksIdleThread s \ - (\x. replyOpt = Some x \ ex_nonz_cap_to' x s \ - reply_at' x s \ replyTCBs_of s x = None) \ - ko_at' ep (capEPPtr cap) s \ - (ep_at' (capEPPtr cap) s \ - obj_at' (\ep. ep \ IdleEP \ t \ set (epQueue ep)) (capEPPtr cap) s)" + apply (rule_tac Q'="\ep s. invs' s \ sym_heap_tcbSCs s \ sym_heap_scReplies s + \ st_tcb_at' simple' t s + \ (\ptr. replyOpt = Some ptr + \ reply_at' ptr s \ replyTCBs_of s ptr = None) + \ ko_at' ep (capEPPtr cap) s" in bind_wp) apply (rule_tac P'1="\s. \rptr. replyOpt = Some rptr \ \ is_reply_linked rptr s" - in hoare_pre_add[THEN iffD2]) + in hoare_pre_add[THEN iffD2]) apply clarsimp apply (frule valid_replies'_no_tcb; clarsimp) apply (rename_tac ep) - apply (case_tac ep; clarsimp) - \ \RecvEP\ - apply (wpsimp wp: completeSignal_invs' setEndpoint_invs' setThreadState_BlockedOnReceive_invs' - maybeReturnSc_invs' updateReply_replyTCB_invs' tcbEPAppend_valid_RecvEP + apply (case_tac "epState ep"; clarsimp) + apply (find_goal \match premises in "epState _ = IdleEPState" \ -\) + apply (clarsimp simp: receiveIPCBlocked_def) + apply (wpsimp wp: completeSignal_invs' tcbEPAppend_invs' + setThreadState_BlockedOnReceive_invs' maybeReturnSc_invs' + updateReply_replyTCB_invs' inIPCQueueThreadState_sched_flag_set getNotification_wp gbn_wp' hoare_vcg_all_lift hoare_vcg_const_imp_lift - simp: if_fun_split + simp: receiveIPCBlocked_def if_fun_split | wp (once) hoare_false_imp)+ - apply (clarsimp simp: pred_tcb_at') - apply (erule valid_objsE'[OF invs_valid_objs']) - apply (fastforce simp: obj_at'_def) - apply (fastforce simp: valid_obj'_def valid_ep'_def pred_tcb_at'_def obj_at'_def) - \ \IdleEP\ - apply (wpsimp wp: completeSignal_invs' setEndpoint_invs' setThreadState_BlockedOnReceive_invs' - maybeReturnSc_invs' updateReply_replyTCB_invs' getNotification_wp gbn_wp' + apply (fastforce simp: valid_obj'_def pred_tcb_at'_def obj_at'_def) + apply (find_goal \match premises in "epState _ = ReceiveEPState" \ -\) + apply (clarsimp simp: receiveIPCBlocked_def) + apply (wpsimp wp: completeSignal_invs' tcbEPAppend_invs' setThreadState_BlockedOnReceive_invs' + maybeReturnSc_invs' updateReply_replyTCB_invs' + inIPCQueueThreadState_sched_flag_set getNotification_wp gbn_wp' hoare_vcg_all_lift hoare_vcg_const_imp_lift - simp: if_fun_split + simp: receiveIPCBlocked_def if_fun_split | wp (once) hoare_false_imp)+ - apply (fastforce simp: valid_obj'_def valid_ep'_def pred_tcb_at'_def obj_at'_def) + apply (fastforce simp: valid_obj'_def pred_tcb_at'_def obj_at'_def) \ \SendEP\ + apply (rule bind_wp[OF _ gbn_sp']) apply (wpsimp wp: replyPush_invs' completeSignal_invs' sts_invs' setThreadState_st_tcb threadGet_wp) - apply (rename_tac sender queue senderState badge canGrant canGrantReply scOpt) - apply (rule_tac Q'="\_. invs' - and (\s. sch_act_wf (ksSchedulerAction s) s) and tcb_at' t - and st_tcb_at' (Not \ is_replyState) sender - and sym_heap_tcbSCs and sym_heap_scReplies - and ex_nonz_cap_to' sender and ex_nonz_cap_to' t - and (\s. \x. replyOpt = Some x \ reply_at' x s \ - replyTCBs_of s x = None \ ex_nonz_cap_to' x s)" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_tcb_at'_eq_commute) - apply (fastforce simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def - is_BlockedOnReply_def is_BlockedOnReceive_def) - apply (wpsimp wp: ifCondRefillUnblockCheck_invs' hoare_vcg_all_lift hoare_vcg_imp_lift') - apply (rule_tac Q'="\_. invs' and (\s. sch_act_wf (ksSchedulerAction s) s) - and tcb_at' t and st_tcb_at' (Not \ is_replyState) x21 + apply (rename_tac scOpt) + apply (rule_tac Q'="\_. invs' and tcb_at' t + and st_tcb_at' (Not \ is_replyState) + (the (tcbQueueHead (epQueue ep))) + and (\s. \ is_sched_linked + (the (tcbQueueHead (epQueue ep))) s) and sym_heap_tcbSCs and sym_heap_scReplies - and ex_nonz_cap_to' x21 and ex_nonz_cap_to' t - and (\s. \x. replyOpt = Some x \ reply_at' x s \ replyTCBs_of s x = None \ ex_nonz_cap_to' x s)" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: o_def invs_valid_objs') - apply (wpsimp wp: hoare_vcg_imp_lift' setEndpoint_invs' maybeReturnSc_invs' - hoare_vcg_all_lift getNotification_wp gbn_wp')+ - apply (clarsimp split: if_split cong: conj_cong imp_cong simp: tcb_cte_cases_def) - apply (drule pred_tcb_at', clarsimp) - apply (rename_tac sender queue ntfna ntfnb ntfnc) - apply (frule ep_ko_at_valid_objs_valid_ep', clarsimp) - apply (frule invs_valid_objs') - apply (subgoal_tac "st_tcb_at' isBlockedOnSend sender s") - apply (frule_tac t=sender in pred_tcb_at', clarsimp) - apply (subgoal_tac "st_tcb_at' (Not \ is_replyState) sender s") - apply (clarsimp simp: o_def) - apply (subgoal_tac "ex_nonz_cap_to' sender s \ - valid_ep' (case queue of [] \ Structures_H.endpoint.IdleEP - | a # list \ Structures_H.endpoint.SendEP queue) s", clarsimp) - apply (intro conjI) - apply (erule st_tcb_ex_cap''; clarsimp simp: isBlockedOnSend_equiv is_BlockedOnSend_def) - apply (clarsimp simp: valid_ep'_def pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def - split: list.splits) - apply (fastforce elim!: pred_tcb'_weakenE - simp: isBlockedOnSend_def is_BlockedOnReply_def - is_BlockedOnReceive_def) - apply (clarsimp simp: valid_ep'_def pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def - isSend_equiv isBlockedOnSend_equiv, fastforce) + and (\s. \ptr. replyOpt = Some ptr + \ reply_at' ptr s \ replyTCBs_of s ptr = None)" + in hoare_post_imp) + apply (clarsimp simp: pred_tcb_at'_eq_commute) + apply (fastforce simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def + is_BlockedOnReply_def is_BlockedOnReceive_def) + apply (wpsimp wp: ifCondRefillUnblockCheck_invs' hoare_vcg_all_lift + hoare_vcg_imp_lift') + apply (rule_tac Q'="\_. invs' and tcb_at' t + and st_tcb_at' (Not \ is_replyState) + (the (tcbQueueHead (epQueue ep))) + and (\s. \ is_sched_linked + (the (tcbQueueHead (epQueue ep))) s) + and sym_heap_tcbSCs and sym_heap_scReplies + and (\s. \ptr. replyOpt = Some ptr + \ reply_at' ptr s \ replyTCBs_of s ptr = None)" + in hoare_post_imp) + apply (clarsimp simp: o_def invs_valid_objs') + apply (wpsimp wp: hoare_vcg_imp_lift' maybeReturnSc_invs' + hoare_vcg_all_lift getNotification_wp gbn_wp' + stateAssert_inv + | drule Some_to_the)+ + apply (clarsimp simp: st_tcb_at'_def obj_at'_def) + subgoal + by (intro conjI impI allI; + force simp: is_BlockedOnReply_def is_BlockedOnReceive_def isSend_def + split: thread_state.splits) \ \Resolve common precondition\ apply (simp (no_asm_use) cong: conj_cong - | wpsimp wp: cancelIPC_st_tcb_at'_different_thread cancelIPC_notin_epQueue + | wpsimp wp: cancelIPC_st_tcb_at'_different_thread cancelIPC_replyTCBs_of_None hoare_vcg_all_lift getEndpoint_wp hoare_drop_imp[where Q'="\_ s. \ko. ko_at' ko _ s"] hoare_vcg_imp_lift')+ apply (rename_tac s) @@ -6539,33 +6582,15 @@ lemma ri_invs' [wp]: cong: conj_cong imp_cong) apply (frule (3) sym_refs_tcbSCs) apply (frule (3) sym_refs_scReplies) - apply (prop_tac "\ep. ko_at' ep (capEPPtr cap) s \ ep \ IdleEP \ t \ set (epQueue ep)") - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (drule_tac ko="ko :: endpoint" for ko in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def) - apply (fastforce simp: ep_q_refs_of'_def refs_of_rev' ko_wp_at'_def split: endpoint.splits) apply (prop_tac "\r g. replyCap = ReplyCap r g \ \obj_at' (\a. replyTCB a = Some t) r s") apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) apply (drule_tac ko="ko :: reply" for ko in sym_refs_ko_atD'[rotated]) apply (fastforce simp: obj_at'_def) apply (fastforce simp: refs_of_rev' ko_wp_at'_def tcb_bound_refs'_def get_refs_def split: option.splits) - apply (prop_tac "ex_nonz_cap_to' (capEPPtr cap) s \ st_tcb_at' simple' t s \ - t \ ksIdleThread s \ (ep_at' (capEPPtr cap) s \ - obj_at' (\ep. ep \ Structures_H.endpoint.IdleEP \ t \ set (epQueue ep)) - (capEPPtr cap) s)") - apply (fastforce simp: valid_idle'_def idle_tcb'_def pred_tcb_at'_def obj_at'_def - isCap_simps isSend_def) - apply (clarsimp split: if_splits) - apply (prop_tac "(\y. replyTCB ko = Some y) \ ko_at' ko x s \ sch_act_not (the (replyTCB ko)) s") - apply clarsimp - apply (frule_tac tp="the (replyTCB ko)" in sym_ref_replyTCB_Receive_or_Reply) - apply blast - apply fastforce - subgoal by (fastforce simp: st_tcb_at'_def obj_at_simps sch_act_wf_def split: thread_state.splits) - apply (fastforce simp: opt_map_def obj_at'_def valid_cap'_def - intro!: replyTCB_is_not_ksIdleThread - split: if_split) + apply (prop_tac "st_tcb_at' simple' t s ") + apply (fastforce simp: pred_tcb_at'_def obj_at'_def) + apply (fastforce simp: opt_map_def obj_at'_def) done lemma bindScReply_st_tcb_at'[wp]: @@ -6583,13 +6608,12 @@ lemma replyPush_st_tcb_at'_not_caller: by (wpsimp wp: sts_st_tcb_at'_cases_strong hoare_vcg_imp_lift) lemma replyUnlink_invs': - "\\s. invs' s \ (replyTCBs_of s replyPtr = Some tcbPtr \ \ is_reply_linked replyPtr s)\ + "\\s. invs' s \ (replyTCBs_of s replyPtr = Some tcbPtr \ \ is_reply_linked replyPtr s) + \ \ is_sched_linked tcbPtr s\ replyUnlink replyPtr tcbPtr \\_. invs'\" unfolding invs'_def valid_dom_schedule'_def - apply wpsimp - apply fastforce - done + by (wpsimp wp: replyUnlink_valid_sched_pointers) lemma asUser_pred_tcb_at'[wp]: "asUser tptr f \\s. P (pred_tcb_at' proj test t s)\" @@ -6607,28 +6631,32 @@ crunch doIPCTransfer for pred_tcb_at''[wp]: "\s. P (pred_tcb_at' proj test t s)" (wp: setCTE_pred_tcb_at' getCTE_wp mapM_wp' simp: cte_wp_at'_def zipWithM_x_mapM) -lemma si_invs'_helper2: - "\\s. invs' s \ st_tcb_at' active' t s \ - st_tcb_at' (Not \ is_BlockedOnReply) d s \ - ex_nonz_cap_to' t s \ ex_nonz_cap_to' d s \ - sym_heap_tcbSCs s \ sym_heap_scReplies s \ - (\reply. replyObject recvState = Some reply \ ex_nonz_cap_to' reply s \ reply_at' reply s - \ replyTCBs_of s reply = None) \ - (cd \ scOptDest = Nothing \ bound_sc_tcb_at' ((=) None) d s \ - (\scptr. bound_sc_tcb_at' (\scp. scp = (Some scptr)) t s \ ex_nonz_cap_to' scptr s)) \ - t \ d\ +lemma si_invs'_helper: + "\\s. invs' s \ st_tcb_at' runnable' t s + \ st_tcb_at' (Not \ is_BlockedOnReply) d s + \ \ (tcbQueued |< tcbs_of' s) d \ \ (tcbInReleaseQueue |< tcbs_of' s) d + \ \ is_sched_linked d s \ sch_act_not d s + \ sym_heap_tcbSCs s \ sym_heap_scReplies s + \ (cd \ scOptDest = Nothing + \ bound_sc_tcb_at' ((=) None) d s + \ (\scptr. bound_sc_tcb_at' (\scp. scp = (Some scptr)) t s)) + \ t \ d\ if call \ (\y. fault = Some y) then if (cg \ cgr) \ (\y. replyObject recvState = Some y) then replyPush t d (the (replyObject recvState)) cd else setThreadState Structures_H.thread_state.Inactive t else when (cd \ scOptDest = None) (do - scOptSrc <- threadGet tcbSchedContext t; + scOptSrc \ threadGet tcbSchedContext t; + y \ assert (\y. scOptSrc = Some y); schedContextDonate (the scOptSrc) d od) - \\b s. invs' s \ tcb_at' d s \ ex_nonz_cap_to' d s - \ st_tcb_at' (Not \ is_BlockedOnReply) d s\" - apply (wpsimp wp: ex_nonz_cap_to_pres' schedContextDonate_invs' replyPush_invs' sts_invs_minor' - replyPush_st_tcb_at'_not_caller sts_st_tcb' threadGet_wp) + \\_ s. invs' s + \ st_tcb_at' (Not \ is_BlockedOnReply) d s + \ \ is_sched_linked d s\" + apply (wpsimp wp: schedContextDonate_invs' replyPush_invs' sts_invs_minor' + replyPush_st_tcb_at'_not_caller sts_st_tcb' + schedContextDonate_tcbSchedPrevs_of_None + schedContextDonate_tcbSchedNexts_of_None threadGet_wp) apply (frule_tac P'="(\st'. \rptr. st' \ BlockedOnReply rptr)" in pred_tcb'_weakenE) apply (clarsimp simp: is_BlockedOnReply_def) apply (frule pred_tcb_at') @@ -6637,7 +6665,9 @@ lemma si_invs'_helper2: apply (fastforce simp: is_BlockedOnReply_def is_BlockedOnReceive_def) apply (frule invs_valid_objs') apply (clarsimp simp: tcb_at'_ex_eq_all o_def) + apply normalise_obj_at' apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def) + apply (rename_tac tcb tcb', case_tac "tcbState tcb"; clarsimp) done lemma replyUnlink_obj_at_tcb_none: @@ -6648,131 +6678,102 @@ lemma replyUnlink_obj_at_tcb_none: apply (wpsimp wp: updateReply_wp_all gts_wp') by (auto simp: obj_at'_def objBitsKO_def) -crunch possibleSwitchTo - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - lemma si_invs'[wp]: - "\invs' and st_tcb_at' active' t - and (\s. cd \ bound_sc_tcb_at' (\a. a \ None) t s) - and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ + "\invs' and st_tcb_at' runnable' t and (\s. cd \ bound_sc_tcb_at' (\a. a \ None) t s)\ sendIPC bl call ba cg cgr cd t ep - \\rv. invs'\" + \\_. invs'\" supply if_split[split del] - apply (simp add: sendIPC_def valid_idle'_asrt_def) + apply (simp add: sendIPC_def) apply (intro bind_wp[OF _ stateAssert_sp]) apply (rule bind_wp [OF _ get_ep_sp']) apply (rename_tac ep') - apply (case_tac ep') - \ \ep' = RecvEP\ - apply (rename_tac list) - apply (case_tac list; simp) - apply (wpsimp wp: possibleSwitchTo_invs') - apply (wpsimp wp: setThreadState_st_tcb setThreadState_Running_invs') - apply (wpsimp wp: si_invs'_helper2) - apply wpsimp - apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\_ s. invs' s \ st_tcb_at' active' t s \ - st_tcb_at' (Not \ is_BlockedOnReply) a s \ - ex_nonz_cap_to' t s \ ex_nonz_cap_to' a s \ - (\x. replyObject recvState = Some x \ - ex_nonz_cap_to' x s \ reply_at' x s \ - replyTCBs_of s x = None) \ - sym_heap_tcbSCs s \ sym_heap_scReplies s \ - (cd \ (\scptr. bound_sc_tcb_at' (\scp. scp = Some scptr) t s \ - ex_nonz_cap_to' scptr s)) \ - t \ a" - in hoare_strengthen_post[rotated]) - apply (fastforce simp: obj_at'_def pred_tcb_at'_def invs'_def - dest!: global'_no_ex_cap) - apply (wpsimp wp: replyUnlink_invs' replyUnlink_st_tcb_at' replyUnlink_obj_at_tcb_none - hoare_vcg_ex_lift hoare_vcg_imp_lift') - apply (rule_tac Q'="\_ s. invs' s \ st_tcb_at' active' t s \ - st_tcb_at' is_BlockedOnReceive a s \ - ex_nonz_cap_to' t s \ ex_nonz_cap_to' a s \ a \ t \ - sym_heap_tcbSCs s \ sym_heap_scReplies s \ - (\x. replyObject recvState = Some x \ - ex_nonz_cap_to' x s \ reply_at' x s \ - (replyTCBs_of s x = Some a \ - \ is_reply_linked x s)) \ - (cd \ (\scptr. bound_sc_tcb_at' (\scp. scp = Some scptr) t s \ ex_nonz_cap_to' scptr s))" - in hoare_strengthen_post[rotated]) - apply (auto simp: obj_at'_def pred_tcb_at'_def invs'_def - is_BlockedOnReceive_def is_BlockedOnReply_def - dest!: global'_no_ex_cap)[1] - apply (wpsimp simp: invs'_def valid_dom_schedule'_def valid_pspace'_def - comp_def sym_refs_asrt_def - wp: hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_imp_lift' gts_wp')+ - apply (intro conjI; clarsimp?) - apply (force simp: obj_at'_def valid_obj'_def valid_ep'_def - elim: valid_objsE' split: list.splits) - apply (fastforce simp: pred_tcb_at'_eq_commute pred_tcb_at'_def obj_at'_def - is_BlockedOnReceive_def isReceive_def - split: thread_state.splits) - apply (fastforce simp: pred_tcb_at'_def ko_wp_at'_def obj_at'_def isReceive_def live'_def - elim: if_live_then_nonz_capE' split: thread_state.splits) - apply (fastforce simp: pred_tcb_at'_def ko_wp_at'_def obj_at'_def isReceive_def - split: thread_state.splits) - apply (erule (3) sym_refs_tcbSCs) - apply (erule (3) sym_refs_scReplies) - apply (simp flip: conj_assoc, rule conjI) - apply (subgoal_tac "ko_wp_at' live' xb s \ reply_at' xb s", clarsimp) - apply (erule (1) if_live_then_nonz_capE') - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (drule_tac p=a and ko="obja" in sym_refs_ko_atD'[rotated]) - apply (clarsimp simp: obj_at'_def) - apply (clarsimp simp: isReceive_def refs_of_rev' ko_wp_at'_def live'_def live_reply'_def - split: thread_state.splits) - apply (rule impI) - apply (drule (1) valid_replies'_other_state; clarsimp simp: isReceive_def) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (erule if_live_then_nonz_capE') - apply (drule_tac ko=obj and p=t in sym_refs_ko_atD'[rotated]) - apply (clarsimp simp: obj_at'_def) - apply (clarsimp simp: ko_wp_at'_def obj_at'_def refs_of_rev' live'_def live_sc'_def valid_idle'_def - idle_tcb'_def tcb_bound_refs'_def) - \ \epa = IdleEP\ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def isReceive_def is_BlockedOnReply_def) - apply (cases bl) - apply (wpsimp wp: sts_sch_act' setThreadState_ct_not_inQ - simp: invs'_def valid_dom_schedule'_def valid_ep'_def) - apply (fastforce simp: valid_tcb_state'_def valid_idle'_def pred_tcb_at'_def obj_at'_def - idle_tcb'_def comp_def) - apply wpsimp - \ \ep' = SendEP\ - apply (cases bl) - apply (wpsimp wp: tcbEPAppend_valid_SendEP sts_sch_act' sts'_valid_replies' - simp: invs'_def valid_dom_schedule'_def valid_pspace'_def - valid_ep'_def sym_refs_asrt_def) - apply (erule valid_objsE'[where x=ep], fastforce simp: obj_at'_def) - apply (drule_tac ko="SendEP xa" in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def) - apply (clarsimp simp: comp_def obj_at'_def pred_tcb_at'_def valid_idle'_def - valid_tcb_state'_def valid_obj'_def valid_ep'_def - idle_tcb'_def) - apply (fastforce simp: ko_wp_at'_def refs_of_rev') - apply wpsimp + apply (case_tac "epState ep'"; clarsimp) + apply (find_goal \match premises in "epState _ = IdleEPState" \ -\) + apply (wpsimp wp: tcbEPAppend_invs' setThreadState_nonqueued_state_update + inIPCQueueThreadState_sched_flag_set) + apply (rule conjI) + apply (erule pred_tcb'_weakenE) + apply (rename_tac st, case_tac st; clarsimp) + apply fastforce + apply (find_goal \match premises in "epState _ = SendEPState" \ -\) + apply (wpsimp wp: tcbEPAppend_invs' setThreadState_nonqueued_state_update + inIPCQueueThreadState_sched_flag_set) + apply (rule conjI) + apply (erule pred_tcb'_weakenE) + apply (rename_tac st, case_tac st; clarsimp) + apply fastforce + \ \ep' = RecvEP\ + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (rule bind_wp[OF _ assert_sp]) + apply (rule hoare_gen_asm_conj) + apply (clarsimp simp: tcbQueueEmpty_def) + apply (rename_tac q dest) + apply (wpsimp wp: setThreadState_Running_invs' replyPush_invs' replyPush_st_tcb_at'_not_caller + setThreadState_nonqueued_state_update[where t=t] sts_st_tcb' + schedContextDonate_invs' schedContextDonate_tcbSchedPrevs_of_None + schedContextDonate_tcbSchedNexts_of_None threadGet_wp) + apply (rule hoare_drop_imp) + apply (wpsimp wp: setThreadState_Running_invs') + apply (wpsimp wp: si_invs'_helper) + apply wpsimp + apply (wpsimp wp: threadGet_wp) + apply (rule_tac Q'="\_ s. invs' s \ st_tcb_at' runnable' t s + \ st_tcb_at' (Not \ is_BlockedOnReply) dest s + \ \ (tcbQueued |< tcbs_of' s) dest + \ \ (tcbInReleaseQueue |< tcbs_of' s) dest + \ \ is_sched_linked dest s \ sch_act_not dest s + \ sym_heap_tcbSCs s \ sym_heap_scReplies s + \ (cd \ (\scptr. bound_sc_tcb_at' (\scp. scp = Some scptr) t s)) + \ t \ dest" + in hoare_post_imp) + apply (fastforce simp: obj_at'_def pred_tcb_at'_def) + apply (wpsimp wp: replyUnlink_invs' replyUnlink_st_tcb_at' replyUnlink_obj_at_tcb_none + hoare_vcg_ex_lift hoare_vcg_imp_lift') + apply (rule_tac Q'="\_ s. invs' s \ st_tcb_at' runnable' t s + \ st_tcb_at' is_BlockedOnReceive dest s + \ dest \ t + \ \ (tcbQueued |< tcbs_of' s) dest + \ \ (tcbInReleaseQueue |< tcbs_of' s) dest + \ \ is_sched_linked dest s \ sch_act_not dest s + \ sym_heap_tcbSCs s \ sym_heap_scReplies s + \ (\ptr. replyObject recvState = Some ptr + \ (replyTCBs_of s ptr = Some dest + \ \ is_reply_linked ptr s)) + \ (cd \ (\scptr. bound_sc_tcb_at' (\scp. scp = Some scptr) t s))" + in hoare_post_imp) + apply (force simp: obj_at'_def pred_tcb_at'_def invs'_def + is_BlockedOnReceive_def is_BlockedOnReply_def) + apply (wpsimp simp: invs'_def valid_dom_schedule'_def valid_pspace'_def + wp: hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_imp_lift' gts_wp')+ + apply (intro conjI; (solves clarsimp)?) + apply (erule pred_tcb'_weakenE) + apply (rename_tac st, case_tac st; clarsimp simp: is_BlockedOnReceive_def isReceive_def) + apply (erule (3) sym_refs_tcbSCs) + apply (erule (3) sym_refs_scReplies) + apply clarsimp + apply (drule (1) valid_replies'_other_state; clarsimp simp: isReceive_def) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) done lemma sendFaultIPC_invs': - "\invs' and st_tcb_at' active' t and (\s. canDonate \ bound_sc_tcb_at' (\a. a \ None) t s) - and ex_nonz_cap_to' t - and (\s. \n\dom tcb_cte_cases. \cte. cte_wp_at' (\cte. cteCap cte = cap) (t + n) s)\ + "\invs' and st_tcb_at' runnable' t and (\s. canDonate \ bound_sc_tcb_at' (\a. a \ None) t s)\ sendFaultIPC t cap f canDonate \\_. invs'\" unfolding sendFaultIPC_def - apply (wpsimp wp: threadSet_invs_trivial threadSet_pred_tcb_no_state threadSet_cap_to') - by (fastforce simp: invs'_def obj_at'_def ex_nonz_cap_to'_def cte_wp_at'_def) + by (wpsimp wp: threadSet_invs_trivial threadSet_pred_tcb_no_state threadSet_cap_to') lemma handleFault_corres: "fr f f' \ 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 sorted_ipc_queues and scheduler_act_not t + and st_tcb_at runnable t and not_queued t and not_in_release_q 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) + invs' (handle_fault t f) (handleFault t f')" + apply (rule_tac Q'="st_tcb_at' runnable' t" in corres_cross_add_guard) + apply (fastforce intro: st_tcb_at_runnable_cross) apply add_valid_idle' apply (simp add: handle_fault_def handleFault_def) apply (rule corres_stateAssert_add_assertion[rotated], simp) @@ -6807,9 +6808,10 @@ lemma handleFault_corres: get_tcb_timeout_handler_ptr_def) apply clarsimp apply (intro conjI impI allI; fastforce?) - apply (fastforce elim: cte_wp_valid_cap) - apply (fastforce dest: tcb_ep_slot_cte_wp_ats[where t=t] - simp: tcb_at_def get_tcb_def cte_wp_at_cases) + apply (fastforce elim: cte_wp_valid_cap) + apply (fastforce dest: tcb_ep_slot_cte_wp_ats[where t=t] + simp: tcb_at_def get_tcb_def cte_wp_at_cases) + apply (fastforce simp: runnable_eq_active) apply (fastforce simp: caps_of_state_Some_simp) apply clarsimp apply (intro conjI impI allI; fastforce?) @@ -6848,7 +6850,8 @@ lemma handleTimeout_corres: 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 sorted_ipc_queues and scheduler_act_not t + and st_tcb_at runnable t and not_queued t and not_in_release_q t and current_time_bounded and cte_wp_at is_ep_cap (t,tcb_cnode_index 4) and K (valid_fault f)) invs' (handle_timeout t f) (handleTimeout t f')" @@ -6890,7 +6893,7 @@ lemma handleTimeout_corres: done lemma hf_invs'[wp]: - "\invs' and st_tcb_at' active' t and ex_nonz_cap_to' t\ + "\invs' and st_tcb_at' runnable' t\ handleFault t f \\_. invs'\" apply (simp add: handleFault_def handleNoFaultHandler_def sendFaultIPC_def) @@ -6907,10 +6910,8 @@ lemma hf_invs'[wp]: apply (rename_tac cap n get set) apply (intro conjI impI allI; clarsimp?) apply fastforce - apply (drule_tac x=cap in spec) - apply (clarsimp simp: ex_nonz_cap_to'_def) - apply (rule_tac x="t + 2 ^ cte_level_bits * tcbFaultHandlerSlot" in exI) - apply (fastforce elim!: cte_wp_at_weakenE' simp: cte_wp_at_cases') + apply (rename_tac tcb cap n get set) + apply (case_tac "tcbState tcb"; clarsimp) done lemma gts_st_tcb': @@ -7112,7 +7113,7 @@ lemma doReplyTransfer_corres: apply (clarsimp split: if_split simp: valid_fault_def invs_def valid_state_def valid_pspace_def) apply (frule valid_ready_qs_in_correct_ready_q) apply (frule valid_ready_qs_ready_qs_distinct) - apply (clarsimp simp: tcb_cnode_map_def obj_at_def TCB_cte_wp_at_obj_at sc_at_pred_n_def pred_tcb_at_def) + apply (fastforce simp: tcb_cnode_map_def obj_at_def TCB_cte_wp_at_obj_at sc_at_pred_n_def pred_tcb_at_def) apply (clarsimp simp: obj_at_def) apply (frule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) apply (clarsimp simp: tcb_relation_cut_def obj_at'_def @@ -7135,23 +7136,25 @@ lemma doReplyTransfer_corres: split: if_split) apply (frule valid_objs_valid_tcbs) apply (frule valid_ready_qs_in_correct_ready_q) - apply (clarsimp simp: obj_at_def sc_at_pred_n_def - obj_at_kh_kheap_simps) + apply (frule valid_ready_qs_ready_queues_runnable) + apply (fastforce simp: obj_at_def sc_at_pred_n_def + obj_at_kh_kheap_simps) apply (clarsimp simp: invs_def valid_state_def valid_pspace_def invs'_def valid_pspace'_def split: if_split) apply (frule (1) valid_objs_ko_at, clarsimp simp: valid_obj_def) apply (clarsimp simp: obj_at_def) apply (frule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - apply (clarsimp simp: other_obj_relation_def obj_at'_def - sc_relation_def active_sc_at'_rewrite) + apply (prop_tac "sc_at' (the scopt') s'") + apply (fastforce intro!: sc_at_cross intro: sc_at_pred_n_sc_at) + apply (clarsimp simp: obj_at'_def sc_relation_def) apply (clarsimp simp: invs_def valid_state_def valid_pspace_def invs'_def valid_pspace'_def) apply (frule (1) valid_objs_ko_at, clarsimp simp: valid_obj_def) apply (rename_tac sc' n) apply (prop_tac "sc_relation sc n sc'") apply (clarsimp simp: obj_at_def) apply (frule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - apply (clarsimp simp: other_obj_relation_def obj_at'_def split: if_splits) + apply (clarsimp simp: obj_at'_def split: if_splits) apply (frule (1) ksPSpace_valid_sched_context') apply (subgoal_tac "0 < scRefillMax sc'") apply (subgoal_tac "sc_valid_refills sc") @@ -7162,9 +7165,8 @@ lemma doReplyTransfer_corres: apply (subst (asm) active_sc_at_equiv) apply (frule (1) active_scs_validE) apply (clarsimp simp: valid_refills_def2 obj_at_def) - apply (fastforce intro: active_sc_at'_cross - simp: obj_at_def vs_all_heap_simps active_sc_def - sc_relation_def) + apply (fastforce simp: obj_at_def vs_all_heap_simps active_sc_def + sc_relation_def) apply wpsimp apply wpsimp apply (wpsimp wp: refillReady_wp) @@ -7236,17 +7238,17 @@ lemma doReplyTransfer_corres: apply (rule_tac Q'="\_. tcb_at' recvr and invs'" in hoare_strengthen_post[rotated]) apply (clarsimp simp: tcb_at'_ex_eq_all invs'_def valid_pspace'_def) apply (wpsimp wp: sts_invs') - apply (rule_tac Q'="\_. invs' and ex_nonz_cap_to' recvr and tcb_at' recvr - and (st_tcb_at' (\st. st = Inactive) recvr)" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (rule_tac Q'="\_. invs' and (st_tcb_at' (\st. st = Inactive) recvr)" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def opt_pred_def + split: option.splits) apply wpsimp apply (wpsimp wp: sts_invs') - apply (rule_tac Q'="\_. invs' and sch_act_not recvr and ex_nonz_cap_to' recvr and tcb_at' recvr - and (st_tcb_at' (\st. st = Inactive) recvr)" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (fastforce dest: global'_no_ex_cap simp: invs'_def split: if_split) + apply (rule_tac Q'="\_. invs' and sch_act_not recvr + and (st_tcb_at' (\st. st = Inactive) recvr)" + in hoare_post_imp) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def opt_pred_def + split: option.splits) apply (wpsimp wp: threadSet_fault_invs' threadSet_pred_tcb_no_state threadSet_cur) apply wpsimp+ apply (wpsimp wp: thread_get_wp') @@ -7262,9 +7264,9 @@ lemma doReplyTransfer_corres: dest!: idle_no_ex_cap) apply (wpsimp wp: refill_unblock_check_valid_sched simp: if_cond_refill_unblock_check_def) - apply (rule_tac Q'="\_. tcb_at' recvr and invs' and tcb_at' sender - and ex_nonz_cap_to' recvr and sch_act_not recvr and st_tcb_at' ((=) Inactive) recvr" - in hoare_strengthen_post[rotated]) + apply (rule_tac Q'="\_. invs' and tcb_at' sender and sch_act_not recvr + and st_tcb_at' ((=) Inactive) recvr" + in hoare_post_imp) apply (clarsimp simp: op_equal invs'_def obj_at'_def) apply wpsimp apply (wpsimp wp: get_tcb_obj_ref_wp) @@ -7286,11 +7288,10 @@ lemma doReplyTransfer_corres: apply (prop_tac "heap_ref_eq scp t (tcb_scps_of s) \ heap_ref_eq scp recvr (tcb_scps_of s)") apply (clarsimp simp: vs_all_heap_simps) apply (clarsimp simp: heap_refs_inv_def2 vs_all_heap_simps) - apply (wpsimp wp: reply_remove_valid_sched reply_remove_active_if_bound_sc_tcb_at reply_remove_invs) - apply (rule_tac Q'="\_. tcb_at' sender and invs' and sch_act_not recvr and ex_nonz_cap_to' recvr and tcb_at' recvr - and st_tcb_at' (\a. a = Structures_H.thread_state.Inactive) recvr" - in hoare_strengthen_post[rotated]) + apply (rule_tac Q'="\_. tcb_at' sender and invs' and sch_act_not recvr + and st_tcb_at' (\a. a = Structures_H.thread_state.Inactive) recvr" + in hoare_post_imp) apply (clarsimp simp: obj_at'_def invs'_def valid_pspace'_def op_equal split: option.split) apply (wpsimp simp: valid_pspace'_def wp: replyRemove_invs') apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def @@ -7313,12 +7314,12 @@ lemma doReplyTransfer_corres: apply (erule (2) reply_tcb_sym_refsD) apply (clarsimp simp: invs'_def valid_pspace'_def cong: conj_cong) apply (intro conjI) - apply (erule cross_relF[OF _ tcb_at'_cross_rel[where t=sender]], fastforce) - apply (erule (1) st_tcb_ex_cap'', simp) - apply (prop_tac "sch_act_wf (ksSchedulerAction s') s'") - apply (fastforce dest: sch_act_wf_cross) + apply (erule cross_relF[OF _ tcb_at'_cross_rel[where t=sender]], fastforce) apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (wpsimp wp: get_simple_ko_wp)+ + apply (prop_tac "sch_act_wf (ksSchedulerAction s') s'") + apply (fastforce dest: sch_act_wf_cross) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (wpsimp wp: get_simple_ko_wp)+ apply (clarsimp split: option.split simp: invs_def valid_state_def valid_pspace_def) apply (frule (1) valid_objs_ko_at) apply (clarsimp simp: valid_obj_def valid_reply_def obj_at_def reply_tcb_reply_at_def) diff --git a/proof/refine/RISCV64/Refine.thy b/proof/refine/RISCV64/Refine.thy index a9d809f37b..5c60328526 100644 --- a/proof/refine/RISCV64/Refine.thy +++ b/proof/refine/RISCV64/Refine.thy @@ -77,7 +77,8 @@ lemma typ_at_UserDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def other_aobj_relation_def - cte_relation_def other_obj_relation_def tcb_relation_cut_def + cte_relation_def tcb_relation_cut_def + ep_relation_cut_def ntfn_relation_cut_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -107,7 +108,8 @@ lemma typ_at_DeviceDataI: apply clarsimp apply (subst mask_lower_twice [where n = pageBits, OF pbfs_atleast_pageBits, symmetric]) apply (clarsimp simp: obj_relation_cuts_def2 pte_relation_def other_aobj_relation_def - cte_relation_def other_obj_relation_def tcb_relation_cut_def + cte_relation_def tcb_relation_cut_def + ep_relation_cut_def ntfn_relation_cut_def split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) @@ -904,7 +906,7 @@ lemma kernel_corres': invs_strengthen_cur_sc_tcb_are_bound) apply simp apply clarsimp - apply (frule schedulable'_runnableE) + apply (frule ksCurThread_schedulable'_ct_active') apply (clarsimp simp: cur_tcb'_def) apply (clarsimp simp: st_tcb_at'_def obj_at'_def ct_in_state'_def) done @@ -1197,10 +1199,6 @@ lemma ckernel_invariant: apply (rename_tac s' s) apply (frule_tac a=s and b=s' in curthread_relation) apply (intro conjI) - apply (frule_tac s=s in invs_sym_refs) - apply (frule_tac s'=s' in state_refs_of_cross_eq) - apply fastforce - apply fastforce apply clarsimp apply (erule (1) ct_running_cross) apply fastforce diff --git a/proof/refine/RISCV64/Reply_R.thy b/proof/refine/RISCV64/Reply_R.thy index d1b6306633..16e218da01 100644 --- a/proof/refine/RISCV64/Reply_R.thy +++ b/proof/refine/RISCV64/Reply_R.thy @@ -13,17 +13,9 @@ defs replyUnlink_assertion_def: \ \replyPtr state s. state = BlockedOnReply (Some replyPtr) \ (\ep d. state = BlockedOnReceive ep d (Some replyPtr))" -lemma valid_reply'_updates[simp]: - "\f. valid_reply' reply (ksReprogramTimer_update f s) = valid_reply' reply s" - "\f. valid_reply' reply (ksReleaseQueue_update f s) = valid_reply' reply s" - by (auto simp: valid_reply'_def valid_bound_obj'_def split: option.splits) - crunch updateReply for pred_tcb_at'[wp]: "\s. P (pred_tcb_at' proj test t s)" - and typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" - and ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" and sc_obj_at'[wp]: "\s. Q (obj_at' (P :: sched_context \ bool) scp s)" global_interpretation updateReply: typ_at_all_props' "updateReply p f" @@ -90,7 +82,6 @@ crunch cleanReply for st_tcb_at'[wp]: "st_tcb_at' P t" and typ_at'[wp]: "\s. P (typ_at' T p s)" and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - and weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" (rule: weak_sch_act_wf_lift) global_interpretation cleanReply: typ_at_all_props' "cleanReply p" @@ -187,25 +178,19 @@ lemma replyRemoveTCB_st_tcb_at'_sym_ref: done crunch cleanReply, updateReply - for valid_idle'[wp]: valid_idle' - and ct_not_inQ[wp]: ct_not_inQ - and sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - and sch_act_not[wp]: "sch_act_not t" + for sch_act_not[wp]: "sch_act_not t" and aligned'[wp]: pspace_aligned' and distinct'[wp]: pspace_distinct' and bounded'[wp]: pspace_bounded' and no_0_obj'[wp]: "no_0_obj'" - and cap_to': "ex_nonz_cap_to' t" and valid_mdb'[wp]: "valid_mdb'" crunch replyUnlink for list_refs_of_replies'[wp]: "\s. P (list_refs_of_replies' s)" - and ct_not_inQ[wp]: ct_not_inQ and ex_nonz_cap_to'[wp]: "(\s. ex_nonz_cap_to' t s)" and valid_irq_handlers'[wp]: valid_irq_handlers' and valid_irq_states'[wp]: valid_irq_states' and irqs_masked'[wp]: irqs_masked' - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' and pspace_domain_valid[wp]: pspace_domain_valid and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" and ksArchState[wp]: "\s. P (ksArchState s)" @@ -241,23 +226,11 @@ lemma updateReply_valid_objs': apply clarsimp done -lemma replyUnlink_idle'[wp]: - "\valid_idle' and (\s. tptr \ ksIdleThread s)\ - replyUnlink rptr tptr - \\_. valid_idle'\" - unfolding replyUnlink_def replyUnlink_assertion_def updateReply_def - apply (wpsimp wp: hoare_vcg_imp_lift' - simp: pred_tcb_at'_def) - done - lemma replyUnlink_valid_objs'[wp]: - "\valid_objs' and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - replyUnlink rptr tptr - \\_. valid_objs'\" + "replyUnlink rptr tptr \valid_objs'\" unfolding replyUnlink_def apply (wpsimp wp: updateReply_valid_objs'[where upd="replyTCB_update (\_. tptrOpt)" for tptrOpt] - gts_wp' - simp: valid_tcb_state'_def) + gts_wp') apply (clarsimp simp: valid_reply'_def) done @@ -324,7 +297,7 @@ lemma replyUnlink_valid_replies'[wp]: apply (wpsimp wp: updateReply_valid_replies'_not_linked sts'_valid_replies' hoare_vcg_all_lift hoare_vcg_imp_lift' gts_wp') apply normalise_obj_at' - apply (clarsimp simp: valid_reply'_def pred_tcb_at'_def obj_at'_def replyUnlink_assertion_def) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def replyUnlink_assertion_def) by (auto simp: opt_map_def split: option.splits) lemma replyUnlink_valid_pspace'[wp]: @@ -381,9 +354,6 @@ crunch replyRemoveTCB and distinct'[wp]: pspace_distinct' and bounded'[wp]: pspace_bounded' and pspace_canonical'[wp]: pspace_canonical' - and ct_not_inQ[wp]: ct_not_inQ - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and cur_tcb'[wp]: "cur_tcb'" and no_0_obj'[wp]: "no_0_obj'" and it'[wp]: "\s. P (ksIdleThread s)" and ct'[wp]: "\s. P (ksCurThread s)" @@ -400,7 +370,6 @@ crunch replyRemoveTCB and typ_at'[wp]: "\s. P (typ_at' T p s)" and sc_at'_n[wp]: "\s. P (sc_at'_n T p s)" and vms'[wp]: "valid_machine_state'" - and cap_to': "ex_nonz_cap_to' t" and pspace_domain_valid[wp]: pspace_domain_valid and valid_mdb'[wp]: valid_mdb' and pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' @@ -412,9 +381,7 @@ global_interpretation replyUnlink: typ_at_all_props' "replyUnlink replyPtr tcbPt by typ_at_props' lemma replyRemoveTCB_valid_objs'[wp]: - "\valid_objs' and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - replyRemoveTCB tptr - \\_. valid_objs'\" + "replyRemoveTCB tptr \valid_objs'\" unfolding replyRemoveTCB_def updateSchedContext_def supply set_reply'.set_wp[wp del] if_split[split del] apply (wpsimp wp: updateReply_valid_objs' hoare_vcg_if_lift hoare_vcg_imp_lift gts_wp' @@ -451,63 +418,6 @@ lemma replyRemoveTCB_valid_pspace'[wp]: unfolding valid_pspace'_def by wpsimp -lemma updateReply_iflive'_strong: - "\(\s. reply_at' rptr s \ if_live_then_nonz_cap' s) and - (\s. \ko. ko_at' ko rptr s \ \ live_reply' ko \ live_reply' (f ko) \ ex_nonz_cap_to' rptr s)\ - updateReply rptr f - \\_. if_live_then_nonz_cap'\" - unfolding if_live_then_nonz_cap'_def - apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - apply (wpsimp wp: updateReply_wp_all) - apply wpsimp - apply clarsimp - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def ps_clear_def live'_def) - apply (case_tac "x=rptr"; clarsimp) - done - -lemma updateReply_iflive': - "\if_live_then_nonz_cap' and K (\r. live_reply' (upd r) \ live_reply' r)\ - updateReply rptr upd - \\_. if_live_then_nonz_cap'\" - by (wpsimp wp: updateReply_iflive'_strong) - -crunch replyUnlink - for if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - (wp: updateReply_iflive' simp: live_reply'_def) - -lemma cleanReply_iflive'[wp]: - "cleanReply rptr \if_live_then_nonz_cap'\" - unfolding cleanReply_def - apply (wpsimp wp: updateReply_iflive' simp: live_reply'_def) - done - -lemma replyRemoveTCB_iflive'[wp]: - "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - replyRemoveTCB tptr - \\_. if_live_then_nonz_cap'\" - unfolding replyRemoveTCB_def updateSchedContext_def - apply (wpsimp wp: hoare_vcg_all_lift updateReply_iflive' hoare_vcg_if_lift hoare_vcg_imp_lift' - gts_wp' - split_del: if_split) - apply (clarsimp simp: live_reply'_def) - apply (intro impI conjI allI; - clarsimp simp: live_reply'_def pred_tcb_at'_def) - apply normalise_obj_at' - apply (rename_tac s sc reply tcb_reply_ptr next_ptr prev_ptr tcb) - apply (prop_tac "live_sc' sc") - apply (clarsimp simp: live_sc'_def) - apply (prop_tac "ko_wp_at' live' (theHeadScPtr (Some next_ptr)) s") - apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) - apply (clarsimp simp: if_live_then_nonz_cap'_def) - apply normalise_obj_at' - apply (rename_tac s sc reply tcb_reply_ptr next_ptr tcb) - apply (prop_tac "live_sc' sc") - apply (clarsimp simp: live_sc'_def) - apply (prop_tac "ko_wp_at' live' (theHeadScPtr (Some next_ptr)) s") - apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) - apply (clarsimp simp: if_live_then_nonz_cap'_def) - done - lemma cleanReply_valid_pspace'[wp]: "cleanReply rptr \valid_pspace'\" unfolding cleanReply_def valid_pspace'_def @@ -582,26 +492,6 @@ lemma replyRemoveTCB_sym_refs_list_refs_of_replies': option.inject)+ done -lemma replyUnlink_sch_act[wp]: - "replyUnlink r t \\s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp only: replyUnlink_def liftM_def) - apply (wpsimp wp: sts_sch_act' gts_wp') - apply (fastforce simp: replyUnlink_assertion_def st_tcb_at'_def obj_at'_def) - done - -lemma replyUnlink_weak_sch_act_wf[wp]: - "replyUnlink r t \\s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp only: replyUnlink_def liftM_def) - apply (wpsimp wp: sts_sch_act' gts_wp') - done - -lemma replyRemoveTCB_sch_act_wf: - "replyRemoveTCB tptr \\s. sch_act_wf (ksSchedulerAction s) s\" - unfolding replyRemoveTCB_def - by (wpsimp wp: gts_wp' haskell_assert_wp hoare_vcg_if_lift hoare_vcg_imp_lift' - simp: pred_tcb_at'_def - split_del: if_split) - lemma setSchedContext_valid_tcbs'[wp]: "setSchedContext scPtr sc \valid_tcbs'\" unfolding setSchedContext_def @@ -610,31 +500,52 @@ lemma setSchedContext_valid_tcbs'[wp]: apply simp done -crunch updateReply +crunch cleanReply for valid_sched_pointers[wp]: valid_sched_pointers and tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" and tcbQueueds_of[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + and tcbStates_of'[wp]: "\s. P (tcbStates_of' s)" (simp: setReply_def) crunch cleanReply - for valid_sched_pointers[wp]: valid_sched_pointers + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers crunch replyRemoveTCB for valid_bitmaps[wp]: valid_bitmaps - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers (simp: crunch_simps) +(* A direct weakening of @{thm setThreadState_valid_sched_pointers} *) +lemma setThreadState_not_queued_valid_sched_pointers: + "\\s. valid_sched_pointers s \ \ (inIPCQueueThreadState |< tcbStates_of' s) t\ + setThreadState st t + \\_. valid_sched_pointers\" + by (wpsimp wp: setThreadState_valid_sched_pointers) + +lemma replyRemove_valid_sched_pointers[wp]: + "replyRemoveTCB tptr \valid_sched_pointers\" + apply (clarsimp simp: replyRemoveTCB_def replyUnlink_def) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (wpsimp wp: setThreadState_not_queued_valid_sched_pointers + gts_wp' hoare_vcg_all_lift hoare_drop_imps) + apply (clarsimp simp: st_tcb_at'_def) + apply normalise_obj_at' + apply (rename_tac tcb, case_tac "tcbState tcb"; + clarsimp simp: isReply_def obj_at'_def opt_pred_def opt_map_def) + done + +crunch replyRemoveTCB + for tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + lemma replyRemoveTCB_invs': "replyRemoveTCB tptr \invs'\" unfolding invs'_def valid_dom_schedule'_def - apply (wpsimp wp: replyRemoveTCB_sym_refs_list_refs_of_replies' - valid_irq_node_lift valid_irq_handlers_lift' valid_irq_states_lift' - irqs_masked_lift replyRemoveTCB_sch_act_wf - simp: cteCaps_of_def) - apply fastforce - done + by (wpsimp wp: replyRemoveTCB_sym_refs_list_refs_of_replies' + valid_irq_node_lift valid_irq_handlers_lift' valid_irq_states_lift' + irqs_masked_lift + simp: cteCaps_of_def) lemma set_reply_obj_ref_noop: "monadic_rewrite False True (reply_at rptr) @@ -720,13 +631,20 @@ lemma update_sc_reply_stack_update_ko_at'_corres: | fastforce split: Structures_A.kernel_object.splits)+ done +defs valid_bound_reply'_asrt_def: + "valid_bound_reply'_asrt replyOpt \ valid_bound_reply' replyOpt" + +declare valid_bound_reply'_asrt_def[simp] + lemma bindScReply_corres: - "corres dc (reply_at rptr and sc_at scptr and (\s. rptr \ fst ` replies_with_sc s) - and pspace_aligned and pspace_distinct and valid_objs - and valid_replies and (\s. sym_refs (state_refs_of s))) - (reply_at' rptr and sc_at' scptr) - (bind_sc_reply scptr rptr) - (bindScReply scptr rptr)" + "corres dc + (reply_at rptr and sc_at scptr and (\s. rptr \ fst ` replies_with_sc s) + and pspace_aligned and pspace_distinct and valid_objs + and valid_replies and (\s. sym_refs (state_refs_of s))) + (reply_at' rptr) + (bind_sc_reply scptr rptr) (bindScReply scptr rptr)" + apply (rule_tac Q'="sc_at' scptr" in corres_cross_add_guard) + apply (fastforce intro!: sc_at_cross) unfolding bind_sc_reply_def bindScReply_def case_list_when sym_refs_asrt_def apply (clarsimp simp: liftM_def) apply add_sym_refs @@ -747,6 +665,8 @@ lemma bindScReply_corres: and valid_replies and (\s. sym_refs (state_refs_of s)) and (\s. \n. ko_at (Structures_A.SchedContext sc n) scptr s)" in stronger_corres_guard_imp) + apply (rule corres_stateAssert_ignore) + apply (clarsimp simp: valid_bound_reply'_def split: option.splits) apply (rule corres_guard_imp) apply (rule corres_split [where r'=dc]) apply (rule_tac F="(sc_replies sc \ []) = (\y. scReply sc' = Some y)" in corres_gen_asm2) @@ -833,12 +753,9 @@ crunch bindScReply and valid_irq_states'[wp]: valid_irq_states' and valid_machine_state'[wp]: valid_machine_state' and irqs_masked'[wp]: irqs_masked' - and ct_not_inQ[wp]: ct_not_inQ - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' and pspace_domain_valid[wp]: pspace_domain_valid and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and valid_dom_schedule'[wp]: valid_dom_schedule' - and cur_tcb'[wp]: cur_tcb' and no_0_obj'[wp]: no_0_obj' and valid_mdb'[wp]: valid_mdb' and tcb_at'[wp]: "tcb_at' t" @@ -848,10 +765,6 @@ crunch bindScReply (wp: crunch_wps hoare_vcg_all_lift valid_irq_node_lift simp: crunch_simps valid_mdb'_def valid_dom_schedule'_def) -crunch setThreadState - for sc_ko_at'[wp]: "\s. P (ko_at' (sc :: sched_context) p s)" - (wp: crunch_wps simp: crunch_simps) - lemma updateReply_obj_at': "\\s. reply_at' rptr s \ P (obj_at' (\ko. if rptr = p then Q (f ko) else Q ko) p s)\ @@ -891,22 +804,16 @@ lemma updateReply_obj_at'_inv: apply simp by (force simp: obj_at'_real_def ko_wp_at'_def objBitsKO_def ps_clear_def) -lemma updateReply_iflive'_weak: - "\\s. reply_at' replyPtr s \ if_live_then_nonz_cap' s \ ex_nonz_cap_to' replyPtr s\ - updateReply replyPtr f - \\_. if_live_then_nonz_cap'\" - by (wpsimp wp: updateReply_iflive'_strong, clarsimp simp: obj_at'_def) - lemma updateReply_replyTCB_invs': - "\invs' and ex_nonz_cap_to' rptr and case_option \ (\t. tcb_at' t) p and + "\invs' and case_option \ (\t. tcb_at' t) p and (\s. is_reply_linked rptr s \ (\tptr. p = Some tptr \ st_tcb_at' ((=) (BlockedOnReply (Some rptr))) tptr s))\ updateReply rptr (replyTCB_update (\_. p)) \\_. invs'\" - apply (wpsimp wp: updateReply_iflive'_weak updateReply_valid_objs' - updateReply_list_refs_of_replies'_inv updateReply_valid_replies' - simp: invs'_def valid_pspace'_def valid_reply'_def - split: option.split_asm) + apply (wpsimp wp: updateReply_valid_objs' updateReply_list_refs_of_replies'_inv + updateReply_valid_replies' + simp: invs'_def valid_pspace'_def valid_reply'_def + split: option.split_asm) by (auto simp: obj_at'_def opt_map_def) lemma bindScReply_valid_objs'[wp]: @@ -929,11 +836,12 @@ lemma bindScReply_valid_objs'[wp]: dest!: sc_ko_at_valid_objs_valid_sc' split: if_splits) apply fastforce apply (rule_tac Q'="\_ s. valid_objs' s \ reply_at' replyPtr s \ ko_at' sc scp s - \ scReply sc = scReplyOpt" + \ scReply sc = scReplyOpt + \ (scReplyOpt \ None \ reply_at' (the scReplyOpt) s)" in hoare_strengthen_post) apply (wpsimp wp: updateReply_valid_objs') - apply (clarsimp simp: valid_reply'_def valid_sched_context'_def - dest!: sc_ko_at_valid_objs_valid_sc' split: if_splits) + apply (clarsimp simp: valid_reply'_def valid_sched_context'_def valid_bound_obj'_def + dest!: sc_ko_at_valid_objs_valid_sc' split: if_splits option.splits) apply wpsimp+ apply (clarsimp simp: valid_reply'_def) done @@ -960,11 +868,6 @@ lemma bindScReply_valid_replies'[wp]: apply ((erule impCE)?; fastforce simp: obj_at'_def elim!: opt_mapE)+ done -lemma bindScReply_sch_act_wf[wp]: - "bindScReply scPtr replyPtr \\s. sch_act_wf (ksSchedulerAction s) s\" - unfolding bindScReply_def - by (wpsimp wp: sts_sch_act' hoare_vcg_all_lift hoare_vcg_if_lift hoare_drop_imps) - lemma bindsym_heap_scReplies_list_refs_of_replies': "\\s. sym_refs (list_refs_of_replies' s) \ \ is_reply_linked replyPtr s \ replySCs_of s replyPtr = None @@ -980,32 +883,6 @@ lemma bindsym_heap_scReplies_list_refs_of_replies': opt_map_Some_def obj_at'_def elim: delta_sym_refs split: if_splits) -lemma bindScReply_if_live_then_nonz_cap': - "\if_live_then_nonz_cap' - and ex_nonz_cap_to' scPtr and ex_nonz_cap_to' replyPtr - and (\s. \rp. (scReplies_of s) scPtr = Some rp - \ replySCs_of s rp = Some scPtr)\ - bindScReply scPtr replyPtr - \\_. if_live_then_nonz_cap'\" - unfolding bindScReply_def updateSchedContext_def - apply (simp (no_asm_use) split del: if_split - | wp hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_disj_lift - hoare_vcg_if_lift updateReply_iflive'_weak - | rule threadGet_wp)+ - apply clarsimp - apply (erule if_live_then_nonz_capE') - apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def live_reply'_def opt_map_def) - done - -lemma bindScReply_ex_nonz_cap_to'[wp]: - "bindScReply scPtr replyPtr \ex_nonz_cap_to' ptr\" - unfolding bindScReply_def - apply (simp (no_asm_use) split del: if_split - | wp hoare_vcg_all_lift hoare_vcg_disj_lift hoare_vcg_imp_lift' - hoare_vcg_if_lift set_reply'.obj_at' updateReply_obj_at' - | rule threadGet_wp)+ - by clarsimp - lemma bindScReply_obj_at'_scTCB[wp]: "bindScReply scPtr replyPtr \\s. P (obj_at' (\ko. P' (scTCB ko)) scPtr s)\" @@ -1028,7 +905,7 @@ lemma updateReply_replyNext_None_invs': updateReply rptr (replyNext_update (\_. None)) \\_. invs'\" apply (simp only: invs'_def valid_pspace'_def) - apply (wpsimp wp: updateReply_valid_objs' updateReply_iflive') + apply (wpsimp wp: updateReply_valid_objs') apply (clarsimp simp: obj_at'_def valid_reply'_def live_reply'_def dest: pspace_alignedD' pspace_distinctD') done @@ -1085,10 +962,6 @@ lemma sym_refs_replySCs_of_None: by (clarsimp simp: state_refs_of'_def refs_of_rev' opt_map_red split: option.split_asm if_split_asm) -(* cleanReply *) -crunch cleanReply - for valid_tcbs'[wp]: valid_tcbs' - lemma no_fail_setReply [wp]: "no_fail (reply_at' p) (setReply p reply)" unfolding setReply_def @@ -1106,20 +979,6 @@ lemma no_fail_cleanReply [wp]: apply (clarsimp simp: obj_at'_def ps_clear_upd gen_objBits_simps) done -(* sc_with_reply/sc_with_reply' *) - -lemma valid_objs'_replyPrevs_of_reply_at': - "\ valid_objs' s'; replyPrevs_of s' rp = Some rp'\ \ reply_at' rp' s'" - apply (clarsimp elim!: opt_mapE) - apply (erule (1) valid_objsE') - by (clarsimp simp: valid_obj'_def valid_reply'_def valid_bound_obj'_def obj_at'_def) - -lemma valid_objs'_replyNexts_of_reply_at': - "\ valid_objs' s'; replyNexts_of s' rp = Some rp'\ \ reply_at' rp' s'" - apply (clarsimp elim!: opt_mapE) - apply (erule (1) valid_objsE') - by (clarsimp simp: valid_obj'_def valid_reply'_def valid_bound_obj'_def obj_at'_def) - (** sc_with_reply and sc_replies_relations : crossing information **) (* modified version of sc_replies_relation_prevs_list in StateRelation.thy; @@ -1189,8 +1048,9 @@ lemma next_reply_in_sc_replies: by (force dest!: in_list_decompose_takeWhile) lemma prev_reply_in_sc_replies: - "\sc_replies_relation s s'; sc_with_reply rp s = Some scp; sym_refs (list_refs_of_replies' s'); - sym_refs (state_refs_of' s'); replyPrevs_of s' rp = Some nrp; + "\sc_replies_relation s s'; pspace_relation (kheap s) (ksPSpace s'); + sc_with_reply rp s = Some scp; sym_refs (list_refs_of_replies' s'); + sym_refs (state_refs_of s); replyPrevs_of s' rp = Some nrp; pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'\ \\xs ys. sc_replies_of s scp = Some (xs @ rp # nrp # ys)" apply (frule (1) sc_replies_relation_sc_with_reply_heap_path) @@ -1201,9 +1061,6 @@ lemma prev_reply_in_sc_replies: using heap_ls_unique sc_replies_relation_prevs_list' apply blast apply simp apply (frule (2) heap_ls_next_in_list) - apply (frule (3) sym_refs_replySCs_of_None[where rp=nrp]) - apply (rule replyNexts_Some_replySCs_None, simp) - apply (drule_tac x=scp in spec) apply (clarsimp simp: vs_heap_simps) apply (frule (2) heap_ls_next_takeWhile_append[where p=rp]) apply (frule in_list_decompose_takeWhile[where x=nrp]) @@ -1292,9 +1149,10 @@ lemma sc_with_reply_replyPrev_None: apply (clarsimp elim!: opt_mapE) apply (erule (1) pspace_dom_relatedE) apply (erule (1) obj_relation_cutsE) - apply ((clarsimp simp: other_obj_relation_def other_aobj_relation_def is_reply obj_at_def + apply ((clarsimp simp: is_reply obj_at_def is_other_obj_relation_type_def + other_aobj_relation_def split: Structures_A.kernel_object.split_asm if_split_asm - RISCV64_A.arch_kernel_obj.split_asm)+)[8] + RISCV64_A.arch_kernel_obj.split_asm)+)[9] apply (prop_tac "sc_with_reply' rp s' = None \ reply_at' rp s' \ pspace_aligned' s' \ pspace_distinct' s'") apply (fastforce simp: sc_replies_relation_sc_with_reply_cross_eq elim!: reply_at_cross pspace_distinct_cross pspace_aligned_cross) @@ -1320,16 +1178,17 @@ lemma sc_with_reply_replyNext_None: "\sc_with_reply rp s = None; sc_replies_relation s s'; valid_objs' s'; pspace_relation (kheap s) (ksPSpace s'); valid_replies s; pspace_distinct s; pspace_aligned s; - sym_refs (state_refs_of' s'); sym_refs (list_refs_of_replies' s'); + sym_refs (state_refs_of s); sym_refs (list_refs_of_replies' s'); replyNexts_of s' rp = Some nxt_rp\ \ sc_with_reply nxt_rp s = None" apply (prop_tac "reply_at rp s") apply (clarsimp elim!: opt_mapE) apply (erule (1) pspace_dom_relatedE) apply (erule (1) obj_relation_cutsE) - apply ((clarsimp simp: other_obj_relation_def other_aobj_relation_def is_reply obj_at_def + apply ((clarsimp simp: is_reply obj_at_def is_other_obj_relation_type_def + other_aobj_relation_def split: Structures_A.kernel_object.split_asm if_split_asm - RISCV64_A.arch_kernel_obj.split_asm)+)[8] + RISCV64_A.arch_kernel_obj.split_asm)+)[9] apply (prop_tac "pspace_aligned' s' \ pspace_distinct' s'") apply (fastforce elim!: pspace_distinct_cross pspace_aligned_cross) apply (rule ccontr) @@ -1342,7 +1201,7 @@ lemma sc_with_reply_replyNext_None: apply (rule_tac x=scp in exI) apply (frule (1) sym_refs_replyNext_replyPrev_sym[THEN iffD1]) apply (frule pspace_relation_pspace_bounded') - apply (frule (7) prev_reply_in_sc_replies) + apply (frule (8) prev_reply_in_sc_replies) apply (drule sc_with_reply_SomeD) apply (clarsimp simp: vs_heap_simps) apply (rename_tac sc n) @@ -1368,8 +1227,8 @@ lemma pspace_relation_reply_at: shows "reply_at p s" using assms apply - apply (erule (1) pspace_dom_relatedE) - apply (erule (1) obj_relation_cutsE) - apply (clarsimp simp: other_obj_relation_def other_aobj_relation_def is_reply obj_at_def + apply (erule (1) obj_relation_cutsE; + clarsimp simp: is_reply obj_at_def is_other_obj_relation_type_def other_aobj_relation_def split: Structures_A.kernel_object.split_asm if_split_asm RISCV64_A.arch_kernel_obj.split_asm)+ done @@ -1430,6 +1289,10 @@ lemma updateReply_sr_inv: apply (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def) apply (frule tcbs_of'_non_tcb_update) apply clarsimp + apply (extract_conjunct \match conclusion in "ep_queues_relation_2 _ _ _ _" \ -\) + apply (fastforce simp: ep_queues_relation_def eps_of_kh_def projectKO_opts_defs) + apply (extract_conjunct \match conclusion in "ntfn_queues_relation_2 _ _ _ _" \ -\) + apply (fastforce simp: ntfn_queues_relation_def projectKO_opts_defs) apply (clarsimp simp: ready_queues_relation_def Let_def release_queue_relation_def) done @@ -1464,7 +1327,7 @@ lemma updateReply_sr_inv_next: apply clarsimp apply (erule (2) pspace_relation_reply_update_conc_only) apply (clarsimp simp: reply_relation_def) - apply (rule conjI) + apply (extract_conjunct \match conclusion in "sc_replies_relation_2 _ _ _" \ -\) apply (clarsimp simp: sc_replies_relation_def) apply (drule_tac x=p and y=replies in spec2) apply (clarsimp simp: vs_heap_simps projectKO_opt_reply projectKO_opt_sc) @@ -1480,6 +1343,10 @@ lemma updateReply_sr_inv_next: apply (clarsimp simp: typ_at'_def ko_wp_at'_def obj_at'_def) apply (frule tcbs_of'_non_tcb_update) apply clarsimp + apply (extract_conjunct \match conclusion in "ep_queues_relation_2 _ _ _ _" \ -\) + apply (fastforce simp: ep_queues_relation_def eps_of_kh_def projectKO_opts_defs) + apply (extract_conjunct \match conclusion in "ntfn_queues_relation_2 _ _ _ _" \ -\) + apply (fastforce simp: ntfn_queues_relation_def projectKO_opts_defs) apply (clarsimp simp: ready_queues_relation_def Let_def release_queue_relation_def) done @@ -1527,6 +1394,11 @@ lemma scReply_update_empty_sc_with_reply': apply blast by simp +(* FIXME RT: move *) +lemma takeWhile_taken_P: + "x \ set (takeWhile P queue) \ P x" + by (induction queue arbitrary: x; fastforce split: if_split_asm) + (* another version of sc_replies_update_takeWhile_not_fst_replies_with_sc? *) lemma sc_replies_update_takeWhile_sc_with_reply: "\(\s. sc_with_reply rp s = Some scp) and valid_replies\ @@ -1715,7 +1587,7 @@ lemma updateReply_replyPrev_takeWhile_middle_corres: shows "corres dc (valid_objs and pspace_aligned and pspace_distinct and valid_replies - and (\s. sym_refs (state_refs_of s)) + and (\s. sym_refs (state_refs_of s)) and (\s. sc_with_reply rp s = Some scp) and obj_at (\ko. \n. ko = kernel_object.SchedContext sc n) scp and reply_sc_reply_at ((=) None) rp) @@ -1732,7 +1604,7 @@ proof - (* crossing information *) apply (rule_tac Q'="reply_at' rp and reply_at' nrp and sc_at' scp and pspace_distinct' and pspace_aligned' - and (\s. sym_refs (state_refs_of' s)) + and (\s. sym_refs (state_refs_of' s)) and (\s'. sc_with_reply' rp s' = Some scp)" in corres_cross_add_guard) apply clarsimp @@ -1740,12 +1612,25 @@ proof - apply (fastforce dest!: state_relationD intro!: reply_at_cross simp: reply_sc_reply_at_def obj_at_def is_reply) apply (intro conjI, simp) - apply (fastforce dest!: valid_objs'_replyNexts_of_reply_at') - apply (fastforce dest!: state_relationD sc_at_cross elim: valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj) - apply (fastforce dest!: state_relationD pspace_distinct_cross) - apply (fastforce dest!: state_relationD pspace_aligned_cross) - apply (fastforce dest!: state_refs_of_cross_eq) + apply (rule reply_at_cross, fastforce+) + apply (rule valid_objs_sc_replies_reply_at[where sc_ptr=scp]) + apply fastforce + apply (clarsimp simp: sc_at_ppred_def obj_at_def) + apply (frule state_relation_sc_replies_relation) + apply (clarsimp simp: sc_replies_relation_def) + apply (drule_tac x=scp in spec) + apply (drule_tac x="sc_replies sc" in spec) + apply (elim impE) + apply (clarsimp simp: sc_replies_of_scs_def map_project_def scs_of_kh_def opt_map_def) + apply (frule (1) heap_ls_prev_cases[where np=rp and p=nrp]) + apply (fastforce simp: sym_refs_replyNext_replyPrev_sym) + apply (erule reply_sym_heap_Prev_Next) + apply (fastforce dest: heap_path_head) + apply (fastforce dest!: state_relationD sc_at_cross elim: valid_objs_valid_sched_context_size + simp: obj_at_def is_sc_obj) + apply (fastforce dest!: state_relationD pspace_distinct_cross) + apply (fastforce dest!: state_relationD pspace_aligned_cross) + apply (fastforce dest!: sym_refs_cross) apply (fastforce dest: state_relationD simp: sc_replies_relation_sc_with_reply_cross_eq) (* corres proof *) apply (clarsimp simp: corres_underlying_def) @@ -1792,8 +1677,7 @@ proof - apply (frule_tac ko'="kernel_object.Reply reply" and x'=nrp in RISCV64.obj_relation_cut_same_type) (*FIXME arch-split RT*) apply simp+ apply (clarsimp simp: reply_relation_def) - apply (rule conjI) - (* sc_replies_relation *) + apply (extract_conjunct \match conclusion in "sc_replies_relation_2 _ _ _" \ -\) apply (clarsimp simp: projectKO_opt_sc opt_map_red) apply (clarsimp simp: sc_replies_relation_def sc_replies_of_scs_def map_project_def scs_of_kh_def) apply (drule_tac x=p in spec) @@ -1828,13 +1712,26 @@ proof - apply (erule_tac x=scp in allE)+ apply (clarsimp simp: obj_at_def a_type_def split: Structures_A.kernel_object.splits if_split_asm) + apply (prop_tac "tcbs_of' s' nrp = None") + apply (clarsimp simp: opt_map_def projectKO_opts_defs split: option.splits) + apply (extract_conjunct \match conclusion in "ep_queues_relation_2 _ _ _ _" \ -\) + apply (clarsimp simp: ep_queues_relation_def eps_of_kh_def projectKO_opts_defs) + apply (extract_conjunct \match conclusion in "ntfn_queues_relation_2 _ _ _ _" \ -\) + apply (clarsimp simp: ntfn_queues_relation_def projectKO_opts_defs) apply (clarsimp simp: caps_of_state_after_update cte_wp_at_after_update swp_def fun_upd_def gen_obj_at_simps) apply (rule conjI) apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def list_queue_relation_def) apply (rule conjI) - apply (fastforce intro: rsubst3[where P=heap_ls] simp: opt_map_def split: option.splits) + apply (rename_tac d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply clarsimp + apply (erule heap_ls_cong) + subgoal by (fastforce simp: opt_map_def projectKO_opts_defs) + apply fastforce + apply fastforce apply (clarsimp simp: prev_queue_head_def opt_map_def inQ_def opt_pred_def split: option.splits) apply blast apply (clarsimp simp: release_queue_relation_def Let_def list_queue_relation_def) diff --git a/proof/refine/RISCV64/SchedContextInv_R.thy b/proof/refine/RISCV64/SchedContextInv_R.thy index f017c300eb..25c6532860 100644 --- a/proof/refine/RISCV64/SchedContextInv_R.thy +++ b/proof/refine/RISCV64/SchedContextInv_R.thy @@ -187,6 +187,7 @@ lemma decodeSchedcontext_Bind_corres: apply (corresKsimp corres: getNotification_corres simp: get_sk_obj_ref_def ntfn_relation_def valid_cap_def valid_cap'_def wp: hoare_vcg_all_lift) + apply fastforce apply (rule corres_splitEE_skip; (solves wpsimp)?) apply (corresKsimp corres: getNotification_corres simp: get_sk_obj_ref_def sc_relation_def) @@ -405,25 +406,24 @@ lemma decode_sc_ctrl_inv_corres: lemma schedContextBindNtfn_corres: "corres dc (valid_objs and sc_ntfn_sc_at ((=) None) scp - and (obj_at (\ko. \ntfn. ko = Notification ntfn \ ntfn_sc ntfn = None) ntfnp) + and (obj_at (\ko. \ntfn. ko = kernel_object.Notification ntfn \ ntfn_sc ntfn = None) ntfnp) and (\s. sym_refs (state_refs_of s)) and pspace_aligned and pspace_distinct) - (ntfn_at' ntfnp and sc_at' scp) + \ (sched_context_bind_ntfn scp ntfnp) (schedContextBindNtfn scp ntfnp)" apply add_sym_refs unfolding sched_context_bind_ntfn_def schedContextBindNtfn_def - apply (rule corres_stateAssert_ignore, simp) - apply (clarsimp simp: update_sk_obj_ref_def bind_assoc) + apply (clarsimp simp: updateNotification_def update_sk_obj_ref_def bind_assoc) apply (rule corres_guard_imp) apply (rule corres_split[OF getNotification_corres]) - apply (rule corres_split[OF setNotification_corres]) + apply (rule corres_split[OF setNotification_no_queue_update_corres], simp) apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) apply (rule updateSchedContext_no_stack_update_corres) apply (clarsimp simp: sc_relation_def refillSize_def) apply (clarsimp simp: opt_map_red) apply (clarsimp simp: objBits_simps') - apply wpsimp+ + apply (wpsimp wp: get_simple_ko_wp getNotification_wp)+ apply (fastforce simp: obj_at_simps sc_ntfn_sc_at_def is_ntfn is_sc_obj valid_obj_def) - apply clarsimp + apply (clarsimp simp: obj_at'_def) done crunch tcb_sched_action, complete_yield_to, reschedule_required, sched_context_resume @@ -448,7 +448,6 @@ crunch schedContextCompleteYieldTo, tcbSchedEnqueue, tcbSchedDequeue, rescheduleRequired, schedContextResume for valid_ipc_buffer_ptr'[wp]: "valid_ipc_buffer_ptr' buf" and sc_at'[wp]: "sc_at' scp" - and cur_tcb'[wp]: cur_tcb' (simp: crunch_simps wp: crunch_wps threadSet_cur ignore: setSchedContext) lemma sc_yield_from_update_sc_tcb_sc_at[wp]: @@ -499,8 +498,20 @@ crunch set_tcb_obj_ref for ready_qs_distinct[wp]: ready_qs_distinct (rule: ready_qs_distinct_lift) -crunch setSchedContext - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers +lemma returnConsumed_corres: + "corres (=) + (sc_at scp and pspace_aligned and pspace_distinct and cur_tcb) \ + (return_consumed scp) (returnConsumed scp)" + apply (clarsimp simp: return_consumed_def returnConsumed_def) + apply (rule_tac Q'=cur_tcb' in corres_cross_add_guard) + apply (fastforce intro!: cur_tcb_cross) + apply (rule corres_stateAssert_ignore, simp) + apply (rule corres_guard_imp) + apply (rule corres_split[OF schedContextUpdateConsumed_corres], simp) + apply (rule corres_return_eq_same) + apply fastforce + apply wpsimp+ + done lemma schedContextYieldTo_corres: "corres (=) @@ -521,8 +532,8 @@ lemma schedContextYieldTo_corres: apply (rename_tac sc sc') apply (rule_tac P="einvs and ?ct and ?scp and ct_active and ct_not_in_release_q and (\s. \n. ko_at (Structures_A.SchedContext sc n) scp s)" - and P'="invs' and cur_tcb' and ko_at' sc' scp" - in corres_inst) + and P'="invs' and ko_at' sc' scp" + in corres_inst) apply simp apply (erule exE) apply (rule corres_underlying_split[where r'=dc]) @@ -535,8 +546,8 @@ lemma schedContextYieldTo_corres: apply (rule_tac P="einvs and ?ct and ?scp and ct_active and ct_not_in_release_q and (\s. \n. ko_at (Structures_A.SchedContext sc n) scp s) and K (bound (sc_yield_from sc))" - and P'="invs' and cur_tcb' and ko_at' sc' scp" - in corres_inst) + and P'="invs' and ko_at' sc' scp" + in corres_inst) apply (rule corres_gen_asm') apply (erule exE, simp only: option.sel) apply (rule corres_guard_imp) @@ -544,8 +555,8 @@ lemma schedContextYieldTo_corres: apply (rule corres_split[OF schedContextCompleteYieldTo_corres]) apply (rule_tac P="einvs and ?ct and ?scp and ct_active and ct_not_in_release_q and sc_yf_sc_at ((=) None) scp" - and P'="invs' and cur_tcb'" - in corres_inst) + and P'=invs' + in corres_inst) apply simp apply (rule corres_symb_exec_l) apply (rename_tac sc'') @@ -566,8 +577,6 @@ lemma schedContextYieldTo_corres: apply clarsimp apply (fastforce simp: valid_obj'_def valid_sched_context'_def obj_at'_def dest!: invs_valid_objs') - apply (rule_tac P="einvs and sc_at scp and ct_active and ct_not_in_release_q" - and P'="invs' and cur_tcb' and sc_at' scp" in corres_inst) apply simp apply (clarsimp simp: sc_yf_sc_at_def sc_tcb_sc_at_def obj_at_def is_sc_obj) apply (fastforce dest!: invs_valid_objs simp: valid_obj_def valid_sched_context_def obj_at_def) @@ -575,7 +584,7 @@ lemma schedContextYieldTo_corres: apply simp apply (rule_tac P="einvs and sc_yf_sc_at ((=) None) scp and ?ct and ?scp and ct_active and ct_not_in_release_q" - and P'="invs' and cur_tcb' and sc_at' scp" + and P'="invs' and sc_at' scp" in corres_inst) apply (rule corres_guard_imp) apply (rule corres_split[OF schedContextResume_corres]) @@ -588,7 +597,7 @@ lemma schedContextYieldTo_corres: and ct_active and ct_not_in_release_q and (\s. \n. ko_at (Structures_A.SchedContext sc0 n) scp s) and K (bound (sc_tcb sc0))" - and P'="invs' and cur_tcb' and ko_at' sc0' scp" + and P'="invs' and ko_at' sc0' scp" in corres_inst) apply (rule corres_gen_asm') apply (elim exE) @@ -598,10 +607,15 @@ lemma schedContextYieldTo_corres: apply (rename_tac ct_schedulable) apply (rule corres_assert_assume[rotated], fastforce) apply (simp add: bind_assoc) - apply (rule corres_symb_exec_r[OF _ getSchedulable_sp, rotated]; (solves wpsimp)?) - apply wpsimp - apply (frule (1) invs'_ko_at_valid_sched_context') - apply (fastforce simp: valid_sched_context'_def) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ getSchedulable_sp, rotated]; + (solves wpsimp)?) + apply (wpsimp wp: no_fail_getSchedulable) + apply (clarsimp simp: ex_abs_def) + apply (prop_tac "tcb_at' tp s") + apply (frule invs_valid_objs) + apply (frule (1) valid_objs_ko_at) + apply (fastforce intro!: tcb_at_cross simp: valid_obj_def valid_sched_context_def) + apply fastforce apply (rename_tac ct_schedulable') apply (rule_tac F="ct_schedulable = ct_schedulable'" in corres_req) apply clarsimp @@ -617,10 +631,9 @@ lemma schedContextYieldTo_corres: and ct_active and ct_not_in_release_q and (\s. sched = schedulable tp s) and tcb_at tp and sc_tcb_sc_at ((=) (Some tp)) scp" - and P'="invs' and cur_tcb' and tcb_at' tp and ko_at' sc0' scp - and (\s. scTCBs_of s scp = Some tp)" - in corres_inst) - apply (rule corres_guard_imp) + and P'=invs' + in corres_inst) + apply (rule stronger_corres_guard_imp) apply (rule corres_if2, simp) apply (rule corres_split_eqr[OF getCurThread_corres]) apply (rename_tac ct_ptr) @@ -644,13 +657,12 @@ lemma schedContextYieldTo_corres: and tcb_at ct_ptr and st_tcb_at runnable tp and sc_tcb_sc_at ((=) (Some tp)) scp and in_correct_ready_q and ready_qs_distinct - and ready_or_release + and ready_queues_runnable and ready_or_release + and ep_queues_blocked and ntfn_queues_blocked and (\s. sched = schedulable tp s) and (\s. cur_thread s = ct_ptr) and ct_active and ct_not_in_release_q and K sched" - and P'="valid_objs' and cur_tcb' and tcb_at' tp and sc_at' scp - and obj_at' (\sc. scYieldFrom sc = Some ct_ptr) scp - and (\s. scTCBs_of s scp = Some tp) + and P'="valid_objs' and sym_heap_sched_pointers and valid_sched_pointers and pspace_aligned' and pspace_distinct' and pspace_bounded'" in corres_inst) @@ -668,32 +680,19 @@ lemma schedContextYieldTo_corres: set_yf_sc_yf_sc_at[simplified op_equal] set_sc_obj_ref_schedulable) apply (wpsimp wp:hoare_case_option_wp) - apply (rule hoare_vcg_conj_lift) - apply (wpsimp wp: set_sc'.obj_at' set_sc'.set_wp - simp: updateSchedContext_def) - apply (rule hoare_vcg_conj_lift) - apply (wpsimp wp: set_sc'.obj_at' set_sc'.set_wp - simp: updateSchedContext_def) - apply wpsimp - apply (wpsimp wp: syt_bound_tcb_at') - apply (rule_tac Q'="\_. valid_objs' and cur_tcb' - and (\s. scTCBs_of s scp = Some tp) - and ko_at' sc0' scp and tcb_at' ct_ptr + apply ((wpsimp wp: syt_bound_tcb_at' thread_set_ready_queues_runnable + thread_set_ep_queues_blocked + thread_set_ntfn_queues_blocked thread_set_schedulable + thread_set_ct_in_state + | simp add: set_tcb_obj_ref_thread_set)+)[1] + apply (rule_tac Q'="\_. valid_objs' and sym_heap_sched_pointers and valid_sched_pointers and pspace_aligned' and pspace_distinct' - and pspace_bounded'" + and pspace_bounded' and tcb_at' ct_ptr" in hoare_post_imp) - apply (clarsimp simp: opt_map_red) - apply (frule (1) sc_ko_at_valid_objs_valid_sc'[rotated]) - apply (frule valid_objs'_valid_tcbs') - apply (clarsimp simp: valid_sched_context'_def valid_sched_context_size'_def - obj_at'_def refillSize_def) - apply (erule_tac x=tp in valid_objsE', simp) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def obj_at'_def - valid_sched_context'_def refillSize_def - valid_sched_context_size'_def - opt_pred_def opt_map_def) - apply (wpsimp wp: threadSet_cur threadSet_valid_objs' hoare_drop_imp + apply (clarsimp simp: valid_obj'_def valid_sched_context'_def + refillSize_def valid_sched_context_size'_def) + apply (wpsimp wp: threadSet_valid_objs' hoare_drop_imp threadSet_sched_pointers threadSet_valid_sched_pointers simp: fun_upd_def[symmetric]) apply (rule_tac Q'="\_. sc_at scp and valid_objs @@ -706,6 +705,8 @@ lemma schedContextYieldTo_corres: and tcb_at tp and sc_tcb_sc_at ((=) (Some tp)) scp and ct_active and ct_not_in_release_q and in_correct_ready_q and ready_qs_distinct + and ep_queues_blocked and ntfn_queues_blocked + and ready_queues_runnable and ready_or_release and (\s. sched = schedulable tp s) and (\s. cur_thread s = ct_ptr) and K sched" in hoare_post_imp) @@ -717,24 +718,20 @@ lemma schedContextYieldTo_corres: apply wpsimp apply wpsimp apply wpsimp - apply (rule_tac P="invs and sc_yf_sc_at ((=) None) scp and ?scp" - and P'="invs' and cur_tcb' and ko_at' sc0' scp" - in corres_inst) - apply simp + apply (rule corres_return_eq_same) + apply clarsimp apply clarsimp apply (frule invs_valid_objs) + apply (frule invs_sym_refs) apply (frule valid_sched_valid_ready_qs) apply (fastforce elim: sc_at_pred_n_sc_at simp: schedulable_def2) - apply (clarsimp cong: conj_cong simp: invs'_def valid_pspace'_def cur_tcb'_def) - apply (frule valid_objs'_valid_tcbs') - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + apply (fastforce intro: sc_at_cross sc_at_pred_n_sc_at cur_tcb_cross + simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def + simp flip: cur_tcb'_def) apply (rule corres_if, simp) - apply (clarsimp simp: return_consumed_def returnConsumed_def) - apply (rule corres_stateAssert_r) - apply (rule corres_split[OF schedContextUpdateConsumed_corres], simp) - apply clarsimp - apply (wpsimp wp: thread_get_wp hoare_case_option_wp)+ - apply (wpsimp wp: threadGet_wp)+ + apply (rule returnConsumed_corres) + apply clarsimp + apply (wpsimp wp: thread_get_wp hoare_case_option_wp cur_tcb_lift)+ apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_objs_valid_tcbs cong: conj_cong imp_cong if_cong) apply (rule context_conjI; @@ -758,8 +755,7 @@ lemma schedContextYieldTo_corres: apply ((wpsimp wp: hoare_case_option_wp sched_context_resume_valid_sched sched_context_resume_not_in_release_q_other | wps)+)[1] - apply (rule_tac Q'="\rv'. invs' and sc_at' scp and cur_tcb'" - in hoare_strengthen_post[rotated]) + apply (rule_tac Q'="\_. invs'" in hoare_post_imp) apply clarsimp apply (wpsimp wp: hoare_case_option_wp) apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def) @@ -779,9 +775,6 @@ lemma schedContextYieldTo_corres: apply (force dest!: valid_objs_ko_at[OF invs_valid_objs] simp: valid_obj_def valid_sched_context_def obj_at_def) apply (wpsimp wp: hoare_case_option_wp schedContextCompleteYieldTo_invs' split: option.splits) - apply (fastforce dest: invs'_ko_at_valid_sched_context' - simp: valid_sched_context'_def valid_bound_obj'_def obj_at'_def - split: if_splits) apply wpsimp+ apply (fastforce simp: sc_tcb_sc_at_def obj_at_def is_sc_obj elim!: valid_sched_context_size_objsI[OF invs_valid_objs]) @@ -850,8 +843,6 @@ lemma invokeSchedContext_corres: apply wpsimp+ apply (fastforce dest!: ex_nonz_cap_to_not_idle_sc_ptr) apply wpsimp - apply (frule invs_valid_global') - apply (fastforce dest!: invs_valid_pspace' global'_sc_no_ex_cap) apply (corres corres: schedContextYieldTo_corres) done @@ -859,9 +850,11 @@ lemma refillResetRR_corres: "corres dc (sc_at csc_ptr and valid_objs and pspace_aligned and pspace_distinct and is_active_sc csc_ptr and round_robin csc_ptr and valid_refills csc_ptr) - (valid_objs' and sc_at' csc_ptr) + valid_objs' (refill_reset_rr csc_ptr) (refillResetRR csc_ptr)" supply projection_rewrites[simp] + apply (rule_tac Q'=pspace_bounded' in corres_cross_add_guard) + apply (fastforce intro: pspace_relation_pspace_bounded') apply (subst is_active_sc_rewrite) apply (subst valid_refills_rewrite) apply (rule_tac Q'="is_active_sc' csc_ptr" in corres_cross_add_guard) @@ -890,6 +883,8 @@ lemma refillNew_corres: [where Q' = "sc_at' sc_ptr and (\s'. ((\sc. scSize sc = n) |< scs_of' s') sc_ptr)"]) apply (fastforce dest!: sc_obj_at_cross[OF state_relation_pspace_relation] simp: obj_at'_def in_omonad objBits_simps) + apply (rule_tac Q'=pspace_bounded' in corres_cross_add_guard) + apply (fastforce intro: pspace_relation_pspace_bounded') apply (clarsimp simp: refillNew_def refill_new_def setRefillHd_def updateRefillHd_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF getCurTime_corres], rename_tac ctime) @@ -968,6 +963,8 @@ lemma refillUpdate_corres: apply (rule corres_cross_add_guard[where Q' = "sc_at' sc_ptr"]) apply (fastforce dest!: sc_obj_at_cross[OF state_relation_pspace_relation] simp: obj_at'_def opt_map_red objBits_simps) + apply (rule_tac Q'=pspace_bounded' in corres_cross_add_guard) + apply (fastforce intro: pspace_relation_pspace_bounded') apply (rule corres_cross_add_guard [where Q'="obj_at' (\sc. objBits sc = minSchedContextBits + n) sc_ptr"]) apply (fastforce intro: sc_obj_at_cross) @@ -1063,7 +1060,7 @@ lemma refillUpdate_corres: apply (clarsimp simp: in_omonad is_active_sc2_def active_sc_def sc_refill_cfgs_of_scs_def map_project_simps) apply (wpsimp wp: update_refill_hd_is_active_sc2) - apply (rule_tac Q'="\_ s. sc_at' sc_ptr s \ valid_objs' s + apply (rule_tac Q'="\_ s. sc_at' sc_ptr s \ valid_objs' s \ pspace_bounded' s \ (\s'. ((\sc'. refillSize sc' < scRefillMax sc' \ sc_valid_refills' sc') |< scs_of' s') sc_ptr) s \ active_sc_at' sc_ptr s" @@ -1078,7 +1075,7 @@ lemma refillUpdate_corres: apply ((rule hoare_vcg_conj_lift hoare_drop_imps hoare_vcg_all_lift | wpsimp wp: update_sched_context_valid_objs_same | wpsimp wp: update_sched_context_wp)+)[1] - apply (rule_tac Q'="\_ s. sc_at' sc_ptr s \ valid_objs' s + apply (rule_tac Q'="\_ s. sc_at' sc_ptr s \ valid_objs' s \ pspace_bounded' s \ (\s'. ((\sc'. refillSize sc' < scRefillMax sc' \ sc_valid_refills' sc') |< scs_of' s') sc_ptr) s @@ -1131,7 +1128,7 @@ lemma refillNew_invs': lemma refillUpdate_invs': "\\s. invs' s \ (\n. sc_at'_n n scPtr s \ valid_refills_number' newMaxRefills n) - \ ex_nonz_cap_to' scPtr s \ MIN_REFILLS \ newMaxRefills\ + \ MIN_REFILLS \ newMaxRefills\ refillUpdate scPtr newPeriod newBudget newMaxRefills \\_. invs'\" (is "\?P\ _ \_\") @@ -1155,15 +1152,10 @@ lemma refillUpdate_invs': apply (wpsimp wp: updateSchedContext_wp refillReady_wp simp: updateRefillHd_def) apply (clarsimp simp: active_sc_at'_def obj_at_simps MIN_REFILLS_def ps_clear_def) - apply (rule_tac Q'="\_. invs' and ex_nonz_cap_to' scPtr" in bind_wp) + apply (rule_tac Q'="\_. invs'" in bind_wp) apply (wpsimp wp: updateSchedContext_invs') apply (fastforce dest: invs'_ko_at_valid_sched_context' simp: valid_sched_context'_def valid_sched_context_size'_def obj_at_simps) - apply (clarsimp simp: pred_conj_def) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply (find_goal \match conclusion in "\P\ f \\_. ex_nonz_cap_to' scPtr\" for P f \ -\) - apply (wpsimp wp: updateSchedContext_ex_nonz_cap_to' refillReady_wp - simp: updateRefillHd_def) apply (simp add: bind_assoc) apply (rule bind_wp_fwd_skip) apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) @@ -1260,7 +1252,7 @@ lemma invokeSchedControlConfigureFlags_corres: apply (rule_tac Q="\s. sc_at (cur_sc s) s" in corres_cross_add_abs_guard) apply (fastforce intro: cur_sc_tcb_sc_at_cur_sc) apply (rule_tac Q'="\s'. active_sc_at' (ksCurSc s') s'" in corres_cross_add_guard) - apply (fastforce intro: active_sc_at'_cross simp: state_relation_def) + apply (force intro!: active_sc_at'_cross simp: state_relation_def) apply (rule_tac F="budget \ MAX_PERIOD \ budget \ MIN_BUDGET \ period \ MAX_PERIOD \ budget \ MIN_BUDGET \ MIN_REFILLS \ mrefills \ budget \ period" @@ -1316,17 +1308,17 @@ lemma invokeSchedControlConfigureFlags_corres: apply (rule commitTime_corres) apply (wpsimp wp: hoare_drop_imps | wps)+ apply (frule valid_sched_valid_ready_qs) + apply (frule valid_sched_valid_release_q) + apply (frule invs_sym_refs) apply (intro conjI impI; fastforce?) - apply (fastforce dest: invs_valid_objs valid_sched_context_objsI - simp: valid_sched_context_def valid_bound_obj_def obj_at_def) - apply (frule valid_sched_valid_release_q) - apply fastforce + apply (fastforce dest: invs_valid_objs valid_sched_context_objsI + simp: valid_sched_context_def valid_bound_obj_def obj_at_def) apply (fastforce dest: invs_valid_objs valid_sched_context_objsI simp: valid_sched_context_def valid_bound_obj_def obj_at_def) apply (fastforce intro: active_scs_validE) apply (fastforce dest: invs_valid_objs' sc_ko_at_valid_objs_valid_sc' - intro: valid_objs'_valid_refills' - simp: valid_sched_context'_def valid_bound_obj'_def active_sc_at'_rewrite) + intro: valid_objs'_valid_refills' active_sc_at'_imp_is_active_sc' + simp: valid_sched_context'_def valid_bound_obj'_def) apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) apply wps_conj_solves @@ -1393,9 +1385,12 @@ lemma invokeSchedControlConfigureFlags_corres: split: option.splits) apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply (wps_conj_solves simp: active_sc_at'_rewrite) - apply (wpsimp wp: commitTime_invs' tcbReleaseRemove_invs' - simp: active_sc_at'_rewrite) + apply wps_conj_solves + apply (wpsimp wp: commitTime_invs' tcbReleaseRemove_invs') + apply ((wpsimp | wps)+)[1] + apply (fastforce intro: aligned'_distinct'_obj_at'I + simp: active_sc_at'_def opt_pred_def opt_map_def obj_at'_def + split: option.splits) apply (rule_tac Q="\_ s. invs s \ schact_is_rct s \ current_time_bounded s \ valid_sched_action s \ active_scs_valid s \ valid_ready_qs s \ valid_release_q s \ ready_or_release s @@ -1450,8 +1445,6 @@ lemma invokeSchedControlConfigureFlags_corres: apply (rule valid_objs'_valid_refills') apply fastforce apply (clarsimp simp: obj_at_simps ko_wp_at'_def) - apply (rename_tac ko obj, case_tac ko; clarsimp) - apply simp apply (rule corres_guard_imp) apply (rule_tac n=n in refillNew_corres) @@ -1549,6 +1542,7 @@ lemma invokeSchedControlConfigureFlags_corres: apply fastforce apply (clarsimp simp: objBits_simps) apply wpsimp+ + apply (frule invs_sym_refs) apply (fastforce simp: sc_at_pred_n_def obj_at_def schact_is_rct_def pred_tcb_at_def intro: valid_sched_action_weak_valid_sched_action) apply (fastforce intro: sc_at_cross) diff --git a/proof/refine/RISCV64/SchedContext_R.thy b/proof/refine/RISCV64/SchedContext_R.thy index 2b8dcd8a22..97f494aeac 100644 --- a/proof/refine/RISCV64/SchedContext_R.thy +++ b/proof/refine/RISCV64/SchedContext_R.thy @@ -54,27 +54,10 @@ lemma sym_refs_tcbSchedContext: apply (auto simp: state_refs_of'_def ko_wp_at'_def obj_at'_def refs_of_rev' tcb_bound_refs'_def) done -lemma setSchedContext_valid_idle'[wp]: - "\valid_idle' and K (scPtr = idle_sc_ptr \ idle_sc' v)\ - setSchedContext scPtr v - \\rv. valid_idle'\" - apply (rule hoare_weaken_pre) - apply (simp add: valid_idle'_def) - apply (wpsimp simp: setSchedContext_def wp: setObject_ko_wp_at) - apply (rule hoare_lift_Pf3[where f=ksIdleThread]) - apply (wpsimp wp: hoare_vcg_conj_lift) - apply (wpsimp simp: obj_at'_real_def wp: setObject_ko_wp_at) - apply wpsimp - apply (wpsimp wp: updateObject_default_inv) - by (auto simp: valid_idle'_def obj_at'_real_def ko_wp_at'_def)[1] - lemma setSchedContext_invs': - "\invs' - and (\s. live_sc' sc \ ex_nonz_cap_to' scPtr s) - and valid_sched_context' sc - and (\_. valid_sched_context_size' sc)\ - setSchedContext scPtr sc - \\rv. invs'\" + "\invs' and valid_sched_context' sc and (\_. valid_sched_context_size' sc)\ + setSchedContext scPtr sc + \\_. invs'\" apply (simp add: invs'_def valid_dom_schedule'_def) apply (wpsimp wp: untyped_ranges_zero_lift sym_heap_sched_pointers_lift simp: cteCaps_of_def o_def) @@ -91,11 +74,10 @@ lemma setSchedContext_active_sc_at': lemma updateSchedContext_invs': "\invs' - and (\s. \ko. ko_at' ko scPtr s \ live_sc' (f ko) \ ex_nonz_cap_to' scPtr s) and (\s. \ko. ko_at' ko scPtr s \ valid_sched_context' (f ko) s \ valid_sched_context_size' (f ko))\ - updateSchedContext scPtr f - \\rv. invs'\" + updateSchedContext scPtr f + \\_. invs'\" apply (simp add: updateSchedContext_def) by (wpsimp wp: setSchedContext_invs') @@ -112,32 +94,11 @@ lemma sym_refs_sc_trivial_update: apply (rule ext) by (clarsimp simp: state_refs_of'_def obj_at'_real_def ko_wp_at'_def) -lemma live_sc'_ko_ex_nonz_cap_to': - "\invs' s; ko_at' ko scPtr s\ \ live_sc' ko \ ex_nonz_cap_to' scPtr s" - apply (drule invs_iflive') - apply (erule if_live_then_nonz_capE') - by (clarsimp simp: ko_wp_at'_def obj_at'_real_def live'_def) - -lemma updateSchedContext_refills_invs': - "\invs' - and (\s. \ko. ko_at' ko scPtr s \ valid_sched_context' (f ko) s \ valid_sched_context_size' (f ko)) - and (\_. \ko. scNtfn (f ko) = scNtfn ko) - and (\_. \ko. scTCB (f ko) = scTCB ko) - and (\_. \ko. scYieldFrom (f ko) = scYieldFrom ko) - and (\_. \ko. scReply (f ko) = scReply ko)\ - updateSchedContext scPtr f - \\rv. invs'\" - apply (simp add: updateSchedContext_def) - apply (wpsimp wp: setSchedContext_invs') - apply (erule (1) live_sc'_ko_ex_nonz_cap_to') - apply (clarsimp simp: live_sc'_def) - done - lemma updateSchedContext_active_sc_at': "\active_sc_at' scPtr' and (\s. scPtr = scPtr' \ (\ko. ko_at' ko scPtr s \ 0 < scRefillMax ko \ 0 < scRefillMax (f ko)))\ - updateSchedContext scPtr f - \\rv. active_sc_at' scPtr'\" + updateSchedContext scPtr f + \\_. active_sc_at' scPtr'\" apply (simp add: updateSchedContext_def) apply (wpsimp wp: setSchedContext_active_sc_at') apply (clarsimp simp: active_sc_at'_def obj_at'_real_def ko_wp_at'_def) @@ -154,24 +115,6 @@ lemma ksPSpace_valid_sched_context': \ valid_sched_context' sc s \ valid_sched_context_size' sc" by (fastforce simp: valid_objs'_def valid_obj'_def split: kernel_object.splits) -lemma updateSchedContext_invs'_indep: - "\invs' - and (\s. \ko. valid_sched_context' ko s \ valid_sched_context' (f ko) s) - and (\_. \ko. valid_sched_context_size' ko \ valid_sched_context_size' (f ko)) - and (\s. \ko. scNtfn (f ko) = scNtfn ko - \ scTCB (f ko) = scTCB ko - \ scYieldFrom (f ko) = scYieldFrom ko - \ scReply (f ko) = scReply ko )\ - updateSchedContext scPtr f - \\rv. invs'\" - apply (wpsimp wp: updateSchedContext_invs') - apply (intro conjI; intro allI impI; (drule_tac x=ko in spec)+) - apply (clarsimp simp: invs'_def valid_objs'_def obj_at'_def) - apply (erule if_live_then_nonz_capE') - apply (clarsimp simp: ko_wp_at'_def live'_def live_sc'_def) - apply (frule (1) invs'_ko_at_valid_sched_context', simp) - done - context begin interpretation Arch . (*FIXME: arch-split*) lemma schedContextUpdateConsumed_corres: @@ -233,13 +176,11 @@ crunch schedContextUpdateConsumed and irq_node'[wp]: "\s. P (irq_node' s)" and no_0_obj'[wp]: no_0_obj' and valid_mdb'[wp]: valid_mdb' - and sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" and valid_global_refs'[wp]: valid_global_refs' and valid_arch_state'[wp]: valid_arch_state' and interrupt_state[wp]: "\s. P (ksInterruptState s)" and valid_irq_state'[wp]: valid_irq_states' and valid_machine_state'[wp]: valid_machine_state' - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' and pspace_domain_valid[wp]: pspace_domain_valid and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" @@ -247,7 +188,6 @@ crunch schedContextUpdateConsumed and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" and ctes_of[wp]: "\s. P (ctes_of s)" and ksCurThread[wp]: "\s. P (ksCurThread s)" - and ct_not_inQ[wp]: ct_not_inQ and ksQ[wp]: "\s. P (ksReadyQueues s p)" and reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" and valid_replies' [wp]: valid_replies' @@ -268,18 +208,6 @@ lemma schedContextUpdateConsumed_valid_ipc_buffer_ptr'[wp]: unfolding schedContextUpdateConsumed_def valid_ipc_buffer_ptr'_def by wpsimp -lemma schedContextUpdateConsumed_iflive[wp]: - "schedContextUpdateConsumed scp \if_live_then_nonz_cap'\" - apply (wpsimp simp: schedContextUpdateConsumed_def updateSchedContext_def) - apply (clarsimp elim!: if_live_then_nonz_capE' simp: obj_at'_def ko_wp_at'_def live'_def) - done - -lemma schedContextUpdateConsumed_valid_idle'[wp]: - "schedContextUpdateConsumed scp \valid_idle'\" - apply (wpsimp simp: schedContextUpdateConsumed_def updateSchedContext_def) - apply (clarsimp simp: valid_idle'_def obj_at'_def) - done - lemma schedContextUpdateConsumed_state_refs_of: "schedContextUpdateConsumed sc \\s. P (state_refs_of' s)\" unfolding schedContextUpdateConsumed_def updateSchedContext_def @@ -316,19 +244,16 @@ lemma schedContextUpdateConsumed_invs'[wp]: simp: cteCaps_of_def o_def) done -(* FIXME RT: should other update wp rules for valid_objs/valid_objs' be in this form? - The following might be nicer: - \sc'. scs_of' s scp = Some sc' \ valid_obj' (injectKO sc') s - \ valid_obj' (injectKO (f' sc') s) *) lemma updateSchedContext_valid_objs'[wp]: - "\valid_objs' and - (\s. ((\sc'. valid_obj' (injectKO sc') s \ valid_obj' (injectKO (f' sc')) s) - |< scs_of' s) scp)\ + "\\s. valid_objs' s + \ (\sc'. ko_at' sc' scp s \ valid_obj' (injectKO sc') s + \ valid_obj' (injectKO (f' sc')) s)\ updateSchedContext scp f' \\_. valid_objs'\" apply (wpsimp simp: updateSchedContext_def wp: set_sc'.valid_objs') - by (fastforce simp: valid_obj'_def valid_sched_context'_def valid_sched_context_size'_def - obj_at'_def scBits_simps gen_objBits_simps opt_map_red opt_pred_def) + apply (fastforce simp: valid_obj'_def valid_sched_context'_def valid_sched_context_size'_def + obj_at'_def opt_map_red) + done lemma valid_tcb'_tcbYieldTo_update: "valid_tcb' tcb s \ valid_tcb' (tcbYieldTo_update Map.empty tcb) s" @@ -336,12 +261,13 @@ lemma valid_tcb'_tcbYieldTo_update: lemma schedContextCancelYieldTo_valid_objs'[wp]: "schedContextCancelYieldTo tptr \valid_objs'\" - apply (clarsimp simp: schedContextCancelYieldTo_def) - apply (wpsimp wp: threadSet_valid_objs' hoare_vcg_all_lift threadGet_wp + unfolding schedContextCancelYieldTo_def + apply (wpsimp wp: threadSet_valid_objs' threadGet_wp | strengthen valid_tcb'_tcbYieldTo_update)+ - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') - by (fastforce simp: valid_obj'_def opt_map_def gen_obj_at_simps valid_tcb'_def refillSize_def - valid_sched_context'_def valid_sched_context_size'_def opt_pred_def) + apply (clarsimp simp: valid_obj'_def valid_sched_context'_def valid_sched_context_size'_def + refillSize_def + split: if_splits) + done lemma schedContextCancelYieldTo_valid_mdb'[wp]: "schedContextCancelYieldTo tptr \valid_mdb'\" @@ -350,47 +276,12 @@ lemma schedContextCancelYieldTo_valid_mdb'[wp]: apply (fastforce simp: obj_at'_def update_tcb_cte_cases) done -lemma schedContextCancelYieldTo_sch_act_wf[wp]: - "schedContextCancelYieldTo tptr \\s. sch_act_wf (ksSchedulerAction s) s\" - apply (clarsimp simp: schedContextCancelYieldTo_def updateSchedContext_def) - apply (wpsimp wp: threadSet_sch_act threadGet_wp) - done - -lemma schedContextCancelYieldTo_if_live_then_nonz_cap'[wp]: - "\\s. if_live_then_nonz_cap' s\ - schedContextCancelYieldTo tptr - \\_. if_live_then_nonz_cap'\" - apply (clarsimp simp: schedContextCancelYieldTo_def updateSchedContext_def) - apply (wpsimp wp: RISCV64.threadSet_iflive' setSchedContext_iflive' hoare_vcg_imp_lift' hoare_vcg_all_lift - threadGet_wp) (*FIXME arch-split RT*) - by (fastforce elim: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def live'_def live_sc'_def) - lemma schedContextCancelYieldTo_if_unsafe_then_cap'[wp]: "schedContextCancelYieldTo tptr \if_unsafe_then_cap'\" apply (clarsimp simp: schedContextCancelYieldTo_def updateSchedContext_def) apply (wpsimp wp: threadSet_ifunsafe' threadGet_wp) done -lemma schedContextCancelYieldTo_valid_idle'[wp]: - "schedContextCancelYieldTo tptr \valid_idle'\" - apply (clarsimp simp: schedContextCancelYieldTo_def updateSchedContext_def) - apply (wpsimp wp: threadSet_idle' setObject_sc_idle' updateObject_default_inv - threadGet_wp hoare_vcg_imp_lift' hoare_vcg_all_lift) - apply (fastforce simp: valid_idle'_def obj_at'_def idle_tcb'_def) - done - -lemma schedContextCancelYieldTo_ct_not_inQ[wp]: - "schedContextCancelYieldTo tptr \ct_not_inQ\" - apply (clarsimp simp: schedContextCancelYieldTo_def updateSchedContext_def) - apply (wpsimp wp: threadSet_not_inQ threadGet_wp) - done - -lemma schedContextCancelYieldTo_cur_tcb'[wp]: - "schedContextCancelYieldTo tptr \cur_tcb'\" - by (wpsimp simp: schedContextCancelYieldTo_def updateSchedContext_def - wp: threadSet_cur threadGet_wp) - crunch schedContextCancelYieldTo for pspace_aligned'[wp]: pspace_aligned' and pspace_distinct'[wp]: pspace_distinct' @@ -406,7 +297,6 @@ crunch schedContextCancelYieldTo and interrupt_state[wp]: "\s. P (ksInterruptState s)" and valid_irq_state'[wp]: valid_irq_states' and valid_machine_state'[wp]: valid_machine_state' - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' and pspace_domain_valid[wp]: pspace_domain_valid and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" @@ -426,7 +316,8 @@ crunch schedContextCancelYieldTo and ksReadyQueuesL1Bitmap[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" and ksReadyQueuesL2Bitmap[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" and valid_sched_pointers[wp]: valid_sched_pointers - (wp: crunch_wps threadSet_pred_tcb_no_state threadSet_tcbInReleaseQueue threadSet_tcbQueued + (wp: crunch_wps threadSet_pred_tcb_no_state threadSet_field_inv threadSet_valid_replies' + threadSet_field_opt_pred threadSet_valid_sched_pointers simp: crunch_simps updateSchedContext_def) crunch schedContextCancelYieldTo @@ -454,7 +345,7 @@ crunch setConsumed (wp: crunch_wps simp: crunch_simps) lemma rfk_invs'[wp]: - "\invs' and tcb_at' t\ replyFromKernel t r \\rv. invs'\" + "replyFromKernel t r \invs'\" unfolding replyFromKernel_def by (cases r) wpsimp @@ -551,7 +442,7 @@ lemma schedContextCompleteYieldTo_corres: (complete_yield_to thread) (schedContextCompleteYieldTo thread)" apply (simp add: complete_yield_to_def schedContextCompleteYieldTo_def) apply (subst maybeM_when) - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF get_tcb_yield_to_corres], simp) apply (rule corres_when2[OF refl]) apply (rule corres_split[OF setConsumed_corres], simp, simp) @@ -563,7 +454,7 @@ lemma schedContextCompleteYieldTo_corres: apply (clarsimp simp: invs_def valid_state_def valid_pspace_def cur_tcb_def) apply (subgoal_tac "valid_tcb thread tcb s", clarsimp simp: valid_tcb_def) apply (fastforce simp: obj_at'_def valid_tcb_valid_obj elim: valid_objs_ko_at) - apply clarsimp + apply fastforce done crunch schedContextDonate @@ -627,20 +518,21 @@ lemma updateSchedContext_valid_objs'_stTCB_update_Just[wp]: objBits_def objBitsKO_def refillSize_def obj_at'_def split: if_splits) -lemma schedContextDonate_valid_objs': - "\valid_objs' and tcb_at' tcbPtr - and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - schedContextDonate scPtr tcbPtr - \\_. valid_objs'\" +lemma scTCB_update_Nothing_valid_objs': + "updateSchedContext scPtr (scTCB_update (\_. Nothing)) \valid_objs'\" + apply wpsimp + apply (clarsimp simp: valid_obj'_def opt_pred_def opt_map_def obj_at'_def valid_sched_context'_def + refillSize_def gen_objBits_simps valid_sched_context_size'_def + split: if_splits) + done + +lemma schedContextDonate_valid_objs'[wp]: + "\valid_objs' and tcb_at' tcbPtr\ schedContextDonate scPtr tcbPtr \\_. valid_objs'\" unfolding schedContextDonate_def - apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_disj_lift) - by fastforce + by wpsimp -lemma schedContextDonate_list_refs_of_replies' [wp]: - "schedContextDonate scPtr tcbPtr \\s. P (list_refs_of_replies' s)\" - unfolding schedContextDonate_def updateSchedContext_def - by (wpsimp simp: comp_def | rule hoare_strengthen_post[where Q'="\_ s. P (list_refs_of_replies' s)"])+ +crunch schedContextDonate + for list_refs_of_replies'[wp]: "\s. P (list_refs_of_replies' s)" lemma schedContextDonate_bound_tcb_sc_at[wp]: "\\\ schedContextDonate scPtr tcbPtr \\_. obj_at' (\a. \y. scTCB a = Some y) scPtr\" @@ -658,15 +550,6 @@ lemma state_relation_sc_relation: apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation, rotated]) by (clarsimp simp: sc_relation_def scBits_simps opt_map_red) -(* using the concrete side size *) -lemma state_relation_sc_relation': - "\(s, s') \ state_relation; sc_at ptr s; sc_at' ptr s'\ \ - sc_relation (the ((scs_of2 s) ptr)) (objBits (the (scs_of' s' ptr)) - minSchedContextBits) (the ((scs_of' s') ptr))" - supply projection_rewrites[simp] - apply (clarsimp simp: gen_obj_at_simps is_sc_obj) - apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation, rotated]) - by (clarsimp simp: sc_relation_def scBits_simps opt_map_red) - lemma state_relation_sc_replies_relation_sc: "\(s, s') \ state_relation; sc_at ptr s; sc_at' ptr s'\ \ heap_ls (replyPrevs_of s') (scReplies_of s' ptr) (sc_replies (the ((scs_of2 s) ptr)))" @@ -699,10 +582,10 @@ lemma updateRefillHd_corres: "\sc_ptr = scPtr; \refill refill'. refill = refill_map refill' \ f refill = refill_map (f' refill')\ \ corres dc - (sc_at sc_ptr) - (valid_refills' sc_ptr and sc_at' sc_ptr) - (update_refill_hd sc_ptr f) - (updateRefillHd scPtr f')" + (sc_at sc_ptr and pspace_aligned and pspace_distinct) (valid_refills' sc_ptr) + (update_refill_hd sc_ptr f) (updateRefillHd scPtr f')" + apply (rule_tac Q'="sc_at' sc_ptr" in corres_cross_add_guard) + apply (fastforce intro: sc_at_cross) apply (clarsimp simp: update_refill_hd_def updateRefillHd_def) apply (rule corres_guard_imp) apply (rule updateSchedContext_no_stack_update_corres_Q[where Q=\ and Q'="sc_valid_refills'"]) @@ -751,10 +634,12 @@ lemma updateRefillTl_corres: "\sc_ptr = scPtr; \refill refill'. refill = refill_map refill' \ f refill = (refill_map (f' refill'))\ \ corres dc - (sc_at sc_ptr) - (sc_at' scPtr and valid_refills' scPtr) - (update_refill_tl sc_ptr f) - (updateRefillTl scPtr f')" + (sc_at sc_ptr and pspace_aligned and pspace_distinct) + (valid_refills' scPtr) + (update_refill_tl sc_ptr f) + (updateRefillTl scPtr f')" + apply (rule_tac Q'="sc_at' scPtr" in corres_cross_add_guard) + apply (fastforce intro: sc_at_cross) apply (clarsimp simp: update_refill_tl_def updateRefillTl_def) apply (rule corres_guard_imp) apply (rule updateSchedContext_no_stack_update_corres_Q[where Q=\ and Q'="sc_valid_refills'"]) @@ -787,16 +672,16 @@ lemma refillReady_corres: ohaskell_state_assert_def gets_the_ostate_assert simp flip: get_refill_head_def getRefillHead_def getCurTime_def) apply (rule corres_stateAssert_ignore[simplified HaskellLib_H.stateAssert_def], simp) - apply (rule corres_symb_exec_r[OF _ stateAssert_sp[unfolded HaskellLib_H.stateAssert_def]]; - (solves wpsimp)?) + apply (rule corres_stateAssert_ignore[simplified HaskellLib_H.stateAssert_def]) + apply (fastforce intro!: sc_at_cross) apply (corres corres: getRefillHead_corres getCurTime_corres simp: refill_map_def projection_rewrites) done lemma scReleased_corres: "corres (=) - (active_scs_valid and valid_objs and pspace_aligned and pspace_distinct) - (valid_objs' and sc_at' sc_ptr) + (sc_at sc_ptr and active_scs_valid and valid_objs and pspace_aligned and pspace_distinct) + (valid_objs') (get_sc_released sc_ptr) (scReleased sc_ptr)" apply (corres corres: scActive_corres refillReady_corres simp: get_sc_refill_ready_def[symmetric, simplified fun_app_def] diff --git a/proof/refine/RISCV64/Schedule_R.thy b/proof/refine/RISCV64/Schedule_R.thy index 5e8fb747c4..0a6c1a83e6 100644 --- a/proof/refine/RISCV64/Schedule_R.thy +++ b/proof/refine/RISCV64/Schedule_R.thy @@ -37,7 +37,6 @@ crunch refillUnblockCheck, refillBudgetCheck, ifCondRefillUnblockCheck, refillBu and pspace_canonical'[wp]: pspace_canonical' and no_0_obj'[wp]: no_0_obj' and ctes_of[wp]: "\s. P (ctes_of s)" - and sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" and if_unsafe_then_cap'[wp]: if_unsafe_then_cap' and valid_global_refs'[wp]: valid_global_refs' and valid_arch_state'[wp]: valid_arch_state' @@ -50,8 +49,6 @@ crunch refillUnblockCheck, refillBudgetCheck, ifCondRefillUnblockCheck, refillBu and ksCurdomain[wp]: "\s. P (ksCurDomain s)" and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and untyped_ranges_zero'[wp]: untyped_ranges_zero' - and cur_tcb'[wp]: cur_tcb' - and ct_not_inQ[wp]: ct_not_inQ and valid_dom_schedule'[wp]: valid_dom_schedule' and ksCurSc[wp]: "\s. P (ksCurSc s)" and pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' @@ -173,11 +170,15 @@ lemma schedule_choose_new_thread_sched_act_rct[wp]: lemma tcbSchedAppend_corres: "tcb_ptr = tcbPtr \ corres dc - (in_correct_ready_q and ready_qs_distinct and st_tcb_at runnable tcb_ptr - and not_in_release_q tcb_ptr and ready_or_release and pspace_aligned and pspace_distinct) - (sym_heap_sched_pointers and valid_sched_pointers and valid_tcbs') + (ep_queues_blocked and ntfn_queues_blocked + and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable + and st_tcb_at runnable tcb_ptr and not_in_release_q tcb_ptr and ready_or_release + and pspace_aligned and pspace_distinct) + (valid_sched_pointers and valid_tcbs') (tcb_sched_action tcb_sched_append tcb_ptr) (tcbSchedAppend tcbPtr)" - supply if_split[split del] + supply if_split[split del] bind_return[simp del] return_bind[simp del] + ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + heap_ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) apply (rule_tac Q'="st_tcb_at' runnable' tcbPtr" in corres_cross_add_guard) apply (fastforce intro!: st_tcb_at_runnable_cross simp: vs_all_heap_simps obj_at_def is_tcb_def) apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) @@ -199,19 +200,19 @@ lemma tcbSchedAppend_corres: apply (fastforce intro: ksReadyQueues_asrt_cross) apply (rule corres_stateAssert_ignore) apply (fastforce intro: ksReleaseQueue_asrt_cross) - apply (rule corres_stateAssert_ignore, fastforce) + apply (rule corres_stateAssert_ignore, fastforce)+ apply (rule corres_symb_exec_r[OF _ isRunnable_sp]; wpsimp?) apply (rule corres_symb_exec_r[OF _ assert_sp, rotated]; (solves wpsimp)?) apply wpsimp apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) - apply (subst if_distrib[where f="set_tcb_queue domain prio" for domain prio]) - apply (rule corres_if_strong') - apply (rule arg_cong_Not) - subgoal - by (fastforce dest!: state_relation_ready_queues_relation - in_ready_q_tcbQueued_eq[where t=tcbPtr] - simp: obj_at'_def opt_pred_def opt_map_def in_correct_ready_q_def - vs_all_heap_simps obj_at_def in_ready_q_def) + apply (rule_tac F="tcbPtr \ set (queues domain priority) \ queued" in corres_req) + subgoal + by (fastforce dest!: state_relation_ready_queues_relation + in_ready_q_tcbQueued_eq[THEN arg_cong_Not, where t1=tcbPtr] + simp: obj_at'_def opt_pred_def opt_map_def in_correct_ready_q_def + vs_all_heap_simps obj_at_def in_ready_q_def) + apply (case_tac "tcbPtr \ set (queues domain priority)"; clarsimp) + apply (clarsimp simp: return_bind) apply (find_goal \match conclusion in "corres _ _ _ _ (return ())" \ \-\\) apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) apply (clarsimp simp: set_tcb_queue_def) @@ -227,97 +228,134 @@ lemma tcbSchedAppend_corres: apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) apply (rule corres_symb_exec_r[OF _ gets_sp]; (solves wpsimp)?) - \ \break off the addToBitmap\ apply (rule corres_add_noop_lhs) apply (rule corres_split_skip) apply wpsimp - apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_ex_lift) + apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_ex_lift hoare_vcg_imp_lift') apply (corres corres: addToBitmap_if_null_noop_corres) - apply (rule_tac F="tdom = domain \ prio = priority" in corres_req) apply (fastforce dest: pspace_relation_tcb_domain_priority state_relation_pspace_relation simp: obj_at_def obj_at'_def) apply clarsimp - - apply (rule corres_from_valid_det) - apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) - apply (wpsimp simp: tcbQueueAppend_def wp: hoare_vcg_imp_lift' hoare_vcg_if_lift2) - apply (clarsimp simp: ex_abs_def split: if_splits) + \ \set the ready queue\ + apply (rule corres_underlying_from_rcorres) + apply (wpsimp wp: no_fail_tcbQueueAppend hoare_vcg_imp_lift' hoare_vcg_if_lift2) + apply (clarsimp simp: ex_abs_def obj_at_def split: if_splits) + apply normalise_obj_at' + apply (rename_tac s' s tcb tcb') apply (frule state_relation_ready_queues_relation) apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - subgoal by (auto dest!: obj_at'_tcbQueueEnd_ksReadyQueues simp: obj_at'_def) - - apply (rename_tac s rv t) - apply (clarsimp simp: state_relation_def) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) - - apply (find_goal \match conclusion in "\_\ _ \\_. release_queue_relation t\" for t \ \-\\) - apply (frule_tac d=domain and p=priority in ready_or_release_disjoint) - apply (drule set_tcb_queue_projs_inv) - apply (wpsimp wp: tcbQueueAppend_list_queue_relation_other hoare_vcg_ex_lift - threadSet_sched_pointers - simp: release_queue_relation_def - | wps)+ - apply (rule_tac x="ready_queues s (tcbDomain tcba) (tcbPriority tcb)" in exI) - apply (auto simp: ready_queues_relation_def ready_queue_relation_def Let_def)[1] - - \ \ready_queues_relation\ - apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) - apply (intro hoare_allI) - apply (drule singleton_eqD) - apply (drule set_tcb_queue_new_state) - apply (intro hoare_vcg_conj_lift_pre_fix) - - apply (find_goal \match conclusion in "\_\ _ \\_ s. maxDomain < d \ _\" for d \ \-\\) - apply (wpsimp wp: threadSet_wp getTCB_wp simp: setQueue_def tcbQueueAppend_def) - apply (frule valid_tcbs'_maxDomain[where t=tcbPtr]) - apply fastforce - subgoal by (force simp: obj_at'_def tcbQueueEmpty_def split: if_split) - - apply (find_goal \match conclusion in "\_\ _ \\_ s. maxPriority < d \ _\" for d \ \-\\) - apply (wpsimp wp: threadSet_wp getTCB_wp simp: setQueue_def tcbQueueAppend_def) - apply (frule valid_tcbs'_maxPriority[where t=tcbPtr]) - apply fastforce - subgoal by (force simp: obj_at'_def tcbQueueEmpty_def split: if_split) - - apply (find_goal \match conclusion in "\_\ _ \\_ s. list_queue_relation _ _ _ _ \" \ \-\\) - apply (clarsimp simp: obj_at_def) - apply (case_tac "d \ tcb_domain tcb \ p \ tcb_priority tcb") - apply (wpsimp wp: tcbQueueAppend_list_queue_relation_other setQueue_ksReadyQueues_other - threadSet_sched_pointers hoare_vcg_ex_lift - | wps)+ - apply (intro conjI) - subgoal by fastforce - apply (rule_tac x="ready_queues s (tcb_domain tcb) (tcb_priority tcb)" in exI) - apply (auto dest!: in_correct_ready_qD simp: ready_queues_disjoint - split: if_splits)[1] - apply fastforce - apply ((wpsimp wp: tcbQueueAppend_list_queue_relation threadSet_sched_pointers | wps)+)[1] - apply (fastforce dest!: valid_sched_pointersD[where t=tcbPtr] - simp: in_opt_pred opt_map_red obj_at'_def) - - apply (rule hoare_allI, rename_tac t') - apply (case_tac "d \ domain \ p \ priority") - apply (wpsimp wp: tcbQueued_update_inQ_other hoare_vcg_disj_lift - simp: opt_pred_disj[simplified pred_disj_def, symmetric] simp_del: disj_not1) - apply (clarsimp simp: opt_map_def opt_pred_def obj_at'_def split: option.splits if_splits) - apply (case_tac "t' = tcbPtr") - apply (wpsimp wp: tcbQueued_True_makes_inQ) - apply (clarsimp simp: opt_pred_def opt_map_def obj_at'_def) - apply (wpsimp wp: threadSet_opt_pred_other) - done + apply (rule_tac x="ready_queues s (tcbDomain tcb) (tcbPriority tcb)" in exI) + apply clarsimp + apply (rule conjI) + apply (fastforce intro!: tcb_at_cross simp: ready_queues_runnable_def) + apply (force dest!: state_relation_ready_queues_relation in_ready_q_tcbQueued_eq[THEN iffD1] + simp: in_ready_q_def) + apply (simp add: state_relation_def ghost_relation_heap_ghost_relation + pspace_relation_heap_pspace_relation heap_pspace_relation_def) + apply (rcorres_conj_lift \fastforce\ simp: set_tcb_queue_def wp: threadSet_field_inv)+ + apply (rule rcorres_add_return_l) + apply (subst bind_assoc[symmetric]) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ep_queues_relation\ + apply (simp only: ep_queues_relation_def) + apply (rcorres rcorres: tcbQueueAppend_rcorres_other rcorres_threadSet_list_queue_relation + rcorres_op_lifts) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def obj_at_def) + apply (thin_tac "valid_sched_pointers _") + apply (metis runnable_not_in_ep_queue ep_queues_ready_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ntfn_queues_relation\ + apply (simp only: ntfn_queues_relation_def) + apply (rcorres rcorres: tcbQueueAppend_rcorres_other rcorres_threadSet_list_queue_relation + rcorres_op_lifts) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def obj_at_def) + apply (thin_tac "valid_sched_pointers _") + apply (metis runnable_not_in_ntfn_queue ntfn_queues_ready_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ready_queues_relation\ + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac d p) + apply (case_tac "d \ domain \ p \ priority") + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation + tcbQueueAppend_rcorres_other) + apply (clarsimp simp: obj_at_def) + apply (thin_tac "valid_sched_pointers _") + apply (metis in_correct_ready_qD ready_queues_disjoint) + apply (wpsimp wp: setQueue_ksReadyQueues_other) + apply (wpsimp wp: set_tcb_queue_ready_queues_other) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac t) + apply (rule_tac p="\s. t \ set (ready_queues s d p)" in rcorres_lift_abs) + apply (rule_tac p="\s'. (inQ d p |< tcbs_of' s') t" in rcorres_lift_conc) + apply (rule rcorres_prop_fwd; wpsimp) + apply (wpsimp wp: tcbQueued_update_inQ_other hoare_vcg_disj_lift + simp: opt_pred_disj[simplified pred_disj_def, symmetric] simp_del: disj_not1) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at'_def) + apply (wpsimp wp: set_tcb_queue_ready_queues_other) + apply (rule rcorres_lift_conc_only; wpsimp wp: setQueue_ksReadyQueues_other) + \ \d = domain \ p = priority\ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rcorres rcorres: tcbQueueAppend_rcorres + rcorres_threadSet_ready_queues_list_queue_relation) + apply clarsimp + apply (frule valid_sched_pointersD[where t=tcbPtr]) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at'_def) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at'_def) + apply (elim runnable'_not_inIPCQueueThreadState) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at'_def) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac t) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (clarsimp simp: set_tcb_queue_def in_monad) + apply (case_tac "t \ tcbPtr") + apply (wpsimp wp: threadSet_opt_pred_other) + apply (wpsimp wp: tcbQueued_True_makes_inQ) + apply (force simp: obj_at'_def opt_pred_def opt_map_red) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule rcorres_imp_lift_fwd; (solves wpsimp)?) + apply (rule rcorres_prop_fwd; wpsimp) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: setQueue_ksReadyQueues_other) + apply (force dest!: valid_tcbs'_maxDomain[where t=tcbPtr] simp: obj_at'_def) + apply (rule rcorres_imp_lift_fwd; (solves wpsimp)?) + apply (rule rcorres_prop_fwd; wpsimp) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: setQueue_ksReadyQueues_other) + apply (force dest!: valid_tcbs'_maxPriority[where t=tcbPtr] simp: obj_at'_def) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \release_queue_relation\ + apply (clarsimp simp: release_queue_relation_def) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule_tac p=release_queue in rcorres_lift_abs) + apply (rule_tac p=ksReleaseQueue in rcorres_lift_conc) + apply (rcorres rcorres: tcbQueueAppend_rcorres_other rcorres_threadSet_list_queue_relation) + apply normalise_obj_at' + apply (subst Int_commute) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def obj_at_def) + apply (thin_tac "valid_sched_pointers_2 _ _ _") + apply (metis ready_or_release_disjoint) + apply wpsimp + apply wpsimp + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: hoare_vcg_all_lift) + apply (clarsimp simp: set_tcb_queue_def in_monad) + by (rcorres_conj_lift \fastforce\ simp: set_tcb_queue_def wp: threadSet_field_inv)+ lemma tcbQueueAppend_valid_objs'[wp]: - "\\s. valid_objs' s \ tcb_at' tcbPtr s \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s)\ + "\valid_objs' and tcb_at' tcbPtr\ tcbQueueAppend queue tcbPtr \\_. valid_objs'\" unfolding tcbQueueAppend_def apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') - apply (clarsimp simp: tcbQueueEmpty_def valid_bound_tcb'_def split: option.splits) + apply (fastforce simp: list_queue_relation_def queue_end_valid_def tcbQueueEmpty_def) done lemma tcbQueueInsert_valid_objs'[wp]: @@ -329,18 +367,9 @@ lemma tcbQueueInsert_valid_objs'[wp]: done lemma tcbSchedAppend_valid_objs'[wp]: - "\valid_objs' and pspace_aligned' and pspace_distinct'\ - tcbSchedAppend tcbPtr - \\_. valid_objs'\" + "tcbSchedAppend tcbPtr \valid_objs'\" apply (clarsimp simp: tcbSchedAppend_def setQueue_def) - apply (wpsimp wp: threadSet_valid_objs' threadGet_wp hoare_vcg_all_lift) - apply (normalise_obj_at', rename_tac tcb "end") - apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply clarsimp - apply (frule he_ptrs_head_iff_he_ptrs_end) - apply (force dest!: obj_at'_tcbQueueEnd_ksReadyQueues simp: tcbQueueEmpty_def) + apply (wpsimp wp: threadGet_wp) done crunch tcbSchedEnqueue, tcbSchedAppend, tcbSchedDequeue @@ -352,92 +381,20 @@ lemmas obj_at'_conjI = obj_at_conj' crunch tcbSchedAppend, tcbSchedDequeue, tcbSchedEnqueue for tcb_at'[wp]: "tcb_at' t" - and cap_to'[wp]: "ex_nonz_cap_to' p" and ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" and tcbInReleaseQueue[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" and ifunsafe'[wp]: if_unsafe_then_cap' (wp: crunch_wps simp: crunch_simps) -lemma tcbSchedAppend_iflive'[wp]: - "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ - tcbSchedAppend tcbPtr - \\_. if_live_then_nonz_cap'\" - unfolding tcbSchedAppend_def - apply (wpsimp wp: tcbQueueAppend_if_live_then_nonz_cap' threadGet_wp - threadSet_sched_pointers hoare_vcg_all_lift hoare_vcg_imp_lift' - simp: bitmap_fun_defs) - apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') - apply (fastforce simp: ko_wp_at'_def st_tcb_at'_def obj_at'_def runnable_eq_active' live'_def) - apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) - apply (intro conjI impI allI) - apply (erule if_live_then_nonz_capE') - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply clarsimp - apply (frule (3) obj_at'_tcbQueueEnd_ksReadyQueues) - apply (frule he_ptrs_head_iff_he_ptrs_end) - apply (clarsimp simp: ko_wp_at'_def inQ_def obj_at'_def tcbQueueEmpty_def live'_def) - apply fastforce - done - -lemma tcbSchedDequeue_iflive'[wp]: - "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers\ - tcbSchedDequeue tcbPtr - \\_. if_live_then_nonz_cap'\" - apply (simp add: tcbSchedDequeue_def) - apply (wpsimp wp: tcbQueueRemove_if_live_then_nonz_cap' threadGet_wp threadSet_valid_objs') - apply (fastforce elim: if_live_then_nonz_capE' simp: obj_at'_def ko_wp_at'_def live'_def) - done - lemma tcbSchedEnqueue_vms'[wp]: "tcbSchedEnqueue t \valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift tcbSchedEnqueue_ksMachine) - done - -lemma ct_idle_or_in_cur_domain'_lift2: - "\ \t. \tcb_in_cur_domain' t\ f \\_. tcb_in_cur_domain' t\; - \P. \\s. P (ksCurThread s) \ f \\_ s. P (ksCurThread s) \; - \P. \\s. P (ksIdleThread s) \ f \\_ s. P (ksIdleThread s) \; - \P. \\s. P (ksSchedulerAction s) \ f \\_ s. P (ksSchedulerAction s) \\ - \ \ ct_idle_or_in_cur_domain'\ f \\_. ct_idle_or_in_cur_domain' \" - apply (unfold ct_idle_or_in_cur_domain'_def) - apply (rule hoare_lift_Pf2[where f=ksCurThread]) - apply (rule hoare_lift_Pf2[where f=ksSchedulerAction]) - including no_pre - apply (wp hoare_weak_lift_imp hoare_vcg_disj_lift) - apply simp+ - done - -lemma tcbQueuePrepend_valid_mdb': - "\valid_mdb' and tcb_at' tcbPtr - and (\s. \ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s)\ - tcbQueuePrepend queue tcbPtr - \\_. valid_mdb'\" - unfolding tcbQueuePrepend_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') - -lemma tcbQueueAppend_valid_mdb': - "\\s. valid_mdb' s \ tcb_at' tcbPtr s - \ (\ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueEnd queue)) s)\ - tcbQueueAppend queue tcbPtr - \\_. valid_mdb'\" - unfolding tcbQueueAppend_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') - -lemma tcbQueueInsert_valid_mdb': - "\valid_mdb' and tcb_at' tcbPtr and valid_tcbs'\ tcbQueueInsert tcbPtr afterPtr \\_. valid_mdb'\" - unfolding tcbQueueInsert_def - apply (wpsimp wp: getTCB_wp) - apply (frule (1) ko_at'_valid_tcbs'_valid_tcb') - apply (clarsimp simp: valid_tcb'_def valid_bound_tcb'_def) + apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) done -lemma tcbInReleaseQueue_update_valid_mdb'[wp]: - "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbInReleaseQueue_update f) tcbPtr \\_. valid_mdb'\" - apply (wpsimp wp: threadSet_mdb') - apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) - done +crunch tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert + for valid_mdb'[wp]: valid_mdb' + (wp: crunch_wps ignore: threadSet) lemma tcbQueued_update_valid_mdb'[wp]: "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbQueued_update f) tcbPtr \\_. valid_mdb'\" @@ -446,21 +403,15 @@ lemma tcbQueued_update_valid_mdb'[wp]: done lemma tcbSchedEnqueue_valid_mdb'[wp]: - "\valid_mdb' and valid_tcbs' and pspace_aligned' and pspace_distinct'\ - tcbSchedEnqueue tcbPtr - \\_. valid_mdb'\" - apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) - apply (wpsimp wp: tcbQueuePrepend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) - apply normalise_obj_at' - apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues - simp: ready_queue_relation_def ksReadyQueues_asrt_def) - done + "tcbSchedEnqueue tcbPtr \valid_mdb'\" + unfolding tcbSchedEnqueue_def setQueue_def + by (wpsimp simp: bitmap_fun_defs wp: threadGet_wp) lemma tcbSchedEnqueue_invs'[wp]: "tcbSchedEnqueue t \invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (simp add: invs'_def valid_pspace'_def) apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift - untyped_ranges_zero_lift valid_replies'_lift + untyped_ranges_zero_lift simp: cteCaps_of_def o_def) done @@ -478,22 +429,16 @@ lemma tcbSchedAppend_valid_bitmapQ[wp]: supply if_split[split del] unfolding tcbSchedAppend_def apply (wpsimp simp: tcbQueueAppend_def - wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ - threadGet_wp hoare_vcg_if_lift2 threadSet_bitmapQ) - apply (clarsimp simp: ksReadyQueues_asrt_def split: if_splits) - apply normalise_obj_at' + wp: stateAssert_inv setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except + addToBitmap_bitmapQ threadGet_wp) apply (force dest: he_ptrs_head_iff_he_ptrs_end - simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def) + simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def split: if_splits) done lemma tcbSchedAppend_valid_mdb'[wp]: - "\valid_mdb' and valid_tcbs' and pspace_aligned' and pspace_distinct'\ - tcbSchedAppend tcbPtr - \\_. valid_mdb'\" + "tcbSchedAppend tcbPtr \valid_mdb'\" apply (clarsimp simp: tcbSchedAppend_def setQueue_def) apply (wpsimp wp: tcbQueueAppend_valid_mdb' threadGet_wp simp: bitmap_fun_defs) - apply (fastforce dest: obj_at'_tcbQueueEnd_ksReadyQueues - simp: ready_queue_relation_def ksReadyQueues_asrt_def) done lemma tcbSchedAppend_valid_bitmaps[wp]: @@ -522,13 +467,13 @@ lemma tcbSchedDequeue_vms'[wp]: done lemma tcbSchedDequeue_valid_mdb'[wp]: - "\valid_mdb' and valid_objs'\ tcbSchedDequeue tcbPtr \\_. valid_mdb'\" + "tcbSchedDequeue tcbPtr \valid_mdb'\" unfolding tcbSchedDequeue_def - by (wpsimp simp: bitmap_fun_defs setQueue_def wp: tcbQueueRemove_valid_mdb' threadGet_wp) + by (wpsimp simp: bitmap_fun_defs setQueue_def wp: threadGet_wp) lemma tcbSchedDequeue_invs'[wp]: "tcbSchedDequeue t \invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (simp add: invs'_def valid_pspace'_def) apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift untyped_ranges_zero_lift valid_replies'_lift simp: cteCaps_of_def o_def) @@ -597,23 +542,8 @@ crunch storeWordUser, setVMRoot, asUser, storeWordUser, Arch.switchToThread and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" and sym_heap_sched_poinetsr[wp]: sym_heap_sched_pointers and valid_objs'[wp]: valid_objs' - (wp: crunch_wps sym_heap_sched_pointers_lift simp: crunch_simps) - -lemma ready_qs_distinct_lift: - assumes r: "\P. f \\s. P (ready_queues s)\" - shows "f \ready_qs_distinct\" - unfolding ready_qs_distinct_def - apply (rule hoare_pre) - apply (wps assms | wpsimp)+ - done - -lemma valid_ready_qs_in_correct_ready_q[elim!]: - "valid_ready_qs s \ in_correct_ready_q s" - by (simp add: valid_ready_qs_def in_correct_ready_q_def) - -lemma valid_ready_qs_ready_qs_distinct[elim!]: - "valid_ready_qs s \ ready_qs_distinct s" - by (simp add: valid_ready_qs_def ready_qs_distinct_def) + (wp: crunch_wps sym_heap_sched_pointers_lift threadSet_field_inv simp: crunch_simps + ignore: threadSet) crunch arch_switch_to_thread, arch_switch_to_idle_thread for pspace_aligned[wp]: pspace_aligned @@ -621,11 +551,18 @@ crunch arch_switch_to_thread, arch_switch_to_idle_thread and in_correct_ready_q[wp]: in_correct_ready_q and ready_qs_distinct[wp]: ready_qs_distinct and valid_idle[wp]: valid_idle - (rule: in_correct_ready_q_lift ready_qs_distinct_lift) + and state_refs_of[wp]: "\s. P (state_refs_of s)" + and ready_queues_runnable[wp]: ready_queues_runnable + and ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (rule: in_correct_ready_q_lift ready_qs_distinct_lift ready_queues_runnable_lift + ep_queues_blocked_lift ntfn_queues_blocked_lift + simp: crunch_simps) lemma switchToThread_corres: "corres dc - (valid_arch_state and valid_objs and valid_idle + (ep_queues_blocked and ntfn_queues_blocked + and valid_arch_state and valid_objs and valid_idle and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_ready_qs and valid_vs_lookup and valid_global_objs and unique_table_refs and st_tcb_at runnable t and ready_or_release) @@ -762,16 +699,14 @@ lemma Arch_swichToThread_tcbPriority_triv[wp]: apply (wp hoare_drop_imp | simp)+ done -lemma Arch_switchToThread_tcb_in_cur_domain'[wp]: - "\tcb_in_cur_domain' t'\ Arch.switchToThread t \\_. tcb_in_cur_domain' t' \" - apply (rule tcb_in_cur_domain'_lift) - apply wp+ - done +crunch tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert + for obj_at'_tcbQueued[wp]: "\s. P (obj_at' (\tcb. Q (tcbQueued tcb)) tcbPtr s)" + (wp: crunch_wps threadSet_obj_at'_no_state) -lemma tcbSchedDequeue_not_tcbQueued: - "\\\ tcbSchedDequeue t \\_. obj_at' (\tcb. \ tcbQueued tcb) t\" +lemma tcbSchedDequeue_not_tcbQueued[wp]: + "\\\ tcbSchedDequeue t \\_. obj_at' (Not \ tcbQueued) t\" unfolding tcbSchedDequeue_def - apply (wpsimp wp: hoare_vcg_if_lift2 threadGet_wp) + apply (wpsimp wp: hoare_vcg_if_lift2 threadGet_wp hoare_drop_imps) by (clarsimp simp: obj_at'_def) lemma asUser_tcbState_inv[wp]: @@ -817,25 +752,6 @@ lemma asUser_irq_masked'[wp]: apply (rule asUser_irq_masked'_helper) done -lemma asUser_ct_not_inQ[wp]: - "\ct_not_inQ\ asUser t (setRegister f r) - \\_ . ct_not_inQ\" - apply (clarsimp simp: submonad_asUser.fn_is_sm submonad_fn_def) - apply (rule bind_wp)+ - prefer 4 - apply (rule stateAssert_sp) - prefer 3 - apply (rule gets_inv) - defer - apply (rule select_f_inv) - apply (case_tac rv; simp) - apply (clarsimp simp: asUser_replace_def obj_at'_def fun_upd_def - split: option.split kernel_object.split) - apply wp - apply (clarsimp simp: ct_not_inQ_def obj_at'_def objBitsKO_def ps_clear_def dom_def) - apply (rule conjI; clarsimp; blast) - done - crunch asUser for pspace_domain_valid[wp]: "pspace_domain_valid" (wp: crunch_wps simp: crunch_simps) @@ -917,23 +833,10 @@ crunch "Arch.switchToThread" for cap_to'[wp]: "ex_nonz_cap_to' p" (simp: crunch_simps wp: crunch_wps) -crunch switchToThread - for cap_to'[wp]: "ex_nonz_cap_to' p" - (simp: crunch_simps) - lemma no_longer_inQ[simp]: "\ inQ d p (tcbQueued_update (\x. False) tcb)" by (simp add: inQ_def) -lemma iflive_inQ_nonz_cap_strg: - "if_live_then_nonz_cap' s \ obj_at' (inQ d prio) t s - \ ex_nonz_cap_to' t s" - by (clarsimp simp: obj_at'_real_def inQ_def live'_def - elim!: if_live_then_nonz_capE' ko_wp_at'_weakenE) - -lemmas iflive_inQ_nonz_cap[elim] - = mp [OF iflive_inQ_nonz_cap_strg, OF conjI[rotated]] - declare Cons_eq_tails[simp] crunch "ThreadDecls_H.switchToThread" @@ -1157,10 +1060,6 @@ lemma corres_split_sched_act: apply (rule corres_guard_imp, force+)+ done -crunch tcbSchedEnqueue - for cur[wp]: cur_tcb' - (simp: unless_def) - lemma gts_exs_valid[wp]: "tcb_at t s \ \(=) s\ get_thread_state t \\\r. (=) s\" apply (clarsimp simp: get_thread_state_def assert_opt_def fail_def @@ -1171,7 +1070,9 @@ lemma gts_exs_valid[wp]: lemma guarded_switch_to_corres: "corres dc - (valid_arch_state and valid_objs and valid_vspace_objs and pspace_aligned and pspace_distinct + (ep_queues_blocked and ntfn_queues_blocked + and valid_arch_state and valid_objs and valid_vspace_objs + and pspace_aligned and pspace_distinct and valid_vs_lookup and valid_global_objs and unique_table_refs and schedulable t and valid_ready_qs and ready_or_release and valid_idle) (no_0_obj' and sym_heap_sched_pointers and valid_objs') @@ -1293,7 +1194,7 @@ lemma guarded_switch_to_chooseThread_fragment_corres: apply (rule corres_symb_exec_l[rotated, OF _ assert_sp]; wpsimp) apply (rule corres_guard_imp) apply (rule switchToThread_corres) - apply (fastforce simp: schedulable_def2) + apply (fastforce dest: invs_sym_refs simp: schedulable_def2) apply fastforce done @@ -1494,7 +1395,7 @@ lemma scheduleChooseNewThread_fragment_corres: lemma scheduleSwitchThreadFastfail_corres: "\ ct \ it \ (tp = tp' \ cp = cp') ; ct = ct' ; it = it' \ \ - corres ((=)) (tcb_at ct) (tcb_at' ct) + corres ((=)) (tcb_at ct) \ (schedule_switch_thread_fastfail ct it cp tp) (scheduleSwitchThreadFastfail ct' it' cp' tp')" by (clarsimp simp: schedule_switch_thread_fastfail_def scheduleSwitchThreadFastfail_def) @@ -1560,26 +1461,12 @@ lemma scheduleChooseNewThread_corres: apply wpsimp+ done -lemma ssa_ct_not_inQ: - "\\s. sa = ResumeCurrentThread \ obj_at' (Not \ tcbQueued) (ksCurThread s) s\ - setSchedulerAction sa \\rv. ct_not_inQ\" - by (simp add: setSchedulerAction_def ct_not_inQ_def, wp, clarsimp) - lemma ssa_invs': "setSchedulerAction sa \invs'\" - apply (wp ssa_ct_not_inQ) + apply (wp ssa_wp) apply (clarsimp simp: invs'_def valid_irq_node'_def valid_dom_schedule'_def) done -lemma switchToThread_ct_not_queued_2: - "\invs' and tcb_at' t\ switchToThread t \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s\" - (is "\_\ _ \\_. ?POST\") - apply (simp add: Thread_H.switchToThread_def) - apply wp - apply (simp add: RISCV64_H.switchToThread_def setCurThread_def) - apply (wp tcbSchedDequeue_not_tcbQueued hoare_drop_imp | simp )+ - done - lemma setCurThread_obj_at': "\ obj_at' P t \ setCurThread t \\rv s. obj_at' P (ksCurThread s) s \" proof - @@ -1625,9 +1512,8 @@ lemma setReprogramTimer_invs'[wp]: "setReprogramTimer v \invs'\" unfolding setReprogramTimer_def apply wpsimp - by (clarsimp simp: invs'_def valid_machine_state'_def cur_tcb'_def - ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def ct_not_inQ_def - valid_dom_schedule'_def) + apply (clarsimp simp: invs'_def valid_machine_state'_def valid_dom_schedule'_def) + done lemma machine_op_lift_underlying_memory_invar: "(x, b) \ fst (machine_op_lift a m) \ underlying_memory b = underlying_memory m" @@ -1700,13 +1586,10 @@ lemma refillAddTail_valid_objs'[wp]: done lemma updateRefillIndex_invs'[wp]: - "\invs' and sc_at' scPtr\ - updateRefillIndex scPtr f next - \\_. invs'\" + "updateRefillIndex scPtr f next \invs'\" unfolding updateRefillIndex_def apply (wpsimp wp: updateSchedContext_invs') apply (fastforce dest: sc_ko_at_valid_objs_valid_sc' - elim: live_sc'_ko_ex_nonz_cap_to' simp: valid_sched_context'_scRefills_update) done @@ -1716,8 +1599,7 @@ lemma refillAddTail_invs'[wp]: apply (wpsimp wp: getRefillNext_wp getRefillSize_wp updateSchedContext_invs') apply (frule (1) invs'_ko_at_valid_sched_context', clarsimp) apply (drule ko_at'_inj, assumption, clarsimp) - apply (fastforce elim: live_sc'_ko_ex_nonz_cap_to' - simp: in_omonad obj_at'_def valid_sched_context'_def refillSize_def + apply (fastforce simp: in_omonad obj_at'_def valid_sched_context'_def refillSize_def valid_sched_context_size'_def sc_size_bounds_def objBits_simps refillNext_def) done @@ -1728,15 +1610,15 @@ lemma refillBudgetCheckRoundRobin_invs'[wp]: \\_. invs'\" supply if_split [split del] apply (simp add: refillBudgetCheckRoundRobin_def updateRefillTl_def updateRefillHd_def) - apply (wpsimp simp: wp: updateSchedContext_refills_invs') + apply (wpsimp simp: wp: updateSchedContext_invs') apply (rule_tac Q'="\_. invs' and active_sc_at' scPtr" in hoare_strengthen_post[rotated]) apply clarsimp apply (frule (1) invs'_ko_at_valid_sched_context', clarsimp) - apply (clarsimp simp: valid_sched_context'_def active_sc_at'_def obj_at'_real_def + apply (clarsimp simp: valid_sched_context'_def is_active_sc'_def obj_at'_real_def ko_wp_at'_def valid_sched_context_size'_def objBits_def objBitsKO_def refillSize_def split: if_splits) - apply (wpsimp wp: updateSchedContext_refills_invs' getCurTime_wp updateSchedContext_active_sc_at') + apply (wpsimp wp: updateSchedContext_invs' getCurTime_wp updateSchedContext_active_sc_at') apply wpsimp apply clarsimp apply (frule invs'_ko_at_valid_sched_context', simp, clarsimp) @@ -1761,58 +1643,11 @@ lemma updateRefillTl_invs'[wp]: "updateRefillTl scPtr f \invs'\" apply (clarsimp simp: updateRefillTl_def) apply (wpsimp wp: updateSchedContext_invs') - apply (intro conjI) - apply (fastforce dest: invs_iflive' - elim: if_live_then_nonz_capE' - simp: valid_idle'_def obj_at'_def ko_wp_at'_def live'_def live_sc'_def) apply (fastforce dest: sc_ko_at_valid_objs_valid_sc' simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps refillSize_def) done -lemma updateRefillIndex_if_live_then_nonz_cap'[wp]: - "updateRefillIndex scPtr f index \if_live_then_nonz_cap'\" - apply (clarsimp simp: updateRefillIndex_def updateSchedContext_def) - apply (wpsimp wp: setSchedContext_iflive') - apply (fastforce elim: if_live_then_nonz_capE' - simp: valid_idle'_def obj_at'_def ko_wp_at'_def live'_def live_sc'_def) - done - -lemma updateRefillTl_if_live_then_nonz_cap'[wp]: - "updateRefillTl scPtr f \if_live_then_nonz_cap'\" - apply (clarsimp simp: updateRefillTl_def updateSchedContext_def) - apply (wpsimp wp: setSchedContext_iflive') - apply (fastforce elim: if_live_then_nonz_capE' - simp: valid_idle'_def obj_at'_def ko_wp_at'_def live'_def live_sc'_def) - done - -lemma refillAddTail_if_live_then_nonz_cap'[wp]: - "refillAddTail scPtr new \if_live_then_nonz_cap'\" - apply (clarsimp simp: refillAddTail_def updateSchedContext_def) - apply (wpsimp wp: setSchedContext_iflive' getRefillNext_wp getRefillSize_wp) - apply (fastforce elim: if_live_then_nonz_capE' - simp: valid_idle'_def obj_at'_def ko_wp_at'_def live'_def live_sc'_def) - done - -lemma scheduleUsed_if_live_then_nonz_cap'[wp]: - "scheduleUsed scPtr refill \if_live_then_nonz_cap'\" - unfolding scheduleUsed_def - by (wpsimp simp: scheduleUsed_def - wp: updateSchedContext_wp getRefillSize_wp getRefillNext_wp getRefillFull_wp getRefillTail_wp) - -lemma updateSchedContext_valid_idle': - "\valid_idle' and (\s. \sc. idle_sc' sc \ idle_sc' (f sc))\ - updateSchedContext scPtr f - \\_. valid_idle'\" - apply (clarsimp simp: updateSchedContext_def) - apply wpsimp - apply (fastforce simp: valid_idle'_def obj_at'_def) - done - -crunch scheduleUsed, updateRefillHd, refillPopHead - for valid_idle'[wp]: valid_idle' - (wp: updateSchedContext_valid_idle' getRefillSize_wp) - lemma scheduleUsed_invs'[wp]: "scheduleUsed scPtr refill \invs'\" apply (simp add: scheduleUsed_def) @@ -1836,13 +1671,10 @@ lemma refillPopHead_invs'[wp]: apply (simp add: refillPopHead_def) apply (wpsimp wp: updateSchedContext_invs' getRefillNext_wp) apply normalise_obj_at' - apply (rule conjI) - apply (fastforce intro!: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def live'_def live_sc'_def) by (fastforce dest!: invs'_ko_at_valid_sched_context' simp: valid_sched_context'_def valid_sched_context_size'_def obj_at_simps - refillSize_def refillNext_def - split: if_split) + refillSize_def refillNext_def opt_pred_def opt_map_def + split: if_split option.splits) lemma refillPopHead_active_sc_at'[wp]: "refillPopHead scPtr \active_sc_at' scPtr'\" @@ -1873,8 +1705,6 @@ lemma updateRefillHd_invs': "\invs' and active_sc_at' scPtr\ updateRefillHd scPtr f \\_. invs'\" apply (clarsimp simp: updateRefillHd_def) apply (wpsimp wp: updateSchedContext_invs') - apply (intro conjI; intro allI impI) - apply (fastforce dest: live_sc'_ko_ex_nonz_cap_to') apply (frule invs'_ko_at_valid_sched_context', simp, clarsimp) apply (clarsimp simp: valid_sched_context'_def active_sc_at'_def obj_at'_real_def ko_wp_at'_def valid_sched_context_size'_def objBits_def objBitsKO_def refillSize_def @@ -2070,39 +1900,6 @@ lemma refillUnblockCheck_list_refs_of_replies'[wp]: simp: o_def) done -lemma refillPopHead_if_live_then_nonz_cap'[wp]: - "refillPopHead scPtr \if_live_then_nonz_cap'\" - apply (clarsimp simp: refillPopHead_def updateSchedContext_def getRefillNext_def) - apply wpsimp - apply (fastforce intro: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_real_def live'_def live_sc'_def) - done - -lemma updateRefillHd_if_live_then_nonz_cap'[wp]: - "updateRefillHd scPtr f \if_live_then_nonz_cap'\" - apply (clarsimp simp: updateRefillHd_def updateSchedContext_def) - apply wpsimp - apply (fastforce intro: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_real_def live'_def live_sc'_def) - done - -crunch refillHeadOverlappingLoop, headInsufficientLoop - for if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - (wp: crunch_wps) - -lemma setRefillHd_if_live_then_nonz_cap'[wp]: - "setRefillHd scPtr f \if_live_then_nonz_cap'\" - apply (wpsimp simp: setRefillHd_def) - done - -crunch handleOverrun, refillUnblockCheck - for if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - (wp: crunch_wps) - -crunch refillHeadOverlappingLoop, headInsufficientLoop, handleOverrun - for valid_idle'[wp]: valid_idle' - (wp: crunch_wps) - crunch refillUnblockCheck, refillBudgetCheck for reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" and pred_tcb_at'[wp]: "pred_tcb_at' proj P p" @@ -2154,10 +1951,6 @@ crunch refillBudgetCheck and valid_machine_state'[wp]: valid_machine_state' (wp: crunch_wps hoare_vcg_all_lift hoare_vcg_if_lift2) -crunch refillBudgetCheck - for if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - (simp: crunch_simps wp: crunch_wps hoare_vcg_all_lift) - lemma refillBudgetCheck_invs'[wp]: "refillBudgetCheck usage \invs'\" apply (clarsimp simp: invs'_def valid_pspace'_def pred_conj_def) @@ -2167,13 +1960,15 @@ lemma refillBudgetCheck_invs'[wp]: lemma commitTime_invs': "commitTime \invs'\" apply (simp add: commitTime_def) - apply wpsimp - apply (wpsimp wp: updateSchedContext_invs'_indep) - apply (clarsimp simp: valid_sched_context'_def valid_sched_context_size'_def objBits_def sc_size_bounds_def objBitsKO_def live_sc'_def) - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post) - apply (wpsimp wp: isRoundRobin_wp) - apply (wpsimp wp: getConsumedTime_wp getCurSc_wp)+ - by (clarsimp simp: active_sc_at'_def obj_at'_real_def ko_wp_at'_def) + apply (wpsimp wp: updateSchedContext_invs') + apply (rule_tac Q'="\_. invs'" in hoare_post_imp) + apply (fastforce dest: invs'_ko_at_valid_sched_context') + apply wpsimp + apply (rule_tac Q'="\_. invs'" in hoare_post_imp) + apply (fastforce dest: invs'_ko_at_valid_sched_context') + apply (wpsimp wp: getConsumedTime_wp getCurSc_wp hoare_drop_imps)+ + apply (fastforce dest: invs'_ko_at_valid_sched_context' simp: active_sc_at'_def obj_at'_def ) + done lemma switchSchedContext_invs': "switchSchedContext \invs'\" @@ -2207,14 +2002,12 @@ crunch possibleSwitchTo crunch possibleSwitchTo for valid_tcbs'[wp]: valid_tcbs' - and cap_to'[wp]: "ex_nonz_cap_to' p" and ifunsafe'[wp]: "if_unsafe_then_cap'" and global_refs'[wp]: valid_global_refs' and valid_machine_state'[wp]: valid_machine_state' and cur[wp]: cur_tcb' and refs_of'[wp]: "\s. P (state_refs_of' s)" and replies_of'[wp]: "\s. P (replies_of' s)" - and idle'[wp]: "valid_idle'" and valid_arch'[wp]: valid_arch_state' and irq_node'[wp]: "\s. P (irq_node' s)" and typ_at'[wp]: "\s. P (typ_at' T p s)" @@ -2239,10 +2032,6 @@ crunch possibleSwitchTo lemmas possibleSwitchTo_typ_ats[wp] = typ_at_lifts[OF possibleSwitchTo_typ_at'] -crunch possibleSwitchTo - for if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - (wp: crunch_wps simp: crunch_simps) - lemma possibleSwitchTo_utr[wp]: "possibleSwitchTo t \untyped_ranges_zero'\" by (wpsimp simp: cteCaps_of_def o_def wp: untyped_ranges_zero_lift) @@ -2286,7 +2075,6 @@ crunch awaken crunch checkDomainTime for invs'[wp]: invs' - and sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" and cur_tcb'[wp]: cur_tcb' (simp: crunch_simps wp: crunch_wps) @@ -2419,8 +2207,12 @@ lemma rescheduleRequired_sch_act_sane[wp]: apply (simp add: rescheduleRequired_def sch_act_sane_def setSchedulerAction_def) by (wpsimp wp: getSchedulable_wp) +lemma sch_act_sane_chooseNewThread[simp]: + "sch_act_sane (s\ksSchedulerAction := ChooseNewThread\)" + by (clarsimp simp: sch_act_sane_def) + crunch setThreadState, setBoundNotification - for sch_act_sane[wp]: "sch_act_sane" + for sch_act_sane[wp]: sch_act_sane (simp: crunch_simps wp: crunch_wps) lemma weak_sch_act_wf_cross: @@ -2477,44 +2269,68 @@ crunch set_scheduler_action crunch reschedule_required for in_correct_ready_q[wp]: in_correct_ready_q and ready_qs_distinct[wp]: ready_qs_distinct - (ignore: tcb_sched_action wp: crunch_wps) + and ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (ignore: tcb_sched_action wp: crunch_wps ep_queues_blocked_lift ntfn_queues_blocked_lift) + +lemma ready_queues_runnable_tcb_sched_enqueue_[wp]: + "\ready_queues_runnable and st_tcb_at runnable t\ + tcb_sched_action tcb_sched_enqueue t + \\_. ready_queues_runnable\" + unfolding tcb_sched_action_def set_tcb_queue_def tcb_sched_enqueue_def + apply (wpsimp wp: thread_get_wp) + apply (clarsimp simp: ready_queues_runnable_def st_tcb_at_def obj_at_def) + done + +lemma ready_queues_runnable_scheduler_action[simp]: + "ready_queues_runnable (scheduler_action_update f s) = ready_queues_runnable s" + by (simp add: ready_queues_runnable_def) + +lemma reschedule_required_ready_queues_runnable[wp]: + "reschedule_required \ready_queues_runnable\" + unfolding reschedule_required_def + apply (wpsimp wp: set_scheduler_action_wp thread_get_wp) + apply (clarsimp simp: st_tcb_at_def obj_at_def schedulable_def2 is_tcb_def) + done lemma possibleSwitchTo_corres: "t = t' \ corres dc - (valid_sched_action and st_tcb_at runnable t + (ep_queues_blocked and ntfn_queues_blocked + and valid_sched_action and st_tcb_at runnable t and pspace_aligned and pspace_distinct and valid_tcbs - and active_scs_valid and in_correct_ready_q and ready_or_release and ready_qs_distinct) - (sym_heap_sched_pointers and valid_sched_pointers and valid_tcbs' - and pspace_aligned' and pspace_distinct' and pspace_bounded') + and active_scs_valid and ready_or_release + and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable) + (valid_sched_pointers and valid_tcbs' + and pspace_aligned' and pspace_distinct') (possible_switch_to t) (possibleSwitchTo t')" supply dc_simp [simp del] - apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) - apply (fastforce intro: tcb_at_cross) + apply (rule corres_cross_add_guard[where Q'="st_tcb_at' runnable' t"]) + apply (fastforce intro!: st_tcb_at_runnable_cross) apply (simp add: possible_switch_to_def possibleSwitchTo_def cong: if_cong) apply (rule corres_stateAssert_ignore, simp) - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) apply (simp add: get_tcb_obj_ref_def) apply (rule_tac r'="(=)" in corres_split[OF threadGet_corres]) apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split[OF inReleaseQueue_corres]) - apply (rule corres_when[rotated]) - apply (rule corres_split[OF curDomain_corres], simp) - apply (rule corres_split[OF threadGet_corres[where r="(=)"]]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split[OF getSchedulerAction_corres]) - apply (rule corres_if, simp) - apply (rule tcbSchedEnqueue_corres, simp) - apply (rule corres_if, simp) - apply (case_tac rva; simp) - apply (rule corres_split[OF rescheduleRequired_corres]) - apply (rule tcbSchedEnqueue_corres) - apply (wpsimp)+ - apply (rule setSchedulerAction_corres, simp) - apply (wpsimp simp: if_apply_def2 valid_sched_action_def - wp: thread_get_wp threadGet_wp inReleaseQueue_wp)+ + apply (rule corres_split[OF inReleaseQueue_corres]) + apply (rule corres_when[rotated]) + apply (rule corres_split[OF curDomain_corres], simp) + apply (rule corres_split[OF threadGet_corres[where r="(=)"]]) + apply (clarsimp simp: tcb_relation_def) + apply (rule corres_split[OF getSchedulerAction_corres]) + apply (rule corres_if, simp) + apply (rule tcbSchedEnqueue_corres, simp) + apply (rule corres_if, simp) + apply (case_tac rva; simp) + apply (rule corres_split[OF rescheduleRequired_corres]) + apply (rule tcbSchedEnqueue_corres) + apply wpsimp+ + apply (rule setSchedulerAction_corres, simp) + apply (wpsimp simp: if_apply_def2 valid_sched_action_def + wp: thread_get_wp threadGet_wp inReleaseQueue_wp)+ apply (clarsimp simp: st_tcb_at_def obj_at_def is_tcb_def) - apply (clarsimp simp: obj_at'_def) + apply force done lemma ct_active_cross: @@ -2530,7 +2346,7 @@ lemma ct_released_cross_weak: apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps) apply (clarsimp simp: state_relation_def pspace_relation_def ) apply (erule_tac x="ksCurThread s'" in ballE) - by (auto simp: vs_all_heap_simps other_obj_relation_def tcb_relation_def tcb_relation_cut_def + by (auto simp: vs_all_heap_simps tcb_relation_def tcb_relation_cut_def cur_tcb'_def pred_tcb_at'_def obj_at'_def split: kernel_object.splits) @@ -2555,15 +2371,34 @@ lemma scActive_inv: "scActive scPtr \P\" by wpsimp +abbreviation tcb_queue_head_end_valid :: "tcb_queue \ kernel_state \ bool" where + "tcb_queue_head_end_valid queue s \ + (\head. tcbQueueHead queue = Some head \ tcb_at' head s) + \ (\end. tcbQueueEnd queue = Some end \ tcb_at' end s) + \ ((\head. tcbQueueHead queue = Some head) \ (\end. tcbQueueEnd queue = Some end))" + +lemma list_queue_relation_tcb_queue_head_end_valid: + "\list_queue_relation ts queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s); + \t \ set ts. tcb_at' t s\ + \ tcb_queue_head_end_valid queue s" + by (fastforce dest: heap_path_head' simp: list_queue_relation_def queue_end_valid_def) + +defs tcb_queue_head_end_valid_asrt_def: + "tcb_queue_head_end_valid_asrt \ tcb_queue_head_end_valid" + +declare tcb_queue_head_end_valid_asrt_def[simp] + lemma gets_the_releaseQNonEmptyAndReady_corres: "corres (=) (valid_release_q and active_scs_valid and valid_objs and pspace_aligned and pspace_distinct) - (valid_objs' and pspace_bounded') + valid_objs' (gets_the (read_release_q_non_empty_and_ready)) (gets_the (releaseQNonEmptyAndReady))" apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) apply (fastforce dest: pspace_aligned_cross) apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) apply (fastforce dest: pspace_distinct_cross) + apply (rule_tac Q'=pspace_bounded' in corres_cross_add_guard) + apply (fastforce intro!: pspace_relation_pspace_bounded') apply (simp add: read_release_q_non_empty_and_ready_def releaseQNonEmptyAndReady_def gets_the_ogets readReleaseQueue_def gets_the_if_distrib flip: getReleaseQueue_def) @@ -2589,7 +2424,8 @@ lemma gets_the_releaseQNonEmptyAndReady_corres: apply clarsimp apply wpsimp apply (wpsimp wp: thread_get_wp) - apply (rule_tac Q'="\rv s. \scPtr. rv = Some scPtr \ active_sc_at' scPtr s \ valid_objs' s" + apply (rule_tac Q'="\rv s. \scPtr. rv = Some scPtr \ active_sc_at' scPtr s \ valid_objs' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s" in hoare_post_imp) apply (fastforce intro: valid_objs'_valid_refills' simp: active_sc_at'_def is_active_sc'_def obj_at'_def @@ -2614,10 +2450,16 @@ lemma gets_the_releaseQNonEmptyAndReady_corres: apply (frule (3) obj_at'_tcbQueueHead_ksReleaseQueue) apply (clarsimp simp: tcbQueueEmpty_def) apply normalise_obj_at' - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') - by (fastforce simp: active_sc_tcb_at'_def opt_pred_def opt_map_def - obj_at'_def active_sc_at'_def valid_bound_obj'_def valid_tcb'_def - split: option.splits) + apply (elim impE) + apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_head) + apply fastforce + apply (fastforce simp: opt_pred_def opt_map_def obj_at'_def) + apply (clarsimp simp: active_sc_tcb_at'_def active_sc_at'_def opt_pred_def opt_map_def obj_at'_def + split: option.splits) + apply (rename_tac sc scPtr) + apply (frule_tac x=scPtr and v=sc in aligned_distinct_obj_atI'; fastforce simp: obj_at'_def) + done lemma release_queue_length_well_founded: "wf {((r :: unit, s :: 'a state), (r', s')). length (release_queue s) < length (release_queue s')}" @@ -2654,67 +2496,47 @@ lemma awaken_terminates: apply (rule release_queue_length_well_founded) done -definition tcb_release_remove' :: "obj_ref \ (unit, 'z::state_ext) s_monad" where - "tcb_release_remove' tcb_ptr \ do - qs \ gets release_queue; - when (tcb_ptr \ set qs) $ do - when (hd qs = tcb_ptr) $ modify (reprogram_timer_update (\_. True)); - set_release_queue (tcb_queue_remove tcb_ptr qs) - od - od" - -lemma tcb_release_remove_monadic_rewrite: - "monadic_rewrite False True (tcb_at tcb_ptr and (\s. distinct (release_queue s))) - (tcb_release_remove tcb_ptr) (tcb_release_remove' tcb_ptr)" - supply if_split[split del] - apply (clarsimp simp: tcb_release_remove_def tcb_release_remove'_def tcb_sched_dequeue_def) - apply (rule monadic_rewrite_bind_tail) - apply (clarsimp simp: when_def) - apply (rule monadic_rewrite_if_r) - (* tcb_ptr is in the release queue *) - - (* break off the reprogramming of the timer *) - apply (rule monadic_rewrite_bind) - apply (rule monadic_rewrite_if_known) - - apply (rule_tac P="\_. distinct qs" in monadic_rewrite_guard_arg_cong) - apply (erule (1) filter_tcb_queue_remove) - apply wpsimp +crunch setReleaseQueue + for ready_queues_relation[wp]: "\s'. ready_queues_relation s s'" + (simp: ready_queues_relation_def) - (* tcb_ptr is not in the release queue *) - apply (rule monadic_rewrite_trans) - apply (rule monadic_rewrite_bind_head) - apply (rule monadic_rewrite_if_l_False) - apply (rule monadic_rewrite_refl) - apply (rule monadic_rewrite_drop_return) - apply (rule monadic_rewrite_trans) - apply (rule_tac P="\s. release_queue s = qs" in monadic_rewrite_guard_arg_cong) - apply (rule filter_True) - apply clarsimp +lemma set_release_queue_not_in_release_q_rewrite: + "monadic_rewrite False True (\s. release_queue s = qs \ tcbPtr \ set qs) + (set_release_queue (tcb_sched_dequeue tcbPtr qs)) (return ())" + unfolding set_tcb_queue_def + apply (rule monadic_rewrite_guard_imp) apply (rule monadic_rewrite_modify_noop) - apply wpsimp - apply fastforce + apply (rename_tac s) + apply (case_tac s; fastforce) done -crunch setReleaseQueue - for ready_queues_relation[wp]: "\s'. ready_queues_relation s s'" - (simp: ready_queues_relation_def) +lemma release_q_active_reprogram_timer[simp]: + "release_q_runnable (reprogram_timer_update f s) = release_q_runnable s" + by (simp add: release_q_runnable_def) + +lemma ep_queues_blocked_reprogram_timer[simp]: + "ep_queues_blocked (reprogram_timer_update f s) = ep_queues_blocked s" + by (simp add: ep_queues_blocked_def) + +lemma ntfn_queues_blocked_reprogram_timer[simp]: + "ntfn_queues_blocked (reprogram_timer_update f s) = ntfn_queues_blocked s" + by (simp add: ntfn_queues_blocked_def) lemma tcbReleaseRemove_corres: "tcb_ptr = tcbPtr \ corres dc - (tcb_at tcb_ptr and ready_or_release and (\s. distinct (release_queue s)) - and pspace_aligned and pspace_distinct ) + (ep_queues_blocked and ntfn_queues_blocked and tcb_at tcb_ptr and ready_or_release + and (\s. distinct (release_queue s)) and release_q_runnable + and pspace_aligned and pspace_distinct) (sym_heap_sched_pointers and valid_objs') (tcb_release_remove tcb_ptr) (tcbReleaseRemove tcbPtr)" - supply if_split[split del] - heap_path_append[simp del] fun_upd_apply[simp del] list_remove_append[simp del] + supply if_split[split del] bind_return[simp del] return_bind[simp del] + ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + heap_ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) apply (rule_tac Q'="tcb_at' tcbPtr" in corres_cross_add_guard) apply (fastforce dest!: state_relationD elim!: tcb_at_cross) - apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) - apply (fastforce intro: monadic_rewrite_guard_imp[OF tcb_release_remove_monadic_rewrite]) - apply (clarsimp simp: tcb_release_remove'_def tcbReleaseRemove_def) + apply (clarsimp simp: tcb_release_remove_def tcbReleaseRemove_def) apply (rule corres_symb_exec_l[OF _ _ gets_sp]; wpsimp?) apply (rule corres_stateAssert_ignore, fastforce) apply (rule corres_stateAssert_ignore) @@ -2724,54 +2546,93 @@ lemma tcbReleaseRemove_corres: apply (rule corres_symb_exec_r[OF _ inReleaseQueue_sp]; wpsimp?) apply (rule corres_underlying_lift_ex2') apply (clarsimp simp: when_def) - apply (rule corres_if_strong'; fastforce?) - apply (drule state_relation_release_queue_relation) - apply (clarsimp simp: list_queue_relation_def release_queue_relation_def) - apply (force simp: in_queue_2_def obj_at'_def opt_pred_def opt_map_def) + apply (rule_tac Q="\s. queued = in_release_q tcbPtr s" in corres_cross_add_abs_guard) + apply (fastforce dest: state_relation_release_queue_relation + in_release_q_tcbInReleaseQueue_eq[where t=tcbPtr] + simp: opt_pred_def opt_map_red obj_at'_def) + apply (case_tac "\ queued"; clarsimp) + apply (rule_tac F="\ (qs \ [] \ hd qs = tcbPtr)" in corres_req) + apply (clarsimp simp: in_release_q_def) + apply (clarsimp simp: if_to_top_of_bind split: if_splits) + apply (intro conjI impI) + apply fastforce + apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) + apply (clarsimp simp: return_bind) + apply (rule monadic_rewrite_guard_imp[OF set_release_queue_not_in_release_q_rewrite]) + apply (clarsimp simp: not_in_release_q_def) + apply clarsimp apply (rule corres_symb_exec_r[rotated, OF getReleaseQueue_sp]; wpsimp?) - \ \deal with the reprogram of the timer\ apply (rule corres_split_skip[rotated 2]) apply (rule corres_if_strong') apply (drule state_relation_release_queue_relation) apply (clarsimp simp: list_queue_relation_def release_queue_relation_def) - apply (force dest!: heap_path_head simp: list_queue_relation_def) + apply (frule heap_path_head') + apply fastforce apply corres apply clarsimp - apply (find_goal \match conclusion in "valid _ _ _" \ wpsimp\)+ - + apply (find_goal \match conclusion in "\_\ _ \_\" \ wpsimp\)+ \ \setting the release queue\ - apply (rule corres_from_valid_det) - apply (fastforce intro: det_wp_modify det_wp_pre) - apply (wpsimp wp: tcbQueueRemove_no_fail hoare_vcg_ex_lift threadSet_sched_pointers) - apply (fastforce dest: state_relation_release_queue_relation - simp: ex_abs_def release_queue_relation_def list_queue_relation_def) - apply (clarsimp simp: state_relation_def) - apply (frule singleton_eqD) - apply (drule set_release_queue_new_state) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves \wpsimp simp: swp_def\)?) - - apply (find_goal \match conclusion in "\_\ _ \\_. ready_queues_relation t\" for t \ \-\\) - apply (wpsimp wp: tcbQueueRemove_list_queue_relation_other threadSet_sched_pointers - hoare_vcg_all_lift threadSet_inQ - simp: ready_queues_relation_def ready_queue_relation_def Let_def - | wps)+ + apply (rule corres_underlying_from_rcorres) + apply (wpsimp wp: tcbQueueRemove_no_fail) + apply (rename_tac s) apply (rule_tac x="release_queue s" in exI) - apply (auto dest: ready_or_release_disjoint simp: release_queue_relation_def Let_def)[1] - - apply (clarsimp simp: release_queue_relation_def) - apply (frule singleton_eqD) - apply (drule set_release_queue_new_state) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply ((wpsimp wp: tcbQueueRemove_list_queue_relation threadSet_sched_pointers | wps)+)[1] - - apply (rule hoare_allI, rename_tac t') - apply (subst set_tcb_queue_remove) - apply clarsimp - apply (case_tac "t' = tcbPtr") - apply (wpsimp wp: threadSet_wp) - apply (wpsimp wp: threadSet_opt_pred_other) - done + apply (force intro!: tcb_at_cross dest: state_relation_release_queue_relation + simp: release_queue_relation_def release_q_runnable_def in_release_q_def) + apply (clarsimp simp: state_relation_def ghost_relation_heap_ghost_relation + pspace_relation_heap_pspace_relation heap_pspace_relation_def) + apply (subst bind_assoc[symmetric]) + apply (rule rcorres_add_return_l) + apply (rcorres_conj_lift \fastforce\ wp: threadSet_field_inv)+ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ep_queues_relation\ + apply (simp only: ep_queues_relation_def) + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_threadSet_list_queue_relation + rcorres_op_lifts) + apply (clarsimp simp: release_queue_relation_def in_release_q_def) + apply (metis ep_queues_release_queue_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ntfn_queues_relation\ + apply (simp only: ntfn_queues_relation_def) + apply (rcorres rcorres: tcbQueueRemove_rcorres_other rcorres_threadSet_list_queue_relation + rcorres_op_lifts) + apply (clarsimp simp: release_queue_relation_def in_release_q_def) + apply (metis ntfn_queues_release_queue_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ready_queues_relation\ + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac d p) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation + tcbQueueRemove_rcorres_other) + apply (clarsimp simp: release_queue_relation_def in_release_q_def) + apply (metis ready_or_release_disjoint) + apply wpsimp + apply wpsimp + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: hoare_vcg_all_lift threadSet_field_opt_pred simp: inQ_def) + apply (clarsimp simp: in_monad) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \release_queue_relation\ + apply (clarsimp simp: release_queue_relation_def) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rcorres rcorres: rcorres_threadSet_release_queue_list_queue_relation + tcbQueueRemove_rcorres) + apply (clarsimp simp: release_queue_relation_def in_release_q_def tcb_sched_dequeue_def + removeAll_filter_not_eq) + apply blast + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac t) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (case_tac "t \ tcbPtr") + apply (wpsimp wp: threadSet_opt_pred_other) + subgoal by (clarsimp simp: tcb_sched_dequeue_def in_monad) + apply (wpsimp wp: threadSet_wp hoare_drop_imps) + subgoal by (clarsimp simp: tcb_sched_dequeue_def in_monad) + by (rcorres_conj_lift \fastforce\ wp: threadSet_field_inv)+ lemma tcbInReleaseQueue_update_valid_tcbs'[wp]: "threadSet (tcbInReleaseQueue_update f) tcbPtr \valid_tcbs'\" @@ -2784,15 +2645,20 @@ lemma tcbQueueRemove_valid_tcbs'[wp]: apply (clarsimp simp: valid_tcbs'_def valid_tcb'_def obj_at'_def opt_tcb_at'_def) done -crunch tcbReleaseDequeue +crunch tcbQueueRemove, tcbReleaseDequeue for valid_tcbs'[wp]: valid_tcbs' and valid_sched_pointers[wp]: valid_sched_pointers - (wp: crunch_wps simp: crunch_simps) + (wp: crunch_wps simp: crunch_simps ignore: threadSet) crunch tcb_release_remove for ready_qs_distinct[wp]: ready_qs_distinct and in_correct_ready_q[wp]: in_correct_ready_q - (rule: in_correct_ready_q_lift simp: crunch_simps ready_qs_distinct_def) + and ready_queues_runnable[wp]: ready_queues_runnable + and ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (rule: in_correct_ready_q_lift ready_queues_runnable_lift + ep_queues_blocked_lift ntfn_queues_blocked_lift + simp: crunch_simps ready_qs_distinct_def) defs tcbQueueHead_ksReleaseQueue_active_sc_tcb_at'_asrt_def: "tcbQueueHead_ksReleaseQueue_active_sc_tcb_at'_asrt s \ @@ -2800,11 +2666,11 @@ defs tcbQueueHead_ksReleaseQueue_active_sc_tcb_at'_asrt_def: lemma tcbReleaseDequeue_corres: "corres dc - (pspace_aligned and pspace_distinct and valid_sched_action - and valid_objs and in_correct_ready_q and ready_qs_distinct - and active_scs_valid and ready_or_release - and valid_release_q and (\s. release_queue s \ [])) - (valid_objs' and valid_sched_pointers and sym_heap_sched_pointers and pspace_bounded') + (ep_queues_blocked and ntfn_queues_blocked + and pspace_aligned and pspace_distinct and valid_sched_action + and valid_objs and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable + and active_scs_valid and ready_or_release and valid_release_q and (\s. release_queue s \ [])) + (valid_objs' and valid_sched_pointers and sym_heap_sched_pointers) tcb_release_dequeue tcbReleaseDequeue" apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) apply (fastforce dest: pspace_aligned_cross) @@ -2814,8 +2680,7 @@ lemma tcbReleaseDequeue_corres: apply (rule corres_stateAssert_add_assertion[rotated]) apply (fastforce intro: ksReleaseQueue_asrt_cross) apply (rule corres_stateAssert_add_assertion[rotated]) - apply (fastforce simp: tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt_def - dest!: release_queue_active_sc_tcb_at_cross) + apply (fastforce dest!: release_queue_active_sc_tcb_at_cross) apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF getReleaseQueue_corres]) apply clarsimp @@ -2831,7 +2696,8 @@ lemma tcbReleaseDequeue_corres: apply (simp only: bind_assoc) apply (rule corres_split[OF possibleSwitchTo_corres]) apply fastforce - apply (rule corres_symb_exec_r_conj_ex_abs[where P'=\ and P=\]) + apply (rule corres_symb_exec_r_conj_ex_abs[ + where P'=\ and P="pspace_aligned and pspace_distinct"]) apply (rule corres_symb_exec_r_conj_ex_abs [where P'=\ and P="valid_release_q and pspace_aligned and pspace_distinct @@ -2852,10 +2718,13 @@ lemma tcbReleaseDequeue_corres: apply wpsimp+ apply (fastforce dest!: hd_in_set simp: valid_release_q_def vs_all_heap_simps pred_tcb_at_def obj_at_def is_tcb_def) - apply (fastforce dest: state_relation_release_queue_relation heap_path_head - intro!: st_tcb_at_runnable_cross - simp: valid_release_q_def vs_all_heap_simps pred_tcb_at_def obj_at_def - release_queue_relation_def list_queue_relation_def) + apply clarsimp + apply (frule valid_objs'_valid_tcbs') + apply (frule state_relation_release_queue_relation) + apply (clarsimp simp: release_queue_relation_def list_queue_relation_def) + apply (frule (1) heap_path_head) + apply (rule_tac s=s in st_tcb_at_runnable_cross; + clarsimp simp: valid_release_q_def vs_all_heap_simps obj_at_kh_kheap_simps)+ done crunch tcbReleaseDequeue @@ -2868,26 +2737,44 @@ crunch tcb_release_dequeue crunch tcb_release_dequeue for in_correct_ready_q[wp]: in_correct_ready_q - (rule: in_correct_ready_q_lift ignore: tcb_sched_action) + and ready_qs_distinct[wp]: ready_qs_distinct + (rule: ready_qs_distinct_lift ignore: tcb_sched_action wp: crunch_wps) + +lemma possible_switch_to_ready_queues_runnable[wp]: + "\ready_queues_runnable and st_tcb_at runnable t\ + possible_switch_to t + \\_. ready_queues_runnable\" + unfolding possible_switch_to_def set_scheduler_action_def get_tcb_obj_ref_def + apply (wpsimp wp: thread_get_wp) + apply (fastforce simp: ready_queues_runnable_def st_tcb_at_def obj_at_def is_tcb_def) + done + +lemma tcb_release_dequeue_ready_qs_active[wp]: + "\ready_queues_runnable and release_q_runnable\ tcb_release_dequeue \\_. ready_queues_runnable\" + unfolding tcb_release_dequeue_def set_scheduler_action_def get_tcb_obj_ref_def + apply (wpsimp wp: thread_get_wp) + apply (clarsimp simp: release_q_runnable_def) + done crunch tcb_release_dequeue - for ready_qs_distinct[wp]: ready_qs_distinct - (rule: ready_qs_distinct_lift ignore: tcb_sched_action wp: crunch_wps) + for ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (wp: ep_queues_blocked_lift ntfn_queues_blocked_lift) lemma awaken_corres: "corres dc - (pspace_aligned and pspace_distinct and valid_objs and valid_release_q - and in_correct_ready_q and ready_qs_distinct + (ep_queues_blocked and ntfn_queues_blocked + and pspace_aligned and pspace_distinct and valid_objs + and valid_release_q and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable and valid_sched_action and valid_tcbs and active_scs_valid and ready_or_release) (sym_heap_sched_pointers and valid_sched_pointers and valid_objs' - and pspace_aligned' and pspace_distinct' and pspace_bounded') + and pspace_aligned' and pspace_distinct') Schedule_A.awaken awaken" apply (clarsimp simp: awaken_def Schedule_A.awaken_def runReaderT_def) apply (rule corres_stateAssert_ignore) apply (fastforce intro: ksReleaseQueue_asrt_cross) apply (rule corres_stateAssert_ignore) - apply (fastforce simp: tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt_def - dest!: release_queue_active_sc_tcb_at_cross) + apply (fastforce dest!: release_queue_active_sc_tcb_at_cross) apply (rule corres_whileLoop_abs; simp) apply (rule_tac f=read_release_q_non_empty_and_ready and f'=releaseQNonEmptyAndReady @@ -2971,6 +2858,7 @@ lemma setNextInterrupt_corres: apply clarsimp apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ scActive_sp, rotated]; (solves wpsimp)?) apply wpsimp + apply (clarsimp simp: ex_abs_def) apply (fastforce dest: tcb_ko_at_valid_objs_valid_tcb' simp: valid_tcb'_def) apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp, rotated]; (solves wpsimp)?) apply wpsimp @@ -3012,6 +2900,7 @@ lemma setNextInterrupt_corres: apply clarsimp apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ scActive_sp, rotated]; (solves wpsimp)?) apply wpsimp + apply (clarsimp simp: ex_abs_def) apply (fastforce dest: tcb_ko_at_valid_objs_valid_tcb' simp: valid_tcb'_def) apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ assert_sp, rotated]; (solves wpsimp)?) apply wpsimp @@ -3032,12 +2921,11 @@ lemma setNextInterrupt_corres: (* refillUnblockCheck_corres *) lemma isRoundRobin_corres: - "corres (=) (sc_at sc_ptr) (sc_at' sc_ptr) - (is_round_robin sc_ptr) (isRoundRobin sc_ptr)" + "corres (=) (sc_at sc_ptr and pspace_aligned and pspace_distinct) \ + (is_round_robin sc_ptr) (isRoundRobin sc_ptr)" apply (clarsimp simp: is_round_robin_def isRoundRobin_def) - apply (corresKsimp corres: get_sc_corres - simp: sc_relation_def) - done + by (corres corres: get_sc_corres + simp: sc_relation_def) lemma refillPopHead_refillSize: "\sc_valid_refills' sc'; 1 < refillSize sc'\ @@ -3065,13 +2953,21 @@ lemma refillPopHead_corres: \ valid_objs s \ is_active_sc sc_ptr s) (valid_objs' and valid_refills' sc_ptr) (refill_pop_head sc_ptr) (refillPopHead scPtr)" + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) apply (add_active_sc_at' scPtr) apply (rule corres_cross[where Q' = "sc_at' sc_ptr", OF sc_at'_cross_rel], fastforce) apply (clarsimp simp: refill_pop_head_def refillPopHead_def) apply (rule corres_stateAssert_ignore, simp)+ + apply (rule corres_split_forwards'[OF _ get_refill_head_sp getRefillHead_sp]) + apply (corres corres: getRefillHead_corres) + apply (fastforce dest: length_sc_refills_cross valid_objs'_valid_refills' + simp: sc_at_pred_n_def obj_at_def ) + apply fastforce + apply (rule corres_symb_exec_r[OF _ get_sc_sp']; (solves wpsimp)?) apply (rule stronger_corres_guard_imp) - apply (rule corres_split[OF getRefillHead_corres], simp) - apply (rule corres_symb_exec_r'[OF _ _ hoare_eq_P[OF get_sc_inv']]) apply (rule corres_symb_exec_r'[OF _ _ hoare_eq_P[OF getRefillNext_inv]]) apply (rule_tac Q1=\ and Q'1="\sc'. sc_valid_refills' sc' \ 1 < refillSize sc' @@ -3088,13 +2984,13 @@ lemma refillPopHead_corres: apply (clarsimp simp: objBits_simps) apply (wpsimp | wpsimp wp: getRefillNext_wp)+ apply (clarsimp simp: sc_at_pred_n_def obj_at_def) - by (fastforce dest: length_sc_refills_cross valid_objs'_valid_refills' + by (fastforce dest: length_sc_refills_cross simp: valid_refills'_def obj_at'_def sc_at_pred_n_def obj_at_def opt_map_def opt_pred_def) lemma refillPopHead_valid_refills'[wp]: "\\s. valid_refills' scPtr' s - \ (scPtr = scPtr' \ obj_at' (\sc'. Suc 0 < refillSize sc') scPtr s)\ + \ (scPtr = scPtr' \ ((\sc. 1 < refillSize sc) |< scs_of' s) scPtr)\ refillPopHead scPtr \\_. valid_refills' scPtr'\" apply (clarsimp simp: refillPopHead_def updateSchedContext_def setSchedContext_def) @@ -3224,7 +3120,8 @@ lemma mergeOverlappingRefills_corres: apply (clarsimp simp: refill_map_def)+ apply (rule updateRefillHd_corres, simp) apply (clarsimp simp: refill_map_def) - apply (rule hoare_strengthen_post[where Q'="\_. sc_at sc_ptr", rotated]) + apply (rule hoare_post_imp[ + where Q'="\_. sc_at sc_ptr and pspace_aligned and pspace_distinct"]) apply (simp add: active_sc_at_equiv is_active_sc_rewrite[symmetric]) apply (wpsimp wp: refill_pop_head_sc_active)+ apply (clarsimp simp: obj_at_def is_sc_obj opt_map_red is_active_sc_rewrite active_sc_at_equiv @@ -3233,14 +3130,11 @@ lemma mergeOverlappingRefills_corres: done lemma mergeOverlappingRefills_valid_refills'[wp]: - "\obj_at'(\sc. 1 < refillSize sc) scp and valid_refills' scp\ + "\(\s. ((\sc. 1 < refillSize sc) |< scs_of' s) scp) and valid_refills' scp\ mergeOverlappingRefills p \\_. valid_refills' scp\" - unfolding mergeOverlappingRefills_def - by (wpsimp simp: updateRefillHd_def refillPopHead_def wp: updateSchedContext_wp getRefillNext_wp) - -lemmas no_fail_getRefillHead[wp] = - no_ofail_gets_the[OF no_ofail_readRefillHead, simplified getRefillHead_def[symmetric]] + unfolding mergeOverlappingRefills_def updateSchedContext_def + by (wpsimp simp: updateRefillHd_def refillPopHead_def wp: getRefillNext_wp) lemma no_fail_refillPopHead[wp]: "no_fail (valid_objs' and active_sc_at' scPtr) (refillPopHead scPtr)" @@ -3316,39 +3210,36 @@ lemma refillHeadOverlappingLoop_corres: (sc_at sc_ptr and pspace_aligned and pspace_distinct and valid_objs and is_active_sc sc_ptr) (valid_objs' and valid_refills' sc_ptr) (refill_head_overlapping_loop sc_ptr) (refillHeadOverlappingLoop sc_ptr)" + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) unfolding refill_head_overlapping_loop_def refillHeadOverlappingLoop_def runReaderT_def apply (rule_tac Q'="active_sc_at' sc_ptr" in corres_cross_add_guard) apply (fastforce intro!: active_sc_at'_cross_valid_objs) apply (rule corres_whileLoop) - apply (drule refillHeadOverlapping_corres_eq[where sc_ptr=sc_ptr]; - simp add: runReaderT_def active_sc_at'_rewrite) - apply simp - apply (rule corres_guard_imp - [where P=P and Q=P for P, - where - P'= Q and - Q'="Q and (\s. ((\sc. 1 < refillSize sc) |< scs_of' s) sc_ptr)" for Q]) - apply (rule corres_cross_add_abs_guard - [where Q="(\s. ((\sc. 1 < length (sc_refills sc)) |< scs_of2 s) sc_ptr)"]) - apply (drule state_relation_sc_relation) - apply fastforce - apply (clarsimp simp: active_sc_at'_rewrite) - apply (clarsimp simp: obj_at_simps is_sc_obj valid_refills'_def sc_relation_def - opt_map_red opt_pred_def active_sc_at'_rewrite) - apply (corres corres: mergeOverlappingRefills_corres) - apply fastforce - apply clarsimp - apply (prop_tac "(valid_objs' and active_sc_at' sc_ptr) s", fastforce) - apply (frule no_ofailD[OF no_ofail_refillHeadOverlapping]) + apply (frule refillHeadOverlapping_corres_eq[where sc_ptr=sc_ptr]; + simp add: runReaderT_def) + apply (corres corres: mergeOverlappingRefills_corres) + apply (prop_tac "(valid_objs' and active_sc_at' sc_ptr) s'", fastforce) + apply (frule no_ofailD[OF no_ofail_refillHeadOverlapping]) + apply clarsimp + apply (frule use_ovalid[OF refillHeadOverlapping_refillSize, where r=True, simplified, rotated]) + using no_ofailD[OF no_ofail_refillHeadOverlapping] + apply fastforce + apply (frule (1) state_relation_sc_relation) + apply (fastforce intro!: sc_at_cross) + apply (clarsimp simp: obj_at_simps is_sc_obj valid_refills'_def sc_relation_def + opt_map_red opt_pred_def + split: option.splits) apply clarsimp - apply (fastforce dest!: use_ovalid[OF refillHeadOverlapping_refillSize]) apply (wpsimp simp: is_active_sc_rewrite) apply (wpsimp wp: mergeOverlappingRefills_valid_objs') apply (prop_tac "(valid_objs' and active_sc_at' sc_ptr) s", fastforce) apply (frule no_ofailD[OF no_ofail_refillHeadOverlapping]) - apply (fastforce dest: use_ovalid[OF refillHeadOverlapping_refillSize] - simp: active_sc_at'_rewrite opt_pred_def opt_map_def obj_at'_def) apply clarsimp + apply (fastforce dest!: use_ovalid[OF refillHeadOverlapping_refillSize]) + apply clarsimp apply wpsimp apply (fastforce simp: active_sc_at'_rewrite) apply (fastforce intro!: mergeOverlappingRefills_terminates) @@ -3365,32 +3256,36 @@ lemma refillUnblockCheck_corres: and valid_objs and is_active_sc scp) (valid_objs' and valid_refills' scp) (refill_unblock_check scp) (refillUnblockCheck scp)" + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) apply (clarsimp simp: refill_unblock_check_def refillUnblockCheck_def) apply (rule_tac Q'="active_sc_at' scp" in corres_cross_add_guard) apply (fastforce intro!: active_sc_at'_cross_valid_objs) apply (rule corres_stateAssert_ignore, simp) - apply (intro corres_symb_exec_r'[OF _ scActive_sp]; (solves \wpsimp simp: \)?) - apply (rule corres_assert_gen_asm_cross[where P=P' and P'=P' for P', + apply (intro corres_symb_exec_r[OF _ scActive_sp]; (solves \wpsimp simp: \)?) + apply (find_goal \match conclusion in "no_fail P f" for P f \ -\) + apply wpsimp + apply (fastforce simp: active_sc_at'_def) + apply (rule corres_assert_gen_asm_cross[where P=P' and P'=P' for P', where Q=Q' and Q'=Q' for Q', simplified]) apply (fastforce dest!: active_sc_at'_cross_valid_objs simp: active_sc_at'_def obj_at'_def) - apply simp - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF isRoundRobin_corres]) - apply (rule corres_split_eqr[OF refillReady_corres], simp) - apply (rule corres_when, fastforce) - apply (rule corres_split[OF getCurTime_corres]) - apply (rule corres_split[OF updateRefillHd_corres], simp) - apply (clarsimp simp: refill_map_def) - apply (rule corres_split[OF setReprogramTimer_corres]) - apply (rule refillHeadOverlappingLoop_corres) - apply (wpsimp simp: setReprogramTimer_def)+ - apply (wpsimp wp: is_round_robin_wp isRoundRobin_wp)+ - apply (clarsimp simp: obj_at_simps opt_map_red opt_pred_def is_active_sc_rewrite - sc_at_pred_n_def - split: Structures_A.kernel_object.splits) - apply (fastforce dest!: valid_objs'_valid_refills' - simp: obj_at_simps opt_map_red opt_pred_def is_active_sc'_def) - apply (wpsimp simp: active_sc_at'_rewrite) + apply simp + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF isRoundRobin_corres]) + apply (rule corres_split_eqr[OF refillReady_corres], simp) + apply (rule corres_when, fastforce) + apply (rule corres_split[OF getCurTime_corres]) + apply (rule corres_split[OF updateRefillHd_corres], simp) + apply (clarsimp simp: refill_map_def) + apply (rule corres_split[OF setReprogramTimer_corres]) + apply (rule refillHeadOverlappingLoop_corres) + apply (wpsimp simp: setReprogramTimer_def)+ + apply (wpsimp wp: is_round_robin_wp isRoundRobin_wp)+ + apply (clarsimp simp: obj_at_simps opt_map_red opt_pred_def sc_at_pred_n_def + split: Structures_A.kernel_object.splits) + apply fastforce done lemma sporadic_implies_active_cross: @@ -3413,8 +3308,8 @@ lemma ifCondRefillUnblockCheck_corres: \ (((\sc. case_option (sc_active sc) \ act) |< scs_of2 s) scp) \ valid_objs s) scp_opt) (\s. case_option True (\scp. case_option (valid_objs' s \ valid_refills' scp s) - (\_. valid_objs' s) act) scp_opt) - (if_cond_refill_unblock_check scp_opt act ast) (ifCondRefillUnblockCheck scp_opt act ast)" + (\_. valid_objs' s) act) scp_opt) + (if_cond_refill_unblock_check scp_opt act ast) (ifCondRefillUnblockCheck scp_opt act ast)" unfolding if_cond_refill_unblock_check_def ifCondRefillUnblockCheck_def apply (cases scp_opt; simp add: maybeM_def) apply (rename_tac scp) @@ -3439,9 +3334,8 @@ lemma ifCondRefillUnblockCheck_corres: clarsimp simp: opt_map_red obj_at_def is_active_sc2_def vs_all_heap_simps valid_refills_def rr_valid_refills_def active_sc_def opt_pred_def split: if_split_asm) - apply (clarsimp simp: case_bool_if option.case_eq_if split: if_split_asm) - apply (fastforce elim!: valid_objs'_valid_refills' - dest!: sporadic_implies_active_cross) + apply (fastforce elim!: valid_objs'_valid_refills' dest!: sporadic_implies_active_cross + simp: case_bool_if option.case_eq_if split: if_split_asm) done lemma getCurTime_sp: @@ -3457,10 +3351,10 @@ lemma refillSize_refillAddTail: by (fastforce simp: refillSize_def refillNext_def split: if_splits) lemma getRefillNext_sp: - "\P\ getRefillNext scPtr index \\rv s. P s \ (\sc. ko_at' sc scPtr s \ rv = refillNext sc index)\" - apply (wpsimp wp: getRefillNext_wp) - apply (clarsimp simp: obj_at'_def) - done + "\P\ + getRefillNext scPtr index + \\rv s. P s \ (\sc. scs_of' s scPtr = Some sc \ rv = refillNext sc index)\" + by (wpsimp wp: getRefillNext_wp) lemma no_ofail_readRefillSize[wp]: "no_ofail (sc_at' scPtr) (readRefillSize scPtr)" @@ -3482,6 +3376,10 @@ lemma refillAddTail_corres: (\s'. ((\sc'. refillSize sc' < scRefillMax sc' \ sc_valid_refills' sc') |< scs_of' s') sc_ptr \ valid_objs' s') (refill_add_tail sc_ptr new) (refillAddTail scPtr new')" + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) apply (add_active_sc_at' sc_ptr) apply (rule corres_cross[where Q' = "sc_at' sc_ptr", OF sc_at'_cross_rel], fastforce) apply (clarsimp simp: refill_add_tail_def refillAddTail_def) @@ -3493,8 +3391,10 @@ lemma refillAddTail_corres: apply (clarsimp simp: updateRefillIndex_def) apply (rule corres_guard_imp) apply (rule monadic_rewrite_corres_r) - apply (subst bind_dummy_ret_val) - apply (rule updateSchedContext_decompose[THEN monadic_rewrite_sym]) + apply (rule monadic_rewrite_guard_imp) + apply (subst bind_dummy_ret_val) + apply (rule updateSchedContext_decompose[THEN monadic_rewrite_sym]) + apply (fastforce simp: objBits_simps) apply fastforce apply fastforce apply (rule_tac Q'="\sc'. refillSize sc' < scRefillMax sc' \ sc_valid_refills' sc' @@ -3572,7 +3472,7 @@ lemma getRefills_sp: lemma refillBudgetCheckRoundRobin_corres: "corres dc - (cur_sc_active and (\s. sc_at (cur_sc s) s)) + (cur_sc_active and (\s. sc_at (cur_sc s) s) and pspace_aligned and pspace_distinct) ((\s'. valid_refills' (ksCurSc s') s') and (\s'. sc_at' (ksCurSc s') s')) (refill_budget_check_round_robin usage) (refillBudgetCheckRoundRobin usage)" supply projection_rewrites[simp] @@ -3635,23 +3535,25 @@ lemma mergeNonoverlappingHeadRefill_corres: apply (fastforce dest!: length_sc_refills_cross[where P="\l. Suc 0 < l"] simp: opt_map_red opt_pred_def vs_all_heap_simps obj_at'_def sc_at_ppred_def obj_at_def) - apply (rule_tac Q="\_. sc_at sc_ptr and is_active_sc sc_ptr" + apply (rule_tac Q="\_. sc_at sc_ptr and is_active_sc sc_ptr and pspace_aligned and pspace_distinct" and Q'="\_. valid_refills' scPtr and sc_at' scPtr" in corres_underlying_split; (solves wpsimp)?) - apply (corres corres: refillPopHead_corres - simp: obj_at_def vs_all_heap_simps pred_map_simps sc_at_ppred_def) - apply (rule corres_guard_imp) + apply (corres corres: refillPopHead_corres + simp: obj_at_def vs_all_heap_simps pred_map_simps sc_at_ppred_def) + apply (rule corres_guard_imp) apply (rule corres_underlying_split[OF updateRefillHd_corres]) apply blast apply (clarsimp simp: refill_map_def) apply (fastforce intro: updateRefillHd_corres simp: refill_map_def) apply (wpsimp simp: update_refill_hd_def wp: update_sched_context_wp) - apply (clarsimp simp: vs_all_heap_simps active_sc_def is_active_sc2_def obj_at_def opt_map_def) + apply (clarsimp simp: vs_all_heap_simps active_sc_def is_active_sc2_def obj_at_def opt_map_def) apply (wpsimp simp: updateRefillHd_def simp: objBits_simps) apply (simp add: is_active_sc_rewrite[symmetric]) apply blast + apply wpsimp + apply (clarsimp simp: obj_at'_def opt_pred_def opt_map_def split: option.splits) done lemma refill_pop_head_sched_context_at[wp]: @@ -3750,8 +3652,7 @@ lemma headInsufficientLoop_corres: merge_nonoverlapping_head_refill_nonempty_refills) apply (fastforce dest!: no_ofailD[OF no_ofail_head_insufficient] head_insufficient_length simp: vs_all_heap_simps sc_at_ppred_def obj_at_def) - apply (wpsimp | strengthen valid_objs'_valid_refills' active_sc_at'_imp_is_active_sc')+ - apply (clarsimp simp: active_sc_at'_rewrite) + apply ((wpsimp | strengthen valid_objs'_valid_refills' active_sc_at'_imp_is_active_sc')+)[1] apply (fastforce intro!: non_overlapping_merge_refills_terminates) done @@ -3796,6 +3697,10 @@ lemma getRefillTail_corres: and is_active_sc sc_ptr and sc_at sc_ptr and sc_refills_sc_at (\refills. refills \ []) sc_ptr) valid_objs' (get_refill_tail sc_ptr) (getRefillTail scPtr)" + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross) apply (add_active_sc_at' scPtr) apply (clarsimp simp: get_refill_tail_def getRefillTail_def read_refill_tail_def readRefillTail_def read_sched_context_get_sched_context readSchedContext_def @@ -3810,10 +3715,9 @@ lemma getRefillTail_corres: apply simp+ apply wpsimp+ apply (clarsimp simp: sc_at_ppred_def obj_at_def is_sc_obj_def) - apply clarsimp - apply (frule (4) active_sc_at'_cross_valid_objs) - by (fastforce dest: valid_objs'_valid_refills' - simp: active_sc_at'_def obj_at'_def is_active_sc'_def in_omonad valid_refills'_def) + apply (fastforce dest: valid_objs'_valid_refills' + simp: active_sc_at'_def obj_at'_def is_active_sc'_def in_omonad valid_refills'_def) + done lemma scheduleUsed_corres: "\sc_ptr = scPtr; new = refill_map new'\ \ @@ -3857,8 +3761,8 @@ lemma scheduleUsed_corres: apply (rule corres_if_split; (solves simp)?) apply (corres corres: refillAddTail_corres) apply (fastforce simp: is_active_sc_rewrite) - apply (fastforce dest!: valid_objs'_valid_refills' - simp: obj_at_simps opt_map_red opt_pred_def valid_refills'_def) + apply (force dest!: valid_objs'_valid_refills' + simp: obj_at_simps opt_pred_def opt_map_def valid_refills'_def ) apply (corres corres: updateRefillTl_corres simp: refill_map_def) apply (fastforce intro!: valid_objs'_valid_refills') done @@ -3929,7 +3833,7 @@ lemma chargeEntireHeadRefill_corres: apply wpsimp apply (clarsimp simp: is_active_sc2_def sc_at_ppred_def obj_at_def active_sc_def vs_all_heap_simps Suc_lessI in_omonad) - apply (fastforce dest!: valid_objs'_valid_refills') + apply (force dest!: valid_objs'_valid_refills') done lemma updateRefillIndex_is_active_sc'[wp]: @@ -3972,10 +3876,6 @@ lemma scheduleUsed_valid_refills'[wp]: crunch charge_entire_head_refill for valid_objs[wp]: valid_objs -crunch chargeEntireHeadRefill - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps simp: refillSingle_def) - lemma schedule_used_length_nonzero[wp]: "\\s. if sc_ptr' = sc_ptr then pred_map \ (scs_of s) sc_ptr @@ -4189,9 +4089,9 @@ lemma refillBudgetCheck_corres: in corres_underlying_split[rotated]) apply (corresKsimp corres: headInsufficientLoop_corres) using MIN_BUDGET_pos - apply (fastforce intro!: valid_objs'_valid_refills' + apply (fastforce intro!: valid_objs'_valid_refills' active_sc_at'_imp_is_active_sc' simp: vs_all_heap_simps word_le_nat_alt sc_at_pred_n_def obj_at_def - refills_unat_sum_def unat_eq_0 active_sc_at'_def obj_at'_def + refills_unat_sum_def unat_eq_0 obj_at'_def is_active_sc'_def in_omonad) apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) apply ((wpsimp | wps)+)[1] @@ -4214,7 +4114,6 @@ lemma refillBudgetCheck_corres: apply (clarsimp simp: refill_map_def) apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) apply (corres corres: get_sc_corres) - apply (clarsimp simp: active_sc_at'_def) apply (clarsimp simp: bind_assoc) apply (rule corres_guard_imp) apply (rule corres_split[OF updateRefillHd_corres]) @@ -4231,31 +4130,34 @@ lemma refillBudgetCheck_corres: apply wpsimp apply (wpsimp wp: updateRefillHd_valid_objs') apply (clarsimp simp: vs_all_heap_simps is_active_sc2_def in_omonad active_sc_def) - apply (fastforce dest: valid_objs'_valid_refills' simp: active_sc_at'_rewrite) + apply (fastforce dest: valid_objs'_valid_refills' active_sc_at'_imp_is_active_sc') done (* schedule_corres *) crunch setReprogramTimer - for valid_tcbs'[wp]: valid_tcbs' - and valid_refills'[wp]: "valid_refills' scPtr" + for valid_refills'[wp]: "valid_refills' scPtr" (simp: valid_refills'_def) lemma in_correct_ready_q_reprogram_timer_update[simp]: "in_correct_ready_q (reprogram_timer_update f s) = in_correct_ready_q s" by (clarsimp simp: in_correct_ready_q_def) +lemma ready_queues_runnable_reprogram_timer_update[simp]: + "ready_queues_runnable (reprogram_timer_update f s) = ready_queues_runnable s" + by (clarsimp simp: ready_queues_runnable_def) + lemma ready_qs_distinct_reprogram_timer_update[simp]: "ready_qs_distinct (reprogram_timer_update f s) = ready_qs_distinct s" by (clarsimp simp: ready_qs_distinct_def) lemma checkDomainTime_corres: "corres dc - (valid_tcbs and weak_valid_sched_action and active_scs_valid - and valid_ready_qs and ready_or_release and pspace_aligned and pspace_distinct + ((\s. sym_refs (state_refs_of s)) and valid_tcbs and weak_valid_sched_action + and active_scs_valid and valid_ready_qs and ready_or_release + and pspace_aligned and pspace_distinct and in_correct_ready_q and ready_qs_distinct) - (valid_tcbs' and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct' and pspace_bounded') + (valid_tcbs' and sym_heap_sched_pointers and valid_sched_pointers) check_domain_time checkDomainTime" apply (clarsimp simp: check_domain_time_def checkDomainTime_def) apply (rule corres_guard_imp) @@ -4266,6 +4168,7 @@ lemma checkDomainTime_corres: apply (rule rescheduleRequired_corres) apply (wpsimp wp: hoare_drop_imps simp: isCurDomainExpired_def)+ + apply fastforce+ done crunch refill_budget_check_round_robin @@ -4346,11 +4249,15 @@ crunch ifCondRefillUnblockCheck (simp: crunch_simps) lemma switchSchedContext_corres: - "corres dc (\s. valid_state s \ cur_tcb s \ sc_at (cur_sc s) s \ active_scs_valid s - \ current_time_bounded s \ active_sc_tcb_at (cur_thread s) s) - valid_objs' - switch_sched_context - switchSchedContext" + "corres dc + (\s. valid_state s \ cur_tcb s \ sc_at (cur_sc s) s \ active_scs_valid s + \ current_time_bounded s \ active_sc_tcb_at (cur_thread s) s) + valid_objs' + switch_sched_context switchSchedContext" + apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) + apply (fastforce dest: pspace_aligned_cross simp: valid_state_def valid_pspace_def) + apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) + apply (fastforce dest: pspace_distinct_cross simp: valid_state_def valid_pspace_def) apply (clarsimp simp: valid_state_def) apply add_cur_tcb' apply (clarsimp simp: switch_sched_context_def switchSchedContext_def) @@ -4394,10 +4301,10 @@ lemma switchSchedContext_corres: apply (rule corres_split_skip; (solves \wpsimp wp: hoare_vcg_ex_lift\)?) apply (corresKsimp corres: setReprogramTimer_corres) apply (corresKsimp corres: ifCondRefillUnblockCheck_corres) - apply (fastforce intro: valid_objs'_valid_refills' sc_at_cross is_active_sc'2_cross + apply (fastforce intro: valid_objs'_valid_refills' is_active_sc'_cross sc_at_cross valid_sched_context_size_objsI simp: obj_at_def pred_tcb_at_def vs_all_heap_simps is_sc_obj_def opt_map_red - opt_pred_def) + opt_pred_def is_active_sc2_def active_sc_def) apply (rule corres_split_skip; (solves wpsimp)?) apply (corresKsimp corres: getReprogramTimer_corres) apply (rule_tac Q="\\" and Q'="\\" and r'=dc in corres_underlying_split; (solves wpsimp)?) @@ -4460,19 +4367,19 @@ crunch setQueue, addToBitmap (simp: bitmap_fun_defs schedulable'_def active_sc_tcb_at'_def) lemma tcbQueued_update_schedulable'[wp]: - "threadSet (tcbQueued_update f) tcbPtr \schedulable' tcbPtr'\" + "threadSet (tcbQueued_update f) tcbPtr \\s. P (schedulable' tcbPtr' s)\" by (fastforce intro: threadSet_schedulable'_fields_inv) lemma tcbSchedPrev_update_schedulable'[wp]: - "threadSet (tcbSchedPrev_update f) tcbPtr \schedulable' tcbPtr'\" + "threadSet (tcbSchedPrev_update f) tcbPtr \\s. P (schedulable' tcbPtr' s)\" by (fastforce intro: threadSet_schedulable'_fields_inv) lemma tcbSchedNext_update_schedulable'[wp]: - "threadSet (tcbSchedNext_update f) tcbPtr \schedulable' tcbPtr'\" + "threadSet (tcbSchedNext_update f) tcbPtr \\s. P (schedulable' tcbPtr' s)\" by (fastforce intro: threadSet_schedulable'_fields_inv) lemma tcbSchedEnqueue_schedulable'[wp]: - "tcbSchedEnqueue tcbPtr \schedulable' tcbPtr'\" + "tcbSchedEnqueue tcbPtr \\s. P (schedulable' tcbPtr' s)\" unfolding tcbSchedEnqueue_def tcbQueuePrepend_def by (wpsimp wp: threadSet_schedulable' hoare_vcg_if_lift2 hoare_drop_imps) @@ -4510,9 +4417,17 @@ defs valid_domain_list'_asrt_def: declare valid_domain_list'_asrt_def[simp] -crunch awaken, checkDomainTime - for valid_idle'[wp]: valid_idle' - (wp: crunch_wps) +lemma runnable'_Not_tcbInReleaseQueue_not_sched_linked: + "\(runnable' |< tcbStates_of' s) t; \ (tcbInReleaseQueue |< tcbs_of' s) t; + valid_sched_pointers s\ + \ \ (tcbQueued |< tcbs_of' s) t \ \ is_sched_linked t s" + apply clarsimp + apply (frule (1) valid_sched_pointersD) + apply (clarsimp simp: schedulable'_def in_opt_pred) + apply (clarsimp simp: schedulable'_def in_opt_pred opt_map_def split: option.splits) + apply (rename_tac tcb, case_tac "tcbState tcb"; clarsimp) + apply fastforce + done lemma schedule_corres: "corres dc @@ -4536,20 +4451,21 @@ lemma schedule_corres: apply (wpsimp wp: schedule_invs' schedule_ct_activateable) apply wpsimp apply (subst bind_assoc)+ - apply add_cur_tcb' - apply add_valid_idle' apply (clarsimp simp: Schedule_A.schedule_def schedule_def sch_act_wf_asrt_def) - apply (rule corres_stateAssert_ignore, simp)+ + apply (rule corres_stateAssert_ignore) + apply (fastforce intro: valid_idle'_cross) + apply (rule corres_stateAssert_ignore) apply (fastforce intro: valid_domain_list_cross) - apply (rule corres_stateAssert_ignore, simp)+ - apply (fastforce elim!: sch_act_wf_cross) - apply (rule corres_stateAssert_add_assertion[rotated], simp)+ + apply (rule corres_stateAssert_ignore) + apply (fastforce intro: sch_act_wf_cross) + apply (rule corres_stateAssert_ignore) + apply (fastforce intro: cur_tcb_cross) apply (rule corres_split_skip) apply (wpsimp wp: awaken_valid_sched hoare_vcg_imp_lift') apply fastforce apply (wpsimp wp: awaken_invs') apply (corresKsimp corres: awaken_corres) - apply (fastforce dest: valid_sched_valid_ready_qs simp: invs_def valid_state_def) + apply (fastforce dest: invs_sym_refs valid_sched_valid_ready_qs simp: invs_def valid_state_def) apply (rule corres_split_skip) apply (wpsimp wp: hoare_vcg_imp_lift' cur_sc_active_lift) apply wpsimp @@ -4579,9 +4495,10 @@ lemma schedule_corres: apply (case_tac "action = choose_new_thread") apply (clarsimp simp: bind_assoc) - apply (rule corres_symb_exec_r[OF _ getSchedulable_sp, rotated]; (solves wpsimp)?) - apply wpsimp - apply (clarsimp simp: cur_tcb'_def) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ getSchedulable_sp, rotated]; + (solves wpsimp)?) + apply (wpsimp wp: no_fail_getSchedulable) + apply (force intro!: tcb_at_cross dest: invs_cur simp: ex_abs_def cur_tcb_def) apply (rename_tac isSchedulable) apply (rule_tac F="ct_schdble = isSchedulable" in corres_req) apply (fastforce dest: schedulable_schedulable'_eq) @@ -4599,7 +4516,9 @@ lemma schedule_corres: | rule_tac f=cur_thread in hoare_lift_Pf2)+)[1] apply (wpsimp wp: scheduleChooseNewThread_invs') apply (wpsimp | wps)+ - apply (fastforce elim: ct_released_from_ct_ready_if_schedulable intro!: cur_sc_tcb_sc_at_cur_sc + apply (fastforce elim: ct_released_from_ct_ready_if_schedulable + dest: invs_sym_refs + intro!: cur_sc_tcb_sc_at_cur_sc simp: schedulable_def2) apply fastforce @@ -4630,9 +4549,10 @@ lemma schedule_corres: simp: isHighestPrio_def scheduleSwitchThreadFastfail_def) apply (rename_tac candidate) - apply (rule corres_symb_exec_r[OF _ getSchedulable_sp, rotated]; (solves wpsimp)?) - apply wpsimp - apply (clarsimp simp: cur_tcb'_def) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ getSchedulable_sp, rotated]; + (solves wpsimp)?) + apply (wpsimp wp: no_fail_getSchedulable) + apply (force intro!: tcb_at_cross dest: invs_cur simp: ex_abs_def cur_tcb_def) apply (rename_tac isSchedulable) apply (rule_tac F="isSchedulable = ct_schdble" in corres_req) apply (fastforce dest: schedulable_schedulable'_eq) @@ -4643,13 +4563,9 @@ lemma schedule_corres: by (clarsimp simp: schedulable_def3 pred_tcb_at_def obj_at_def valid_sched_def ct_ready_if_schedulable_def vs_all_heap_simps) apply wpsimp - apply (clarsimp simp: invs'_def valid_pspace'_def schedulable'_def st_tcb_at'_def pred_map_simps - obj_at_simps vs_all_heap_simps cur_tcb'_def - elim!: opt_mapE) + apply (clarsimp simp: when_def) apply (corresKsimp corres: tcbSchedEnqueue_corres) - apply (intro conjI impI allI; fastforce?) - apply (clarsimp simp: cur_tcb_def schedulable_def2 not_in_release_q_def) - apply (clarsimp simp: cur_tcb_def schedulable_def2 not_in_release_q_def) + apply (intro conjI impI allI; fastforce dest!: invs_sym_refs simp: schedulable_def2) apply (rule corres_underlying_split[rotated 2, OF gets_sp getIdleThread_sp]) apply corresKsimp apply (rule corres_underlying_split[rotated 2, OF thread_get_sp threadGet_sp, where r'="(=)"]) @@ -4667,7 +4583,7 @@ lemma schedule_corres: apply (rule_tac Q="\_ s. invs s \ valid_ready_qs s \ ready_or_release s \ pred_map runnable (tcb_sts_of s) candidate \ released_sc_tcb_at candidate s \ not_in_release_q candidate s" - and Q'="\_ s. invs' s \ cur_tcb' s \ curThread = ksCurThread s" + and Q'="\_ s. invs' s \ curThread = ksCurThread s" and r'="\rv rv'. curThread \ it \ rv' = rv" in corres_underlying_split) apply (case_tac "curThread \ it"; clarsimp) @@ -4676,9 +4592,10 @@ lemma schedule_corres: apply fastforce apply fastforce apply (rule corres_bind_return2) - apply (rule corres_symb_exec_r) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ threadGet_sp, rotated]) apply wpsimp+ - apply (fastforce simp: cur_tcb'_def) + apply (force intro!: tcb_at_cross dest: invs_cur simp: ex_abs_def cur_tcb_def) + apply fastforce apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) apply (wpsimp wp: thread_get_wp) apply (clarsimp simp: valid_sched_def valid_sched_action_def weak_valid_sched_action_def @@ -4720,27 +4637,35 @@ lemma schedule_corres: apply fastforce apply (rule corres_if_split; (solves simp)?) - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) apply clarsimp apply (rule corres_split[OF setSchedulerAction_corres]) apply (clarsimp simp: sched_act_relation_def) apply (rule scheduleChooseNewThread_corres) apply wpsimp+ - apply (fastforce simp: obj_at_def vs_all_heap_simps is_tcb_def pred_tcb_at_def) - apply fastforce + apply (fastforce dest: invs_sym_refs + simp: obj_at_def vs_all_heap_simps is_tcb_def pred_tcb_at_def) + apply clarsimp + apply (frule invs_valid_objs') + apply (frule valid_objs'_valid_tcbs') + apply clarsimp apply (rule corres_if_split) apply fastforce - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) apply (rule corres_split[OF tcbSchedAppend_corres], simp) apply clarsimp apply (rule corres_split[OF setSchedulerAction_corres]) apply (clarsimp simp: sched_act_relation_def) apply (rule scheduleChooseNewThread_corres) apply wpsimp+ - apply (fastforce simp: obj_at_def vs_all_heap_simps is_tcb_def pred_tcb_at_def) - apply fastforce + apply (fastforce dest: invs_sym_refs + simp: obj_at_def vs_all_heap_simps is_tcb_def pred_tcb_at_def) + apply clarsimp + apply (frule invs_valid_objs') + apply (frule valid_objs'_valid_tcbs') + apply clarsimp apply (rule corres_guard_imp) apply (rule corres_split[OF guarded_switch_to_corres]) @@ -4749,8 +4674,10 @@ lemma schedule_corres: apply (clarsimp simp: sched_act_relation_def) apply wpsimp apply wpsimp - apply (clarsimp simp: pred_conj_def) - apply (fastforce simp: obj_at_def vs_all_heap_simps pred_tcb_at_def schedulable_def3) + apply clarsimp + subgoal + by (fastforce dest: invs_sym_refs + simp: obj_at_def vs_all_heap_simps pred_tcb_at_def schedulable_def3) apply fastforce done @@ -4794,7 +4721,6 @@ crunch schedContextDonate and valid_irq_states'[wp]: "\s. valid_irq_states' s" and valid_machine_state'[wp]: "\s. valid_machine_state' s" and pspace_domain_valid[wp]: "\s. pspace_domain_valid s" - and cur_tcb'[wp]: "cur_tcb'" and valid_dom_schedule'[wp]: valid_dom_schedule' and reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" and valid_replies' [wp]: valid_replies' @@ -4805,34 +4731,10 @@ crunch schedContextDonate and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" (simp: comp_def crunch_simps update_tcb_cte_cases - wp: threadSet_not_inQ hoare_vcg_imp_lift' valid_irq_node_lift + wp: hoare_vcg_imp_lift' valid_irq_node_lift threadSet_ifunsafe'T threadSet_cur crunch_wps cur_tcb_lift valid_dom_schedule'_lift valid_replies'_lift irqs_masked_lift) -lemma schedContextDonate_valid_pspace': - "\valid_pspace' and tcb_at' tcbPtr and sym_heap_sched_pointers and valid_sched_pointers\ - schedContextDonate scPtr tcbPtr - \\_. valid_pspace'\" - by (wpsimp wp: schedContextDonate_valid_objs' simp: valid_pspace'_def) - -crunch setQueue, setSchedContext - for valid_sched_pointers[wp]: valid_sched_pointers - and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - (wp: threadSet_sched_pointers) - -lemma schedContextDonate_if_live_then_nonz_cap': - "\\s. if_live_then_nonz_cap' s \ valid_objs' s \ sym_heap_sched_pointers s - \ ex_nonz_cap_to' tcbPtr s \ ex_nonz_cap_to' scPtr s - \ valid_sched_pointers s - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ - schedContextDonate scPtr tcbPtr - \\_. if_live_then_nonz_cap'\" - unfolding schedContextDonate_def updateSchedContext_def - by (wpsimp wp: RISCV64.threadSet_iflive'T setSchedContext_iflive' hoare_vcg_all_lift threadSet_cap_to' - simp: conj_ac cong: conj_cong (*FIXME arch-split RT*) - | wp hoare_drop_imps - | fastforce simp: update_tcb_cte_cases)+ - crunch schedContextDonate for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers and valid_sched_pointers[wp]: valid_sched_pointers @@ -4841,12 +4743,11 @@ crunch schedContextDonate simp: crunch_simps) lemma schedContextDonate_invs': - "\\s. invs' s \ bound_sc_tcb_at' ((=) None) tcbPtr s \ - ex_nonz_cap_to' scPtr s \ ex_nonz_cap_to' tcbPtr s\ + "\invs' and tcb_at' tcbPtr\ schedContextDonate scPtr tcbPtr \\_. invs'\" apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) - apply (wpsimp wp: schedContextDonate_valid_objs' schedContextDonate_if_live_then_nonz_cap') + apply (wpsimp wp: schedContextDonate_valid_objs') done lemma setQueue_valid_tcbs'[wp]: @@ -4860,10 +4761,6 @@ lemma schedContextDonate_corres_helper: (when (t = cur \ (case rv' of SwitchToThread x \ t = x | _ \ False)) rescheduleRequired)" by (case_tac rv'; clarsimp simp: when_def) -crunch tcbReleaseRemove - for valid_tcbs'[wp]: valid_tcbs' - (wp: crunch_wps) - lemma thread_set_not_in_valid_ready_qs: "\valid_ready_qs and not_queued tcb_ptr\ thread_set f tcb_ptr \\_. valid_ready_qs\" apply (wpsimp wp: thread_set_wp) @@ -4881,6 +4778,22 @@ lemma thread_set_in_correct_ready_q: split: option.splits) done +lemma thread_set_ep_queues_blocked: + "(\tcb. tcb_state (f tcb) = tcb_state tcb) \ thread_set f tptr \ep_queues_blocked\" + by (wpsimp wp: ep_queues_blocked_lift thread_set_no_change_tcb_state)+ + +lemma thread_set_ntfn_queues_blocked: + "(\tcb. tcb_state (f tcb) = tcb_state tcb) \ thread_set f tptr \ntfn_queues_blocked\" + by (wpsimp wp: ntfn_queues_blocked_lift thread_set_no_change_tcb_state)+ + +lemma thread_set_ready_queues_runnable: + "(\tcb. tcb_state (f tcb) = tcb_state tcb) \ thread_set f tptr \ready_queues_runnable\" + by (wpsimp wp: ready_queues_runnable_lift thread_set_no_change_tcb_state) + +lemma thread_set_release_q_runnable: + "(\tcb. tcb_state (f tcb) = tcb_state tcb) \ thread_set f tptr \release_q_runnable\" + by (wpsimp wp: release_q_runnable_lift thread_set_no_change_tcb_state) + lemma tcb_sched_dequeue_in_correct_ready_q[wp]: "tcb_sched_action tcb_sched_dequeue t \in_correct_ready_q\ " unfolding tcb_sched_action_def set_tcb_queue_def @@ -4900,12 +4813,26 @@ lemma thread_set_ready_qs_distinct[wp]: apply (wpsimp wp: thread_set_wp) by (clarsimp simp: ready_qs_distinct_def) +crunch tcb_sched_action + for ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + and release_q_runnable[wp]: release_q_runnable + (rule: release_q_runnable_lift) + +lemma tcb_sched_dequeue_ready_queues_runnable[wp]: + "tcb_sched_action tcb_sched_dequeue t \ready_queues_runnable\" + unfolding tcb_sched_dequeue_def tcb_sched_action_def set_tcb_queue_def + apply (wpsimp wp: thread_get_wp') + apply (clarsimp simp: ready_queues_runnable_def st_tcb_at_def obj_at_def) + done + lemma schedContextDonate_corres: "corres dc (sc_at scp and tcb_at thread and weak_valid_sched_action and pspace_aligned and pspace_distinct and valid_objs and active_scs_valid - and in_correct_ready_q and ready_qs_distinct and ready_or_release - and (\s. distinct (release_queue s))) + and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable and ready_or_release + and (\s. distinct (release_queue s)) and release_q_runnable + and ep_queues_blocked and ntfn_queues_blocked) (valid_objs' and sym_heap_sched_pointers and valid_sched_pointers and pspace_aligned' and pspace_distinct') (sched_context_donate scp thread) (schedContextDonate scp thread)" @@ -4947,7 +4874,8 @@ lemma schedContextDonate_corres: apply wpsimp apply wpsimp apply ((wpsimp wp: hoare_drop_imps thread_set_not_in_valid_ready_qs - thread_set_in_correct_ready_q + thread_set_in_correct_ready_q thread_set_ep_queues_blocked + thread_set_ntfn_queues_blocked thread_set_ready_queues_runnable | drule Some_to_the)+)[1] apply (wpsimp wp: hoare_drop_imps threadSet_sched_pointers threadSet_valid_sched_pointers) apply ((wpsimp | strengthen weak_valid_sched_action_strg | drule Some_to_the)+)[1] @@ -4968,8 +4896,8 @@ lemma schedContextDonate_corres: apply clarsimp apply (rule threadset_corresT) apply (clarsimp simp: tcb_relation_def) - apply (fastforce simp: tcb_cap_cases_def) - apply (fastforce simp: update_tcb_cte_cases) + apply (fastforce simp: tcb_cap_cases_def update_tcb_cte_cases) + apply (fastforce simp: tcb_cte_cases_def update_tcb_cte_cases) apply wpsimp apply wpsimp apply (fastforce simp: inQ_def) @@ -4977,7 +4905,7 @@ lemma schedContextDonate_corres: apply (wpsimp wp: hoare_drop_imp)+ apply (frule (1) valid_objs_ko_at) apply (fastforce simp: valid_obj_def valid_sched_context_def valid_bound_obj_def obj_at_def) - apply (fastforce elim: sc_at_cross tcb_at_cross simp: state_relation_def) + apply fastforce done end diff --git a/proof/refine/RISCV64/Syscall_R.thy b/proof/refine/RISCV64/Syscall_R.thy index 7fd5dc05a8..0cc181f49c 100644 --- a/proof/refine/RISCV64/Syscall_R.thy +++ b/proof/refine/RISCV64/Syscall_R.thy @@ -253,7 +253,7 @@ lemma hinv_corres_assist: extracaps extracapsa)) (invs and tcb_at thread and (\_. valid_message_info info)) - (invs' and tcb_at' thread) + invs' (doE (cap, slot) \ cap_fault_on_failure cptr' False (lookup_cap_and_slot thread (to_bl cptr')); @@ -271,6 +271,7 @@ lemma hinv_corres_assist: odE od odE)" + apply (rule_tac Q'="tcb_at' thread" in corres_cross_add_guard, fastforce intro!: tcb_at_cross) apply (clarsimp simp add: split_def) apply (rule corres_guard_imp) apply (rule corres_splitEE[OF corres_cap_fault]) @@ -330,26 +331,6 @@ lemma setObject_F_st_tcb_at': lemmas setObject_tcbDomain_update_st_tcb_at'[wp] = setObject_F_st_tcb_at'[where F="tcbDomain_update", simplified] -lemma threadSet_tcbDomain_update_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s \ sch_act_not t s\ - threadSet (tcbDomain_update (\_. domain)) t - \\_ s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: sch_act_wf_cases split: scheduler_action.split) - apply (wp hoare_vcg_conj_lift) - apply (simp add: threadSet_def) - apply wp - apply (wps set_tcb'.ksSchedulerAction) - apply (wp hoare_weak_lift_imp getObject_tcb_wp hoare_vcg_all_lift)+ - apply (rename_tac word) - apply (rule_tac Q'="\_ s. ksSchedulerAction s = SwitchToThread word \ - st_tcb_at' runnable' word s \ tcb_in_cur_domain' word s \ word \ t" - in hoare_strengthen_post) - apply (wp hoare_vcg_all_lift hoare_vcg_conj_lift hoare_vcg_imp_lift)+ - apply (simp add: threadSet_def) - apply (wp getObject_tcb_wp threadSet_tcbDomain_triv')+ - apply (auto simp: obj_at'_def) - done - lemma tcb_sched_action_schedulable_bool[wp]: "tcb_sched_action f t \\s. P (schedulable t' s)\" apply (wpsimp simp: tcb_sched_action_def thread_get_def wp: set_tcb_queue_wp) @@ -385,6 +366,7 @@ lemma setDomain_corres: "corres dc (valid_tcbs and pspace_aligned and pspace_distinct and weak_valid_sched_action and in_correct_ready_q and ready_qs_distinct and ready_or_release + and ep_queues_blocked and ntfn_queues_blocked and ready_queues_runnable and active_scs_valid and tcb_at tptr) (invs' and (\_. new_dom \ maxDomain)) (set_domain tptr new_dom) @@ -407,7 +389,9 @@ lemma setDomain_corres: apply (wpsimp wp: hoare_vcg_imp_lift' thread_set_valid_tcbs thread_set_weak_valid_sched_action thread_set_in_correct_ready_q_not_queued - thread_set_no_change_tcb_state thread_set_schedulable) + thread_set_no_change_tcb_state thread_set_schedulable + thread_set_ep_queues_blocked thread_set_ntfn_queues_blocked + thread_set_ready_queues_runnable) apply (wpsimp wp: hoare_vcg_imp_lift' threadSet_valid_tcbs' threadSet_sched_pointers threadSet_valid_sched_pointers threadSet_schedulable'_fields_inv) @@ -430,6 +414,9 @@ crunch arch_prepare_set_domain for valid_tcbs[wp]: valid_tcbs and in_correct_ready_q[wp]: in_correct_ready_q and ready_qs_distinct[wp]: ready_qs_distinct + and ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + and ready_queues_runnable[wp]: ready_queues_runnable (wp: crunch_wps) lemma performInvocation_corres: @@ -475,6 +462,9 @@ lemma performInvocation_corres: ct_in_state_def released_sc_tcb_at_def active_sc_tcb_at_def2) apply (intro conjI) + apply (metis runnable_eq_active[symmetric]) + apply (clarsimp simp: ct_not_in_q_def schact_is_rct_def) + apply fastforce apply fastforce apply fastforce apply (fastforce elim!: st_tcb_ex_cap) @@ -504,7 +494,7 @@ lemma performInvocation_corres: apply (rule corres_split[OF setDomain_corres]) apply (rule corres_trivial, simp) apply wpsimp+ - apply ((clarsimp | fastforce dest: valid_sched_valid_ready_qs)+)[3] + apply ((clarsimp | fastforce dest: invs_sym_refs valid_sched_valid_ready_qs)+)[3] \ \SchedContext\ apply (corres corres: invokeSchedContext_corres) \ \SchedControl\ @@ -592,6 +582,7 @@ lemma sts_mcpriority_tcb_at'[wp]: crunch setThreadState for valid_ipc_buffer_ptr'[wp]: "valid_ipc_buffer_ptr' buf" + (simp: crunch_simps wp: crunch_wps) context begin interpretation Arch . (*FIXME: arch-split*) @@ -790,7 +781,7 @@ lemma isReply_awaiting_reply': by (case_tac st, (clarsimp simp add: isReply_def isBlockedOnReply_def)+) lemma handleTimeout_invs': - "\invs' and st_tcb_at' active' tptr and ex_nonz_cap_to' tptr\ + "\invs' and st_tcb_at' active' tptr\ handleTimeout tptr timeout \\_. invs'\" unfolding handleTimeout_def @@ -806,40 +797,38 @@ crunch ifCondRefillUnblockCheck for sch_act_simple[wp]: sch_act_simple (simp: crunch_simps sch_act_simple_def) -lemma ifConfRefillUnblockCheck_ko_at'_tcb[wp]: - "ifCondRefillUnblockCheck scOpt act ast \\s. P (ko_at' (ko :: tcb) tcbPtr s)\" - unfolding ifCondRefillUnblockCheck_def refillUnblockCheck_def refillHeadOverlappingLoop_def - mergeOverlappingRefills_def updateRefillHd_def updateSchedContext_def refillPopHead_def - by (wpsimp wp: whileLoop_valid_inv hoare_drop_imps getRefillNext_wp isRoundRobin_wp) - lemma doReplyTransfer_invs'[wp]: - "\invs' and tcb_at' sender and reply_at' replyPtr\ - doReplyTransfer sender replyPtr grant - \\_. invs'\" + "doReplyTransfer sender replyPtr grant \invs'\" unfolding doReplyTransfer_def apply (wpsimp wp: handleTimeout_invs' postpone_invs' threadGet_wp hoare_vcg_all_lift hoare_drop_imp[where f="isValidTimeoutHandler _ "]) - apply (rename_tac receiver state scOpt tcb) - apply (rule_tac Q'="\_ s. invs' s \ ex_nonz_cap_to' receiver s" in hoare_post_imp) + apply (rule_tac Q'="\_. invs'" in hoare_post_imp) apply (clarsimp simp: runnable_eq_active') - apply (wpsimp wp: setThreadState_Running_invs' split_del: if_splits)+ - apply (rename_tac receiver state scOpt tcb x2a mi buf mrs restart) - apply (rule_tac Q'="\_ s. invs' s \ ex_nonz_cap_to' receiver s" in hoare_post_imp) - apply (clarsimp simp: runnable_eq_active') - apply (wpsimp wp: setThreadState_Running_invs') + apply (wpsimp wp: sts_invs') + apply (rename_tac receiver state rv scOpt rv' faultOpt tcb) + apply (rule_tac Q'="\_. invs' and (st_tcb_at' (\st. st = Inactive) receiver)" + in hoare_post_imp) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def opt_pred_def opt_map_def + split: option.splits) + apply (wpsimp wp: setThreadState_Running_invs' split_del: if_splits) + apply (rename_tac receiver state scOpt tcb x2a mi buf mrs restart) + apply (rule_tac Q'="\_. invs'" in hoare_post_imp) + apply (clarsimp simp: runnable_eq_active') + apply wpsimp apply (intro conjI) apply (wpsimp wp: setThreadState_Restart_invs') apply (wpsimp wp: sts_invs' sts_st_tcb_at'_cases) apply (rename_tac receiver state rvc scOpt rvd faultOpt tcb x2a mi buf mrs restart) apply (rule_tac Q'="\_ s. invs' s \ st_tcb_at' (Not \ is_BlockedOnReply) receiver s - \ ex_nonz_cap_to' receiver s" + \ st_tcb_at' (Not \ inIPCQueueThreadState) receiver s" in hoare_post_imp) - apply (clarsimp simp: obj_at_simps st_tcb_at'_def is_BlockedOnReply_def) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at_simps st_tcb_at'_def + is_BlockedOnReply_def) apply metis - apply (wpsimp wp: threadSet_fault_invs' threadSet_st_tcb_at2)+ + apply (wpsimp wp: threadSet_fault_invs' threadSet_st_tcb_at2) apply (wpsimp wp: replyRemove_invs' gts_wp' hoare_drop_imps)+ - by (fastforce intro: st_tcb_ex_cap'' - simp: isReply_def split: thread_state.splits) + apply (fastforce elim!: pred_tcb'_weakenE simp: isReply_def split: thread_state.splits) + done lemma ct_active_runnable' [simp]: "ct_active' s \ ct_in_state' runnable' s" @@ -868,9 +857,9 @@ lemma threadSet_tcbDomain_update_invs': apply (wp threadSet_valid_pspace'T_P) apply (simp add: tcb_cte_cases_def tcb_cte_cases_neqs)+ apply (wp valid_irq_node_lift valid_irq_handlers_lift'' threadSet_ctes_ofT - threadSet_valid_dom_schedule' threadSet_iflive'T threadSet_ifunsafe'T + threadSet_valid_dom_schedule' threadSet_ifunsafe'T untyped_ranges_zero_lift threadSet_valid_sched_pointers - sym_heap_sched_pointers_lift threadSet_tcbSchedNexts_of threadSet_tcbSchedPrevs_of + sym_heap_sched_pointers_lift threadSet_field_inv | simp add: tcb_cte_cases_def tcb_cte_cases_neqs cteCaps_of_def o_def invs'_def | intro allI)+ apply (fastforce simp: obj_at'_def opt_map_def) @@ -884,10 +873,8 @@ lemma threadSet_not_curthread_ct_domain: done lemma schedContextBindNtfn_invs': - "\invs' and ex_nonz_cap_to' scPtr and ex_nonz_cap_to' ntfnPtr\ - schedContextBindNtfn scPtr ntfnPtr - \\_. invs'\" - apply (clarsimp simp: schedContextBindNtfn_def updateSchedContext_def) + "schedContextBindNtfn scPtr ntfnPtr \invs'\" + apply (clarsimp simp: schedContextBindNtfn_def updateSchedContext_def updateNotification_def) apply (wpsimp wp: setSchedContext_invs' setNotification_invs' hoare_vcg_imp_lift' hoare_vcg_all_lift getNotification_wp) apply (rule conjI) @@ -900,17 +887,16 @@ lemma schedContextBindNtfn_invs': done lemma contextYieldToUpdateQueues_invs'_helper: - "\\s. invs' s \ sc_at' scPtr s \ valid_sched_context_size' sc - \ ex_nonz_cap_to' scPtr s \ ex_nonz_cap_to' ctPtr s \ tcb_at' ctPtr s\ + "\\s. invs' s \ tcb_at' ctPtr s\ do y \ threadSet (tcbYieldTo_update (\_. Some scPtr)) ctPtr; updateSchedContext scPtr (\sc. scYieldFrom_update (\_. Some ctPtr) sc) od \\_. invs'\" unfolding updateSchedContext_def apply (clarsimp simp: invs'_def valid_pspace'_def valid_dom_schedule'_def) - apply (wp threadSet_valid_objs' threadSet_mdb' threadSet_iflive' threadSet_cap_to + apply (wp threadSet_valid_objs' threadSet_mdb' threadSet_cap_to threadSet_ifunsafe'T threadSet_ctes_ofT threadSet_valid_sched_pointers - sym_heap_sched_pointers_lift threadSet_tcbSchedNexts_of threadSet_tcbSchedPrevs_of + sym_heap_sched_pointers_lift threadSet_field_inv untyped_ranges_zero_lift valid_irq_node_lift valid_irq_handlers_lift'' hoare_vcg_const_imp_lift hoare_vcg_imp_lift' threadSet_valid_replies' hoare_vcg_all_lift @@ -941,8 +927,7 @@ crunch schedContextCompleteYieldTo for bound_scTCB[wp]: "obj_at' (\a. \y. scTCB a = Some y) scPtr" lemma contextYieldToUpdateQueues_invs': - "\invs' and (\s. obj_at' (\a. \y. scTCB a = Some y) scPtr s) and ct_active' - and ex_nonz_cap_to' scPtr and cur_tcb'\ + "\invs' and ct_active'\ contextYieldToUpdateQueues scPtr \\_. invs'\" apply (clarsimp simp: contextYieldToUpdateQueues_def) @@ -958,8 +943,7 @@ lemma contextYieldToUpdateQueues_invs': apply (subst bind_assoc[symmetric]) apply (rule_tac Q'="\_. invs'" in bind_wp_fwd) apply (wp contextYieldToUpdateQueues_invs'_helper) - apply (fastforce dest: sc_ko_at_valid_objs_valid_sc' - simp: cur_tcb'_def) + apply (clarsimp simp: ct_in_state'_def) apply wpsimp done @@ -971,23 +955,15 @@ crunch schedContextResume for scTCBs_of[wp]: "\s. P (scTCBs_of s)" (wp: crunch_wps threadSet_st_tcb_at2 mapM_wp_inv simp: crunch_simps) -crunch schedContextCompleteYieldTo - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" - (simp: crunch_simps tcb_cte_cases_def cteSizeBits_def wp: crunch_wps threadSet_cap_to) +crunch schedContextResume, schedContextCompleteYieldTo + for ct_in_state'[wp]: "ct_in_state' P" + (wp: crunch_wps threadSet_st_tcb_at2 setConsumed_pred_tcb_at' + simp: ct_in_state'_def crunch_simps bitmap_fun_defs ignore: setConsumed) lemma schedContextYiedTo_invs': - "\invs' and ct_active' and ex_nonz_cap_to' scPtr - and (\s. obj_at' (\sc. \t. scTCB sc = Some t) scPtr s)\ - schedContextYieldTo scPtr - \\_. invs'\" + "\invs' and ct_active'\ schedContextYieldTo scPtr \\_. invs'\" unfolding schedContextYieldTo_def returnConsumed_def - apply (wpsimp wp: contextYieldToUpdateQueues_invs' setConsumed_invs' hoare_drop_imps - simp: ct_in_state'_def - | wps)+ - apply normalise_obj_at' - apply (frule (1) invs'_ko_at_valid_sched_context') - apply (fastforce simp: valid_sched_context'_def cur_tcb'_def) - done + by (wpsimp wp: contextYieldToUpdateQueues_invs' hoare_drop_imps)+ lemma invokeSchedContext_invs': "\invs' and ct_active' and valid_sc_inv' iv\ @@ -1003,13 +979,11 @@ lemma invokeSchedContext_invs': apply (wpsimp wp: schedContextBindNtfn_invs') apply wpsimp apply wpsimp - using global'_sc_no_ex_cap apply fastforce apply (wpsimp wp: schedContextYiedTo_invs') - apply (fastforce simp: obj_at_simps) done lemma setDomain_invs': - "\invs' and tcb_at' ptr and K (domain \ maxDomain)\ + "\invs' and K (domain \ maxDomain)\ setDomain ptr domain \\_. invs'\" supply comp_apply[simp del] @@ -1017,7 +991,8 @@ lemma setDomain_invs': apply (wpsimp wp: getSchedulable_wp hoare_vcg_if_lift2) apply (rule_tac Q'="\_. invs'" in hoare_post_imp) apply fastforce - by (wpsimp wp: threadSet_tcbDomain_update_invs' tcbSchedDequeue_not_queued)+ + apply (wpsimp wp: threadSet_tcbDomain_update_invs')+ + done crunch refillNew, refillUpdate, commitTime for pred_tcb_at''[wp]: "\s. Q (pred_tcb_at' proj P tcbPtr s)" @@ -1028,15 +1003,13 @@ crunch refillNew, refillUpdate, commitTime lemma scSBadge_update_invs'[wp]: "updateSchedContext scPtr (scBadge_update f) \invs'\" apply (wpsimp wp: updateSchedContext_invs') - apply (fastforce elim!: live_sc'_ko_ex_nonz_cap_to' dest: invs'_ko_at_valid_sched_context' - simp: live_sc'_def) + apply (fastforce dest: invs'_ko_at_valid_sched_context') done lemma scSporadic_update_invs'[wp]: "updateSchedContext scPtr (scSporadic_update f) \invs'\" apply (wpsimp wp: updateSchedContext_invs') - apply (fastforce elim!: live_sc'_ko_ex_nonz_cap_to' dest: invs'_ko_at_valid_sched_context' - simp: live_sc'_def) + apply (fastforce dest: invs'_ko_at_valid_sched_context') done lemma invokeSchedControlConfigureFlags_invs': @@ -1064,15 +1037,18 @@ crunch prepareSetDomain lemma performInv_invs'[wp]: "\invs' and ct_active' and valid_invocation' i - and (\s. can_donate \ bound_sc_tcb_at' bound (ksCurThread s) s)\ + and (\s. can_donate \ bound_sc_tcb_at' bound (ksCurThread s) s) + and (\s. ksSchedulerAction s = ResumeCurrentThread)\ performInvocation block call can_donate i \\_. invs'\" apply (clarsimp simp: performInvocation_def) - apply (cases i; clarsimp) - by (clarsimp simp: stateAssertE_def sym_refs_asrt_def ct_in_state'_def sch_act_simple_def - | wp tcbinv_invs' arch_performInvocation_invs' setDomain_invs' stateAssertE_inv - stateAssertE_wp invokeSchedControlConfigureFlags_invs' invokeSchedContext_invs' - | erule active_ex_cap'[simplified ct_in_state'_def])+ + apply (cases i) + apply (clarsimp simp: stateAssertE_def ct_in_state'_def runnable_eq_active' + | wp tcbinv_invs' arch_performInvocation_invs' setDomain_invs' + invokeSchedControlConfigureFlags_invs' invokeSchedContext_invs' + | erule active_ex_cap'[simplified ct_in_state'_def] + | fastforce simp: sch_act_simple_def)+ + done lemma getSlotCap_to_refs[wp]: "\\\ getSlotCap ref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\" @@ -1242,6 +1218,10 @@ crunch replyFromKernel for valid_objs'[wp]: valid_objs' (simp: crunch_simps wp: crunch_wps) +lemma active_not_halted: + "active st \ \ halted st" + by (cases st; clarsimp) + (* Note: the preconditions on the abstract side are based on those of performInvocation_corres. *) lemma handleInvocation_corres: "call \ blocking \ @@ -1257,7 +1237,8 @@ lemma handleInvocation_corres: (handleInvocation call blocking can_donate first_phase cptr')" supply opt_mapE[elim!] apply add_cur_tcb' - apply add_ct_not_inQ + apply (rule_tac Q'=ct_not_inQ in corres_cross_add_guard) + apply (fastforce intro!: ct_not_inQ_cross) apply add_valid_idle' apply add_sym_refs apply (rule_tac Q'="\s'. bound_sc_tcb_at' bound (ksCurThread s') s'" in corres_cross_add_guard) @@ -1325,15 +1306,15 @@ lemma handleInvocation_corres: apply (wp sts_st_tcb_at' set_thread_state_simple_sched_action sts_sym_refs' set_thread_state_active_valid_sched set_thread_state_schact_is_rct_strong) apply (rule_tac Q'="\_. invs' and (\s. sym_refs (state_refs_of' s)) - and ct_not_inQ and valid_invocation' rve' - and (\s. thread = ksCurThread s) - and st_tcb_at' active' thread - and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. bound_sc_tcb_at' bound (ksCurThread s) s)" - in hoare_post_imp) + and valid_invocation' rve' + and (\s. thread = ksCurThread s) + and st_tcb_at' active' thread + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and (\s. bound_sc_tcb_at' bound (ksCurThread s) s)" + in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) apply ((wpsimp wp: sts_sym_refs' setThreadState_nonqueued_state_update setThreadState_st_tcb - setThreadState_rct setThreadState_ct_not_inQ sts_bound_sc_tcb_at' + setThreadState_rct sts_bound_sc_tcb_at' | wps)+)[1] apply clarsimp apply (wp | simp add: split_def liftE_bindE[symmetric] @@ -1351,9 +1332,13 @@ lemma handleInvocation_corres: apply (frule valid_objs_valid_tcbs) apply (clarsimp simp: invs_def cur_tcb_def valid_state_def current_time_bounded_def valid_sched_def valid_pspace_def ct_in_state_def simple_from_active) + apply (clarsimp cong: conj_cong) apply (frule valid_release_q_distinct) + apply (intro conjI) + apply (metis runnable_eq_active[symmetric]) + apply (clarsimp simp: ct_not_in_q_def schact_is_rct_def) apply (erule st_tcb_ex_cap, clarsimp+) - apply (case_tac st; clarsimp) + apply (fast dest!: active_not_halted) apply (clarsimp cong: conj_cong) apply (frule curthread_relation) apply (prop_tac "ct_schedulable s") @@ -1363,13 +1348,12 @@ lemma handleInvocation_corres: apply (frule ct_active_cross, fastforce, fastforce, simp) apply (clarsimp simp: ct_in_state'_def cong: conj_cong) apply (frule pred_tcb'_weakenE [where P=active' and P'=simple'], clarsimp) - apply (frule(1) st_tcb_ex_cap'', fastforce) apply (clarsimp simp: valid_pspace'_def schact_is_rct_def) apply (frule state_relation_sched_act_relation, simp) apply (subgoal_tac "schedulable' (ksCurThread s') s'") apply (clarsimp simp: schedulable'_def pred_map_conj[simplified pred_conj_def]) apply (frule active'_st_tcb_at_state_refs_ofD') - apply (clarsimp simp: pred_tcb_at'_def) + apply (clarsimp simp: opt_pred_def opt_map_red pred_tcb_at'_def obj_at'_def) apply (force intro!: schedulable_schedulable'_eq[THEN iffD1] schedulable_imp_tcb_at) done @@ -1402,7 +1386,7 @@ lemma rfk_ksQ[wp]: done lemma hinv_invs'[wp]: - "\invs' and cur_tcb' + "\invs' and (\s. schedulable' (ksCurThread s) s) and (\s. ksSchedulerAction s = ResumeCurrentThread)\ handleInvocation calling blocking can_donate first_phase cptr @@ -1413,15 +1397,12 @@ lemma hinv_invs'[wp]: apply (intro bindE_wp[OF _ stateAssertE_sp]) apply (wp syscall_valid' setThreadState_nonqueued_state_update rfk_invs' hoare_vcg_all_lift hoare_weak_lift_imp) - apply simp - apply (intro conjI impI) - apply (wp gts_imp' | simp)+ + apply (wp gts_imp' | simp)+ apply (rule_tac Q'="\rv. invs'" in hoare_strengthen_postE_R[rotated]) apply clarsimp apply (fastforce elim!: pred_tcb'_weakenE st_tcb_ex_cap'') apply wp+ - apply (rule_tac Q'="\_. invs' and cur_tcb' - and ct_not_inQ + apply (rule_tac Q'="\_. invs' and valid_invocation' rv and (\s. ksSchedulerAction s = ResumeCurrentThread) and (\s. ksCurThread s = thread) @@ -1430,7 +1411,7 @@ lemma hinv_invs'[wp]: in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) apply (wpsimp wp: sts_invs_minor' sts_sym_refs' setThreadState_st_tcb setThreadState_rct - setThreadState_ct_not_inQ hoare_vcg_imp_lift' + hoare_vcg_imp_lift' | wps)+ by (fastforce simp: ct_in_state'_def simple_sane_strg sch_act_simple_def pred_map_simps obj_at_simps pred_tcb_at'_def st_tcb_at'_def schedulable'_def @@ -1452,13 +1433,14 @@ lemma getCapReg_corres: lemma handleSend_corres: "corres (dc \ dc) - (einvs and valid_machine_time and schact_is_rct and ct_active - and ct_released and (\s. active_sc_tcb_at (cur_thread s) s) - and ct_not_in_release_q and cur_sc_active and current_time_bounded - and consumed_time_bounded and (\s. cur_sc_offset_ready (consumed_time s) s) - and (\s. cur_sc_offset_sufficient (consumed_time s) s)) - (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_active') - (handle_send blocking) (handleSend blocking)" + (einvs and valid_machine_time and schact_is_rct and ct_active + and ct_released and (\s. active_sc_tcb_at (cur_thread s) s) + and ct_not_in_release_q and cur_sc_active and current_time_bounded + and consumed_time_bounded and (\s. cur_sc_offset_ready (consumed_time s) s) + and (\s. cur_sc_offset_sufficient (consumed_time s) s)) + invs' + (handle_send blocking) (handleSend blocking)" + apply (rule_tac Q'=ct_active' in corres_cross_add_guard, fastforce intro!: ct_active_cross) apply add_cur_tcb' apply (simp add: handle_send_def handleSend_def) apply (rule corres_guard_imp) @@ -1469,7 +1451,7 @@ lemma handleSend_corres: done lemma hs_invs'[wp]: - "\invs' and cur_tcb' and (\s. schedulable' (ksCurThread s) s) + "\invs' and (\s. schedulable' (ksCurThread s) s) and (\s. ksSchedulerAction s = ResumeCurrentThread)\ handleSend blocking \\_. invs'\" @@ -1497,8 +1479,9 @@ lemma getCapReg_corres_gen: lemma lookupReply_corres: "corres (fr \ cap_relation) (cur_tcb and valid_objs and pspace_aligned and pspace_distinct) - (cur_tcb' and valid_objs' and pspace_aligned' and pspace_distinct') + (valid_objs' and pspace_aligned' and pspace_distinct') lookup_reply lookupReply" + apply (rule_tac Q'=cur_tcb' in corres_cross_add_guard, fastforce intro!: cur_tcb_cross) unfolding lookup_reply_def lookupReply_def withoutFailure_def apply simp apply (rule corres_rel_imp) @@ -1550,8 +1533,8 @@ lemma lookupReply_valid [wp]: done lemma getBoundNotification_corres: - "corres (=) (ntfn_at nptr) (ntfn_at' nptr) - (get_ntfn_obj_ref ntfn_bound_tcb nptr) (liftM ntfnBoundTCB (getNotification nptr))" + "corres (=) (ntfn_at nptr and pspace_aligned and pspace_distinct) \ + (get_ntfn_obj_ref ntfn_bound_tcb nptr) (liftM ntfnBoundTCB (getNotification nptr))" apply (simp add: get_sk_obj_ref_def) apply (rule corres_bind_return2) apply (rule corres_guard_imp) @@ -1561,13 +1544,12 @@ lemma getBoundNotification_corres: done lemma handleRecv_isBlocking_corres': - "corres dc (einvs and ct_in_state active and current_time_bounded - and scheduler_act_sane and ct_not_queued and ct_not_in_release_q - and (\s. ex_nonz_cap_to (cur_thread s) s)) - (invs' and ct_in_state' simple' - and sch_act_sane - and (\s. ex_nonz_cap_to' (ksCurThread s) s)) - (handle_recv isBlocking canReply) (handleRecv isBlocking canReply)" + "corres dc + (einvs and ct_active and current_time_bounded + and scheduler_act_sane and ct_not_queued and ct_not_in_release_q + and (\s. ex_nonz_cap_to (cur_thread s) s)) + (invs' and ct_in_state' simple' and sch_act_sane) + (handle_recv isBlocking canReply) (handleRecv isBlocking canReply)" (is "corres dc (?pre1) (?pre2) (handle_recv _ _) (handleRecv _ _)") unfolding handle_recv_def handleRecv_def Let_def apply add_cur_tcb' @@ -1583,7 +1565,7 @@ lemma handleRecv_isBlocking_corres': apply (rule_tac P="?pre1 and tcb_at thread and (\s. (cur_thread s) = thread ) and valid_cap rv" - and P'="?pre2 and cur_tcb' and tcb_at' thread and valid_cap' epCap" in corres_inst) + and P'="?pre2 and tcb_at' thread and valid_cap' epCap" in corres_inst) apply (clarsimp split: cap_relation_split_asm arch_cap.split_asm split del: if_split simp: lookup_failure_map_def whenE_def) apply (rename_tac rights) @@ -1619,8 +1601,10 @@ lemma handleRecv_isBlocking_corres': apply (clarsimp simp: cap_relation_def) apply (clarsimp simp: lookup_failure_map_def) apply (wpsimp wp: get_sk_obj_ref_wp getNotification_wp)+ + apply (subst runnable_eq_active)+ apply (clarsimp simp: valid_cap_def valid_sched_def valid_sched_action_def current_time_bounded_def ct_in_state_def) + apply fastforce apply (clarsimp simp: valid_cap_def valid_cap'_def dest!: state_relationD) apply (clarsimp simp: lookup_failure_map_def) apply wpsimp+ @@ -1631,6 +1615,7 @@ lemma handleRecv_isBlocking_corres': (ExceptionTypes_A.lookup_failure.MissingCapability 0)))" and E=E and E'=E for E in hoare_strengthen_postE[rotated]) + apply (subst runnable_eq_active)+ apply (fastforce dest: valid_sched_valid_release_q simp: valid_sched_valid_sched_action valid_sched_active_scs_valid ct_in_state_def) @@ -1652,7 +1637,7 @@ lemma handleRecv_isBlocking_corres': apply (clarsimp simp: invs_def cur_tcb_def valid_state_def valid_pspace_def ct_in_state_def valid_sched_valid_sched_action valid_sched_active_scs_valid dest!: get_tcb_SomeD) - apply (fastforce elim: objs_valid_tcb_ctable) + apply (fastforce simp: runnable_eq_active elim: objs_valid_tcb_ctable) apply (clarsimp simp: invs'_def cur_tcb'_def valid_pspace'_def sch_act_sane_def ct_in_state'_def) done @@ -1666,7 +1651,6 @@ lemma handleRecv_isBlocking_corres: apply (clarsimp simp: ct_in_state_def) apply (fastforce elim!: st_tcb_weakenE st_tcb_ex_cap) apply (clarsimp simp: ct_in_state'_def invs'_def) - apply (frule(1) st_tcb_ex_cap'') apply (auto elim: pred_tcb'_weakenE) done @@ -1675,27 +1659,26 @@ lemma lookupCap_refs[wp]: by (simp add: lookupCap_def split_def | wp | simp add: o_def)+ lemma hw_invs'[wp]: - "\invs' and ct_in_state' active'\ + "\invs' and ct_in_state' runnable'\ handleRecv isBlocking canReply \\_. invs'\" - apply (simp add: handleRecv_def cong: if_cong split del: if_split) + supply if_split[split del] + apply (simp add: handleRecv_def cong: if_cong) apply (rule bind_wp[OF _ getCurThread_sp]) apply (rule bind_wp_fwd_skip, wpsimp) apply (rule catch_wp; (solves wpsimp)?) apply (rule_tac P=P and Q'="\rv. P and (\s. \r\zobj_refs' rv. ex_nonz_cap_to' r s) - and (\s. ex_nonz_cap_to' (ksCurThread s) s) - and (\s. st_tcb_at' active' (ksCurThread s) s)" + and (\s. st_tcb_at' runnable' (ksCurThread s) s)" for P in bindE_wp_fwd) apply wpsimp apply (fastforce simp: ct_in_state'_def) apply (rename_tac epCap) - apply (case_tac epCap; clarsimp split del: if_split; (wpsimp; fail)?) + apply (case_tac epCap; clarsimp; (wpsimp; fail)?) apply (rename_tac readright; case_tac readright; (wp getNotification_wp |simp)+) - apply (clarsimp simp: obj_at_simps isNotificationCap_def) - by (wpsimp simp: lookupReply_def getCapReg_def - | wp (once) hoare_drop_imps)+ - (clarsimp simp: obj_at_simps ct_in_state'_def pred_tcb_at'_def) + apply wpsimp + apply (clarsimp simp: runnable_eq_active') + done lemma setSchedulerAction_obj_at'[wp]: "\obj_at' P p\ setSchedulerAction sa \\rv. obj_at' P p\" @@ -1732,10 +1715,7 @@ lemma endTimeslice_corres: (* called when ct_schedulable *) dest: valid_sched_context_size_objsI) apply (rule_tac Q'="\s. is_active_sc' (ksCurSc s) s" in corres_cross_add_guard) apply (prop_tac "cur_sc s = ksCurSc s'", clarsimp dest!: state_relationD) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply (fastforce dest: valid_sched_context_size_objsI elim!: is_active_sc'2_cross - simp: invs_def valid_state_def valid_pspace_def cur_sc_tcb_def sc_tcb_sc_at_def - obj_at_def is_sc_obj) + apply (fastforce intro: is_active_sc'_cross simp: is_active_sc_rewrite) apply add_cur_tcb' apply (rule corres_stateAssert_add_assertion[rotated], simp) apply (rule corres_guard_imp) @@ -1771,9 +1751,10 @@ lemma endTimeslice_corres: (* called when ct_schedulable *) apply (frule cur_sc_tcb_sc_at_cur_sc) apply fastforce apply (clarsimp cong: conj_cong) - apply (intro conjI impI allI; clarsimp) - apply (clarsimp simp: ct_in_state_def) - apply (fastforce simp: get_tcb_timeout_handler_ptr_def cte_wp_at_cases) + apply (frule invs_sym_refs) + apply (intro conjI impI allI; fastforce?) + apply (fastforce simp: ct_in_state_def runnable_eq_active) + apply (fastforce simp: runnable_eq_active get_tcb_timeout_handler_ptr_def cte_wp_at_cases) apply (clarsimp simp: valid_fault_def) apply (clarsimp simp: ct_in_state_def runnable_eq_active) subgoal @@ -1821,22 +1802,6 @@ lemma end_timeslice_valid_sched_action: apply (clarsimp simp: pred_map_simps) done -lemma sendFaultIPC_invs': - "\invs' and valid_idle' and st_tcb_at' active' t - and (\s. canDonate \ bound_sc_tcb_at' bound t s) - and ex_nonz_cap_to' t - and (\s. \n\dom tcb_cte_cases. \cte. cte_wp_at' (\cte. cteCap cte = cap) (t + n) s)\ - sendFaultIPC t cap f canDonate - \\_. invs'\" - apply (simp add: sendFaultIPC_def) - apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state - threadSet_cap_to' threadSet_idle' - | wpc | simp)+ - apply (intro conjI impI allI; (fastforce simp: inQ_def)?) - apply (clarsimp simp: invs'_def obj_at'_def) - apply (fastforce simp: ex_nonz_cap_to'_def cte_wp_at'_def) - done - lemma endTimeslice_invs'[wp]: "\invs' and ct_active'\ endTimeslice timeout @@ -1844,8 +1809,7 @@ lemma endTimeslice_invs'[wp]: unfolding endTimeslice_def apply (wpsimp wp: handleTimeout_invs' isValidTimeoutHandler_inv hoare_drop_imp refillReady_wp) - apply (frule (1) active_ex_cap'[OF _ invs_iflive']) - apply (clarsimp simp: ct_in_state'_def sch_act_sane_def) + apply (clarsimp simp: ct_in_state'_def) done crunch setConsumedTime, updateSchedContext @@ -1885,10 +1849,6 @@ lemmas refill_reset_rr_typ_ats [wp] = crunch refillResetRR for ksCurSc[wp]: "\s. P (ksCurSc s)" -crunch setConsumedTime, refillResetRR - for cur_tcb'[wp]: cur_tcb' - (simp: cur_tcb'_def) - crunch end_timeslice for in_correct_ready_q[wp]: in_correct_ready_q and ready_qs_distinct[wp]: ready_qs_distinct @@ -1922,7 +1882,8 @@ lemma chargeBudget_corres: apply (rule_tac Q'="\s. is_active_sc' (ksCurSc s) s" in corres_cross_add_guard) apply (fastforce intro: valid_objs_valid_sched_context_size simp: sc_at_pred_n_def obj_at_def is_sc_obj_def state_relation_def vs_all_heap_simps - intro: is_active_sc'2_cross) + is_active_sc_rewrite[symmetric] + intro: is_active_sc'_cross) apply (rule_tac Q="\s. sc_at (cur_sc s) s" in corres_cross_add_abs_guard) apply (fastforce intro: cur_sc_tcb_sc_at_cur_sc) apply add_cur_tcb' @@ -1935,7 +1896,7 @@ lemma chargeBudget_corres: apply (rule_tac F="idle_sc_ptr = idleSCPtr" in corres_req) apply (clarsimp simp: state_relation_def) apply (rule_tac Q="\_. ?pred" - and Q'="\_. invs' and cur_tcb'" + and Q'="\_. invs'" in corres_underlying_split) apply (clarsimp simp: when_def split del: if_split) apply (rule corres_if_split; (solves corresKsimp)?) @@ -1972,23 +1933,27 @@ lemma chargeBudget_corres: apply wpsimp 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 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) + and valid_ready_qs and ready_or_release + and sorted_ipc_queues", rotated]) + apply clarsimp + apply (frule invs_sym_refs) + apply (fastforce 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 - end_timeslice_sorted_ipc_queues) + end_timeslice_sorted_ipc_queues end_timeslice_valid_ready_qs) apply (rule hoare_strengthen_post[where Q'="\_. invs'", rotated]) apply (clarsimp simp: invs'_def valid_pspace'_def) apply wpsimp apply simp+ apply wpsimp apply (rule hoare_strengthen_post - [where Q'="\_. invs' and cur_tcb'", rotated]) - apply (clarsimp simp: invs'_def valid_pspace'_def valid_objs'_valid_tcbs' cur_tcb'_def - schedulable'_def runnable_eq_active' opt_pred_def opt_map_def - obj_at'_def pred_tcb_at'_def ct_in_state'_def + [where Q'="\_. invs'", rotated]) + apply (frule invs_valid_objs') + apply (frule valid_objs'_valid_tcbs') + apply (clarsimp simp: ct_in_state'_def st_tcb_at'_def schedulable'_def opt_pred_def opt_map_def split: option.splits) + apply (erule aligned'_distinct'_obj_at'_propI, fastforce+)[1] + apply (rename_tac tcb, case_tac "tcbState tcb"; clarsimp) apply wpsimp apply (fastforce simp: schedulable_def2 ct_in_state_def runnable_eq_active current_time_bounded_def invs_def valid_state_def valid_pspace_def cur_tcb_def @@ -2007,47 +1972,39 @@ lemma chargeBudget_corres: refill_budget_check_valid_release_q refill_budget_check_valid_ready_qs_not_queued) apply ((wpsimp wp: refill_budget_check_released_ipc_queues - | strengthen live_sc'_ex_cap[OF invs_iflive'] valid_sc_strengthen[OF invs_valid_objs'])+)[1] + | strengthen valid_sc_strengthen[OF invs_valid_objs'])+)[1] apply (wpsimp wp: hoare_vcg_disj_lift) apply (wpsimp wp: is_round_robin_wp isRoundRobin_wp)+ apply (rule conjI; clarsimp) apply (prop_tac "sc_scheduler_act_not (cur_sc s) s") - apply (clarsimp simp: vs_all_heap_simps) - apply (clarsimp simp: cur_sc_chargeable_def) - apply (rotate_tac -1) - apply (drule_tac x=t in spec) - apply (prop_tac "heap_ref_eq (cur_sc s) t (tcb_scps_of s)") - apply (clarsimp simp: vs_all_heap_simps) + apply (clarsimp simp: vs_all_heap_simps cur_sc_chargeable_def) apply (simp only: scheduler_act_not_def, rule notI) apply (drule (1) valid_sched_action_switch_thread_is_schedulable) - apply (clarsimp simp: schedulable_def3 vs_all_heap_simps) + apply (fastforce simp: schedulable_def3 vs_all_heap_simps) apply (frule ct_not_blocked_cur_sc_not_blocked, clarsimp) apply (rule conjI; clarsimp) apply (drule (1) active_scs_validE, clarsimp) apply (clarsimp simp: vs_all_heap_simps obj_at_def sc_refills_sc_at_def sc_valid_refills_def rr_valid_refills_def) - apply (clarsimp simp: vs_all_heap_simps) apply (clarsimp simp: cur_sc_chargeable_def) - apply (rotate_tac -1) + apply (drule_tac x=t in spec) + apply (clarsimp simp: valid_release_q_def) + apply (drule_tac x=t in bspec, simp add: in_queue_2_def) + apply (fastforce simp: tcb_at_kh_simps[symmetric] pred_tcb_at_def obj_at_def) + apply (clarsimp simp: vs_all_heap_simps cur_sc_chargeable_def) apply (intro conjI; clarsimp?) apply (drule_tac x=t in spec) - apply (prop_tac "heap_ref_eq (cur_sc s) t (tcb_scps_of s)") - apply (clarsimp simp: vs_all_heap_simps) apply (clarsimp simp: valid_release_q_def) apply (drule_tac x=t in bspec, simp add: in_queue_2_def) apply (fastforce simp: tcb_at_kh_simps[symmetric] pred_tcb_at_def obj_at_def) apply (drule_tac x=t in spec) - apply (prop_tac "heap_ref_eq (cur_sc s) t (tcb_scps_of s)") - apply (clarsimp simp: vs_all_heap_simps) apply (clarsimp simp: valid_ready_qs_def in_ready_q_def) apply (drule_tac x=d and y=p in spec2, clarsimp) - apply (drule_tac x=t in bspec, simp) - apply clarsimp apply (clarsimp simp: tcb_at_kh_simps[symmetric] pred_tcb_at_def obj_at_def) apply (drule_tac x=d and y=p in spec2) apply fastforce apply (wpsimp wp: updateSchedContext_invs' isRoundRobin_wp - | strengthen live_sc'_ex_cap[OF invs_iflive'] valid_sc_strengthen[OF invs_valid_objs'])+ + | strengthen valid_sc_strengthen[OF invs_valid_objs'])+ apply (clarsimp simp: active_sc_at'_rewrite) done @@ -2059,8 +2016,8 @@ lemma checkBudget_corres: (* called when ct_schedulable or in checkBudgetRestart invs' check_budget checkBudget" unfolding check_budget_def checkBudget_def - apply (rule_tac Q'="\s'. active_sc_at' (ksCurSc s') s'" in corres_cross_add_guard) - apply (fastforce intro: active_sc_at'_cross_valid_objs simp: state_relation_def) + apply (rule_tac Q'="\s'. is_active_sc' (ksCurSc s') s'" in corres_cross_add_guard) + apply (fastforce intro: is_active_sc'_cross simp: is_active_sc_rewrite state_relation_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF getCurSc_corres]) apply (rule corres_split_eqr[OF getConsumedTime_corres]) @@ -2085,6 +2042,11 @@ lemma checkBudget_corres: (* called when ct_schedulable or in checkBudgetRestart apply clarsimp done +crunch charge_budget + for pspace_aligned[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct + (simp: crunch_simps) + lemma handleYield_corres: "corres dc (einvs and ct_active and cur_sc_active and schact_is_rct and scheduler_act_sane @@ -2139,13 +2101,13 @@ lemma chargeBudget_invs'[wp]: apply (clarsimp simp: schedulable'_def obj_at'_def opt_map_def opt_pred_def ct_in_state'_def pred_tcb_at'_def runnable_eq_active') by (wpsimp wp: updateSchedContext_invs' isRoundRobin_wp - | strengthen live_sc'_ex_cap[OF invs_iflive'] valid_sc_strengthen[OF invs_valid_objs'])+ + | strengthen valid_sc_strengthen[OF invs_valid_objs'])+ lemma hy_invs': "handleYield \invs'\" apply (simp add: handleYield_def) by (wpsimp wp: updateSchedContext_invs' ct_in_state_thread_state_lift' - | strengthen live_sc'_ex_cap[OF invs_iflive'] valid_sc_strengthen[OF invs_valid_objs'])+ + | strengthen valid_sc_strengthen[OF invs_valid_objs'])+ lemma hv_invs'[wp]: "\invs' and tcb_at' t'\ handleVMFault t' vptr \\r. invs'\" apply (simp add: RISCV64_H.handleVMFault_def @@ -2188,11 +2150,10 @@ lemma handleCall_corres: and consumed_time_bounded and (\s. cur_sc_offset_ready (consumed_time s) s) and (\s. cur_sc_offset_sufficient (consumed_time s) s)) - (invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. ksSchedulerAction s = ResumeCurrentThread) and - ct_active') + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread)) handle_call handleCall" apply add_cur_tcb' + apply (rule_tac Q'=ct_active' in corres_cross_add_guard, fastforce intro!: ct_active_cross) apply (simp add: handle_call_def handleCall_def liftE_bindE handleInvocation_corres) apply (rule corres_stateAssertE_add_assertion[rotated]) apply (clarsimp simp: cur_tcb'_asrt_def) @@ -2204,7 +2165,7 @@ lemma handleCall_corres: done lemma hc_invs'[wp]: - "\invs' and cur_tcb' + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and (\s. schedulable' (ksCurThread s) s)\ handleCall @@ -2224,13 +2185,8 @@ crunch setExtraBadge, transferCaps, handleFaultReply, doIPCTransfer (wp: crunch_wps sch_act_sane_lift simp: crunch_simps) lemma handleHypervisorFault_corres: - "corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread - and (%_. valid_fault f)) - (invs' and sch_act_not thread - and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) - (handle_hypervisor_fault w fault) (handleHypervisorFault w fault)" - apply (cases fault; clarsimp simp add: handleHypervisorFault_def returnOk_def2) - done + "corres dc einvs invs' (handle_hypervisor_fault w fault) (handleHypervisorFault w fault)" + by (cases fault; clarsimp simp add: handleHypervisorFault_def returnOk_def2) lemma handleSpuriousIRQ_corres[corres]: "corres dc \ \ handle_spurious_irq handleSpuriousIRQ" @@ -2276,36 +2232,6 @@ lemma hh_inv': apply (cases t; clarsimp) done -lemma ct_not_idle': - fixes s - assumes vi: "valid_idle' s" - and cts: "ct_in_state' (\tcb. \idle' tcb) s" - shows "ksCurThread s \ ksIdleThread s" -proof - assume "ksCurThread s = ksIdleThread s" - with vi have "ct_in_state' idle' s" - unfolding ct_in_state'_def valid_idle'_def - by (clarsimp simp: pred_tcb_at'_def obj_at'_def idle_tcb'_def) - - with cts show False - unfolding ct_in_state'_def - by (fastforce dest: pred_tcb_at_conj') -qed - -lemma ct_running_not_idle'[simp]: - "\valid_idle' s; ct_running' s\ \ ksCurThread s \ ksIdleThread s" - apply (rule ct_not_idle') - apply (fastforce simp: ct_in_state'_def - elim: pred_tcb'_weakenE)+ - done - -lemma ct_active_not_idle'[simp]: - "\valid_idle' s; ct_active' s\ \ ksCurThread s \ ksIdleThread s" - apply (rule ct_not_idle') - apply (fastforce simp: ct_in_state'_def - elim: pred_tcb'_weakenE)+ - done - crunch handleFault, receiveSignal, receiveIPC, asUser for ksCurThread[wp]: "\s. P (ksCurThread s)" (wp: crunch_wps hoare_vcg_all_lift simp: crunch_simps) @@ -2330,22 +2256,18 @@ lemma checkBudgetRestart_false: crunch checkBudget for invs'[wp]: invs' - and cur_tcb'[wp]: cur_tcb' (wp: crunch_wps threadSet_cur ignore: threadSet simp: crunch_simps) lemma checkBudgetRestart_invs'[wp]: "checkBudgetRestart \invs'\" unfolding checkBudgetRestart_def - apply (rule bind_wp[OF _ stateAssert_sp]) + apply (rule bind_wp[OF _ stateAssert_inv]) apply clarsimp apply (rule bind_wp_fwd_skip, wpsimp) apply (wpsimp wp: setThreadState_Restart_invs') - apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def) - apply (intro conjI) - apply (erule ko_wp_at'_weakenE, clarsimp) - apply (drule invs_iflive') - apply (erule (1) if_live_then_nonz_capD') - by (fastforce simp: live'_def live_def ko_wp_at'_def opt_map_red is_BlockedOnReply_def)+ + apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def is_BlockedOnReply_def) + apply (rename_tac tcb, case_tac "tcbState tcb"; clarsimp) + done crunch check_budget for cur_tcb[wp]: cur_tcb @@ -2446,10 +2368,14 @@ crunch updateTimeStamp and cur_tcb'[wp]: cur_tcb' (rule: hoare_lift_Pf2[where f=ksCurThread] simp: cur_tcb'_def) -lemma schedulable'_runnableE: - "schedulable' t s \ tcb_at' t s \ st_tcb_at' runnable' t s" +lemma ksCurThread_schedulable'_ct_active': + "\schedulable' (ksCurThread s) s; invs' s\ \ ct_active' s" unfolding schedulable'_def - by (clarsimp simp: pred_tcb_at'_def obj_at'_def opt_pred_def opt_map_def) + apply (clarsimp simp: ct_in_state'_def st_tcb_at'_def schedulable'_def opt_pred_def opt_map_def + split: option.splits) + apply (erule aligned'_distinct'_obj_at'_propI, fastforce+)[1] + apply (rename_tac tcb, case_tac "tcbState tcb"; clarsimp) + done lemma handleSpuriousIRQ_invs'[wp]: "handleSpuriousIRQ \invs'\" @@ -2460,41 +2386,28 @@ crunch handleSpuriousIRQ, maybeHandleInterrupt (ignore: doMachineOp) lemma he_invs'[wp]: - "\invs' and cur_tcb' and - (\s. event \ Interrupt \ schedulable' (ksCurThread s) s) and - (\s. ksSchedulerAction s = ResumeCurrentThread)\ + "\invs' + and (\s. event \ Interrupt \ schedulable' (ksCurThread s) s) + and (\s. ksSchedulerAction s = ResumeCurrentThread)\ handleEvent event - \\rv. invs'\" -proof - - have nidle: "\s. valid_idle' s \ ct_active' s \ ksCurThread s \ ksIdleThread s" - by (clarsimp) - show ?thesis - apply (case_tac event, simp_all add: handleEvent_def) - apply (rename_tac syscall) - apply (case_tac syscall, - (wpsimp wp: checkBudgetRestart_true checkBudgetRestart_false hoare_vcg_if_lift2 - | clarsimp simp: active_from_running' simple_from_running' simple_sane_strg - stateAssertE_def stateAssert_def - simp del: split_paired_All - | rule hoare_strengthen_postE_R[where Q'="\_. invs'", rotated], - clarsimp simp: ct_active'_asrt_def - | clarsimp dest!: schedulable'_runnableE intro!: pred_tcb'_weakenE - simp: ct_in_state'_def cur_tcb'_def runnable_eq_active' - | rule conjI active_ex_cap' - | strengthen nidle)+) - apply (rule hoare_strengthen_post, - rule hoare_weaken_pre, - rule hy_invs') - apply (simp add: active_from_running') - apply simp - apply (wp hv_inv' hh_inv' hoare_vcg_if_lift2 checkBudgetRestart_true checkBudgetRestart_false - updateTimeStamp_ct_in_state'[simplified ct_in_state'_def] - | strengthen active_ex_cap'[OF _ invs_iflive'] - | clarsimp dest!: schedulable'_runnableE intro!: pred_tcb'_weakenE - simp: ct_in_state'_def cur_tcb'_def runnable_eq_active' - | wpc)+ - done -qed + \\_. invs'\" + apply (case_tac event, simp_all add: handleEvent_def) + apply (rename_tac syscall) + apply (case_tac syscall, + (wpsimp wp: checkBudgetRestart_true checkBudgetRestart_false hoare_vcg_if_lift2 + | clarsimp simp: active_from_running' simple_from_running' simple_sane_strg + stateAssertE_def stateAssert_def + simp del: split_paired_All + | rule hoare_strengthen_postE_R[where Q'="\_. invs'", rotated], + clarsimp simp: ct_active'_asrt_def + | clarsimp dest!: ksCurThread_schedulable'_ct_active' intro!: pred_tcb'_weakenE + simp: cur_tcb'_def runnable_eq_active')+) + by (wp hv_inv' hh_inv' hy_invs' hoare_vcg_if_lift2 checkBudgetRestart_true + checkBudgetRestart_false + updateTimeStamp_ct_in_state'[simplified ct_in_state'_def] + | clarsimp dest!: ksCurThread_schedulable'_ct_active' + simp: ct_in_state'_def runnable_eq_active' + | wpc)+ lemma released_imp_active_sc_tcb_at: "released_sc_tcb_at t s \ active_sc_tcb_at t s" @@ -2850,20 +2763,12 @@ proof - apply clarsimp apply (fastforce simp: simple_sane_strg sch_act_simple_def ct_in_state'_def elim: st_tcb_ex_cap'' pred_tcb'_weakenE) - apply add_ct_not_inQ apply (rule corres_underlying_split) apply (rule corres_guard_imp[OF getCurThread_corres], simp+) apply (rule handleHypervisorFault_corres) - apply (simp add: valid_fault_def) - apply wp - apply clarsimp - apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE - simp: ct_in_state_def) + apply wpsimp apply wp apply (clarsimp simp: active_from_running' invs'_def valid_pspace'_def) - apply (fastforce simp: ct_in_state'_def sch_act_simple_def - sch_act_sane_def - elim: pred_tcb'_weakenE st_tcb_ex_cap'') done qed diff --git a/proof/refine/RISCV64/Tcb_R.thy b/proof/refine/RISCV64/Tcb_R.thy index deeffec648..553bfed487 100644 --- a/proof/refine/RISCV64/Tcb_R.thy +++ b/proof/refine/RISCV64/Tcb_R.thy @@ -37,11 +37,6 @@ lemma activateIdle_invs': "activateIdleThread thread \invs'\" by (simp add: activateIdleThread_def) -lemma invs'_live_sc'_ex_nonz_cap_to': - "ko_at' ko scp s \ invs' s \ live_sc' ko \ ex_nonz_cap_to' scp s" - apply (clarsimp simp: invs'_def if_live_then_nonz_cap'_def) - by (fastforce simp: obj_at'_real_def ko_wp_at'_def live'_def) - lemma activateThread_corres: "corres dc (invs and ct_in_state activatable) (invs' and ct_in_state' activatable') activate_thread activateThread" @@ -90,17 +85,19 @@ lemma activateThread_corres: lemma bindNotification_corres: "corres dc - (invs and tcb_at t and ntfn_at a) (invs' and tcb_at' t and ntfn_at' a) - (bind_notification t a) (bindNotification t a)" - unfolding bind_notification_def bindNotification_def + (invs and tcb_at t and ntfn_at a) invs' + (bind_notification t a) (bindNotification t a)" + unfolding bind_notification_def bindNotification_def updateNotification_def apply (simp add: bind_assoc update_sk_obj_ref_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getNotification_corres]) - apply (rule corres_split[OF setNotification_corres]) + apply (rule corres_split[OF setNotification_no_queue_update_corres], simp) apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) apply (rule setBoundNotification_corres) - apply wp+ - by auto + apply (wpsimp wp: get_simple_ko_wp getNotification_wp)+ + apply (fastforce simp: obj_at_def) + apply (fastforce simp: obj_at'_def) + done abbreviation "ct_idle' \ ct_in_state' idle'" @@ -119,14 +116,13 @@ crunch schedContextResume (wp: crunch_wps) lemma setThreadState_Restart_invs': - "\\s. invs' s \ tcb_at' t s \ ex_nonz_cap_to' t s - \ st_tcb_at' (Not \ is_BlockedOnReply) t s\ + "\\s. invs' s + \ st_tcb_at' (Not \ is_BlockedOnReply) t s \ st_tcb_at' (Not \ inIPCQueueThreadState) t s\ setThreadState Restart t \\rv. invs'\" apply (simp add: invs'_def valid_dom_schedule'_def) - apply (wpsimp wp: setThreadState_ct_not_inQ simp: pred_tcb_at'_eq_commute) - apply (auto dest: global'_no_ex_cap - simp: o_def pred_tcb_at'_def obj_at'_def) + apply (wpsimp wp: setThreadState_not_queued_valid_sched_pointers' simp: pred_tcb_at'_eq_commute) + apply (auto simp: pred_tcb_at'_def obj_at'_def) done crunch cancel_ipc @@ -137,11 +133,18 @@ crunch cancel_ipc for sc_tcb_sc_at[wp]: "sc_tcb_sc_at P t" (wp: crunch_wps) +lemma release_queue_update_ready_queues_runnable[simp]: + "ready_queues_runnable (release_queue_update f s) = ready_queues_runnable s" + by (clarsimp simp: ready_queues_runnable_def) + +crunch maybe_donate_sc + for ready_queues_runnable[wp]: ready_queues_runnable + (ignore: tcb_sched_action wp: crunch_wps simp: crunch_simps) + lemma restart_corres: "corres dc - (einvs and tcb_at t and ex_nonz_cap_to t and current_time_bounded) - (invs' and tcb_at' t and ex_nonz_cap_to' t) - (Tcb_A.restart t) (ThreadDecls_H.restart t)" + (einvs and tcb_at t and ex_nonz_cap_to t and current_time_bounded) invs' + (Tcb_A.restart t) (ThreadDecls_H.restart t)" apply (simp add: Tcb_A.restart_def Thread_H.restart_def test_possible_switch_to_def get_tcb_obj_ref_def) apply (rule corres_stateAssert_ignore, simp add: sch_act_wf_asrt_def)+ @@ -167,14 +170,17 @@ lemma restart_corres: apply (rule corres_when2 [OF _ possibleSwitchTo_corres]; (solves simp)?) apply (wpsimp wp: getSchedulable_wp)+ apply (rule_tac Q'="\_. invs and valid_sched_action and active_scs_valid - and in_correct_ready_q and ready_qs_distinct - and ready_or_release and tcb_at t" + and in_correct_ready_q and ready_qs_distinct + and ready_queues_runnable + and ready_or_release and tcb_at t" in hoare_post_imp) + apply clarsimp + apply (frule invs_sym_refs) apply (fastforce simp: schedulable_def2) apply (wpsimp wp: sched_context_resume_valid_sched_action) apply (rule_tac Q'="\rv. invs' and tcb_at' t" in hoare_strengthen_post) apply wpsimp - apply (fastforce simp: invs'_def sch_act_wf_weak valid_pspace'_def) + apply (fastforce simp: invs'_def valid_pspace'_def) apply (rule_tac Q'="\rv. invs and valid_ready_qs and valid_release_q and ready_or_release and current_time_bounded and (\s. \scp. scOpt = Some scp \ sc_not_in_release_q scp s) @@ -222,10 +228,10 @@ lemma restart_corres: in hoare_strengthen_post) apply (wpsimp wp: cancel_ipc_no_refs cancel_ipc_ex_nonz_cap_to_tcb) apply (fastforce simp: invs_def valid_state_def idle_no_ex_cap valid_pspace_def) - apply (rule_tac Q'="\rv. invs' and tcb_at' t and ex_nonz_cap_to' t and st_tcb_at' simple' t" + apply (rule_tac Q'="\rv. invs' and tcb_at' t and st_tcb_at' simple' t" in hoare_strengthen_post) apply wpsimp - apply (fastforce simp: invs'_def sch_act_wf_weak valid_pspace'_def + apply (fastforce simp: invs'_def valid_pspace'_def elim: pred_tcb'_weakenE)[1] apply (wpsimp wp: gts_wp gts_wp' thread_get_wp' wp_del: thread_get_inv)+ apply (frule invs_psp_aligned, frule invs_distinct) @@ -249,27 +255,10 @@ crunch schedContextResume, ifCondRefillUnblockCheck for ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" (wp: crunch_wps simp: crunch_simps) -lemma restart_invs': - "\invs' and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ - ThreadDecls_H.restart t \\rv. invs'\" +lemma restart_invs'[wp]: + "ThreadDecls_H.restart t \invs'\" unfolding restart_def - apply (simp add: isStopped_def2) - apply (wp setThreadState_nonqueued_state_update getSchedulable_wp - cancelIPC_simple setThreadState_st_tcb) - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated]) - apply wpsimp - apply (clarsimp simp: schedulable'_def pred_map_pred_conj[simplified pred_conj_def] - projectKO_opt_tcb pred_map_def pred_tcb_at'_def - obj_at'_real_def ko_wp_at'_def - elim!: opt_mapE) - apply (wpsimp wp: hoare_vcg_imp_lift') - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated]) - apply fastforce - apply (wpsimp wp: ifCondRefillUnblockCheck_invs' hoare_vcg_imp_lift') - apply (wpsimp wp: setThreadState_nonqueued_state_update setThreadState_st_tcb - hoare_vcg_if_lift2) - apply (wpsimp wp: gts_wp')+ - done + by (wpsimp wp: setThreadState_nonqueued_state_update hoare_vcg_all_lift hoare_drop_imps) crunch "ThreadDecls_H.restart" for tcb'[wp]: "tcb_at' t" @@ -278,16 +267,6 @@ crunch "ThreadDecls_H.restart" lemma no_fail_setRegister: "no_fail \ (setRegister r v)" by (simp add: setRegister_def) -lemma updateRestartPC_ex_nonz_cap_to'[wp]: - "\ex_nonz_cap_to' p\ updateRestartPC t \\rv. ex_nonz_cap_to' p\" - unfolding updateRestartPC_def - apply (rule asUser_cap_to') - done - -crunch suspend - for cap_to': "ex_nonz_cap_to' p" - (wp: crunch_wps simp: crunch_simps) - declare det_getRegister[simp] declare det_setRegister[simp] @@ -296,10 +275,10 @@ lemma no_fail_getRegister[wp]: "no_fail \ (getRegister r)" lemma invokeTCB_ReadRegisters_corres: "corres (dc \ (=)) - (einvs and tcb_at src and ex_nonz_cap_to src) - (invs' and tcb_at' src and ex_nonz_cap_to' src) - (invoke_tcb (tcb_invocation.ReadRegisters src susp n arch)) - (invokeTCB (tcbinvocation.ReadRegisters src susp n arch'))" + (einvs and tcb_at src and ex_nonz_cap_to src) invs' + (invoke_tcb (tcb_invocation.ReadRegisters src susp n arch)) + (invokeTCB (tcbinvocation.ReadRegisters src susp n arch'))" + apply (rule_tac Q'="tcb_at' src" in corres_cross_add_guard, fastforce intro!: tcb_at_cross) apply (simp add: invokeTCB_def performTransfer_def genericTake_def frame_registers_def gp_registers_def frameRegisters_def gpRegisters_def) @@ -333,15 +312,6 @@ lemma asUser_postModifyRegisters_corres: apply (rule corres_stateAssert_assume) by simp+ -crunch restart - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' tcbPtr" - (wp: crunch_wps threadSet_cap_to simp: crunch_simps tcb_cte_cases_def cteSizeBits_def) - -crunch restart - for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - and valid_sched_pointers[wp]: valid_sched_pointers - (simp: crunch_simps wp: crunch_wps threadSet_sched_pointers threadSet_valid_sched_pointers) - lemma invokeTCB_WriteRegisters_corres: "corres (dc \ (=)) (einvs and simple_sched_action and tcb_at dest and ex_nonz_cap_to dest @@ -365,18 +335,16 @@ lemma invokeTCB_WriteRegisters_corres: apply (wpsimp wp: restart_valid_sched) using idle_no_ex_cap apply fastforce apply (wpsimp wp: restart_invs') - using global'_no_ex_cap apply fastforce apply (corres corres: restart_corres) apply (corresKsimp corres: rescheduleRequired_corres) - apply (fastforce dest: valid_sched_valid_ready_qs) + apply (fastforce dest: invs_sym_refs valid_sched_valid_ready_qs) done lemma invokeTCB_CopyRegisters_corres: "corres (dc \ (=)) (einvs and simple_sched_action and tcb_at dest and tcb_at src and ex_nonz_cap_to src and ex_nonz_cap_to dest and current_time_bounded) - (invs' and tcb_at' dest and tcb_at' src - and ex_nonz_cap_to' src and ex_nonz_cap_to' dest) + invs' (invoke_tcb (tcb_invocation.CopyRegisters dest src susp resume frames ints arch)) (invokeTCB (tcbinvocation.CopyRegisters dest src susp resume frames ints arch'))" proof - @@ -424,6 +392,8 @@ proof - apply (simp | fastforce)+ done show ?thesis + apply (rule_tac Q'="tcb_at' src" in corres_cross_add_guard, fastforce intro: tcb_at_cross) + apply (rule_tac Q'="tcb_at' dest" in corres_cross_add_guard, fastforce intro: tcb_at_cross) apply (simp add: invokeTCB_def performTransfer_def) apply (rule corres_guard_imp) apply (rule corres_split[OF corres_when [OF refl suspend_corres]], simp) @@ -461,22 +431,18 @@ proof - apply (clarsimp simp: invs_def valid_sched_weak_strg valid_sched_def valid_state_def valid_pspace_def valid_idle_def dest!: idle_no_ex_cap ) - apply (wp suspend_nonz_cap_to_tcb hoare_weak_lift_imp suspend_invs suspend_cap_to' + apply (wp suspend_nonz_cap_to_tcb hoare_weak_lift_imp suspend_invs suspend_valid_sched | simp add: if_apply_def2)+ apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_idle_def dest!: idle_no_ex_cap) - apply (fastforce simp: invs'_def dest!: global'_no_ex_cap) + apply (fastforce simp: invs'_def) done qed lemma readreg_invs': - "\invs' and tcb_at' src and ex_nonz_cap_to' src\ - invokeTCB (tcbinvocation.ReadRegisters src susp n arch) - \\rv. invs'\" - by (simp add: invokeTCB_def performTransfer_def | wp - | clarsimp simp: invs'_def - dest!: global'_no_ex_cap)+ + "invokeTCB (tcbinvocation.ReadRegisters src susp n arch) \invs'\" + by (wpsimp simp: invokeTCB_def performTransfer_def | wp | clarsimp simp: invs'_def)+ lemma writereg_invs': "\invs' and tcb_at' dest and ex_nonz_cap_to' dest\ @@ -488,20 +454,10 @@ lemma writereg_invs': dest!: global'_no_ex_cap)+ lemma copyreg_invs'': - "\invs' and tcb_at' src and tcb_at' dest and ex_nonz_cap_to' src and ex_nonz_cap_to' dest\ - invokeTCB (tcbinvocation.CopyRegisters dest src susp resume frames ints arch) - \\rv. invs' and tcb_at' dest\" + "invokeTCB (tcbinvocation.CopyRegisters dest src susp resume frames ints arch) \invs'\" supply if_split [split del] if_weak_cong[cong] unfolding invokeTCB_def performTransfer_def - apply (wpsimp wp: mapM_x_wp' restart_invs' hoare_vcg_if_lift2 hoare_drop_imp suspend_cap_to') - by (fastforce simp: invs'_def dest!: global'_no_ex_cap split: if_split) - -lemma copyreg_invs': - "\invs' and tcb_at' src and - tcb_at' dest and ex_nonz_cap_to' src and ex_nonz_cap_to' dest\ - invokeTCB (tcbinvocation.CopyRegisters dest src susp resume frames ints arch) - \\rv. invs'\" - by (rule hoare_strengthen_post, rule copyreg_invs'', simp) + by (wpsimp wp: mapM_x_wp' restart_invs' hoare_vcg_if_lift2 hoare_drop_imp) lemma isRunnable_corres': "t = t' \ @@ -532,17 +488,6 @@ lemma isBlocked_corres: apply auto done -lemma tcbSchedDequeue_not_queued: - "\\\ tcbSchedDequeue t - \\rv. obj_at' (Not \ tcbQueued) t\" - apply (simp add: tcbSchedDequeue_def) - apply (wp | simp)+ - apply (rule_tac Q'="\rv. obj_at' (\obj. tcbQueued obj = rv) t" - in hoare_post_imp) - apply (clarsimp simp: obj_at'_def) - apply (wp threadGet_sp' [where P=\, simplified] | simp)+ - done - lemma threadSet_ct_in_state': "(\tcb. tcbState (f tcb) = tcbState tcb) \ \ct_in_state' test\ threadSet f t \\rv. ct_in_state' test\" @@ -553,12 +498,6 @@ lemma threadSet_ct_in_state': apply wp done -lemma tcbSchedDequeue_ct_in_state'[wp]: - "\ct_in_state' test\ tcbSchedDequeue t \\rv. ct_in_state' test\" - apply (simp add: ct_in_state'_def) - apply (rule hoare_lift_Pf [where f=ksCurThread]; wp) - done - lemma valid_tcb'_tcbPriority_update: "\valid_tcb' tcb s; f (tcbPriority tcb) \ maxPriority \ \ valid_tcb' (tcbPriority_update f tcb) s" @@ -586,91 +525,108 @@ lemma threadSet_valid_objs_tcbPriority_update: apply (fastforce simp: obj_at'_def)+ done -lemma tcbEPDequeueAppend_valid_ntfn'_rv: - "\valid_ntfn' ntfn and K (ntfnObj ntfn = WaitingNtfn qs \ t \ set qs)\ - do qs' \ tcbEPDequeue t qs; - tcbEPAppend t qs' - od - \\rv s. valid_ntfn' (ntfnObj_update (\_. WaitingNtfn rv) ntfn) 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)+ - apply (fastforce simp: valid_ntfn'_def split: option.split dest!: in_set_zip1) - done +lemma reorderNtfn_valid_objs'[wp]: + "\valid_objs' and tcb_at' tptr\ reorderNtfn ntfnPtr tptr \\_. valid_objs'\" + unfolding reorderNtfn_def tcbAppend_def + by (wpsimp wp: stateAssert_inv hoare_vcg_all_lift) -lemma reorderNtfn_invs': - "\invs' and st_tcb_at' (\st. ntfnBlocked st = Some ntfnPtr) tptr\ - reorderNtfn ntfnPtr tptr - \\rv. invs'\" - apply (simp only: reorderNtfn_def) - apply (subst bind_assoc[symmetric, where m="tcbEPDequeue tptr _"]) - apply (rule bind_wp | simp only: K_bind_def)+ - apply (wp set_ntfn_minor_invs') - apply (simp add: pred_conj_def live'_def live_ntfn'_def) - apply (wpsimp wp: getNotification_wp tcbEPDequeueAppend_valid_ntfn'_rv hoare_vcg_conj_lift)+ - apply (frule ntfn_ko_at_valid_objs_valid_ntfn', fastforce) - apply (clarsimp simp: sym_refs_asrt_def valid_ntfn'_def pred_tcb_at'_def - obj_at'_def projectKO_eq projectKO_tcb projectKO_ntfn) - apply (case_tac "tcbState obj"; clarsimp simp: ntfnBlocked_def getntfnQueue_def split: ntfn.splits) - 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 (clarsimp simp: invs'_def valid_idle'_def live'_def live_ntfn'_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) - done +lemma reorderEp_valid_objs'[wp]: + "\valid_objs' and tcb_at' tptr \ reorderEp epPtr tptr \\_. valid_objs'\" + unfolding reorderEp_def tcbAppend_def + by (wpsimp wp: stateAssert_inv) -lemma set_ep_minor_invs': - "\invs' and valid_ep' val - and (\s. live' (KOEndpoint val) \ ex_nonz_cap_to' ptr s)\ - setEndpoint ptr val - \\rv. invs'\" - apply (clarsimp simp add: invs'_def cteCaps_of_def valid_dom_schedule'_def) - apply (wpsimp wp: irqs_masked_lift valid_irq_node_lift untyped_ranges_zero_lift simp: o_def live'_def) - done +lemma reorderNtfn_sym_heap_sched_pointers[wp]: + "reorderNtfn ntfnPtr tptr \sym_heap_sched_pointers\" + unfolding reorderNtfn_def + by wpsimp -lemma getEpQueue_wp[wp]: "\\s. ep \ IdleEP \ P (epQueue ep) s\ getEpQueue ep \P\" - unfolding getEpQueue_def by wpsimp auto +lemma reorderEp_sym_heap_sched_pointers[wp]: + "reorderEp epPtr tptr \sym_heap_sched_pointers\" + unfolding reorderEp_def + by wpsimp -lemma updateEpQueue_triv: "ep \ IdleEP \ updateEpQueue ep (epQueue ep) = ep" - by (cases ep; clarsimp simp: updateEpQueue_def) +crunch tcbQueueRemove + for sched_flag_set[wp]: "\s. P (sched_flag_set s tcbPtr)" + (wp: crunch_wps threadSet_sched_flag_set ignore: threadSet) -lemma updateEPQueue_IdleEP[simp]: "(updateEpQueue ep qs = IdleEP) = (ep = IdleEP)" - by (cases ep; simp add: updateEpQueue_def) +lemma reorderNtfn_valid_sched_pointers: + "\valid_sched_pointers and st_tcb_at' (\st. ntfnBlocked st = Some ntfnPtr) tptr\ + reorderNtfn ntfnPtr tptr + \\_. valid_sched_pointers\" + apply (simp only: reorderNtfn_def updateNotification_def tcbAppend_def) + apply (wpsimp wp: getNotification_wp hoare_drop_imp + orderedInsert_valid_sched_pointers tcbQueueRemove_valid_sched_pointers) + apply (clarsimp simp: valid_sched_pointers_except_def ntfnBlocked_def + st_tcb_at'_def obj_at'_def opt_pred_def opt_map_red) + apply (rename_tac tcb, case_tac "tcbState tcb"; clarsimp) + done + +lemma reorderEp_valid_sched_pointers: + "\valid_sched_pointers and st_tcb_at' (\st. epBlocked st = Some epPtr) tptr\ + reorderEp epPtr tptr + \\_. valid_sched_pointers\" + apply (simp only: reorderEp_def updateEndpoint_def tcbAppend_def) + apply (wpsimp wp: getEndpoint_wp hoare_drop_imp + orderedInsert_valid_sched_pointers tcbQueueRemove_valid_sched_pointers) + apply (clarsimp simp: valid_sched_pointers_except_def epBlocked_def + st_tcb_at'_def obj_at'_def opt_pred_def opt_map_red) + apply (rename_tac tcb, case_tac "tcbState tcb"; clarsimp) + done + +crunch reorderNtfn, reorderEp + for replyNexts_of[wp]: "\s. P (replyNexts_of s)" + and replyPrevs_of[wp]: "\s. P (replyPrevs_of s)" + and replyTCBs_of[wp]: "\s. P (replyTCBs_of s)" + and pred_tcb_at'[wp]: "\s. Q (pred_tcb_at' P proj test s)" + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + and pspace_bounded'[wp]: pspace_bounded' + and pspace_canonical'[wp]: pspace_canonical' + and pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' + and no_0_obj'[wp]: no_0_obj' + and valid_mdb'[wp]: valid_mdb' + and valid_bitmaps[wp]: valid_bitmaps + and replies_of'[wp]: "\s. P (replies_of' s)" + and if_unsafe_then_cap'[wp]: if_unsafe_then_cap' + and valid_global_refs'[wp]: valid_global_refs' + and valid_arch_state'[wp]: valid_arch_state' + and irq_node'[wp]: "\s. P (irq_node' s)" + and typ_at'[wp]: "\s. P (typ_at' T p s)" + and ksInterruptState[wp]: "\s. P (ksInterruptState s)" + and ctes_of[wp]: "\s. P (ctes_of s)" + and ksMachineState[wp]: "\s. P (ksMachineState s)" + and valid_machine_state'[wp]: valid_machine_state' + and pspace_domain_valid[wp]: pspace_domain_valid + and ksCurDomain[wp]: "\s. P (ksCurDomain s)" + and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + and valid_dom_schedule'[wp]: valid_dom_schedule' + and valid_replies'[wp]: valid_replies' + (wp: crunch_wps threadSet_ctes_of valid_dom_schedule'_lift valid_replies'_lift ignore: threadSet) -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 reorderNtfn_invs'[wp]: + "\invs' and st_tcb_at' (\st. ntfnBlocked st = Some ntfnPtr) tptr\ + reorderNtfn ntfnPtr tptr + \\_. invs'\" + apply (simp add: invs'_def valid_pspace'_def) + apply (wpsimp wp: reorderNtfn_valid_sched_pointers valid_irq_node_lift valid_irq_handlers_lift' + irqs_masked_lift untyped_ranges_zero_lift valid_irq_states_lift' + simp: cteCaps_of_def o_def) + done -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 (rule bind_wp | simp only: K_bind_def)+ - apply (wp set_ep_minor_invs') - apply (simp add: pred_conj_def live'_def live_ntfn'_def) - 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: 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) - 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 live'_def) +lemma reorderEp_invs'[wp]: + "\invs' and st_tcb_at' (\st. epBlocked st = Some epPtr) tptr\ + reorderEp epPtr tptr + \\_. invs'\" + apply (simp add: invs'_def valid_pspace'_def) + apply (wpsimp wp: reorderEp_valid_sched_pointers valid_irq_node_lift valid_irq_handlers_lift' + irqs_masked_lift untyped_ranges_zero_lift valid_irq_states_lift' + simp: cteCaps_of_def o_def) done lemma threadSetPriority_valid_objs'[wp]: - "\valid_objs' and obj_at' (Not \ tcbQueued) t and K (p \ maxPriority)\ + "\valid_objs' and K (p \ maxPriority)\ threadSetPriority t p \\_. valid_objs'\" apply (wpsimp wp: threadSet_valid_objs' simp: threadSetPriority_def) @@ -720,20 +676,12 @@ crunch threadSetPriority (wp: threadSet_st_tcb_at2 ignore: threadSet) lemma threadSetPriority_valid_mdb'[wp]: - "\valid_mdb' and tcb_at' t\ threadSetPriority t p \\_. valid_mdb'\" + "threadSetPriority t p \valid_mdb'\" unfolding threadSetPriority_def apply (wpsimp wp: threadSet_mdb') apply (fastforce simp: obj_at'_def valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) done -lemma threadSetPriority_if_live_then_nonz_cap'[wp]: - "threadSetPriority t p \if_live_then_nonz_cap'\" - unfolding threadSetPriority_def - apply (wpsimp wp: threadSet_iflive'T) - apply (fastforce simp: tcb_cte_cases_def cteSizeBits_def) - apply fastforce - done - lemma threadSetPriority_if_unsafe_then_cap'[wp]: "threadSetPriority t p \if_unsafe_then_cap'\" unfolding threadSetPriority_def @@ -743,7 +691,7 @@ lemma threadSetPriority_if_unsafe_then_cap'[wp]: done lemma threadSetPriority_invs': - "\invs' and obj_at' (Not \ tcbQueued) t and K (p \ maxPriority)\ + "\invs' and K (p \ maxPriority)\ threadSetPriority t p \\_. invs'\" apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) @@ -758,10 +706,8 @@ crunch reorderEp, threadSetPriority lemma threadSetPriority_onRunning_invs': "\\s. invs' s \ p \ maxPriority\ threadSetPriority_onRunning t p \\_. invs'\" - apply (simp only: threadSetPriority_onRunning_def) - apply (wpsimp wp: threadGet_wp threadSetPriority_invs' tcbSchedDequeue_not_queued)+ - apply (clarsimp simp: obj_at'_def) - done + unfolding threadSetPriority_onRunning_def + by (wpsimp wp: threadGet_wp threadSetPriority_invs') lemma runnable'_case_thread_state_If: "(case rv of Running \ threadSetPriority_onRunning t x @@ -778,132 +724,539 @@ lemma setPriority_invs'[wp]: apply (fastforce simp: ready_qs_runnable_def pred_tcb_at'_def obj_at'_def) done -lemma tcb_ep_dequeue_distinct: - "\\_. distinct q\ tcb_ep_dequeue t q \\q' _. distinct q'\" - by (wpsimp simp: tcb_ep_dequeue_def) +lemma sym_ref_BlockedOnNotification_WaitingNtfn: + "\kheap s tp = Some (TCB tcb); sym_refs (state_refs_of s); + tcb_state tcb = Structures_A.BlockedOnNotification ntfn_ptr\ \ + \notification list. kheap s ntfn_ptr = Some (Structures_A.Notification notification) + \ tp \ set (ntfn_queue_of notification)" + apply (drule sym_refs_obj_atD[rotated, where p=tp]) + apply (clarsimp simp: obj_at_def, simp) + apply (clarsimp simp: state_refs_of_def) + apply (drule_tac x="(ntfn_ptr, TCBSignal)" in bspec) + apply (fastforce split: if_split_asm) + apply (clarsimp simp: obj_at_def) + apply (rename_tac ko'; case_tac ko'; clarsimp simp: ntfn_q_refs_of_def get_refs_def2) + apply (rename_tac ntfn; case_tac ntfn; simp split: ntfn.splits) + done + +lemma updateNotification_queue_update_ntfns_relation_rcorres: + "rcorres + (\s s'. ntfns_relation s s' + \ ko_at (kernel_object.Notification ntfn) ntfnPtr s \ is_WaitingNtfn (ntfn_obj ntfn)) + (set_notification ntfnPtr (ntfn_set_obj ntfn (WaitingNtfn q))) + (updateNotification ntfnPtr (ntfnQueue_update f)) + (\_ _. ntfns_relation)" + apply (rule rcorres_from_valid_det) + apply wpsimp + apply (clarsimp simp: obj_at_def is_ntfn_def) + apply (wpsimp wp: updateNotification_wp) + apply (drule in_set_notification) + apply (clarsimp simp: obj_at'_def ntfn_at_pred_def obj_at_def) + apply (clarsimp simp: map_relation_def ntfn_relation_def projectKO_opts_defs is_WaitingNtfn_def) + apply (drule_tac x=ntfnPtr in spec) + apply (fastforce simp: opt_map_red) + done + +lemma updateNotification_list_queue_relation_rcorres[rcorres]: + "rcorres + (\s s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ ntfn_at ntfnPtr s) + (set_notification ntfnPtr (ntfn_set_obj ntfn (WaitingNtfn ls))) + (updateNotification ntfnPtr (ntfnQueue_update (\_. q))) + (\_ _ s s'. + \ls. ntfn_queues_of s ntfnPtr = Some ls + \ (\q. ntfnQueues_of s' ntfnPtr = Some q + \ list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')))" + apply (rule rcorres_from_valid_det) + apply wpsimp + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_const_imp_lift hoare_vcg_imp_lift') + apply (wpsimp wp: updateNotification_wp) + apply wpsimp + apply (clarsimp simp: in_monad) + apply (drule in_set_notification) + apply (fold fun_upd_def) + apply (clarsimp simp: projectKO_opts_defs) + done + +lemma tcbQueueRemove_tcbs_relation[rcorres]: + "rcorres tcbs_relation (return ls) (tcbQueueRemove q t) (\_ _. tcbs_relation)" + unfolding heap_pspace_relation_def + by (rcorres_conj_lift \fastforce\ simp: tcbAppend_def) + +lemma tcbAppend_tcbs_relation[rcorres]: + "rcorres + (\s s'. tcbs_relation s s' \ (\t \ set ls. tcb_at t s) \ tcb_at t s) + (tcb_append t ls) (tcbAppend t q) + (\_ _. tcbs_relation)" + by (rcorres_conj_lift \fastforce\ simp: tcbAppend_def tcb_append_def) + +lemma tcbQueueRemove_heap_pspace_relation[rcorres]: + "rcorres heap_pspace_relation (return ls) (tcbQueueRemove q t) (\_ _. heap_pspace_relation)" + unfolding heap_pspace_relation_def + by (rcorres_conj_lift \fastforce\ simp: tcbAppend_def)+ + +lemma det_wp_reorder_ntfn[wp]: + "det_wp (\s. (\t \ set qs. tcb_at t s) \ tcb_at tptr s \ ntfn_at ntfnPtr s) + (do qs' \ return (removeAll tptr qs); + qs'' \ tcb_append tptr qs'; + set_notification ntfnPtr (ntfn_set_obj ntfn (WaitingNtfn qs'')) + od)" + by wpsimp + +lemmas no_fail_reorder_ntfn = det_wp_no_fail[OF det_wp_reorder_ntfn] + +lemmas reorder_ntfn_rules = + det_wp_reorder_ntfn no_fail_reorder_ntfn reorder_ntfn_empty_fail + +lemma no_fail_tcbAppend: + "no_fail + (\s'. \s :: det_state. + (\ts. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sorted_wrt (img_ord (prios_of s) (opt_ord_rel (\))) ts + \ (\t \ set ts. tcb_at t s) + \ (\t \ set ts. sched_flag_set s' t) + \ t \ set ts) + \ sym_heap_sched_pointers s' \ tcb_at t s \ pspace_aligned' s' \ pspace_distinct' s' + \ tcbs_relation s s') + (tcbAppend t q)" + apply (clarsimp simp: tcbAppend_def) + apply (rule no_fail_pre) + apply (rule_tac f="return ()" in no_fail_rcorres_bind) + apply (rule no_fail_ex_lift) + apply (fastforce intro: no_fail_orderedInsert) + apply (rule rcorres_return_stateAssert) + apply (rule no_fail_ex_lift) + apply (rule no_fail_stateAssert) + apply clarsimp + apply (rename_tac s' s ts) + apply (prop_tac "\t \ set ts. tcb_at' t s'") + apply (fastforce intro: tcb_at_cross_tcbs_relation) + apply (prop_tac "tcb_at' t s'") + apply (fastforce intro!: tcb_at_cross_tcbs_relation) + apply (prop_tac "sorted_wrt (img_ord (\t. threadRead tcbPriority t s') + (opt_ord_rel (\x y. y \ x))) ts") + apply (erule sorted_wrt_img_ord_eq_lift[THEN iffD1, rotated]) + apply (rename_tac t') + apply (simp flip: thread_read_Some_tcbs_of) + apply (rule_tac f="thread_read tcb_priority t'" and g="threadRead tcbPriority t'" + in rcorres_rrel_eq) + apply (rule threadGet_rcorres[where rrel="(=)"]) + apply (clarsimp simp: tcb_relation_def) + apply clarsimp + apply (fastforce intro!: no_ofailD[OF thread_read_no_ofail]) + apply (fastforce intro!: no_ofailD[OF no_ofail_threadRead_tcb_at']) + apply (clarsimp simp: threadRead_tcb_at'_eq) + apply (fastforce intro!: no_ofailD[OF thread_read_no_ofail]) + done + +lemma tcbQueueRemove_sched_flag_set_rcorres[rcorres]: + "rcorres + (\_ s'. \t \ set ls. sched_flag_set s' t) + (return (removeAll t ls)) (tcbQueueRemove q t) + (\rv _ _ s'. \t \ set rv. sched_flag_set s' t)" + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: hoare_vcg_ball_lift simp: return_def) + apply fastforce + done 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) + \ ready_queues_runnable s \ release_q_runnable s + \ none_top (\q. priority_ordered (filter ((\) t) q) (prios_of s)) + (ntfn_queues_of s ntfn_ptr)) + invs' (reorder_ntfn ntfn_ptr t) (reorderNtfn ntfnPtr t)" - apply add_sym_refs + supply return_bind[simp del] + ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + heap_ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) 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_l) - apply (rule corres_assert_assume_r) - apply (rule corres_split) - apply (rule tcbEPDequeue_corres) - apply (clarsimp simp: ntfn_relation_def get_ntfn_queue_def getntfnQueue_def - split: Structures_A.ntfn.splits) - apply (rule corres_split) - apply clarsimp - apply (rule tcbEPAppend_corres) - apply (rule setNotification_corres) - apply (clarsimp simp: ntfn_relation_def) - apply wp - apply wp - 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) - apply (clarsimp split: Structures_A.thread_state.splits) - apply (frule invs_valid_objs) - 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=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 (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ntfn_sp']) + apply (corres corres: getNotification_corres) + apply (frule tcb_in_valid_state) + apply fastforce + apply (clarsimp simp: valid_tcb_state_def) + apply (rename_tac st, case_tac st; fastforce simp: ntfn_blocked_def) + apply fastforce + apply (rename_tac ntfn ntfn') + apply (rule_tac Q="tcb_at t and ntfn_at ntfnPtr" in corres_cross_add_abs_guard) + apply (fastforce simp: obj_at_def is_ntfn_def) + apply (rule_tac Q'="valid_ntfn' ntfn'" in corres_cross_add_guard) + apply (fastforce intro: ntfn_ko_at_valid_objs_valid_ntfn') + apply (rule_tac Q="\s. \list. ntfn_obj ntfn = WaitingNtfn list \ t \ set list" + in corres_cross_add_abs_guard) + apply (clarsimp simp: pred_tcb_at_def obj_at_def ntfn_blocked_def) + apply (rename_tac tcb, case_tac "tcb_state tcb"; clarsimp) + apply (frule sym_ref_BlockedOnNotification_WaitingNtfn) + apply fastforce + apply fastforce + apply (case_tac "ntfn_obj ntfn"; clarsimp) + apply (rule corres_underlying_lift_ex1[simplified pred_conj_comm]) + apply (rename_tac list) + apply (rule_tac Q="\s. valid_ntfn ntfn s + \ ntfn_queues_of s ntfn_ptr = Some list + \ (\t' \ set list. tcb_at t' s + \ st_tcb_at (\st. ntfn_blocked st = Some ntfnPtr) t' s)" + in corres_cross_add_abs_guard) + apply (intro context_conjI) + apply (fastforce intro: valid_objs_valid_ntfn simp: obj_at_def) + apply (clarsimp simp: opt_map_def obj_at_def split: option.splits) + apply (force dest: st_in_waitingntfn + simp: valid_ntfn_def pred_tcb_at_def obj_at_def ntfn_blocked_def) + apply (rule_tac Q'="\s'. \t' \ set list. tcb_at' t' s' \ sched_flag_set s' t'" + in corres_cross_add_guard) + apply (rule in_ntfn_queue_sched_flag_set; fastforce?) + apply (fastforce dest: invs_sym_refs) + apply (rule corres_assert_assume_l_forward) + apply fastforce + apply (rule corres_gen_asm') + apply clarsimp + apply (rule corres_symb_exec_l[OF _ _ return_sp]; (solves wpsimp)?) + apply (rule corres_assert_assume_l_forward) + apply fastforce + apply clarsimp + apply (rule_tac Q'="\s'. list_queue_relation + list (ntfnQueue ntfn') (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in corres_cross_add_guard) + apply (rule ntfn_queues_relationD) + apply (fastforce simp: obj_at_def opt_map_def split: option.splits) + apply (fastforce simp: opt_map_def obj_at'_def split: option.splits) + apply fastforce + apply (rule corres_underlying_from_rcorres) + apply (rule no_fail_pre) + apply (rule_tac f="return $ removeAll t (ntfn_queue_of ntfn)" in no_fail_rcorres_bind) + apply (rename_tac ls q') + apply (rule_tac f="tcb_append t ls" in no_fail_rcorres_bind) + apply (rule no_fail_ex_lift) + apply wpsimp + apply (rcorres simp: tcbAppend_def) + apply (rule no_fail_tcbAppend) + apply (rcorres rcorres: rcorres_exI_abs_rv rcorres_drop_imp + tcbQueueRemove_rcorres) apply clarsimp - 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') - apply (erule (1) valid_objsE'[where x=t]) - 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=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) + apply (rule no_fail_ex_lift) + apply (rule tcbQueueRemove_no_fail) apply clarsimp - apply (clarsimp simp: refs_of_rev' ko_wp_at'_def getntfnQueue_def - obj_at'_def projectKO_eq projectKO_tcb) - apply (clarsimp simp: sym_refs_asrt_def) + apply (frule state_relation_pspace_relation) + subgoal by (fastforce simp: pspace_relation_heap_pspace_relation removeAll_filter_not_eq) + apply (clarsimp simp: state_relation_def pspace_relation_heap_pspace_relation + ghost_relation_heap_ghost_relation heap_pspace_relation_def) + apply (rule rcorres_conj_lift_fwd) + apply (rule det_wp_pre, rule reorder_ntfn_rules, simp) + apply rcorres + apply simp + apply (rcorres_conj_lift \clarsimp\ + rule: reorder_ntfn_rules wp: stateAssert_inv + simp: tcbAppend_def)+ + apply (rule rcorres_conj_lift_fwd) + apply (rule det_wp_pre, rule reorder_ntfn_rules, simp) + \ \ntfns_relation\ + apply (rcorres rcorres: updateNotification_queue_update_ntfns_relation_rcorres + rcorres_lift: ntfns_relation_lift_rcorres + simp: tcbAppend_def tcb_append_def) + apply (clarsimp simp: ntfn_at_pred_def obj_at_def) + apply (rcorres_conj_lift \clarsimp\ + rule: reorder_ntfn_rules wp: stateAssert_inv + simp: tcbAppend_def)+ + apply (rule rcorres_conj_lift_fwd) + apply (rule det_wp_pre, rule reorder_ntfn_rules, simp) + \ \ep_queues_relation\ + apply (simp add: ep_queues_relation_def) + apply (rcorres rcorres: tcbAppend_rcorres_other + tcbQueueRemove_rcorres_other tcbQueueRemove_rcorres rcorres_op_lifts + simp: tcbAppend_def tcb_append_def) + apply clarsimp + apply (rename_tac p ls q') + apply (frule invs_sym_refs) + apply (prop_tac "set ls \ set list = {}") + apply (rule ep_queues_ntfn_queues_disjoint, fastforce+)[1] + subgoal by (auto simp: heap_pspace_relation_def) + apply (rule rcorres_conj_lift_fwd) + apply (rule det_wp_pre, rule reorder_ntfn_rules, simp) + \ \ntfn_queues_relation\ + apply (simp add: ntfn_queues_relation_def) + apply (rule rcorres_allI_fwd; (solves \wpsimp simp: reorder_ntfn_rules\)?) + apply (rename_tac p) + apply (case_tac "p \ ntfnPtr") + apply (rcorres rcorres: tcbAppend_rcorres_other tcbQueueRemove_rcorres_other + tcbQueueRemove_rcorres rcorres_op_lifts + wp: set_notification_ntfn_queues_of_other + updateNotification_ntfnQueues_of_other) + apply clarsimp + apply (rename_tac ls q') + apply (frule invs_sym_refs) + apply (prop_tac "set ls \ set list = {}") + apply (rule ntfn_queues_disjoint, fastforce+)[1] + subgoal by (auto simp: heap_pspace_relation_def) + apply clarsimp + apply (rcorres rcorres: tcbAppend_rcorres tcbQueueRemove_rcorres_other tcbQueueRemove_rcorres) + apply clarsimp + subgoal by (auto simp: heap_pspace_relation_def simp: removeAll_filter_not_eq) + apply (rule rcorres_conj_lift_fwd) + apply wpsimp + \ \ready_queues_relation\ + apply (simp add: ready_queues_relation_def Let_def) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac d p) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rule_tac p="\s'. inQ d p |< tcbs_of' s'" in rcorres_lift_conc) + apply (clarsimp simp: ready_queue_relation_def) + apply (rcorres rcorres: tcbAppend_rcorres tcbAppend_rcorres_other + tcbQueueRemove_rcorres_other tcbQueueRemove_rcorres rcorres_prop) + apply clarsimp + apply (rename_tac list d p s s') + apply (frule invs_sym_refs) + apply (prop_tac "set list \ set (ready_queues s d p) = {}") + apply (rule ntfn_queues_ready_queues_disjoint, fastforce+)[1] + subgoal by (auto simp: heap_pspace_relation_def) + apply wpsimp + apply wpsimp + apply wpsimp + apply (rule rcorres_conj_lift_fwd) + apply wpsimp + \ \release_q_relation\ + apply (simp add: release_queue_relation_def) + apply (rule_tac p=release_queue in rcorres_lift_abs) + apply (rule_tac p=ksReleaseQueue in rcorres_lift_conc) + apply (rcorres rcorres: tcbAppend_rcorres tcbAppend_rcorres_other + tcbQueueRemove_rcorres_other tcbQueueRemove_rcorres rcorres_prop) + apply clarsimp + apply (rename_tac list s s') + apply (frule invs_sym_refs) + apply (prop_tac "set list \ set (release_queue s) = {}") + apply (rule ntfn_queues_release_queue_disjoint, fastforce+)[1] + subgoal by (auto simp: heap_pspace_relation_def) + apply wpsimp + apply wpsimp + by (rcorres_conj_lift \simp\ + rule: reorder_ntfn_rules wp: stateAssert_inv simp: tcbAppend_def)+ + +lemma det_wp_reorder_ep[wp]: + "det_wp (\s. (\t \ set qs. tcb_at t s) \ tcb_at tptr s \ ep_at ep_ptr s) + (do qs' \ return (removeAll tptr qs); + qs'' \ tcb_append tptr qs'; + set_endpoint ep_ptr (update_ep_queue ep qs'' True) + od)" + by wpsimp + +lemmas no_fail_reorder_ep = det_wp_no_fail[OF det_wp_reorder_ep] + +lemmas reorder_ep_rules = det_wp_reorder_ep no_fail_reorder_ep + +lemma updateEndpoint_tcbs_relation[rcorres]: + "rcorres + (\s s'. tcbs_relation s s' \ ep_at ep_ptr s) + (set_endpoint ep_ptr ep) (updateEndpoint epPtr f') + (\_ _. tcbs_relation)" + by (rcorres_conj_lift \fastforce\ simp: tcbAppend_def tcb_append_def) + +lemma updateEndpoint_queue_update_eps_relation_rcorres[rcorres]: + "rcorres + (\s s'. eps_relation s s' \ ko_at (kernel_object.Endpoint ep) epPtr s \ ep_queue ep \ []) + (set_endpoint epPtr (update_ep_queue ep qs'' bool)) + (updateEndpoint epPtr (epQueue_update f)) + (\_ _. eps_relation)" + apply (rule rcorres_from_valid_det) + apply wpsimp + apply (clarsimp simp: obj_at_def is_ep_def) + apply (wpsimp wp: updateEndpoint_wp) + apply (drule in_set_endpoint) + apply (clarsimp simp: obj_at'_def obj_at_def) + apply (clarsimp simp: map_relation_def ep_relation_def projectKO_opts_defs eps_of_kh_def) + apply (drule_tac x=epPtr in spec) + apply (fastforce simp: opt_map_red split: Structures_A.endpoint.splits) + done + +lemma updateEndpoint_list_queue_relation_rcorres[rcorres]: + "rcorres + (\s s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') \ ep_at epPtr s) + (set_endpoint epPtr (update_ep_queue ep ls bool)) + (updateEndpoint epPtr (epQueue_update (\_. q))) + (\_ _ s s'. + \ls. ep_queues_of s epPtr = Some ls + \ (\q. epQueues_of s' epPtr = Some q + \ list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')))" + apply (rule rcorres_from_valid_det) + apply wpsimp + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_const_imp_lift hoare_vcg_imp_lift') + apply (wpsimp wp: updateEndpoint_wp) + apply wpsimp + apply (clarsimp simp: in_monad) + apply (drule in_set_endpoint) + apply (fold fun_upd_def) + apply (clarsimp simp: eps_of_kh_def projectKO_opts_defs) done 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)) + (\s. invs s \ st_tcb_at (\st. ep_blocked st = Some ep_ptr) t s + \ ready_queues_runnable s \ release_q_runnable 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 + supply return_bind[simp del] + ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + heap_ghost_relation_wrapper_def[simp del] (*FIXME arch-split RT: not necessary after arch-split*) + apply (rule_tac Q="ep_at ep_ptr" in corres_cross_add_abs_guard) + apply clarsimp + apply (frule tcb_in_valid_state) + apply fastforce + apply (clarsimp simp: valid_tcb_state_def) + apply (case_tac st; clarsimp simp: ep_blocked_def) 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 (fastforce intro!: ep_at_cross) + apply (clarsimp simp: valid_tcb_state_def) + apply add_sym_refs apply (clarsimp simp: reorder_ep_def reorderEp_def) - 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 (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 (rule corres_split_forwards'[OF _ get_simple_ko_sp get_ep_sp']) + apply (corres corres: getEndpoint_corres) + apply (rename_tac ep ep') + apply (rule_tac Q="tcb_at t" in corres_cross_add_abs_guard) + apply (fastforce simp: obj_at_def is_ntfn_def) + apply (rule_tac Q="\s. \list. ep_queue ep = list \ t \ set list" + in corres_cross_add_abs_guard) 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 + apply (rename_tac tcb, case_tac "tcb_state tcb"; clarsimp) + apply (fastforce dest: sym_ref_BlockedOnReceive_RecvEP) + apply (fastforce dest: sym_ref_BlockedOnSend_SendEP) + apply (rule corres_underlying_lift_ex1[simplified pred_conj_comm]) + apply (rename_tac list) + apply (rule_tac Q="\s. valid_ep ep s + \ ep_queues_of s ep_ptr = Some list + \ (\t' \ set list. tcb_at t' s + \ st_tcb_at (\st. ep_blocked st = Some epPtr) t' s)" + in corres_cross_add_abs_guard) + apply (intro context_conjI) + apply (fastforce intro: valid_objs_valid_ep simp: obj_at_def) + apply (clarsimp simp: eps_of_kh_def opt_map_def obj_at_def split: option.splits) + apply (case_tac ep; clarsimp) + apply (fastforce dest!: in_send_ep_queue_st_tcb_at + simp: valid_ep_def pred_tcb_at_def obj_at_def ep_blocked_def) + apply (fastforce dest!: in_receive_ep_queue_st_tcb_at + simp: valid_ep_def pred_tcb_at_def obj_at_def ep_blocked_def) + apply (rule_tac Q'="\s'. \t' \ set list. tcb_at' t' s' \ sched_flag_set s' t'" + in corres_cross_add_guard) + apply (rule in_ep_queue_sched_flag_set; fastforce?) + apply (fastforce dest: invs_sym_refs) + apply (rule corres_assert_assume_l_forward) + apply fastforce + apply (rule corres_gen_asm') + apply (rule corres_symb_exec_l[OF _ _ return_sp]; (solves wpsimp)?) + apply (rule corres_assert_assume_l_forward) + apply fastforce + apply (rule_tac Q'="\s'. list_queue_relation + list (epQueue ep') (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + in corres_cross_add_guard) + apply (rule ep_queues_relationD) + apply (fastforce simp: obj_at_def opt_map_def split: option.splits) + apply (fastforce simp: opt_map_def obj_at'_def split: option.splits) + apply fastforce + apply (rule corres_underlying_from_rcorres) + apply (rule no_fail_pre) + apply (rule_tac f="return $ removeAll t (ep_queue ep)" in no_fail_rcorres_bind) + apply (rename_tac rv rv') + apply (rule_tac f="tcb_append t rv" in no_fail_rcorres_bind) + apply (rule no_fail_ex_lift) + apply wpsimp + apply (rcorres simp: tcbAppend_def) + apply (rule no_fail_tcbAppend) + apply (rcorres rcorres: rcorres_exI_abs_rv rcorres_drop_imp + tcbQueueRemove_rcorres) + apply (rule no_fail_ex_lift) + apply (rule tcbQueueRemove_no_fail) + apply clarsimp + apply (frule state_relation_pspace_relation) + subgoal by (fastforce simp: pspace_relation_heap_pspace_relation simp: removeAll_filter_not_eq) + supply return_bind[simp del] + apply (clarsimp simp: state_relation_def pspace_relation_heap_pspace_relation + ghost_relation_heap_ghost_relation heap_pspace_relation_def) + apply (rcorres_conj_lift \clarsimp\ + rule: reorder_ep_rules wp: stateAssert_inv + simp: tcbAppend_def)+ + apply (rule rcorres_conj_lift_fwd) + apply (rule det_wp_pre, rule reorder_ep_rules, simp) + \ \eps_relation\ + apply (rcorres rcorres_lift: eps_relation_lift_rcorres + simp: tcbAppend_def tcb_append_def) + apply clarsimp + apply (rcorres_conj_lift \clarsimp\ + rule: reorder_ep_rules wp: stateAssert_inv + simp: tcbAppend_def)+ + apply (rule rcorres_conj_lift_fwd) + apply (rule det_wp_pre, rule reorder_ep_rules, simp) + \ \ep_queues_relation\ + apply (simp add: ep_queues_relation_def) + apply (rule rcorres_allI_fwd; (solves \wpsimp simp: reorder_ep_rules\)?) + apply (rename_tac p) + apply (case_tac "p \ epPtr") + apply (rcorres rcorres: tcbAppend_rcorres_other tcbQueueRemove_rcorres_other + tcbQueueRemove_rcorres rcorres_op_lifts + wp: set_endpoint_ep_queues_of_other updateEndpoint_epQueues_of_other) + apply clarsimp + apply (rename_tac ls q') + apply (frule invs_sym_refs) + apply (prop_tac "set ls \ set (ep_queue ep) = {}") + apply (rule ep_queues_disjoint, fastforce+)[1] + subgoal by (auto simp: heap_pspace_relation_def) + apply clarsimp + apply (rcorres rcorres: tcbAppend_rcorres tcbQueueRemove_rcorres_other tcbQueueRemove_rcorres) + apply clarsimp + subgoal by (auto simp: heap_pspace_relation_def removeAll_filter_not_eq) + apply (rule rcorres_conj_lift_fwd) + apply (rule det_wp_pre, rule reorder_ep_rules, simp) + \ \ntfn_queues_relation\ + apply (simp add: ntfn_queues_relation_def) + apply (rcorres rcorres: tcbAppend_rcorres_other + tcbQueueRemove_rcorres_other tcbQueueRemove_rcorres rcorres_op_lifts + simp: tcbAppend_def tcb_append_def) + apply clarsimp + apply (rename_tac p ls q') + apply (frule invs_sym_refs) + apply (prop_tac "set (ep_queue ep) \ set ls = {}") + apply (rule ep_queues_ntfn_queues_disjoint, fastforce+)[1] + subgoal by (auto simp: heap_pspace_relation_def) + apply (rule rcorres_conj_lift_fwd) + apply (rule det_wp_pre, rule reorder_ep_rules, simp) + \ \ready_queues_relation\ + apply (simp add: ready_queues_relation_def Let_def) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac d p) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rule_tac p="\s'. inQ d p |< tcbs_of' s'" in rcorres_lift_conc) + apply (clarsimp simp: ready_queue_relation_def) + apply (rcorres rcorres: tcbAppend_rcorres tcbAppend_rcorres_other + tcbQueueRemove_rcorres_other tcbQueueRemove_rcorres rcorres_prop) + apply clarsimp + apply (frule invs_sym_refs) + apply (prop_tac "set (ep_queue ep) \ set (ready_queues s d p) = {}") + apply (rule ep_queues_ready_queues_disjoint, fastforce+)[1] + subgoal by (auto simp: heap_pspace_relation_def) + apply wpsimp + apply wpsimp + apply wpsimp + apply (rule rcorres_conj_lift_fwd) + apply wpsimp + \ \release_q_relation\ + apply (simp add: release_queue_relation_def) + apply (rule_tac p=release_queue in rcorres_lift_abs) + apply (rule_tac p=ksReleaseQueue in rcorres_lift_conc) + apply (rcorres rcorres: tcbAppend_rcorres_other tcbQueueRemove_rcorres_other + tcbQueueRemove_rcorres rcorres_prop) + apply clarsimp + apply (frule invs_sym_refs) + apply (prop_tac "set (ep_queue ep) \ set (release_queue s) = {}") + apply (rule ep_queues_release_queue_disjoint, fastforce+)[1] + subgoal by (auto simp: heap_pspace_relation_def) + apply wpsimp + apply wpsimp + by (rcorres_conj_lift \clarsimp\ + rule: reorder_ep_rules wp: stateAssert_inv simp: tcbAppend_def)+ lemma threadSetPriority_valid_tcbs'[wp]: "\valid_tcbs' and K (prio \ maxPriority)\ @@ -938,7 +1291,7 @@ lemma threadSet_not_queued_corres: \tcb'. tcbQueued (F tcb') = tcbQueued tcb'; \tcb'. tcbInReleaseQueue (F tcb') = tcbInReleaseQueue tcb'; \tcb. \(getF, v) \ ran tcb_cap_cases. getF (f tcb) = getF tcb; - \tcb'. \(getF, v)\ran tcb_cte_cases. getF (F tcb') = getF tcb'\ + \tcb'. \(getF, v) \ ran tcb_cte_cases. getF (F tcb') = getF tcb'\ \ corres dc (tcb_at t and not_queued t and pspace_aligned and pspace_distinct) \ (thread_set f t) (threadSet F t)" apply (rule_tac Q'="tcb_at' t" in corres_cross_add_guard) @@ -958,79 +1311,76 @@ lemma threadSet_not_queued_corres: done lemma threadSetPriority_onRunning_corres: - "corres dc (valid_pspace and weak_valid_sched_action and active_scs_valid - and in_correct_ready_q and ready_qs_distinct and ready_or_release - and ct_not_in_release_q and st_tcb_at runnable t and K (prio \ maxPriority)) - (\s. invs' s \ tcb_at' t s) - (do d <- thread_get tcb_domain t; - p <- thread_get tcb_priority t; - queue <- get_tcb_queue d p; - cur <- gets cur_thread; - if t \ set queue \ t = cur - then do y <- tcb_sched_action tcb_sched_dequeue t; - y <- thread_set_priority t prio; - y <- tcb_sched_action tcb_sched_enqueue t; - reschedule_required od - else thread_set_priority t prio od) - (threadSetPriority_onRunning t prio)" + "corres dc + (valid_pspace and weak_valid_sched_action and active_scs_valid + and in_correct_ready_q and ready_queues_runnable and ready_qs_distinct + and ready_or_release and ct_not_in_release_q and st_tcb_at runnable t + and K (prio \ maxPriority)) + invs' + (do d \ thread_get tcb_domain t; + p \ thread_get tcb_priority t; + queue \ get_tcb_queue d p; + cur \ gets cur_thread; + if t \ set queue \ t = cur + then do y \ tcb_sched_action tcb_sched_dequeue t; + y \ thread_set_priority t prio; + y \ tcb_sched_action tcb_sched_enqueue t; + reschedule_required + od + else thread_set_priority t prio od) + (threadSetPriority_onRunning t prio)" + apply (rule_tac Q'="tcb_at' t" in corres_cross_add_guard) + apply (fastforce intro!: tcb_at_cross) apply (rule corres_gen_asm') apply (simp add: threadSetPriority_onRunning_def thread_set_priority_def threadSetPriority_def epBlocked_def ntfnBlocked_def get_tcb_queue_def) - apply (rule corres_symb_exec_l[OF _ _ thread_get_sp]) - apply (rule corres_symb_exec_l[OF _ _ thread_get_sp]) - apply (rule corres_symb_exec_l[OF _ _ gets_sp]) - apply (rule corres_symb_exec_r[OF _ threadGet_sp']) - apply (rule stronger_corres_guard_imp) - apply (rule_tac F="t \ set (queues d p) = queued" in corres_gen_asm) - apply (rule_tac r'="(=)" in corres_split) - apply (rule getCurThread_corres) - apply (rule corres_if) - apply clarsimp - apply (rule corres_split_nor) - apply (rule tcbSchedDequeue_corres, simp) - apply (rule corres_split_nor) - apply (rule threadSet_not_queued_corres; - simp add: tcb_relation_def tcb_cap_cases_def tcb_cte_cases_def - cteSizeBits_def) - apply (rule corres_split_nor) - apply (rule tcbSchedEnqueue_corres, simp) - apply (rule rescheduleRequired_corres) - apply wp - apply (wpsimp wp: tcbSchedEnqueue_valid_tcbs') - apply (wpsimp wp: thread_set_in_correct_ready_q_not_queued - thread_set_no_change_tcb_state - thread_set_weak_valid_sched_action) - apply (wpsimp wp: tcbSchedEnqueue_valid_tcbs' threadSet_sched_pointers - threadSet_valid_sched_pointers) - apply (wpsimp wp: tcb_dequeue_not_queued') - apply (rule_tac Q'="\_ s. obj_at' (Not \ tcbQueued) t s \ valid_tcbs' s \ - sym_heap_sched_pointers s \ - valid_sched_pointers s\ pspace_aligned' s \ - pspace_distinct' s \ pspace_bounded' s" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: obj_at'_def opt_map_def) - apply (wp tcbSchedDequeue_not_queued hoare_vcg_all_lift) - apply (rule threadSet_not_queued_corres; - simp add: tcb_relation_def tcb_cap_cases_def tcb_cte_cases_def cteSizeBits_def) - apply wp - apply wp - apply (clarsimp simp: valid_pspace_def) - apply (frule valid_objs_valid_tcbs) - apply (frule state_relation_ready_queues_relation) - apply (frule in_ready_q_tcbQueued_eq[where t=t]) - apply (frule state_relation_pspace_relation) - apply (drule obj_at'_prop)+ - apply (clarsimp simp: obj_at_def is_tcb_def) - apply (frule (2) pspace_relation_tcb_domain_priority) - apply (intro conjI impI; - fastforce simp: ready_or_release_def in_ready_q_def opt_pred_def opt_map_def - in_correct_ready_q_def vs_all_heap_simps) - apply clarsimp - apply (frule invs'_valid_tcbs') - apply (fastforce simp: invs'_def valid_tcbs'_def valid_tcb'_def obj_at'_def) - apply (wpsimp wp: thread_get_exs_valid)+ + apply (rule corres_symb_exec_l[OF _ _ thread_get_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_l[OF _ _ thread_get_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_l[OF _ _ gets_sp]; (solves wpsimp)?) + apply (rule corres_split_forwards'[OF _ gets_sp getCurThread_sp]) + apply (corres corres: getCurThread_corres) + apply (rule corres_if_strong') + apply (clarsimp simp: obj_at_def) + apply (rule disj_left_cong) + apply (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=t]) + apply (frule (1) in_correct_ready_q_in_ready_q) + apply (clarsimp simp: in_ready_q_def opt_pred_def opt_map_red obj_at'_def) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF threadSet_not_queued_corres]; + simp add: tcb_relation_def tcb_cap_cases_def tcb_cte_cases_def cteSizeBits_def) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) + apply (rule rescheduleRequired_corres) + apply wpsimp + apply (wpsimp wp: tcbSchedEnqueue_valid_tcbs') + apply (wpsimp wp: thread_set_in_correct_ready_q_not_queued thread_set_no_change_tcb_state + ep_queues_blocked_lift ntfn_queues_blocked_lift + ready_queues_runnable_lift thread_set_weak_valid_sched_action) + apply (wpsimp wp: tcbSchedEnqueue_valid_tcbs' threadSet_sched_pointers + threadSet_valid_sched_pointers hoare_vcg_imp_lift' + threadSet_field_opt_pred) + apply (wpsimp wp: tcb_dequeue_not_queued') + apply (rule_tac Q'="\_. valid_tcbs' and valid_sched_pointers" + in hoare_post_imp) + apply clarsimp + apply wpsimp + apply (clarsimp simp: valid_pspace_def) + apply (fastforce simp: ready_or_release_def in_release_q_def in_ready_q_def) + apply fastforce + apply (rule corres_guard_imp) + apply (rule threadSet_not_queued_corres; + simp add: tcb_relation_def tcb_cap_cases_def tcb_cte_cases_def cteSizeBits_def) + apply (clarsimp simp: obj_at_def) + apply (fastforce dest!: in_correct_ready_q_in_ready_q simp: is_tcb_def) + apply fastforce done +crunch thread_set_priority + for ready_queues_runnable[wp]: ready_queues_runnable + and release_q_runnable[wp]: release_q_runnable + lemma setPriority_corres: "corres dc (einvs and tcb_at t and ct_not_in_release_q) @@ -1040,9 +1390,7 @@ lemma setPriority_corres: 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_stateAssert_ignore) - apply (fastforce intro: ready_qs_runnable_cross) - apply (rule corres_assert_assume[rotated], simp) + apply (rule corres_assert_gen_asm_cross_forwards, simp) apply (rule corres_split_forwards'[OF _ gts_sp gts_sp']) apply (corres corres: getThreadState_corres) apply fastforce @@ -1079,29 +1427,27 @@ lemma setPriority_corres: 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_valid_release_q) 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: 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 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 ntfnBlocked_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: sorted_ipc_queues_def) - apply (drule_tac x=y in spec) + apply (rename_tac p ls, drule_tac x=p 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) + apply (clarsimp simp: ep_blocked_def ntfn_blocked_def split: Structures_A.thread_state.splits) + apply (fastforce simp: ready_qs_runnable_def pred_tcb_at'_def obj_at'_def split: if_splits) done lemma setMCPriority_corres: @@ -1333,11 +1679,12 @@ lemma assertDerived_wp_weak: by (wpsimp simp: assertDerived_def) lemma setMCPriority_invs': - "\invs' and tcb_at' t\ setMCPriority t prio \\_. invs'\" - apply (clarsimp simp: setMCPriority_def) + "setMCPriority t prio \invs'\" + unfolding setMCPriority_def + apply clarsimp apply (rule bind_wp[OF _ assert_sp]) apply (rule hoare_gen_asm_conj) - apply (wpsimp wp: threadSet_invs_trivial) + apply (wpsimp wp: threadSet_invs_trivial simp: inQ_def) done lemma valid_tcb'_tcbMCP_update: @@ -1389,7 +1736,6 @@ lemma threadSet_invs_trivialT2: apply (rule hoare_pre) apply (rule hoare_gen_asm [where P="\tcb. is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits"]) apply (wp threadSet_valid_pspace'T - threadSet_iflive'T threadSet_ifunsafe'T threadSet_global_refsT valid_irq_node_lift @@ -1397,12 +1743,11 @@ lemma threadSet_invs_trivialT2: threadSet_ctes_ofT threadSet_valid_dom_schedule' untyped_ranges_zero_lift - sym_heap_sched_pointers_lift threadSet_valid_sched_pointers - threadSet_tcbInReleaseQueue threadSet_tcbQueued - threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of valid_bitmaps_lift + threadSet_field_inv sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + valid_bitmaps_lift | clarsimp simp: assms cteCaps_of_def valid_arch_tcb'_def | rule refl)+ apply (clarsimp simp: o_def) - by (auto simp: obj_at'_def) + done lemma getThreadBufferSlot_dom_tcb_cte_cases: "\\\ getThreadBufferSlot a \\rv s. rv \ (+) a ` dom tcb_cte_cases\" @@ -1535,11 +1880,12 @@ where = (tcb_at' dest and tcb_at' src and ex_nonz_cap_to' src and ex_nonz_cap_to' dest)" | "tcb_inv_wf' (tcbinvocation.NotificationControl t ntfn) = (tcb_at' t and ex_nonz_cap_to' t - and (case ntfn of None \ \ - | Some ntfnptr \ obj_at' (\ko. ntfnBoundTCB ko = None - \ (\q. ntfnObj ko \ WaitingNtfn q)) ntfnptr - and ex_nonz_cap_to' ntfnptr - and bound_tcb_at' ((=) None) t) )" + and (case ntfn of + None \ \ + | Some ntfnptr \ + obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnState ko \ Waiting) ntfnptr + and ex_nonz_cap_to' ntfnptr + and bound_tcb_at' ((=) None) t) )" | "tcb_inv_wf' (tcbinvocation.SetTLSBase ref w) = (tcb_at' ref and ex_nonz_cap_to' ref)" | "tcb_inv_wf' (tcbinvocation.SetFlags ref clears sets) @@ -1686,6 +2032,12 @@ crunch cteInsert for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers (wp: crunch_wps valid_replies'_lift) +crunch cap_insert + for ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + and ready_queues_runnable[wp]: ready_queues_runnable + (wp: ep_queues_blocked_lift ntfn_queues_blocked_lift ready_queues_runnable_lift) + lemma installThreadBuffer_corres: assumes "case_option (g' = None) (\(vptr,g''). \g'''. g' = Some (vptr, g''') \ newroot_rel g'' g''') g" and "g \ None \ sl' = cte_map slot" @@ -1730,10 +2082,12 @@ lemma installThreadBuffer_corres: apply (rule corres_split[OF getCurThread_corres], clarsimp) apply (rule corres_when[OF refl rescheduleRequired_corres]) apply (rule_tac Q'="\_. valid_objs and weak_valid_sched_action - and active_scs_valid - and in_correct_ready_q and ready_or_release and ready_qs_distinct - and pspace_aligned and pspace_distinct" - in hoare_strengthen_post[rotated], fastforce) + and active_scs_valid and in_correct_ready_q + and ready_or_release and ready_qs_distinct + and ep_queues_blocked and ntfn_queues_blocked + and ready_queues_runnable + and pspace_aligned and pspace_distinct" + in hoare_post_imp, fastforce) apply wp apply (rule_tac Q'="\_. valid_objs' and sym_heap_sched_pointers and valid_sched_pointers and pspace_aligned' and pspace_distinct' and pspace_bounded'" @@ -1748,7 +2102,9 @@ lemma installThreadBuffer_corres: thread_set_tcb_ipc_buffer_cap_cleared_invs thread_set_not_state_valid_sched thread_set_valid_objs' thread_set_cte_wp_at_trivial thread_set_ipc_tcb_cap_valid - thread_set_in_correct_ready_q) + thread_set_in_correct_ready_q ep_queues_blocked_lift + ntfn_queues_blocked_lift ready_queues_runnable_lift + thread_set_no_change_tcb_state) apply (clarsimp simp: option.case_eq_if if_fun_split) apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_all_lift threadSet_invs_trivial threadSet_cte_wp_at' threadSet_valid_objs' threadSet_sched_pointers @@ -1758,8 +2114,11 @@ lemma installThreadBuffer_corres: | strengthen use_no_cap_to_obj_asid_strg is_aligned_tcb_ipc_buffer_update invs_valid_objs2 invs_psp_aligned_strg invs_distinct[atomized] valid_sched_weak_strg valid_sched_active_scs_valid - valid_ready_qs_in_correct_ready_q valid_sched_valid_ready_qs - valid_sched_ready_or_release valid_ready_qs_ready_qs_distinct)+)[1] + sym_refs_ep_queues_blocked[OF invs_sym_refs] + sym_refs_ntfn_queues_blocked[OF invs_sym_refs] + valid_ready_qs_in_correct_ready_q valid_ready_qs_ready_queues_runnable + valid_sched_valid_ready_qs valid_sched_ready_or_release + valid_ready_qs_ready_qs_distinct)+)[1] apply (rule_tac Q'="\_ s. invs' s \ tcb_at' a s \ (g''' \ None \ valid_cap' (fst (the g''')) s) \ cte_wp_at' (\a. cteCap a = capability.NullCap) @@ -1885,12 +2244,14 @@ lemma setSchedContext_scTCB_update_valid_refills[wp]: by (fastforce simp: valid_refills'_def obj_at_simps opt_map_red opt_pred_def refillSize_def) lemma schedContextBindTCB_corres: - "corres dc (valid_objs and pspace_aligned and pspace_distinct and (\s. sym_refs (state_refs_of s)) - and valid_sched and simple_sched_action and bound_sc_tcb_at ((=) None) t - and current_time_bounded - and active_scs_valid and sc_tcb_sc_at ((=) None) ptr and ex_nonz_cap_to t and ex_nonz_cap_to ptr) - (invs' and ex_nonz_cap_to' t and ex_nonz_cap_to' ptr) - (sched_context_bind_tcb ptr t) (schedContextBindTCB ptr t)" + "corres dc + (valid_objs and valid_global_refs and pspace_aligned and pspace_distinct + and (\s. sym_refs (state_refs_of s)) + and valid_sched and simple_sched_action and bound_sc_tcb_at ((=) None) t + and current_time_bounded and active_scs_valid + and sc_tcb_sc_at ((=) None) ptr and ex_nonz_cap_to t and ex_nonz_cap_to ptr) + invs' + (sched_context_bind_tcb ptr t) (schedContextBindTCB ptr t)" apply (simp only: sched_context_bind_tcb_def schedContextBindTCB_def) apply (rule stronger_corres_guard_imp) apply clarsimp @@ -1914,23 +2275,27 @@ lemma schedContextBindTCB_corres: apply (wpsimp wp: tcbSchedEnqueue_valid_tcbs') apply wpsimp apply (wpsimp wp: threadGet_wp getTCB_wp getSchedulable_wp simp: inReleaseQueue_def) - apply (rule_tac Q'="\rv. valid_objs and pspace_aligned and pspace_distinct and (\s. sym_refs (state_refs_of s)) and - weak_valid_sched_action and active_scs_valid and - sc_tcb_sc_at ((=) (Some t)) ptr and current_time_bounded and - bound_sc_tcb_at (\sc. sc = Some ptr) t and - in_correct_ready_q and ready_or_release and ready_qs_distinct" + apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct + and (\s. sym_refs (state_refs_of s)) + and weak_valid_sched_action and active_scs_valid + and sc_tcb_sc_at ((=) (Some t)) ptr and current_time_bounded + and bound_sc_tcb_at (\sc. sc = Some ptr) t + and in_correct_ready_q and ready_or_release + and ready_qs_distinct and ready_queues_runnable" in hoare_strengthen_post[rotated]) apply (fastforce simp: schedulable_def2) apply (wp sched_context_resume_weak_valid_sched_action sched_context_resume_pred_tcb_at) - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated], fastforce) + apply (rule_tac Q'="\_. invs'" in hoare_post_imp) + apply (fastforce dest: runnable'_Not_tcbInReleaseQueue_not_sched_linked + simp: schedulable'_def) apply wp - apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct and - (\s. sym_refs (state_refs_of s)) and current_time_bounded and - valid_ready_qs and valid_release_q and weak_valid_sched_action and - active_scs_valid and scheduler_act_not t and - sc_tcb_sc_at ((=) (Some t)) ptr and - bound_sc_tcb_at (\a. a = Some ptr) t and - in_correct_ready_q and ready_or_release and ready_qs_distinct" + apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct + and (\s. sym_refs (state_refs_of s)) and current_time_bounded + and valid_ready_qs and valid_release_q and weak_valid_sched_action + and active_scs_valid and scheduler_act_not t + and sc_tcb_sc_at ((=) (Some t)) ptr + and bound_sc_tcb_at (\a. a = Some ptr) t + and in_correct_ready_q and ready_or_release and ready_qs_distinct" in hoare_strengthen_post[rotated]) apply (clarsimp simp: sc_tcb_sc_at_def obj_at_def valid_sched_action_def dest!: sym[of "Some _"]) apply (wpsimp simp: if_cond_refill_unblock_check_def @@ -1963,9 +2328,10 @@ lemma schedContextBindTCB_corres: apply (drule_tac tp=ta in sym_ref_tcb_sc) apply (fastforce+)[3] apply ((wpsimp wp: valid_irq_node_typ obj_set_prop_at get_sched_context_wp ssc_refs_of_Some - update_sched_context_valid_objs_same update_sched_context_iflive_update - update_sched_context_refs_of_update update_sched_context_cur_sc_tcb_None - update_sched_context_valid_idle valid_dom_schedule'_lift + update_sched_context_valid_objs_same + update_sched_context_iflive_update update_sched_context_refs_of_update + update_sched_context_cur_sc_tcb_None update_sched_context_valid_idle + valid_dom_schedule'_lift simp: invs'_def valid_pspace_def updateSchedContext_def | rule hoare_vcg_conj_lift update_sched_context_wp)+)[2] apply (clarsimp simp: pred_conj_def) @@ -1974,14 +2340,11 @@ lemma schedContextBindTCB_corres: set_tcb_sched_context_simple_weak_valid_sched_action | ((rule hoare_vcg_conj_lift)?, rule set_tcb_obj_ref_wp))+)[1] apply (clarsimp simp: pred_conj_def valid_pspace'_def cong: conj_cong) - apply (wp threadSet_valid_objs' threadSet_iflive' threadSet_not_inQ threadSet_ifunsafe'T - threadSet_idle'T threadSet_sch_actT_P[where P=False, simplified] threadSet_ctes_ofT - threadSet_mdb' valid_irq_node_lift - valid_irq_handlers_lift'' untyped_ranges_zero_lift threadSet_valid_dom_schedule' - threadSet_ct_idle_or_in_cur_domain' threadSet_cur threadSet_valid_replies' - sym_heap_sched_pointers_lift threadSet_tcbSchedNexts_of threadSet_tcbSchedPrevs_of - threadSet_valid_sched_pointers threadSet_tcbInReleaseQueue threadSet_tcbQueued - threadSet_cap_to + apply (wp threadSet_valid_objs' threadSet_ifunsafe'T threadSet_ctes_ofT + threadSet_mdb' valid_irq_node_lift valid_irq_handlers_lift'' + untyped_ranges_zero_lift threadSet_valid_dom_schedule' + threadSet_valid_replies' sym_heap_sched_pointers_lift + threadSet_valid_sched_pointers threadSet_field_inv threadSet_cap_to | clarsimp simp: tcb_cte_cases_def cteCaps_of_def cteSizeBits_def | rule hoare_vcg_conj_lift hoare_vcg_all_lift hoare_vcg_imp_lift' refl)+ apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def) @@ -2017,7 +2380,7 @@ lemma schedContextBindTCB_corres: apply (fastforce elim: ex_cap_to'_after_update simp: ko_wp_at'_def tcb_cte_cases_def cteSizeBits_def) apply (clarsimp simp: untyped_ranges_zero_inv_def cteCaps_of_def comp_def) - apply (fastforce simp: invs'_def dest!: global'_sc_no_ex_cap) + apply (fastforce dest: idle_sc_no_ex_cap[rotated]) apply (clarsimp simp: state_relation_def invs_def valid_state_def valid_pspace_def) apply (subgoal_tac "tcb_at' t s'") apply (clarsimp simp: pspace_relation_def pred_tcb_at_def pred_tcb_at'_def obj_at_def obj_at'_def) @@ -2101,17 +2464,8 @@ lemma installTCBCap_fh_ex_nonz_cap_to': objBits_defs cte_level_bits_def tcbFaultHandlerSlot_def) done -lemma threadSetPriority_ex_nonz_cap_to'[wp]: - "threadSetPriority param_a param_b \ex_nonz_cap_to' p\" - by (wpsimp wp: threadSet_cap_to' simp: threadSetPriority_def) - -crunch setPriority - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: crunch_wps simp: crunch_simps) - crunch setMCPriority - for tcb_at'[wp]: "tcb_at' t" - and weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" + for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" (wp: crunch_wps simp: crunch_simps inQ_def) lemma setMCPriority_ex_nonz_cap_to'[wp]: @@ -2233,9 +2587,7 @@ lemma tc_corres_sched: apply (frule (2) sym_ref_tcb_sc) apply (clarsimp simp: valid_obj_def valid_tcb_def obj_at_def sc_at_pred_n_def) apply (wpsimp wp: set_priority_valid_sched hoare_vcg_all_lift hoare_vcg_const_imp_lift) - apply (rule_tac Q'=" \_ s. invs' s \ tcb_at' t s \ ex_nonz_cap_to' t s \ - (\scp. sc_opt = Some (Some scp) \ ex_nonz_cap_to' scp s)" - in hoare_strengthen_post[rotated]) + apply (rule_tac Q'=" \_ s. invs' s \ tcb_at' t s" in hoare_post_imp) apply (clarsimp simp: obj_at'_def split: option.splits) apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_const_imp_lift) apply clarsimp @@ -2243,9 +2595,7 @@ lemma tc_corres_sched: apply simp apply clarsimp \ \the following is unified with one of the guard schematics\ - apply (prop_tac "invs' s' \ tcb_at' t s' \ ex_nonz_cap_to' t s' \ - (\x. p_auth = Some x \ fst x \ maxPriority) \ - (\scp. sc_opt = Some (Some scp) \ ex_nonz_cap_to' scp s')") + apply (prop_tac "invs' s' \ tcb_at' t s' \ (\x. p_auth = Some x \ fst x \ maxPriority)") apply assumption apply (clarsimp split: option.splits) apply (clarsimp simp: tcs_cross_asrt2_def) @@ -2282,8 +2632,7 @@ lemma tc_corres_sched: install_tcb_cap_ct_active hoare_vcg_all_lift hoare_weak_lift_imp hoare_lift_Pf3[where f=cur_thread, OF install_tcb_cap_released_sc_tcb_at install_tcb_cap_cur_thread]) - apply (rule_tac Q'="\_ s. invs' s \ tcb_at' t s \ ex_nonz_cap_to' t s \ - (\scp. sc_opt = Some (Some scp) \ ex_nonz_cap_to' scp s) \ + apply (rule_tac Q'="\_ s. invs' s \ tcb_at' t s \ (\p. p_auth = Some p \ fst p \ maxPriority) \ (\p. mcp_auth = Some p \ fst p \ maxPriority)" and E'="\_. \" in hoare_strengthen_postE[rotated], fastforce split: option.splits, simp) @@ -2309,13 +2658,11 @@ lemma tc_corres_sched: subgoal by (fastforce simp: pred_tcb_at_def is_ep_def is_tcb_def sc_at_ppred_def obj_at_def) apply (clarsimp simp: tcs_cross_asrt1_def) apply (intro conjI impI allI; clarsimp?) - apply (clarsimp simp: tcb_at_cte_at'_3) - apply (clarsimp simp: newroot_rel_def isCap_simps valid_fault_handler_def) - apply (case_tac a; clarsimp) - apply (clarsimp simp: newroot_rel_def isCap_simps valid_fault_handler_def) - apply (case_tac a; clarsimp) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb projectKO_ep) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_sc projectKO_ep) + apply (clarsimp simp: tcb_at_cte_at'_3) + apply (clarsimp simp: newroot_rel_def isCap_simps valid_fault_handler_def) + apply (case_tac a; clarsimp) + apply (clarsimp simp: newroot_rel_def isCap_simps valid_fault_handler_def) + apply (case_tac a; clarsimp) apply (clarsimp simp: tcs_cross_asrt1_def) apply (intro conjI impI allI) apply (drule (1) tcb_ep_slot_cte_wp_ats) @@ -2328,12 +2675,12 @@ lemma tc_corres_sched: valid_pspace_def pred_tcb_at_def pred_tcb_at'_def obj_at_def obj_at'_def) apply (drule_tac x=t in bspec, clarsimp) apply (clarsimp simp: tcb_relation_cut_def tcb_relation_def projectKOs) - apply (fastforce elim: tcb_at_cross) + apply (force intro: tcb_at_cross) apply (subgoal_tac "sc_at' x s'") apply (clarsimp simp: state_relation_def pspace_relation_def invs_def valid_state_def valid_pspace_def sc_at_ppred_def obj_at_def obj_at'_def) apply (drule_tac x=x in bspec, clarsimp) - apply (clarsimp simp: other_obj_relation_def sc_relation_def projectKOs split: if_splits) + apply (clarsimp simp: sc_relation_def projectKOs split: if_splits) apply (fastforce elim: sc_at_cross) done @@ -2356,8 +2703,8 @@ lemma tc_caps_invs': done lemma schedContextBindTCB_invs': - "\\s. invs' s \ ex_nonz_cap_to' tcbPtr s \ ex_nonz_cap_to' scPtr s \ - bound_sc_tcb_at' (\sc. sc = None) tcbPtr s \ obj_at' (\sc. scTCB sc = None) scPtr s\ + "\\s. invs' s + \ bound_sc_tcb_at' (\sc. sc = None) tcbPtr s \ obj_at' (\sc. scTCB sc = None) scPtr s\ schedContextBindTCB scPtr tcbPtr \\_. invs'\" apply (simp add: schedContextBindTCB_def updateSchedContext_def) @@ -2372,13 +2719,12 @@ lemma schedContextBindTCB_invs': apply (wpsimp wp: hoare_vcg_imp_lift' simp: ifCondRefillUnblockCheck_def) apply (rule_tac Q'="\_ s. invs' s" in hoare_strengthen_post[rotated], simp) apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) - apply (wp threadSet_valid_objs' threadSet_mdb' threadSet_iflive' + apply (wp threadSet_valid_objs' threadSet_mdb' threadSet_cap_to threadSet_ifunsafe'T threadSet_ctes_ofT untyped_ranges_zero_lift valid_irq_node_lift valid_irq_handlers_lift'' hoare_vcg_const_imp_lift hoare_vcg_imp_lift' - threadSet_valid_replies' threadSet_valid_sched_pointers threadSet_tcbInReleaseQueue - sym_heap_sched_pointers_lift threadSet_tcbSchedNexts_of threadSet_tcbSchedPrevs_of - threadSet_tcbQueued hoare_vcg_all_lift hoare_vcg_imp_lift' + threadSet_valid_replies' threadSet_valid_sched_pointers threadSet_field_inv + sym_heap_sched_pointers_lift hoare_vcg_all_lift hoare_vcg_imp_lift' | clarsimp simp: tcb_cte_cases_def cteCaps_of_def cteSizeBits_def)+ apply (clarsimp simp: invs'_def valid_pspace'_def valid_dom_schedule'_def) by (fastforce simp: pred_tcb_at'_def obj_at'_def @@ -2455,11 +2801,11 @@ lemma tc_sched_invs': \\_. invs'\" apply (simp add: invokeTCB_def) apply (wpsimp wp: schedContextUnbindTCB_invs' schedContextBindTCB_invs' threadGet_wp) - apply (rule_tac Q'="\rv s. invs' s \ ex_nonz_cap_to' t s \ + apply (rule_tac Q'="\rv s. invs' s \ (sc_opt = Some None \ bound_sc_tcb_at' (\sc. sc \ Some idle_sc_ptr) t s) \ (\x. sc_opt = Some (Some x) \ - ex_nonz_cap_to' x s \ obj_at' (\sc. scTCB sc = None) x s \ + obj_at' (\sc. scTCB sc = None) x s \ bound_sc_tcb_at' (\sc. sc = None) t s \ bound_sc_tcb_at' bound (ksCurThread s) s)" in hoare_strengthen_post[rotated]) @@ -2523,6 +2869,8 @@ lemma invokeTCB_corres: apply (rule rescheduleRequired_corres) apply (rule corres_trivial, simp) apply (solves \wpsimp wp: hoare_drop_imp\)+ + apply clarsimp + apply (frule invs_sym_refs) apply (fastforce dest: valid_sched_valid_ready_qs) apply fastforce apply (clarsimp simp: invokeTCB_def invokeSetFlags_def bind_assoc) @@ -2544,33 +2892,23 @@ lemma tcbBoundNotification_caps_safe[simp]: by (case_tac tcb, simp add: tcb_cte_cases_def cteSizeBits_def) lemma bindNotification_invs': - "\bound_tcb_at' ((=) None) tcbptr - and ex_nonz_cap_to' ntfnptr - and ex_nonz_cap_to' tcbptr - and obj_at' (\ntfn. ntfnBoundTCB ntfn = None \ (\q. ntfnObj ntfn \ WaitingNtfn q)) ntfnptr - and invs'\ - bindNotification tcbptr ntfnptr - \\_. invs'\" - unfolding bindNotification_def invs'_def valid_dom_schedule'_def + "\invs' and tcb_at' tcbPtr\ bindNotification tcbPtr ntfnPtr \\_. invs'\" + unfolding bindNotification_def updateNotification_def invs'_def valid_dom_schedule'_def bind_assoc apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (wpsimp wp: set_ntfn_valid_pspace' sbn_sch_act' valid_irq_node_lift - setBoundNotification_ct_not_inQ valid_bound_ntfn_lift + apply (wpsimp wp: set_ntfn_valid_pspace' valid_irq_node_lift + valid_bound_ntfn_lift untyped_ranges_zero_lift irqs_masked_lift sym_heap_sched_pointers_lift simp: cteCaps_of_def) apply (frule(1) ntfn_ko_at_valid_objs_valid_ntfn'[OF _ valid_pspace_valid_objs']) - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def valid_ntfn'_def projectKOs o_def - global'_no_ex_cap - split: ntfn.splits) + apply (clarsimp simp: valid_ntfn'_def o_def) done lemma tcbntfn_invs': - "\invs' and tcb_inv_wf' (tcbinvocation.NotificationControl tcb ntfnptr)\ - invokeTCB (tcbinvocation.NotificationControl tcb ntfnptr) - \\rv. invs'\" - apply (simp add: invokeTCB_def) - apply (case_tac ntfnptr, simp_all) - apply (wp unbindNotification_invs bindNotification_invs' | simp)+ - done + "\invs' and tcb_at' tcbPtr\ + invokeTCB (tcbinvocation.NotificationControl tcbPtr ntfnPtr) + \\_. invs'\" + unfolding invokeTCB_def + by (wpsimp wp: unbindNotification_invs bindNotification_invs') lemma setTLSBase_invs'[wp]: "\invs' and tcb_inv_wf' (tcbinvocation.SetTLSBase tcb tls_base)\ @@ -2616,7 +2954,7 @@ lemma tcbinv_invs': apply (clarsimp simp: invs'_def dest!: global'_no_ex_cap) apply (wpsimp wp: tc_caps_invs' tc_sched_invs' writereg_invs' readreg_invs' - copyreg_invs' tcbntfn_invs')+ + copyreg_invs'' tcbntfn_invs')+ done declare assertDerived_wp [wp] @@ -3006,16 +3344,7 @@ lemma decodeSetSchedParams_corres: apply (clarsimp simp: newroot_rel_def) apply (wpsimp wp: check_prio_inv checkPrio_inv thread_get_wp' threadGet_wp)+ apply (fastforce simp: valid_cap_def) - apply (clarsimp simp: valid_cap_simps') - apply normalise_obj_at' - apply (intro exI impI conjI allI) - apply (clarsimp simp: obj_at'_def ko_wp_at'_def) - apply (rename_tac obj) - apply (case_tac obj; clarsimp) - apply (erule invs_valid_objs') - apply (clarsimp simp: obj_at'_def) - apply fastforce - apply fastforce + apply (fastforce simp: valid_cap_simps') done lemma checkValidIPCBuffer_corres: @@ -3490,7 +3819,7 @@ notes if_cong[cong] shows (decodeBindNotification (capability.ThreadCap t) extras')" apply (simp add: decode_bind_notification_def decodeBindNotification_def) apply (simp add: null_def returnOk_def) - apply (rule corres_guard_imp) + apply (rule stronger_corres_guard_imp) apply (rule corres_split_norE) apply (rule corres_trivial) apply (auto simp: returnOk_def whenE_def)[1] @@ -3510,15 +3839,46 @@ notes if_cong[cong] shows apply (rule corres_splitEE[where r'=ntfn_relation]) apply simp apply (rule getNotification_corres) + apply (clarsimp simp: assertE_liftE) + apply (simp add: liftE_bindE bind_assoc) + apply (rule corres_assert_assume_r) + apply (clarsimp simp: stateAssertE_def) + apply (simp add: liftE_bindE bind_assoc) + apply (rule corres_stateAssert_r) apply (rule corres_trivial, simp split del: if_split) apply (simp add: ntfn_relation_def - split: Structures_A.ntfn.splits Structures_H.ntfn.splits - option.splits) - apply wp+ - apply (wp | simp add: whenE_def split del: if_split)+ - apply (wp | wpc | simp)+ + split: Structures_A.ntfn.splits option.splits) + apply (wpsimp wp: getNotification_wp)+ apply (simp | wp gbn_wp gbn_wp')+ - apply (fastforce simp: valid_cap_def valid_cap'_def obj_at_def is_tcb dest: hd_in_set)+ + apply (fastforce simp: valid_cap_def valid_cap'_def obj_at_def is_tcb dest: hd_in_set) + apply clarsimp + apply (rename_tac capNtfnPtr capNtfnBadge capNtfnCanSend ntfn') + apply (frule state_relation_pspace_relation) + apply (clarsimp simp: pspace_relation_heap_pspace_relation) + apply (frule heap_pspace_relation_ntfns_relation) + apply (frule_tac ptr=capNtfnPtr in ntfns_relation_ntfn_relation_conc[rotated]) + apply (fastforce simp: obj_at'_def) + apply clarsimp + apply (rename_tac ntfn) + apply (frule state_relation_ntfn_queues_relation) + apply (clarsimp simp: ntfn_queues_relation_def) + apply (drule_tac x=capNtfnPtr in spec) + apply (drule_tac x="ntfn_queue (ntfn_obj ntfn)" in spec) + apply (clarsimp simp: opt_map_red) + apply (drule_tac x="ntfnQueue ntfn'" in spec) + apply (elim impE) + apply (clarsimp simp: opt_map_red obj_at'_def) + apply (frule list_queue_relation_tcb_queue_head_end_valid) + apply (frule_tac p=capNtfnPtr + and q="ntfn_queue (ntfn_obj ntfn)" + in in_ntfn_queue_sched_flag_set[OF sym_refs_ntfn_queues_blocked[OF invs_sym_refs]]) + apply fastforce+ + apply (fastforce simp: opt_map_red) + apply fastforce + apply (frule valid_objs_valid_ntfn[OF invs_valid_objs]) + apply fastforce + apply (frule list_queue_relation_Nil) + apply (case_tac "ntfn_obj ntfn"; clarsimp simp: valid_ntfn_def ntfn_relation_def) done lemma decodeUnbindNotification_corres: @@ -3624,7 +3984,7 @@ lemma decodeBindNotification_wf: apply (rule hoare_pre) apply (wp getNotification_wp getObject_tcb_wp | wpc - | simp add: threadGet_getObject getBoundNotification_def)+ + | simp add: threadGet_getObject getBoundNotification_def stateAssertE_def)+ apply (fastforce simp: valid_cap'_def[where c="capability.ThreadCap t"] is_ntfn invs_def valid_pspace'_def null_def pred_tcb_at'_def obj_at'_def diff --git a/proof/refine/RISCV64/Untyped_R.thy b/proof/refine/RISCV64/Untyped_R.thy index af6767a280..0b07533153 100644 --- a/proof/refine/RISCV64/Untyped_R.thy +++ b/proof/refine/RISCV64/Untyped_R.thy @@ -1415,16 +1415,16 @@ crunch updateMDB, updateNewFreeIndex, setCTE (tcbInReleaseQueue |< tcbs_of' s)" and rdyq_projs[wp]: "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" + and epqs_projs[wp]: + "\s. P (epQueues_of s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + and ntfnqs_projs[wp]: + "\s. P (ntfnQueues_of s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" crunch set_cap, set_cdt for domain_index[wp]: "\s. P (domain_index s)" and reprogram_timer[wp]: "\s. P (reprogram_timer s)" (wp: crunch_wps) -crunch updateMDB, updateNewFreeIndex, setCTE - for rdyq_projs[wp]: - "\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) (\d p. inQ d p |< tcbs_of' s)" - lemma insertNewCap_corres: notes if_cong[cong del] if_weak_cong[cong] shows @@ -3669,10 +3669,9 @@ lemma updateFreeIndex_clear_invs': apply (clarsimp simp:invs'_def valid_dom_schedule'_def) apply (wp updateFreeIndex_valid_pspace_no_overlap') apply (simp add: updateFreeIndex_def updateTrackedFreeIndex_def) - apply (wp updateFreeIndex_valid_pspace_no_overlap' sch_act_wf_lift - updateCap_iflive' tcb_in_cur_domain'_lift + apply (wp updateFreeIndex_valid_pspace_no_overlap' sym_heap_sched_pointers_lift valid_bitmaps_lift - | simp add: pred_tcb_at'_def)+ + | simp add: pred_tcb_at'_def)+ apply (rule hoare_vcg_conj_lift) apply (simp add: ifunsafe'_def3 cteInsert_def setUntypedCapAsFull_def split del: if_split) @@ -3682,7 +3681,7 @@ lemma updateFreeIndex_clear_invs': apply (simp add:updateCap_def) apply (wp setCTE_irq_handlers' getCTE_wp) apply (simp add:updateCap_def) - apply (wp irqs_masked_lift cur_tcb_lift ct_idle_or_in_cur_domain'_lift + apply (wp irqs_masked_lift cur_tcb_lift hoare_vcg_disj_lift untyped_ranges_zero_lift getCTE_wp | wp (once) hoare_use_eq[where f="gsUntypedZeroRanges"] | simp add: getSlotCap_def @@ -4722,8 +4721,13 @@ lemma inv_untyped_corres': "\ untypinv_relation ui ui' \ \ corres (dc \ (=)) (einvs and valid_machine_time and valid_untyped_inv ui and ct_active and schact_is_rct) - (invs' and valid_untyped_inv' ui' and ct_active' and (\s. sym_refs (state_refs_of' s))) + (invs' and valid_untyped_inv' ui' and ct_active') (invoke_untyped ui) (invokeUntyped ui')" + apply add_sym_refs + apply add_sch_act_wf + apply (rule_tac Q'="\s. sym_refs (state_refs_of' s)" in corres_cross_add_guard, simp) + apply (rule_tac Q'="\s. weak_sch_act_wf (ksSchedulerAction s) s" in corres_cross_add_guard) + apply (clarsimp simp: weak_sch_act_wf_def) apply (cases ui) apply (rule corres_name_pre) apply (clarsimp simp only: valid_untyped_inv_wcap @@ -4742,6 +4746,7 @@ lemma inv_untyped_corres': assume invs: "invs (s :: det_state)" "ct_active s" "valid_list s" "valid_sched s" "schact_is_rct s" "valid_machine_time s" and invs': "invs' s'" "ct_active' s'" "sym_refs (state_refs_of' s')" + "weak_sch_act_wf (ksSchedulerAction s') s'" and sr: "(s, s') \ state_relation" and vui: "valid_untyped_inv_wcap ?ui (Some (cap.UntypedCap dev (ptr && ~~ mask sz) sz idx)) s" (is "valid_untyped_inv_wcap _ (Some ?cap) s") @@ -5242,13 +5247,6 @@ lemma insertNewCap_ifunsafe'[wp]: crunch updateNewFreeIndex for if_live_then_nonz_cap'[wp]: "if_live_then_nonz_cap'" -lemma insertNewCap_iflive'[wp]: - "\if_live_then_nonz_cap'\ insertNewCap parent slot cap \\rv. if_live_then_nonz_cap'\" - apply (simp add: insertNewCap_def) - apply (wp setCTE_iflive' getCTE_wp') - apply (clarsimp elim!: cte_wp_at_weakenE') - done - lemma insertNewCap_cte_wp_at'': "\cte_wp_at' (\cte. P (cteCap cte)) p and K (\ P NullCap)\ insertNewCap parent slot cap @@ -5308,15 +5306,6 @@ lemma insertNewCap_valid_irq_handlers: apply auto done -lemma insertNewCap_ct_idle_or_in_cur_domain'[wp]: - "\ct_idle_or_in_cur_domain' and ct_active'\ insertNewCap parent slot cap \\_. ct_idle_or_in_cur_domain'\" -apply (wp ct_idle_or_in_cur_domain'_lift_futz[where Q=\]) -apply (rule_tac Q'="\_. obj_at' (\tcb. tcbState tcb \ Structures_H.thread_state.Inactive) t and obj_at' (\tcb. d = tcbDomain tcb) t" - in hoare_strengthen_post) -apply (wp | clarsimp elim: obj_at'_weakenE)+ -apply (auto simp: obj_at'_def) -done - crunch insertNewCap for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" (wp: crunch_simps hoare_drop_imps) @@ -5698,7 +5687,7 @@ lemma invokeUntyped_invs'[wp]: done lemma resetUntypedCap_st_tcb_at': - "\invs' and (\s. sym_refs (state_refs_of' s)) + "\invs' and st_tcb_at' (P and ((\) Inactive) and ((\) IdleThreadState)) t and cte_wp_at' (\cp. isUntypedCap (cteCap cp)) slot and ct_active' and sch_act_simple and (\s. descendants_of' slot (ctes_of s) = {})\ @@ -5706,7 +5695,7 @@ lemma resetUntypedCap_st_tcb_at': \\_. st_tcb_at' P t\" apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) apply (rule_tac - P'="\s. \d v0 v1 f. invs' s \ sym_refs (state_refs_of' s) + P'="\s. \d v0 v1 f. invs' s \ st_tcb_at' (P and (\) Structures_H.thread_state.Inactive and (\) Structures_H.thread_state.IdleThreadState) t s \ (cte_wp_at' (\cp. cteCap cp = capability.UntypedCap d v0 v1 f) slot s) diff --git a/proof/refine/Retype_R.thy b/proof/refine/Retype_R.thy index 4e4aad9204..8b82ddead6 100644 --- a/proof/refine/Retype_R.thy +++ b/proof/refine/Retype_R.thy @@ -53,7 +53,7 @@ lemma valid_obj_makeObject_cte [simp]: lemma valid_obj_makeObject_endpoint [simp]: "valid_obj' (KOEndpoint makeObject) s" - unfolding valid_obj'_def valid_ep'_def + unfolding valid_obj'_def by (clarsimp simp: makeObject_endpoint) lemma valid_obj_makeObject_notification [simp]: @@ -448,12 +448,24 @@ locale Retype_R = makeObjectKO dev us d tp = Some v \ (v = KOReply reply) = (tp = Inr (APIObjectType ArchTypes_H.apiobject_type.ReplyObject) \ reply = makeObject)" + "\v endpoint tp dev us d. + makeObjectKO dev us d tp = Some v \ + (v = KOEndpoint endpoint) + = (tp = Inr (APIObjectType ArchTypes_H.apiobject_type.EndpointObject) \ endpoint = makeObject)" + "\v ntfn tp dev us d. + makeObjectKO dev us d tp = Some v \ + (v = KONotification ntfn) + = (tp = Inr (APIObjectType ArchTypes_H.apiobject_type.NotificationObject) \ ntfn = makeObject)" assumes APIType_map2_Untyped[simp]: "\tp. (APIType_map2 tp = Structures_A.Untyped) = (tp = Inr (APIObjectType ArchTypes_H.Untyped))" assumes APIType_map2_TCBObject[simp]: "\tp. (APIType_map2 tp = Structures_A.TCBObject) = (tp = Inr (APIObjectType ArchTypes_H.TCBObject))" assumes APIType_map2_SchedContext[simp]: "\tp. (APIType_map2 tp = Structures_A.SchedContextObject) = (tp = Inr (APIObjectType SchedContextObject))" + assumes APIType_map2_Endpoint[simp]: + "\tp. (APIType_map2 tp = Structures_A.EndpointObject) = (tp = Inr (APIObjectType EndpointObject))" + assumes APIType_map2_Notification[simp]: + "\tp. (APIType_map2 tp = Structures_A.NotificationObject) = (tp = Inr (APIObjectType NotificationObject))" assumes APIType_capBits_generic[simp]: "\api us. APIType_capBits (APIObjectType api) us = APIType_capBits_gen api us" assumes toAPIType_Some[simp]: @@ -470,10 +482,6 @@ locale Retype_R = "\ko. 0 < objBitsKO ko" assumes arch_tcb_relation_default: "arch_tcb_relation default_arch_tcb newArchTCB" - assumes obj_relation_retype_other_obj: - "\ko ko'. - \ is_other_obj_relation_type (a_type ko); other_obj_relation ko ko' \ - \ obj_relation_retype ko ko'" assumes update_gs_id: "\tp us addrs. tp \ no_gs_types \ update_gs tp us addrs = id" assumes valid_untyped'_helper_arch_cap: @@ -580,13 +588,6 @@ locale Retype_R = \\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ P (list_refs_of_replies' s)\ createNewCaps ty ptr n us dev \\_ s. P (list_refs_of_replies' s)\" - assumes createNewCaps_iflive': - "\ty ptr n us dev sz. - \range_cover ptr sz (APIType_capBits ty us) n; n \ 0; - ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ sc_size_bounds us\ \ - \\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ if_live_then_nonz_cap' s\ - createNewCaps ty ptr n us dev - \\rv. if_live_then_nonz_cap'\" assumes createNewCaps_global_refs': "\ty ptr n us d sz. \\s. range_cover ptr sz (APIType_capBits ty us) n \ n \ 0 \ pspace_aligned' s \ @@ -620,11 +621,11 @@ begin lemma valid_obj_makeObject_tcb[simp]: "valid_obj' (KOTCB makeObject) s" by (simp add: valid_obj'_def valid_tcb'_def makeObject_tcb tcb_cte_cases_def tcb_cte_cases_neqs - VPtr_def valid_tcb_state'_def minBound_word makeObject_cte) + VPtr_def minBound_word makeObject_cte) lemma valid_obj_makeObject_tcb_tcbDomain_update[simp]: "d \ maxDomain \ valid_obj' (KOTCB (tcbDomain_update (\_. d) makeObject)) s" - unfolding valid_obj'_def valid_tcb'_def valid_tcb_state'_def + unfolding valid_obj'_def valid_tcb'_def by (clarsimp simp: makeObject_tcb makeObject_cte gen_objBits_simps minBound_word VPtr_def tcb_cte_cases_def tcb_cte_cases_neqs) @@ -647,7 +648,8 @@ lemma state_relation_null_filterE: null_filter (caps_of_state t) = null_filter (caps_of_state s); null_filter' (ctes_of t') = null_filter' (ctes_of s'); pspace_relation (kheap t) (ksPSpace t'); - sc_replies_relation t t'; ready_queues_relation t t'; release_queue_relation t t'; + sc_replies_relation t t'; ep_queues_relation t t'; ntfn_queues_relation t t'; + ready_queues_relation t t'; release_queue_relation t t'; (arch_state t, ksArchState t') \ arch_state_relation; ghost_relation_wrapper t t'; valid_list s; @@ -1487,7 +1489,6 @@ proof - apply (clarsimp simp: makeObjectKO_gen_def makeObject_sc default_sched_context_def opt_map_def projectKO_opt_sc) apply (erule notE) - apply (clarsimp simp: pspace_relation_def) apply (simp add: obj_relation_retype_addrs_eq[OF not_unt tysc num_r orr cover,symmetric]) apply (clarsimp simp: scs_of_kh_def opt_map_Some sc_replies_of_scs_def map_project_Some) apply (fold foldr_upd_app_if[folded data_map_insert_def]) @@ -1502,6 +1503,95 @@ proof - done qed +lemma retype_ep_queues_relation: + assumes sr: "ep_queues_relation s s'" + and pr: "pspace_relation (kheap s) (ksPSpace s')" + and vs': "pspace_aligned' s'" "pspace_distinct' s'" + and pn': "pspace_no_overlap' ptr sz s'" + and ko: "makeObjectKO dev us d ty = Some ko" + and tysc: "ty = Inr (APIObjectType SchedContextObject) \ min_sched_context_bits \ us" + and cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" + and orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us d) ko" + and num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" + shows + "ep_queues_relation + (s \kheap := foldr (\p. data_map_insert p (default_object (APIType_map2 ty) dev us d)) + (retype_addrs ptr (APIType_map2 ty) n us) (kheap s)\) + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\)" +proof - + have not_unt: "ty \ Inr (APIObjectType ArchTypes_H.Untyped)" + by (rule makeObjectKO_Untyped[OF ko]) + + show ?thesis + using sr pr + unfolding ep_queues_relation_def + apply (clarsimp simp: eps_of_kh_def elim!: opt_mapE) + apply (rename_tac p ep ep') + apply (drule_tac x=p in spec) + apply (drule_tac x="ep_queue ep" in spec) + apply (clarsimp simp: foldr_upd_app_if[folded data_map_insert_def] split: if_split_asm) + apply (case_tac "p \ set (new_cap_addrs m ptr ko)") + apply (case_tac "APIType_map2 ty"; simp add: default_object_def not_unt) + using ko + apply (clarsimp simp: makeObjectKO_gen_def makeObject_endpoint default_ep_def) + apply clarsimp + apply (erule notE) + apply (clarsimp simp: obj_relation_retype_addrs_eq[OF not_unt tysc num_r orr cover, symmetric]) + using obj_relation_retype_addrs_eq[OF not_unt tysc num_r orr cover,symmetric] ko + apply (clarsimp simp: makeObjectKO_gen_def default_object_def + APIType_map2_gen_def makeObjectKO_eq) + apply (clarsimp simp: eps_of_kh_def opt_map_Some) + apply (fold foldr_upd_app_if[folded data_map_insert_def]) + apply (simp add: retype_tcbSchedPrevs_of[OF vs' pn' ko tysc cover num_r, simplified] + retype_tcbSchedNexts_of[OF vs' pn' ko tysc cover num_r, simplified]) + done +qed + +lemma retype_ntfn_queues_relation: + assumes sr: "ntfn_queues_relation s s'" + and pr: "pspace_relation (kheap s) (ksPSpace s')" + and vs': "pspace_aligned' s'" "pspace_distinct' s'" + and pn': "pspace_no_overlap' ptr sz s'" + and ko: "makeObjectKO dev us d ty = Some ko" + and tysc: "ty = Inr (APIObjectType SchedContextObject) \ min_sched_context_bits \ us" + and cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" + and orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us d) ko" + and num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" + shows + "ntfn_queues_relation + (s \kheap := foldr (\p. data_map_insert p (default_object (APIType_map2 ty) dev us d)) + (retype_addrs ptr (APIType_map2 ty) n us) (kheap s)\) + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\)" +proof - + have not_unt: "ty \ Inr (APIObjectType ArchTypes_H.Untyped)" + by (rule makeObjectKO_Untyped[OF ko]) + + show ?thesis + using sr pr + unfolding ntfn_queues_relation_def + apply (clarsimp elim!: opt_mapE) + apply (rename_tac p ntfn ntfn') + apply (drule_tac x=p in spec) + apply (drule_tac x="ntfn_queue (ntfn_obj ntfn)" in spec) + apply (clarsimp simp: foldr_upd_app_if[folded data_map_insert_def] split: if_split_asm) + apply (case_tac "p \ set (new_cap_addrs m ptr ko)") + apply (case_tac "APIType_map2 ty"; simp add: default_object_def not_unt) + using ko + apply (clarsimp simp: makeObjectKO_gen_def makeObject_notification default_ntfn_def + default_notification_def) + apply clarsimp + apply (simp add: obj_relation_retype_addrs_eq[OF not_unt tysc num_r orr cover, symmetric]) + apply (erule notE) + using obj_relation_retype_addrs_eq[OF not_unt tysc num_r orr cover,symmetric] ko + apply (clarsimp simp: makeObjectKO_gen_def default_object_def + APIType_map2_gen_def makeObjectKO_eq) + apply (clarsimp simp: opt_map_Some) + apply (fold foldr_upd_app_if[folded data_map_insert_def]) + apply (simp add: retype_tcbSchedPrevs_of[OF vs' pn' ko tysc cover num_r, simplified] + retype_tcbSchedNexts_of[OF vs' pn' ko tysc cover num_r, simplified]) + done +qed + lemma retype_ready_queues_relation: assumes rlqr: "ready_queues_relation s s'" assumes vs': "pspace_aligned' s'" "pspace_distinct' s'" @@ -1896,14 +1986,6 @@ locale Retype_R_2 = Retype_R + \\_ s. P (null_filter' (ctes_of s))\" assumes retype_mdb_valid_n: (* retype_mdb.valid_n, needs Arch *) "\m P. retype_mdb m P \ valid_mdb_ctes (\p. if P p then Some makeObject else m p)" - assumes createNewCaps_idle'[wp]: - "\ptr sz ty us n d. - \valid_idle' and valid_pspace' and pspace_no_overlap' ptr sz - and K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) - and K (range_cover ptr sz (APIType_capBits ty us) n \ n \ 0)\ - createNewCaps ty ptr n us d - \\rv. valid_idle'\" assumes createNewCaps_valid_arch_state: "\ty ptr n us d sz tp. \(\s. valid_arch_state' s \ valid_pspace' s \ pspace_no_overlap' ptr sz s \ @@ -2430,21 +2512,6 @@ lemma word_to_tcb_flags_0[simp]: context Retype_R begin -lemma other_objs_default_relation: - "\ case ty of Structures_A.EndpointObject \ ko = injectKO (makeObject :: endpoint) - | Structures_A.NotificationObject \ ko = injectKO (makeObject :: notification) - | _ \ False \ \ - obj_relation_retype (default_object ty dev n d) ko" - apply (rule obj_relation_retype_other_obj) - apply (clarsimp simp: default_object_def - split: Structures_A.apiobject_type.split_asm) - apply (clarsimp simp: other_obj_relation_def default_object_def - ep_relation_def ntfn_relation_def - default_ep_def makeObject_endpoint default_notification_def - makeObject_notification default_ntfn_def - split: Structures_A.apiobject_type.split_asm) - done - lemma tcb_relation_retype: "obj_relation_retype (default_object Structures_A.TCBObject dev n d) (KOTCB (tcbDomain_update (\_. d) makeObject))" @@ -2487,6 +2554,20 @@ lemma reply_relation_retype: makeObject_reply obj_relation_retype_def gen_objBits_simps word_bits_def replySizeBits_def RISCV64.wordSizeCase_simp) (*FIXME arch-split RT*) +lemma ep_relation_retype: + "obj_relation_retype (default_object Structures_A.EndpointObject dev n d) + (KOEndpoint makeObject)" + by (clarsimp simp: default_object_def obj_relation_retype_def ep_relation_def default_ep_def + makeObject_endpoint ep_relation_cut_def epSizeBits_def gen_objBits_simps) + +lemma ntfn_relation_retype: + "obj_relation_retype (default_object Structures_A.NotificationObject dev n d) + (KONotification makeObject)" + by (clarsimp simp: default_object_def obj_relation_retype_def ntfn_relation_def + default_ntfn_def default_notification_def + makeObject_notification ntfn_relation_cut_def + ntfnSizeBits_def gen_objBits_simps RISCV64.wordSizeCase_simp) (*FIXME arch-split RT*) + lemma sc_relation_retype: "\sc_size_bounds n\ \ obj_relation_retype (default_object Structures_A.SchedContextObject dev n d) @@ -3324,29 +3405,6 @@ lemma createObjects_state_hyp_refs_of'': apply simp+ done -lemma createObjects_iflive': - "\\s. if_live_then_nonz_cap' s \ \ live' val - \ n \ 0 - \ range_cover ptr sz (objBitsKO val + gbits) n - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s - \ pspace_no_overlap' ptr sz s\ - createObjects' ptr n val gbits - \\rv s. if_live_then_nonz_cap' s\" - apply (rule hoare_pre) - apply (simp only: if_live_then_nonz_cap'_def - ex_nonz_cap_to'_def imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift - hoare_vcg_ex_lift createObjects_orig_ko_wp_at2' - createObjects_orig_cte_wp_at') - apply clarsimp - apply (intro conjI allI impI) - apply simp_all - apply (rule ccontr) - apply clarsimp - apply (drule(1) if_live_then_nonz_capE') - apply (fastforce simp: ex_nonz_cap_to'_def) - done - lemma createObjects_pspace_only: "\ \f s. P (ksPSpace_update f s) = P s \ \ \P\ createObjects' ptr n val gbits \\rv. P\" @@ -3355,32 +3413,6 @@ lemma createObjects_pspace_only: apply wpsimp done -lemma sch_act_wf_lift_asm: - assumes tcb: "\P t. \st_tcb_at' P t and Q \ f \\rv. st_tcb_at' P t\" - assumes tcbDomain: "\P t. \obj_at' (\tcb. P (tcbDomain tcb)) t and Q\ f \\rv. obj_at' (\tcb. P (tcbDomain tcb)) t\" - assumes kCT: "\P. \\s. P (ksCurThread s)\ f \\_ s. P (ksCurThread s)\" - assumes kCD: "\P. \\s. P (ksCurDomain s)\ f \\_ s. P (ksCurDomain s)\" - assumes ksA: "\P. \\s. P (ksSchedulerAction s)\ f \\_ s. P (ksSchedulerAction s)\" - shows - "\\s. sch_act_wf (ksSchedulerAction s) s \ Q s\ - f - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (clarsimp simp: valid_def) - apply (rule use_valid [OF _ ksA], assumption) - apply (frule use_valid[OF _ kCT[of "(=) (ksCurThread s)" for s] refl]) - apply (frule use_valid[OF _ kCD[of "(=) (ksCurDomain s)" for s] refl]) - apply (case_tac "ksSchedulerAction s") - apply (simp add: ct_in_state'_def) - apply (drule use_valid [OF _ tcb]) - apply simp - apply simp - apply simp - apply (clarsimp simp: tcb_in_cur_domain'_def) - apply (frule use_valid [OF _ tcb], fastforce) - apply (frule use_valid [OF _ tcbDomain], fastforce) - apply auto - done - lemma threadSet_ko_wp_at2': "\\s. P (ko_wp_at' P' p s) \ (\tcb_x :: tcb. P' (injectKO (F tcb_x)) = P' (injectKO tcb_x))\ threadSet F ptr @@ -3511,29 +3543,6 @@ lemma createNewCaps_ifunsafe': apply (auto simp: scBits_simps) done -lemma createObjects_idle': - "\valid_idle' and valid_pspace' and pspace_no_overlap' ptr sz - and (\s. \ case_option False (\cte. ksIdleThread s \ capRange (cteCap cte)) - (projectKO_opt val) - \ (\(getF, setF) \ ran tcb_cte_cases. - \ case_option False (\tcb. ksIdleThread s \ capRange (cteCap (getF tcb))) - (projectKO_opt val))) - and K (range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0)\ - createObjects' ptr n val gbits - \\rv. valid_idle'\" - apply (rule hoare_gen_asm) - apply (rule hoare_pre) - apply (clarsimp simp add: valid_idle'_def pred_tcb_at'_def) - apply (rule hoare_vcg_conj_lift) - apply (rule hoare_as_subst[OF createObjects'_it]) - apply (wp createObjects_orig_obj_at' - createObjects_orig_cte_wp_at2' - hoare_vcg_all_lift | simp)+ - apply (clarsimp simp: valid_idle'_def o_def pred_tcb_at'_def valid_pspace'_def - cong: option.case_cong) - apply auto - done - end (* Retype_R *) lemma koTypeOf_eq_UserDataT: @@ -3726,86 +3735,6 @@ lemma createObjects_pspace_domain_valid: crunch doMachineOp for pspace_domain_valid[wp]: pspace_domain_valid -(* FIXME: move *) -lemma ct_idle_or_in_cur_domain'_lift_futz: - assumes a: "\P. \\s. P (ksCurDomain s)\ f \\_ s. P (ksCurDomain s)\" - assumes b: "\P. \\s. P (ksSchedulerAction s)\ f \\_ s. P (ksSchedulerAction s)\" - assumes c: "\P. \\s. P (ksIdleThread s)\ f \\_ s. P (ksIdleThread s)\" - assumes d: "\P. \\s. P (ksCurThread s)\ f \\_ s. P (ksCurThread s)\" - assumes e: "\d t. \\s. obj_at' (\tcb. tcbState tcb \ Inactive \ d = tcbDomain tcb) t s \ Q s\ - f - \\_. obj_at' (\tcb. tcbState tcb \ Inactive \ d = tcbDomain tcb) t\" - shows "\ct_idle_or_in_cur_domain' and ct_active' and Q\ f \\_. ct_idle_or_in_cur_domain'\" -proof - - from e have e': - "\d t. \\s. obj_at' (\tcb. tcbState tcb \ Inactive \ d = tcbDomain tcb) t s \ Q s\ - f - \\_. obj_at' (\tcb. d = tcbDomain tcb) t\" - apply (rule hoare_strengthen_post) - apply (auto simp: obj_at'_def) - done - show ?thesis - apply (simp add: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) - apply (rule hoare_pre) - apply (wps a b c d) - apply (wp hoare_weak_lift_imp e' hoare_vcg_disj_lift) - apply (auto simp: obj_at'_def ct_in_state'_def st_tcb_at'_def) - done -qed - -lemma (in Retype_R) createNewCaps_ct_idle_or_in_cur_domain': - "\ct_idle_or_in_cur_domain' and pspace_aligned' and pspace_distinct' and pspace_bounded' - and pspace_no_overlap' ptr sz - and K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) - and ct_active' and K (range_cover ptr sz (APIType_capBits ty us) n \ 0 < n) \ - createNewCaps ty ptr n us dev - \\_. ct_idle_or_in_cur_domain'\" - by (wp ct_idle_or_in_cur_domain'_lift_futz createNewCaps_obj_at'[where sz=sz] - | simp add: createNewCaps_arch_ko_type_pre_non_arch)+ - -lemma sch_act_wf_lift_asm_futz: - assumes tcb: "\P t. \st_tcb_at' P t and Q \ f \\rv. st_tcb_at' P t\" - assumes tcbDomain: "\P t. \obj_at' (\tcb. runnable' (tcbState tcb) \ P (tcbDomain tcb)) t and Q\ f \\rv. obj_at' (\tcb. runnable' (tcbState tcb) \ P (tcbDomain tcb)) t\" - assumes kCT: "\P. \\s. P (ksCurThread s)\ f \\_ s. P (ksCurThread s)\" - assumes kCD: "\P. \\s. P (ksCurDomain s)\ f \\_ s. P (ksCurDomain s)\" - assumes ksA: "\P. \\s. P (ksSchedulerAction s)\ f \\_ s. P (ksSchedulerAction s)\" - shows - "\\s. sch_act_wf (ksSchedulerAction s) s \ Q s\ - f - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (clarsimp simp: valid_def) - apply (rule use_valid [OF _ ksA], assumption) - apply (frule use_valid [OF _ kCT[of "(=) (ksCurThread s)" for s] refl]) - apply (frule use_valid [OF _ kCD[of "(=) (ksCurDomain s)" for s] refl]) - apply (case_tac "ksSchedulerAction s") - apply (simp add: ct_in_state'_def) - apply (drule use_valid [OF _ tcb]) - apply simp - apply simp - apply simp - apply (clarsimp simp: tcb_in_cur_domain'_def) - apply (frule use_valid [OF _ tcb], fastforce) - apply simp - apply (rename_tac word) - apply (subgoal_tac "(obj_at' (\tcb. runnable' (tcbState tcb) \ ksCurDomain b = tcbDomain tcb) word and Q) s") - apply (drule use_valid [OF _ tcbDomain], fastforce) - apply (auto simp: st_tcb_at'_def o_def obj_at'_def ko_wp_at'_def) - done - -lemma (in Retype_R) createNewCaps_sch_act_wf: - "\(\s. sch_act_wf (ksSchedulerAction s) s) and pspace_aligned' and pspace_distinct' - and pspace_bounded' and pspace_no_overlap' ptr sz - and K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) - and K (range_cover ptr sz (APIType_capBits ty us) n \ 0 < n)\ - createNewCaps ty ptr n us dev - \\_ s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift_asm_futz - createNewCaps_pred_tcb_at'[where sz=sz] - createNewCaps_obj_at'[where sz=sz] - | simp add: createNewCaps_arch_ko_type_pre_non_arch)+ - lemma (in Retype_R) createObjects_null_filter': "\\s. P (null_filter' (ctes_of s)) \ makeObjectKO dev us d ty = Some val \ range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 \ @@ -3936,7 +3865,6 @@ proof (rule hoare_gen_asm, elim conjE) apply (wp createNewCaps_valid_pspace[OF not_0 cover sz_limit ptr_cn ptr_km] createNewCaps_state_refs_of'[OF cover not_0] createNewCaps_state_hyp_refs_of'[OF cover not_0] - createNewCaps_iflive'[OF cover not_0] irqs_masked_lift createNewCaps_ifunsafe' createNewCaps_cur[OF cover not_0] @@ -3948,8 +3876,6 @@ proof (rule hoare_gen_asm, elim conjE) createNewCaps_sched_queues[OF cover not_0] createNewCaps_valid_sched_pointers createNewCaps_pred_tcb_at' - createNewCaps_ct_idle_or_in_cur_domain' - createNewCaps_sch_act_wf createNewCaps_urz[where sz=sz] createNewCaps_list_refs_of_replies' [OF cover not_0] | simp add: tysc)+ @@ -4018,15 +3944,6 @@ lemma createObjects_orig_obj_at3: context Retype_R begin -lemma createObjects_sch: - "\(\s. sch_act_wf (ksSchedulerAction s) s) and pspace_aligned' and pspace_distinct' - and pspace_bounded' and pspace_no_overlap' ptr sz - and K (range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0)\ - createObjects ptr n val gbits - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (rule hoare_gen_asm) - (wp sch_act_wf_lift_asm createObjects_pred_tcb_at' createObjects_orig_obj_at3 | force)+ - lemma createObjects_no_cte_ifunsafe': assumes no_cte: "\c. projectKO_opt val \ Some (c::cte)" assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" @@ -4120,19 +4037,6 @@ lemma createObjects_no_cte_irq_handlers: createObjects_orig_cte_wp_at2') using no_cte no_tcb by (auto simp: split_def split: option.splits) -lemma createObjects_cur': - "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ - pspace_no_overlap' ptr sz s \ range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 \ - cur_tcb' s\ - createObjects ptr n val gbits - \\rv s. cur_tcb' s\" - apply (rule hoare_post_imp[where Q'="\rv s. \t. ksCurThread s = t \ tcb_at' t s"]) - apply (simp add: cur_tcb'_def) - apply (wp hoare_vcg_ex_lift createObjects_orig_obj_at3) - apply (clarsimp simp: cur_tcb'_def) - apply auto - done - end (* Retype_R *) lemma createObjects_vms'[wp]: @@ -4147,17 +4051,6 @@ lemma createObjects_vms'[wp]: apply auto done -lemma (in Retype_R) createObjects_ct_idle_or_in_cur_domain': - "\ct_active' and valid_pspace' and pspace_no_overlap' ptr sz - and ct_idle_or_in_cur_domain' - and K (range_cover ptr sz (objBitsKO val + gSize) n \ n \ 0)\ - createObjects ptr n val gSize - \\_. ct_idle_or_in_cur_domain'\" - apply (rule hoare_gen_asm) - apply (wp ct_idle_or_in_cur_domain'_lift_futz createObjects_obj_at_other[where sz=sz]) - apply simp_all - done - lemma untyped_zero_ranges_cte_def: "untyped_ranges_zero_inv (cteCaps_of s) rs = (\r. (\p. cte_wp_at' (\cte. untypedZeroRange (cteCap cte) = Some r) p s) diff --git a/proof/refine/StateRelation.thy b/proof/refine/StateRelation.thy index cddb42de35..790e2d038c 100644 --- a/proof/refine/StateRelation.thy +++ b/proof/refine/StateRelation.thy @@ -89,17 +89,17 @@ definition cte_relation :: "cap_ref \ obj_relation_cut" where definition ntfn_relation :: "Structures_A.notification \ Structures_H.notification \ bool" where "ntfn_relation \ \ntfn ntfn'. (case ntfn_obj ntfn of - Structures_A.IdleNtfn \ ntfnObj ntfn' = Structures_H.IdleNtfn - | Structures_A.WaitingNtfn q \ ntfnObj ntfn' = Structures_H.WaitingNtfn q - | Structures_A.ActiveNtfn b \ ntfnObj ntfn' = Structures_H.ActiveNtfn b) - \ ntfn_bound_tcb ntfn = ntfnBoundTCB ntfn' - \ ntfn_sc ntfn = ntfnSc ntfn'" + Structures_A.IdleNtfn \ ntfnState ntfn' = IdleNtfnState + | Structures_A.WaitingNtfn q \ ntfnState ntfn' = Waiting + | Structures_A.ActiveNtfn w \ ntfnState ntfn' = Active \ ntfnMsgIdentifier ntfn' = Some w) + \ ntfn_bound_tcb ntfn = ntfnBoundTCB ntfn' + \ ntfn_sc ntfn = ntfnSc ntfn'" definition ep_relation :: "Structures_A.endpoint \ Structures_H.endpoint \ bool" where "ep_relation \ \ep ep'. case ep of - Structures_A.IdleEP \ ep' = Structures_H.IdleEP - | Structures_A.RecvEP q \ ep' = Structures_H.RecvEP q - | Structures_A.SendEP q \ ep' = Structures_H.SendEP q" + Structures_A.IdleEP \ epState ep' = IdleEPState + | Structures_A.RecvEP q \ epState ep' = ReceiveEPState + | Structures_A.SendEP q \ epState ep' = SendEPState" definition fault_rel_optionation :: "ExceptionTypes_A.fault option \ Fault_H.fault option \ bool" where @@ -241,13 +241,14 @@ lemma valid_refills'_nonzero_scRefillCount: by (clarsimp simp: valid_refills'_def opt_pred_def refillSize_def split: option.splits) lemma valid_objs'_valid_refills': - "\valid_objs' s'; sc_at' scp s'; is_active_sc' scp s'\ \ valid_refills' scp s'" - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_opt_sc - split: option.split_asm) - apply (case_tac ko; clarsimp) + "\valid_objs' s'; is_active_sc' scp s'\ \ valid_refills' scp s'" + apply (clarsimp simp: is_active_sc'_def opt_pred_def opt_map_def + split: option.splits kernel_object.splits) apply (erule (1) valid_objsE') - by (clarsimp simp: valid_refills'_def valid_obj'_def valid_sched_context'_def opt_pred_def - is_active_sc'_def opt_map_red projectKO_opt_sc) + apply (clarsimp simp: valid_refills'_def valid_obj'_def valid_sched_context'_def opt_pred_def + opt_map_red projectKO_opts_defs + split: kernel_object.splits) + done lemma valid_refills'_ksSchedulerAction_update[simp]: @@ -270,24 +271,17 @@ definition reply_relation :: "Structures_A.reply \ Structures_H.repl "reply_relation \ \reply reply'. reply_sc reply = replySC reply' \ reply_tcb reply = replyTCB reply'" -\ \ - A pair of objects @{term "(obj, obj')"} should satisfy the following relation when, under further - mild assumptions, a @{term corres_underlying} lemma for @{term "set_object obj"} - and @{term "setObject obj'"} can be stated: see setObject_other_corres in KHeap_R. - - Scheduling context objects and reply objects do not satisfy this relation because of the - reply stack (see sc_replies_relation below). TCBs do not satisfy this relation because the - tcbSchedPrev and tcbSchedNext fields of a TCB are used to model the ready queues and the release - queue, and so an update to such a field would correspond to an update to a ready queue or the - release queue (see ready_queues_relation and release_queue_relation below).\ -definition - other_obj_relation :: "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" -where - "other_obj_relation obj obj' \ +definition ep_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where + "ep_relation_cut obj obj' \ case (obj, obj') of - (Endpoint ep, KOEndpoint ep') \ ep_relation ep ep' - | (Notification ntfn, KONotification ntfn') \ ntfn_relation ntfn ntfn' - | _ \ False" + (Structures_A.Endpoint t, KOEndpoint t') \ ep_relation t t' + | _ \ False" + +definition ntfn_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where + "ntfn_relation_cut obj obj' \ + case (obj, obj') of + (Structures_A.Notification t, KONotification t') \ ntfn_relation t t' + | _ \ False" abbreviation sc_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where "sc_relation_cut obj obj' \ @@ -313,18 +307,13 @@ primrec obj_relation_cuts :: "Structures_A.kernel_object \ machine_w then {(cte_map (x, y), cte_relation y) | y. y \ dom cs} else {(x, \\)})" | "obj_relation_cuts (TCB tcb) x = {(x, tcb_relation_cut)}" -| "obj_relation_cuts (Endpoint ep) x = {(x, other_obj_relation)}" -| "obj_relation_cuts (Notification ntfn) x = {(x, other_obj_relation)}" +| "obj_relation_cuts (Structures_A.Endpoint ep) x = {(x, ep_relation_cut)}" +| "obj_relation_cuts (Structures_A.Notification ntfn) x = {(x, ntfn_relation_cut)}" | "obj_relation_cuts (Structures_A.SchedContext sc n) x = (if valid_sched_context_size n then {(x, sc_relation_cut)} else {(x, \\)})" | "obj_relation_cuts (Structures_A.Reply _) x = {(x, reply_relation_cut)}" | "obj_relation_cuts (ArchObj ao) x = aobj_relation_cuts ao x" -lemma other_obj_relation_not_aobj: - "other_obj_relation ko ko' \ \ is_ArchObj ko" - unfolding other_obj_relation_def is_ArchObj_def - by clarsimp - definition pspace_dom :: "Structures_A.kheap \ machine_word set" where "pspace_dom ps \ \x\dom ps. fst ` (obj_relation_cuts (the (ps x)) x)" @@ -404,6 +393,34 @@ abbreviation release_queue_relation :: "det_state \ kernel_state \ obj_ref list) \ (obj_ref \ tcb_queue) \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ bool" + where + "ep_queues_relation_2 ep_qs epQs nexts prevs \ + \p ls q. ep_qs p = Some ls \ epQs p = Some q \ list_queue_relation ls q nexts prevs" + +abbreviation ep_queues_relation :: "det_state \ kernel_state \ bool" where + "ep_queues_relation s s' \ + ep_queues_relation_2 + (ep_queues_of s) (epQueues_of s') (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + +lemmas ep_queues_relation_def = ep_queues_relation_2_def + +definition ntfn_queues_relation_2 :: + "(obj_ref \ obj_ref list) \ (obj_ref \ tcb_queue) \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) + \ bool" + where + "ntfn_queues_relation_2 ntfn_qs ntfnQs nexts prevs \ + \p ls q. ntfn_qs p = Some ls \ ntfnQs p = Some q \ list_queue_relation ls q nexts prevs" + +abbreviation ntfn_queues_relation :: "det_state \ kernel_state \ bool" where + "ntfn_queues_relation s s' \ + ntfn_queues_relation_2 + (ntfn_queues_of s) (ntfnQueues_of s') (tcbSchedNexts_of s') (tcbSchedPrevs_of s')" + +lemmas ntfn_queues_relation_def = ntfn_queues_relation_2_def + definition cdt_relation :: "(cslot_ptr \ bool) \ cdt \ cte_heap \ bool" where "cdt_relation \ \cte_at m m'. \c. cte_at c \ cte_map ` descendants_of c m = descendants_of' (cte_map c) m'" @@ -472,10 +489,12 @@ abbreviation ghost_relation_wrapper :: "det_state \ kernel_state \ kernel_state) set" where "state_relation \ {(s, s'). pspace_relation (kheap s) (ksPSpace s') - \ sc_replies_relation s s' - \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') + \ ep_queues_relation s s' + \ ntfn_queues_relation s s' \ ready_queues_relation s s' \ release_queue_relation s s' + \ sc_replies_relation s s' + \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ ghost_relation_wrapper s s' \ cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \ cdt_list_relation (cdt_list s) (cdt s) (ctes_of s') @@ -527,6 +546,14 @@ lemma state_relation_release_queue_relation[elim!]: "(s,s') \ state_relation \ release_queue_relation s s'" by (clarsimp simp: state_relation_def) +lemma state_relation_ep_queues_relation[elim!]: + "(s,s') \ state_relation \ ep_queues_relation s s'" + by (clarsimp simp: state_relation_def) + +lemma state_relation_ntfn_queues_relation[elim!]: + "(s,s') \ state_relation \ ntfn_queues_relation s s'" + by (clarsimp simp: state_relation_def) + lemma state_relation_sc_replies_relation: "(s,s') \ state_relation \ sc_replies_relation s s'" using state_relation_def by blast @@ -543,6 +570,8 @@ lemma state_relationD: sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ ready_queues_relation s s' \ release_queue_relation s s' \ + ep_queues_relation s s' \ + ntfn_queues_relation s s' \ ghost_relation_wrapper s s' \ cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \ cdt_list_relation (cdt_list s) (cdt s) (ctes_of s') \ @@ -571,6 +600,8 @@ lemma state_relationE [elim?]: sched_act_relation (scheduler_action s) (ksSchedulerAction s'); ready_queues_relation s s'; release_queue_relation s s'; + ep_queues_relation s s'; + ntfn_queues_relation s s'; ghost_relation_wrapper s s'; cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \ revokable_relation (is_original_cap s) (null_filter (caps_of_state s)) (ctes_of s'); @@ -1084,8 +1115,8 @@ locale StateRelation_R = "\n. \ is_other_obj_relation_type (ASchedContext n)" "\ is_other_obj_relation_type AReply" "\ is_other_obj_relation_type ATCB" - "is_other_obj_relation_type AEndpoint" - "is_other_obj_relation_type ANTFN" + "\ is_other_obj_relation_type AEndpoint" + "\ is_other_obj_relation_type ANTFN" "\n. \ is_other_obj_relation_type (AGarbage n)" assumes msgLabelBits_msg_label_bits: "msgLabelBits = msg_label_bits" diff --git a/proof/refine/StateRelationPre.thy b/proof/refine/StateRelationPre.thy index 2a45f07f4c..87efed892d 100644 --- a/proof/refine/StateRelationPre.thy +++ b/proof/refine/StateRelationPre.thy @@ -25,4 +25,13 @@ text \ type_synonym obj_relation_cut = "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" type_synonym obj_relation_cuts = "(machine_word \ obj_relation_cut) set" +text \ + An analogue of cmap_relation in CRefine, used to formulate predicates stating that all kernel + objects of some type are in a particular relation. Applies where for every abstract kernel + object, there is exactly one associated concrete kernel object.\ +definition map_relation :: "(obj_ref \ 'a) \ (obj_ref \ 'b) \ ('a \ 'b \ bool) \ bool" where + "map_relation ah ch rel \ + dom ah = dom ch + \ (\p obj obj'. ah p = Some obj \ ch p = Some obj' \ rel obj obj')" + end diff --git a/proof/refine/TcbAcc_R.thy b/proof/refine/TcbAcc_R.thy index bdc7fb38f2..7705c1a225 100644 --- a/proof/refine/TcbAcc_R.thy +++ b/proof/refine/TcbAcc_R.thy @@ -10,10 +10,51 @@ theory TcbAcc_R imports ArchCSpace_R begin +crunch orderedInsert, tcbQueueRemove + for typ_at'[wp]: "\s. P (typ_at' T p s)" + and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" + (wp: crunch_wps) + +global_interpretation tcbQueuePrepend: typ_at_all_props' "tcbQueuePrepend q tcbPtr" + by typ_at_props' + +global_interpretation tcbQueueAppend: typ_at_all_props' "tcbQueueAppend q tcbPtr" + by typ_at_props' + +global_interpretation tcbQueueInsert: typ_at_all_props' "tcbQueueInsert tcbPtr afterPtr" + by typ_at_props' + +global_interpretation orderedInsert: typ_at_all_props' "orderedInsert t q f r" + by typ_at_props' + lemma threadRead_SomeD: "threadRead f t s = Some y \ \tcb. ko_at' tcb t s \ y = f tcb" by (fastforce simp: threadRead_def oliftM_def dest!: readObject_misc_ko_at') +lemma threadGet_wp: + "\\s. \tcb. ko_at' tcb t s \ P (f tcb) s\ threadGet f t \P\" + apply (simp add: threadGet_getObject) + apply (wp getObject_tcb_wp) + apply (clarsimp simp: obj_at'_def) + done + +lemma threadGet_return_rewrite: + "monadic_rewrite False True (ko_at' ko t) (threadGet f t) (return (f ko))" + apply (rule monadic_rewrite_add_return_l) + apply monadic_rewrite_symb_exec_l + apply (rule monadic_rewrite_guard_arg_cong) + apply fastforce + apply (wpsimp wp: threadGet_wp)+ + apply (clarsimp simp: obj_at'_def) + done + +lemma ko_at'_threadRead: + "ko_at' ko tcbPtr s \ threadRead f tcbPtr s = Some (f ko)" + apply (frule threadGet_return_rewrite[ + simplified monadic_rewrite_def threadGet_def, simplified, rule_format]) + apply (fastforce simp: monad_simps split: option.splits) + done + (* Auxiliaries and basic properties of priority bitmap functions *) lemma countLeadingZeros_word_clz[simp]: @@ -143,6 +184,7 @@ crunch tcbSchedDequeue, tcbSchedEnqueue crunch tcbSchedDequeue, tcbSchedEnqueue, tcbReleaseRemove for obj_at'_reply[wp]: "\s. P (obj_at' (Q :: reply \ bool) p s)" and obj_at'_ep[wp]: "\s. P (obj_at' (Q :: endpoint \ bool) p s)" + and obj_at'_ntfn[wp]: "\s. P (obj_at' (Q :: notification \ bool) p s)" and obj_at'_sc[wp]: "\s. Q (obj_at' (P :: sched_context \ bool) p s)" (wp: crunch_wps) @@ -164,9 +206,8 @@ lemma valid_tcb'_tcbDomain_update: by (clarsimp simp: tcb_cte_cases_def gen_objBits_simps tcb_cte_cases_neqs) lemma valid_tcb'_tcbState_update: - "\valid_tcb_state' st s; valid_tcb' tcb s\ \ - valid_tcb' (tcbState_update (\_. st) tcb) s" - by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def valid_tcb_state'_def gen_objBits_simps + "valid_tcb' tcb s \ valid_tcb' (tcbState_update (\_. st) tcb) s" + by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def gen_objBits_simps tcb_cte_cases_neqs) definition valid_tcbs' :: "kernel_state \ bool" where @@ -210,8 +251,7 @@ lemma (in Arch) update_valid_tcb'[simp]: "\f. valid_tcb' tcb (ksReadyQueues_update f s) = valid_tcb' tcb s" "\f. valid_tcb' tcb (ksSchedulerAction_update f s) = valid_tcb' tcb s" "\f. valid_tcb' tcb (ksDomainTime_update f s) = valid_tcb' tcb s" - by (auto simp: valid_tcb'_def valid_tcb_state'_def valid_bound_obj'_def - opt_tcb_at'_def valid_arch_tcb'_def + by (auto simp: valid_tcb'_def valid_bound_obj'_def opt_tcb_at'_def valid_arch_tcb'_def split: option.splits thread_state.splits none_top_split) lemma update_tcbInReleaseQueue_False_valid_tcb'[simp]: @@ -514,43 +554,6 @@ lemma setObject_tcb_state_refs_of'[wp]: by (wp setObject_state_refs_of', simp_all add: gen_objBits_simps fun_upd_def) -lemma setObject_tcb_iflive': - "\\s. if_live_then_nonz_cap' s \ - (live' (injectKO v) \ ex_nonz_cap_to' t s) - \ obj_at' (\t. \(getF, setF) \ ran tcb_cte_cases. getF t = getF v) t s\ - setObject t (v :: tcb) - \\rv. if_live_then_nonz_cap'\" - apply (rule setObject_iflive') - apply (simp add: gen_objBits_simps)+ - apply (clarsimp simp: updateObject_default_def in_monad obj_at'_def - in_magnitude_check gen_objBits_simps prod_eq_iff) - apply fastforce - apply (clarsimp simp: updateObject_default_def bind_def in_monad) - done - -lemma setObject_tcb_idle': - "\\s. valid_idle' s \ (t = ksIdleThread s \ idle_tcb' v)\ - setObject t (v :: tcb) \\rv. valid_idle'\" - apply (rule hoare_pre) - apply (rule setObject_idle') - apply (simp add: gen_objBits_simps)+ - apply (simp add: updateObject_default_inv) - apply (simp add: idle_tcb_ps_def idle_sc_ps_def) - done - -lemma setObject_sc_idle': - "\\s. valid_idle' s \ (t = idle_sc_ptr \ idle_sc' v)\ - setSchedContext t v - \\rv. valid_idle'\" - apply (clarsimp simp: setSchedContext_def) - apply (rule hoare_pre) - apply (rule setObject_idle') - apply simp - apply (simp add: scBits_pos_power2) - apply (simp add: updateObject_default_inv) - apply (simp add: idle_tcb_ps_def idle_sc_ps_def) - done - lemma setObject_tcb_ifunsafe': "\if_unsafe_then_cap' and obj_at' (\t. \(getF, setF) \ ran tcb_cte_cases. getF t = getF v) t\ setObject t (v :: tcb) @@ -622,9 +625,6 @@ lemma setObject_tcb_valid_replies': lemma threadSet_valid_pspace'T_P: assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - assumes z: "\tcb. (P \ Q1 (tcbState tcb)) \ - (\s. valid_tcb_state' (tcbState tcb) s - \ valid_tcb_state' (tcbState (F tcb)) s)" assumes z': "\tcb. (P \ Q1 (tcbState tcb)) \ (\rptr. (tcbState tcb = BlockedOnReply rptr) \ (tcbState (F tcb) = BlockedOnReply rptr))" @@ -664,7 +664,7 @@ lemma threadSet_valid_pspace'T_P: apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) apply (erule(1) valid_objsE') apply (clarsimp simp add: valid_obj'_def valid_tcb'_def - bspec_split [OF spec [OF x]] z + bspec_split [OF spec [OF x]] split_paired_Ball y u w v1 v2 v3 v4 v5 w' v' f) apply (fastforce simp: eq_commute[where b="tcbState obj" for obj] z') done @@ -810,20 +810,6 @@ lemmas threadSet_cteCaps_of = ctes_of_cteCaps_of_lift [OF threadSet_ctes_of] lemmas threadSet_urz = untyped_ranges_zero_lift[where f="cteCaps_of", OF _ threadSet_cteCaps_of] -lemma threadSet_idle'T: - "\\s. valid_idle' s - \ (t = ksIdleThread s \ (\tcb. ko_at' tcb t s \ idle_tcb' tcb \ idle_tcb' (F tcb)))\ - threadSet F t - \\rv. valid_idle'\" - apply (simp add: threadSet_def) - apply (wp setObject_tcb_idle' getObject_tcb_wp) - apply (clarsimp simp: obj_at'_def valid_idle'_def pred_tcb_at'_def) - done - -lemmas threadSet_idle' = - (*threadSet_idle'T [OF all_tcbI, OF ball_tcb_cte_casesI]*) - threadSet_idle'T - lemma threadSet_valid_bitmapQ[wp]: "\ valid_bitmapQ \ threadSet f t \ \rv. valid_bitmapQ \" unfolding bitmapQ_defs threadSet_def @@ -979,97 +965,25 @@ lemma threadSet_pred_tcb_no_state: by (wpsimp wp: threadSet_obj_at'_no_state simp: pred_tcb_at'_def assms) lemma threadSet_mdb': - "\valid_mdb' and obj_at' (\t. \(getF, setF) \ ran tcb_cte_cases. getF t = getF (f t)) t\ + "\\s. valid_mdb' s + \ (tcb_at' t s \ obj_at' (\t. \(getF, setF) \ ran tcb_cte_cases. getF t = getF (f t)) t s)\ threadSet f t - \\rv. valid_mdb'\" + \\_. valid_mdb'\" apply (wpsimp wp: setObject_tcb_mdb' getTCB_wp simp: threadSet_def obj_at'_def) apply fastforce done -lemma threadSet_sch_act: - "(\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb) \ - \\s. sch_act_wf (ksSchedulerAction s) s\ - threadSet F t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (wp sch_act_wf_lift threadSet_pred_tcb_no_state | simp add: tcb_in_cur_domain'_def)+ - apply (rule_tac f="ksCurDomain" in hoare_lift_Pf) - apply (wp threadSet_obj_at'_strongish | simp)+ - done - -lemma threadSet_sch_actT_P: - assumes z: "\ P \ (\tcb. tcbState (F tcb) = tcbState tcb - \ tcbDomain (F tcb) = tcbDomain tcb)" - assumes z': "P \ (\tcb. tcbState (F tcb) = Inactive \ tcbDomain (F tcb) = tcbDomain tcb ) - \ (\st. Q st \ st = Inactive)" - shows "\\s. sch_act_wf (ksSchedulerAction s) s \ (P \ st_tcb_at' Q t s)\ - threadSet F t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - using z z' - apply (case_tac P, simp_all add: threadSet_sch_act) - apply (clarsimp simp: valid_def) - apply (frule_tac P1="\sa. sch_act_wf sa s" - in use_valid [OF _ threadSet.ksSchedulerAction], assumption) - apply (frule_tac P1="(=) (ksCurThread s)" - in use_valid [OF _ threadSet.ct], rule refl) - apply (frule_tac P1="(=) (ksCurDomain s)" - in use_valid [OF _ threadSet.cur_domain], rule refl) - apply (case_tac "ksSchedulerAction b", - simp_all add: ct_in_state'_def pred_tcb_at'_def) - apply (subgoal_tac "t \ ksCurThread s") - apply (drule_tac t'1="ksCurThread s" - and P1="activatable' \ tcbState" - in use_valid [OF _ threadSet_obj_at'_really_strongest]) - apply (clarsimp simp: o_def) - apply (clarsimp simp: o_def) - apply (fastforce simp: obj_at'_def) - apply (rename_tac word) - apply (subgoal_tac "t \ word") - apply (frule_tac t'1=word - and P1="runnable' \ tcbState" - in use_valid [OF _ threadSet_obj_at'_really_strongest]) - apply (clarsimp simp: o_def) - apply (rule conjI) - apply (clarsimp simp: o_def) - apply (clarsimp simp: tcb_in_cur_domain'_def) - apply (frule_tac t'1=word - and P1="\tcb. ksCurDomain b = tcbDomain tcb" - in use_valid [OF _ threadSet_obj_at'_really_strongest]) - apply (clarsimp simp: o_def)+ - apply (fastforce simp: obj_at'_def) - done - lemma threadSet_vms'[wp]: "\valid_machine_state'\ threadSet F t \\rv. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) by (intro hoare_vcg_all_lift hoare_vcg_disj_lift; wp) -lemma threadSet_not_inQ: - "\ct_not_inQ and (\s. (\tcb. tcbQueued (F tcb) \ \ tcbQueued tcb) - \ ksSchedulerAction s = ResumeCurrentThread - \ t \ ksCurThread s)\ - threadSet F t \\_. ct_not_inQ\" - apply (simp add: threadSet_def ct_not_inQ_def) - apply (wp) - apply (rule hoare_convert_imp [OF setObject_nosch]) - apply (wpsimp wp: updateObject_default_inv) - apply (wps setObject_ct_inv) - apply (wp setObject_tcb_strongest getObject_tcb_wp)+ - apply (case_tac "t = ksCurThread s") - apply (clarsimp simp: obj_at'_def)+ - done - lemma threadSet_invs_trivial_helper[simp]: "{r \ state_refs_of' s t. snd r \ TCBBound \ snd r \ TCBSchedContext \ snd r \ TCBYieldTo} \ {r \ state_refs_of' s t. (snd r = TCBBound \ snd r = TCBSchedContext \ snd r = TCBYieldTo)} = state_refs_of' s t" by auto -lemma threadSet_ct_idle_or_in_cur_domain': - "(\tcb. tcbDomain (F tcb) = tcbDomain tcb) \ \ct_idle_or_in_cur_domain'\ threadSet F t \\_. ct_idle_or_in_cur_domain'\" - apply (rule ct_idle_or_in_cur_domain'_lift) - apply (wp hoare_vcg_disj_lift| simp)+ - done - lemma threadSet_valid_dom_schedule': "\ valid_dom_schedule'\ threadSet F t \\_. valid_dom_schedule'\" unfolding threadSet_def valid_dom_schedule'_def @@ -1093,39 +1007,21 @@ lemma threadSet_sched_pointers: lemma threadSet_valid_sched_pointers: "\\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb; \tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb; \tcb. tcbInReleaseQueue (F tcb) = tcbInReleaseQueue tcb; - \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \tcb. tcbQueued (F tcb) = tcbQueued tcb; \tcb. tcbState (F tcb) = tcbState tcb\ \ threadSet F tcbPtr \valid_sched_pointers\" unfolding valid_sched_pointers_def apply (wpsimp wp: hoare_vcg_all_lift threadSet_wp) - by (fastforce simp: opt_pred_def opt_map_def obj_at'_def split: option.splits) - -lemma threadSet_tcbSchedNexts_of: - "(\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb) \ - threadSet F t \\s. P (tcbSchedNexts_of s)\" - apply (wpsimp wp: threadSet_wp) - apply (erule rsubst[where P=P]) - apply (fastforce simp: opt_map_def obj_at'_def) + apply (clarsimp simp: opt_pred_def opt_map_def obj_at'_def split: option.splits) + apply (fastforce dest: spec[where x=tcbPtr]) done -lemma threadSet_tcbSchedPrevs_of: - "(\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb) \ - threadSet F t \\s. P (tcbSchedPrevs_of s)\" +lemma threadSet_field_inv: + "(\tcb. f (F tcb) = f tcb) \ threadSet F t \\s. P (tcbs_of' s |> f)\" apply (wpsimp wp: threadSet_wp) - apply (erule rsubst[where P=P]) - apply (fastforce simp: opt_map_def obj_at'_def) - done - -lemma threadSet_tcbInReleaseQueue: - "(\tcb. tcbInReleaseQueue (F tcb) = tcbInReleaseQueue tcb) \ - threadSet F t \\s. P (tcbInReleaseQueue |< tcbs_of' s)\" - apply (wpsimp wp: threadSet_wp) - apply (erule rsubst[where P=P]) - apply (fastforce simp: opt_pred_def opt_map_def obj_at'_def) - done + by (fastforce elim!: rsubst[where P=P] simp: opt_map_def obj_at'_def) -lemma threadSet_tcbQueued: - "(\tcb. tcbQueued (F tcb) = tcbQueued tcb) \ - threadSet F t \\s. P (tcbQueued |< tcbs_of' s)\" +lemma threadSet_field_opt_pred: + "(\tcb. f (F tcb) = f tcb) \ threadSet F t \\s. P (f |< tcbs_of' s)\" apply (wpsimp wp: threadSet_wp) apply (erule rsubst[where P=P]) apply (fastforce simp: opt_pred_def opt_map_def obj_at'_def) @@ -1270,13 +1166,6 @@ crunch asUser global_interpretation asUser: typ_at_all_props' "asUser tptr f" by typ_at_props' -lemma threadGet_wp: - "\\s. \tcb. ko_at' tcb t s \ P (f tcb) s\ threadGet f t \P\" - apply (simp add: threadGet_getObject) - apply (wp getObject_tcb_wp) - apply (clarsimp simp: obj_at'_def) - done - lemma threadGet_sp: "\P\ threadGet f ptr \\rv s. \tcb :: tcb. ko_at' tcb ptr s \ f tcb = rv \ P s\" apply (wpsimp wp: threadGet_wp) @@ -1378,17 +1267,6 @@ lemma asUser_tcbState_inv[wp]: apply (wpsimp wp: getObject_tcb_wp simp: obj_at'_def) done -lemma asUser_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - asUser t m \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift) - -lemma asUser_idle'[wp]: - "\valid_idle'\ asUser t m \\rv. valid_idle'\" - apply (simp add: asUser_def split_def) - apply (wpsimp wp: threadSet_idle' select_f_inv) - done - lemma no_fail_asUser[wp]: "no_fail \ f \ no_fail (tcb_at' t) (asUser t f)" apply (simp add: asUser_def split_def) @@ -1423,16 +1301,6 @@ lemma is_blocked_corres: apply wpsimp+ done -lemma gts_wf'[wp]: - "\valid_objs'\ getThreadState t \valid_tcb_state'\" - apply (simp add: getThreadState_def threadGet_getObject liftM_def) - apply (wp getObject_tcb_wp) - apply clarsimp - apply (drule obj_at_ko_at', clarsimp) - apply (frule ko_at_valid_objs', fastforce, simp) - apply (fastforce simp: valid_obj'_def valid_tcb'_def) - done - lemma gts_st_tcb_at'[wp]: "\st_tcb_at' P t\ getThreadState t \\rv s. P rv\" apply (simp add: getThreadState_def threadGet_getObject) apply wp @@ -1643,13 +1511,6 @@ lemma pspace_relation_tcb_domain_priority: apply (clarsimp simp: tcb_relation_cut_def tcb_relation_def) done -lemma no_fail_thread_get[wp]: - "no_fail (tcb_at tcb_ptr) (thread_get f tcb_ptr)" - unfolding thread_get_def - apply wpsimp - apply (clarsimp simp: tcb_at_def) - done - lemma pspace_relation_tcb_relation: "\pspace_relation (kheap s) (ksPSpace s'); kheap s ptr = Some (TCB tcb); ksPSpace s' ptr = Some (KOTCB tcb')\ @@ -1660,70 +1521,6 @@ lemma pspace_relation_tcb_relation: apply (clarsimp simp: obj_at_def obj_at'_def tcb_relation_cut_def) done -context TcbAcc_R begin - -lemma pspace_relation_update_concrete_tcb: - "\pspace_relation s s'; s ptr = Some (TCB tcb); s' ptr = Some (KOTCB otcb'); - tcb_relation tcb tcb'\ - \ pspace_relation s (s'(ptr \ KOTCB tcb'))" - by (fastforce dest: pspace_relation_update_tcbs simp: map_upd_triv) - -lemma pspace_relation_update_abstract_tcb: - "\pspace_relation s s'; s ptr = Some (TCB tcb); s' ptr = Some (KOTCB otcb'); - tcb_relation tcb' otcb'\ - \ pspace_relation (s(ptr \ TCB tcb')) s'" - by (fastforce dest: pspace_relation_update_tcbs simp: map_upd_triv) - -crunch threadSet - for scReplies_of[wp]: "\s. P (scReplies_of s) (replyPrevs_of s')" - -lemma threadSet_sc_replies_relation[wp]: - "threadSet f tcbPtr \sc_replies_relation s\" - by (rule_tac f=scReplies_of in hoare_lift_Pf2; wpsimp) - -lemma threadSet_pspace_relation: - fixes s :: det_state - assumes tcb_rel: "(\tcb tcb'. tcb_relation tcb tcb' \ tcb_relation tcb (F tcb'))" - shows "threadSet F tcbPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" - apply (wpsimp wp: threadSet_wp) - apply (frule tcb_at'_cross) - apply (fastforce simp: obj_at'_def) - apply (clarsimp simp: obj_at_def is_tcb_def) - apply (rename_tac ko, case_tac ko; clarsimp) - apply (rule pspace_relation_update_concrete_tcb) - apply fastforce - apply fastforce - apply (fastforce simp: obj_at'_def) - apply (frule (1) pspace_relation_tcb_relation) - apply (fastforce simp: obj_at'_def) - apply (fastforce dest!: tcb_rel) - done - -lemma tcbQueued_update_pspace_relation[wp]: - fixes s :: det_state - shows "threadSet (tcbQueued_update f) tcbPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" - unfolding tcbQueueRemove_def - by (wpsimp wp: threadSet_pspace_relation simp: tcb_relation_def) - -lemma tcbInReleaseQueue_update_pspace_relation[wp]: - fixes s :: det_state - shows "threadSet (tcbInReleaseQueue_update f) tcbPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" - unfolding tcbQueueRemove_def - by (wpsimp wp: threadSet_pspace_relation simp: tcb_relation_def) - -lemma tcbQueueRemove_pspace_relation[wp]: - fixes s :: det_state - shows "tcbQueueRemove queue tcbPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" - unfolding tcbQueueRemove_def - by (wpsimp wp: threadSet_pspace_relation hoare_drop_imps simp: tcb_relation_def) - -lemma setReleaseQueue_pspace_relation[wp]: - fixes s :: det_state - shows "setReleaseQueue f \\s'. pspace_relation (kheap s) (ksPSpace s')\" - by (wpsimp simp: setReleaseQueue_def) - -end (* TcbAcc_R *) - lemma threadSet_ksIdleSc[wp]: "threadSet f tcbPtr \\s. P (ksIdleSC s)\" by (wpsimp wp: threadSet_wp) @@ -1736,12 +1533,16 @@ lemma tcbInReleaseQueue_update_ctes_of[wp]: "threadSet (tcbInReleaseQueue_update f) t \\s. P (ctes_of s)\" by (wpsimp wp: threadSet_ctes_of) +lemma tcbYieldTo_update_ctes_of[wp]: + "threadSet (tcbYieldTo_update f) t \\s. P (ctes_of s)\" + by (wpsimp wp: threadSet_ctes_of) + lemma removeFromBitmap_ctes_of[wp]: "removeFromBitmap tdom prio \\s. P (ctes_of s)\" by (wpsimp simp: bitmap_fun_defs) -crunch tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, - setReleaseQueue, setQueue, removeFromBitmap +crunch tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, orderedInsert, + setReleaseQueue, setQueue, removeFromBitmap for sc_replies_relation_projs[wp]: "\s. P (scReplies_of s) (replyPrevs_of s)" and ghost_relation_projs[wp]: "\s. P (gsUserPages s) (gsCNodes s)" and ksArchState[wp]: "\s. P (ksArchState s)" @@ -1754,48 +1555,11 @@ crunch tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, and ksReprogramTimer[wp]: "\s. P (ksReprogramTimer s)" (wp: crunch_wps) -lemma set_release_queue_projs: - "set_release_queue queue - \\s. P (kheap s) (cdt s) (is_original_cap s) (cur_thread s) (idle_thread s) (consumed_time s) - (cur_time s) (cur_sc s) (reprogram_timer s) (scheduler_action s) (domain_list s) - (domain_index s) (cur_domain s) (domain_time s) (ready_queues s) (machine_state s) - (interrupt_irq_node s) (interrupt_states s) (arch_state s) (caps_of_state s) - (work_units_completed s) (cdt_list s)\" - by wpsimp - lemma set_release_queue_cte_at: "set_release_queue queue \\s. P (swp cte_at s)\" apply wpsimp by (clarsimp simp: swp_def cte_wp_at_def) -lemma set_release_queue_projs_inv: - "(r, s') \ fst (set_release_queue f s) \ - kheap s = kheap s' - \ cdt s = cdt s' - \ is_original_cap s = is_original_cap s' - \ cur_thread s = cur_thread s' - \ idle_thread s = idle_thread s' - \ consumed_time s = consumed_time s' - \ cur_time s = cur_time s' - \ cur_sc s = cur_sc s' - \ reprogram_timer s = reprogram_timer s' - \ scheduler_action s = scheduler_action s' - \ domain_list s = domain_list s' - \ domain_index s = domain_index s' - \ cur_domain s = cur_domain s' - \ domain_time s = domain_time s' - \ ready_queues s = ready_queues s' - \ machine_state s = machine_state s' - \ interrupt_irq_node s = interrupt_irq_node s' - \ interrupt_states s = interrupt_states s' - \ arch_state s = arch_state s' - \ caps_of_state s = caps_of_state s' - \ work_units_completed s = work_units_completed s' - \ cdt_list s = cdt_list s' - \ swp cte_at s = swp cte_at s'" - by (auto elim!: use_valid_inv[where E=\, simplified] - intro: set_release_queue_projs set_release_queue_cte_at) - lemma set_release_queue_new_state: "(rv, t) \ fst (set_release_queue queue s) \ t = s\release_queue := queue\" by (clarsimp simp: in_monad) @@ -1816,68 +1580,6 @@ lemma set_tcb_queue_cte_at: apply (clarsimp simp: swp_def cte_wp_at_def) done -lemma set_tcb_queue_projs_inv: - "fst (set_tcb_queue d p queue s) = {(r, s')} \ - kheap s = kheap s' - \ cdt s = cdt s' - \ is_original_cap s = is_original_cap s' - \ cur_thread s = cur_thread s' - \ idle_thread s = idle_thread s' - \ consumed_time s = consumed_time s' - \ cur_time s = cur_time s' - \ cur_sc s = cur_sc s' - \ reprogram_timer s = reprogram_timer s' - \ scheduler_action s = scheduler_action s' - \ domain_list s = domain_list s' - \ domain_index s = domain_index s' - \ cur_domain s = cur_domain s' - \ domain_time s = domain_time s' - \ release_queue s = release_queue s' - \ machine_state s = machine_state s' - \ interrupt_irq_node s = interrupt_irq_node s' - \ interrupt_states s = interrupt_states s' - \ arch_state s = arch_state s' - \ caps_of_state s = caps_of_state s' - \ work_units_completed s = work_units_completed s' - \ cdt_list s = cdt_list s' - \ swp cte_at s = swp cte_at s'" - apply (drule singleton_eqD) - by (auto elim!: use_valid_inv[where E=\, simplified] - intro: set_tcb_queue_projs set_tcb_queue_cte_at) - -lemma set_tcb_queue_new_state: - "(rv, t) \ fst (set_tcb_queue d p queue s) \ - t = s\ready_queues := \dom prio. if dom = d \ prio = p then queue else ready_queues s dom prio\" - by (clarsimp simp: set_tcb_queue_def in_monad) - -context TcbAcc_R begin - -lemma tcbQueuePrepend_pspace_relation[wp]: - fixes s :: det_state - shows "tcbQueuePrepend queue tcbPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" - unfolding tcbQueuePrepend_def - by (wpsimp wp: threadSet_pspace_relation simp: tcb_relation_def) - -lemma tcbQueueAppend_pspace_relation[wp]: - fixes s :: det_state - shows "tcbQueueAppend queue tcbPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" - unfolding tcbQueueAppend_def - by (wpsimp wp: threadSet_pspace_relation simp: tcb_relation_def) - -lemma tcbQueueInsert_pspace_relation[wp]: - fixes s :: det_state - shows "tcbQueueInsert tcbPtr afterPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" - unfolding tcbQueueInsert_def - by (wpsimp wp: threadSet_pspace_relation hoare_drop_imps simp: tcb_relation_def) - -end (* TcbAcc_R *) - -lemma removeFromBitmap_pspace_relation[wp]: - fixes s :: det_state - shows "removeFromBitmap tdom prio \\s'. pspace_relation (kheap s) (ksPSpace s')\" - unfolding bitmap_fun_defs - by wpsimp - crunch setReprogramTimer, setReleaseQueue, setQueue, removeFromBitmap for valid_pspace'[wp]: valid_pspace' and state_refs_of'[wp]: "\s. P (state_refs_of' s)" @@ -1894,7 +1596,6 @@ crunch setReprogramTimer, setReleaseQueue, setQueue, removeFromBitmap and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" and valid_machine_state'[wp]: valid_machine_state' - and cur_tcb'[wp]: cur_tcb' and ksPSpace[wp]: "\s. P (ksPSpace s)" (wp: crunch_wps simp: crunch_simps tcb_cte_cases_def tcb_bound_refs'_def cur_tcb'_def threadSet_cur @@ -1923,6 +1624,7 @@ crunch tcbReleaseRemove, tcbReleaseEnqueue, and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and valid_dom_schedule'[wp]: valid_dom_schedule' and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" and ctes_of[wp]: "\s. P (ctes_of s)" and ksCurThread[wp]: "\s. P (ksCurThread s)" @@ -1930,7 +1632,7 @@ crunch tcbReleaseRemove, tcbReleaseEnqueue, and reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" and pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' and ksIdleThread[wp]: "\s. P (ksIdleThread s)" - (wp: crunch_wps threadSet_state_refs_of'[where f'=id and g'=id] + (wp: crunch_wps threadSet_state_refs_of'[where f'=id and g'=id] valid_dom_schedule'_lift simp: crunch_simps tcb_cte_cases_def tcb_bound_refs'_def bitmap_fun_defs) crunch tcbReleaseRemove, tcbReleaseEnqueue @@ -1939,68 +1641,10 @@ crunch tcbReleaseRemove, tcbReleaseEnqueue end (* TcbAcc_R *) -lemma threadSet_release_queue_relation: - "(\tcb. tcbInReleaseQueue (F tcb) = tcbInReleaseQueue tcb) \ - \\s'. release_queue_relation s s' \ \ (tcbInReleaseQueue |< tcbs_of' s') tcbPtr \ - threadSet F tcbPtr - \\_ s'. release_queue_relation s s'\" - apply (clarsimp simp: release_queue_relation_def) - apply (wpsimp wp: threadSet_wp) - apply (clarsimp simp: list_queue_relation_def) - apply (rule conjI) - apply (fastforce intro: heap_path_heap_upd_not_in) - apply (rule conjI) - apply (clarsimp simp: prev_queue_head_def) - apply (prop_tac "release_queue s \ []", fastforce) - apply (fastforce dest: heap_path_head) - apply (clarsimp simp: obj_at'_def opt_pred_def opt_map_def split: option.splits) - done - -lemma threadSet_ready_queues_relation: - "(\tcb. tcbQueued (F tcb) = tcbQueued tcb) \ - \\s'. ready_queues_relation s s' \ \ (tcbQueued |< tcbs_of' s') tcbPtr\ - threadSet F tcbPtr - \\_ s'. ready_queues_relation s s'\" - apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) - apply (wpsimp wp: threadSet_wp) - apply (clarsimp simp: list_queue_relation_def) - apply (rename_tac tcb' d p) - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (clarsimp simp: list_queue_relation_def) - apply (rule conjI) - apply (drule_tac x=tcbPtr in spec) - apply (fastforce intro: heap_path_heap_upd_not_in - simp: inQ_def opt_map_def opt_pred_def obj_at'_def) - apply (rule conjI) - apply (drule_tac x=tcbPtr in spec) - apply (clarsimp simp: prev_queue_head_def) - apply (prop_tac "ready_queues s d p \ []", fastforce) - apply (fastforce dest: heap_path_head simp: inQ_def opt_pred_def obj_at'_def opt_map_def) - apply (auto simp: inQ_def opt_pred_def obj_at'_def opt_map_def split: option.splits) - done - crunch setQueue - for release_queue_relation[wp]: "\s'. release_queue_relation s s'" + for ksReleaseQueue[wp]: "\s'. P (ksReleaseQueue s')" (simp: release_queue_relation_def) -definition in_correct_ready_q :: "'z state \ bool" where - "in_correct_ready_q s \ - \d p. \t\set (ready_queues s d p). - pred_map (\t. etcb_priority t = p \ etcb_domain t = d) (etcbs_of s) t" - -definition ready_qs_distinct :: "'z state \ bool" where - "ready_qs_distinct s \ \d p. distinct (ready_queues s d p)" - -lemma in_correct_ready_q_lift: - assumes e: "\P. f \\s. P (etcbs_of s)\" - assumes r: "\P. f \\s. P (ready_queues s)\" - shows "f \in_correct_ready_q\" - unfolding in_correct_ready_q_def - apply (rule hoare_pre) - apply (wps assms | wpsimp)+ - done - lemma ready_queues_disjoint: "\in_correct_ready_q s; ready_qs_distinct s; d \ d' \ p \ p'\ \ set (ready_queues s d p) \ set (ready_queues s d' p') = {}" @@ -2015,33 +1659,57 @@ defs ksReadyQueues_asrt_def: "ksReadyQueues_asrt \ \s'. \d p. \ts. ready_queue_relation d p ts (ksReadyQueues s' (d, p)) (tcbSchedNexts_of s') (tcbSchedPrevs_of s') - (inQ d p |< tcbs_of' s')" + (inQ d p |< tcbs_of' s') + \ (\t \ set ts. (tcbQueued |< tcbs_of' s') t \ tcb_at' t s')" lemma ksReadyQueues_asrt_cross: - "ready_queues_relation s s' \ ksReadyQueues_asrt s'" - by (fastforce simp: ready_queues_relation_def Let_def ksReadyQueues_asrt_def) - -lemma ex_abs_ksReadyQueues_asrt: - "ex_abs P s \ ksReadyQueues_asrt s" - by (fastforce simp: ex_abs_underlying_def intro: ksReadyQueues_asrt_cross) + "\ready_queues_relation s s'; pspace_relation (kheap s) (ksPSpace s'); + pspace_aligned s; pspace_distinct s\ + \ ksReadyQueues_asrt s'" + apply (frule (1) pspace_aligned_cross) + apply (frule (2) pspace_distinct_cross) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + ksReadyQueues_asrt_def) + apply (rule_tac x="ready_queues s d p" in exI) + apply clarsimp + apply (rule conjI) + apply (rule in_ready_q_tcbQueued_eq[THEN iffD1]) + apply (fastforce simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (fastforce simp: in_ready_q_def) + apply (fastforce intro: aligned'_distinct'_obj_at'I + simp: inQ_def opt_pred_def opt_map_def split: option.splits) + done defs ksReleaseQueue_asrt_def': "ksReleaseQueue_asrt \ \s'. \ts. release_queue_relation_2 ts (ksReleaseQueue s' ) (tcbSchedNexts_of s') (tcbSchedPrevs_of s') - (tcbInReleaseQueue |< tcbs_of' s')" + (tcbInReleaseQueue |< tcbs_of' s') + \ (\t \ set ts. (tcbInReleaseQueue |< tcbs_of' s') t \ tcb_at' t s')" + lemmas ksReleaseQueue_asrt_def = ksReleaseQueue_asrt_def'[simplified release_queue_relation_def] lemma ksReleaseQueue_asrt_cross: - "release_queue_relation s s' \ ksReleaseQueue_asrt s'" - by (fastforce simp: release_queue_relation_def ksReleaseQueue_asrt_def) + "\release_queue_relation s s'; pspace_relation (kheap s) (ksPSpace s'); + pspace_aligned s; pspace_distinct s\ + \ ksReleaseQueue_asrt s'" + apply (frule (1) pspace_aligned_cross) + apply (frule (2) pspace_distinct_cross) + apply (clarsimp simp: release_queue_relation_def ksReleaseQueue_asrt_def) + apply (rule_tac x="release_queue s" in exI) + apply (fastforce intro: aligned'_distinct'_obj_at'I + simp: opt_pred_def opt_map_def split: option.splits) + done crunch addToBitmap for ko_at'[wp]: "\s. P (ko_at' ko ptr s)" and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" and valid_sched_pointers[wp]: valid_sched_pointers and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" and tcbInReleaseQueue[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" + and tcbQueued[wp]: "\s. P (tcbQueued |< tcbs_of' s)" and ksReadyQueues_asrt[wp]: ksReadyQueues_asrt and ksReleaseQueue_asrt[wp]: ksReleaseQueue_asrt and st_tcb_at'[wp]: "\s. P (st_tcb_at' Q tcbPtr s)" @@ -2119,11 +1787,6 @@ lemma thread_get_exs_valid[wp]: by (clarsimp simp: thread_get_def get_tcb_def gets_the_def gets_def return_def get_def exs_valid_def tcb_at_def bind_def) -lemma in_correct_ready_qD: - "\tcb_ptr \ set (ready_queues s d p); kheap s tcb_ptr = Some (TCB tcb); in_correct_ready_q s\ - \ tcb_domain tcb = d \ tcb_priority tcb = p " - by (fastforce simp: in_correct_ready_q_def vs_all_heap_simps) - lemma threadSet_heap_ls_other: "\\s. heap_ls (tcbSchedNexts_of s) st ls \ t \ set ls\ threadSet F t @@ -2141,145 +1804,344 @@ lemma threadSet_prev_queue_head_other: apply (fastforce simp: prev_queue_head_def dest: heap_path_not_Nil hd_in_set) done -lemma list_queue_relation_neighbour_in_set: - "\list_queue_relation ls q hp hp'; sym_heap hp hp'; p \ set ls\ - \ \nbr. (hp p = Some nbr \ nbr \ set ls) \ (hp' p = Some nbr \ nbr \ set ls)" - apply (rule heap_ls_neighbour_in_set) - apply (fastforce simp: list_queue_relation_def) - apply fastforce - apply (clarsimp simp: list_queue_relation_def prev_queue_head_def) - apply fastforce +lemma tcbQueuePrepend_rcorres: + "rcorres + (\_ s'. (\ts. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ ts' = t # ts \ t \ set ts) + \ \ is_sched_linked t s') + (return ts') (tcbQueuePrepend q t) + (\ts' q' _ s'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + supply if_split[split del] + apply (clarsimp simp: tcbQueuePrepend_def tcbQueueEmpty_def bind_if_distribR) + apply (rule rcorres_stateAssert_r_fwd) + apply (rule rcorres_if_r_fwd) + apply clarsimp + apply (rule rcorres_return) + apply (clarsimp simp: list_queue_relation_def queue_end_valid_def prev_queue_head_def) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_not_Nil) + apply (frule (1) heap_path_head) + apply (drule (2) heap_ls_prepend[where new=t]) + apply (rule conjI) + apply (fastforce elim: heap_ls_cong + simp: opt_map_upd_triv opt_map_def obj_at'_def return_def split: if_splits) + apply (clarsimp simp: queue_end_valid_def prev_queue_head_def opt_map_def obj_at'_def return_def + split: if_splits) done -lemma tcbQueueRemove_list_queue_relation_other: - "\\s. list_queue_relation ls queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ sym_heap_sched_pointers s - \ (\ls'. list_queue_relation ls' queue' (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ tcbPtr \ set ls' \ set ls \ set ls' = {})\ - tcbQueueRemove queue' tcbPtr - \\_ s. list_queue_relation ls queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" - unfolding tcbQueueRemove_def list_queue_relation_def - apply (wpsimp wp: threadSet_prev_queue_head_other threadSet_heap_ls_other getTCB_wp - hoare_vcg_ex_lift) - by (fastforce dest: list_queue_relation_neighbour_in_set[where p=tcbPtr, rotated 2] - simp: list_queue_relation_def opt_map_def obj_at'_def) - -lemma tcbQueuePrepend_list_queue_relation_other: - "\\s. list_queue_relation ls queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ (\ls'. list_queue_relation ls' queue' (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ tcbPtr \ set ls \ set ls \ set ls' = {})\ - tcbQueuePrepend queue' tcbPtr - \\_ s. list_queue_relation ls queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" - unfolding tcbQueuePrepend_def list_queue_relation_def - apply (wpsimp wp: threadSet_prev_queue_head_other threadSet_heap_ls_other hoare_vcg_ex_lift) - by (fastforce dest: list_queue_relation_Nil[THEN arg_cong_Not, THEN iffD2, rotated] heap_path_head - simp: list_queue_relation_def) - -lemma tcbQueueAppend_list_queue_relation_other: - "\\s. list_queue_relation ls queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ sym_heap_sched_pointers s - \ (\ls'. list_queue_relation ls' queue' (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ tcbPtr \ set ls \ set ls \ set ls' = {})\ - tcbQueueAppend queue' tcbPtr - \\_ s. list_queue_relation ls queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" - unfolding tcbQueueAppend_def list_queue_relation_def - apply (wpsimp wp: threadSet_prev_queue_head_other threadSet_heap_ls_other hoare_vcg_ex_lift) - by (fastforce dest: list_queue_relation_Nil[THEN arg_cong_Not, THEN iffD2, rotated] heap_path_head - simp: list_queue_relation_def queue_end_valid_def) - -lemma tcbQueueInsert_list_queue_relation_other: - "\\s. list_queue_relation ls queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ sym_heap_sched_pointers s - \ tcbPtr \ set ls - \ (\ls' queue'. list_queue_relation ls' queue' (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ afterPtr \ set ls' \ set ls \ set ls' = {})\ - tcbQueueInsert tcbPtr afterPtr - \\_ s. list_queue_relation ls queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" - unfolding tcbQueueInsert_def list_queue_relation_def - apply (wpsimp wp: threadSet_prev_queue_head_other threadSet_heap_ls_other getTCB_wp - hoare_vcg_ex_lift) - by (force dest!: heap_ls_neighbour_in_set[where p=afterPtr] intro!: exI[where x=ls] - simp: prev_queue_head_def opt_map_def obj_at'_def) - -lemma tcbQueued_update_tcbInReleaseQueue[wp]: - "threadSet (tcbQueued_update f) tcbPtr \\s. P (tcbInReleaseQueue |< tcbs_of' s)\" - by (wpsimp wp: threadSet_tcbInReleaseQueue) - -lemma threadSet_tcbPriority: - "(\tcb. tcbPriority (F tcb) = tcbPriority tcb) \ - threadSet F t \\s. P ((\tcb. Q (tcbPriority tcb)) |< tcbs_of' s)\" - apply (wpsimp wp: threadSet_wp) - by (fastforce elim: rsubst[where P=P] simp: opt_pred_def opt_map_def obj_at'_def) +lemma tcbQueueAppend_rcorres: + "rcorres + (\_ s'. (\ts. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ t \ set ts \ ts' = ts @ [t]) + \ \ is_sched_linked t s') + (return ts') (tcbQueueAppend q t) + (\ts' q' _ s'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + supply if_split[split del] + apply (clarsimp simp: tcbQueueAppend_def tcbQueueEmpty_def bind_if_distribR) + apply (rule rcorres_stateAssert_r_fwd) + apply (rule rcorres_if_r_fwd) + apply clarsimp + apply (rule rcorres_return) + apply (clarsimp simp: list_queue_relation_def queue_end_valid_def prev_queue_head_def) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_not_Nil) + apply (frule (1) heap_path_head) + apply (drule (2) heap_ls_append[where new=t]) + apply (rule conjI) + apply (erule heap_ls_cong) + apply (subst opt_map_upd_triv) + apply (fastforce simp: opt_map_def obj_at'_def) + apply (clarsimp simp: queue_end_valid_def) + apply (subst fun_upd_swap) + apply fastforce + apply (simp add: opt_map_upd_triv_None opt_map_upd_triv obj_at'_def) + apply simp + apply simp + apply (force simp: queue_end_valid_def prev_queue_head_def opt_map_def obj_at'_def return_def) + apply (force simp: queue_end_valid_def prev_queue_head_def opt_map_def obj_at'_def return_def + split: if_splits) + done -lemma threadSet_tcbDomain: - "(\tcb. tcbDomain (F tcb) = tcbDomain tcb) \ - threadSet F t \\s. P ((\tcb. Q (tcbDomain tcb)) |< tcbs_of' s)\" - apply (wpsimp wp: threadSet_wp) - by (fastforce elim: rsubst[where P=P] simp: opt_pred_def opt_map_def obj_at'_def) +defs sym_heap_sched_pointers_asrt_def: + "sym_heap_sched_pointers_asrt \ sym_heap_sched_pointers" -lemma ready_or_release_disjoint: - "ready_or_release s \ set (ready_queues s d p) \ set (release_queue s) = {}" - by (fastforce simp: ready_or_release_def in_ready_q_def not_in_release_q_def) +declare sym_heap_sched_pointers_asrt_def[simp] -lemma setQueue_ksReadyQueues_other: - "\\s. P (ksReadyQueues s (d, p)) \ (domain \ d \ priority \ p)\ - setQueue domain priority ts - \\_ s. P (ksReadyQueues s (d, p))\" - by (wpsimp simp: setQueue_def) +lemma tcbQueueInsert_rcorres: + "rcorres + (\_ s'. (\ts. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ t \ set ts \ afterPtr \ set ts \ afterPtr \ hd ts + \ ts' = list_insert_before ts afterPtr t) + \ sym_heap_sched_pointers s') + (return ts') (do _ \ tcbQueueInsert t afterPtr; return q od) + (\ts' q' _ s'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + supply heap_path_append[simp del] + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (clarsimp simp: tcbQueueInsert_def bind_assoc) + apply (rule bind_wp[OF _ stateAssert_sp])+ + apply (rule bind_wp[OF _ get_tcb_sp'], rename_tac after_tcb) + apply (rule bind_wp[OF _ assert_sp]) + apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac beforePtr) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (clarsimp simp: list_queue_relation_def return_def) + apply normalise_obj_at' + apply (frule heap_ls_distinct) + apply (frule heap_path_head') + apply (clarsimp simp: in_set_conv_decomp) + apply (rename_tac xs ys) + apply (frule (1) heap_path_sym_heap_non_nil_lookup_prev) + apply fastforce + apply (cut_tac xs=xs and ys="afterPtr # ys" and new=t in list_insert_before_distinct) + apply (fastforce dest: heap_ls_distinct) + apply fastforce + apply (drule heap_ls_list_insert_before[where new=t]) + apply (fastforce dest!: split_list) + apply (fastforce dest: heap_ls_distinct) + apply fastforce + apply (drule obj_at'_prop)+ + apply clarsimp + apply (prop_tac "t \ set xs") + apply (fastforce dest: heap_ls_distinct simp: opt_map_red split: if_splits) + apply (prop_tac "beforePtr = last xs", clarsimp simp: obj_at'_def opt_map_def) + apply clarsimp + apply (prop_tac "last xs \ t") + apply (frule heap_ls_distinct) + apply (case_tac xs; clarsimp split: if_splits) + apply clarsimp + apply (rule conjI) + apply (fastforce elim!: rsubst3[where P=heap_ls] simp: opt_map_red) + apply (rule conjI) + apply (case_tac ys; fastforce simp: queue_end_valid_def) + apply (case_tac xs; fastforce simp: prev_queue_head_def opt_map_def split: if_splits) + done + +lemma takeWhile_dropWhile_enqueue: + "\sorted_wrt (img_ord (\t. f t s) (opt_ord_rel R)) ts; \t \ set ts. \v. f t s = Some v; + ts \ []; f (hd ts) s = Some head_val; R val head_val; val \ head_val; antisymp R; reflp R\ + \ takeWhile (\val'. R (the (f val' s)) val) ts + @ t # dropWhile (\val'. R (the (f val' s)) val) ts + = t # ts" + apply (prop_tac "\x \ set ts. R head_val (the (f x s))") + apply (clarsimp, rename_tac x) + apply (case_tac "x = hd ts") + apply (fastforce dest: reflpD) + apply (clarsimp simp: in_set_conv_nth) + apply (rename_tac i) + apply (frule_tac i=0 and j=i in sorted_wrt_nth_less) + apply (fastforce intro: gr0I simp: hd_conv_nth) + apply fastforce + apply (drule_tac x="ts ! i" in bspec, fastforce) + apply (fastforce simp: img_ord_Some' hd_conv_nth) + apply (subst takeWhile_eq_Nil_iff[THEN iffD2], fastforce simp: antisympD) + apply (subst dropWhile_eq_self_iff[THEN iffD2], fastforce simp: antisympD) + apply simp + done -lemma tcbQueued_update_inQ_other: - "\\s. P (inQ d p |< tcbs_of' s) - \ ((\tcb. tcbDomain tcb \ d \ tcbPriority tcb \ p) |< tcbs_of' s) tcbPtr\ - threadSet (tcbQueued_update f) tcbPtr - \\_ s. P (inQ d p |< tcbs_of' s)\" - apply (wpsimp wp: threadSet_wp) - by (fastforce elim: rsubst[where P=P] simp: inQ_def opt_pred_def opt_map_def obj_at'_def) +lemma takeWhile_dropWhile_append: + "\sorted_wrt (img_ord (\t. f t s) (opt_ord_rel R)) ts; \t \ set ts. \v. f t s = Some v; + ts \ []; R (the (f (last ts) s)) val; transp R; reflp R\ + \ takeWhile (\val'. R (the (f val' s)) val) ts + @ t # dropWhile (\val'. R (the (f val' s)) val) ts + = ts @ [t]" + apply (prop_tac "\x \ set ts. R (the (f x s)) (the (f (last ts) s))") + apply (clarsimp, rename_tac x) + apply (case_tac "x = last ts") + apply (fastforce dest!: reflpD last_in_set) + apply (clarsimp simp: in_set_conv_nth last_conv_nth, rename_tac i) + apply (frule_tac i=i and j="length ts - 1" in sorted_wrt_nth_less) + apply (fastforce dest: le_neq_implies_less nat_le_Suc_less_imp) + apply fastforce + apply (frule_tac x="ts ! (length ts - Suc 0)" in bspec, fastforce) + apply (drule_tac x="ts ! i" in bspec, fastforce) + apply (fastforce simp: img_ord_Some') + apply (subst takeWhile_eq_all_conv[THEN iffD2], fastforce elim: transpE) + apply (fastforce elim: transpE) + done + +lemma findInsertionPoint_rv_in_set: + "\\s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ ts \ [] \ (\t \ set ts. \v. f t s' = Some v) + \ (\v. f (hd ts) s' = Some v \ R v val) \ (\v. f (last ts) s' = Some v \ \ R v val)\ + findInsertionPoint val (tcbQueueHead q) f R + \\ptrOpt _. \ptr. ptrOpt = Some ptr \ ptr \ set ts \ ptr \ hd ts\" + (is "\?pre\ _ \_\") + apply (clarsimp simp: findInsertionPoint_def) + apply (rule hoare_pre) + apply (rule_tac Q4="\ptrOpt s'. ?pre s' \ (\ptr. ptrOpt = Some ptr \ ptr \ set ts)" + in valid_whileLoop[where P=Q and I=Q for Q, simplified]) + apply clarsimp + apply (wpsimp wp: hoare_vcg_ex_lift getTCB_wp) + apply (clarsimp simp: list_queue_relation_def compareVals_def runReaderT_def obind_def) + apply (prop_tac "ptr \ last ts") + apply fastforce + apply (frule (2) not_last_next_not_None) + apply (fastforce dest!: heap_ls_next_in_list simp: obj_at'_def opt_map_def) + apply (clarsimp simp: compareVals_def runReaderT_def obind_def) + apply (fastforce dest: heap_path_head simp: list_queue_relation_def) + done + +lemma compareVals_not_None: + "the (runReaderT (compareVals val r f R) s) \ \ptr. r = Some ptr" + by (fastforce simp: compareVals_def runReaderT_def split: if_splits) + +lemma findInsertionPoint_rv_rel: + "\reflp R; transp R; totalp R\ \ + \\s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sym_heap_sched_pointers s' + \ sorted_wrt (img_ord (\t. f t s') (opt_ord_rel R)) ts + \ ts \ [] \ (\t \ set ts. \v. f t s' = Some v) \ (\t \ set ts. tcb_at' t s') + \ (\v. f (hd ts) s' = Some v \ R v val) \ (\v. f (last ts) s' = Some v \ \ R v val) + \ val' = val\ + findInsertionPoint val (tcbQueueHead q) f R + \\ptrOpt s'. \ptr. (ptrOpt = Some ptr \ ptr \ set ts \ ptr \ hd ts) + \ (\val'. f ptr s' = Some val' \ R val val' \ val \ val') + \ (\pfx. (\sfx. pfx @ ptr # sfx = ts) + \ (\p \ set pfx. R (the (f p s')) val'))\" + (is "\_; _; _\ \ \?pre\ _ \_\") + supply heap_path_append[simp del] + apply (rule hoeare_ex_context_conj) + apply (wpsimp wp: findInsertionPoint_rv_in_set) + apply (clarsimp simp: findInsertionPoint_def) + apply (rule hoare_pre) + apply (rule_tac Q4="\ptrOpt s'. ?pre s' + \ (\ptr. (ptrOpt = Some ptr \ ptr \ set ts) + \ (\pfx sfx. pfx @ ptr # sfx = ts + \ (\p \ set pfx. R (the (f p s')) val')))" + in valid_whileLoop[where P=Q and I=Q for Q, simplified]) + apply fastforce + apply (clarsimp simp: no_ofail_def) + apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) + apply (wp hoare_vcg_ex_lift getTCB_wp) + apply (intro impI allI ballI) + apply (rename_tac tcb ptr pfx p) + apply (elim conjE) + apply (frule compareVals_not_None) + apply simp + apply (elim exE) + apply (rename_tac prev_ptr) + apply (prop_tac "prev_ptr = last pfx") + apply (clarsimp simp: list_queue_relation_def) + apply (frule (1) heap_path_sym_heap_non_nil_lookup_prev) + apply fastforce + apply (frule_tac p=prev_ptr and p'=ptr in sym_heapD1) + apply (clarsimp simp: obj_at'_def opt_map_def) + apply clarsimp + apply (drule_tac x="last pfx" in spec) + apply (elim impE) + apply (case_tac pfx; clarsimp) + apply (case_tac "p = last pfx") + apply (force dest!: bspec simp: compareVals_def runReaderT_def obind_def) + apply (drule_tac x="butlast pfx" in spec) + apply (elim impE) + apply (rule_tac x="ptr # sfx" in exI) + apply (fastforce intro: append_butlast_last_id) + apply (fastforce simp: not_last_in_set_butlast) + apply (intro conjI impI allI) + apply (clarsimp simp: compareVals_def runReaderT_def obind_def split: option.splits) + apply fastforce + apply (metis reflpD totalpD) + apply fastforce + apply (fastforce dest!: heap_path_sym_heap_non_nil_lookup_prev + simp: list_queue_relation_def prev_queue_head_def) + done -lemma threadSet_inQ: - "\\tcb. tcbPriority (F tcb) = tcbPriority tcb; \tcb. tcbDomain (F tcb) = tcbDomain tcb; - \tcb. tcbQueued (F tcb) = tcbQueued tcb\ - \ threadSet F tcbPtr \\s. P (inQ d p |< tcbs_of' s)\" - apply (wpsimp wp: threadSet_wp) - by (fastforce elim: rsubst[where P=P] simp: inQ_def opt_pred_def opt_map_def obj_at'_def) +crunch findInsertionPoint + for inv[wp]: P + (wp: crunch_wps) -crunch tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert - for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" - and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" - and tcbInReleaseQueue_opt_pred[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" - and tcbQueued_opt_pred[wp]: "\s. P (tcbQueued |< tcbs_of' s)" - and tcbPriority_opt_pred[wp]: "\s. P ((\tcb. Q (tcbPriority tcb)) |< tcbs_of' s)" - and tcbDomain_opt_pred[wp]: "\s. P ((\tcb. Q (tcbDomain tcb)) |< tcbs_of' s)" - and inQ_opt_pred[wp]: "\s. P (inQ d p |< tcbs_of' s)" - (wp: crunch_wps threadSet_tcbPriority threadSet_tcbDomain threadSet_inQ - threadSet_tcbInReleaseQueue threadSet_tcbQueued - ignore: threadSet) - -lemma set_butlast: - "distinct list \ set (butlast list) = (set list) - {last list}" - by (induct list, simp+, fastforce) - -\ \ - A direct analogue of tcbQueueRemove, used in tcb_sched_dequeue' below, so that within the proof of - tcbQueueRemove_corres, we may reason in terms of the list operations used within this function - rather than @{term filter}.\ -definition tcb_queue_remove :: "'a \ 'a list \ 'a list" where - "tcb_queue_remove a ls \ - if ls = [a] - then [] - else if a = hd ls - then tl ls - else if a = last ls - then butlast ls - else list_remove ls a" - -lemma set_tcb_queue_remove: - "distinct ls \ set (tcb_queue_remove t ls) = set ls - {t}" - by (auto dest: set_remove1_eq[where x=t] - simp: tcb_queue_remove_def set_butlast list_remove_removed) - -lemma tcb_queue_remove_middle: - "distinct (xs @ tcbPtr # ys) \ tcb_queue_remove tcbPtr (xs @ tcbPtr # ys) = xs @ ys" - by (cases xs; fastforce simp: tcb_queue_remove_def list_remove_none) +lemma orderedInsert_rcorres: + assumes rcorres: "\t. rcorres (P t) (gets_the (f t)) (gets_the (f' t)) (\rv rv' _ _. rv = rv')" + assumes nf: "\t. no_ofail (Q t) (f t)" + assumes nf': "\t s. no_ofail (\s'. Q' t s s') (f' t)" + assumes ord: "reflp R" "totalp R" "transp R" "antisymp R" + shows + "rcorres + (\s s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sorted_wrt (img_ord (\t. f t s) (opt_ord_rel R)) ts + \ sym_heap_sched_pointers s' \ \ is_sched_linked t s' + \ (\t \ set ts. Q t s) \ Q t s \ t \ set ts \ (\t \ set ts. tcb_at' t s') + \ (\t \ set ts. P t s s' \ Q' t s s') \ P t s s' \ Q' t s s') + (ordered_insert t ts f R) (orderedInsert t q f' R) + (\ts' q' s s'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (insert assms) + apply (clarsimp simp: ordered_insert_def orderedInsert_def) + apply (rule rcorres_symb_exec_r[OF stateAssert_inv]) + apply (rule rcorres_split_gets_the_fwd[where rrel="(=)"]) + apply (fastforce intro: rcorres_weaken_pre[OF rcorres]) + apply (fastforce simp: no_ofail_def) + apply (rename_tac val val') + apply (rule rcorres_symb_exec_l) + apply (rule mapM_gets_the_sp') + apply (rule_tac P="\s. \t \ set ts. Q t s" in exs_valid_state_inv) + apply (wpsimp wp: mapM_wp_inv) + apply (wpsimp wp: no_fail_mapM_wp) + apply (fastforce intro: no_ofailD) + apply (fastforce intro: no_ofailD) + apply (wpsimp wp: empty_fail_mapM) + apply (rename_tac vals) + apply (cases "tcbQueueEmpty q") + apply clarsimp + apply (rcorres rcorres: tcbQueuePrepend_rcorres) + apply (force intro!: exI[where x=ts] dest: list_queue_relation_Nil) + apply (rule_tac Q="\s s'. (\t \ set ts. f t s = f' t s') \ vals = map (\t. the (f' t s')) ts" + in rcorres_add_to_pre) + apply (fastforce dest: rcorres_rrel') + apply (simp only: if_False bind_assoc haskell_assert_def) + apply (rule rcorres_assert_r_fwd) + apply (simp only: K_bind_def bind_assoc fun_app_def) + apply (rule rcorres_symb_exec_r[OF return_sp]; (solves \wpsimp simp: tcbQueueEmpty_def\)?) + apply (rule rcorres_symb_exec_r[OF gets_the_sp]; (solves wpsimp)?) + apply (rule rcorres_symb_exec_r[OF return_sp]; (solves wpsimp)?) + apply (rule rcorres_if_r_fwd) + apply (rcorres rcorres: tcbQueuePrepend_rcorres) + apply clarsimp + apply (frule list_queue_relation_Nil) + apply (clarsimp simp: list_queue_relation_def) + apply (frule (1) heap_path_head) + apply (fastforce elim!: takeWhile_dropWhile_enqueue) + apply (rule rcorres_assert_r_fwd) + apply clarsimp + apply (rule rcorres_symb_exec_r[OF gets_the_sp]; (solves wpsimp)?) + apply (rule rcorres_if_r_fwd) + apply (rcorres rcorres: tcbQueueAppend_rcorres) + apply clarsimp + apply (frule list_queue_relation_Nil) + apply (clarsimp simp: list_queue_relation_def queue_end_valid_def) + apply (fastforce elim!: takeWhile_dropWhile_append) + apply (rule_tac Q="\_ s'. sorted_wrt (img_ord (\t. f' t s') (opt_ord_rel R)) ts" + in rcorres_add_to_pre) + apply (rule sorted_wrt_img_ord_eq_lift[THEN iffD1, rotated]) + apply fastforce + apply (fastforce dest: rcorres_rrel') + apply (rule_tac F="val' = val" in rcorres_req) + apply fastforce + apply clarsimp + apply (rule_tac Q="\ptrOpt s s'. list_queue_relation + ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sym_heap_sched_pointers s' \ t \ set ts + \ (\t\set ts. Q' t s s') + \ vals = map (\t. the (f' t s')) ts + \ (\ptr. ptrOpt = Some ptr \ ptr \ set ts \ ptr \ hd ts + \ (\v. f' ptr s'= Some v \ R val v \ val \ v) + \ (\pfx. (\sfx. pfx @ ptr # sfx = ts) + \ (\p\set pfx. R (the (f' p s')) val)))" + in rcorres_symb_exec_r) + apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) + apply (wpsimp wp: findInsertionPoint_rv_rel[simplified]) + apply (frule list_queue_relation_Nil) + apply (clarsimp dest!: heap_path_head simp: list_queue_relation_def queue_end_valid_def) + apply (metis reflpD totalpD) + apply (rule rcorres_assert_r_fwd) + apply (rule rcorres_stateAssert_r_fwd) + apply (rcorres rcorres: tcbQueueInsert_rcorres) + supply map_fst_dropWhile_zip[simp del] map_fst_takeWhile_zip[simp del] + apply (clarsimp simp: list_queue_relation_def) + apply (blast intro: takeWhile_dropWhile_insert_list_before no_ofailD dest: heap_ls_distinct) + done lemma in_queue_not_head_or_not_tail_length_gt_1: "\tcbPtr \ set ls; tcbQueueHead q \ Some tcbPtr \ tcbQueueEnd q \ Some tcbPtr; @@ -2287,203 +2149,874 @@ lemma in_queue_not_head_or_not_tail_length_gt_1: \ Suc 0 < length ls" by (cases ls; fastforce simp: list_queue_relation_def queue_end_valid_def) -lemma tcbQueueRemove_list_queue_relation: - "\\s. list_queue_relation ls q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ sym_heap_sched_pointers s - \ tcbPtr \ set ls\ - tcbQueueRemove q tcbPtr - \\q' s. list_queue_relation (tcb_queue_remove tcbPtr ls) q' (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" - supply heap_path_append[simp del] distinct_append[simp del] - apply (clarsimp simp: tcbQueueRemove_def) - apply (wpsimp wp: threadSet_wp getTCB_wp) - apply (intro conjI impI allI) - \ \ls is a singleton list containing tcbPtr\ - apply (clarsimp simp: list_queue_relation_def queue_end_valid_def prev_queue_head_def - tcb_queue_remove_def heap_ls_unique heap_path_last_end - emptyHeadEndPtrs_def) - apply (frule heap_ls_distinct) - apply (cases ls; clarsimp) - \ \tcbPtr is the head of ls\ - apply (clarsimp simp: list_queue_relation_def) - apply (frule heap_path_head') - apply (frule set_list_mem_nonempty) - apply (frule in_queue_not_head_or_not_tail_length_gt_1) - apply fastforce - apply (force dest!: spec simp: list_queue_relation_def) - apply (intro conjI) - apply (frule list_not_head) - apply (clarsimp simp: tcb_queue_remove_def) - apply (frule length_tail_nonempty) - apply (frule (2) heap_ls_next_of_hd) - apply (drule (1) heap_ls_remove_head_not_singleton) - apply (clarsimp simp: opt_map_red opt_map_upd_triv obj_at'_def) - apply (cases ls; clarsimp simp: queue_end_valid_def tcb_queue_remove_def) - apply (clarsimp simp: prev_queue_head_def tcb_queue_remove_def opt_map_def obj_at'_def) - \ \tcbPtr is the last element of ls\ +lemma tcbQueueRemove_rcorres: + "rcorres + (\_ s'. (\ts. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ t \ set ts \ ts' = removeAll t ts) + \ sym_heap_sched_pointers s') + (return ts') (tcbQueueRemove q t) + (\ts' q' _ s'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + supply heap_path_append[simp del] distinct_append[simp del] filter_append[simp del] + if_split[split del] + apply (clarsimp simp: tcbQueueRemove_def removeAll_filter_not_eq) + apply (rule rcorres_stateAssert_r_fwd) + apply (rule rcorres_stateAssert_r_fwd) + apply (rule rcorres_symb_exec_r[OF get_tcb_sp']) + apply wpsimp + apply (rule rcorres_if_r_fwd) + \ \ts is the singleton list containing tcbPtr\ + apply (rule rcorres_return) + apply (clarsimp simp: list_queue_relation_def queue_end_valid_def prev_queue_head_def + emptyHeadEndPtrs_def) + apply (rename_tac ts) + apply (frule heap_ls_distinct) + apply (case_tac ts; clarsimp split: if_splits) + apply (rule rcorres_if_r_fwd) + \ \tcbPtr is the head of ts\ + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (rename_tac ts nextPtr tcb tcb') apply (clarsimp simp: list_queue_relation_def) + apply (frule heap_path_head') + apply (frule set_list_mem_nonempty) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fastforce + apply (force simp: list_queue_relation_def) + apply (clarsimp simp: return_def) + apply (frule length_tail_nonempty) + apply (frule heap_ls_distinct) + apply (frule (1) filter_hd_equals_tl) + apply (frule (2) heap_ls_next_of_hd) + apply (intro conjI) + apply (drule (1) heap_ls_remove_head_not_singleton) + apply (clarsimp simp: return_def) + apply (erule heap_ls_cong; simp?) + apply (clarsimp simp: opt_map_red opt_map_upd_triv obj_at'_def) + apply (clarsimp simp: prev_queue_head_def opt_map_def obj_at'_def) + apply (case_tac ts; clarsimp simp: queue_end_valid_def) + apply (clarsimp simp: prev_queue_head_def obj_at'_def split: if_splits) + apply (rule rcorres_if_r_fwd) + \ \tcbPtr is the last element of ts\ + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (rename_tac ts prevPtr tcb tcb') + apply (clarsimp simp: list_queue_relation_def return_def) + apply (frule in_queue_not_head_or_not_tail_length_gt_1) + apply fast + apply (force dest!: spec simp: list_queue_relation_def) + apply (frule length_gt_1_imp_butlast_nonempty) + apply (frule heap_ls_distinct) + apply (frule filter_last_equals_butlast, fastforce) + apply (prop_tac "t = last ts") + apply (clarsimp simp: queue_end_valid_def) + apply (frule (2) heap_path_prev_of_last) apply (intro conjI) - apply (frule in_queue_not_head_or_not_tail_length_gt_1) - apply fast - apply (force dest!: spec simp: list_queue_relation_def) - apply (clarsimp simp: queue_end_valid_def) - apply (frule list_not_last) - apply (clarsimp simp: tcb_queue_remove_def) - apply (frule length_gt_1_imp_butlast_nonempty) - apply (frule (2) heap_path_prev_of_last) - apply (intro conjI impI; clarsimp?) - apply (cases ls; clarsimp) apply (drule (1) heap_ls_remove_last_not_singleton) - apply (force elim!: rsubst3[where P=heap_ls] simp: opt_map_def obj_at'_def) - apply (clarsimp simp: queue_end_valid_def tcb_queue_remove_def) - apply (frule heap_path_prev_of_last) - apply (fastforce intro: butlast_nonempty_length) - apply (cases ls; fastforce) - apply (cases ls; force simp: opt_map_def obj_at'_def) - apply (clarsimp simp: prev_queue_head_def opt_map_def obj_at'_def) - \ \tcbPtr is in the middle of ls\ - apply (clarsimp simp: list_queue_relation_def) + apply (erule heap_ls_cong; simp?) + apply (fastforce simp: opt_map_def obj_at'_def intro: butlast_nonempty_length split: if_splits) + apply (clarsimp simp: queue_end_valid_def opt_map_def obj_at'_def) + apply (clarsimp simp: prev_queue_head_def opt_map_def obj_at'_def split: if_splits) + \ \tcbPtr is in the middle of ts\ + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (clarsimp simp: list_queue_relation_def return_def) + apply (rename_tac ts nextPtr prevPtr tcb tcb' tcb'' tcb''') apply (frule heap_ls_distinct) apply (frule split_list) apply (elim exE) apply (rename_tac xs ys) + apply (frule_tac q=ts in filter_middle_distinct, assumption) apply (prop_tac "xs \ [] \ ys \ []", fastforce simp: queue_end_valid_def) apply clarsimp - apply (frule (2) ptr_in_middle_prev_next[where ptr=tcbPtr]) - apply fastforce - apply (frule tcb_queue_remove_middle) + apply (frule (3) ptr_in_middle_prev_next[where ptr=t]) apply clarsimp apply (intro conjI) apply (drule (2) heap_ls_remove_middle) - apply (fastforce elim!: rsubst3[where P=heap_ls] simp: opt_map_def obj_at'_def) + apply (fastforce elim!: heap_ls_cong simp: opt_map_def obj_at'_def split: if_splits) apply (simp add: queue_end_valid_def) apply (subst opt_map_upd_triv) - apply (clarsimp simp: prev_queue_head_def tcb_queue_remove_def opt_map_def obj_at'_def) + apply (clarsimp simp: prev_queue_head_def opt_map_def obj_at'_def) apply (intro prev_queue_head_heap_upd) apply assumption apply (frule heap_path_head') apply (prop_tac "the (tcbQueueHead q) \ set xs") apply (fastforce simp: hd_append) - apply (fastforce simp: hd_append distinct_append opt_map_def obj_at'_def) + apply (fastforce simp: distinct_append opt_map_def obj_at'_def) apply fastforce done -lemma tcbQueuePrepend_list_queue_relation: - "\\s. list_queue_relation ls q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ sym_heap_sched_pointers s - \ tcbPtr \ set ls \ (tcbSchedNexts_of s) tcbPtr = None \ (tcbSchedPrevs_of s) tcbPtr = None\ - tcbQueuePrepend q tcbPtr - \\q' s. list_queue_relation (tcbPtr # ls) q' (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" - supply if_split[split del] - apply (clarsimp simp: tcbQueuePrepend_def tcbQueueEmpty_def) - apply (wpsimp wp: threadSet_wp getTCB_wp) - apply (intro conjI impI allI) - \ \ls was originally empty\ - apply (clarsimp simp: list_queue_relation_def queue_end_valid_def prev_queue_head_def) - \ \ls was not originally empty\ - apply (clarsimp simp: list_queue_relation_def) - apply (frule heap_path_not_Nil) - apply (frule (1) heap_path_head) - apply (drule (2) heap_ls_prepend[where new=tcbPtr]) - apply (rule conjI) - apply (fastforce elim: rsubst3[where P=heap_ls] - simp: opt_map_upd_triv opt_map_def obj_at'_def split: if_splits) - apply (clarsimp simp: queue_end_valid_def prev_queue_head_def opt_map_def obj_at'_def - split: if_splits) +lemma tcbQueuePrepend_rcorres_other: + "rcorres + (\_ s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ (\ts'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ t' \ set ts \ set ts \ set ts' = {})) + (return ts') (tcbQueuePrepend q' t') + (\ts' q' _ s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + unfolding tcbQueuePrepend_def list_queue_relation_def + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: threadSet_prev_queue_head_other threadSet_heap_ls_other hoare_vcg_ex_lift) + by (fastforce dest: list_queue_relation_Nil[THEN arg_cong_Not, THEN iffD2, rotated] heap_path_head + simp: list_queue_relation_def return_def) + +lemma tcbQueueAppend_rcorres_other: + "rcorres + (\_ s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ (\ts'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ t' \ set ts \ set ts \ set ts' = {})) + (return ts') (tcbQueueAppend q' t') + (\ts' q' _ s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + unfolding tcbQueueAppend_def list_queue_relation_def + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: threadSet_prev_queue_head_other threadSet_heap_ls_other hoare_vcg_ex_lift) + by (fastforce dest: list_queue_relation_Nil[THEN arg_cong_Not, THEN iffD2, rotated] heap_path_head + simp: list_queue_relation_def queue_end_valid_def return_def) + +lemma tcbQueueInsert_rcorres_other: + "rcorres + (\_ s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sym_heap_sched_pointers s' \ t' \ set ts + \ (\ts' q'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ afterPtr \ set ts' \ set ts \ set ts' = {})) + (return ts') (do _ \ tcbQueueInsert t' afterPtr; return q' od) + (\ts' q' _ s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + unfolding tcbQueueInsert_def list_queue_relation_def + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: threadSet_prev_queue_head_other threadSet_heap_ls_other getTCB_wp + hoare_vcg_ex_lift) + by (force dest: heap_ls_neighbour_in_set[where p=afterPtr] intro!: exI[where x=ts] + simp: prev_queue_head_def opt_map_def obj_at'_def return_def) + +lemma orderedInsert_rcorres_other: + assumes rcorres: "\t. rcorres (P t) (gets_the (f t)) (gets_the (f' t)) (\rv rv' _ _. rv = rv')" + assumes nf: "\t. no_ofail (Q t) (f t)" + assumes nf': "\t s. no_ofail (\s'. Q' t s s') (f' t)" + assumes ord: "reflp R" "totalp R" + shows + "rcorres + (\s s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sym_heap_sched_pointers s' + \ t' \ set ts \ set ts \ set ts' = {} + \ (\t \ set ts'. Q t s) \ Q t' s \ (\t \ set ts'. tcb_at' t s') + \ (\t \ set ts'. P t s s' \ Q' t s s') \ P t' s s' \ Q' t' s s') + (ordered_insert t' ts' f R) (orderedInsert t' q' f' R) + (\_ _ _ s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (insert assms) + apply (simp only: ordered_insert_def orderedInsert_def) + apply (rule rcorres_stateAssert_r_fwd) + apply clarsimp + apply (rule rcorres_split_gets_the_fwd[where rrel="(=)"]) + apply (fastforce intro: rcorres_weaken_pre[OF rcorres]) + apply (fastforce intro: no_ofail_pre_imp) + apply (rule rcorres_symb_exec_l) + apply (rule mapM_gets_the_sp') + apply (rule_tac P="\s. \t \ set ts'. Q t s" in exs_valid_state_inv) + apply (wpsimp wp: mapM_wp_inv) + apply (wpsimp wp: no_fail_mapM_wp) + apply (fastforce intro: no_ofailD) + apply fastforce + apply (wpsimp wp: empty_fail_mapM) + apply (rename_tac vals) + apply (rule_tac Q="\s s'. \t \ set ts'. f t s = f' t s'" in rcorres_add_to_pre) + apply (fastforce dest: rcorres_rrel') + apply (cases "tcbQueueEmpty q'") + apply clarsimp + apply (rcorres rcorres: tcbQueuePrepend_rcorres_other) + apply fastforce + apply (simp only: if_False bind_assoc haskell_assert_def) + apply (rule rcorres_assert_r_fwd) + apply (clarsimp simp: bind_assoc) + apply (rule rcorres_symb_exec_r[OF gets_the_sp]; (solves wpsimp)?) + apply (rule rcorres_if_r_fwd) + apply (rcorres rcorres: tcbQueuePrepend_rcorres_other) + apply fastforce + apply (rule rcorres_assert_r_fwd) + apply clarsimp + apply (rule rcorres_symb_exec_r[OF gets_the_sp]; (solves wpsimp)?) + apply (rule rcorres_if_r_fwd) + apply (rcorres rcorres: tcbQueueAppend_rcorres_other) + apply fast + apply (rule_tac Q="\ptrOpt s s'. list_queue_relation + ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ list_queue_relation + ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sym_heap_sched_pointers s' + \ t' \ set ts \ set ts \ set ts' = {} + \ vals = map (\t. the (f' t s')) ts' + \ (\ptr. ptrOpt = Some ptr \ ptr \ set ts' \ ptr \ hd ts')" + in rcorres_symb_exec_r) + apply (wpsimp wp: findInsertionPoint_rv_in_set) + apply (frule list_queue_relation_Nil[where ts=ts']) + apply (clarsimp dest!: heap_path_head simp: list_queue_relation_def queue_end_valid_def) + apply (metis reflpD totalpD) + apply wpsimp + apply (rule rcorres_assert_r_fwd) + apply (rule rcorres_stateAssert_r_fwd) + apply (rcorres rcorres: tcbQueueInsert_rcorres_other) + apply fastforce done -(* FIXME RT: move *) -lemma heap_upd_cong: - "\hp = hp'; p = p'\ \ hp(p := val) = hp' (p' := val)" - by fastforce +lemma tcbQueueRemove_rcorres_other: + "rcorres + (\_ s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sym_heap_sched_pointers s' + \ (\ts'. list_queue_relation ts' q' (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ t \ set ts' \ set ts \ set ts' = {})) + (return ts') (tcbQueueRemove q' t) + (\_ _ _ s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + unfolding tcbQueueRemove_def list_queue_relation_def + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: threadSet_prev_queue_head_other threadSet_heap_ls_other getTCB_wp + hoare_vcg_ex_lift) + by (fastforce dest: list_queue_relation_neighbour_in_set[where p=t, rotated 2] + simp: list_queue_relation_def opt_map_def obj_at'_def return_def) -lemma tcbQueueAppend_list_queue_relation: - "\\s. list_queue_relation ls q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ sym_heap_sched_pointers s - \ tcbPtr \ set ls - \ (tcbSchedNexts_of s) tcbPtr = None \ (tcbSchedPrevs_of s) tcbPtr = None\ - tcbQueueAppend q tcbPtr - \\q' s. list_queue_relation (ls @ [tcbPtr]) q' (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" +defs insertionPoint_asrt_def: + "insertionPoint_asrt \ + \q ptr s. \ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ ptr \ set ts" + +declare insertionPoint_asrt_def[simp] + +lemma det_wp_ordered_insert[wp]: + "(\t. no_ofail (P t) (f t)) + \ det_wp (\s. P t s \ (\t \ set ts. P t s)) (ordered_insert t ts f R)" + unfolding ordered_insert_def + apply wpsimp + apply (clarsimp simp: no_ofail_def) + done + +abbreviation (input) ls_opt_rel :: "'a list \ 'a option \ bool" where + "ls_opt_rel ls opt \ if ls = [] then opt = None else \ptr. opt = Some ptr \ hd ls = ptr" + +lemma return_tl_return_next_corres_underlying: + "ls_opt_rel ts ptrOpt \ + corres_underlying {(s, s'). s = s'} False True ls_opt_rel + (\_. ts \ []) + (\s'. \ptr. ptrOpt = Some ptr \ heap_ls (tcbSchedNexts_of s') ptrOpt ts \ tcb_at' ptr s') + (return (tl ts)) + (do tcb \ getObject (the ptrOpt); return (tcbSchedNext tcb) od)" + apply (rule corres_symb_exec_r[OF _ get_tcb_sp']; (solves wpsimp)?) + apply clarsimp + apply (cases ts; fastforce dest: heap_ls_next_of_hd[rotated] simp: opt_map_def obj_at'_def) + done + +defs tcbQueueAdd_asrt_def: + "tcbQueueAdd_asrt \ + \q tcbPtr s. \ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t \ set ts. tcb_at' t s \ sched_flag_set s t)" + +declare tcbQueueAdd_asrt_def[simp] + +lemma no_fail_tcbQueuePrepend: + "no_fail + (\s. (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t \ set ts. tcb_at' t s \ sched_flag_set s t)) + \ tcb_at' t s) + (tcbQueuePrepend q t)" + supply if_split[split del] + unfolding tcbQueuePrepend_def + apply (wpsimp wp: no_fail_stateAssert) + apply (frule list_queue_relation_Nil) + apply (fastforce dest: heap_path_head simp: list_queue_relation_def) + done + +lemma no_fail_tcbQueueAppend: + "no_fail + (\s. (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t \ set ts. tcb_at' t s \ sched_flag_set s t)) + \ tcb_at' t s) + (tcbQueueAppend q t)" + supply if_split[split del] + unfolding tcbQueueAppend_def + apply (wpsimp wp: no_fail_stateAssert) + apply (frule list_queue_relation_Nil) + apply (fastforce simp: list_queue_relation_def queue_end_valid_def) + done + +defs tcbQueueInsert_asrt_def: + "tcbQueueInsert_asrt \ + \tcbPtr ptr s. + \ts q. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t \ set ts. tcb_at' t s \ sched_flag_set s t) + \ tcbPtr \ set ts \ ptr \ set ts" + +declare tcbQueueInsert_asrt_def[simp] + +lemma no_fail_tcbQueueInsert: + "no_fail + (\s. (\ts q. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t \ set ts. tcb_at' t s \ sched_flag_set s t) + \ tcbPtr \ set ts \ afterPtr \ set ts \ afterPtr \ hd ts) + \ sym_heap_sched_pointers s \ tcb_at' tcbPtr s) + (tcbQueueInsert tcbPtr afterPtr)" supply heap_path_append[simp del] if_split[split del] - apply (clarsimp simp: tcbQueueAppend_def tcbQueueEmpty_def) - apply (wpsimp wp: threadSet_wp getTCB_wp) - apply (intro conjI impI allI) - \ \ls was originally empty\ - apply (clarsimp simp: list_queue_relation_def queue_end_valid_def prev_queue_head_def) - \ \ls was not originally empty\ + apply (wpsimp wp: getTCB_wp no_fail_stateAssert simp: tcbQueueInsert_def) apply (clarsimp simp: list_queue_relation_def) - apply (frule heap_path_not_Nil) - apply (frule (1) heap_path_head) - apply (drule (2) heap_ls_append[where new=tcbPtr]) - apply (rule conjI) - apply (erule rsubst3[where P=heap_ls]) - apply (subst opt_map_upd_triv) - apply (fastforce simp: opt_map_def obj_at'_def) - apply (clarsimp simp: queue_end_valid_def) - apply (subst fun_upd_swap) + apply (frule split_list) + apply (clarsimp, rename_tac ys zs) + apply (intro context_conjI impI) + apply (rule_tac x="ys @ afterPtr # zs" in exI) + apply force + apply clarsimp + apply (intro context_conjI impI) + apply (force dest: heap_path_sym_heap_non_nil_lookup_prev simp: opt_map_def obj_at'_def) + apply (force dest: heap_ls_prev_no_loops simp: opt_map_def obj_at'_def) + apply (prop_tac "ys \ []", fastforce dest: last_in_set) + apply (fastforce dest!: heap_path_sym_heap_non_nil_lookup_prev simp: opt_map_def obj_at'_def) + done + +lemma no_fail_findInsertionPoint: + "\reflp R; totalp R; transp R\ \ + no_fail + (\s. (\ts q. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t\set ts. (\v. f t s = Some v) \ tcb_at' t s) + \ (\ptr. ptrOpt = Some ptr \ ptr \ set ts)) + \ sym_heap_sched_pointers s) + (findInsertionPoint val ptrOpt f R)" + apply (simp add: findInsertionPoint_def no_fail_def) + apply (intro impI allI) + apply (elim exE conjE)+ + apply (rename_tac ts q) + apply (rule_tac P="\ptrOpt s. (\t \ set ts. f t s \ None \ tcb_at' t s) + \ list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\ptr. ptrOpt = Some ptr \ ptr \ set ts)" + in no_fail_whileLoop) + apply wpsimp + apply (fastforce dest: compareVals_not_None) + apply (rule_tac C'="\r _. r \ None" in whileLoop_terminates_weaken_cond) + apply (clarsimp simp: compareVals_def runReaderT_def obind_def + queue_end_valid_def list_queue_relation_def + split: option.splits if_splits) apply fastforce - apply (simp add: opt_map_upd_triv_None opt_map_upd_triv obj_at'_def) - apply simp - apply simp - apply (force simp: queue_end_valid_def prev_queue_head_def opt_map_def obj_at'_def split: if_splits) - done + apply (rename_tac new_s r r_val) + apply (frule_tac x=r in split_list) + apply clarsimp + apply (rename_tac ys zs v) + apply (rule_tac P'="\r r' s'. heap_ls (tcbSchedNexts_of s') r' r + \ (r' \ None \ tcb_at' (the r') s') + \ (\t \ set r. tcb_at' t s')" + and P="\r' s. suffix r' (r # zs)" + and r="r # zs" + in whileLoop_terminates_cross_ret[where rrel=ls_opt_rel and C="\r _. r \ []"]) + apply (rule stronger_corres_guard_imp) + apply (fastforce intro!: return_tl_return_next_corres_underlying) + apply simp + apply simp + apply fastforce + apply wpsimp + apply (fastforce dest: suffix_tl) + apply (wpsimp wp: getTCB_wp) + apply (clarsimp simp: return_def split: if_splits) + apply (rename_tac r' s' ko) + apply (frule_tac xs=r' in hd_in_set) + apply (frule_tac x="hd r'" in split_list) + apply clarsimp + apply (rule conjI) + apply (case_tac r'; fastforce dest!: prefix_of_hd_nil simp: opt_map_def obj_at'_def) + apply (intro conjI impI) + apply (clarsimp, rename_tac next_ptr) + apply (frule_tac p="hd r'" and np=next_ptr in heap_ls_next_in_list) + apply force + apply (clarsimp simp: opt_map_def obj_at'_def split: option.splits) + apply fastforce + apply (force dest: list.set_sel(2)) + apply (rename_tac r' s' ko) + apply (intro conjI impI) + apply (case_tac r'; clarsimp simp: opt_map_def obj_at'_def split: option.splits) + apply (clarsimp, rename_tac next_ptr) + apply (frule_tac p="hd r'" and np=next_ptr in heap_ls_next_in_list) + apply force + apply (clarsimp simp: opt_map_def obj_at'_def split: option.splits) + apply fastforce + apply (force dest: list.set_sel(2)) + apply (rule whileLoop_terminates_inv[ + OF _ _ list_length_wf_helper, where I="\\", simplified]) + apply wpsimp + apply (clarsimp simp: ex_abs_underlying_def) + apply (clarsimp split: if_splits) + apply clarsimp + apply wpsimp + apply (fastforce intro!: compareVals_not_None) + apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' getTCB_wp) + apply (force dest!: compareVals_not_None heap_ls_next_in_list + simp: list_queue_relation_def opt_map_def obj_at'_def) + apply (force dest: heap_path_head simp: list_queue_relation_def queue_end_valid_def) + done + +lemma no_fail_orderedInsert: + "\reflp R; totalp R; transp R\ \ + no_fail + (\s. (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t \ set ts. \v. f t s = Some v \ tcb_at' t s \ sched_flag_set s t) + \ t \ set ts) + \ sym_heap_sched_pointers s \ (\val. f t s = Some val) \ tcb_at' t s) + (orderedInsert t q f R)" + apply (clarsimp simp: orderedInsert_def) + apply (wpsimp wp: no_fail_tcbQueueInsert no_fail_tcbQueueAppend no_fail_tcbQueuePrepend + no_fail_stateAssert) + apply (rule_tac Q'="\ptrOpt s. \ts. list_queue_relation ts q + (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t \ set ts. tcb_at' t s \ sched_flag_set s t) + \ (\ptr. ptrOpt = Some ptr \ ptr \ set ts + \ ptr \ hd ts) + \ t \ set ts + \ sym_heap_sched_pointers s \ tcb_at' t s" + in hoare_post_imp) + apply fastforce + apply (wpsimp wp: findInsertionPoint_rv_in_set no_fail_findInsertionPoint + hoare_vcg_ex_lift no_fail_stateAssert)+ + apply (rename_tac ts val) + apply (frule list_queue_relation_Nil) + apply (frule he_ptrs_head_iff_he_ptrs_end) + apply (clarsimp simp: list_queue_relation_def queue_end_valid_def tcbQueueEmpty_def) + apply (frule heap_path_head') + apply (intro conjI impI allI; clarsimp) + apply fastforce + apply fastforce + apply fastforce + apply (rule_tac x=ts in exI) + apply clarsimp + apply (rule_tac x=q in exI) + apply clarsimp + apply (rule_tac x=ts in exI) + apply clarsimp + apply (intro conjI impI allI) + apply (drule_tac x="hd ts" in bspec, simp) + apply (metis Some_to_the reflpE totalpD) + apply (drule_tac x="last ts" in bspec, simp) + apply (clarsimp split: option.splits) + done + +text \Work towards showing a @{const monadic_rewrite} rule for part of @{const orderedInsert}\ + +lemma findInsertionPoint_beforePtr_afterPtr: + assumes sorted: "sorted_wrt (img_ord (\t. f t s) (opt_ord_rel R)) ts" + assumes nf: "\t \ set ts. \v. f t s = Some v" + assumes after: "afterPtr \ set ts" + "\afterVal. f afterPtr s = Some afterVal \ R val afterVal \ val \ afterVal" + "\pfx. (\sfx. pfx @ afterPtr # sfx = ts) \ (\x \ set pfx. R (the (f x s)) val)" + assumes before: "beforePtr \ set ts" + "\beforeVal. f beforePtr s = Some beforeVal \ R beforeVal val" + "\sfx. (\pfx. pfx @ beforePtr # sfx = ts) + \ (\x \ set sfx. R val (the (f x s)) \ the (f x s) \ val)" + assumes ord: "transp R" "antisymp R" + shows "\pfx sfx. ts = pfx @ beforePtr # afterPtr # sfx" + apply (insert nf ord before(1) before(2)) + apply (frule split_list[where x=beforePtr]) + apply clarsimp + apply (rename_tac beforeVal ys zs) + apply (rule_tac x=ys in exI) + apply (rule_tac x="tl zs" in exI) + apply (insert after) + apply clarsimp + apply (rename_tac afterVal) + apply (prop_tac "R beforeVal afterVal \ beforeVal \ afterVal") + apply (metis antisympD transpD) + apply (prop_tac "afterPtr \ set ys") + apply clarsimp + apply (frule split_list[where x=afterPtr]) + apply (insert sorted) + apply (prop_tac "R afterVal beforeVal") + apply (force simp: img_ord_Some' sorted_wrt_append) + apply (fastforce dest: antisympD) + apply (prop_tac "afterPtr \ set zs") + apply (fastforce simp: after) + apply (frule split_list[where x=afterPtr]) + apply clarsimp + apply (rename_tac ys' zs') + apply (drule_tac x="ys @ beforePtr # ys'" in spec) + apply (insert before(3)) + apply (case_tac ys'; force dest!: spec antisympD) + done + +definition compareValsBackwards where + "compareValsBackwards val ptrOpt f R \ + if ptrOpt \ Nothing + then do { ptr \ oreturn $ fromJust ptrOpt; + val' \ f ptr; + oreturn $ R val val' \ val' \ val } + else oreturn False" + +definition findInsertionPointBackwards where + "findInsertionPointBackwards val ptrOpt f R \ + whileLoop (\ptrOpt. fromJust \ runReaderT (compareValsBackwards val ptrOpt f R)) + (\ptrOpt. do tcb \ getObject (fromJust ptrOpt); + return (tcbSchedPrev tcb) + od) + ptrOpt" + +crunch findInsertionPointBackwards + for inv[wp]: P + (wp: crunch_wps) -lemma tcbQueueInsert_list_queue_relation: - "\\s. list_queue_relation (xs @ ys) q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ sym_heap_sched_pointers s - \ tcbPtr \ set (xs @ ys) \ xs \ [] \ ys \ [] \ afterPtr = hd ys - \ (tcbSchedNexts_of s) tcbPtr = None \ (tcbSchedPrevs_of s) tcbPtr = None\ - tcbQueueInsert tcbPtr afterPtr - \\_ s. list_queue_relation (xs @ tcbPtr # ys) q (tcbSchedNexts_of s) (tcbSchedPrevs_of s)\" +lemma compareValsBackwards_not_None: + "the (runReaderT (compareValsBackwards val r f R) s) \ r \ None" + by (fastforce simp: compareValsBackwards_def runReaderT_def split: if_splits) + +lemma findInsertionPointBackwards_rv_rel: + "\reflp R; totalp R; antisymp R\ \ + \\s'. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sym_heap_sched_pointers s' + \ sorted_wrt (img_ord (\t. f t s') (opt_ord_rel R)) ts + \ ts \ [] \ (\t \ set ts. \v. f t s' = Some v) \ (\t \ set ts. tcb_at' t s') + \ (\v. f (hd ts) s' = Some v \ R v val) \ (\v. f (last ts) s' = Some v \ \ R v val)\ + findInsertionPointBackwards val (tcbQueueEnd q) f R + \\ptrOpt s'. \ptr. (ptrOpt = Some ptr \ ptr \ set ts \ ptr \ last ts) + \ (\val'. f ptr s'= Some val' \ R val' val) + \ (\sfx. (\pfx. pfx @ ptr # sfx = ts) + \ (\p \ set sfx. R val (the (f p s')) \ the (f p s') \ val))\" + (is "\_; _; _\ \ \?pre\ _ \_\") supply heap_path_append[simp del] - apply (clarsimp simp: tcbQueueInsert_def bind_assoc) - apply (rule bind_wp[OF _ get_tcb_sp'], rename_tac after_tcb) - apply (rule bind_wp[OF _ assert_sp]) - apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac beforePtr) - apply (wpsimp wp: threadSet_wp getTCB_wp) - apply (clarsimp simp: list_queue_relation_def) - apply normalise_obj_at' - apply (frule heap_ls_distinct) - apply (frule heap_path_head') - apply (frule nonempty_proper_suffix_split_distinct[where queue="xs @ ys" and sfx=ys]) + apply (clarsimp simp: findInsertionPointBackwards_def) + apply (rule hoare_pre) + apply (rule_tac Q4="\ptrOpt s'. ?pre s' + \ (\ptr. ptrOpt = Some ptr \ ptr \ set ts + \ (\sfx. (\pfx. pfx @ ptr # sfx = ts) + \ (\p \ set sfx. R val (the (f p s')) + \ the (f p s') \ val)))" + in valid_whileLoop[where P=Q and I=Q for Q, simplified]) apply fastforce - apply (clarsimp simp: suffix_def) - apply simp - apply (clarsimp, rename_tac xs' ys') - apply (frule (2) heap_path_sym_heap_non_nil_lookup_prev) - apply (prop_tac "hd ys \ tcbPtr", fastforce) - apply (prop_tac "beforePtr \ tcbPtr", clarsimp simp: obj_at'_def opt_map_def in_queue_2_def) - apply (metis Un_iff last_in_set set_append) - apply (cut_tac xs=xs and ys=ys and new=tcbPtr in list_insert_before_distinct) - apply (metis distinct_append) - apply fastforce - apply (drule heap_ls_list_insert_before[where new=tcbPtr]) - apply (metis Un_iff set_append) + apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) + apply (wpsimp wp: hoare_vcg_ex_lift getTCB_wp) + apply (clarsimp simp: list_queue_relation_def compareValsBackwards_def runReaderT_def obind_def + split: option.splits) + apply fastforce + apply (rename_tac ptr ptrVal) + apply (frule (1) heap_path_head) + apply (drule_tac x=ptr in bspec, fastforce)+ + apply normalise_obj_at' + apply (prop_tac "ptr \ hd ts") + apply (fastforce dest!: antisympD) + apply (frule_tac p=ptr in not_head_prev_not_None, fastforce+) + apply clarsimp + apply (rename_tac prev_ptr) + apply (rule_tac x=prev_ptr in exI) + apply (intro conjI) + apply (clarsimp simp: opt_map_def obj_at'_def split: option.splits) + apply (fastforce dest: heap_ls_prev_cases intro: sym_heapD2) + apply (intro impI allI ballI) + apply (rename_tac sfx p) + apply (elim exE) + apply (rename_tac pfx) + apply (prop_tac "ptr = hd sfx") + subgoal by (auto dest!: heap_path_non_nil_lookup_next sym_heapD2 split: list.splits) + apply (drule_tac x="tl sfx" in spec) + apply (case_tac "p = hd sfx") + apply simp + apply (case_tac sfx; clarsimp) + apply (clarsimp simp: compareValsBackwards_def runReaderT_def obind_def split: option.splits) apply fastforce - apply fastforce - apply (prop_tac "beforePtr = last xs'", clarsimp simp: obj_at'_def opt_map_def) - apply (rule conjI) - apply (erule rsubst3[where P=heap_ls]) - apply (subst fun_upd_swap) - apply fastforce - apply (rule heap_upd_cong) - apply (subst fun_upd_swap) - apply fastforce - apply (fastforce simp: fun_upd_swap opt_map_red obj_at'_def opt_map_upd_triv) + apply (metis Some_to_the reflpD totalpD) + apply (clarsimp simp: list_queue_relation_def queue_end_valid_def) + apply (fastforce dest!: heap_ls_distinct suffix_last_nil[rotated, OF _ sym]) + done + +definition tcbQueueInsertAfter where + "tcbQueueInsertAfter tcbPtr beforePtr \ do + tcb \ getObject beforePtr; + afterPtrOpt \ return $ tcbSchedNext tcb; + assert (afterPtrOpt \ None); + afterPtr \ return $ fromJust afterPtrOpt; + threadSet (tcbSchedPrev_update (\_. Some beforePtr)) tcbPtr; + threadSet (tcbSchedNext_update (\_. Some afterPtr)) tcbPtr; + threadSet (tcbSchedPrev_update (\_. Some tcbPtr)) afterPtr; + threadSet (tcbSchedNext_update (\_. Some tcbPtr)) beforePtr + od" + +lemma setObject_rewrite: + "monadic_rewrite F E (\s. ptr' = ptr \ val' = val) (setObject ptr val) (setObject ptr' val')" + by (clarsimp simp: monadic_rewrite_def) + +lemma threadSet_rewrite: + "monadic_rewrite F E (\s. t' = t \ (\tcb. f tcb = f' tcb) \ tcb_at' t s) + (threadSet f t) (threadSet f' t')" + apply (clarsimp simp: threadSet_def) + apply monadic_rewrite_symb_exec_l + apply monadic_rewrite_symb_exec_r + apply (rule setObject_rewrite) + apply (wpsimp wp: getTCB_wp)+ + apply (clarsimp simp: obj_at'_def) + done + +lemma tcbQueueInsert_rewrite: + "monadic_rewrite True True + (\s. tcbSchedNexts_of s beforePtr = Some afterPtr \ sym_heap_sched_pointers s + \ tcb_at' beforePtr s \ tcb_at' t s) + (tcbQueueInsert t afterPtr) (tcbQueueInsertAfter t beforePtr)" + apply (clarsimp simp: tcbQueueInsert_def tcbQueueInsertAfter_def) + apply monadic_rewrite_symb_exec_l + apply monadic_rewrite_symb_exec_l + apply monadic_rewrite_symb_exec_l + apply monadic_rewrite_symb_exec_r + apply monadic_rewrite_symb_exec_l + apply monadic_rewrite_symb_exec_r + apply monadic_rewrite_symb_exec_l + apply (rule monadic_rewrite_bind) + apply (rule threadSet_rewrite) + apply (rule monadic_rewrite_bind) + apply (rule threadSet_rewrite) + apply (rule monadic_rewrite_bind) + apply (rule threadSet_rewrite) + apply (rule threadSet_rewrite) + apply (wpsimp wp: getTCB_wp no_fail_stateAssert)+ + apply (fastforce dest!: sym_heapD1 simp: opt_map_def obj_at'_def) + done + +crunch findInsertionPoint, findInsertionPointBackwards + for (empty_fail) empty_fail[intro!, wp, simp] + +abbreviation (input) last_ls_opt_rel :: "'a list \ 'a option \ bool" where + "last_ls_opt_rel ls opt \ if ls = [] then opt = None else \ptr. opt = Some ptr \ last ls = ptr" + +lemma return_butlast_return_prev_corres_underlying: + "last_ls_opt_rel ts ptrOpt \ + corres_underlying {(s, s'). s = s'} False True last_ls_opt_rel + (\_. ts \ []) + (\s'. \ptr. ptrOpt = Some ptr \ tcb_at' ptr s' + \ (\end. heap_path (tcbSchedNexts_of s') (Some (hd ts)) ts end) \ ptr = last ts + \ tcbSchedPrevs_of s' (hd ts) = None \ sym_heap_sched_pointers s' \ distinct ts) + (return (butlast ts)) + (do tcb \ getObject (the ptrOpt); return (tcbSchedPrev tcb) od)" + apply (rule corres_symb_exec_r[OF _ get_tcb_sp']; (solves wpsimp)?) + apply clarsimp + apply (intro conjI) + apply (case_tac ts; clarsimp simp: opt_map_def obj_at'_def) + apply clarsimp + apply (frule last_in_set[where as=ts]) + apply (frule split_list) + apply clarsimp + apply (rename_tac xs ys) + apply (frule (1) suffix_last_nil) + apply (cut_tac xs=xs and z="last ts" and ys=ys in heap_path_sym_heap_non_nil_lookup_prev) apply fastforce apply fastforce - apply fastforce - apply (rule conjI) - apply (cases ys; fastforce simp: append_Cons_eq_iff queue_end_valid_def) - apply (fastforce simp: prev_queue_head_def obj_at'_def opt_map_red split: if_splits) + apply (metis butlast_snoc) + apply (prop_tac "last xs = last (butlast ts)") + apply (metis butlast_snoc) + apply (fastforce simp: opt_map_def obj_at'_def) + done + +lemma no_fail_findInsertionPointBackwards: + "no_fail + (\s. (\ts q. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) \ ts \ [] + \ (\t\set ts. \v. f t s = Some v \ tcb_at' t s) + \ (\ptr. ptrOpt = Some ptr \ ptr \ set ts)) + \ sym_heap_sched_pointers s) + (findInsertionPointBackwards val ptrOpt f R)" + apply (simp add: findInsertionPointBackwards_def no_fail_def) + apply (intro impI allI) + apply (elim exE conjE)+ + apply (rename_tac ts q) + apply (rule_tac P="\ptrOpt s. (\t \ set ts. f t s \ None \ tcb_at' t s) + \ list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ sym_heap_sched_pointers s + \ (\ptr. ptrOpt = Some ptr \ (ptr \ set ts \ tcb_at' ptr s))" + in no_fail_whileLoop) + apply wpsimp + apply (fastforce dest: compareValsBackwards_not_None) + apply (rule_tac C'="\r _. r \ None" in whileLoop_terminates_weaken_cond) + apply (clarsimp simp: compareValsBackwards_def runReaderT_def obind_def + queue_end_valid_def list_queue_relation_def + split: option.splits if_splits) + apply (force dest: bspec) + apply (rename_tac r r_val) + apply (frule_tac x=r in split_list') + apply (elim exE) + apply (rename_tac ys zs) + apply (rule_tac P'="\r r' s'. (\end. heap_path (tcbSchedNexts_of s') (Some (hd ts)) r end + \ (r \ [] \ the r' = last r)) + \ tcbSchedPrevs_of s' (hd ts) = None + \ (\t \ set r. tcb_at' t s') \ sym_heap_sched_pointers s'" + and P="\r' s. prefix r' (ys @ [r])" + and r="ys @ [r]" + in whileLoop_terminates_cross_ret[where rrel=last_ls_opt_rel and C="\r _. r \ []"]) + apply (rule stronger_corres_guard_imp) + apply (erule return_butlast_return_prev_corres_underlying) + apply fastforce + apply (frule heap_ls_distinct) + apply clarsimp + apply (frule (1) heap_path_head) + apply (intro conjI impI allI) + apply (clarsimp simp: prefix_def) + apply blast + apply force + apply (force intro: distinct_prefix' elim!: prefix_order.trans) + apply force + apply wpsimp + apply (elim disjE) + apply (force simp: prefixeq_butlast) + apply (metis prefix_order.order_trans prefixeq_butlast) + apply (wpsimp wp: getTCB_wp) + apply (clarsimp simp: return_def) + apply (intro conjI impI allI) + apply (metis heap_path_butlast if_option_eq) + apply (rename_tac r' s' tcb v "end" ptr) + apply (clarsimp simp: prefix_def return_def) + apply (frule_tac ls=r' in heap_path_prev_of_last) + apply fastforce + apply (fastforce intro!: butlast_nonempty_length) + apply (prop_tac "r' \ []", force) + apply (clarsimp simp: opt_map_def obj_at'_def) + apply (clarsimp simp: prefix_def) + apply (metis in_set_butlastD) + apply (rule whileLoop_terminates_inv[OF _ _ list_length_wf_helper, where I="\\", simplified]) + apply wpsimp + apply (clarsimp simp: ex_abs_underlying_def) + apply (clarsimp split: if_splits) + apply (frule (1) heap_path_head) + apply (intro conjI impI allI) + apply (case_tac zs; clarsimp) + apply (clarsimp simp: prev_queue_head_def heap_path_head') + apply simp + apply fastforce + apply wpsimp + apply (fastforce dest: compareValsBackwards_not_None) + apply (wpsimp wp: hoare_vcg_all_lift getTCB_wp) + apply (rule context_conjI) + apply (frule compareValsBackwards_not_None) + apply (clarsimp simp: list_queue_relation_def) + apply (rename_tac new_s tcb prev_ptr ptr) + apply (frule_tac np=ptr and p=prev_ptr and hp="tcbSchedNexts_of new_s" in heap_ls_prev_cases) + apply simp + apply (erule sym_heapD2) + apply (fastforce simp: opt_map_def obj_at'_def) + apply fastforce + apply (fastforce simp: opt_map_def obj_at'_def prev_queue_head_def) + apply force + apply (clarsimp simp: list_queue_relation_def) done +defs orderedInsertBackwards_asrt_def: + "orderedInsertBackwards_asrt \ + \t q f R s. + (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ sorted_wrt (img_ord (\t. f t s) (opt_ord_rel R)) ts + \ (\t \ set ts. \v. f t s = Some v \ tcb_at' t s)) + \ (\val. f t s = Some val) \ tcb_at' t s + \ sym_heap_sched_pointers s" + +declare orderedInsertBackwards_asrt_def[simp] + +lemma findInsertionPointBackwards_rewrite: + "\reflp R; transp R; totalp R; antisymp R\ \ + monadic_rewrite True True + (\s'. (\ts. list_queue_relation ts q (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ sorted_wrt (img_ord (\t. f t s') (opt_ord_rel R)) ts + \ (\t \ set ts. \v. f t s' = Some v \ tcb_at' t s') + \ ts \ [] + \ (\v. f (hd ts) s' = Some v \ R v val) + \ (\v. f (last ts) s' = Some v \ \ R v val)) + \ (\val. f t s' = Some val) \ tcb_at' t s' + \ sym_heap_sched_pointers s') + (do ptrOpt \ findInsertionPoint val (tcbQueueHead q) f R; + assert (\y. ptrOpt = Some y); + ptr \ return (the ptrOpt); + stateAssert (insertionPoint_asrt q ptr) []; + tcbQueueInsert t ptr + od) + (do ptrOpt \ findInsertionPointBackwards val (tcbQueueEnd q) f R; + assert (\y. ptrOpt = Some y); + ptr \ return (the ptrOpt); + stateAssert (insertionPoint_asrt q ptr) []; + tcbQueueInsertAfter t (the ptrOpt) + od)" + apply monadic_rewrite_symb_exec_l + apply monadic_rewrite_symb_exec_r + apply monadic_rewrite_symb_exec_l + apply monadic_rewrite_symb_exec_r + apply clarsimp + apply monadic_rewrite_symb_exec_l + apply monadic_rewrite_symb_exec_r + apply (rule tcbQueueInsert_rewrite) + apply (wpsimp wp: no_fail_stateAssert)+ + apply (rule no_fail_findInsertionPointBackwards) + apply (rename_tac ptrOpt) + apply (rule_tac Q'="\rv s'. \ts. list_queue_relation ts q + (tcbSchedNexts_of s') (tcbSchedPrevs_of s') + \ (\t \ set ts. \v. f t s' = Some v \ tcb_at' t s') + \ sorted_wrt (img_ord (\t. f t s') (opt_ord_rel R)) ts + \ (\beforePtr. (rv = Some beforePtr \ beforePtr \ set ts + \ beforePtr \ last ts) + \ (\val'. f beforePtr s'= Some val' \ R val' val) + \ (\sfx. (\pfx. pfx @ beforePtr # sfx = ts) + \ (\p \ set sfx. R val (the (f p s')) + \ the (f p s') \ val))) + \ (\afterPtr. (ptrOpt = Some afterPtr \ afterPtr \ set ts + \ afterPtr \ hd ts) + \ (\val'. f afterPtr s' = Some val' + \ R val val' \ val \ val') + \ (\pfx. (\sfx. pfx @ afterPtr # sfx = ts) + \ (\p \ set pfx. R (the (f p s')) val))) + \ tcb_at' t s' \ sym_heap_sched_pointers s'" + in hoare_post_imp) + apply (clarsimp simp: list_queue_relation_def) + apply (intro conjI impI) + subgoal for \ beforePtr _ _ afterPtr _ + by (frule_tac afterPtr=afterPtr and beforePtr=beforePtr + in findInsertionPoint_beforePtr_afterPtr[where val=val]; + force?) + apply fastforce + apply (rule hoare_vcg_ex_lift) + apply (wpsimp wp: hoare_vcg_conj_lift findInsertionPointBackwards_rv_rel) + apply (wpsimp wp: findInsertionPoint_rv_rel hoare_vcg_conj_lift hoare_vcg_ex_lift) + apply (fastforce simp: list_queue_relation_def queue_end_valid_def) + done + +lemma tcbQueued_update_tcbInReleaseQueue[wp]: + "threadSet (tcbQueued_update f) tcbPtr \\s. P (tcbInReleaseQueue |< tcbs_of' s)\" + by (wpsimp wp: threadSet_field_opt_pred) + +lemma ready_or_release_disjoint: + "ready_or_release s \ set (ready_queues s d p) \ set (release_queue s) = {}" + by (fastforce simp: ready_or_release_def in_ready_q_def not_in_release_q_def) + +lemma setQueue_ksReadyQueues_other: + "\\s. P (ksReadyQueues s (d, p)) \ (domain \ d \ priority \ p)\ + setQueue domain priority ts + \\_ s. P (ksReadyQueues s (d, p))\" + by (wpsimp simp: setQueue_def) + +lemma tcbQueued_update_inQ_other: + "\\s. P (inQ d p |< tcbs_of' s) + \ ((\tcb. tcbDomain tcb \ d \ tcbPriority tcb \ p) |< tcbs_of' s) tcbPtr\ + threadSet (tcbQueued_update f) tcbPtr + \\_ s. P (inQ d p |< tcbs_of' s)\" + apply (wpsimp wp: threadSet_wp) + by (fastforce elim: rsubst[where P=P] simp: inQ_def opt_pred_def opt_map_def obj_at'_def) + +lemma threadSet_inQ: + "\\tcb. tcbPriority (F tcb) = tcbPriority tcb; \tcb. tcbDomain (F tcb) = tcbDomain tcb; + \tcb. tcbQueued (F tcb) = tcbQueued tcb\ + \ threadSet F tcbPtr \\s. P (inQ d p |< tcbs_of' s)\" + apply (wpsimp wp: threadSet_field_opt_pred) + apply (clarsimp simp: inQ_def) + apply fastforce + done + +crunch tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert + for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" + and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and tcbInReleaseQueue_opt_pred[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" + and tcbQueued_opt_pred[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + and tcbPriority_opt_pred[wp]: "\s. P ((\tcb. Q (tcbPriority tcb)) |< tcbs_of' s)" + and tcbDomain_opt_pred[wp]: "\s. P ((\tcb. Q (tcbDomain tcb)) |< tcbs_of' s)" + and inQ_opt_pred[wp]: "\s. P (inQ d p |< tcbs_of' s)" + (wp: crunch_wps threadSet_inQ threadSet_field_inv threadSet_field_opt_pred) + +lemma set_butlast: + "distinct list \ set (butlast list) = (set list) - {last list}" + by (induct list, simp+, fastforce) + lemma setQueue_sets_queue[wp]: "\d p ts P. \ \s. P ts \ setQueue d p ts \\rv s. P (ksReadyQueues s (d, p)) \" unfolding setQueue_def by (wp, simp) lemma threadSet_opt_pred_other: - "t' \ t \ threadSet F t' \\s. P ((prop |< tcbs_of' s) t)\" + "\\s. P ((prop |< tcbs_of' s) t) \ t' \ t\ + threadSet F t' + \\_ s. P ((prop |< tcbs_of' s) t)\" apply (wpsimp wp: threadSet_wp) by (clarsimp simp: obj_at'_def opt_pred_def) @@ -2512,14 +3045,352 @@ defs valid_objs'_asrt_def: declare valid_objs'_asrt_def[simp] -lemma threadSet_ghost_relation_wrapper[wp]: - "threadSet f p \ghost_relation_wrapper t\" - unfolding threadSet_def setObject_def - by (wpsimp wp: getObject_tcb_wp simp: updateObject_default_def obj_at'_def) +lemma threadSet_eps_of'[wp]: + "threadSet F tcbPtr \\s. P (eps_of' s)\" + apply (wpsimp wp: threadSet_wp) + apply (erule rsubst[where P=P]) + apply (drule obj_at'_prop) + apply (fastforce simp: opt_map_def projectKO_opts_defs split: kernel_object.splits) + done + +lemma threadSet_ntfns_of'[wp]: + "threadSet F tcbPtr \\s. P (ntfns_of' s)\" + apply (wpsimp wp: threadSet_wp) + apply (erule rsubst[where P=P]) + apply (drule obj_at'_prop) + apply (fastforce simp: opt_map_def projectKO_opts_defs split: kernel_object.splits) + done -lemma removeFromBitmap_ghost_relation_wrapper[wp]: - "removeFromBitmap tdom prio \ghost_relation_wrapper s\" - by (wpsimp simp: bitmap_fun_defs) +crunch orderedInsert, tcbQueueRemove + for eps_of'[wp]: "\s. P (eps_of' s)" + and ntfns_of'[wp]: "\s. P (ntfns_of' s)" + (wp: crunch_wps) + +definition ep_queues_blocked :: "'z::state_ext state \ bool" where + "ep_queues_blocked s \ + \p q. ep_queues_of s p = Some q \ (\t \ set q. st_tcb_at (\st. ep_blocked st = Some p) t s)" + +lemma ep_queues_blocked_lift: + assumes "\P. f \\s. P (ep_queues_of s)\" + assumes "\P t. f \\s. st_tcb_at P t s\" + shows "f \ep_queues_blocked\" + unfolding ep_queues_blocked_def + apply (rule hoare_pre) + apply (wps | wp assms | wpsimp wp: hoare_vcg_all_lift hoare_vcg_ball_lift hoare_vcg_imp_lift')+ + done + +lemma sym_refs_ep_queues_blocked[elim!]: + "sym_refs (state_refs_of s) \ ep_queues_blocked s" + by (fastforce elim: st_tcb_weakenE dest: in_ep_queue_st_tcb_at + simp: ep_queues_blocked_def ep_blocked_def) + +definition ntfn_queues_blocked :: "'z::state_ext state \ bool" where + "ntfn_queues_blocked s \ + \p q. ntfn_queues_of s p = Some q + \ (\t \ set q. st_tcb_at (\st. ntfn_blocked st = Some p) t s)" + +lemma ntfn_queues_blocked_lift: + assumes "\P. f \\s. P (ntfn_queues_of s)\" + assumes "\P t. f \\s. st_tcb_at P t s\" + shows "f \ntfn_queues_blocked\" + unfolding ntfn_queues_blocked_def + apply (rule hoare_pre) + apply (wps | wp assms | wpsimp wp: hoare_vcg_all_lift hoare_vcg_ball_lift hoare_vcg_imp_lift')+ + done + +lemma sym_refs_ntfn_queues_blocked[elim!]: + "sym_refs (state_refs_of s) \ ntfn_queues_blocked s" + by (fastforce elim: st_tcb_weakenE dest: in_ntfn_queue_st_tcb_at + simp: ntfn_queues_blocked_def ntfn_blocked_def) + +lemma ready_qs_distinct_lift: + assumes "\P. f \\s. P (ready_queues s)\" + shows "f \ready_qs_distinct\" + unfolding ready_qs_distinct_def + apply (rule hoare_pre) + apply (wps assms | wpsimp)+ + done + +lemma ready_queues_runnable_lift: + assumes "\P. f \\s. P (ready_queues s)\" + assumes "\P t. f \\s. st_tcb_at P t s\" + shows "f \ready_queues_runnable\" + unfolding ready_queues_runnable_def + apply (rule hoare_pre) + apply (wps assms | wp assms | wpsimp wp: hoare_vcg_all_lift hoare_vcg_ball_lift)+ + done + +lemma release_q_runnable_lift: + assumes "\P. f \\s. P (release_queue s)\" + assumes "\P t. f \\s. st_tcb_at P t s\" + shows "f \release_q_runnable\" + unfolding release_q_runnable_def + apply (rule hoare_pre) + apply (wps | wp assms | wpsimp wp: hoare_vcg_ball_lift2_pre_conj)+ + done + +lemma valid_ready_qs_in_correct_ready_q[elim!]: + "valid_ready_qs s \ in_correct_ready_q s" + by (simp add: valid_ready_qs_def in_correct_ready_q_def) + +lemma valid_ready_qs_ready_qs_distinct[elim!]: + "valid_ready_qs s \ ready_qs_distinct s" + by (simp add: valid_ready_qs_def ready_qs_distinct_def) + +lemma valid_ready_qs_ready_queues_runnable[elim!]: + "valid_ready_qs s \ ready_queues_runnable s" + by (simp add: valid_ready_qs_def ready_queues_runnable_def obj_at_kh_kheap_simps) + +lemma valid_release_q_release_q_runnable[elim!]: + "valid_release_q s \ release_q_runnable s" + by (fastforce simp: valid_release_q_def release_q_runnable_def vs_all_heap_simps pred_tcb_at_def + obj_at_def) + +lemma disjoint_via_tcb_state: + "\\t \ set q. st_tcb_at P t s; \t \ set q'. st_tcb_at P' t s; \st. P st \ \ P' st\ + \ set q \ set q' = {}" + by (fastforce simp: pred_tcb_at_def obj_at_def) + +lemma not_in_set_via_tcb_state: + "\\t \ set q. st_tcb_at P t s; st_tcb_at P' t s; \st. P st \ \ P' st\ \ t \ set q" + by (fastforce simp: pred_tcb_at_def obj_at_def) + +lemma ep_queues_disjoint: + "\ep_queues_blocked s; ep_queues_of s p = Some q; ep_queues_of s p' = Some q'; p \ p'\ + \ set q \ set q' = {}" + apply (simp add: ep_queues_blocked_def) + apply (rule disjoint_via_tcb_state) + apply (fastforce dest!: spec[where x=p]) + apply (fastforce dest!: spec[where x=p']) + apply (rename_tac st, case_tac st; clarsimp) + done + +lemma ntfn_queues_disjoint: + "\ntfn_queues_blocked s; ntfn_queues_of s p = Some q; ntfn_queues_of s p' = Some q'; p \ p'\ + \ set q \ set q' = {}" + apply (simp add: ntfn_queues_blocked_def) + apply (rule disjoint_via_tcb_state) + apply (fastforce dest!: spec[where x=p]) + apply (fastforce dest!: spec[where x=p']) + apply (rename_tac st, case_tac st; clarsimp) + done + +lemma ep_queues_ntfn_queues_disjoint: + "\ep_queues_blocked s; ntfn_queues_blocked s; + ep_queues_of s p = Some q; ntfn_queues_of s p' = Some q'\ + \ set q \ set q' = {}" + apply (simp add: ep_queues_blocked_def ntfn_queues_blocked_def ep_blocked_def ntfn_blocked_def) + apply (rule disjoint_via_tcb_state) + apply (fastforce dest!: spec[where x=p]) + apply (fastforce dest!: spec[where x=p']) + apply (rename_tac st, case_tac st; clarsimp) + done + +lemma ep_queues_ready_queues_disjoint: + "\ep_queues_blocked s; ready_queues_runnable s; ep_queues_of s p = Some q\ + \ set q \ set (ready_queues s domain priority) = {}" + apply (simp add: ep_queues_blocked_def ready_queues_runnable_def ep_blocked_def) + apply (rule disjoint_via_tcb_state[where P'=runnable]) + apply (fastforce dest!: spec[where x=p]) + apply fastforce + apply (rename_tac st, case_tac st; clarsimp) + done + +lemma ntfn_queues_ready_queues_disjoint: + "\ntfn_queues_blocked s; ready_queues_runnable s; ntfn_queues_of s p = Some q\ + \ set q \ set (ready_queues s domain priority) = {}" + apply (simp add: ntfn_queues_blocked_def ready_queues_runnable_def ntfn_blocked_def) + apply (rule disjoint_via_tcb_state[where P'=runnable]) + apply (fastforce dest!: spec[where x=p]) + apply fastforce + apply (rename_tac st, case_tac st; clarsimp) + done + +lemma ep_queues_release_queue_disjoint: + "\ep_queues_blocked s; release_q_runnable s; ep_queues_of s p = Some q\ + \ set q \ set (release_queue s) = {}" + apply (simp add: ep_queues_blocked_def release_q_runnable_def ep_blocked_def) + apply (rule disjoint_via_tcb_state[where P'=runnable]) + apply (fastforce dest!: spec[where x=p]) + apply fastforce + apply (rename_tac st, case_tac st; clarsimp) + done + +lemma ntfn_queues_release_queue_disjoint: + "\ntfn_queues_blocked s; release_q_runnable s; ntfn_queues_of s p = Some q\ + \ set q \ set (release_queue s) = {}" + apply (simp add: ntfn_queues_blocked_def release_q_runnable_def ntfn_blocked_def) + apply (rule disjoint_via_tcb_state[where P'=runnable]) + apply (fastforce dest!: spec[where x=p]) + apply fastforce + apply (rename_tac st, case_tac st; clarsimp) + done + +lemma runnable_not_in_ep_queue: + "\st_tcb_at runnable tcbPtr s; ep_queues_of s p = Some q; ep_queues_blocked s\ + \ tcbPtr \ set q" + apply (rule_tac P="\st. ep_blocked st = Some p" and s=s in not_in_set_via_tcb_state) + apply (fastforce simp: ep_queues_blocked_def opt_map_def ep_blocked_def) + apply fastforce + apply (rename_tac st, case_tac st; clarsimp simp: ep_blocked_def) + done + +lemma runnable_not_in_ntfn_queue: + "\st_tcb_at runnable tcbPtr s; ntfn_queues_of s p = Some q; ntfn_queues_blocked s\ + \ tcbPtr \ set q" + apply (rule_tac P="\st. ntfn_blocked st = Some p" and s=s in not_in_set_via_tcb_state) + apply (force simp: ntfn_queues_blocked_def) + apply simp + apply (rename_tac st, case_tac st; clarsimp simp: ntfn_blocked_def) + done + +lemma runnable'_not_inIPCQueueThreadState: + "st_tcb_at' runnable' t s \ \ (inIPCQueueThreadState |< tcbStates_of' s) t" + apply (clarsimp simp: st_tcb_at'_def obj_at'_def opt_pred_def opt_map_red + inIPCQueueThreadState_def) + apply (rename_tac tcb, case_tac "tcbState tcb"; clarsimp) + done + +crunch set_tcb_queue + for ep_queues_blocked[wp]: ep_queues_blocked + and ntfn_queues_blocked[wp]: ntfn_queues_blocked + (wp: ep_queues_blocked_lift ntfn_queues_blocked_lift) + +lemma set_endpoint_ep_queues_of_other: + "\\s. P (ep_queues_of s p) \ p \ ep_ptr\ + set_endpoint ep_ptr ep + \\_ s. P (ep_queues_of s p)\" + by (wpsimp wp: set_simple_ko_wp) + (clarsimp simp: eps_of_kh_def opt_map_def) + +lemma threadSet_dom_tcbs_of'[wp]: + "threadSet f tcbPtr \\s. P (dom (tcbs_of' s))\" + apply (wpsimp wp: threadSet_wp) + apply (fastforce elim: rsubst[where P=P] simp: opt_map_def obj_at'_def) + done + +crunch tcbQueueRemove, orderedInsert + for dom_tcbs_of'[wp]: "\s. P (dom (tcbs_of' s))" + (wp: crunch_wps) + +crunch tcbQueueRemove, orderedInsert, updateEndpoint, updateNotification + for tcbIPCBuffers_of[wp]: "\s. P (tcbIPCBuffers_of s)" + and tcbArches_of[wp]: "\s. P (tcbArches_of s)" + and tcbStates_of'[wp]: "\s. P (tcbStates_of' s)" + and tcbFaults_of[wp]: "\s. P (tcbFaults_of s)" + and tcbCTables_of[wp]: "\s. P (tcbCTables_of s)" + and tcbVTables_of[wp]: "\s. P (tcbVTables_of s)" + and tcbFaultHandlers_of[wp]: "\s. P (tcbFaultHandlers_of s)" + and tcbTimeoutHandlers_of[wp]: "\s. P (tcbTimeoutHandlers_of s)" + and tcbIPCBufferFrames_of[wp]: "\s. P (tcbIPCBufferFrames_of s)" + and tcbBoundNotifications_of[wp]: "\s. P (tcbBoundNotifications_of s)" + and tcbSchedContexts_of[wp]: "\s. P (tcbSchedContexts_of s)" + and tcbYieldTos_of[wp]: "\s. P (tcbYieldTos_of s)" + and tcbMCPs_of[wp]: "\s. P (tcbMCPs_of s)" + and tcbPriorities_of[wp]: "\s. P (tcbPriorities_of s)" + and tcbDomains_of[wp]: "\s. P (tcbDomains_of s)" + and tcbFlags_of[wp]: "\s. P (tcbFlags_of s)" + (wp: crunch_wps threadSet_field_inv) + +lemma set_tcb_queue_det_wp[wp]: + "det_wp \ (set_tcb_queue d p queue)" + by (wpsimp simp: set_tcb_queue_def) + +lemmas set_tcb_queue_no_fail[wp] = det_wp_no_fail[OF set_tcb_queue_det_wp] + +lemma set_tcb_queue_ready_queues_other: + "\\s. P (ready_queues s d p) \ (domain \ d \ priority \ p)\ + set_tcb_queue domain priority q + \\_ s. P (ready_queues s d p)\" + by (wpsimp simp: set_tcb_queue_def) + +lemma rcorres_threadSet_list_queue_relation: + "\\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb; + \tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb\ \ + rcorres + (\_ s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')) + (return rv) (threadSet F t) + (\_ _ _ s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (rule rcorres_from_valid_det; wpsimp wp: threadSet_wp) + apply (fastforce elim: list_queue_relation_cong simp: opt_map_def obj_at'_def) + done + +lemma rcorres_setQueue_list_queue_relation_other: + "rcorres + (\_ s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')) + (set_tcb_queue d p ls') (setQueue d p q') + (\_ _ _ s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + by (rule rcorres_from_valid_det; wpsimp) + +lemma rcorres_setQueue_list_queue_relation[rcorres]: + "\domain = d; priority = p\ \ + rcorres + (\_ s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')) + (set_tcb_queue domain priority ls) (setQueue domain priority q) + (\_ _ s s'. list_queue_relation (ready_queues s d p) (ksReadyQueues s' (d, p)) + (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp simp: setQueue_def set_tcb_queue_def) + apply (clarsimp simp: in_monad) + done + +lemma rcorres_threadSet_ready_queues_list_queue_relation: + "\\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb; + \tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb\ \ + rcorres + (\s s'. list_queue_relation (ready_queues s d p) (ksReadyQueues s' (d, p)) + (tcbSchedNexts_of s') (tcbSchedPrevs_of s')) + (return ls) (threadSet F t) + (\_ _ s s'. list_queue_relation (ready_queues s d p) (ksReadyQueues s' (d, p)) + (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc[where Q="\\", simplified]) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs[where Q="\\", simplified]) + apply (rule rcorres_weaken_pre[OF rcorres_threadSet_list_queue_relation]) + apply wpsimp+ + done + +lemma rcorres_threadSet_release_queue_list_queue_relation: + "\\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb; + \tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb\ \ + rcorres + (\s s'. list_queue_relation (release_queue s) (ksReleaseQueue s') + (tcbSchedNexts_of s') (tcbSchedPrevs_of s')) + (return ls) (threadSet F t) + (\_ _ s s'. list_queue_relation (release_queue s) (ksReleaseQueue s') + (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (rule_tac p="\s'. ksReleaseQueue s'" in rcorres_lift_conc[where Q="\\", simplified]) + apply (rule_tac p="\s. release_queue s" in rcorres_lift_abs[where Q="\\", simplified]) + apply (rule rcorres_weaken_pre[OF rcorres_threadSet_list_queue_relation]) + apply wpsimp+ + done + +lemma rcorres_setReleaseQueue_list_queue_relation_other: + "rcorres + (\_ s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')) + (set_release_queue ls') (setReleaseQueue q') + (\_ _ _ s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + by (rule rcorres_from_valid_det; wpsimp wp: threadSet_wp) + +lemma rcorres_setReleaseQueue_list_queue_relation[rcorres]: + "rcorres + (\_ s'. list_queue_relation ls q (tcbSchedNexts_of s') (tcbSchedPrevs_of s')) + (set_release_queue ls) (setReleaseQueue q) + (\_ _ s s'. list_queue_relation (release_queue s) (ksReleaseQueue s') + (tcbSchedNexts_of s') (tcbSchedPrevs_of s'))" + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp simp: setReleaseQueue_def) + apply (clarsimp simp: in_monad) + done + +crunch tcbQueueRemove, orderedInsert, updateEndpoint, updateNotification + for ctes_of'[wp]: "\s. P (ctes_of' s)" + and replies_of[wp]: "\s. P (replies_of' s)" + and scs_of'[wp]: "\s. P (scs_of' s)" + and userDataDevice_at[wp]: "\s. P (userDataDevice_at s)" + and userData_at[wp]: "\s. P (userData_at s)" + and kernelData_at[wp]: "\s. P (kernelData_at s)" + and aobjs_of'[wp]: "\s. P (aobjs_of' s)" + (wp: crunch_wps) locale TcbAcc_R_2 = TcbAcc_R + assumes removeFromBitmap_valid_bitmapQ_except: @@ -2544,26 +3415,6 @@ locale TcbAcc_R_2 = TcbAcc_R + (tcb_at t and valid_objs and pspace_aligned and pspace_distinct) (valid_objs' and no_0_obj') (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" - assumes tcbSchedNext_update_iflive': - "\t f. - \\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ - threadSet (tcbSchedNext_update f) t - \\_. if_live_then_nonz_cap'\" - assumes tcbSchedPrev_update_iflive': - "\t f. - \\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ - threadSet (tcbSchedPrev_update f) t - \\_. if_live_then_nonz_cap'\" - assumes tcbInReleaseQueue_update_iflive'[wp]: - "\t f. - \\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ - threadSet (tcbInReleaseQueue_update f) t - \\_. if_live_then_nonz_cap'\" - assumes tcbQueued_update_iflive'[wp]: - "\t f. - \\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' t s\ - threadSet (tcbQueued_update f) t - \\_. if_live_then_nonz_cap'\" assumes setThreadState_state_hyp_refs_of'[wp]: "\st t P. setThreadState st t \\s. P ((state_hyp_refs_of' s))\" assumes storeWord_invs'[wp]: @@ -2587,18 +3438,16 @@ locale TcbAcc_R_2 = TcbAcc_R + (asUser t (setRegister r v))" begin -crunch setQueue, tcbQueuePrepend, tcbQueueRemove, removeFromBitmap - for ghost_relation_wrapper[wp]: "ghost_relation_wrapper t" - (wp: crunch_wps) - lemma tcbSchedEnqueue_corres: "tcb_ptr = tcbPtr \ corres dc - (in_correct_ready_q and ready_qs_distinct and st_tcb_at runnable tcb_ptr - and not_in_release_q tcb_ptr and ready_or_release and pspace_aligned and pspace_distinct) - (sym_heap_sched_pointers and valid_sched_pointers and valid_tcbs') + (ep_queues_blocked and ntfn_queues_blocked + and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable + and st_tcb_at runnable tcb_ptr and not_in_release_q tcb_ptr and ready_or_release + and pspace_aligned and pspace_distinct) + (valid_sched_pointers and valid_tcbs') (tcb_sched_action tcb_sched_enqueue tcb_ptr) (tcbSchedEnqueue tcbPtr)" - supply if_split[split del] + supply if_split[split del] bind_return[simp del] return_bind[simp del] apply (rule_tac Q'="st_tcb_at' runnable' tcbPtr" in corres_cross_add_guard) apply (fastforce intro!: st_tcb_at_runnable_cross simp: vs_all_heap_simps obj_at_def is_tcb_def) apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) @@ -2616,21 +3465,20 @@ lemma tcbSchedEnqueue_corres: apply (fastforce intro: ready_or_release_cross) apply (rule corres_stateAssert_add_assertion[rotated]) apply (fastforce dest: state_relation_release_queue_relation in_release_q_tcbInReleaseQueue_eq) - apply (rule corres_stateAssert_ignore) - apply (fastforce intro: ksReadyQueues_asrt_cross) - apply (rule corres_stateAssert_ignore) - apply (fastforce intro: ksReleaseQueue_asrt_cross) - apply (rule corres_stateAssert_ignore, fastforce) + apply (rule corres_stateAssert_ignore, fastforce intro: ksReadyQueues_asrt_cross) + apply (rule corres_stateAssert_ignore, fastforce intro: ksReleaseQueue_asrt_cross) + apply (rule corres_stateAssert_ignore, fastforce)+ apply (rule corres_symb_exec_r[OF _ isRunnable_sp]; (solves wpsimp)?) apply (rule corres_symb_exec_r[OF _ assert_sp, rotated]; (solves wpsimp)?) apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) - apply (subst if_distrib[where f="set_tcb_queue domain prio" for domain prio]) - apply (rule corres_if_strong') - subgoal - by (fastforce dest!: state_relation_ready_queues_relation - in_ready_q_tcbQueued_eq[THEN arg_cong_Not, where t1=tcbPtr] - simp: obj_at'_def opt_pred_def opt_map_def in_correct_ready_q_def - vs_all_heap_simps obj_at_def in_ready_q_def) + apply (rule_tac F="tcbPtr \ set (queues domain priority) \ queued" in corres_req) + subgoal + by (fastforce dest!: state_relation_ready_queues_relation + in_ready_q_tcbQueued_eq[THEN arg_cong_Not, where t1=tcbPtr] + simp: obj_at'_def opt_pred_def opt_map_def in_correct_ready_q_def + vs_all_heap_simps obj_at_def in_ready_q_def) + apply (case_tac queued; clarsimp) + apply (clarsimp simp: return_bind) apply (find_goal \match conclusion in "corres _ _ _ _ (return ())" \ \-\\) apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) apply (clarsimp simp: set_tcb_queue_def) @@ -2646,89 +3494,126 @@ lemma tcbSchedEnqueue_corres: apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) apply (rule corres_symb_exec_r[OF _ gets_sp]; (solves wpsimp)?) - \ \break off the addToBitmap\ apply (rule corres_add_noop_lhs) apply (rule corres_split_skip) apply wpsimp - apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_ex_lift) + apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_ex_lift hoare_vcg_imp_lift') apply (corres corres: addToBitmap_if_null_noop_corres) - apply (rule_tac F="tdom = domain \ prio = priority" in corres_req) apply (fastforce dest: pspace_relation_tcb_domain_priority state_relation_pspace_relation simp: obj_at_def obj_at'_def) + \ \set the ready queue\ apply clarsimp - - apply (rule corres_from_valid_det) - apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) - apply (wpsimp simp: tcbQueuePrepend_def wp: hoare_vcg_imp_lift' hoare_vcg_if_lift2) - apply (clarsimp simp: ex_abs_def split: if_splits) + apply (rule corres_underlying_from_rcorres) + apply (wpsimp wp: no_fail_tcbQueuePrepend hoare_vcg_imp_lift' hoare_vcg_if_lift2) + apply (clarsimp simp: ex_abs_def obj_at_def split: if_splits) + apply normalise_obj_at' + apply (rename_tac s tcb tcb') apply (frule state_relation_ready_queues_relation) apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - subgoal by (auto dest!: obj_at'_tcbQueueHead_ksReadyQueues simp: obj_at'_def) - - apply (rename_tac s rv t) - apply (clarsimp simp: state_relation_def) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) - - apply (find_goal \match conclusion in "\_\ _ \\_. release_queue_relation t\" for t \ \-\\) - apply (frule_tac d=domain and p=priority in ready_or_release_disjoint) - apply (drule set_tcb_queue_projs_inv) - apply (wpsimp wp: tcbQueuePrepend_list_queue_relation_other hoare_vcg_ex_lift - threadSet_sched_pointers - simp: release_queue_relation_def setQueue_def - | wps)+ - apply (rule_tac x="ready_queues s (tcbDomain tcba) (tcbPriority tcb)" in exI) - apply (auto simp: ready_queues_relation_def ready_queue_relation_def Let_def)[1] - - \ \ready_queues_relation\ - apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) - apply (intro hoare_allI) - apply (drule singleton_eqD) - apply (drule set_tcb_queue_new_state) - apply (intro hoare_vcg_conj_lift_pre_fix) - - apply (find_goal \match conclusion in "\_\ _ \\_ s. maxDomain < d \ _\" for d \ \-\\) - apply (wpsimp wp: threadSet_wp getTCB_wp simp: setQueue_def tcbQueuePrepend_def) - apply (frule valid_tcbs'_maxDomain[where t=tcbPtr]) - apply fastforce - subgoal by (force simp: obj_at'_def tcbQueueEmpty_def split: if_split) - - apply (find_goal \match conclusion in "\_\ _ \\_ s. maxPriority < d \ _\" for d \ \-\\) - apply (wpsimp wp: threadSet_wp getTCB_wp simp: setQueue_def tcbQueuePrepend_def) - apply (frule valid_tcbs'_maxPriority[where t=tcbPtr]) - apply fastforce - subgoal by (force simp: obj_at'_def tcbQueueEmpty_def split: if_split) - - apply (find_goal \match conclusion in "\_\ _ \\_ s. list_queue_relation _ _ _ _ \" \ \-\\) - apply (clarsimp simp: obj_at_def) - apply (case_tac "d \ tcb_domain tcb \ p \ tcb_priority tcb") - apply (wpsimp wp: tcbQueuePrepend_list_queue_relation_other setQueue_ksReadyQueues_other - threadSet_sched_pointers hoare_vcg_ex_lift - | wps)+ - apply (intro conjI) - subgoal by fastforce - apply (rule_tac x="ready_queues s (tcb_domain tcb) (tcb_priority tcb)" in exI) - apply (auto dest!: in_correct_ready_qD simp: ready_queues_disjoint - split: if_splits)[1] - apply fastforce - apply ((wpsimp wp: tcbQueuePrepend_list_queue_relation threadSet_sched_pointers | wps)+)[1] - apply (fastforce dest!: valid_sched_pointersD[where t=tcbPtr] - simp: in_opt_pred opt_map_red obj_at'_def) - - apply (rule hoare_allI, rename_tac t') - apply (case_tac "d \ domain \ p \ priority") - apply (wpsimp wp: tcbQueued_update_inQ_other hoare_vcg_disj_lift - simp: opt_pred_disj[simplified pred_disj_def, symmetric] simp_del: disj_not1) - apply (clarsimp simp: opt_map_def opt_pred_def obj_at'_def split: option.splits if_splits) - apply (case_tac "t' = tcbPtr") - apply (wpsimp wp: tcbQueued_True_makes_inQ) - apply (clarsimp simp: opt_pred_def opt_map_def obj_at'_def) - apply (wpsimp wp: threadSet_opt_pred_other) - done + apply (rule_tac x="ready_queues s (tcbDomain tcb) (tcbPriority tcb)" in exI) + apply clarsimp + apply (rule conjI) + apply (fastforce intro!: tcb_at_cross simp: ready_queues_runnable_def) + apply (force dest!: state_relation_ready_queues_relation in_ready_q_tcbQueued_eq[THEN iffD1] + simp: in_ready_q_def) + apply (clarsimp simp: state_relation_def pspace_relation_heap_pspace_relation + ghost_relation_heap_ghost_relation heap_pspace_relation_def) + apply (rcorres_conj_lift \fastforce\ simp: set_tcb_queue_def wp: threadSet_field_inv)+ + apply (rule rcorres_add_return_l) + apply (subst bind_assoc[symmetric]) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ep_queues_relation\ + apply (simp only: ep_queues_relation_def) + apply (rcorres rcorres: tcbQueuePrepend_rcorres_other rcorres_threadSet_list_queue_relation + rcorres_op_lifts) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def obj_at_def) + apply (thin_tac "valid_sched_pointers _") + apply (metis runnable_not_in_ep_queue ep_queues_ready_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ntfn_queues_relation\ + apply (simp only: ntfn_queues_relation_def) + apply (rcorres rcorres: tcbQueuePrepend_rcorres_other rcorres_threadSet_list_queue_relation + rcorres_op_lifts) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def obj_at_def) + apply (thin_tac "valid_sched_pointers _") + apply (metis runnable_not_in_ntfn_queue ntfn_queues_ready_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ready_queues_relation\ + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac d p) + apply (case_tac "d \ domain \ p \ priority") + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation tcbQueuePrepend_rcorres_other) + apply (clarsimp simp: obj_at_def) + apply (thin_tac "valid_sched_pointers _") + apply (metis in_correct_ready_qD ready_queues_disjoint) + apply (wpsimp wp: setQueue_ksReadyQueues_other) + apply (wpsimp wp: set_tcb_queue_ready_queues_other) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac t) + apply (rule_tac p="\s. t \ set (ready_queues s d p)" in rcorres_lift_abs) + apply (rule_tac p="\s'. (inQ d p |< tcbs_of' s') t" in rcorres_lift_conc) + apply (rcorres rcorres: rcorres_prop) + apply force + apply (wpsimp wp: tcbQueued_update_inQ_other hoare_vcg_disj_lift + simp: opt_pred_disj[simplified pred_disj_def, symmetric] simp_del: disj_not1) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at'_def) + apply (wpsimp wp: set_tcb_queue_ready_queues_other) + apply (rule rcorres_lift_conc_only; wpsimp wp: setQueue_ksReadyQueues_other) + \ \d = domain \ p = priority\ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rcorres rcorres: tcbQueuePrepend_rcorres + rcorres_threadSet_ready_queues_list_queue_relation) + apply clarsimp + apply (frule valid_sched_pointersD[where t=tcbPtr]) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at'_def) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at'_def) + apply (elim runnable'_not_inIPCQueueThreadState) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at'_def) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac t) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (clarsimp simp: set_tcb_queue_def in_monad) + apply (case_tac "t \ tcbPtr") + apply (wpsimp wp: threadSet_opt_pred_other) + apply (wpsimp wp: tcbQueued_True_makes_inQ) + apply (force simp: obj_at'_def opt_pred_def opt_map_red) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule rcorres_imp_lift_fwd; (solves wpsimp)?) + apply (rule rcorres_prop_fwd; wpsimp) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: setQueue_ksReadyQueues_other) + apply (force dest!: valid_tcbs'_maxDomain[where t=tcbPtr] simp: obj_at'_def) + apply (rule rcorres_imp_lift_fwd; (solves wpsimp)?) + apply (rule rcorres_prop_fwd; wpsimp) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: setQueue_ksReadyQueues_other) + apply (force dest!: valid_tcbs'_maxPriority[where t=tcbPtr] simp: obj_at'_def) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \release_queue_relation\ + apply (clarsimp simp: release_queue_relation_def) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule_tac p=release_queue in rcorres_lift_abs) + apply (rule_tac p=ksReleaseQueue in rcorres_lift_conc) + apply (rcorres rcorres: tcbQueuePrepend_rcorres_other rcorres_threadSet_list_queue_relation) + apply normalise_obj_at' + apply (subst Int_commute) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def obj_at_def) + apply (thin_tac "valid_sched_pointers_2 _ _ _") + apply (metis ready_or_release_disjoint) + apply wpsimp + apply wpsimp + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: hoare_vcg_all_lift) + apply (clarsimp simp: set_tcb_queue_def in_monad) + by (rcorres_conj_lift \fastforce\ simp: set_tcb_queue_def wp: threadSet_field_inv)+ end (* TcbAcc_R_2 *) @@ -2889,18 +3774,8 @@ lemmas no_fail_scActive[wp] = crunch inReleaseQueue for inv[wp]: P -defs tcb_at'_asrt_def: - "tcb_at'_asrt \ \tcbPtr s. tcb_at' tcbPtr s" - -declare tcb_at'_asrt_def[simp] - -defs sc_at'_asrt_def: - "sc_at'_asrt \ \scPtr s. sc_at' scPtr s" - -declare sc_at'_asrt_def[simp] - defs active_sc_at'_asrt_def: - "active_sc_at'_asrt \ \scPtr s. active_sc_at' scPtr s" + "active_sc_at'_asrt \ active_sc_at'" declare active_sc_at'_asrt_def[simp] @@ -2912,7 +3787,7 @@ definition schedulable' :: "machine_word \ kernel_state \ (runnable' |< (tcbs_of' s' ||> tcbState)) tcbPtr \ active_sc_tcb_at' tcbPtr s' - \ (Not \ tcbInReleaseQueue |< tcbs_of' s') tcbPtr" + \ \ (tcbInReleaseQueue |< tcbs_of' s') tcbPtr" lemma getSchedulable_wp: "\\s. \t. schedulable' tcbPtr s = t \ tcb_at' tcbPtr s \ P t s\ getSchedulable tcbPtr \P\" @@ -2935,15 +3810,15 @@ lemma isSchedulable_inv[wp]: "getSchedulable tcbPtr \P\" by (wpsimp wp: getSchedulable_wp) -lemma no_ofail_readSchedulable[wp]: +lemma no_ofail_readSchedulable: "no_ofail (tcb_at' tcbPtr and valid_tcbs') (readSchedulable tcbPtr)" - apply (clarsimp simp: readSchedulable_def readSchedContext_def ohaskell_state_assert_def) - apply (wpsimp wp: ovalid_inv ovalid_wp_comb3 ovalid_if_lift2 ovalid_threadRead) + unfolding readSchedulable_def ohaskell_state_assert_def + apply (wpsimp wp: ovalid_threadRead) apply normalise_obj_at' - apply (fastforce dest: ko_at'_valid_tcbs'_valid_tcb' simp: valid_tcb'_def valid_bound_obj'_def) + apply (fastforce dest: ko_at'_valid_tcbs'_valid_tcb' simp: valid_tcb'_def) done -lemmas no_fail_getSchedulable[wp] = +lemmas no_fail_getSchedulable = no_ofail_gets_the[OF no_ofail_readSchedulable, simplified getSchedulable_def[symmetric]] lemma threadSet_schedulable'_fields_inv: @@ -2966,13 +3841,6 @@ lemma updateSchedContext_schedulable': by (fastforce simp: opt_pred_def opt_map_def obj_at'_def active_sc_tcb_at'_def split: option.splits if_splits) -lemma schedulable'_imp_ct_active': - "\schedulable' (ksCurThread s) s; cur_tcb' s\ \ ct_active' s" - apply (clarsimp simp: schedulable'_def ct_in_state'_def st_tcb_at'_def cur_tcb'_def obj_at'_def - opt_pred_def opt_map_def) - apply (rename_tac tcb, case_tac "tcbState tcb"; clarsimp) - done - lemma runnable_tsr: "thread_state_relation ts ts' \ runnable' ts' = runnable ts" by (case_tac ts, auto) @@ -2988,13 +3856,12 @@ lemma runnable_runnable'_eq: split: Structures_A.kernel_object.splits) lemma sc_active_cross_eq: - "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; tcb_at t s; valid_tcbs' s'\ + "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; tcb_at t s; valid_tcbs s\ \ (sc_active |< (tcbs_of s |> tcb_sched_context |> scs_of s)) t = active_sc_tcb_at' t s'" apply (clarsimp simp: active_sc_tcb_at'_def) apply (frule state_relation_pspace_relation) apply (frule (3) tcb_at_cross) apply normalise_obj_at' - apply (frule (1) ko_at'_valid_tcbs'_valid_tcb') apply (clarsimp simp: obj_at_def is_tcb_def) apply (rename_tac ko, case_tac ko; clarsimp) apply (rename_tac tcb) @@ -3005,7 +3872,8 @@ lemma sc_active_cross_eq: apply clarsimp apply (rename_tac scPtr) apply (prop_tac "sc_at' scPtr s'") - apply (clarsimp simp: valid_tcb'_def valid_bound_obj'_def tcb_relation_def split: option.splits) + apply (fastforce elim!: sc_at_cross dest: valid_tcbs_valid_tcb + simp: valid_tcb_def get_tcb_def split: option.splits) apply (frule (1) sc_at'_cross) apply (clarsimp simp: obj_at_def is_sc_obj_def) by (auto dest: pspace_relation_sc_relation @@ -3013,21 +3881,15 @@ lemma sc_active_cross_eq: sc_relation_def active_sc_def obj_at'_def split: Structures_A.kernel_object.splits option.splits) -lemma in_release_q_inReleaseQueue_eq: - "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s\ - \ t \ set (release_queue s) = (tcbInReleaseQueue |< (tcbs_of' s')) t" - by (fastforce dest!: state_relation_release_queue_relation - simp: release_queue_relation_def opt_pred_def opt_map_def obj_at'_def) - lemma schedulable_schedulable'_eq: - "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; tcb_at t s; valid_tcbs' s'\ + "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; tcb_at t s; valid_tcbs s\ \ schedulable t s = schedulable' t s'" apply (clarsimp simp: schedulable_def schedulable'_def) apply (intro conj_cong) apply (fastforce dest: runnable_runnable'_eq) apply (fastforce dest: sc_active_cross_eq) - apply (force dest!: in_release_q_inReleaseQueue_eq simp: opt_pred_def opt_map_def - split: option.splits) + apply (frule state_relation_release_queue_relation) + apply (force dest!: in_release_q_tcbInReleaseQueue_eq simp: in_release_q_def) done lemma getSchedulable_corres: @@ -3037,7 +3899,8 @@ lemma getSchedulable_corres: apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) apply (fastforce intro: tcb_at_cross) apply (rule corres_bind_return2) - apply (rule corres_symb_exec_r[OF _ getSchedulable_sp, rotated]; (solves wpsimp)?) + apply (rule corres_symb_exec_r_conj_ex_abs_forwards[OF _ getSchedulable_sp, rotated]; (solves wpsimp)?) + apply (wpsimp wp: no_fail_getSchedulable) apply (rule corres_gets_return_trivial) apply (fastforce dest: schedulable_schedulable'_eq) done @@ -3074,11 +3937,10 @@ context TcbAcc_R_2 begin lemma rescheduleRequired_corres_weak: "corres dc - (valid_tcbs and in_correct_ready_q and weaker_valid_sched_action - and pspace_aligned and pspace_distinct and active_scs_valid and ready_or_release - and ready_qs_distinct) - (valid_tcbs' and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct') + (ep_queues_blocked and ntfn_queues_blocked and valid_tcbs and in_correct_ready_q + and weaker_valid_sched_action and pspace_aligned and pspace_distinct + and active_scs_valid and ready_or_release and ready_qs_distinct and ready_queues_runnable) + (valid_tcbs' and valid_sched_pointers) reschedule_required rescheduleRequired" apply (simp add: rescheduleRequired_def reschedule_required_def) apply (rule corres_underlying_split[OF _ _ gets_sp, rotated 2]) @@ -3136,10 +3998,10 @@ lemma rescheduleRequired_corres_weak: lemma rescheduleRequired_corres: "corres dc - (valid_tcbs and weak_valid_sched_action and pspace_aligned and pspace_distinct - and active_scs_valid and in_correct_ready_q and ready_or_release and ready_qs_distinct) - (valid_tcbs' and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct') + (ep_queues_blocked and ntfn_queues_blocked and valid_tcbs and weak_valid_sched_action + and pspace_aligned and pspace_distinct and active_scs_valid + and in_correct_ready_q and ready_or_release and ready_qs_distinct and ready_queues_runnable) + (valid_tcbs' and valid_sched_pointers) reschedule_required rescheduleRequired" by (rule corres_guard_imp[OF rescheduleRequired_corres_weak]) (auto simp: weak_valid_sched_action_strg) @@ -3168,7 +4030,7 @@ lemma weak_sch_act_wf_lift: crunch (in TcbAcc_R) tcbSchedEnqueue for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (wp: weak_sch_act_wf_lift ignore: tcbSchedEnqueue) + (wp: weak_sch_act_wf_lift) lemma rescheduleRequired_weak_sch_act_wf[wp]: "\\\ @@ -3192,57 +4054,10 @@ lemma doMachineOp_weak_sch_act_wf[wp]: doMachineOp m \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" by (simp add: doMachineOp_def split_def tcb_in_cur_domain'_def | wp weak_sch_act_wf_lift)+ -lemma weak_sch_act_wf_setQueue[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ - setQueue qdom prio queue - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s \" - by (simp add: setQueue_def weak_sch_act_wf_def tcb_in_cur_domain'_def | wp)+ - -lemma threadSet_tcbDomain_triv: - assumes "\tcb. tcbDomain (f tcb) = tcbDomain tcb" - shows "\tcb_in_cur_domain' t'\ threadSet f t \\_. tcb_in_cur_domain' t'\" - apply (simp add: tcb_in_cur_domain'_def) - apply (rule_tac f="ksCurDomain" in hoare_lift_Pf) - apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | simp add: assms)+ - done - -lemmas threadSet_weak_sch_act_wf[wp] - = weak_sch_act_wf_lift[OF threadSet.ksSchedulerAction threadSet_tcb_at', simplified] - -lemma removeFromBitmap_nosch[wp]: - "\\s. P (ksSchedulerAction s)\ removeFromBitmap d p \\rv s. P (ksSchedulerAction s)\" - unfolding removeFromBitmap_def - by (simp add: bitmap_fun_defs|wp setObject_nosch)+ - -lemma addToBitmap_nosch[wp]: - "\\s. P (ksSchedulerAction s)\ addToBitmap d p \\rv s. P (ksSchedulerAction s)\" - unfolding addToBitmap_def - by (simp add: bitmap_fun_defs|wp setObject_nosch)+ - -lemmas removeFromBitmap_weak_sch_act_wf[wp] - = weak_sch_act_wf_lift[OF removeFromBitmap_nosch] - -lemmas addToBitmap_weak_sch_act_wf[wp] - = weak_sch_act_wf_lift[OF addToBitmap_nosch] - crunch removeFromBitmap, addToBitmap for pred_tcb_at'[wp]: "\s. Q (pred_tcb_at' proj P' t s)" and obj_at'[wp]: "\s. Q (obj_at' P t s)" -lemma removeFromBitmap_tcb_in_cur_domain'[wp]: - "\tcb_in_cur_domain' t\ removeFromBitmap tdom prio \\ya. tcb_in_cur_domain' t\" - unfolding tcb_in_cur_domain'_def removeFromBitmap_def - apply (rule_tac f="\s. ksCurDomain s" in hoare_lift_Pf) - apply (wp setObject_cte_obj_at_tcb' | simp add: bitmap_fun_defs)+ - done - -lemma addToBitmap_tcb_in_cur_domain'[wp]: - "\tcb_in_cur_domain' t\ addToBitmap tdom prio \\ya. tcb_in_cur_domain' t\" - unfolding tcb_in_cur_domain'_def addToBitmap_def - apply (rule_tac f="\s. ksCurDomain s" in hoare_lift_Pf) - apply (wp setObject_cte_obj_at_tcb' | simp add: bitmap_fun_defs)+ - done - lemma dequeue_nothing_eq[simp]: "t \ set list \ tcb_sched_dequeue t list = list" apply (clarsimp simp: tcb_sched_dequeue_def) @@ -3256,49 +4071,6 @@ lemma gets_the_exec: "f s \ None \ (do x \ ge return_def assert_opt_def) done -definition tcb_sched_dequeue' :: "obj_ref \ unit det_ext_monad" where - "tcb_sched_dequeue' tcb_ptr \ do - d \ thread_get tcb_domain tcb_ptr; - prio \ thread_get tcb_priority tcb_ptr; - queue \ get_tcb_queue d prio; - when (tcb_ptr \ set queue) $ set_tcb_queue d prio (tcb_queue_remove tcb_ptr queue) - od" - -lemma filter_tcb_queue_remove: - "\a \ set ls; distinct ls \ \ filter ((\) a) ls = tcb_queue_remove a ls" - apply (clarsimp simp: tcb_queue_remove_def) - apply (intro conjI impI) - apply (fastforce elim: filter_hd_equals_tl) - apply (fastforce elim: filter_last_equals_butlast) - apply (fastforce elim: filter_hd_equals_tl) - apply (frule split_list) - apply (clarsimp simp: list_remove_middle_distinct) - apply (subst filter_True | clarsimp simp: list_remove_none)+ - done - -lemma tcb_sched_dequeue_monadic_rewrite: - "monadic_rewrite False True (tcb_at t and (\s. \d p. distinct (ready_queues s d p))) - (tcb_sched_action tcb_sched_dequeue t) (tcb_sched_dequeue' t)" - supply if_split[split del] - apply (clarsimp simp: tcb_sched_dequeue'_def tcb_sched_dequeue_def tcb_sched_action_def - set_tcb_queue_def) - apply (rule monadic_rewrite_bind_tail)+ - apply (clarsimp simp: when_def) - apply (rule monadic_rewrite_if_r) - apply (rule_tac P="\_. distinct queue" in monadic_rewrite_guard_arg_cong) - apply (erule (1) filter_tcb_queue_remove) - apply (rule monadic_rewrite_modify_noop) - apply (wpsimp wp: thread_get_wp)+ - apply (clarsimp simp: tcb_at_def) - apply (prop_tac "tcb_sched_ready_q_update (tcb_domain tcb) (tcb_priority tcb) - (filter ((\) t)) (ready_queues s) - = ready_queues s") - apply (subst filter_True) - apply fastforce - apply (clarsimp del: ext intro!: ext split: if_splits) - apply fastforce - done - crunch removeFromBitmap for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" @@ -3307,42 +4079,8 @@ lemma thread_get_test: "do cur_ts \ get_thread_state cur; g (test cur apply (simp add: get_thread_state_def thread_get_def) done -lemma (in TcbAcc_R) setObject_tcbState_update_corres: - "\thread_state_relation ts ts'; tcb_relation tcb tcb'\ \ - corres dc - (ko_at (TCB tcb) t) - (ko_at' tcb' t) - (set_object t (TCB (tcb\tcb_state := ts\))) - (setObject t (tcbState_update (\_. ts') tcb'))" - apply (rule setObject_update_TCB_corres') - apply (simp add: tcb_relation_def) - apply (rule ball_tcb_cap_casesI; clarsimp) - apply (rule ball_tcb_cte_casesI; clarsimp) - apply (fastforce simp: inQ_def)+ - done - context TcbAcc_R_2 begin -lemma scheduleTCB_corres: - "corres dc - (valid_tcbs and weak_valid_sched_action and pspace_aligned and pspace_distinct - and tcb_at tcbPtr and active_scs_valid and in_correct_ready_q and ready_or_release - and ready_qs_distinct) - (valid_tcbs' and sym_heap_sched_pointers and valid_sched_pointers - and pspace_aligned' and pspace_distinct') - (schedule_tcb tcbPtr) (scheduleTCB tcbPtr)" - apply (clarsimp simp: schedule_tcb_def scheduleTCB_def) - apply (rule corres_guard_imp) - apply (rule corres_split [OF getCurThread_corres]) - apply (rule corres_split [OF getSchedulerAction_corres], rename_tac sched_action) - apply (rule corres_split [OF getSchedulable_corres]) - apply (clarsimp simp: when_def) - apply (intro conjI impI; (clarsimp simp: sched_act_relation_def)?) - apply (rule rescheduleRequired_corres) - apply (case_tac sched_act; clarsimp) - apply (wpsimp wp: getSchedulable_wp)+ - done - lemma set_thread_state_act_corres: "corres dc (valid_tcbs and pspace_aligned and pspace_distinct and tcb_at tcbPtr) @@ -3355,12 +4093,12 @@ lemma set_thread_state_act_corres: apply (corres corres: getSchedulerAction_corres) apply (rule corres_split_forwards'[OF _ gets_sp getSchedulable_sp]) apply (corres corres: getSchedulable_corres) - apply (clarsimp simp: when_def split del: if_split) + apply (clarsimp simp: scheduleTCB_def when_def split del: if_split) + apply (rename_tac sched_act action schedulable) apply (rule corres_if_split) apply (case_tac sched_act; clarsimp) - apply (corres corres: rescheduleRequired_corres_simple) - apply (fastforce simp: sch_act_simple_def) - apply simp + apply (corres corres: setSchedulerAction_corres) + apply fastforce done lemma setThreadState_corres: @@ -3369,21 +4107,21 @@ lemma setThreadState_corres: (valid_tcbs and pspace_aligned and pspace_distinct and tcb_at t and valid_tcb_state ts) valid_tcbs' (set_thread_state t ts) (setThreadState ts' t)" - apply (rule corres_cross_add_guard[where Q'="tcb_at' t and valid_tcb_state' ts'"]) - apply (solves \fastforce simp: state_relation_def intro: valid_tcb_state_cross tcb_at_cross\) - apply (simp add: set_thread_state_thread_set setThreadState_def) + apply (rule corres_cross_add_guard[where Q'="tcb_at' t"]) + apply (solves \fastforce simp: state_relation_def intro: tcb_at_cross\) + apply (simp add: set_thread_state_def setThreadState_def) apply (rule corres_guard_imp) apply (rule corres_split[OF threadset_corresT]; simp?) apply (clarsimp simp: tcb_relation_def) apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def tcb_cte_cases_neqs) + apply (clarsimp simp: tcb_cte_cases_def gen_objBits_simps tcb_cte_cases_neqs) apply (clarsimp simp: inQ_def) apply (rule set_thread_state_act_corres) apply (wpsimp wp: thread_set_valid_tcbs) apply (wpsimp wp: threadSet_valid_tcbs') apply wpsimp apply (fastforce intro: valid_tcb_state_update) - apply (fastforce intro: valid_tcb'_tcbState_update) + apply (clarsimp simp: valid_tcb'_tcbState_update) done lemma set_tcb_obj_ref_corresT: @@ -3463,30 +4201,25 @@ lemma tcbSchedPrev_update_valid_objs'[wp]: done lemma tcbQueuePrepend_valid_objs'[wp]: - "\\s. valid_objs' s \ tcb_at' tcbPtr s - \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)\ + "\valid_objs' and tcb_at' tcbPtr\ tcbQueuePrepend queue tcbPtr \\_. valid_objs'\" unfolding tcbQueuePrepend_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift' simp: tcbQueueEmpty_def) + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (clarsimp simp: list_queue_relation_def tcbQueueEmpty_def) + apply (rename_tac ts head) + apply (prop_tac "ts \ []", fastforce) + apply (fastforce dest: heap_path_head) + done crunch addToBitmap for valid_objs'[wp]: valid_objs' (simp: unless_def crunch_simps wp: crunch_wps) lemma tcbSchedEnqueue_valid_objs'[wp]: - "\valid_objs' and pspace_aligned' and pspace_distinct'\ - tcbSchedEnqueue tcbPtr - \\_. valid_objs'\" + "tcbSchedEnqueue tcbPtr \valid_objs'\" unfolding tcbSchedEnqueue_def setQueue_def - apply (wpsimp wp: threadSet_valid_objs' threadGet_wp hoare_vcg_all_lift) - apply normalise_obj_at' - apply (rename_tac tcb head) - apply (clarsimp simp: ksReadyQueues_asrt_def ready_queue_relation_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues simp: tcbQueueEmpty_def) - done + by (wpsimp wp: threadSet_valid_objs' threadGet_wp) crunch rescheduleRequired, removeFromBitmap, scheduleTCB for valid_objs'[wp]: valid_objs' @@ -3505,12 +4238,11 @@ lemma tcbSchedDequeue_valid_objs'[wp]: unfolding tcbSchedDequeue_def setQueue_def by (wpsimp wp: threadSet_valid_objs' threadGet_wp) -lemma sts_valid_objs': - "\valid_objs' and valid_tcb_state' st and pspace_aligned' and pspace_distinct'\ - setThreadState st t - \\_. valid_objs'\" +lemma setThreadState_valid_objs'[wp]: + "setThreadState st t \valid_objs'\" apply (wpsimp simp: setThreadState_def wp: threadSet_valid_objs') - by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def tcb_cte_cases_neqs) + apply (simp add: valid_tcb'_def tcb_cte_cases_def objBits_simps') + done lemma sbn_valid_objs': "\valid_objs' and valid_bound_ntfn' ntfn\ @@ -3532,18 +4264,13 @@ lemma ssa_wp[wp]: by (wpsimp simp: setSchedulerAction_def) crunch removeFromBitmap - for pspace_aligned'[wp]: "pspace_aligned'" - and pspace_distinct'[wp]: "pspace_distinct'" - and pspace_bounded'[wp]: "pspace_bounded'" - and no_0_obj[wp]: "no_0_obj'" - and reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" - and valid_replies'[wp]: "valid_replies'" + for valid_replies'[wp]: "valid_replies'" (wp: valid_replies'_lift) crunch rescheduleRequired, tcbSchedDequeue, scheduleTCB for st_tcb_at'[wp]: "st_tcb_at' P p" and valid_replies' [wp]: valid_replies' - (wp: crunch_wps threadSet_pred_tcb_no_state valid_replies'_lift ignore: threadSet) + (wp: crunch_wps threadSet_pred_tcb_no_state valid_replies'_lift simp: crunch_simps) crunch rescheduleRequired, tcbSchedDequeue, setThreadState for aligned'[wp]: pspace_aligned' @@ -3552,7 +4279,7 @@ crunch rescheduleRequired, tcbSchedDequeue, setThreadState and no_0_obj'[wp]: no_0_obj' and pspace_canonical'[wp]: pspace_canonical' and pspace_in_kernel_mappings'[wp]: pspace_in_kernel_mappings' - (wp: crunch_wps) + (wp: crunch_wps simp: crunch_simps) lemma threadSet_valid_replies': "\\s. valid_replies' s \ @@ -3576,13 +4303,13 @@ lemma sts'_valid_replies': by (auto simp: pred_tcb_at'_def obj_at'_def opt_map_def) lemma sts'_valid_pspace'_inv[wp]: - "\ valid_pspace' and tcb_at' t and valid_tcb_state' st - and (\s. \rptr. st_tcb_at' ((=) (BlockedOnReply (Some rptr))) t s - \ st = BlockedOnReply (Some rptr) \ \ is_reply_linked rptr s)\ + "\valid_pspace' and tcb_at' t + and (\s. \rptr. st_tcb_at' ((=) (BlockedOnReply (Some rptr))) t s + \ st = BlockedOnReply (Some rptr) \ \ is_reply_linked rptr s)\ setThreadState st t - \ \rv. valid_pspace' \" + \\_. valid_pspace' \" apply (simp add: valid_pspace'_def) - apply (wpsimp wp: sts_valid_objs' sts'_valid_replies') + apply (wpsimp wp: sts'_valid_replies') by (auto simp: opt_map_def) abbreviation is_replyState :: "thread_state \ bool" where @@ -3626,27 +4353,11 @@ lemma sts'_valid_replies'_except_Blocked: apply (wpsimp wp: threadSet_valid_replies'_except_Blocked) by (auto simp: pred_tcb_at'_def obj_at'_def opt_map_def) -lemma setQueue_tcb_in_cur_domain'[wp]: - "\tcb_in_cur_domain' t\ setQueue d p xs \\_. tcb_in_cur_domain' t\" - apply (simp add: setQueue_def tcb_in_cur_domain'_def) - apply wp - apply (simp add: ps_clear_def obj_at'_def) - done - lemma sbn'_valid_pspace'_inv[wp]: - "\ valid_pspace' and tcb_at' t and valid_bound_ntfn' ntfn \ - setBoundNotification ntfn t - \ \rv. valid_pspace' \" - apply (simp add: valid_pspace'_def) - apply (rule hoare_pre) - apply (wp sbn_valid_objs') - apply (simp add: setBoundNotification_def threadSet_def bind_assoc valid_mdb'_def) - apply (wp getObject_obj_at_tcb) - apply (clarsimp simp: valid_mdb'_def) - apply (drule obj_at_ko_at') - apply clarsimp - apply (erule obj_at'_weakenE) - apply (simp add: tcb_cte_cases_def tcb_cte_cases_neqs) + "\valid_pspace' and valid_bound_ntfn' ntfn\ setBoundNotification ntfn t \\_. valid_pspace'\" + apply (clarsimp simp: setBoundNotification_def valid_pspace'_def) + apply (wpsimp wp: threadSet_valid_replies' threadSet_valid_objs' threadSet_mdb') + apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) done end @@ -3654,12 +4365,6 @@ end crunch setQueue for pred_tcb_at'[wp]: "\s. P (pred_tcb_at' proj P' t s)" -lemma (in TcbAcc_R) setQueue_sch_act: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - setQueue d p xs - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wp sch_act_wf_lift) - lemma setQueue_valid_bitmapQ_except[wp]: "\ valid_bitmapQ_except d p \ setQueue d p ts @@ -3672,42 +4377,6 @@ lemma ssa_sch_act[wp]: \\rv s. sch_act_wf (ksSchedulerAction s) s\" by (simp add: setSchedulerAction_def | wp)+ -lemma threadSet_runnable_sch_act: - "(\tcb. runnable' (tcbState (F tcb)) \ tcbDomain (F tcb) = tcbDomain tcb \ tcbPriority (F tcb) = tcbPriority tcb) \ - \\s. sch_act_wf (ksSchedulerAction s) s\ - threadSet F t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (clarsimp simp: valid_def) - apply (frule_tac P1="(=) (ksSchedulerAction s)" - in use_valid [OF _ threadSet.ksSchedulerAction], - rule refl) - apply (frule_tac P1="(=) (ksCurThread s)" - in use_valid [OF _ threadSet.ct], - rule refl) - apply (frule_tac P1="(=) (ksCurDomain s)" - in use_valid [OF _ threadSet.cur_domain], - rule refl) - apply (case_tac "ksSchedulerAction b", - simp_all add: sch_act_simple_def ct_in_state'_def pred_tcb_at'_def) - apply (drule_tac t'1="ksCurThread s" - and P1="activatable' \ tcbState" - in use_valid [OF _ threadSet_obj_at'_really_strongest]) - apply (clarsimp elim!: obj_at'_weakenE) - apply (simp add: o_def) - apply (rename_tac word) - apply (rule conjI) - apply (frule_tac t'1=word - and P1="runnable' \ tcbState" - in use_valid [OF _ threadSet_obj_at'_really_strongest]) - apply (clarsimp elim!: obj_at'_weakenE, clarsimp simp: obj_at'_def) - apply (simp add: tcb_in_cur_domain'_def) - apply (frule_tac t'1=word - and P1="\tcb. ksCurDomain b = tcbDomain tcb" - in use_valid [OF _ threadSet_obj_at'_really_strongest]) - apply (clarsimp simp: o_def tcb_in_cur_domain'_def) - apply clarsimp - done - lemma threadSet_pred_tcb_at_state: "\\s. tcb_at' t s \ (p = t \ obj_at' (\tcb. P (Q (proj (tcb_to_itcb' (f tcb))))) t s) \ @@ -3723,36 +4392,6 @@ lemma threadSet_pred_tcb_at_state: apply (clarsimp simp: obj_at'_def) done -lemma threadSet_tcbDomain_triv': - "\tcb_in_cur_domain' t' and K (t \ t')\ threadSet f t \\_. tcb_in_cur_domain' t'\" - apply (simp add: tcb_in_cur_domain'_def) - apply (rule hoare_assume_pre) - apply simp - apply (rule_tac f="ksCurDomain" in hoare_lift_Pf) - apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | simp)+ - done - -lemma threadSet_sch_act_wf: - "\\s. sch_act_wf (ksSchedulerAction s) s \ sch_act_not t s \ - (ksCurThread s = t \ \(\tcb. activatable' (tcbState (F tcb))) \ - ksSchedulerAction s \ ResumeCurrentThread) \ - threadSet F t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (rule hoare_lift_Pf2 [where f=ksSchedulerAction]) - prefer 2 - apply wp - apply (case_tac x, simp_all) - apply (simp add: ct_in_state'_def) - apply (rule hoare_lift_Pf2 [where f=ksCurThread]) - prefer 2 - apply wp[1] - apply (wp threadSet_pred_tcb_at_state) - apply clarsimp - apply wp - apply (clarsimp) - apply (wp threadSet_pred_tcb_at_state threadSet_tcbDomain_triv' | clarsimp)+ - done - lemma rescheduleRequired_sch_act'[wp]: "\\\ rescheduleRequired @@ -3800,26 +4439,6 @@ lemma setObject_queued_ct_activatable'[wp]: apply (clarsimp simp: obj_at'_def) done -lemma threadSet_queued_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - threadSet (tcbQueued_update f) t - \\_ s. sch_act_wf (ksSchedulerAction s) s\" - including classic_wp_pre - apply (simp add: sch_act_wf_cases - split: scheduler_action.split) - apply (wp hoare_vcg_conj_lift) - apply (simp add: threadSet_def) - apply (wp hoare_weak_lift_imp) - apply wps - apply (wp hoare_weak_lift_imp getObject_tcb_wp)+ - apply (clarsimp simp: obj_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_conj_lift hoare_convert_imp)+ - apply (simp add: threadSet_def) - apply (wp getObject_tcb_wp) - apply (clarsimp simp: obj_at'_def) - apply (wp tcb_in_cur_domain'_lift | simp add: obj_at'_def)+ - done - lemma tcbSchedNext_update_pred_tcb_at'[wp]: "threadSet (tcbSchedNext_update f) t \\s. P (pred_tcb_at' proj P' t' s)\" by (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ @@ -3834,69 +4453,6 @@ lemma tcbSchedEnqueue_pred_tcb_at'[wp]: apply (wp threadSet_pred_tcb_no_state crunch_wps | clarsimp simp: tcb_to_itcb'_def)+ done -lemma (in TcbAcc_R_2) tcbSchedDequeue_sch_act_wf[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s\ - tcbSchedDequeue t - \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding tcbSchedDequeue_def tcbQueueRemove_def - by (wp setQueue_sch_act threadSet_tcbDomain_triv hoare_drop_imps - | wp sch_act_wf_lift | simp add: if_apply_def2)+ - -lemma scheduleTCB_sch_act_wf: - "\\s. \ (t = ksCurThread s \ ksSchedulerAction s = ResumeCurrentThread - \ \ (runnable' |< (tcbs_of' s ||> tcbState)) t) - \ (sch_act_wf (ksSchedulerAction s) s)\ - scheduleTCB t - \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding scheduleTCB_def - by (wpsimp wp: getSchedulable_wp simp: schedulable'_def) - -lemma sts_sch_act': - "\\s. (\ runnable' st \ sch_act_not t s) \ sch_act_wf (ksSchedulerAction s) s\ - setThreadState st t \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: setThreadState_def) - apply (wp scheduleTCB_sch_act_wf) - prefer 2 - apply assumption - apply (case_tac "runnable' st") - apply (wpsimp wp: hoare_drop_imps threadSet_runnable_sch_act) - apply (rule_tac Q'="\rv s. st_tcb_at' (Not \ runnable') t s \ - (ksCurThread s \ t \ ksSchedulerAction s \ ResumeCurrentThread \ - sch_act_wf (ksSchedulerAction s) s)" - in hoare_post_imp) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def opt_pred_def opt_map_def) - apply (simp only: imp_conv_disj) - apply (wpsimp wp: threadSet_pred_tcb_at_state threadSet_sch_act_wf hoare_vcg_disj_lift) - done - -(* FIXME: sts_sch_act' (above) is stronger, and should be the wp rule. VER-1366 *) -lemma sts_sch_act[wp]: - "\\s. (\ runnable' st \ sch_act_simple s) \ sch_act_wf (ksSchedulerAction s) s\ - setThreadState st t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: setThreadState_def) - apply (wp scheduleTCB_sch_act_wf) - prefer 2 - apply assumption - apply (case_tac "runnable' st") - apply (wpsimp wp: hoare_drop_imps threadSet_runnable_sch_act) - apply (rule_tac Q'="\rv s. st_tcb_at' (Not \ runnable') t s \ - (ksCurThread s \ t \ ksSchedulerAction s \ ResumeCurrentThread \ - sch_act_wf (ksSchedulerAction s) s)" - in hoare_post_imp) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def opt_pred_def opt_map_def elim!: opt_mapE) - apply (simp only: imp_conv_disj) - apply (wpsimp wp: threadSet_pred_tcb_at_state threadSet_sch_act_wf hoare_vcg_disj_lift) - apply (fastforce simp: sch_act_simple_def) - done - -lemma sbn_sch_act': - "\\s. sch_act_wf (ksSchedulerAction s) s\ - setBoundNotification ntfn t \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_sch_act | simp)+ - done - lemma ssa_sch_act_simple[wp]: "sa = ResumeCurrentThread \ sa = ChooseNewThread \ \\\ setSchedulerAction sa \\rv. sch_act_simple\" @@ -3921,19 +4477,6 @@ lemma sts_sch_act_simple[wp]: apply (clarsimp simp: setThreadState_def) by (wpsimp simp: sch_act_simple_def) -lemma setQueue_after: - "(setQueue d p q >>= (\rv. threadSet f t)) = - (threadSet f t >>= (\rv. setQueue d p q))" - apply (simp add: setQueue_def) - apply (rule oblivious_modify_swap) - apply (simp add: threadSet_def getObject_def setObject_def obind_def - loadObject_default_def gets_the_def omonad_defs read_magnitudeCheck_assert - split_def projectKO_def alignCheck_assert readObject_def - magnitudeCheck_assert updateObject_default_def - split: option.splits if_splits) - apply (intro oblivious_bind, simp_all split: option.splits) - done - context TcbAcc_R begin lemma no_0_obj_kheap: @@ -4032,33 +4575,20 @@ lemma setQueue_bitmapQ_no_L2_orphans[wp]: unfolding setQueue_def bitmapQ_no_L2_orphans_def null_def by (wp, auto) -crunch setQueue - for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" - -lemma tcbSchedEnqueue_tcbInReleaseQueue[wp]: - "tcbSchedEnqueue tcbPtr \\s. P (tcbInReleaseQueue |< tcbs_of' s)\" - apply (clarsimp simp: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def when_def setQueue_def) - apply (wpsimp wp: threadGet_wp threadSet_wp simp: bitmap_fun_defs) - by (fastforce simp: obj_at'_def opt_pred_def opt_map_def intro!: ext - split: option.splits if_splits elim!: rsubst[where P=P]) +crunch orderedInsert, tcbQueueRemove, tcbSchedEnqueue, tcbSchedAppend, tcbSchedDequeue + for tcbInReleaseQueue[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" + (wp: threadSet_field_opt_pred crunch_wps) crunch tcbSchedEnqueue for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" lemma tcbSchedPrev_update_tcbInReleaseQueues[wp]: "threadSet (tcbSchedPrev_update f) tcbPtr \\s. P (tcbInReleaseQueue |< tcbs_of' s)\" - by (wpsimp wp: threadSet_tcbInReleaseQueue) + by (wpsimp wp: threadSet_field_opt_pred) lemma tcbSchedNext_update_tcbInReleaseQueue[wp]: "threadSet (tcbSchedNext_update f) tcbPtr \\s. P (tcbInReleaseQueue |< tcbs_of' s)\" - by (wpsimp wp: threadSet_tcbInReleaseQueue) - -crunch tcbSchedEnqueue - for valid_dom_schedule'_misc[wp]: "\s. P (ksDomScheduleIdx s) (ksDomSchedule s)" - -lemma tcbSchedEnqueue_valid_dom_schedule'[wp]: - "tcbSchedEnqueue t \valid_dom_schedule'\" - by (wpsimp wp: valid_dom_schedule'_lift) + by (wpsimp wp: threadSet_field_opt_pred) lemma rescheduleRequired_valid_bitmapQ_sch_act_simple: "\ valid_bitmapQ and sch_act_simple\ @@ -4173,25 +4703,22 @@ lemma tcbQueued_update_valid_tcbs'[wp]: by (wpsimp wp: threadSet_valid_tcbs') lemma tcbQueuePrepend_valid_tcbs'[wp]: - "\\s. valid_tcbs' s \ tcb_at' tcbPtr s - \ (\head. tcbQueueHead queue = Some head \ tcb_at' head s)\ + "\\s. valid_tcbs' s \ tcb_at' tcbPtr s\ tcbQueuePrepend queue tcbPtr \\_. valid_tcbs'\" unfolding tcbQueuePrepend_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift' simp: tcbQueueEmpty_def) + apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') + apply (clarsimp simp: list_queue_relation_def tcbQueueEmpty_def) + apply (rename_tac ts) + apply (prop_tac "ts \ []", fastforce) + apply (fastforce dest: heap_path_head) + done -lemma tcbSchedEnqueue_valid_tcbs': - "\valid_tcbs' and pspace_aligned' and pspace_distinct'\ - tcbSchedEnqueue thread - \\_. valid_tcbs'\" +lemma tcbSchedEnqueue_valid_tcbs'[wp]: + "tcbSchedEnqueue thread \valid_tcbs'\" apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def bitmap_fun_defs) apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift' threadGet_wp hoare_vcg_all_lift) - apply normalise_obj_at' - apply (rename_tac tcb head) - apply (clarsimp simp: ksReadyQueues_asrt_def ready_queue_relation_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues simp: tcbQueueEmpty_def) + apply (clarsimp simp: obj_at'_def) done lemma setSchedulerAction_valid_tcbs'[wp]: @@ -4200,9 +4727,7 @@ lemma setSchedulerAction_valid_tcbs'[wp]: by (wpsimp wp: hoare_vcg_all_lift update_valid_tcb') lemma rescheduleRequired_valid_tcbs'[wp]: - "\valid_tcbs' and pspace_aligned' and pspace_distinct'\ - rescheduleRequired - \\_. valid_tcbs'\" + "rescheduleRequired \valid_tcbs'\" apply (clarsimp simp: rescheduleRequired_def) apply (rule bind_wp_fwd_skip, wpsimp wp: tcbSchedEnqueue_valid_tcbs' update_valid_tcb' getSchedulable_wp)+ @@ -4214,9 +4739,7 @@ crunch scheduleTCB (wp: crunch_wps simp: crunch_simps) lemma setThreadState_valid_tcbs'[wp]: - "\valid_tcb_state' st and valid_tcbs' and pspace_aligned' and pspace_distinct'\ - setThreadState st t - \\_. valid_tcbs' \" + "setThreadState st t \valid_tcbs'\" apply (simp add: setThreadState_def pred_conj_def) apply (wpsimp wp: threadSet_valid_tcbs') apply (clarsimp simp: valid_tcb'_tcbState_update) @@ -4229,15 +4752,12 @@ crunch rescheduleRequired crunch setThreadState, setBoundNotification for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" + and tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" and tcbInReleaseQueue[wp]: "\s. P (tcbInReleaseQueue |< tcbs_of' s)" - (wp: threadSet_tcbSchedNexts_of threadSet_tcbSchedPrevs_of threadSet_tcbInReleaseQueue) - -lemma setThreadState_valid_objs'[wp]: - "\valid_tcb_state' st and valid_objs' and pspace_aligned' and pspace_distinct'\ - setThreadState st t - \\_. valid_objs'\" - unfolding setThreadState_def - by (wpsimp wp: threadSet_valid_objs' simp: valid_tcb'_tcbState_update) + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + (wp: crunch_wps sym_heap_sched_pointers_lift threadSet_field_inv threadSet_field_opt_pred + simp: crunch_simps) lemma setSchedulerAction_ksQ[wp]: "\\s. P (ksReadyQueues s)\ setSchedulerAction act \\_ s. P (ksReadyQueues s)\" @@ -4408,25 +4928,6 @@ lemma (in TcbAcc_R_2) ct_in_state'_set: apply clarsimp done -crunch setQueue, scheduleTCB, tcbSchedDequeue - for idle'[wp]: "valid_idle'" - (simp: crunch_simps wp: crunch_wps) - -lemma sts_valid_idle'[wp]: - "\valid_idle' and (\s. t = ksIdleThread s \ idle' ts)\ - setThreadState ts t - \\rv. valid_idle'\" - apply (simp add: setThreadState_def) - by (wpsimp wp: threadSet_idle' simp: idle_tcb'_def) - -lemma sbn_valid_idle'[wp]: - "\valid_idle' and (\s. t = ksIdleThread s \ \bound ntfn)\ - setBoundNotification ntfn t - \\rv. valid_idle'\" - apply (simp add: setBoundNotification_def) - apply (wpsimp wp: threadSet_idle' simp: idle_tcb'_def) - done - lemma gts_sp': "\P\ getThreadState t \\rv. st_tcb_at' (\st. st = rv) t and P\" apply (simp add: getThreadState_def threadGet_getObject) @@ -4471,7 +4972,7 @@ lemma tcbReleaseRemove_pred_tcb_at'[wp]: | fastforce simp: obj_at'_def)+ done -crunch tcbReleaseRemove +crunch (in TcbAcc_R) tcbReleaseRemove for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" (wp: crunch_wps) @@ -4510,6 +5011,7 @@ lemma sbn_st_tcb'[wp]: crunch scheduleTCB, setThreadState for cte_wp_at'[wp]: "\s. Q (cte_wp_at' P p s)" and ksInterruptState[wp]: "\s. P (ksInterruptState s)" + (wp: crunch_wps simp: crunch_simps) lemmas setThreadState_cap_to'[wp] = ex_cte_cap_to'_pres [OF setThreadState_cte_wp_at' setThreadState_ksInterruptState] @@ -4526,6 +5028,7 @@ crunch rescheduleRequired crunch scheduleTCB for state_refs_of'[wp]: "\s. P (state_refs_of' s)" + (wp: crunch_wps simp: crunch_simps) abbreviation tcb_non_st_state_refs_of' :: "kernel_state \ obj_ref \ (obj_ref \ reftype) set" @@ -4556,25 +5059,6 @@ lemma setBoundNotification_list_refs_of_replies'[wp]: unfolding setBoundNotification_def by wpsimp -context TcbAcc_R_2 begin - -lemma sts_cur_tcb'[wp]: - "\cur_tcb'\ setThreadState st t \\rv. cur_tcb'\" - by (wp cur_tcb_lift) - -lemma sbn_cur_tcb'[wp]: - "\cur_tcb'\ setBoundNotification ntfn t \\rv. cur_tcb'\" - by (wp cur_tcb_lift) - -end (* TcbAcc_R_2 *) - -crunch setQueue, addToBitmap, removeFromBitmap - for iflive'[wp]: if_live_then_nonz_cap' - and nonz_cap[wp]: "ex_nonz_cap_to' t" - -crunch rescheduleRequired - for cap_to'[wp]: "ex_nonz_cap_to' p" - lemma update_tcb_cte_cases: "\f. (getF, setF) \ ran tcb_cte_cases \ getF (tcbInReleaseQueue_update f tcb) = getF tcb" "\f. (getF, setF) \ ran tcb_cte_cases \ getF (tcbQueued_update f tcb) = getF tcb" @@ -4595,100 +5079,13 @@ lemma tcbSchedPrev_update_ctes_of[wp]: "threadSet (tcbSchedPrev_update f) tptr \\s. P (ctes_of s)\" by (wpsimp wp: threadSet_ctes_ofT simp: update_tcb_cte_cases) -lemma tcbQueued_ex_nonz_cap_to'[wp]: - "threadSet (tcbQueued_update f) tptr \ex_nonz_cap_to' p\" - by (wpsimp wp: threadSet_cap_to simp: update_tcb_cte_cases) - -lemma tcbInReleaseQueue_ex_nonz_cap_to'[wp]: - "threadSet (tcbInReleaseQueue_update f) tptr \ex_nonz_cap_to' p\" - by (wpsimp wp: threadSet_cap_to simp: update_tcb_cte_cases) - -lemma tcbSchedNext_ex_nonz_cap_to'[wp]: - "threadSet (tcbSchedNext_update f) tptr \ex_nonz_cap_to' p\" - by (wpsimp wp: threadSet_cap_to simp: update_tcb_cte_cases) - -lemma tcbSchedPrev_ex_nonz_cap_to'[wp]: - "threadSet (tcbSchedPrev_update f) tptr \ex_nonz_cap_to' p\" - by (wpsimp wp: threadSet_cap_to simp: update_tcb_cte_cases) - -context TcbAcc_R_2 begin - -lemma tcbQueueRemove_if_live_then_nonz_cap': - "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers and ex_nonz_cap_to' tcbPtr\ - tcbQueueRemove q tcbPtr - \\_. if_live_then_nonz_cap'\" - unfolding tcbQueueRemove_def - apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' - hoare_vcg_imp_lift' getTCB_wp) - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') - by (force dest: sym_heapD2[where p'=tcbPtr] sym_heapD1[where p=tcbPtr] - elim: if_live_then_nonz_capE' - simp: valid_tcb'_def opt_map_def obj_at'_def ko_wp_at'_def opt_tcb_at'_def live'_def) - -lemma tcbQueueRemove_ex_nonz_cap_to'[wp]: - "tcbQueueRemove q tcbPtr \ex_nonz_cap_to' tcbPtr'\" - unfolding tcbQueueRemove_def - by (wpsimp wp: threadSet_cap_to' hoare_drop_imps getTCB_wp) - -lemma tcbQueuePrepend_if_live_then_nonz_cap': - "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s - \ (\head. tcbQueueHead q = Some head \ ex_nonz_cap_to' head s)\ - tcbQueuePrepend q tcbPtr - \\_. if_live_then_nonz_cap'\" - unfolding tcbQueuePrepend_def tcbQueueEmpty_def - by (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' - hoare_vcg_if_lift2 hoare_vcg_imp_lift') - -lemma tcbQueueAppend_if_live_then_nonz_cap': - "\\s. if_live_then_nonz_cap' s \ ex_nonz_cap_to' tcbPtr s - \ (\end. tcbQueueEnd q = Some end \ ex_nonz_cap_to' end s) - \ (\ls. list_queue_relation ls q (tcbSchedNexts_of s) (tcbSchedPrevs_of s))\ - tcbQueueAppend q tcbPtr - \\_. if_live_then_nonz_cap'\" - unfolding tcbQueueAppend_def tcbQueueEmpty_def - apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive') - by (fastforce dest: he_ptrs_head_iff_he_ptrs_end) - -lemma tcbQueueInsert_if_live_then_nonz_cap': - "\if_live_then_nonz_cap' and ex_nonz_cap_to' tcbPtr and valid_objs' and sym_heap_sched_pointers\ - tcbQueueInsert tcbPtr afterPtr - \\_. if_live_then_nonz_cap'\" - unfolding tcbQueueInsert_def - apply (wpsimp wp: tcbSchedPrev_update_iflive' tcbSchedNext_update_iflive' getTCB_wp) - apply (intro conjI) - apply (erule if_live_then_nonz_capE') - apply (clarsimp simp: ko_wp_at'_def obj_at'_def live'_def) - apply (erule if_live_then_nonz_capE') - apply (frule_tac p'=afterPtr in sym_heapD2) - apply (fastforce simp: opt_map_def obj_at'_def) - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') - apply (clarsimp simp: valid_tcb'_def valid_bound_obj'_def ko_wp_at'_def obj_at'_def opt_map_def - live'_def) - done - -lemma tcbSchedEnqueue_iflive'[wp]: - "\if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'\ - tcbSchedEnqueue tcbPtr - \\_. if_live_then_nonz_cap'\" - unfolding tcbSchedEnqueue_def - apply (wpsimp wp: tcbQueuePrepend_if_live_then_nonz_cap' threadGet_wp hoare_vcg_imp_lift' - hoare_vcg_all_lift) - apply (normalise_obj_at', rename_tac tcb) - apply (frule_tac p=tcbPtr in if_live_then_nonz_capE') - apply (fastforce simp: ko_wp_at'_def obj_at'_def live'_def) - apply clarsimp - apply (erule if_live_then_nonz_capE') - apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - by (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues - simp: ko_wp_at'_def inQ_def obj_at'_def live'_def tcbQueueEmpty_def) - -crunch scheduleTCB - for if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - (wp: crunch_wps isSchedulable_inv hoare_vcg_if_lift2) +defs tcbQueueRemove_asrt_def: + "tcbQueueRemove_asrt \ + \q tcbPtr s. \ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t \ set ts. tcb_at' t s \ (t \ tcbPtr \ sched_flag_set s t)) + \ tcbPtr \ set ts" -end (* TcbAcc_R_2 *) +declare tcbQueueRemove_asrt_def[simp] crunch addToBitmap for if_unsafe_then_cap'[wp]: if_unsafe_then_cap' @@ -4732,7 +5129,7 @@ lemma bound_tcb_ex_cap'': crunch setThreadState, setBoundNotification for arch' [wp]: "\s. P (ksArchState s)" - (simp: unless_def crunch_simps) + (wp: crunch_wps simp: crunch_simps) crunch setThreadState for it' [wp]: "\s. P (ksIdleThread s)" @@ -4741,7 +5138,7 @@ crunch setThreadState crunch setThreadState, setBoundNotification for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" - (simp: unless_def crunch_simps wp: setObject_ksPSpace_only updateObject_default_inv) + (wp: crunch_wps simp: crunch_simps) lemmas setThreadState_irq_handlers[wp] = valid_irq_handlers_lift'' [OF setThreadState_ctes_of setThreadState_ksInterruptState] @@ -4759,12 +5156,12 @@ lemma sbn_global_reds' [wp]: crunch setThreadState, setBoundNotification for irq_states' [wp]: valid_irq_states' - (simp: unless_def crunch_simps) + (wp: crunch_wps simp: crunch_simps) crunch setThreadState, setBoundNotification for ksMachine[wp]: "\s. P (ksMachineState s)" and pspace_domain_valid[wp]: "pspace_domain_valid" - (wp: crunch_wps) + (wp: crunch_wps simp: crunch_simps) lemma (in TcbAcc_R_2) setThreadState_vms'[wp]: "\valid_machine_state'\ setThreadState F t \\rv. valid_machine_state'\" @@ -4772,16 +5169,6 @@ lemma (in TcbAcc_R_2) setThreadState_vms'[wp]: apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift; wp) done -lemma ct_not_inQ_addToBitmap[wp]: - "\ ct_not_inQ \ addToBitmap d p \\_. ct_not_inQ \" - unfolding bitmap_fun_defs - by (wp, clarsimp simp: ct_not_inQ_def) - -lemma ct_not_inQ_removeFromBitmap[wp]: - "\ ct_not_inQ \ removeFromBitmap d p \\_. ct_not_inQ \" - unfolding bitmap_fun_defs - by (wp|simp add: bitmap_fun_defs ct_not_inQ_def comp_def)+ - lemma (in TcbAcc_R_2) setBoundNotification_vms'[wp]: "\valid_machine_state'\ setBoundNotification ntfn t \\rv. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) @@ -4790,144 +5177,22 @@ lemma (in TcbAcc_R_2) setBoundNotification_vms'[wp]: lemma setSchedulerAction_direct[wp]: "\\\ setSchedulerAction sa \\_ s. ksSchedulerAction s = sa\" - by (wpsimp simp: setSchedulerAction_def) - -lemma rescheduleRequired_ct_not_inQ[wp]: - "\\\ rescheduleRequired \\_. ct_not_inQ\" - apply (simp add: rescheduleRequired_def ct_not_inQ_def) - apply (rule_tac Q'="\_ s. ksSchedulerAction s = ChooseNewThread" - in hoare_post_imp, clarsimp) - apply wp - done - -lemma scheduleTCB_ct_not_inQ[wp]: - "scheduleTCB tcbPtr \ct_not_inQ\" - apply (clarsimp simp: scheduleTCB_def getCurThread_def getSchedulerAction_def) - by (wpsimp wp: rescheduleRequired_ct_not_inQ isSchedulable_inv hoare_vcg_if_lift2 hoare_drop_imps) - -lemma rescheduleRequired_sa_cnt[wp]: - "\\s. True \ rescheduleRequired \\_ s. ksSchedulerAction s = ChooseNewThread \" - unfolding rescheduleRequired_def setSchedulerAction_def - by (wpsimp wp: hoare_vcg_if_lift2) - -lemma threadSet_tcbState_update_ct_not_inQ[wp]: - "\ct_not_inQ\ threadSet (tcbState_update f) t \\_. ct_not_inQ\" - apply (simp add: ct_not_inQ_def) - apply (rule hoare_convert_imp [OF threadSet.ksSchedulerAction]) - apply (simp add: threadSet_def) - apply (wp) - apply (wps setObject_ct_inv) - apply (rule setObject_tcb_strongest) - prefer 2 - apply assumption - apply (clarsimp) - apply (rule hoare_conjI) - apply (rule hoare_weaken_pre) - apply (wps, wp hoare_weak_lift_imp) - apply (wp OMG_getObject_tcb)+ - apply (clarsimp simp: comp_def) - apply (wp hoare_drop_imp) - done - -lemma threadSet_tcbBoundNotification_update_ct_not_inQ[wp]: - "\ct_not_inQ\ threadSet (tcbBoundNotification_update f) t \\_. ct_not_inQ\" - apply (simp add: ct_not_inQ_def) - apply (rule hoare_convert_imp [OF threadSet.ksSchedulerAction]) - apply (simp add: threadSet_def) - apply (wp) - apply (wps setObject_ct_inv) - apply (rule setObject_tcb_strongest) - prefer 2 - apply assumption - apply (clarsimp) - apply (rule hoare_conjI) - apply (rule hoare_weaken_pre) - apply wps - apply (wp hoare_weak_lift_imp) - apply (wp OMG_getObject_tcb) - apply (clarsimp simp: comp_def) - apply (wp hoare_drop_imp) - done - -lemma setThreadState_ct_not_inQ: - "\ct_not_inQ\ setThreadState st t \\_. ct_not_inQ\" - (is "\?PRE\ _ \_\") - including no_pre - apply (simp add: setThreadState_def) - by (wpsimp wp: threadSet_tcbState_update_ct_not_inQ) - -lemma setBoundNotification_ct_not_inQ: - "\ct_not_inQ\ setBoundNotification ntfn t \\_. ct_not_inQ\" - (is "\?PRE\ _ \_\") - by (simp add: setBoundNotification_def, wp) - -crunch setQueue - for ct_not_inQ[wp]: "ct_not_inQ" - -crunch setQueue - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - (simp: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) - -crunch tcbQueuePrepend - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - -context TcbAcc_R_2 begin - -lemma addToBitmap_ct_idle_or_in_cur_domain'[wp]: - "\ ct_idle_or_in_cur_domain' \ addToBitmap d p \ \_. ct_idle_or_in_cur_domain' \" - apply (rule ct_idle_or_in_cur_domain'_lift) - apply (wp hoare_vcg_disj_lift| rule obj_at_setObject2 - | clarsimp simp: updateObject_default_def in_monad setNotification_def)+ - done - -lemma removeFromBitmap_ct_idle_or_in_cur_domain'[wp]: - "\ ct_idle_or_in_cur_domain' \ removeFromBitmap d p \ \_. ct_idle_or_in_cur_domain' \" - apply (rule ct_idle_or_in_cur_domain'_lift) - apply (wp hoare_vcg_disj_lift| rule obj_at_setObject2 - | clarsimp simp: updateObject_default_def in_monad setNotification_def)+ - done - -end (* TcbAcc_R_2 *) - -lemma setSchedulerAction_spec: - "\\\setSchedulerAction ChooseNewThread - \\rv. ct_idle_or_in_cur_domain'\" - apply (simp add:setSchedulerAction_def) - apply wp - apply (simp add:ct_idle_or_in_cur_domain'_def) - done - -crunch rescheduleRequired, setThreadState, setBoundNotification - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - (wp: crunch_wps) - -lemma rescheduleRequired_ct_idle_or_in_cur_domain'[wp]: - "\\\ rescheduleRequired \\rv. ct_idle_or_in_cur_domain'\" - apply (simp add: rescheduleRequired_def) - apply (wp setSchedulerAction_spec) - done - -crunch scheduleTCB - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - (wp: crunch_wps hoare_vcg_if_lift2) + by (wpsimp simp: setSchedulerAction_def) -lemma setThreadState_ct_idle_or_in_cur_domain'[wp]: - "\ct_idle_or_in_cur_domain'\ setThreadState st tptr \\rv. ct_idle_or_in_cur_domain'\" - apply (simp add: setThreadState_def) - apply (wp threadSet_ct_idle_or_in_cur_domain' hoare_drop_imps | simp)+ - done +lemma rescheduleRequired_sa_cnt[wp]: + "\\s. True \ rescheduleRequired \\_ s. ksSchedulerAction s = ChooseNewThread \" + unfolding rescheduleRequired_def setSchedulerAction_def + by (wpsimp wp: hoare_vcg_if_lift2) -lemma setBoundNotification_ct_idle_or_in_cur_domain'[wp]: - "\ct_idle_or_in_cur_domain'\ setBoundNotification t a \\rv. ct_idle_or_in_cur_domain'\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_ct_idle_or_in_cur_domain' hoare_drop_imps | simp)+ - done +crunch rescheduleRequired, setThreadState, setBoundNotification + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + (wp: crunch_wps simp: crunch_simps) crunch rescheduleRequired, setBoundNotification, setThreadState for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps) + (wp: crunch_wps simp: crunch_simps) lemma sts_utr[wp]: "\untyped_ranges_zero'\ setThreadState st t \\_. untyped_ranges_zero'\" @@ -4949,14 +5214,6 @@ lemma tcb_bound_refs'_helper: apply (intro conjI impI allI; fastforce?) done -lemma valid_tcb_state'_same_tcb_st_refs_of': - "\tcb_st_refs_of' st = tcb_st_refs_of' st'; valid_tcb_state' st s\ - \ valid_tcb_state' st' s" - apply (cases st'; - clarsimp simp: valid_tcb_state'_def tcb_st_refs_of'_def - split: Structures_H.thread_state.splits if_splits) - by (metis pair_inject reftype.distinct prod.inject) - lemma removeFromBitmap_bitmapQ: "\\\ removeFromBitmap d p \\_ s. \ bitmapQ d p s \" unfolding bitmapQ_defs bitmap_fun_defs @@ -5046,8 +5303,8 @@ lemma tcbSchedEnqueue_valid_bitmapQ[wp]: supply if_split[split del] unfolding tcbSchedEnqueue_def apply (wpsimp simp: tcbQueuePrepend_def - wp: setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except addToBitmap_bitmapQ - threadGet_wp threadSet_bitmapQ) + wp: stateAssert_inv setQueue_valid_bitmapQ' addToBitmap_valid_bitmapQ_except + addToBitmap_bitmapQ threadGet_wp) apply (fastforce simp: valid_bitmaps_def valid_bitmapQ_def tcbQueueEmpty_def split: if_splits) done @@ -5064,61 +5321,212 @@ lemma tcbSchedEnqueue_valid_bitmaps[wp]: crunch rescheduleRequired, threadSet, setThreadState for valid_bitmaps[wp]: valid_bitmaps - (rule: valid_bitmaps_lift) + (rule: valid_bitmaps_lift simp: crunch_simps wp: crunch_wps) end (* TcbAcc_R_2 *) -lemma tcbSchedEnqueue_valid_sched_pointers[wp]: - "tcbSchedEnqueue tcbPtr \valid_sched_pointers\" - apply (clarsimp simp: tcbSchedEnqueue_def getQueue_def unless_def) - \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ - apply (intro bind_wp[OF _ stateAssert_sp] bind_wp[OF _ isRunnable_inv] - bind_wp[OF _ assert_sp] bind_wp[OF _ threadGet_sp] - bind_wp[OF _ gets_sp] - | rule hoare_when_cases, fastforce)+ - apply (forward_inv_step wp: hoare_vcg_ex_lift) - supply if_split[split del] - apply (wpsimp wp: threadSet_wp simp: tcbQueuePrepend_def setQueue_def) - apply (clarsimp simp: valid_sched_pointers_def) - apply (intro conjI impI) - apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) - apply normalise_obj_at' - apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply (clarsimp simp: valid_sched_pointers_def list_queue_relation_def) - apply (case_tac "ts = []", fastforce simp: tcbQueueEmpty_def) +lemma tcbQueueRemove_valid_sched_pointers: + "\valid_sched_pointers_except tcbPtr\ + tcbQueueRemove q tcbPtr + \\_. valid_sched_pointers\" + apply (clarsimp simp: tcbQueueRemove_def valid_sched_pointers_def) + apply (rule bind_wp[OF _ stateAssert_sp])+ + apply (rule bind_wp[OF _ get_tcb_sp']) + apply (rule hoare_if) + \\q is the singleton containing tcbPtr\ + apply wpsimp + apply (clarsimp simp: list_queue_relation_def) + apply (rename_tac ptr ts) + apply (intro conjI impI allI) + apply (drule_tac x=ptr in spec) + apply (force simp: prev_queue_head_def queue_end_valid_def opt_map_def) + apply (drule_tac x=ptr in spec) + apply (force dest: heap_ls_last_None simp: queue_end_valid_def opt_map_def) + apply (rule hoare_if) + \\tcbPtr is the head of q\ + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (clarsimp simp: list_queue_relation_def) + apply (drule obj_at'_prop)+ + subgoal + by (fastforce simp: prev_queue_head_def queue_end_valid_def opt_pred_def opt_map_def) + apply (rule hoare_if) + \\tcbPtr is the end of q\ + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (drule obj_at'_prop)+ + subgoal + by (fastforce dest: heap_ls_last_None + simp: list_queue_relation_def queue_end_valid_def opt_pred_def opt_map_def) + \\tcbPtr occurs in the middle of q\ + apply (wpsimp wp: threadSet_wp getTCB_wp) + apply (frule (2) list_queue_relation_neighbour_in_set) + by (auto simp: list_queue_relation_def obj_at'_def opt_pred_def opt_map_def + split: if_splits option.splits) + +lemma tcbSchedPrev_update_None_valid_sched_pointers[wp]: + "threadSet (tcbSchedPrev_update (\_. None)) tcbPtr \valid_sched_pointers\" + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: valid_sched_pointers_def obj_at'_def opt_map_def in_opt_pred + split: option.splits) + done + +lemma tcbSchedNext_update_None_valid_sched_pointers[wp]: + "threadSet (tcbSchedNext_update (\_. None)) tcbPtr \valid_sched_pointers\" + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: valid_sched_pointers_def obj_at'_def opt_map_def in_opt_pred + split: option.splits) + done + +lemma tcbSchedPrev_update_Some_valid_sched_pointers[wp]: + "\\s. valid_sched_pointers s \ sched_flag_set s tcbPtr\ + threadSet (tcbSchedPrev_update (\_. Some ptr)) tcbPtr + \\_. valid_sched_pointers\" + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: valid_sched_pointers_def obj_at'_def opt_map_def in_opt_pred) + done + +lemma tcbSchedNext_update_Some_valid_sched_pointers[wp]: + "\\s. valid_sched_pointers s \ sched_flag_set s tcbPtr\ + threadSet (tcbSchedNext_update (\_. Some ptr)) tcbPtr + \\_. valid_sched_pointers\" + apply (wpsimp wp: threadSet_wp) + apply (fastforce simp: valid_sched_pointers_def obj_at'_def opt_map_def in_opt_pred) + done + +lemma threadSet_sched_flag_set: + "\\tcb. tcbInReleaseQueue (F tcb) = tcbInReleaseQueue tcb; + \tcb. tcbQueued (F tcb) = tcbQueued tcb; \tcb. tcbState (F tcb) = tcbState tcb\ + \ threadSet F t \\s. P (sched_flag_set s tcbPtr)\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: opt_pred_def opt_map_def obj_at'_def) + done + +lemma tcbSchedNext_update_sched_flag_set[wp]: + "threadSet (tcbSchedNext_update f) t \\s. P (sched_flag_set s tcbPtr)\" + by (wpsimp wp: threadSet_sched_flag_set) + +lemma tcbSchedPrev_update_sched_flag_set[wp]: + "threadSet (tcbSchedPrev_update f) t \\s. P (sched_flag_set s tcbPtr)\" + by (wpsimp wp: threadSet_sched_flag_set) + +lemma tcbQueuePrepend_valid_sched_pointers_except: + "\valid_sched_pointers\ + tcbQueuePrepend q tcbPtr + \\_. valid_sched_pointers_except tcbPtr\" + unfolding tcbQueuePrepend_def + apply (wpsimp wp: threadSet_wp getTCB_wp) + by (force dest!: bspec[where x="the (tcbQueueHead q)"] dest: heap_path_head + simp: valid_sched_pointers_def list_queue_relation_def tcbQueueEmpty_def + opt_pred_def opt_map_def obj_at'_def queue_end_valid_def) + +lemma tcbQueuePrepend_valid_sched_pointers: + "\\s. valid_sched_pointers s \ sched_flag_set s tcbPtr\ + tcbQueuePrepend q tcbPtr + \\_. valid_sched_pointers\" + apply (rule_tac Q'="\_ s. valid_sched_pointers_except tcbPtr s \ sched_flag_set s tcbPtr" + in hoare_post_imp) + apply (fastforce simp: valid_sched_pointers_def list_queue_relation_def) + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (wpsimp wp: tcbQueuePrepend_valid_sched_pointers_except) + apply (clarsimp simp: tcbQueuePrepend_def bind_if_distribR split del: if_split) + apply wpsimp + done + +lemma tcbQueueAppend_valid_sched_pointers_except: + "\valid_sched_pointers\ + tcbQueueAppend q tcbPtr + \\_. valid_sched_pointers_except tcbPtr\" + unfolding tcbQueueAppend_def + apply (wpsimp wp: threadSet_wp getTCB_wp) + by (force dest!: bspec[where x="the (tcbQueueEnd q)"] + simp: valid_sched_pointers_def list_queue_relation_def tcbQueueEmpty_def + opt_pred_def opt_map_def obj_at'_def queue_end_valid_def) + +lemma tcbQueueAppend_valid_sched_pointers: + "\\s. valid_sched_pointers s \ sched_flag_set s tcbPtr\ + tcbQueueAppend q tcbPtr + \\_. valid_sched_pointers\" + apply (rule_tac Q'="\_ s. valid_sched_pointers_except tcbPtr s \ sched_flag_set s tcbPtr" + in hoare_post_imp) + apply (fastforce simp: valid_sched_pointers_def list_queue_relation_def) + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (wpsimp wp: tcbQueueAppend_valid_sched_pointers_except) + apply (clarsimp simp: tcbQueueAppend_def split del: if_split) + apply wpsimp + done + +lemma tcbQueueInsert_valid_sched_pointers_except: + "\valid_sched_pointers\ + tcbQueueInsert tcbPtr afterPtr + \\_. valid_sched_pointers_except tcbPtr\" + apply (clarsimp simp: tcbQueueInsert_def) + apply (wpsimp wp: threadSet_wp getTCB_wp) apply (drule obj_at'_prop)+ apply clarsimp - by (intro conjI impI; - force dest!: hd_in_set heap_path_head - simp: inQ_def opt_pred_def opt_map_def split: if_splits) + apply (rename_tac beforePtr tcb tcb' tcb'') + apply (prop_tac "tcbPtr \ afterPtr", fastforce) + apply (clarsimp simp: valid_sched_pointers_def list_queue_relation_def) + apply (prop_tac "beforePtr \ set ts") + apply (force dest!: heap_ls_prev_cases intro: sym_heapD2 simp: prev_queue_head_def opt_map_def) + apply (clarsimp simp: opt_pred_def opt_map_def split: option.splits) + done + +lemma tcbQueueInsert_valid_sched_pointers: + "\\s. valid_sched_pointers s \ sched_flag_set s tcbPtr\ + tcbQueueInsert tcbPtr afterPtr + \\_. valid_sched_pointers\" + apply (rule_tac Q'="\_ s. valid_sched_pointers_except tcbPtr s \ sched_flag_set s tcbPtr" + in hoare_post_imp) + apply (fastforce simp: valid_sched_pointers_def list_queue_relation_def) + apply (rule hoare_vcg_conj_lift_pre_fix) + apply (wpsimp wp: tcbQueueInsert_valid_sched_pointers_except) + apply (clarsimp simp: tcbQueueInsert_def) + apply (wpsimp wp: getTCB_wp) + done + +lemma orderedInsert_valid_sched_pointers: + "\\s. valid_sched_pointers s \ sched_flag_set s t\ + orderedInsert t q f R + \\_. valid_sched_pointers\" + unfolding orderedInsert_def + by (wpsimp wp: tcbQueuePrepend_valid_sched_pointers tcbQueueAppend_valid_sched_pointers + tcbQueueInsert_valid_sched_pointers hoare_drop_imps) + +crunch addToBitmap + for valid_sched_pointers_except_set[wp]: "valid_sched_pointers_except_set S" + and sched_flag_set[wp]: "\s. sched_flag_set s t" + and tcbStates_of'[wp]: "\s. P (tcbStates_of' s)" + +lemma threadSet_valid_sched_pointers_except_inv[wp]: + "threadSet F tcbPtr \valid_sched_pointers_except tcbPtr\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: valid_sched_pointers_except_def opt_pred_def) + done + +lemma tcbQueued_update_True_sched_flag_set[wp]: + "\\\ threadSet (tcbQueued_update (\_. True)) tcbPtr \\_ s. sched_flag_set s tcbPtr\" + by (wpsimp wp: threadSet_wp) + +lemma tcbInReleaseQueue_update_True_sched_flag_set[wp]: + "\\\ threadSet (tcbInReleaseQueue_update (\_. True)) tcbPtr \\_ s. sched_flag_set s tcbPtr\" + by (wpsimp wp: threadSet_wp) + +lemma tcbQueued_True_valid_sched_pointers[wp]: + "\valid_sched_pointers_except tcbPtr\ + threadSet (tcbQueued_update \) tcbPtr + \\_. valid_sched_pointers\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: valid_sched_pointers_def opt_pred_def) + done + +lemma tcbSchedEnqueue_valid_sched_pointers[wp]: + "tcbSchedEnqueue tcbPtr \valid_sched_pointers\" + unfolding tcbSchedEnqueue_def + by (wpsimp wp: tcbQueuePrepend_valid_sched_pointers_except) lemma tcbSchedAppend_valid_sched_pointers[wp]: "tcbSchedAppend tcbPtr \valid_sched_pointers\" - apply (clarsimp simp: tcbSchedAppend_def getQueue_def unless_def) - \ \we step forwards until we can step over the addToBitmap in order to avoid state blow-up\ - apply (intro bind_wp[OF _ stateAssert_sp] bind_wp[OF _ isRunnable_inv] - bind_wp[OF _ assert_sp] bind_wp[OF _ threadGet_sp] - bind_wp[OF _ gets_sp] - | rule hoare_when_cases, fastforce)+ - apply (forward_inv_step wp: hoare_vcg_ex_lift) - supply if_split[split del] - apply (wpsimp wp: threadSet_wp simp: tcbQueueAppend_def setQueue_def) - apply (clarsimp simp: valid_sched_pointers_def) - apply (intro conjI impI) - apply (fastforce simp: opt_pred_def opt_map_def split: if_splits) - apply normalise_obj_at' - apply (drule obj_at'_prop)+ - apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - by (intro conjI impI; - clarsimp dest: last_in_set - simp: valid_sched_pointers_def opt_map_def list_queue_relation_def tcbQueueEmpty_def - queue_end_valid_def inQ_def opt_pred_def - split: if_splits option.splits; - fastforce) + unfolding tcbSchedAppend_def + by (wpsimp wp: tcbQueueAppend_valid_sched_pointers_except) lemma monadic_rewrite_threadSet_same: "monadic_rewrite F E (obj_at' (\tcb :: tcb. f tcb = tcb) tcbPtr) @@ -5136,59 +5544,44 @@ lemma monadic_rewrite_threadSet_same: apply (clarsimp simp: obj_at'_def) done -lemma tcbSchedDequeue_valid_sched_pointers[wp]: - "\valid_sched_pointers and sym_heap_sched_pointers\ - tcbSchedDequeue tcbPtr +lemma tcbQueued_False_valid_sched_pointers: + "\\s. valid_sched_pointers s \ \ is_sched_linked tcbPtr s\ + threadSet (tcbQueued_update (\_. False)) tcbPtr \\_. valid_sched_pointers\" - supply if_split[split del] fun_upd_apply[simp del] - apply (clarsimp simp: tcbSchedDequeue_def getQueue_def setQueue_def) - apply (wpsimp wp: threadSet_wp getTCB_wp threadGet_wp simp: tcbQueueRemove_def) - apply (thin_tac "valid_objs' s") - apply normalise_obj_at' - apply (rename_tac tcb) - apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - apply (clarsimp split: if_splits) - apply (frule (1) list_queue_relation_neighbour_in_set[where p=tcbPtr]) - apply (fastforce simp: inQ_def opt_pred_def opt_map_def obj_at'_def) - apply (clarsimp simp: list_queue_relation_def) - apply (intro conjI impI) - \ \the ready queue is the singleton consisting of tcbPtr\ - apply (clarsimp simp: valid_sched_pointers_def) - apply (case_tac "ptr = tcbPtr") - apply (force dest!: heap_ls_last_None - simp: prev_queue_head_def queue_end_valid_def inQ_def opt_map_def obj_at'_def) - apply (simp add: fun_upd_def opt_pred_def) - \ \tcbPtr is the head of the ready queue\ - subgoal - by (clarsimp simp: valid_sched_pointers_def fun_upd_apply prev_queue_head_def - inQ_def opt_pred_def opt_map_def obj_at'_def - split: if_splits option.splits; - auto) - \ \tcbPtr is the end of the ready queue\ - apply (frule heap_ls_last_None) - apply (fastforce simp: fun_upd_apply opt_map_def obj_at'_def) - subgoal - by (clarsimp simp: valid_sched_pointers_def inQ_def opt_pred_def - opt_map_def fun_upd_apply obj_at'_def queue_end_valid_def - split: if_splits option.splits; - auto) - \ \tcbPtr is in the middle of the ready queue\ - by (auto simp: valid_sched_pointers_def inQ_def opt_pred_def opt_map_def fun_upd_apply - obj_at'_def - split: if_splits option.splits) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: valid_sched_pointers_def obj_at'_def opt_map_red opt_pred_def) + done -lemma tcbQueueRemove_sym_heap_sched_pointers: - "\\s. sym_heap_sched_pointers s - \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ tcbPtr \ set ts)\ - tcbQueueRemove q tcbPtr - \\_. sym_heap_sched_pointers\" +lemma tcbQueueRemove_tcbSchedPrev_tcbSchedNext_None[wp]: + "\\\ + tcbQueueRemove q t + \\_ s. obj_at' (\tcb. tcbSchedPrev tcb = None \ tcbSchedNext tcb = None) t s\" + apply (clarsimp simp: tcbQueueRemove_def) + apply (wpsimp wp: threadSet_wp getTCB_wp) + by (force dest!: heap_ls_last_None + simp: list_queue_relation_def prev_queue_head_def queue_end_valid_def + obj_at'_def opt_map_def ps_clear_def gen_objBits_simps) + +lemma tcbQueueRemove_not_sched_linked[wp]: + "\\\ tcbQueueRemove q t \\_ s. \ is_sched_linked t s\" + apply (rule hoare_strengthen_post[OF tcbQueueRemove_tcbSchedPrev_tcbSchedNext_None]) + apply (clarsimp simp: obj_at'_def opt_map_def) + done + +lemma tcbSchedDequeue_valid_sched_pointers[wp]: + "tcbSchedDequeue tcbPtr \valid_sched_pointers\" + unfolding tcbSchedDequeue_def + apply (wpsimp wp: tcbQueued_False_valid_sched_pointers + tcbQueueRemove_valid_sched_pointers threadGet_wp) + apply (clarsimp simp: valid_sched_pointers_def) + done + +lemma tcbQueueRemove_sym_heap_sched_pointers[wp]: + "\\\ tcbQueueRemove q tcbPtr \\_. sym_heap_sched_pointers\" supply heap_path_append[simp del] apply (clarsimp simp: tcbQueueRemove_def) apply (wpsimp wp: threadSet_wp getTCB_wp) - apply (rename_tac tcb ts) + apply (rename_tac ts tcb) \ \tcbPtr is the head of q, which is not a singleton\ apply (rule conjI) @@ -5229,35 +5622,64 @@ lemma tcbQueueRemove_sym_heap_sched_pointers: apply fastforce apply (fastforce simp: opt_map_def obj_at'_def) apply (fastforce simp: opt_map_def obj_at'_def) - apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def split: if_splits) - done + by (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def split: if_splits) lemma tcbQueuePrepend_sym_heap_sched_pointers: - "\\s. sym_heap_sched_pointers s - \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ tcbPtr \ set ts) - \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + "\\s. sym_heap_sched_pointers s \ \ is_sched_linked tcbPtr s\ tcbQueuePrepend q tcbPtr \\_. sym_heap_sched_pointers\" supply if_split[split del] - apply (clarsimp simp: tcbQueuePrepend_def) + apply (clarsimp simp: tcbQueuePrepend_def bind_if_distribR) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (rule hoare_if) + \ \q was originally empty\ + apply (wpsimp wp: threadSet_wp) + \ \q was not originally empty\ apply (wpsimp wp: threadSet_wp) - apply (prop_tac "tcbPtr \ the (tcbQueueHead q)") - apply (case_tac "ts = []"; - fastforce dest: heap_path_head simp: list_queue_relation_def tcbQueueEmpty_def) + apply (drule obj_at'_prop)+ + apply (clarsimp simp: list_queue_relation_def prev_queue_head_def tcbQueueEmpty_def) + apply (clarsimp split: if_splits) + apply (fastforce dest: sym_heap_connect) apply (drule_tac a=tcbPtr and b="the (tcbQueueHead q)" in sym_heap_connect) apply assumption apply (clarsimp simp: list_queue_relation_def prev_queue_head_def tcbQueueEmpty_def) - apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def tcbQueueEmpty_def) + apply (fastforce simp: fun_upd_swap opt_map_red opt_map_upd_triv) + done + +lemma tcbQueueAppend_sym_heap_sched_pointers: + "\\s. sym_heap_sched_pointers s \ \ is_sched_linked tcbPtr s\ + tcbQueueAppend q tcbPtr + \\_. sym_heap_sched_pointers\" + supply if_split[split del] + apply (clarsimp simp: tcbQueueAppend_def bind_if_distribR) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (rule hoare_if) + \ \q was originally empty\ + apply (wpsimp wp: threadSet_wp) + \ \q was not originally empty\ + apply (wpsimp wp: threadSet_wp) + apply (drule obj_at'_prop)+ + apply (clarsimp simp: tcbQueueEmpty_def list_queue_relation_def queue_end_valid_def obj_at'_def + split: if_splits) + apply (drule_tac a="last ts" and b=tcbPtr in sym_heap_connect) + apply (fastforce dest: heap_ls_last_None) + apply fastforce + apply fastforce + apply (drule_tac a="last ts" and b=tcbPtr in sym_heap_connect) + apply (fastforce dest: heap_ls_last_None) + apply fastforce + apply (simp add: opt_map_red tcbQueueEmpty_def) + apply (subst fun_upd_swap, simp) + apply (fastforce simp: opt_map_red opt_map_upd_triv) done lemma tcbQueueInsert_sym_heap_sched_pointers: - "\\s. sym_heap_sched_pointers s - \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ + "\\s. \ is_sched_linked tcbPtr s\ tcbQueueInsert tcbPtr afterPtr \\_. sym_heap_sched_pointers\" apply (clarsimp simp: tcbQueueInsert_def) \ \forwards step in order to name beforePtr below\ + apply (rule bind_wp[OF _ stateAssert_sp])+ apply (rule bind_wp[OF _ getObject_tcb_sp]) apply (rule bind_wp[OF _ assert_sp]) apply (rule hoare_ex_pre_conj[simplified conj_commute], rename_tac beforePtr) @@ -5274,36 +5696,13 @@ lemma tcbQueueInsert_sym_heap_sched_pointers: simp: fun_upd_swap opt_map_red opt_map_upd_triv obj_at'_def) done -lemma tcbQueueAppend_sym_heap_sched_pointers: - "\\s. sym_heap_sched_pointers s - \ (\ts. list_queue_relation ts q (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ tcbPtr \ set ts) - \ tcbSchedNexts_of s tcbPtr = None \ tcbSchedPrevs_of s tcbPtr = None\ - tcbQueueAppend q tcbPtr - \\_. sym_heap_sched_pointers\" - supply if_split[split del] - apply (clarsimp simp: tcbQueueAppend_def) - apply (wpsimp wp: threadSet_wp) - apply (clarsimp simp: tcbQueueEmpty_def list_queue_relation_def queue_end_valid_def obj_at'_def - split: if_splits) - apply fastforce - apply (drule_tac a="last ts" and b=tcbPtr in sym_heap_connect) - apply (fastforce dest: heap_ls_last_None) - apply assumption - apply (simp add: opt_map_red tcbQueueEmpty_def) - apply (subst fun_upd_swap, simp) - apply (fastforce simp: opt_map_red opt_map_upd_triv) - done - lemma tcbInReleaseQueue_update_sym_heap_sched_pointers[wp]: "threadSet (tcbInReleaseQueue_update f) tcbPtr \sym_heap_sched_pointers\" - by (rule sym_heap_sched_pointers_lift; - wpsimp wp: threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of) + by (rule sym_heap_sched_pointers_lift; wpsimp wp: threadSet_field_inv) lemma tcbQueued_update_sym_heap_sched_pointers[wp]: "threadSet (tcbQueued_update f) tcbPtr \sym_heap_sched_pointers\" - by (rule sym_heap_sched_pointers_lift; - wpsimp wp: threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of) + by (rule sym_heap_sched_pointers_lift; wpsimp wp: threadSet_field_inv) lemma tcbSchedEnqueue_sym_heap_sched_pointers[wp]: "\sym_heap_sched_pointers and valid_sched_pointers\ @@ -5311,13 +5710,11 @@ lemma tcbSchedEnqueue_sym_heap_sched_pointers[wp]: \\_. sym_heap_sched_pointers\" unfolding tcbSchedEnqueue_def apply (wpsimp wp: tcbQueuePrepend_sym_heap_sched_pointers threadGet_wp threadSet_sched_pointers - simp: addToBitmap_def bitmap_fun_defs | wps)+ - apply (normalise_obj_at', rename_tac tcb) - apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - by (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of - simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) + simp: addToBitmap_def bitmap_fun_defs) + apply (frule runnable'_not_inIPCQueueThreadState) + apply (fastforce dest!: valid_sched_pointersD[where t=tcbPtr] + simp: opt_pred_def opt_map_def obj_at'_def) + done lemma tcbSchedAppend_sym_heap_sched_pointers[wp]: "\sym_heap_sched_pointers and valid_sched_pointers\ @@ -5326,28 +5723,40 @@ lemma tcbSchedAppend_sym_heap_sched_pointers[wp]: unfolding tcbSchedAppend_def apply (wpsimp wp: tcbQueueAppend_sym_heap_sched_pointers threadGet_wp threadSet_sched_pointers simp: addToBitmap_def bitmap_fun_defs) - apply (normalise_obj_at', rename_tac tcb) - apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def) - apply (drule_tac x="tcbDomain tcb" in spec) - apply (drule_tac x="tcbPriority tcb" in spec) - by (fastforce dest!: spec[where x=tcbPtr] inQ_implies_tcbQueueds_of - simp: valid_sched_pointers_def opt_pred_def opt_map_def obj_at'_def) - -lemma tcbSchedDequeue_sym_heap_sched_pointers[wp]: - "\sym_heap_sched_pointers and valid_sched_pointers\ - tcbSchedDequeue tcbPtr - \\_. sym_heap_sched_pointers\" - unfolding tcbSchedDequeue_def - apply (wpsimp wp: tcbQueueRemove_sym_heap_sched_pointers threadGet_wp threadSet_sched_pointers - simp: bitmap_fun_defs - | wps)+ - by (fastforce simp: ready_queue_relation_def ksReadyQueues_asrt_def inQ_def opt_pred_def - opt_map_def obj_at'_def) + apply (frule runnable'_not_inIPCQueueThreadState) + apply (fastforce dest!: valid_sched_pointersD[where t=tcbPtr] + simp: opt_pred_def opt_map_def obj_at'_def) + done -crunch setThreadState +crunch tcbSchedDequeue + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + (wp: tcbQueueRemove_sym_heap_sched_pointers crunch_wps ignore: threadSet simp: crunch_simps) + +crunch scheduleTCB for valid_sched_pointers[wp]: valid_sched_pointers and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers - (simp: crunch_simps wp: crunch_wps threadSet_valid_sched_pointers threadSet_sched_pointers) + (simp: crunch_simps wp: crunch_wps) + +lemma tcbState_update_valid_sched_pointers: + "\\s. valid_sched_pointers s + \ (is_sched_linked t s \ (inIPCQueueThreadState |< tcbStates_of' s) t + \ inIPCQueueThreadState st)\ + threadSet (tcbState_update (\_. st)) t + \\_. valid_sched_pointers\" + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: valid_sched_pointers_def) + apply (intro conjI impI allI; + clarsimp dest!: spec[where x=t] simp: obj_at'_def opt_pred_def opt_map_def) + done + +lemma setThreadState_valid_sched_pointers: + "\\s. valid_sched_pointers s + \ (is_sched_linked t s \ (inIPCQueueThreadState |< tcbStates_of' s) t + \ inIPCQueueThreadState st)\ + setThreadState st t + \\_. valid_sched_pointers\" + unfolding setThreadState_def + by (wpsimp wp: tcbState_update_valid_sched_pointers) lemma sts_sym_refs': "\\s. sym_refs (state_refs_of' s) @@ -5516,7 +5925,7 @@ lemma getCurSc_corres[corres]: apply (rule corres_gets_trivial) by (clarsimp simp: state_relation_def) -crunch getTCBReadyTime, scActive +crunch scActive for inv[wp]: P (wp: crunch_wps) @@ -5535,50 +5944,39 @@ lemma thread_set_empty_tcb_sched_context_weaker_valid_sched_action[wp]: split: option.splits Structures_A.kernel_object.splits) done -locale TcbAcc_R_3 = TcbAcc_R_2 + - assumes sts_iflive'[wp]: - "\st t. - \\s. if_live_then_nonz_cap' s - \ (st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) - \ pspace_aligned' s \ pspace_distinct' s\ - setThreadState st t - \\rv. if_live_then_nonz_cap'\" -begin - -lemma sts_invs_minor': +lemma (in TcbAcc_R_2) sts_invs_minor': "\invs' - and st_tcb_at' (\st'. (st \ Inactive \ \ idle' st \ st' \ Inactive \ \ idle' st') - \ (\rptr. st' = BlockedOnReply rptr \ st = BlockedOnReply rptr)) t - and valid_tcb_state' st\ + and st_tcb_at' (\st'. (\rptr. st' = BlockedOnReply rptr \ st = BlockedOnReply rptr) + \ \ inIPCQueueThreadState st') t\ setThreadState st t \\_. invs'\" apply (simp add: invs'_def valid_dom_schedule'_def) - apply (wpsimp wp: sts_sch_act' valid_irq_node_lift irqs_masked_lift setThreadState_ct_not_inQ + apply (wpsimp wp: valid_irq_node_lift irqs_masked_lift + setThreadState_valid_sched_pointers + setThreadState_sym_heap_sched_pointers simp: cteCaps_of_def o_def pred_tcb_at'_eq_commute) apply (intro conjI impI; fastforce?) - apply clarsimp apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (erule if_live_then_nonz_capE') - apply (clarsimp simp: pred_tcb_at'_def ko_wp_at'_def obj_at'_def live'_def) + apply (clarsimp simp: pred_tcb_at'_def ko_wp_at'_def obj_at'_def opt_pred_def opt_map_def) done -lemma sts_invs': - "\(\s. st \ Inactive \ \ idle' st \ ex_nonz_cap_to' t s) - and (\s. \rptr. st_tcb_at' ((=) (BlockedOnReply (Some rptr))) t s \ (is_reply_linked rptr s) \ st = BlockedOnReply (Some rptr)) - and tcb_at' t - and valid_tcb_state' st - and invs'\ +lemma (in TcbAcc_R_2) sts_invs': + "\(\s. \rptr. st_tcb_at' ((=) (BlockedOnReply (Some rptr))) t s + \ (is_reply_linked rptr s) \ st = BlockedOnReply (Some rptr)) + and (\s. is_sched_linked t s \ (inIPCQueueThreadState |< tcbStates_of' s) t + \ inIPCQueueThreadState st) + and tcb_at' t + and invs'\ setThreadState st t \\rv. invs'\" apply (simp add: invs'_def valid_dom_schedule'_def) - apply (wpsimp wp: sts_sch_act' valid_irq_node_lift irqs_masked_lift setThreadState_ct_not_inQ + apply (wpsimp wp: valid_irq_node_lift irqs_masked_lift + setThreadState_valid_sched_pointers setThreadState_sym_heap_sched_pointers simp: cteCaps_of_def o_def) apply (clarsimp simp: valid_pspace'_def) apply fast done -end - lemma setReleaseQueue_ksReleaseQueue[wp]: "\\_. P qs\ setReleaseQueue qs \\_ s. P (ksReleaseQueue s)\" by (wpsimp simp: setReleaseQueue_def) @@ -5596,19 +5994,10 @@ crunch tcbReleaseRemove, tcbQueueRemove, tcbReleaseEnqueue for valid_irq_handlers'[wp]: valid_irq_handlers' (wp: valid_irq_handlers_lift'') -crunch tcbReleaseRemove, tcbQueueRemove, tcbReleaseEnqueue - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - (wp: crunch_wps threadSet_ct_idle_or_in_cur_domain') - crunch tcbReleaseRemove, tcbQueueRemove, tcbReleaseEnqueue for if_unsafe_then_cap'[wp]: if_unsafe_then_cap' (wp: crunch_wps threadSet_ifunsafe'T simp: update_tcb_cte_cases) -crunch tcbReleaseRemove, tcbQueueRemove, tcbReleaseEnqueue - for ctes_of[wp]: "\s. P (ctes_of s)" - and valid_idle'[wp]: valid_idle' - (simp: crunch_simps wp: crunch_wps threadSet_idle') - crunch setReleaseQueue, tcbQueueRemove, setReprogramTimer for valid_objs'[wp]: valid_objs' (wp: crunch_wps hoare_vcg_all_lift simp: crunch_simps) @@ -5623,15 +6012,12 @@ crunch tcbReleaseRemove, tcbQueueRemove, tcbReleaseEnqueue crunch tcbReleaseRemove, tcbQueueRemove, tcbReleaseEnqueue for tcbDomain[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" - and tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" - and sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - (wp: crunch_wps threadSet_obj_at'_no_state rule: tcb_in_cur_domain'_lift sch_act_wf_lift) + (wp: crunch_wps threadSet_obj_at'_no_state) end (* TcbAcc_R *) crunch setReleaseQueue - for if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - and obj_at'[wp]: "\s. Q (obj_at' P ptr s)" + for obj_at'[wp]: "\s. Q (obj_at' P ptr s)" lemma getReleaseQueue_sp: "\P\ getReleaseQueue \\rv s. P s \ rv = ksReleaseQueue s\" @@ -5639,25 +6025,14 @@ lemma getReleaseQueue_sp: crunch setReprogramTimer for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" - and ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' tcbPtr" - and if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - (simp_del: comp_apply) - -lemma (in TcbAcc_R_2) tcbReleaseRemove_if_live_then_nonz_cap'[wp]: - "\if_live_then_nonz_cap' and valid_objs' and sym_heap_sched_pointers\ - tcbReleaseRemove tcbPtr - \\_. if_live_then_nonz_cap'\" - unfolding tcbReleaseRemove_def setReleaseQueue_def - apply (wpsimp wp: tcbQueueRemove_if_live_then_nonz_cap' inReleaseQueue_wp threadSet_valid_objs') - by (fastforce elim: if_live_then_nonz_capE' simp: obj_at'_def ko_wp_at'_def live'_def) lemma tcbSchedPrev_update_tcbQueueds_of[wp]: "threadSet (tcbSchedPrev_update f) tcbPtr \\s. P (tcbQueued |< tcbs_of' s)\" - by (wpsimp wp: threadSet_tcbQueued) + by (wpsimp wp: threadSet_field_opt_pred) lemma tcbSchedNext_update_tcbQueueds_of[wp]: "threadSet (tcbSchedNext_update f) tcbPtr \\s. P (tcbQueued |< tcbs_of' s)\" - by (wpsimp wp: threadSet_tcbQueued) + by (wpsimp wp: threadSet_field_opt_pred) lemma setReprogramTimer_ready_or_release'[wp]: "setReprogramTimer reprogramTimer \ready_or_release'\" @@ -5667,15 +6042,14 @@ lemma setReprogramTimer_ready_or_release'[wp]: done lemma tcbQueueRemove_no_fail: - "no_fail (\s. tcb_at' tcbPtr s - \ (\ts. list_queue_relation ts queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) - \ tcbPtr \ set ts) + "no_fail (\s. (\ts. list_queue_relation ts queue (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + \ (\t \ set ts. tcb_at' t s \ (t \ tcbPtr \ sched_flag_set s t)) + \ tcbPtr \ set ts) \ sym_heap_sched_pointers s \ valid_objs' s) (tcbQueueRemove queue tcbPtr)" unfolding tcbQueueRemove_def - apply (wpsimp wp: getTCB_wp) - apply normalise_obj_at' - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') + apply (wpsimp wp: getTCB_wp no_fail_stateAssert) + apply (frule (2) list_queue_relation_neighbour_in_set) apply (clarsimp simp: list_queue_relation_def) apply (prop_tac "tcbQueueHead queue \ Some tcbPtr \ tcbSchedPrevs_of s tcbPtr \ None") apply (rule impI) @@ -5684,18 +6058,13 @@ lemma tcbQueueRemove_no_fail: apply (fastforce dest: heap_path_head) apply fastforce apply (fastforce simp: opt_map_def obj_at'_def valid_tcb'_def valid_bound_tcb'_def) - apply (fastforce dest!: not_last_next_not_None[where p=tcbPtr] - simp: queue_end_valid_def opt_map_def obj_at'_def valid_tcb'_def) + apply (force dest!: not_last_next_not_None[where p=tcbPtr] + simp: queue_end_valid_def opt_map_def obj_at'_def valid_tcb'_def) done crunch removeFromBitmap for (no_fail) no_fail[wp] -crunch removeFromBitmap - for release_queue_relation[wp]: "release_queue_relation s" - and ready_queues_relation[wp]: "ready_queues_relation s" - (simp: bitmap_fun_defs release_queue_relation_def ready_queues_relation_def) - lemma ready_or_release'_inQ: "ready_or_release' s \ \t. \ ((inQ domain prio |< tcbs_of' s) t \ (tcbInReleaseQueue |< tcbs_of' s) t)" @@ -5703,29 +6072,55 @@ lemma ready_or_release'_inQ: context TcbAcc_R_2 begin +lemma set_tcb_queue_not_queued_rewrite: + "monadic_rewrite False True (\s. ready_queues s = queues \ tcbPtr \ set (queues d p)) + (set_tcb_queue d p (tcb_sched_dequeue tcbPtr (queues d p))) (return ())" + unfolding set_tcb_queue_def + apply (rule monadic_rewrite_guard_imp) + apply (rule monadic_rewrite_modify_noop) + apply (rename_tac s) + apply (case_tac s; fastforce) + done + +lemma setQueue_gets_rewrite: + "(\P. h \\s. P (ksReadyQueues s)\) \ + monadic_rewrite F E \ + (do queue \ f; + setQueue d p queue; + h; + g queue od) + (do queue \ f; + setQueue d p queue; + h; + queue' \ gets (\s. ksReadyQueues s (d, p)); + g queue' + od)" + apply (intro monadic_rewrite_bind_tail) + apply simp + apply (intro monadic_rewrite_bind_tail) + apply monadic_rewrite_symb_exec_r + apply (rule monadic_rewrite_guard_arg_cong) + apply assumption + apply (wpsimp simp: setQueue_def | rule hoare_lift_Pf2[where f=ksReadyQueues])+ + done + lemma tcbSchedDequeue_corres: "tcb_ptr = tcbPtr \ corres dc - (in_correct_ready_q and ready_qs_distinct and ready_or_release and tcb_at tcb_ptr - and pspace_aligned and pspace_distinct) + (ep_queues_blocked and ntfn_queues_blocked + and in_correct_ready_q and ready_qs_distinct and ready_queues_runnable + and ready_or_release and tcb_at tcb_ptr and pspace_aligned and pspace_distinct) (sym_heap_sched_pointers and valid_objs') (tcb_sched_action tcb_sched_dequeue tcb_ptr) (tcbSchedDequeue tcbPtr)" - supply if_split[split del] + supply if_split[split del] bind_return[simp del] return_bind[simp del] apply (rule_tac Q'="tcb_at' tcbPtr" in corres_cross_add_guard) apply (fastforce intro!: tcb_at_cross simp: vs_all_heap_simps obj_at_def is_tcb_def) - apply (rule_tac Q'=pspace_aligned' in corres_cross_add_guard) - apply (fastforce dest: pspace_aligned_cross) - apply (rule_tac Q'=pspace_distinct' in corres_cross_add_guard) - apply (fastforce dest: pspace_distinct_cross) - apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) - apply (rule monadic_rewrite_guard_imp[OF tcb_sched_dequeue_monadic_rewrite]) - apply (clarsimp simp: ready_qs_distinct_def) - apply (clarsimp simp: tcb_sched_dequeue'_def get_tcb_queue_def tcbSchedDequeue_def getQueue_def - unless_def when_def) + apply (clarsimp simp: tcb_sched_action_def get_tcb_queue_def + tcbSchedDequeue_def getQueue_def unless_def) apply (rule corres_symb_exec_l[OF _ _ thread_get_sp]; wpsimp?) - apply (rename_tac dom) + apply (rename_tac domain) apply (rule corres_symb_exec_l[OF _ _ thread_get_sp]; wpsimp?) - apply (rename_tac prio) + apply (rename_tac priority) apply (rule corres_symb_exec_l[OF _ _ gets_sp]; (solves wpsimp)?) apply (rule corres_stateAssert_add_assertion[rotated]) apply (fastforce intro: ready_or_release_cross) @@ -5733,130 +6128,188 @@ lemma tcbSchedDequeue_corres: apply (fastforce intro: ksReadyQueues_asrt_cross) apply (rule corres_stateAssert_ignore, fastforce) apply (rule corres_symb_exec_r[OF _ threadGet_sp]; (solves wpsimp)?) - apply (rule corres_if_strong'; fastforce?) - apply (intro iffI) - apply (frule state_relation_ready_queues_relation) - apply (fastforce dest!: in_ready_q_tcbQueued_eq[THEN iffD1] - simp: obj_at'_def obj_at_def in_ready_q_def opt_pred_def opt_map_def) - apply (frule state_relation_ready_queues_relation) - apply (frule in_ready_q_tcbQueued_eq[THEN iffD2, where t1=tcb_ptr]) - apply (fastforce simp: obj_at'_def opt_pred_def opt_map_def) - apply (fastforce simp: in_correct_ready_q_def vs_all_heap_simps obj_at_def in_ready_q_def) + apply (rename_tac queued) + apply (rule_tac Q="\s. queued = in_ready_q tcbPtr s" in corres_cross_add_abs_guard) + apply (fastforce dest: state_relation_ready_queues_relation in_ready_q_tcbQueued_eq[where t=tcbPtr] + simp: opt_pred_def opt_map_red obj_at'_def) + apply (case_tac "\ queued"; clarsimp) + apply (clarsimp simp: return_bind) + apply (rule monadic_rewrite_corres_l[where P=P and Q=P for P, simplified]) + apply (rule monadic_rewrite_guard_imp[OF set_tcb_queue_not_queued_rewrite]) + apply (clarsimp simp: not_queued_def) + apply clarsimp apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) - apply (rename_tac dom') + apply (rename_tac domain') apply (rule corres_symb_exec_r[OF _ threadGet_sp]; wpsimp?) - apply (rename_tac prio') - - apply (rule_tac F="dom' = dom \ prio' = prio" in corres_req) + apply (rename_tac priority') + apply (rule_tac F="domain' = domain \ priority' = priority" in corres_req) apply (fastforce dest: pspace_relation_tcb_domain_priority state_relation_pspace_relation simp: obj_at_def obj_at'_def) apply clarsimp - - apply (rule corres_from_valid_det) - apply (fastforce intro: det_wp_modify det_wp_pre simp: set_tcb_queue_def) + apply (rule corres_symb_exec_r[OF _ gets_sp]; wpsimp?) + apply (rule monadic_rewrite_corres_r[where P'=P' and Q=P' for P', simplified]) + apply (subst bind_dummy_ret_val)+ + apply (rule monadic_rewrite_guard_imp) + apply (rule setQueue_gets_rewrite) + apply wpsimp + apply wpsimp + apply (rule corres_underlying_from_rcorres) apply ((wpsimp wp: tcbQueueRemove_no_fail hoare_vcg_ex_lift - threadSet_sched_pointers threadSet_valid_objs' + threadSet_sched_pointers threadSet_valid_objs' hoare_vcg_ball_lift + hoare_vcg_const_imp_lift hoare_disjI1 threadSet_opt_pred_other | wps)+)[1] - apply (fastforce dest: state_relation_ready_queues_relation - simp: ex_abs_def ready_queues_relation_def ready_queue_relation_def Let_def) - apply (clarsimp simp: state_relation_def) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \frule singleton_eqD, frule set_tcb_queue_projs_inv, wpsimp simp: swp_def\)?) - - apply (find_goal \match conclusion in "\_\ _ \\_. release_queue_relation t\" for t \ \-\\) - apply (frule_tac d=dom and p=prio in ready_or_release_disjoint) - apply (drule set_tcb_queue_projs_inv) - apply (wpsimp wp: tcbQueueRemove_list_queue_relation_other hoare_vcg_ex_lift - threadSet_sched_pointers - simp: release_queue_relation_def - | wps)+ - apply (rule_tac x="ready_queues s (tcbDomain tcba) (tcbPriority tcb)" in exI) - apply (auto simp: ready_queues_relation_def ready_queue_relation_def Let_def)[1] - - \ \ready_queues_relation\ - apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) - apply (intro hoare_allI) - apply (drule singleton_eqD) - apply (drule set_tcb_queue_new_state) - apply (intro hoare_vcg_conj_lift_pre_fix) - - apply (find_goal \match conclusion in "\_\ _ \\_ s. maxDomain < d \ _\" for d \ \-\\) - apply (wpsimp wp: threadSet_wp getTCB_wp simp: setQueue_def tcbQueueRemove_def) - apply (force simp: obj_at_def tcbQueueEmpty_def split: if_split) - - apply (find_goal \match conclusion in "\_\ _ \\_ s. maxPriority < d \ _\" for d \ \-\\) - apply (wpsimp wp: threadSet_wp getTCB_wp simp: setQueue_def tcbQueueRemove_def) - apply (force simp: obj_at_def tcbQueueEmpty_def split: if_split) - - apply (find_goal \match conclusion in "\_\ _ \\_ s. list_queue_relation _ _ _ _ \" \ \-\\) - apply (case_tac "d \ dom \ p \ prio") - apply (clarsimp simp: obj_at_def obj_at'_def) - apply (wpsimp wp: tcbQueueRemove_list_queue_relation_other setQueue_ksReadyQueues_other - threadSet_sched_pointers hoare_vcg_ex_lift - | wps)+ - apply (frule (2) pspace_relation_tcb_domain_priority[where t=tcbPtr]) - apply (intro conjI) - apply fastforce - apply (rule_tac x="ready_queues s (tcb_domain tcb) (tcb_priority tcb)" in exI) - apply (auto simp: ready_queues_disjoint split: if_splits)[1] - apply fastforce - apply ((wpsimp wp: tcbQueueRemove_list_queue_relation threadSet_sched_pointers | wps)+)[1] - - apply (rule hoare_allI, rename_tac t') - apply (case_tac "d \ dom \ p \ prio") - apply (wpsimp wp: tcbQueued_update_inQ_other hoare_vcg_disj_lift hoare_drop_imp - simp: opt_pred_disj[simplified pred_disj_def, symmetric] - simp_del: disj_not1 fun_upd_apply) - apply (clarsimp simp: opt_map_def opt_pred_def obj_at'_def split: if_splits) + apply (clarsimp simp: ex_abs_def obj_at_def in_ready_q_def) + apply normalise_obj_at' + apply (rename_tac s tcb d p tcb') + apply (rule_tac x="ready_queues s d p" in exI) + apply (rule conjI) + apply (force dest!: in_correct_ready_qD state_relation_ready_queues_relation + simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply clarsimp + apply (rule conjI) + subgoal by (force intro!: tcb_at_cross simp: ready_queues_runnable_def) + apply (force intro: in_ready_q_tcbQueued_eq[THEN iffD1] simp: in_ready_q_def) + \ \break off the call to removeFromBitmap\ + apply (rule rcorres_add_return_l) + apply (rule rcorres_add_return_l) + apply (subst bind_assoc[symmetric]) apply clarsimp - apply (subst set_tcb_queue_remove) - apply (clarsimp simp: ready_qs_distinct_def) - apply (case_tac "t' = tcbPtr") - apply (wpsimp wp: tcbQueued_False_makes_not_inQ) - apply (wpsimp wp: threadSet_opt_pred_other) - done + apply (subst bind_assoc[symmetric]) + apply (rule rcorres_split) + apply clarsimp + apply (rule rcorres_from_corres[where P=\ and P'=\ and r=dc, simplified]) + apply (rule corres_symb_exec_r[OF _ gets_sp]; (solves wpsimp)?) + apply (clarsimp simp: when_def split: if_splits) + apply (corres corres: removeFromBitmap_corres_noop) + apply (rule rcorres_add_return_l) + \ \set the ready queue\ + apply (clarsimp simp: state_relation_def pspace_relation_heap_pspace_relation + ghost_relation_heap_ghost_relation heap_pspace_relation_def) + apply (rcorres_conj_lift \fastforce\ simp: set_tcb_queue_def wp: threadSet_field_inv)+ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ep_queues_relation\ + apply (simp only: ep_queues_relation_def) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation + tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply normalise_obj_at' + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def obj_at_def + in_ready_q_def) + apply (metis in_correct_ready_qD ep_queues_ready_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ntfn_queues_relation\ + apply (simp only: ntfn_queues_relation_def) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation + tcbQueueRemove_rcorres_other rcorres_op_lifts) + apply normalise_obj_at' + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def obj_at_def + in_ready_q_def) + apply (metis in_correct_ready_qD ntfn_queues_ready_queues_disjoint) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \ready_queues_relation\ + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac d p) + apply (case_tac "d \ domain \ p \ priority") + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule_tac p="\s. ready_queues s d p" in rcorres_lift_abs) + apply (rule_tac p="\s'. ksReadyQueues s' (d, p)" in rcorres_lift_conc) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation tcbQueueRemove_rcorres_other) + apply normalise_obj_at' + apply (clarsimp simp: obj_at_def in_ready_q_def) + apply (metis in_correct_ready_qD ready_queues_disjoint) + apply (wpsimp wp: setQueue_ksReadyQueues_other) + apply (wpsimp wp: set_tcb_queue_ready_queues_other) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac t) + apply (rule_tac p="\s. t \ set (ready_queues s d p)" in rcorres_lift_abs) + apply (rule_tac p="\s'. (inQ d p |< tcbs_of' s') t" in rcorres_lift_conc) + apply (rule rcorres_prop_fwd; wpsimp) + apply (wpsimp wp: tcbQueued_update_inQ_other hoare_vcg_disj_lift + simp: opt_pred_disj[simplified pred_disj_def, symmetric] simp_del: disj_not1) + apply (clarsimp simp: opt_pred_def opt_map_red obj_at'_def) + apply (wpsimp wp: set_tcb_queue_ready_queues_other) + apply (rule rcorres_lift_conc_only; wpsimp wp: setQueue_ksReadyQueues_other) + \ \d = domain \ p = priority\ + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rcorres rcorres: rcorres_threadSet_ready_queues_list_queue_relation + tcbQueueRemove_rcorres) + apply (clarsimp simp: obj_at_def in_ready_q_def tcb_sched_dequeue_def removeAll_filter_not_eq) + apply (metis in_correct_ready_qD) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (intro rcorres_allI_fwd; (solves wpsimp)?) + apply (rename_tac t) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (case_tac "t \ tcbPtr") + apply (wpsimp wp: threadSet_opt_pred_other) + apply (clarsimp simp: set_tcb_queue_def tcb_sched_dequeue_def in_monad) + apply (clarsimp simp: set_tcb_queue_def tcb_sched_dequeue_def in_monad) + apply (wpsimp wp: tcbQueued_False_makes_not_inQ) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule rcorres_imp_lift_fwd; (solves wpsimp)?) + apply (rule rcorres_prop_fwd; wpsimp) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: setQueue_ksReadyQueues_other) + apply (force dest!: valid_objs'_valid_tcbs' valid_tcbs'_maxDomain[where t=tcbPtr] + simp: obj_at'_def) + apply (rule rcorres_imp_lift_fwd; (solves wpsimp)?) + apply (rule rcorres_prop_fwd; wpsimp) + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: setQueue_ksReadyQueues_other) + apply (force dest!: valid_objs'_valid_tcbs' valid_tcbs'_maxPriority[where t=tcbPtr] + simp: obj_at'_def) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + \ \release_queue_relation\ + apply (clarsimp simp: release_queue_relation_def) + apply (rule rcorres_conj_lift_fwd; (solves wpsimp)?) + apply (rule_tac p=release_queue in rcorres_lift_abs) + apply (rule_tac p=ksReleaseQueue in rcorres_lift_conc) + apply (rcorres rcorres: rcorres_threadSet_list_queue_relation tcbQueueRemove_rcorres_other) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def obj_at_def + in_ready_q_def) + apply (metis in_correct_ready_qD Int_commute ready_or_release_disjoint) + apply wpsimp + apply wpsimp + apply (rule rcorres_from_valid_det; (solves wpsimp)?) + apply (wpsimp wp: hoare_vcg_all_lift) + apply (clarsimp simp: set_tcb_queue_def in_monad) + by (rcorres_conj_lift \fastforce\ simp: set_tcb_queue_def wp: threadSet_field_inv)+ end (* TcbAcc_R_2 *) lemma tcbReleaseRemove_sym_heap_sched_pointers[wp]: "tcbReleaseRemove tcbPtr \sym_heap_sched_pointers\" unfolding tcbReleaseRemove_def - apply (wpsimp wp: tcbQueueRemove_sym_heap_sched_pointers inReleaseQueue_wp - threadSet_sched_pointers - | wps)+ - by (fastforce simp: ksReleaseQueue_asrt_def opt_pred_def obj_at'_def opt_map_red) + apply (wpsimp wp: inReleaseQueue_wp) + apply (fastforce simp: obj_at'_def) + done crunch setReprogramTimer - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - and valid_mdb'[wp]: valid_mdb' - and ct_not_inQ[wp]: ct_not_inQ - and ksReleaseQueue_asrt[wp]: ksReleaseQueue_asrt - (simp: valid_mdb'_def ksReleaseQueue_asrt_def) + for valid_mdb'[wp]: valid_mdb' + (simp: valid_mdb'_def) lemma tcbSchedNext_update_valid_mdb'[wp]: - "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedNext_update f) tcbPtr \\_. valid_mdb'\" + "threadSet (tcbSchedNext_update f) tcbPtr \valid_mdb'\" apply (wpsimp wp: threadSet_mdb') - apply (fastforce simp: obj_at'_def valid_tcb'_def update_tcb_cte_cases) + apply (clarsimp simp: obj_at'_def update_tcb_cte_cases) done lemma tcbSchedPrev_update_valid_mdb'[wp]: - "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbSchedPrev_update f) tcbPtr \\_. valid_mdb'\" + "threadSet (tcbSchedPrev_update f) tcbPtr \valid_mdb'\" apply (wpsimp wp: threadSet_mdb') - apply (fastforce simp: obj_at'_def valid_tcb'_def update_tcb_cte_cases) + apply (clarsimp simp: obj_at'_def update_tcb_cte_cases) done lemma tcbInReleaseQueue_update_valid_mdb'[wp]: - "\valid_mdb' and tcb_at' tcbPtr\ threadSet (tcbInReleaseQueue_update f) tcbPtr \\_. valid_mdb'\" + "threadSet (tcbInReleaseQueue_update f) tcbPtr \valid_mdb'\" apply (wpsimp wp: threadSet_mdb') - by (fastforce simp: obj_at'_def update_tcb_cte_cases) + apply (clarsimp simp: obj_at'_def update_tcb_cte_cases) + done -lemma tcbQueueRemove_valid_mdb': - "\\s. valid_mdb' s \ valid_objs' s\ tcbQueueRemove q tcbPtr \\_. valid_mdb'\" +lemma tcbQueueRemove_valid_mdb'[wp]: + "tcbQueueRemove q tcbPtr \valid_mdb'\" unfolding tcbQueueRemove_def - apply (wpsimp wp: getTCB_wp) - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') - apply (fastforce simp: valid_tcb'_def obj_at'_def) - done + by (wpsimp wp: getTCB_wp) crunch setReleaseQueue for valid_mdb'[wp]: valid_mdb' @@ -5870,52 +6323,31 @@ lemma tcbQueued_update_valid_objs'[wp]: "threadSet (tcbQueued_update f) tcbPtr \valid_objs'\" by (wpsimp wp: threadSet_valid_objs') -lemma (in TcbAcc_R) tcbReleaseRemove_valid_mdb'[wp]: - "\valid_mdb' and valid_objs' and sym_heap_sched_pointers\ - tcbReleaseRemove tcbPtr - \\_. valid_mdb'\" +lemma tcbReleaseRemove_valid_mdb'[wp]: + "tcbReleaseRemove tcbPtr \valid_mdb'\" unfolding tcbReleaseRemove_def - apply (wpsimp simp: setReleaseQueue_def wp: tcbQueueRemove_valid_mdb' inReleaseQueue_wp) - by (fastforce simp: ksReleaseQueue_asrt_def obj_at'_def opt_map_def) + by (wpsimp wp: tcbQueueRemove_valid_mdb') crunch setReprogramTimer for obj_at'[wp]: "\s. Q (obj_at' P ptr s)" and valid_tcbs'[wp]: valid_tcbs' -lemma tcbReleaseRemove_valid_sched_pointers[wp]: - "\valid_sched_pointers and sym_heap_sched_pointers\ - tcbReleaseRemove tcbPtr +lemma tcbInReleaseQueue_False_valid_sched_pointers: + "\\s. valid_sched_pointers s \ \ is_sched_linked tcbPtr s\ + threadSet (tcbInReleaseQueue_update (\_. False)) tcbPtr \\_. valid_sched_pointers\" - supply if_split[split del] + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: valid_sched_pointers_def obj_at'_def opt_map_red opt_pred_def) + done + +lemma tcbReleaseRemove_valid_sched_pointers[wp]: + "tcbReleaseRemove tcbPtr \valid_sched_pointers\" apply (clarsimp simp: tcbReleaseRemove_def) - apply (intro bind_wp[OF _ stateAssert_sp] bind_wp[OF _ inReleaseQueue_sp]) - apply (rule hoare_when_cases, fastforce) - apply (rule bind_wp[OF _ getReleaseQueue_sp]) - apply (rule forward_inv_step_rules) - apply (wpsimp wp: hoare_vcg_ex_lift split: if_splits) - apply (wpsimp wp: threadSet_wp getTCB_wp simp: tcbQueueRemove_def setReleaseQueue_def) - apply (clarsimp simp: ksReleaseQueue_asrt_def) - apply (frule (1) list_queue_relation_neighbour_in_set[where p=tcbPtr]) - apply (clarsimp simp: opt_pred_def opt_map_def obj_at'_def split: option.splits) - apply (intro conjI impI) - \ \the release queue is the singleton containing tcbPtr\ - apply (fastforce dest: heap_ls_last_None - simp: valid_sched_pointers_def ksReleaseQueue_asrt_def - list_queue_relation_def prev_queue_head_def queue_end_valid_def - opt_pred_def opt_map_def obj_at'_def - split: if_splits) - \ \tcbPtr is the head of the release queue\ - apply (fastforce simp: valid_sched_pointers_def list_queue_relation_def prev_queue_head_def - opt_pred_def opt_map_def obj_at'_def - split: if_splits option.splits) - \ \tcbPtr is the end of the release queue\ - apply (force dest: heap_ls_last_None - simp: valid_sched_pointers_def list_queue_relation_def queue_end_valid_def - opt_pred_def opt_map_def obj_at'_def - split: if_splits option.splits) - \ \tcbPtr is in the middle of the release queue\ - by (force simp: valid_sched_pointers_def inQ_def opt_pred_def opt_map_def obj_at'_def - split: if_splits option.splits) + apply (wpsimp wp: tcbInReleaseQueue_False_valid_sched_pointers tcbQueueRemove_valid_sched_pointers + inReleaseQueue_wp) + apply normalise_obj_at' + apply (clarsimp simp: valid_sched_pointers_except_def) + done lemma tcbReleaseRemove_valid_bitmaps[wp]: "tcbReleaseRemove tcbPtr \valid_bitmaps\" @@ -5923,9 +6355,9 @@ lemma tcbReleaseRemove_valid_bitmaps[wp]: lemma (in TcbAcc_R_2) tcbReleaseRemove_invs': "tcbReleaseRemove tcbPtr \invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) - apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift - untyped_ranges_zero_lift valid_replies'_lift + apply (simp add: invs'_def valid_pspace'_def) + apply (wpsimp wp: valid_irq_node_lift irqs_masked_lift untyped_ranges_zero_lift + valid_replies'_lift simp: cteCaps_of_def o_def) done diff --git a/proof/refine/VSpace_R.thy b/proof/refine/VSpace_R.thy index 6708a257e9..06b75ce7e7 100644 --- a/proof/refine/VSpace_R.thy +++ b/proof/refine/VSpace_R.thy @@ -142,7 +142,7 @@ lemma message_info_from_data_eqv: msgLabelBits_msg_label_bits msgMaxLength_def mask_def) lemma set_mi_invs'[wp]: - "\invs' and tcb_at' t\ setMessageInfo t a \\x. invs'\" + "setMessageInfo t a \invs'\" by (simp add: setMessageInfo_def) wp lemma setMessageInfo_corres: diff --git a/spec/design/skel/KernelStateData_H.thy b/spec/design/skel/KernelStateData_H.thy index 5aae175bc7..95e470cc31 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 tcb_at'_asrt sc_at'_asrt valid_tcbs'_asrt valid_objs'_asrt invs'_asrt weak_sch_act_wf_asrt sch_act_simple_asrt priority_ordered'_asrt active_sc_at'_asrt active_tcb_at'_asrt valid_domain_list'_asrt active_sc_tcb_at'_ct_asrt ct_not_in_release_q'_asrt -#INCLUDE_HASKELL SEL4/Model/StateData.lhs NOT doMachineOp KernelState ReadyQueue ReleaseQueue ReaderM Kernel KernelR getsJust assert stateAssert readStateAssert 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 tcb_at'_asrt sc_at'_asrt valid_tcbs'_asrt valid_objs'_asrt invs'_asrt weak_sch_act_wf_asrt sch_act_simple_asrt priority_ordered'_asrt active_sc_at'_asrt active_tcb_at'_asrt valid_domain_list'_asrt active_sc_tcb_at'_ct_asrt ct_not_in_release_q'_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 insertionPoint_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 tcb_at'_asrt ep_at'_asrt sc_at'_asrt valid_tcbs'_asrt valid_objs'_asrt invs'_asrt weak_sch_act_wf_asrt sch_act_simple_asrt priority_ordered'_asrt active_sc_at'_asrt active_tcb_at'_asrt valid_domain_list'_asrt active_sc_tcb_at'_ct_asrt ct_not_in_release_q'_asrt pspace_aligned'_asrt pspace_distinct'_asrt valid_bound_ep'_asrt valid_bound_ntfn'_asrt valid_bound_tcb'_asrt valid_bound_sc'_asrt valid_bound_reply'_asrt tcbQueueAdd_asrt tcbQueueInsert_asrt tcbQueueRemove_asrt sym_heap_sched_pointers_asrt if_live_then_nonz_cap'_asrt not_sched_linked_asrt reply_object_asrt tcb_queue_head_end_valid_asrt orderedInsertBackwards_asrt +#INCLUDE_HASKELL SEL4/Model/StateData.lhs NOT doMachineOp KernelState ReadyQueue ReleaseQueue ReaderM Kernel KernelR getsJust assert stateAssert readStateAssert 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 insertionPoint_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 tcb_at'_asrt ep_at'_asrt sc_at'_asrt valid_tcbs'_asrt valid_objs'_asrt invs'_asrt weak_sch_act_wf_asrt sch_act_simple_asrt priority_ordered'_asrt active_sc_at'_asrt active_tcb_at'_asrt valid_domain_list'_asrt active_sc_tcb_at'_ct_asrt ct_not_in_release_q'_asrt pspace_aligned'_asrt pspace_distinct'_asrt valid_bound_ep'_asrt valid_bound_ntfn'_asrt valid_bound_tcb'_asrt valid_bound_sc'_asrt valid_bound_reply'_asrt tcbQueueAdd_asrt tcbQueueInsert_asrt tcbQueueRemove_asrt sym_heap_sched_pointers_asrt if_live_then_nonz_cap'_asrt not_sched_linked_asrt reply_object_asrt tcb_queue_head_end_valid_asrt orderedInsertBackwards_asrt end diff --git a/spec/haskell/src/SEL4/Kernel/Thread.lhs b/spec/haskell/src/SEL4/Kernel/Thread.lhs index 19fa2f43c4..6813bd340a 100644 --- a/spec/haskell/src/SEL4/Kernel/Thread.lhs +++ b/spec/haskell/src/SEL4/Kernel/Thread.lhs @@ -115,9 +115,9 @@ runnable; this is to prevent it being inserted in the scheduler queue. > readSchedulable :: PPtr TCB -> KernelR Bool > readSchedulable tcbPtr = do +> readStateAssert valid_tcbs'_asrt "`valid_tcbs'`" > runnable <- readRunnable tcbPtr > scPtrOpt <- threadRead tcbSchedContext tcbPtr -> readStateAssert valid_tcbs'_asrt "`valid_tcbs'`" > if scPtrOpt == Nothing > then return False > else do @@ -145,10 +145,10 @@ When a thread is suspended, either explicitly by a TCB invocation or implicitly > cancelIPC target > state <- getThreadState target > if state == Running then updateRestartPC target else return () -> setThreadState Inactive target > tcbSchedDequeue target > tcbReleaseRemove target > schedContextCancelYieldTo target +> setThreadState Inactive target \subsubsection{Restarting a Blocked Thread} @@ -489,7 +489,8 @@ Note also that the level 2 bitmap array is stored in reverse in order to get bet > curThread <- getCurThread > action <- getSchedulerAction > schedulable <- getSchedulable tcbPtr -> when (tcbPtr == curThread && action == ResumeCurrentThread && not schedulable) $ rescheduleRequired +> when (tcbPtr == curThread && action == ResumeCurrentThread && not schedulable) $ +> setSchedulerAction ChooseNewThread \subsubsection{Switching Threads} @@ -562,7 +563,6 @@ The following function is used to alter the priority of a thread. > setPriority :: PPtr TCB -> Priority -> Kernel () > setPriority tptr prio = do -> stateAssert ready_qs_runnable "threads in the ready queues are runnable'" > assert (prio <= maxPriority) "prio must be at most maxPriority" > ts <- getThreadState tptr > case ts of @@ -700,6 +700,7 @@ The following two functions place a thread at the beginning or end of its priori > tcbQueuePrepend :: TcbQueue -> PPtr TCB -> Kernel TcbQueue > tcbQueuePrepend queue tcbPtr = do +> stateAssert (tcbQueueAdd_asrt queue tcbPtr) "" > q <- if tcbQueueEmpty queue > then return $ queue { tcbQueueEnd = Just tcbPtr } > else do @@ -711,6 +712,7 @@ The following two functions place a thread at the beginning or end of its priori > tcbQueueAppend :: TcbQueue -> PPtr TCB -> Kernel TcbQueue > tcbQueueAppend queue tcbPtr = do +> stateAssert (tcbQueueAdd_asrt queue tcbPtr) "" > q <- if tcbQueueEmpty queue > then return $ queue { tcbQueueHead = Just tcbPtr } > else do @@ -724,6 +726,8 @@ Insert a thread into the middle of a queue, immediately before afterPtr, where a > tcbQueueInsert :: PPtr TCB -> PPtr TCB -> Kernel () > tcbQueueInsert tcbPtr afterPtr = do +> stateAssert sym_heap_sched_pointers_asrt "" +> stateAssert (tcbQueueInsert_asrt tcbPtr afterPtr) "" > tcb <- getObject afterPtr > beforePtrOpt <- return $ tcbSchedPrev tcb > assert (beforePtrOpt /= Nothing) "afterPtr must not be the head of the list" @@ -739,6 +743,8 @@ Remove a thread from a queue, which must originally contain the thread > tcbQueueRemove :: TcbQueue -> PPtr TCB -> Kernel TcbQueue > tcbQueueRemove queue tcbPtr = do +> stateAssert sym_heap_sched_pointers_asrt "" +> stateAssert (tcbQueueRemove_asrt queue tcbPtr) "" > tcb <- getObject tcbPtr > beforePtrOpt <- return $ tcbSchedPrev tcb > afterPtrOpt <- return $ tcbSchedNext tcb @@ -788,6 +794,8 @@ tcbPtr is in the middle of the queue > stateAssert ksReadyQueues_asrt "" > stateAssert ksReleaseQueue_asrt "" > stateAssert valid_tcbs'_asrt "`valid_tcbs'`" +> stateAssert pspace_aligned'_asrt "" +> stateAssert pspace_distinct'_asrt "" > runnable <- isRunnable thread > assert runnable "thread must be runnable" > queued <- threadGet tcbQueued thread @@ -808,6 +816,8 @@ tcbPtr is in the middle of the queue > stateAssert ksReadyQueues_asrt "" > stateAssert ksReleaseQueue_asrt "" > stateAssert valid_tcbs'_asrt "`valid_tcbs'`" +> stateAssert pspace_aligned'_asrt "" +> stateAssert pspace_distinct'_asrt "" > runnable <- isRunnable thread > assert runnable "thread must be runnable" > queued <- threadGet tcbQueued thread diff --git a/spec/haskell/src/SEL4/Kernel/VSpace/RISCV64.hs b/spec/haskell/src/SEL4/Kernel/VSpace/RISCV64.hs index f66d7bee6c..d9ee0cfca8 100644 --- a/spec/haskell/src/SEL4/Kernel/VSpace/RISCV64.hs +++ b/spec/haskell/src/SEL4/Kernel/VSpace/RISCV64.hs @@ -265,6 +265,7 @@ unmapPage size asid vptr pptr = ignoreFailure $ do setVMRoot :: PPtr TCB -> Kernel () setVMRoot tcb = do + stateAssert (tcb_at'_asrt tcb) "" threadRootSlot <- getThreadVSpaceRoot tcb threadRoot <- getSlotCap threadRootSlot {- We use this in C to remove the check for isMapped: -} diff --git a/spec/haskell/src/SEL4/Model/PSpace.lhs b/spec/haskell/src/SEL4/Model/PSpace.lhs index 57dadbe991..1824d286a9 100644 --- a/spec/haskell/src/SEL4/Model/PSpace.lhs +++ b/spec/haskell/src/SEL4/Model/PSpace.lhs @@ -247,6 +247,7 @@ No type checks are performed when deleting objects; "deleteObjects" simply delet > deleteObjects ptr bits = do > stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > stateAssert valid_idle'_asrt "`valid_idle'`" +> stateAssert if_live_then_nonz_cap'_asrt "" > unless (fromPPtr ptr .&. mask bits == 0) $ > alignError bits > stateAssert (deletionIsSafe ptr bits) diff --git a/spec/haskell/src/SEL4/Model/StateData.lhs b/spec/haskell/src/SEL4/Model/StateData.lhs index 495d7e2ebd..c1174c5061 100644 --- a/spec/haskell/src/SEL4/Model/StateData.lhs +++ b/spec/haskell/src/SEL4/Model/StateData.lhs @@ -478,11 +478,37 @@ activatable' after schedule runs. We add an assertion that this is the case. > ct_activatable'_asrt :: KernelState -> Bool > ct_activatable'_asrt _ = True -An assert that will say that the return value of findTimeAfter -is a pointer in the release queue. +An assert that will say that there is an abstract list with which the given +TcbQueue is in `list_queue_relation`, that the given TCB pointer is not an +element of the list, and that all elements of the list satisfy the predicate +`sched_flag_set`. -> findTimeAfter_asrt :: PPtr TCB -> KernelState -> Bool -> findTimeAfter_asrt _ _ = True +> tcbQueueAdd_asrt :: TcbQueue -> PPtr TCB -> KernelState -> Bool +> tcbQueueAdd_asrt _ _ _ = True + +An assert that will say that there is an abstract list and a TcbQueue +which are in `list_queue_relation`, that the TCB pointer to be inserted is +not an element of the list, that the TCB pointer before which we insert the +new TCB pointer is in the list, and that all elements of the list satisfy +the predicate `sched_flag_set`. + +> tcbQueueInsert_asrt :: PPtr TCB -> PPtr TCB -> KernelState -> Bool +> tcbQueueInsert_asrt _ _ _ = True + +An assert that will say that there is an abstract list with which the given +TcbQueue is in `list_queue_relation`, that the given TCB pointer is an +element of the list, and that all elements of the list except the given TCB +pointer satisfy the predicate `sched_flag_set`. + +> tcbQueueRemove_asrt :: TcbQueue -> PPtr TCB -> KernelState -> Bool +> tcbQueueRemove_asrt _ _ _ = True + +An assert that will say that there is an abstract list with which the given +TcbQueue is in `list_queue_relation`, and that the given TCB pointer is an +element of the list. + +> insertionPoint_asrt :: TcbQueue -> PPtr TCB -> KernelState -> Bool +> insertionPoint_asrt _ _ _ = True An assert that will say that `ready_or_release'` holds. That is, no thread has both the tcbQueued and tcbInReleaseQueue flag set. @@ -537,6 +563,11 @@ An assert that will say that there is a scheduling context at the given pointer > sc_at'_asrt :: PPtr SchedContext -> KernelState -> Bool > sc_at'_asrt _ _ = True +An assert that will say that there is an endpoint at the given pointer + +> ep_at'_asrt :: PPtr Endpoint -> KernelState -> Bool +> ep_at'_asrt _ _ = True + An assert that will say that there is an active scheduling context at the given pointer > active_sc_at'_asrt :: PPtr SchedContext -> KernelState -> Bool @@ -582,12 +613,75 @@ An assert that will say that sch_act_simple holds > sch_act_simple_asrt :: KernelState -> Bool > sch_act_simple_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 - An assert that will say that valid_domain_list' holds > valid_domain_list'_asrt :: KernelState -> Bool > valid_domain_list'_asrt _ = True + +An assert that will say that pspace_aligned' holds + +> pspace_aligned'_asrt :: KernelState -> Bool +> pspace_aligned'_asrt _ = True + +An assert that will say that pspace_distinct' holds + +> pspace_distinct'_asrt :: KernelState -> Bool +> pspace_distinct'_asrt _ = True + +An assert that will say that valid_bound_ep' holds + +> valid_bound_ep'_asrt :: Maybe (PPtr Endpoint) -> KernelState -> Bool +> valid_bound_ep'_asrt _ _ = True + +An assert that will say that valid_bound_ntfn' holds + +> valid_bound_ntfn'_asrt :: Maybe (PPtr Notification) -> KernelState -> Bool +> valid_bound_ntfn'_asrt _ _ = True + +An assert that will say that valid_bound_tcb' holds + +> valid_bound_tcb'_asrt :: Maybe (PPtr TCB) -> KernelState -> Bool +> valid_bound_tcb'_asrt _ _ = True + +An assert that will say that valid_bound_sc' holds + +> valid_bound_sc'_asrt :: Maybe (PPtr SchedContext) -> KernelState -> Bool +> valid_bound_sc'_asrt _ _ = True + +An assert that will say that valid_bound_reply' holds + +> valid_bound_reply'_asrt :: Maybe (PPtr Reply) -> KernelState -> Bool +> valid_bound_reply'_asrt _ _ = True + +An assert that will say that sym_heap_sched_pointers holds + +> sym_heap_sched_pointers_asrt :: KernelState -> Bool +> sym_heap_sched_pointers_asrt _ = True + +An assert that will say that if_live_then_nonz_cap' holds + +> if_live_then_nonz_cap'_asrt :: KernelState -> Bool +> if_live_then_nonz_cap'_asrt _ = True + +An assert that will say that the given thread is not `is_sched_linked` + +> not_sched_linked_asrt :: PPtr TCB -> KernelState -> Bool +> not_sched_linked_asrt _ _ = True + +An assert that will say that if a thread's state is either blocked on +receive or blocked on reply, then its reply object is none + +> reply_object_asrt :: PPtr TCB -> KernelState -> Bool +> reply_object_asrt _ _ = True + +An assert that will say that tcb_queue_head_end_valid holds of the +given tcb_queue + +> tcb_queue_head_end_valid_asrt :: TcbQueue -> KernelState -> Bool +> tcb_queue_head_end_valid_asrt _ _ = True + +An assert regarding many properties that are true when we call +orderedInsert and traverse the list backwards + +> orderedInsertBackwards_asrt :: PPtr TCB -> TcbQueue -> (PPtr TCB -> KernelR b) -> (b -> b -> Bool) -> KernelState -> Bool +> orderedInsertBackwards_asrt _ _ _ _ _ = True diff --git a/spec/haskell/src/SEL4/Object/Endpoint.lhs b/spec/haskell/src/SEL4/Object/Endpoint.lhs index 0053a2e67e..1c51089fbc 100644 --- a/spec/haskell/src/SEL4/Object/Endpoint.lhs +++ b/spec/haskell/src/SEL4/Object/Endpoint.lhs @@ -8,13 +8,13 @@ This module specifies the contents and behaviour of a synchronous IPC endpoint. > module SEL4.Object.Endpoint ( > sendIPC, receiveIPC, -> cancelIPC, cancelAllIPC, cancelBadgedSends, epBlocked, reorderEp +> cancelIPC, cancelAllIPC, cancelBadgedSends, epBlocked, tcbAppend, reorderEp > ) where \begin{impdetails} % {-# BOOT-IMPORTS: SEL4.Machine SEL4.Model SEL4.Object.Structures #-} -% {-# BOOT-EXPORTS: cancelIPC #-} +% {-# BOOT-EXPORTS: cancelIPC tcbAppend #-} > import Prelude hiding (Word) > import SEL4.API.Types @@ -53,47 +53,54 @@ The normal (blocking) version of the send operation will remove a recipient from > stateAssert (active_tcb_at'_asrt thread) > "`thread` has an `active'` thread state" > ep <- getEndpoint epptr -> case ep of +> case epState ep of If the endpoint is idle, and this is a blocking IPC operation, then the current thread is queued in the endpoint, which changes to the sending state. The thread will block until a receive operation is performed on the endpoint. -> IdleEP | blocking -> do +> IdleEPState | blocking -> do > setThreadState (BlockedOnSend { > blockingObject = epptr, > blockingIPCBadge = badge, > blockingIPCCanGrant = canGrant, > blockingIPCCanGrantReply = canGrantReply, > blockingIPCIsCall = call }) thread -> setEndpoint epptr $ SendEP [thread] +> tcbEPAppend thread epptr SendEPState If the endpoint is already in the sending state, and this is a blocking IPC operation, then the current thread is blocked and added to the queue. -> SendEP queue | blocking -> do +> SendEPState | blocking -> do > setThreadState (BlockedOnSend { > blockingObject = epptr, > blockingIPCBadge = badge, > blockingIPCCanGrant = canGrant, > blockingIPCCanGrantReply = canGrantReply, > blockingIPCIsCall = call }) thread -> qs' <- tcbEPAppend thread queue -> setEndpoint epptr $ SendEP qs' +> tcbEPAppend thread epptr SendEPState A non-blocking IPC to an idle or sending endpoint will be silently dropped. -> IdleEP -> return () -> SendEP _ -> return () +> IdleEPState -> return () +> SendEPState -> return () If the endpoint is receiving, then a thread is removed from its queue, and an IPC transfer is performed. If the recipient is the last thread in the endpoint's queue, the endpoint becomes idle. -> RecvEP (dest:queue) -> do -> setEndpoint epptr $ case queue of -> [] -> IdleEP -> _ -> RecvEP queue +> ReceiveEPState -> do +> let q = epQueue ep +> stateAssert (tcb_queue_head_end_valid_asrt q) "" +> assert (not (tcbQueueEmpty q)) "Receive endpoint queue must not be empty" +> let dest = fromJust $ tcbQueueHead q +> assert (dest /= thread) "thread must not be the head of the queue" +> stateAssert (not_tcbQueued_asrt dest) "" +> stateAssert (not_tcbInReleaseQueue_asrt dest) "" +> action <- getSchedulerAction +> assert (action /= SwitchToThread dest) "" +> tcbEPDequeue dest epptr > recvState <- getThreadState dest > assert (isReceive recvState) > "TCB in receive endpoint queue must be blocked on receive" > doIPCTransfer thread (Just epptr) badge canGrant dest > let replyOpt = replyObject recvState +> stateAssert (valid_bound_reply'_asrt replyOpt) "" > case replyOpt of > Just reply -> replyUnlink reply dest > _ -> return () @@ -105,6 +112,7 @@ If the endpoint is receiving, then a thread is removed from its queue, and an IP > else setThreadState Inactive thread > else when (canDonate && scOptDest == Nothing) $ do > scOptSrc <- threadGet tcbSchedContext thread +> assert (scOptSrc /= Nothing) "" > schedContextDonate (fromJust scOptSrc) dest @@ -115,28 +123,34 @@ The receiving thread has now completed its blocking operation and can run. If th > ifCondRefillUnblockCheck scOpt (Just False) (Just False) > possibleSwitchTo dest -Empty receive endpoints are invalid. - -> RecvEP [] -> fail "Receive endpoint queue must not be empty" - \subsection{Receiving IPC} The IPC receive operation is essentially the same as the send operation, but with the send and receive states swapped. There are a few other differences: the badge must be retrieved from the TCB when completing an operation, and is not set when adding a TCB to the queue; also, the operation always blocks if no partner is immediately available; lastly, the receivers thread state does not need updating to Running however the senders state may. -> isActive :: Notification -> Bool -> isActive (NTFN (ActiveNtfn _) _ _) = True -> isActive _ = False - > isTimeoutFault :: Fault -> Bool > isTimeoutFault (Timeout _) = True > isTimeoutFault _ = False +> receiveIPCBlocked :: Bool -> PPtr TCB -> PPtr Endpoint -> Maybe (PPtr Reply) -> Kernel () +> receiveIPCBlocked isBlocking thread epptr replyOpt = do +> case isBlocking of +> True -> do +> setThreadState (BlockedOnReceive { +> blockingObject = epptr, +> blockingIPCCanGrant = False, +> replyObject = replyOpt}) thread +> when (replyOpt /= Nothing) $ +> updateReply (fromJust replyOpt) (\reply -> reply { replyTCB = Just thread }) +> tcbEPAppend thread epptr ReceiveEPState +> False -> doNBRecvFailedTransfer thread + > receiveIPC :: PPtr TCB -> Capability -> Bool -> Capability -> Kernel () > receiveIPC thread cap@(EndpointCap {}) isBlocking replyCap = do > let epptr = capEPPtr cap > stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > stateAssert sch_act_wf_asrt "`sch_act_wf (ksSchedulerAction s) s`" > stateAssert valid_idle'_asrt "`valid_idle'`" +> assert (isReplyCap replyCap || isNullCap replyCap) "replyCap must be either a reply cap or a null cap" > replyOpt <- (case replyCap of > ReplyCap r _ -> return (Just r) > NullCap -> return Nothing @@ -145,64 +159,46 @@ The IPC receive operation is essentially the same as the send operation, but wit > tptrOpt <- liftM replyTCB (getReply (fromJust replyOpt)) > when (tptrOpt /= Nothing && tptrOpt /= Just thread) $ do > cancelIPC $ fromJust tptrOpt -> let recvCanGrant = capEPCanGrant cap +> stateAssert (valid_bound_reply'_asrt replyOpt) "" > ep <- getEndpoint epptr > -- check if anything is waiting on bound ntfn > ntfnPtr <- getBoundNotification thread -> ntfn <- maybe (return $ NTFN IdleNtfn Nothing Nothing) getNotification ntfnPtr -> if (isJust ntfnPtr && isActive ntfn) +> ntfn <- maybe (return $ Notification IdleNtfnState emptyQueue Nothing Nothing Nothing) getNotification ntfnPtr +> if (isJust ntfnPtr && ntfnState ntfn == Active) > then completeSignal (fromJust ntfnPtr) thread > else do > when (ntfnPtr /= Nothing && isBlocking) $ > maybeReturnSc (fromJust ntfnPtr) thread -> case ep of -> IdleEP -> case isBlocking of -> True -> do -> setThreadState (BlockedOnReceive { -> blockingObject = epptr, -> blockingIPCCanGrant = recvCanGrant, -> replyObject = replyOpt }) thread -> when (replyOpt /= Nothing) $ -> updateReply (fromJust replyOpt) (\reply -> reply { replyTCB = Just thread }) -> setEndpoint epptr $ RecvEP [thread] -> False -> doNBRecvFailedTransfer thread -> RecvEP queue -> case isBlocking of -> True -> do -> setThreadState (BlockedOnReceive { -> blockingObject = epptr, -> blockingIPCCanGrant = recvCanGrant, -> replyObject = replyOpt}) thread -> when (replyOpt /= Nothing) $ -> updateReply (fromJust replyOpt) (\reply -> reply { replyTCB = Just thread }) -> qs' <- tcbEPAppend thread queue -> setEndpoint epptr $ RecvEP $ qs' -> False -> doNBRecvFailedTransfer thread -> SendEP (sender:queue) -> do -> setEndpoint epptr $ case queue of -> [] -> IdleEP -> _ -> SendEP queue -> senderState <- getThreadState sender -> assert (isSend senderState) -> "TCB in send endpoint queue must be blocked on send" -> let badge = blockingIPCBadge senderState -> let canGrant = blockingIPCCanGrant senderState -> let canGrantReply = blockingIPCCanGrantReply senderState -> doIPCTransfer sender (Just epptr) badge canGrant thread -> scOpt <- threadGet tcbSchedContext sender -> ifCondRefillUnblockCheck scOpt (Just False) (Just True) -> let call = blockingIPCIsCall senderState -> fault <- threadGet tcbFault sender -> if (call || isJust fault) -> then if ((canGrant || canGrantReply) && replyOpt /= Nothing) -> then do -> senderSc <- threadGet tcbSchedContext sender -> donate <- return ((senderSc /= Nothing) && not (isJust fault && isTimeoutFault (fromJust fault))) -> replyPush sender thread (fromJust replyOpt) donate -> else setThreadState Inactive sender -> else do -> setThreadState Running sender -> possibleSwitchTo sender -> SendEP [] -> fail "Send endpoint queue must not be empty" +> case epState ep of +> IdleEPState -> receiveIPCBlocked isBlocking thread epptr replyOpt +> ReceiveEPState -> receiveIPCBlocked isBlocking thread epptr replyOpt +> SendEPState -> do +> let q = epQueue ep +> stateAssert (tcb_queue_head_end_valid_asrt q) "" +> assert (not (tcbQueueEmpty q)) "Send endpoint queue must not be empty" +> let sender = fromJust $ tcbQueueHead q +> tcbEPDequeue sender epptr +> senderState <- getThreadState sender +> assert (isSend senderState) +> "TCB in send endpoint queue must be blocked on send" +> let badge = blockingIPCBadge senderState +> let canGrant = blockingIPCCanGrant senderState +> let canGrantReply = blockingIPCCanGrantReply senderState +> doIPCTransfer sender (Just epptr) badge canGrant thread +> scOpt <- threadGet tcbSchedContext sender +> ifCondRefillUnblockCheck scOpt (Just False) (Just True) +> let call = blockingIPCIsCall senderState +> fault <- threadGet tcbFault sender +> if call || isJust fault +> then if (canGrant || canGrantReply) && replyOpt /= Nothing +> then do +> senderSc <- threadGet tcbSchedContext sender +> donate <- return ((senderSc /= Nothing) && not (isJust fault && isTimeoutFault (fromJust fault))) +> replyPush sender thread (fromJust replyOpt) donate +> else setThreadState Inactive sender +> else do +> setThreadState Running sender +> possibleSwitchTo sender > receiveIPC _ _ _ _ = fail "receiveIPC: invalid cap" @@ -233,16 +229,10 @@ If a thread is blocking on an endpoint, then the endpoint is fetched and the thr > blockedCancelIPC :: ThreadState -> PPtr TCB -> Maybe (PPtr Reply) -> Kernel () > blockedCancelIPC state tptr replyOpt = do +> stateAssert (valid_bound_reply'_asrt replyOpt) "" > epptr <- getBlockingObject state -> 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 -> _ -> ep { epQueue = queue' } -> setEndpoint epptr ep' +> stateAssert (ep_at'_asrt epptr) "" +> tcbEPDequeue tptr epptr > case replyOpt of > Nothing -> return () > Just reply -> replyUnlink reply tptr @@ -250,11 +240,6 @@ If a thread is blocking on an endpoint, then the endpoint is fetched and the thr Finally, replace the IPC block with a fault block (which will retry the operation if the thread is resumed). > setThreadState Inactive tptr -> -> where -> isIdle ep = case ep of -> IdleEP -> True -> _ -> False > restartThreadIfNoFault :: PPtr TCB -> Kernel () > restartThreadIfNoFault t = do @@ -267,10 +252,14 @@ Finally, replace the IPC block with a fault block (which will retry the operatio > possibleSwitchTo t > else setThreadState Inactive t -> cancelAllIPC_loop_body :: PPtr TCB -> Kernel () -> cancelAllIPC_loop_body t = do +> removeAndRestartEPQueuedThread :: PPtr TCB -> PPtr Endpoint -> Kernel () +> removeAndRestartEPQueuedThread t epptr = do +> st <- getThreadState t +> assert (isSend st || isReceive st) "TCB in endpoint queue must be blocked on send or receive" +> tcbEPDequeue t epptr > st <- getThreadState t > let replyOpt = if isReceive st then replyObject st else Nothing +> stateAssert (valid_bound_reply'_asrt replyOpt) "" > case replyOpt of > Nothing -> return () > Just reply -> replyUnlink reply t @@ -280,44 +269,56 @@ If an endpoint is deleted, then every pending IPC operation using it must be can > cancelAllIPC :: PPtr Endpoint -> Kernel () > cancelAllIPC epptr = do -> stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > stateAssert sch_act_wf_asrt "`sch_act_wf (ksSchedulerAction s) s`" > stateAssert ksReadyQueues_asrt "" > ep <- getEndpoint epptr -> case ep of -> IdleEP -> +> case epState ep of +> IdleEPState -> > 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) +> let q = epQueue ep +> stateAssert (tcb_queue_head_end_valid_asrt q) "" +> whileLoop (\ptrOpt -> const (ptrOpt /= Nothing)) +> (\ptrOpt -> do +> assert (ptrOpt /= Nothing) "the option type must not be Nothing" +> ptr <- return $ fromJust ptrOpt +> next <- threadGet tcbSchedNext ptr +> removeAndRestartEPQueuedThread ptr epptr +> return next) +> (tcbQueueHead q) +> ep <- getEndpoint epptr +> assert (epState ep == IdleEPState) "the endpoint must now be idle" > rescheduleRequired If a badged endpoint is recycled, then cancel every pending send operation using a badge equal to the recycled capability's badge. Receive operations are not affected. +> removeAndRestartBadgedThread :: PPtr TCB -> PPtr Endpoint -> Word -> Kernel () +> removeAndRestartBadgedThread t epptr badge = do +> st <- getThreadState t +> assert (isSend st) "TCB in send endpoint queue must be blocked on send" +> when (blockingIPCBadge st == badge) $ do +> tcbEPDequeue t epptr +> restartThreadIfNoFault t + > cancelBadgedSends :: PPtr Endpoint -> Word -> Kernel () > cancelBadgedSends epptr badge = do -> stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > stateAssert sch_act_wf_asrt "`sch_act_wf (ksSchedulerAction s) s`" > stateAssert ksReadyQueues_asrt "" > ep <- getEndpoint epptr -> case ep of -> 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 -> if blockingIPCBadge st == badge -> then do -> restartThreadIfNoFault t -> return False -> else return True -> ep' <- case queue' of -> [] -> return IdleEP -> _ -> return $ SendEP { epQueue = queue' } -> setEndpoint epptr ep' +> case epState ep of +> IdleEPState -> return () +> ReceiveEPState -> return () +> SendEPState -> do +> let q = epQueue ep +> stateAssert (tcb_queue_head_end_valid_asrt q) "" +> whileLoop (\ptrOpt -> const (ptrOpt /= Nothing)) +> (\ptrOpt -> do +> assert (ptrOpt /= Nothing) "the option type must not be Nothing" +> ptr <- return $ fromJust ptrOpt +> next <- threadGet tcbSchedNext ptr +> removeAndRestartBadgedThread ptr epptr badge +> return next) +> (tcbQueueHead q) > rescheduleRequired \subsection{Accessing Endpoints} @@ -331,6 +332,11 @@ The following two functions are specialisations of "getObject" and > setEndpoint :: PPtr Endpoint -> Endpoint -> Kernel () > setEndpoint = setObject +> updateEndpoint :: PPtr Endpoint -> (Endpoint -> Endpoint) -> Kernel () +> updateEndpoint epPtr upd = do +> ep <- getEndpoint epPtr +> setEndpoint epPtr (upd ep) + > epBlocked :: ThreadState -> Maybe (PPtr Endpoint) > epBlocked ts = case ts of > BlockedOnReceive r _ _ -> Just r @@ -343,23 +349,31 @@ The following two functions are specialisations of "getObject" and > assert (epOpt /= Nothing) "getBlockingObject: endpoint must not be Nothing" > return $ fromJust epOpt -> getEpQueue :: Endpoint -> Kernel [PPtr TCB] -> getEpQueue ep = -> case ep of -> SendEP q -> return q -> RecvEP q -> return q -> _ -> fail "getEpQueue: endpoint must not be idle" - -> updateEpQueue :: Endpoint -> [PPtr TCB] -> Endpoint -> updateEpQueue (RecvEP _) q' = RecvEP q' -> updateEpQueue (SendEP _) q' = SendEP q' -> updateEpQueue _ _ = IdleEP +> tcbEPDequeue :: PPtr TCB -> PPtr Endpoint -> Kernel () +> tcbEPDequeue tcbPtr epPtr = do +> ep <- getEndpoint epPtr +> q' <- tcbQueueRemove (epQueue ep) tcbPtr +> updateEndpoint epPtr (\ep -> ep { epQueue = q' }) +> when (tcbQueueEmpty q') $ +> updateEndpoint epPtr (\ep -> ep { epState = IdleEPState }) + +> tcbAppend :: PPtr TCB -> TcbQueue -> Kernel TcbQueue +> tcbAppend tcbPtr q = do +> stateAssert (orderedInsertBackwards_asrt tcbPtr q (threadRead tcbPriority) (>=)) "" +> orderedInsert tcbPtr q (threadRead tcbPriority) (>=) + +> tcbEPAppend :: PPtr TCB -> PPtr Endpoint -> EPState -> Kernel () +> tcbEPAppend tcbPtr epPtr state = do +> stateAssert (not_sched_linked_asrt tcbPtr) "" +> ep <- getEndpoint epPtr +> stateAssert (tcb_queue_head_end_valid_asrt (epQueue ep)) "" +> q' <- tcbAppend tcbPtr (epQueue ep) +> updateEndpoint epPtr (\ep -> ep { epQueue = q' }) +> updateEndpoint epPtr (\ep -> ep { epState = state }) > reorderEp :: PPtr Endpoint -> PPtr TCB -> Kernel () > reorderEp epPtr tptr = do -> stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > ep <- getEndpoint epPtr -> qs <- getEpQueue ep -> qs' <- tcbEPDequeue tptr qs -> qs'' <- tcbEPAppend tptr qs' -> setEndpoint epPtr (updateEpQueue ep qs'') +> q' <- tcbQueueRemove (epQueue ep) tptr +> q'' <- tcbAppend tptr q' +> updateEndpoint epPtr (\ep -> ep { epQueue = q'' }) diff --git a/spec/haskell/src/SEL4/Object/Instances.lhs b/spec/haskell/src/SEL4/Object/Instances.lhs index b6f79e72b6..3dbd7f655f 100644 --- a/spec/haskell/src/SEL4/Object/Instances.lhs +++ b/spec/haskell/src/SEL4/Object/Instances.lhs @@ -35,7 +35,7 @@ The following are the instances of "Storable" for the four main types of kernel \subsubsection{Synchronous IPC Endpoint} > instance PSpaceStorable Endpoint where -> makeObject = IdleEP +> makeObject = Endpoint IdleEPState emptyQueue > injectKO = KOEndpoint > projectKO o = case o of > KOEndpoint e -> return e @@ -44,7 +44,7 @@ The following are the instances of "Storable" for the four main types of kernel \subsubsection{Notification objects} > instance PSpaceStorable Notification where -> makeObject = NTFN IdleNtfn Nothing Nothing +> makeObject = Notification IdleNtfnState emptyQueue Nothing Nothing Nothing > injectKO = KONotification > projectKO o = case o of > KONotification e -> return e diff --git a/spec/haskell/src/SEL4/Object/Notification.lhs b/spec/haskell/src/SEL4/Object/Notification.lhs index 8b4bd800cb..487e081adf 100644 --- a/spec/haskell/src/SEL4/Object/Notification.lhs +++ b/spec/haskell/src/SEL4/Object/Notification.lhs @@ -9,7 +9,7 @@ This module specifies the behavior of notification objects. > module SEL4.Object.Notification ( > sendSignal, receiveSignal, > cancelAllSignals, cancelSignal, completeSignal, -> getNotification, setNotification, doUnbindNotification, unbindNotification, +> getNotification, setNotification, updateNotification, doUnbindNotification, unbindNotification, > unbindMaybeNotification, bindNotification, doNBRecvFailedTransfer, > ntfnBlocked, reorderNtfn > ) where @@ -17,13 +17,13 @@ This module specifies the behavior of notification objects. \begin{impdetails} % {-# BOOT-IMPORTS: SEL4.Machine SEL4.Model SEL4.Object.Structures #-} -% {-# BOOT-EXPORTS: getNotification setNotification #-} +% {-# BOOT-EXPORTS: getNotification setNotification updateNotification #-} > import Prelude hiding (Word) > import SEL4.Machine > import SEL4.Model > import SEL4.Object.Structures -> import {-# SOURCE #-} SEL4.Object.Endpoint(cancelIPC) +> import {-# SOURCE #-} SEL4.Object.Endpoint(cancelIPC, tcbAppend) > import SEL4.Object.SchedContext > import {-# SOURCE #-} SEL4.Object.TCB > import SEL4.Object.Instances() @@ -55,12 +55,12 @@ Fetch the notification object object, and select the operation based on its stat > stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > nTFN <- getNotification ntfnPtr -> case (ntfnObj nTFN, ntfnBoundTCB nTFN) of +> case (ntfnState nTFN, ntfnBoundTCB nTFN) of If the notification object is idle, store the badge and the value, and then mark the notification object as active. -> (IdleNtfn, Just tcb) -> do +> (IdleNtfnState, Just tcb) -> do > state <- getThreadState tcb > if (receiveBlocked state) > then do @@ -73,18 +73,18 @@ mark the notification object as active. > scOpt <- threadGet tcbSchedContext tcb > ifCondRefillUnblockCheck scOpt (Just False) (Just False) > else -> setNotification ntfnPtr $ nTFN { ntfnObj = ActiveNtfn badge } -> (IdleNtfn, Nothing) -> setNotification ntfnPtr $ nTFN { ntfnObj = ActiveNtfn badge } +> ntfnSetActive ntfnPtr badge +> (IdleNtfnState, Nothing) -> ntfnSetActive ntfnPtr badge If the notification object is waiting, a thread is removed from its queue and the signal is transferred to it. -> (WaitingNtfn (dest:queue), _) -> do -> assert (distinct (dest:queue)) "the notification queue must be a list of distinct pointers" -> setNotification ntfnPtr $ nTFN { -> ntfnObj = case queue of -> [] -> IdleNtfn -> _ -> WaitingNtfn queue -> } +> (Waiting, _) -> do +> let q = ntfnQueue nTFN +> assert (not (tcbQueueEmpty q)) "the notification's queue cannot be empty" +> let dest = fromJust $ tcbQueueHead q +> st <- getThreadState dest +> assert (isBlockedOnNtfn st) "TCB in notification queue must be blocked on notification" +> tcbNTFNDequeue dest ntfnPtr > setThreadState Running dest > asUser dest $ setRegister badgeRegister badge > maybeDonateSc dest ntfnPtr @@ -92,13 +92,12 @@ If the notification object is waiting, a thread is removed from its queue and th > when schedulable $ possibleSwitchTo dest > scOpt <- threadGet tcbSchedContext dest > ifCondRefillUnblockCheck scOpt (Just False) (Just False) -> (WaitingNtfn [], _) -> fail "WaitingNtfn Notification must have non-empty queue" If the notification object is active, new values are calculated and stored in the notification object. The calculation is done by a bitwise OR operation of the currently stored, and the newly sent values. -> (ActiveNtfn badge', _) -> do -> let newBadge = badge .|. badge' -> setNotification ntfnPtr $ nTFN { ntfnObj = ActiveNtfn newBadge } +> (Active, _) -> do +> let newBadge = badge .|. (fromJust $ ntfnMsgIdentifier nTFN) +> updateNotification ntfnPtr (\ntfn -> ntfn { ntfnMsgIdentifier = Just newBadge }) \subsection{Receiving Signals} @@ -107,9 +106,16 @@ This function performs an receive signal operation, given a thread pointer and a > doNBRecvFailedTransfer :: PPtr TCB -> Kernel () > doNBRecvFailedTransfer thread = asUser thread $ setRegister badgeRegister 0 +> receiveSignalBlocked :: PPtr TCB -> PPtr Notification -> Bool -> Kernel () +> receiveSignalBlocked thread ntfnPtr isBlocking = do +> case isBlocking of +> True -> do +> setThreadState (BlockedOnNotification { waitingOnNotification = ntfnPtr } ) thread +> tcbNTFNAppend thread ntfnPtr +> maybeReturnSc ntfnPtr thread +> False -> doNBRecvFailedTransfer thread > receiveSignal :: PPtr TCB -> Capability -> Bool -> Kernel () - > receiveSignal thread cap isBlocking = do Fetch the notification object, and select the operation based on its state. @@ -117,59 +123,63 @@ Fetch the notification object, and select the operation based on its state. > let ntfnPtr = capNtfnPtr cap > stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > stateAssert valid_idle'_asrt "`valid_idle' s`" +> runnable <- isRunnable thread +> assert runnable "the thread must have a runnable' thread state" +> stateAssert (not_sched_linked_asrt thread) "" > ntfn <- getNotification ntfnPtr -> case ntfnObj ntfn of +> case ntfnState ntfn of If the notification object is idle, then it becomes a waiting notification object, with the current thread in its queue. The thread is blocked. -> IdleNtfn -> case isBlocking of -> True -> do -> setThreadState (BlockedOnNotification { -> waitingOnNotification = ntfnPtr } ) thread -> setNotification ntfnPtr $ ntfn {ntfnObj = WaitingNtfn ([thread]) } -> maybeReturnSc ntfnPtr thread -> False -> doNBRecvFailedTransfer thread +> IdleNtfnState -> receiveSignalBlocked thread ntfnPtr isBlocking If the notification object is already waiting, the current thread is blocked and added to the queue. Note that this case cannot occur when the notification object is bound, as only the associated thread can wait on it. -> 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 -> setNotification ntfnPtr $ ntfn {ntfnObj = WaitingNtfn qs' } -> maybeReturnSc ntfnPtr thread -> False -> doNBRecvFailedTransfer thread +> Waiting -> receiveSignalBlocked thread ntfnPtr isBlocking If the notification object is active, the badge of the invoked notification object capability will be loaded to the badge of the receiving thread and the notification object will be marked as idle. -> ActiveNtfn badge -> do +> Active -> do +> let badge = fromJust $ ntfnMsgIdentifier ntfn > asUser thread $ setRegister badgeRegister badge -> setNotification ntfnPtr $ ntfn {ntfnObj = IdleNtfn } +> updateNotification ntfnPtr (\notification -> notification { ntfnState = IdleNtfnState, ntfnMsgIdentifier = Nothing }) > maybeDonateSc thread ntfnPtr > scOpt <- threadGet tcbSchedContext thread > ifCondRefillUnblockCheck scOpt (Just False) (Just False) \subsection{Delete Operation} +> removeAndRestartNTFNQueuedThread :: PPtr TCB -> PPtr Notification -> Kernel () +> removeAndRestartNTFNQueuedThread t ntfnPtr = do +> st <- getThreadState t +> assert (isBlockedOnNtfn st) "TCB in notification queue must be blocked on notification" +> tcbNTFNDequeue t ntfnPtr +> setThreadState Restart t +> scOpt <- threadGet tcbSchedContext t +> ifCondRefillUnblockCheck scOpt (Just False) (Just True) +> possibleSwitchTo t + If a notification object is deleted, then pending receive operations must be cancelled. > cancelAllSignals :: PPtr Notification -> Kernel () > cancelAllSignals ntfnPtr = do -> stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > stateAssert sch_act_wf_asrt "`sch_act_wf (ksSchedulerAction s) s`" > stateAssert ksReadyQueues_asrt "" > 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 -> scOpt <- threadGet tcbSchedContext t -> ifCondRefillUnblockCheck scOpt (Just False) (Just True) -> possibleSwitchTo t) +> case ntfnState ntfn of +> Waiting -> do +> let q = ntfnQueue ntfn +> stateAssert (tcb_queue_head_end_valid_asrt q) "" +> whileLoop (\ptrOpt -> const (ptrOpt /= Nothing)) +> (\ptrOpt -> do +> assert (ptrOpt /= Nothing) "the option type must not be Nothing" +> ptr <- return $ fromJust ptrOpt +> next <- threadGet tcbSchedNext ptr +> removeAndRestartNTFNQueuedThread ptr ntfnPtr +> return next) +> (tcbQueueHead q) +> ntfn <- getNotification ntfnPtr +> assert (ntfnState ntfn == IdleNtfnState) "the notification must now be idle" > rescheduleRequired > _ -> return () @@ -179,29 +189,17 @@ The following function will remove the given thread from the queue of the notifi > cancelSignal threadPtr ntfnPtr = do > stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > stateAssert ready_qs_runnable "threads in the ready queues are runnable'" -> 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 -> _ -> return $ (ntfnObj ntfn) { ntfnQueue = queue' } -> setNotification ntfnPtr (ntfn { ntfnObj = ntfn' }) +> tcbNTFNDequeue threadPtr ntfnPtr > setThreadState Inactive threadPtr -> where -> isWaiting ntfn = case ntfn of -> WaitingNtfn {} -> True -> _ -> False > completeSignal :: PPtr Notification -> PPtr TCB -> Kernel () > completeSignal ntfnPtr tcbPtr = do -> stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > ntfn <- getNotification ntfnPtr -> case ntfnObj ntfn of -> ActiveNtfn badge -> do +> case ntfnState ntfn of +> Active -> do +> let badge = fromJust $ ntfnMsgIdentifier ntfn > asUser tcbPtr $ setRegister badgeRegister badge -> setNotification ntfnPtr $ ntfn {ntfnObj = IdleNtfn} +> updateNotification ntfnPtr (\notification -> notification { ntfnState = IdleNtfnState, ntfnMsgIdentifier = Nothing }) > maybeDonateSc tcbPtr ntfnPtr > scOpt <- threadGet tcbSchedContext tcbPtr > case scOpt of @@ -225,41 +223,37 @@ The following functions are specialisations of the "getObject" and "setObject" f > setNotification :: PPtr Notification -> Notification -> Kernel () > setNotification = setObject +> updateNotification :: PPtr Notification -> (Notification -> Notification) -> Kernel () +> updateNotification ntfnPtr upd = do +> ntfn <- getNotification ntfnPtr +> setNotification ntfnPtr (upd ntfn) \subsection{Miscellaneous} > bindNotification :: PPtr TCB -> PPtr Notification -> Kernel () > bindNotification tcb ntfnPtr = do > -- set the bound tcb inside the ntfn -> ntfn <- getNotification ntfnPtr -> setNotification ntfnPtr $ ntfn { ntfnBoundTCB = Just tcb } +> updateNotification ntfnPtr (\ntfn -> ntfn { ntfnBoundTCB = Just tcb }) > -- set the bound ntfn inside the thread > setBoundNotification (Just ntfnPtr) tcb -> doUnbindNotification :: PPtr Notification -> Notification -> PPtr TCB -> Kernel () -> doUnbindNotification ntfnPtr ntfn tcbptr = do -> let ntfn' = ntfn { ntfnBoundTCB = Nothing } -> setNotification ntfnPtr ntfn' +> doUnbindNotification :: PPtr Notification -> PPtr TCB -> Kernel () +> doUnbindNotification ntfnPtr tcbptr = do +> updateNotification ntfnPtr (\ntfn -> ntfn { ntfnBoundTCB = Nothing }) > setBoundNotification Nothing tcbptr > unbindNotification :: PPtr TCB -> Kernel () > unbindNotification tcb = do -> stateAssert sym_refs_asrt -> "Assert that `sym_refs (state_refs_of' s)` holds" -> ntfnPtr <- getBoundNotification tcb -> case ntfnPtr of -> Just ntfnPtr' -> do -> ntfn <- getNotification ntfnPtr' -> doUnbindNotification ntfnPtr' ntfn tcb +> ntfnPtrOpt <- getBoundNotification tcb +> case ntfnPtrOpt of +> Just ntfnPtr -> doUnbindNotification ntfnPtr tcb > Nothing -> return () > unbindMaybeNotification :: PPtr Notification -> Kernel () > unbindMaybeNotification ntfnPtr = do -> stateAssert sym_refs_asrt -> "Assert that `sym_refs (state_refs_of' s)` holds" > ntfn <- getNotification ntfnPtr > case ntfnBoundTCB ntfn of -> Just t -> doUnbindNotification ntfnPtr ntfn t +> Just t -> doUnbindNotification ntfnPtr t > Nothing -> return () > ntfnBlocked :: ThreadState -> Maybe (PPtr Notification) @@ -267,19 +261,28 @@ The following functions are specialisations of the "getObject" and "setObject" f > BlockedOnNotification r -> Just r > _ -> Nothing +> tcbNTFNDequeue :: PPtr TCB -> PPtr Notification -> Kernel () +> tcbNTFNDequeue tcbPtr ntfnPtr = do +> notification <- getNotification ntfnPtr +> q' <- tcbQueueRemove (ntfnQueue notification) tcbPtr +> updateNotification ntfnPtr (\notification -> notification { ntfnQueue = q' }) +> when (tcbQueueEmpty q') $ +> updateNotification ntfnPtr (\notification -> notification { ntfnState = IdleNtfnState, ntfnMsgIdentifier = Nothing }) + +> tcbNTFNAppend :: PPtr TCB -> PPtr Notification -> Kernel () +> tcbNTFNAppend tcbPtr ntfnPtr = do +> notification <- getNotification ntfnPtr +> stateAssert (tcb_queue_head_end_valid_asrt (ntfnQueue notification)) "" +> q' <- tcbAppend tcbPtr (ntfnQueue notification) +> updateNotification ntfnPtr (\notification -> notification { ntfnQueue = q' , ntfnState = Waiting, ntfnMsgIdentifier = Nothing }) + > reorderNtfn :: PPtr Notification -> PPtr TCB -> Kernel () > reorderNtfn ntfnPtr tptr = do -> stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" -> ntfn <- getNotification ntfnPtr -> qsOpt <- return $ getntfnQueue ntfn -> assert (qsOpt /= Nothing) "reorder_ntfn: the notification queue must not be Nothing" -> qs <- return $ fromJust qsOpt -> qs' <- tcbEPDequeue tptr qs -> qs'' <- tcbEPAppend tptr qs' -> setNotification ntfnPtr (ntfn { ntfnObj = WaitingNtfn qs'' }) - -> getntfnQueue :: Notification -> Maybe [PPtr TCB] -> getntfnQueue ntfn = -> case ntfnObj ntfn of -> WaitingNtfn qs -> Just qs -> _ -> Nothing +> notification <- getNotification ntfnPtr +> q' <- tcbQueueRemove (ntfnQueue notification) tptr +> q'' <- tcbAppend tptr q' +> updateNotification ntfnPtr (\notification -> notification { ntfnQueue = q'' }) + +> ntfnSetActive :: PPtr Notification -> Word -> Kernel () +> ntfnSetActive ntfnPtr badge = +> updateNotification ntfnPtr (\notification -> notification { ntfnState = Active , ntfnMsgIdentifier = Just badge }) diff --git a/spec/haskell/src/SEL4/Object/ObjectType.lhs b/spec/haskell/src/SEL4/Object/ObjectType.lhs index 8b133ac55c..199c84e4ed 100644 --- a/spec/haskell/src/SEL4/Object/ObjectType.lhs +++ b/spec/haskell/src/SEL4/Object/ObjectType.lhs @@ -171,6 +171,7 @@ Threads are treated as special capability nodes; they also become zombies when t > return (Zombie cte_ptr ZombieTCB 5, NullCap) > finaliseCap (SchedContextCap { capSchedContextPtr = scPtr }) True _ = do +> stateAssert sch_act_simple_asrt "`sch_act_simple` must hold" > schedContextUnbindAllTCBs scPtr > schedContextUnbindNtfn scPtr > schedContextUnbindReply scPtr diff --git a/spec/haskell/src/SEL4/Object/Reply.lhs b/spec/haskell/src/SEL4/Object/Reply.lhs index d10418b372..16222b0053 100644 --- a/spec/haskell/src/SEL4/Object/Reply.lhs +++ b/spec/haskell/src/SEL4/Object/Reply.lhs @@ -45,6 +45,7 @@ This module specifies the behavior of reply objects. > stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > sc <- getSchedContext scPtr > scReplyOpt <- return $ scReply sc +> stateAssert (valid_bound_reply'_asrt scReplyOpt) "" > when (scReplyOpt /= Nothing) $ do > scReplyPtr <- return $ fromJust scReplyOpt > stateAssert (valid_replies'_sc_asrt scReplyPtr) @@ -60,6 +61,10 @@ This module specifies the behavior of reply objects. > "`valid_replies'_sc` holds for `replyPtr`" > stateAssert valid_idle'_asrt "`valid_idle'`" > stateAssert valid_objs'_asrt "`valid_objs'`" +> stateAssert (not_sched_linked_asrt callerPtr) "" +> reply <- getReply replyPtr +> assert (replyTCB reply == Nothing) "the reply must not be linked to a TCB" +> stateAssert (reply_object_asrt callerPtr) "" > scPtrOptDonated <- threadGet tcbSchedContext callerPtr > scPtrOptCallee <- threadGet tcbSchedContext calleePtr diff --git a/spec/haskell/src/SEL4/Object/SchedContext.lhs b/spec/haskell/src/SEL4/Object/SchedContext.lhs index 2ffa904733..738317a25e 100644 --- a/spec/haskell/src/SEL4/Object/SchedContext.lhs +++ b/spec/haskell/src/SEL4/Object/SchedContext.lhs @@ -32,7 +32,8 @@ This module uses the C preprocessor to select a target architecture. > schedContextUnbindReply, schedContextSetInactive, unbindFromSC, > schedContextCancelYieldTo, refillAbsoluteMax, schedContextUpdateConsumed, > scReleased, setConsumed, refillResetRR, preemptionPoint, refillHdInsufficient, -> mergeNonoverlappingHeadRefill, headInsufficientLoop, maxReleaseTime, readScActive, scActive +> mergeNonoverlappingHeadRefill, headInsufficientLoop, maxReleaseTime, readScActive, scActive, +> orderedInsert > ) where \begin{impdetails} @@ -500,9 +501,7 @@ This module uses the C preprocessor to select a target architecture. > schedContextBindNtfn :: PPtr SchedContext -> PPtr Notification -> Kernel () > schedContextBindNtfn scPtr ntfnPtr = do -> stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" -> ntfn <- getNotification ntfnPtr -> setNotification ntfnPtr (ntfn { ntfnSc = Just scPtr }) +> updateNotification ntfnPtr (\ntfn -> ntfn { ntfnSc = Just scPtr }) > updateSchedContext scPtr (\sc -> sc { scNtfn = Just ntfnPtr }) > schedContextUnbindTCB :: PPtr SchedContext -> Kernel () @@ -516,6 +515,7 @@ This module uses the C preprocessor to select a target architecture. > let tptrOpt = scTCB sc > assert (tptrOpt /= Nothing) "schedContextUnbind: option of TCB pointer must not be Nothing" > let tptr = fromJust tptrOpt +> stateAssert (tcb_at'_asrt tptr) "" > cur <- getCurThread > when (tptr == cur) $ rescheduleRequired > tcbSchedDequeue tptr @@ -530,8 +530,7 @@ This module uses the C preprocessor to select a target architecture. > case scNtfn sc of > Nothing -> return () > Just ntfnPtr -> do -> ntfn <- getNotification ntfnPtr -> setNotification ntfnPtr (ntfn { ntfnSc = Nothing }) +> updateNotification ntfnPtr (\ntfn -> ntfn { ntfnSc = Nothing }) > updateSchedContext scPtr (\sc -> sc { scNtfn = Nothing }) > schedContextMaybeUnbindNtfn :: PPtr Notification -> Kernel () @@ -575,6 +574,7 @@ This module uses the C preprocessor to select a target architecture. > stateAssert sym_refs_asrt "`sym_refs (state_refs_of' s)`" > sc <- getSchedContext scPtr > replyPtrOpt <- return $ scReply sc +> stateAssert (valid_bound_reply'_asrt replyPtrOpt) "" > when (replyPtrOpt /= Nothing) $ do > replyPtr <- return $ fromJust replyPtrOpt > updateReply replyPtr (\reply -> reply { replyNext = Nothing }) @@ -818,33 +818,58 @@ This module uses the C preprocessor to select a target architecture. > assert active "the sc must be active" > readReadyTime (fromJust scPtrOpt) -> getTCBReadyTime :: PPtr TCB -> Kernel Time -> getTCBReadyTime tcbPtr = getsJust (readTCBReadyTime tcbPtr) - -> timeAfter :: Maybe (PPtr TCB) -> Time -> KernelR Bool -> timeAfter tcbPtrOpt newTime = do -> if (tcbPtrOpt /= Nothing) +> compareVals :: Ord b => b -> Maybe (PPtr TCB) -> (PPtr TCB -> KernelR b) -> (b -> b -> Bool) -> KernelR Bool +> compareVals val ptrOpt f r = do +> if (ptrOpt /= Nothing) > then do -> tcbPtr <- return $ fromJust tcbPtrOpt -> time <- readTCBReadyTime (fromJust tcbPtrOpt) -> return $ time <= newTime +> ptr <- return $ fromJust ptrOpt +> val' <- f ptr +> return $ r val' val > else return False -> findTimeAfter :: Maybe (PPtr TCB) -> Time -> Kernel (Maybe (PPtr TCB)) -> findTimeAfter tcbPtrOpt newTime = do -> stateAssert tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt -> "every thread in the release queue is associated with \ -> an active scheduling context" -> whileLoop (\afterPtrOpt -> fromJust . runReaderT (timeAfter afterPtrOpt newTime)) -> (\afterPtrOpt -> do -> tcb <- getObject (fromJust afterPtrOpt) -> return $ tcbSchedNext tcb) -> tcbPtrOpt +> findInsertionPoint :: Ord b => b -> Maybe (PPtr TCB) -> (PPtr TCB -> KernelR b) -> (b -> b -> Bool) -> Kernel (Maybe (PPtr TCB)) +> findInsertionPoint val ptrOpt f r = +> whileLoop (\ptrOpt -> fromJust . runReaderT (compareVals val ptrOpt f r)) +> (\ptrOpt -> do +> tcb <- getObject (fromJust ptrOpt) +> return $ tcbSchedNext tcb) +> ptrOpt + +> orderedInsert :: Ord b => PPtr TCB -> TcbQueue -> (PPtr TCB -> KernelR b) -> (b -> b -> Bool) -> Kernel TcbQueue +> orderedInsert t q f r = do +> stateAssert sym_heap_sched_pointers_asrt "" +> val <- getsJust (f t) +> test <- if tcbQueueEmpty q +> then return True +> else do +> assert (tcbQueueHead q /= Nothing) "the head of q cannot be Nothing" +> head <- return $ fromJust $ tcbQueueHead q +> headVal <- getsJust (f head) +> return (r val headVal && val /= headVal) +> if test +> then tcbQueuePrepend q t +> else do +> assert (tcbQueueHead q /= Nothing) "the head of q cannot be Nothing" +> end <- return $ fromJust $ tcbQueueEnd q +> endVal <- getsJust (f end) +> if r endVal val +> then tcbQueueAppend q t +> else do +> ptrOpt <- findInsertionPoint val (tcbQueueHead q) f r +> assert (ptrOpt /= Nothing) "the pointer found must not be Nothing" +> ptr <- return $ fromJust ptrOpt +> stateAssert (insertionPoint_asrt q ptr) "" +> tcbQueueInsert t ptr +> return q > tcbReleaseEnqueue :: PPtr TCB -> Kernel () > tcbReleaseEnqueue tcbPtr = do + +> stateAssert tcbInReleaseQueue_imp_active_sc_tcb_at'_asrt +> "every thread in the release queue is associated with an active scheduling context" > stateAssert ready_or_release'_asrt "`ready_or_release'`" -> stateAssert (not_tcbQueued_asrt tcbPtr) "`tcbPtr` must not have the `tcbQueued` flag set" +> stateAssert (not_tcbQueued_asrt tcbPtr) +> "tcbPtr must not have the tcbQueued flag set" > stateAssert ksReadyQueues_asrt "" > stateAssert ksReleaseQueue_asrt "" > stateAssert valid_objs'_asrt "`valid_objs'`" @@ -852,31 +877,13 @@ This module uses the C preprocessor to select a target architecture. > assert runnable "thread must be runnable" > tcb <- getObject tcbPtr > assert (tcbInReleaseQueue tcb == False) "tcbPtr must not already be in the release queue" -> newTime <- getTCBReadyTime tcbPtr + > queue <- getReleaseQueue -> ifM (orM (return (tcbQueueEmpty queue)) -> (do -> headTime <- getTCBReadyTime (fromJust $ tcbQueueHead queue) -> return (newTime < headTime))) -> (do -> newQueue <- tcbQueuePrepend queue tcbPtr -> setReleaseQueue newQueue -> setReprogramTimer True) -> (do -> assert (tcbQueueHead queue /= Nothing && tcbQueueEnd queue /= Nothing) "the queue is nonempty" -> lastTime <- getTCBReadyTime (fromJust $ tcbQueueEnd queue) -> if lastTime <= newTime -> then do -> newQueue <- tcbQueueAppend queue tcbPtr -> setReleaseQueue newQueue -> else do -> afterPtrOpt <- findTimeAfter (tcbQueueHead queue) newTime -> assert (afterPtrOpt /= Nothing) "the afterPtr must be in the queue" -> afterPtr <- return $ fromJust afterPtrOpt -> stateAssert (findTimeAfter_asrt afterPtr) -> "`tcbPtr` must be in the release queue" -> tcbQueueInsert tcbPtr afterPtr) +> queue' <- orderedInsert tcbPtr queue readTCBReadyTime (<=) +> setReleaseQueue queue' > threadSet (\t -> t { tcbInReleaseQueue = True }) tcbPtr +> queue'' <- getReleaseQueue +> when (tcbQueueHead queue /= tcbQueueHead queue'') (setReprogramTimer True) In preemptible code, the kernel may explicitly mark a preemption point with the "preemptionPoint" function. The preemption will only be taken if an interrupt has occurred and the preemption point has been called "workUnitsLimit" times. diff --git a/spec/haskell/src/SEL4/Object/Structures.lhs b/spec/haskell/src/SEL4/Object/Structures.lhs index f7e88725aa..5a82c27456 100644 --- a/spec/haskell/src/SEL4/Object/Structures.lhs +++ b/spec/haskell/src/SEL4/Object/Structures.lhs @@ -173,28 +173,23 @@ When stored in the physical memory model (described in \autoref{sec:model.pspace Synchronous endpoints are represented in the physical memory model using the "Endpoint" data structure. -> data Endpoint - There are three possible states for a synchronous endpoint: -\begin{itemize} - -\item waiting for one or more receive operations to complete, with -a list of pointers to waiting threads. -> = RecvEP { epQueue :: [PPtr TCB] } - -\item idle; - -> | IdleEP +> data EPState +> = IdleEPState -- idle +> | SendEPState -- waiting for one or more send operations to complete +> | ReceiveEPState -- waiting for one or more receive operations to complete +> deriving (Show, Eq) -\item or waiting for one or more send operations to complete, with a -list of pointers to waiting threads; +A synchronous endpoint consists of a state, together with a value of type TcbQueue that +indicates the head and end of the endpoint queue of threads that are waiting; +the full queue is obtained by starting at the head and following the tcbSchedNext pointers. -> | SendEP { epQueue :: [PPtr TCB] } +> data Endpoint = Endpoint { +> epState :: EPState, +> epQueue :: TcbQueue } > deriving Show -\end{itemize} - \subsubsection{SchedContext Objects} > data Refill = Refill { @@ -274,29 +269,21 @@ list of pointers to waiting threads; Notification objects are represented in the physical memory model using the "Notification" data structure. -> data NTFN - There are three possible states for a notification: -\begin{itemize} -\item idle; - -> = IdleNtfn -\item active, ready to deliver a notification message consisting of one data word and one message identifier word. - -> | ActiveNtfn { ntfnMsgIdentifier :: Word } - -\item or waiting for one or more send operations to complete, with a list of pointers to the waiting threads; - -> | WaitingNtfn { ntfnQueue :: [PPtr TCB] } -> deriving Show +> data NTFNState +> = IdleNtfnState -- idle +> | Active -- active, ready to deliver a notification message consisting of one data word and one message identifier word +> | Waiting -- waiting for one or more send operations to complete +> deriving (Show, Eq) -> data Notification = NTFN { -> ntfnObj :: NTFN, +> data Notification = Notification { +> ntfnState :: NTFNState, +> ntfnQueue :: TcbQueue, -- the queue will be nonempty if and only if the state is Waiting +> ntfnMsgIdentifier :: Maybe Word, -- will be not Nothing if and only if the state is Active > ntfnBoundTCB :: Maybe (PPtr TCB), > ntfnSc :: Maybe (PPtr SchedContext) } - -\end{itemize} +> deriving Show \subsubsection{Capability Table Entry} @@ -555,6 +542,10 @@ Each entry in the domain schedule specifies a domain and a length (a number of t > isSend (BlockedOnSend _ _ _ _ _) = True > isSend _ = False +> isBlockedOnNtfn :: ThreadState -> Bool +> isBlockedOnNtfn (BlockedOnNotification _) = True +> isBlockedOnNtfn _ = False + > isReply :: ThreadState -> Bool > isReply (BlockedOnReply _) = True > isReply _ = False @@ -593,6 +584,7 @@ Various operations on the free index of an Untyped cap. > data TcbQueue = TcbQueue { > tcbQueueHead :: Maybe (PPtr TCB), > tcbQueueEnd :: Maybe (PPtr TCB) } +> deriving (Show, Eq) > emptyQueue :: TcbQueue > emptyQueue = TcbQueue { tcbQueueHead = Nothing, tcbQueueEnd = Nothing } diff --git a/spec/haskell/src/SEL4/Object/TCB.lhs b/spec/haskell/src/SEL4/Object/TCB.lhs index c15a657fa1..b896ac0ffc 100644 --- a/spec/haskell/src/SEL4/Object/TCB.lhs +++ b/spec/haskell/src/SEL4/Object/TCB.lhs @@ -26,13 +26,13 @@ This module uses the C preprocessor to select a target architecture. > archThreadSet, archThreadGet, > decodeSchedContextInvocation, decodeSchedControlInvocation, > checkBudget, chargeBudget, checkBudgetRestart, mcsPreemptionPoint, commitTime, awaken, switchSchedContext, -> updateAt, tcbEPAppend, tcbEPDequeue, isBlocked, isStopped +> updateAt, isBlocked, isStopped > ) where \begin{impdetails} % {-# BOOT-IMPORTS: SEL4.API.Types SEL4.API.Failures SEL4.Machine SEL4.Model SEL4.Object.Structures SEL4.API.Invocation #-} -% {-# BOOT-EXPORTS: threadRead threadGet threadSet asUser setMRs replyFromKernel setMessageInfo getThreadCSpaceRoot getThreadVSpaceRoot decodeTCBInvocation invokeTCB getThreadBufferSlot decodeDomainInvocation archThreadSet archThreadGet sanitiseRegister decodeSchedContextInvocation decodeSchedControlInvocation checkBudget chargeBudget updateAt tcbEPAppend tcbEPDequeue #-} +% {-# BOOT-EXPORTS: threadRead threadGet threadSet asUser setMRs replyFromKernel setMessageInfo getThreadCSpaceRoot getThreadVSpaceRoot decodeTCBInvocation invokeTCB getThreadBufferSlot decodeDomainInvocation archThreadSet archThreadGet sanitiseRegister decodeSchedContextInvocation decodeSchedControlInvocation checkBudget chargeBudget updateAt #-} > import Prelude hiding (Word) > import SEL4.Config @@ -406,9 +406,12 @@ This is to ensure that the source capability is not made invalid by the deletion > -- check if notification is bound > -- check if anything is waiting on the notification > notification <- withoutFailure $ getNotification ntfnPtr -> case (ntfnObj notification, ntfnBoundTCB notification) of -> (IdleNtfn, Nothing) -> return () -> (ActiveNtfn _, Nothing) -> return () +> q <- return $ ntfnQueue notification +> assert ((tcbQueueEmpty q) == (ntfnState notification /= Waiting)) "the queue must be nonempty only when the state is Waiting" +> stateAssert (tcb_queue_head_end_valid_asrt q) "" +> case (ntfnState notification, ntfnBoundTCB notification) of +> (IdleNtfnState, Nothing) -> return () +> (Active, Nothing) -> return () > _ -> throw IllegalOperation > return NotificationControl { > notificationTCB = tcb, @@ -1153,15 +1156,3 @@ 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) () - -> tcbEPAppend :: PPtr TCB -> [PPtr TCB] -> Kernel [PPtr TCB] -> 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 = return $ filter (\t -> t /= tptr) queue diff --git a/tools/haskell-translator/caseconvs b/tools/haskell-translator/caseconvs index 005a40b405..c2dbea354f 100644 --- a/tools/haskell-translator/caseconvs +++ b/tools/haskell-translator/caseconvs @@ -429,8 +429,8 @@ case \x of Arch.Types.APIObjectType _ -> Arch.Types.SmallPageObject -> Arch.Type case \x of (srcIndex:srcDepth:args, srcRootCap:_) | label < 4 -> (_, _) | label == 4 -> (_, _) | label == 5 -> (_, _) | label == 6 -> (pivotNewData:pivotIndex:pivotDepth:srcNewData:srcIndex:srcDepth:_, pivotRootCap:srcRootCap:_) | label == 7 -> (_, _) | label > 7 -> _ -> ---> let (\v0\, \v1\) = \x in if length \v0\ >= 2 & length \v1\ >= 1 & label < 4 then let srcIndex = \v0\ !! 0; srcDepth = \v0\ !! 1; args = drop 2 \v0\; srcRootCap = \v1\ !! 0 in ->1 else if label = 4 then ->2 else if label = 5 then ->3 else if label = 6 then ->4 else if length \v0\ >= 6 & length \v1\ >= 2 & label = 7 then let pivotNewData = \v0\ !! 0; pivotIndex = \v0\ !! 1; pivotDepth = \v0\ !! 2; srcNewData = \v0\ !! 3; srcIndex = \v0\ !! 4; srcDepth = \v0\ !! 5; pivotRootCap = \v1\ !! 0; srcRootCap = \v1\ !! 1 in ->5 else if label > 7 then ->6 else ->7 -case \x of IdleEP | blocking -> SendEP queue | blocking -> IdleEP -> SendEP _ -> RecvEP (dest:queue) -> RecvEP [] -> ---> case \x of - IdleEP \ if blocking then ->1 else ->3 | SendEP queue \ if blocking then ->2 else ->4 | RecvEP \v0\ \ (case \v0\ of dest # queue \ ->5 | [] \ ->6 ) +case \x of IdleEPState | blocking -> SendEPState | blocking -> IdleEPState -> SendEPState -> ReceiveEPState -> ---> case \x of + IdleEPState \ if blocking then ->1 else ->3 | SendEPState \ if blocking then ->2 else ->4 | ReceiveEPState \ ->5 case \x of Zombie {} -> cap@(UntypedCap {}) -> ReplyCap {} -> ArchObjectCap cap -> cap -> ---> let cap = \x in case cap of