From 3787b8d68211d6991cabe392ff4920dcfe47e28e Mon Sep 17 00:00:00 2001 From: Corey Lewis Date: Thu, 14 Nov 2024 18:49:16 +1100 Subject: [PATCH] rt arm refine: discard broken state of proofs This restores the ARM refine proofs to match master. The rt changes to these proofs have not been maintained for a long time and have not been kept up to date with changes made to the specifications and ainvs. There also hasn't been a strong effort to keep them in a consistent state when doing merges in the past. When we want to do these proofs for ARM again in the future we will need to pull in the changes from RISCV64 anyway, and discarding them like this will make merges easier now. Signed-off-by: Corey Lewis --- proof/refine/ARM/ADT_H.thy | 681 ++- proof/refine/ARM/ArchAcc_R.thy | 741 +-- proof/refine/ARM/ArchMove_R.thy | 9 + proof/refine/ARM/Arch_R.thy | 132 +- proof/refine/ARM/Bits_R.thy | 87 +- proof/refine/ARM/CNodeInv_R.thy | 1271 ++-- proof/refine/ARM/CSpace1_R.thy | 1069 ++-- proof/refine/ARM/CSpace_I.thy | 124 +- proof/refine/ARM/CSpace_R.thy | 1188 ++-- proof/refine/ARM/Corres.thy | 13 - proof/refine/ARM/Detype_R.thy | 2831 +++++---- proof/refine/ARM/EmptyFail.thy | 40 +- proof/refine/ARM/EmptyFail_H.thy | 62 +- proof/refine/ARM/Finalise_R.thy | 2972 +++------- proof/refine/ARM/InitLemmas.thy | 6 +- proof/refine/ARM/Init_R.thy | 35 +- proof/refine/ARM/InterruptAcc_R.thy | 380 +- proof/refine/ARM/Interrupt_R.thy | 239 +- proof/refine/ARM/InvariantUpdates_H.thy | 214 +- proof/refine/ARM/Invariants_H.thy | 2221 +++---- proof/refine/ARM/Invocations_R.thy | 2 +- proof/refine/ARM/IpcCancel_R.thy | 4534 +++++---------- proof/refine/ARM/Ipc_R.thy | 6791 +++++++--------------- proof/refine/ARM/KHeap_R.thy | 5115 ++++------------ proof/refine/ARM/KernelInit_R.thy | 4 +- proof/refine/ARM/LevityCatch.thy | 26 +- proof/refine/ARM/Machine_R.thy | 29 +- proof/refine/ARM/PageTableDuplicates.thy | 741 ++- proof/refine/ARM/RAB_FN.thy | 2 +- proof/refine/ARM/Refine.thy | 1105 ++-- proof/refine/ARM/Reply_R.thy | 1829 ------ proof/refine/ARM/Retype_R.thy | 3258 ++++++----- proof/refine/ARM/SchedContextInv_R.thy | 1616 ----- proof/refine/ARM/SchedContext_R.thy | 860 --- proof/refine/ARM/Schedule_R.thy | 5072 +++------------- proof/refine/ARM/StateRelation.thy | 729 +-- proof/refine/ARM/SubMonad_R.thy | 14 +- proof/refine/ARM/Syscall_R.thy | 3121 ++++------ proof/refine/ARM/TcbAcc_R.thy | 3988 ++++++------- proof/refine/ARM/Tcb_R.thy | 3406 ++++------- proof/refine/ARM/Untyped_R.thy | 749 ++- proof/refine/ARM/VSpace_R.thy | 829 ++- proof/refine/ARM/orphanage/Orphanage.thy | 14 +- 43 files changed, 19336 insertions(+), 38813 deletions(-) delete mode 100644 proof/refine/ARM/Reply_R.thy delete mode 100644 proof/refine/ARM/SchedContextInv_R.thy delete mode 100644 proof/refine/ARM/SchedContext_R.thy diff --git a/proof/refine/ARM/ADT_H.thy b/proof/refine/ARM/ADT_H.thy index e73d29034d..1d3060c9db 100644 --- a/proof/refine/ARM/ADT_H.thy +++ b/proof/refine/ARM/ADT_H.thy @@ -12,11 +12,6 @@ imports Syscall_R begin -(* FIXME: many of the naming conventions in this file are wrong. Definitions should start with - lower case letters, and should be under_score, not camelCase. Some, possibly many of - the functions here can benefit from projections that have been developed since this - was originally written *) - text \ The general refinement calculus (see theory Simulation) requires the definition of a so-called ``abstract datatype'' for each refinement layer. @@ -33,7 +28,7 @@ consts initBootFrames :: "word32 list" initDataStart :: word32 -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \ The construction of the abstract data type @@ -284,13 +279,12 @@ definition | Structures_H.RecvEP q \ Structures_A.RecvEP q" definition - "NtfnMap ntfn \ + "AEndpointMap 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 - , ntfn_bound_tcb = ntfnBoundTCB ntfn - , ntfn_sc = ntfnSc ntfn \" + , ntfn_bound_tcb = ntfnBoundTCB ntfn \" fun CapabilityMap :: "capability \ cap" @@ -306,10 +300,8 @@ fun cap.CNodeCap ref n (bin_to_bl l (uint L))" | "CapabilityMap (capability.ThreadCap ref) = cap.ThreadCap ref" | "CapabilityMap capability.DomainCap = cap.DomainCap" -| "CapabilityMap (capability.ReplyCap ref gr) = - cap.ReplyCap ref {x. gr \ x = AllowGrant \ x = AllowWrite}" -| "CapabilityMap (SchedContextCap sc n) = cap.SchedContextCap sc (n - min_sched_context_bits)" -| "CapabilityMap SchedControlCap = cap.SchedControlCap" +| "CapabilityMap (capability.ReplyCap ref master gr) = + cap.ReplyCap ref master {x. gr \ x = AllowGrant \ x = AllowWrite}" | "CapabilityMap capability.IRQControlCap = cap.IRQControlCap" | "CapabilityMap (capability.IRQHandlerCap irq) = cap.IRQHandlerCap irq" | "CapabilityMap (capability.Zombie p b n) = @@ -357,10 +349,10 @@ where Structures_A.thread_state.Inactive" | "ThStateMap Structures_H.thread_state.IdleThreadState = Structures_A.thread_state.IdleThreadState" -| "ThStateMap (Structures_H.thread_state.BlockedOnReply r) = - Structures_A.thread_state.BlockedOnReply (the r)" -| "ThStateMap (Structures_H.thread_state.BlockedOnReceive oref grant r) = - Structures_A.thread_state.BlockedOnReceive oref r \ receiver_can_grant = grant \" +| "ThStateMap Structures_H.thread_state.BlockedOnReply = + Structures_A.thread_state.BlockedOnReply" +| "ThStateMap (Structures_H.thread_state.BlockedOnReceive oref grant) = + Structures_A.thread_state.BlockedOnReceive oref \ receiver_can_grant = grant \" | "ThStateMap (Structures_H.thread_state.BlockedOnSend oref badge grant grant_reply call) = Structures_A.thread_state.BlockedOnSend oref \ sender_badge = badge, @@ -404,8 +396,6 @@ primrec where "FaultMap (Fault_H.fault.CapFault ref b failure) = ExceptionTypes_A.fault.CapFault ref b (LookupFailureMap failure)" -| "FaultMap (Fault_H.fault.Timeout b) = - ExceptionTypes_A.fault.Timeout b" | "FaultMap (Fault_H.fault.ArchFault fault) = ExceptionTypes_A.fault.ArchFault (ArchFaultMap fault)" | "FaultMap (Fault_H.fault.UnknownSyscallException n) = @@ -418,7 +408,7 @@ lemma ArchFaultMap_arch_fault_map: "ArchFaultMap (arch_fault_map f) = f" lemma FaultMap_fault_map[simp]: "valid_fault ft \ FaultMap (fault_map ft) = ft" - apply (case_tac ft; simp) + apply (case_tac ft, simp_all) apply (simp add: valid_fault_def LookupFailureMap_lookup_failure_map word_bits_def) apply (rule ArchFaultMap_arch_fault_map) done @@ -435,48 +425,23 @@ definition "TcbMap tcb \ \tcb_ctable = CapabilityMap (cteCap (tcbCTable tcb)), tcb_vtable = CapabilityMap (cteCap (tcbVTable tcb)), + tcb_reply = CapabilityMap (cteCap (tcbReply tcb)), + tcb_caller = CapabilityMap (cteCap (tcbCaller tcb)), tcb_ipcframe = CapabilityMap (cteCap (tcbIPCBufferFrame tcb)), - tcb_fault_handler = CapabilityMap (cteCap (tcbFaultHandler tcb)), - tcb_timeout_handler = CapabilityMap (cteCap (tcbTimeoutHandler tcb)), tcb_state = ThStateMap (tcbState tcb), + tcb_fault_handler = to_bl (tcbFaultHandler tcb), tcb_ipc_buffer = tcbIPCBuffer tcb, tcb_fault = map_option FaultMap (tcbFault tcb), tcb_bound_notification = tcbBoundNotification tcb, tcb_mcpriority = tcbMCP tcb, - tcb_sched_context = tcbSchedContext tcb, - tcb_yield_to = tcbYieldTo tcb, - tcb_priority = tcbPriority tcb, - tcb_domain = tcbDomain tcb, tcb_arch = ArchTcbMap (tcbArch tcb)\" -definition absCNode :: "nat \ (obj_ref \ kernel_object) \ obj_ref \ Structures_A.kernel_object" - where - "absCNode sz h a \ CNode sz (\bl. if length bl = sz - then Some (CapabilityMap - (case (h (a + of_bl bl * 2^cteSizeBits)) of - Some (KOCTE cte) \ cteCap cte)) - else None)" - -definition scMap :: "(obj_ref \ obj_ref) \ sched_context \ Structures_A.sched_context" where - "scMap replyPrevs sc = \ - sc_period = scPeriod sc, - sc_budget = if scRefillMax sc > 0 - then refills_sum (refills_map (scRefillHead sc) (scRefillCount sc) - (scRefillMax sc) (scRefills sc)) - else 0, - sc_consumed = scConsumed sc, - sc_tcb = scTCB sc, - sc_ntfn = scNtfn sc, - sc_refills = refills_map (scRefillHead sc) (scRefillCount sc) (scRefillMax sc) (scRefills sc), - sc_refill_max = scRefillMax sc, - sc_badge = scBadge sc, - sc_yield_from = scYieldFrom sc, - sc_replies = heap_walk replyPrevs (scReply sc) [], - sc_sporadic = scSporadic sc - \" - -definition replyMap :: "reply \ Structures_A.reply" where - "replyMap r = \ reply_tcb = replyTCB r, reply_sc = replySC r \" +definition + "absCNode sz h a \ CNode sz (%bl. + if length bl = sz + then Some (CapabilityMap (case (h (a + of_bl bl * 2^cteSizeBits)) of + Some (KOCTE cte) \ cteCap cte)) + else None)" definition absHeap :: "(word32 \ vmpage_size) \ (word32 \ nat) \ @@ -485,15 +450,12 @@ definition "absHeap ups cns h \ \x. case h x of Some (KOEndpoint ep) \ Some (Endpoint (EndpointMap ep)) - | Some (KONotification ntfn) \ Some (Notification (NtfnMap ntfn)) + | Some (KONotification ntfn) \ Some (Notification (AEndpointMap 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) | Some (KOTCB tcb) \ Some (TCB (TcbMap tcb)) | Some (KOCTE cte) \ map_option (%sz. absCNode sz h x) (cns x) - | Some (KOReply reply) \ Some (Structures_A.Reply (replyMap reply)) - | Some (KOSchedContext sc) \ Some (Structures_A.SchedContext - (scMap (h |> reply_of' |> replyPrev) sc) (scSize sc)) | Some (KOArch ako) \ map_option ArchObj (absHeapArch h x ako) | None \ None" @@ -516,6 +478,16 @@ lemma unaligned_page_offsets_helper: apply (frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+ done +(* FIXME: move *) +lemma unaligned_helper: + "\is_aligned x n; y\0; y < 2 ^ n\ \ \ is_aligned (x + y) n" + apply (simp (no_asm_simp) add: is_aligned_mask) + apply (simp add: mask_add_aligned) + apply (cut_tac mask_eq_iff_w2p[of n y], simp_all add: word_size) + apply (rule ccontr) + apply (simp add: not_less power_overflow word_bits_conv) + done + lemma pspace_aligned_distinct_None: (* NOTE: life would be easier if pspace_aligned and pspace_distinct were defined on PSpace instead of the whole kernel state. *) assumes pspace_aligned: @@ -596,30 +568,15 @@ lemma pspace_aligned_distinct_None': apply assumption+ done -context -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 pte_relation_def pde_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 - - lemma absHeap_correct: assumes pspace_aligned: "pspace_aligned s" assumes pspace_distinct: "pspace_distinct 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'" shows "absHeap (gsUserPages s') (gsCNodes s') (ksPSpace s') = kheap s" proof - - note relatedE = pspace_dom_relatedE[OF _ pspace_relation] from ghost_relation have gsUserPages: "\a sz. (\dev. kheap s a = Some (ArchObj (DataPage dev sz))) \ @@ -630,274 +587,377 @@ proof - by (fastforce simp add: ghost_relation_def)+ show "?thesis" - supply image_cong_simp [cong del] + supply image_cong_simp [cong del] apply (rule ext) apply (simp add: absHeap_def split: option.splits) apply (rule conjI) using pspace_relation - apply (clarsimp simp: pspace_relation_def pspace_dom_def UNION_eq dom_def Collect_eq) + apply (clarsimp simp add: pspace_relation_def pspace_dom_def UNION_eq + dom_def Collect_eq) apply (erule_tac x=x in allE) apply clarsimp apply (case_tac "kheap s x", simp) - apply (rename_tac ko) apply (erule_tac x=x in allE, clarsimp) 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 a) + apply (simp_all add: other_obj_relation_def + split: if_split_asm Structures_H.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 (clarsimp simp add: image_def cte_map_def + well_formed_cnode_n_def Collect_eq dom_def) apply (erule_tac x="replicate sz False" in allE)+ apply simp apply (rename_tac arch_kernel_obj) - apply (case_tac arch_kernel_obj; simp add: image_def) + apply (case_tac arch_kernel_obj, simp_all add: image_def) apply (erule_tac x=0 in allE, simp) apply (erule_tac x=0 in allE, simp) apply clarsimp apply (erule_tac x=0 in allE, simp add: pageBits_def) apply (rename_tac vmpage_size) - apply (case_tac vmpage_size; simp) + apply (case_tac vmpage_size, simp_all) - apply (clarsimp split: kernel_object.splits) + apply clarsimp apply (intro conjI impI allI) - apply (erule relatedE, ko, ako) - apply (clarsimp simp: ep_relation_def EndpointMap_def - split: Structures_A.endpoint.splits) - apply (erule relatedE, ko, ako) - apply (clarsimp simp: ntfn_relation_def NtfnMap_def - split: Structures_A.ntfn.splits) - apply (erule relatedE, ko, ako) - apply (erule relatedE, ko, ako) - apply (rename_tac vmpage_size n) - apply (cut_tac a=y and sz=vmpage_size in gsUserPages, clarsimp split: if_split_asm) - apply (case_tac "n=0", simp) - apply (case_tac "kheap s (y + n * 2 ^ pageBits)") - apply (rule ccontr) - apply (clarsimp dest!: gsUserPages[symmetric, THEN iffD1] ) - using pspace_aligned - apply (simp add: pspace_aligned_def dom_def) - apply (erule_tac x=y in allE) - apply (case_tac "n=0",(simp split: if_split_asm)+) - apply (frule (2) unaligned_page_offsets_helper) - apply (frule_tac y="n*2^pageBits" in pspace_aligned_distinct_None' - [OF pspace_aligned pspace_distinct]) - apply simp - apply (rule conjI, clarsimp simp add: word_gt_0) - apply (simp add: is_aligned_mask) - apply (clarsimp simp add: pageBits_def mask_def) - apply (case_tac vmpage_size; frule_tac i=n and k="0x1000" in word_mult_less_mono1; simp) - apply simp - - apply (erule relatedE, ko, ako) - apply (rename_tac vmpage_size n) - apply (cut_tac a=y and sz=vmpage_size in gsUserPages, clarsimp split: if_split_asm) - apply (case_tac "n=0", simp) - apply (case_tac "kheap s (y + n * 2 ^ pageBits)") - apply (rule ccontr) - apply (clarsimp dest!: gsUserPages[symmetric, THEN iffD1]) - using pspace_aligned - apply (simp add: pspace_aligned_def dom_def) - apply (erule_tac x=y in allE) - apply (case_tac "n=0"; simp) - apply (frule (2) unaligned_page_offsets_helper) - apply (frule_tac y="n*2^pageBits" in pspace_aligned_distinct_None' - [OF pspace_aligned pspace_distinct]) - apply simp - apply (rule conjI, clarsimp simp add: word_gt_0) - apply (simp add: is_aligned_mask) - apply (clarsimp simp add: pageBits_def mask_def) - apply (case_tac vmpage_size; frule_tac i=n and k="0x1000" in word_mult_less_mono1; simp) + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply clarsimp + apply (case_tac ko, simp_all add: tcb_relation_cut_def other_obj_relation_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp add: ep_relation_def EndpointMap_def + split: Structures_A.endpoint.splits) + apply (clarsimp simp add: EndpointMap_def + split: Structures_A.endpoint.splits) + apply (rename_tac arch_kernel_obj) + apply (case_tac arch_kernel_obj, + simp_all add: other_obj_relation_def) + apply (clarsimp simp add: pte_relation_def) + apply (clarsimp simp add: pde_relation_def) + apply (clarsimp split: if_split_asm)+ + + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply (case_tac ko, simp_all add: tcb_relation_cut_def other_obj_relation_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (clarsimp simp add: ntfn_relation_def AEndpointMap_def + split: Structures_A.ntfn.splits) + apply (clarsimp simp add: AEndpointMap_def + split: Structures_A.ntfn.splits) + apply (rename_tac arch_kernel_obj) + apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def) + apply (clarsimp simp add: pte_relation_def) + apply (clarsimp simp add: pde_relation_def) + apply (clarsimp split: if_split_asm)+ + + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply (case_tac ko, simp_all add: tcb_relation_cut_def other_obj_relation_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (rename_tac arch_kernel_obj) + apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def) + apply (clarsimp simp add: pte_relation_def) + apply (clarsimp simp add: pde_relation_def) + apply (clarsimp split: if_split_asm)+ + + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply (case_tac ko, simp_all add: tcb_relation_cut_def other_obj_relation_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (rename_tac arch_kernel_obj) + apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def) + apply (clarsimp simp add: pte_relation_def) + apply (clarsimp simp add: pde_relation_def) + apply (rename_tac vmpage_size) + apply (cut_tac a=y and sz=vmpage_size in gsUserPages, clarsimp split: if_split_asm) + apply (case_tac "n=0", simp) + apply (case_tac "kheap s (y + n * 2 ^ pageBits)") + apply (rule ccontr) + apply (clarsimp dest!: gsUserPages[symmetric, THEN iffD1] ) + using pspace_aligned + apply (simp add: pspace_aligned_def dom_def) + apply (erule_tac x=y in allE) + apply (case_tac "n=0",(simp split: if_split_asm)+) + apply (frule (2) unaligned_page_offsets_helper) + apply (frule_tac y="n*2^pageBits" in pspace_aligned_distinct_None' + [OF pspace_aligned pspace_distinct]) apply simp - - apply (erule relatedE, ko, ako) - apply (clarsimp simp: TcbMap_def tcb_relation_def valid_obj_def) - apply (rename_tac tcb y tcb') - apply (case_tac tcb, case_tac tcb') - apply (simp add: thread_state_relation_imp_ThStateMap) - apply (subgoal_tac "map_option FaultMap (tcbFault tcb) = tcb_fault") - prefer 2 - apply (simp add: fault_rel_optionation_def) - using valid_objs[simplified valid_objs_def dom_def fun_app_def, simplified] - apply (erule_tac x=y in allE) - apply (clarsimp simp: valid_obj_def valid_tcb_def split: option.splits) - using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def] + apply (rule conjI, clarsimp simp add: word_gt_0) + apply (simp add: is_aligned_mask) + apply (clarsimp simp add: pageBits_def mask_def) + apply (case_tac vmpage_size; simp) + apply ((frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+)[4] + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply (case_tac ko, simp_all add: tcb_relation_cut_def other_obj_relation_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (rename_tac arch_kernel_obj) + apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def) + apply (clarsimp simp add: pte_relation_def) + apply (clarsimp simp add: pde_relation_def) + apply (rename_tac vmpage_size) + apply (cut_tac a=y and sz=vmpage_size in gsUserPages, clarsimp split: if_split_asm) + apply (case_tac "n=0", simp) + apply (case_tac "kheap s (y + n * 2 ^ pageBits)") + apply (rule ccontr) + apply (clarsimp dest!: gsUserPages[symmetric, THEN iffD1]) + using pspace_aligned + apply (simp add: pspace_aligned_def dom_def) apply (erule_tac x=y in allE) - apply (clarsimp simp: cap_relation_imp_CapabilityMap valid_obj_def valid_tcb_def - ran_tcb_cap_cases valid_cap_def2 arch_tcb_relation_imp_ArchTcnMap) - - apply (erule relatedE, ko, ako) - apply (simp add: absCNode_def cte_map_def) - apply (cut_tac a=y and n=sz in gsCNodes, clarsimp) - using pspace_aligned[simplified pspace_aligned_def] - apply (drule_tac x=y in bspec, clarsimp) - apply clarsimp - apply (case_tac "(of_bl ya::word32) * 2^cte_level_bits = 0", simp) - apply (rule ext) - apply simp - apply (rule conjI) - prefer 2 - using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def] - apply (erule_tac x=y in allE) - apply (clarsimp simp: valid_obj_def valid_cs_def valid_cs_size_def - well_formed_cnode_n_def dom_def Collect_eq) - apply (frule_tac x=ya in spec, simp) - apply (erule_tac x=bl in allE) - apply clarsimp - apply (frule pspace_relation_absD[OF _ pspace_relation]) - apply (simp add: cte_map_def) - apply (drule_tac x="y + of_bl bl * 2^cte_level_bits" in spec) - apply clarsimp - apply (erule_tac x="cte_relation bl" in allE) - apply (erule impE) - apply (fastforce simp add: well_formed_cnode_n_def) - apply clarsimp - apply (clarsimp simp add: cte_relation_def) - apply (rule cap_relation_imp_CapabilityMap) - using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def] - apply (erule_tac x=y in allE) - apply (clarsimp simp: valid_obj_def valid_cs_def valid_cap_def2 ran_def) - apply (fastforce simp: cte_level_bits_def cteSizeBits_def)+ - apply (subgoal_tac "kheap s (y + of_bl ya * 2^cte_level_bits) = None") + apply (case_tac "n=0",simp+) + apply (frule (2) unaligned_page_offsets_helper) + apply (frule_tac y="n*2^pageBits" in pspace_aligned_distinct_None' + [OF pspace_aligned pspace_distinct]) + apply simp + apply (rule conjI, clarsimp simp add: word_gt_0) + apply (simp add: is_aligned_mask) + apply (clarsimp simp add: pageBits_def mask_def) + apply (case_tac vmpage_size; simp) + apply ((frule_tac i=n and k="0x1000" in word_mult_less_mono1, simp+)+)[4] + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply (case_tac ko, simp_all add: tcb_relation_cut_def other_obj_relation_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + prefer 2 + apply (rename_tac arch_kernel_obj) + apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def) + apply (clarsimp simp add: pte_relation_def) + apply (clarsimp simp add: pde_relation_def) + apply (clarsimp split: if_split_asm) + apply (clarsimp simp add: TcbMap_def tcb_relation_def valid_obj_def) + apply (rename_tac tcb y tcb') + apply (case_tac tcb) + apply (case_tac tcb') + apply (simp add: thread_state_relation_imp_ThStateMap) + apply (subgoal_tac "map_option FaultMap (tcbFault tcb) = tcb_fault") prefer 2 - using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def] + apply (simp add: fault_rel_optionation_def) + using valid_objs[simplified valid_objs_def dom_def fun_app_def, + simplified] apply (erule_tac x=y in allE) - apply (clarsimp simp add: valid_obj_def valid_cs_def valid_cs_size_def) - apply (rule pspace_aligned_distinct_None'[OF - pspace_aligned pspace_distinct], assumption) - apply (clarsimp simp: word_neq_0_conv power_add cte_index_repair) - apply (simp add: well_formed_cnode_n_def dom_def Collect_eq) - apply (erule_tac x=ya in allE)+ - apply (rule word_mult_less_mono1) - apply (subgoal_tac "sz = length ya") - apply simp - apply (rule of_bl_length, (simp add: word_bits_def)+)[1] - apply fastforce - apply (simp add: cte_level_bits_def) - apply (simp add: word_bits_conv cte_level_bits_def) - apply (drule_tac a="2::nat" in power_strict_increasing, simp+) - apply (rule ccontr, clarsimp) - apply (cut_tac a="y + of_bl ya * 2^cte_level_bits" and n=yc in gsCNodes) - apply clarsimp - - (* mapping architecture-specific objects *) - apply clarsimp - apply (rename_tac x arch_kernel_object) - apply (erule relatedE, ko) - apply (rename_tac y P arch_kernel_obj) - apply (case_tac arch_kernel_object; simp add: absHeapArch_def split: asidpool.splits) - - apply clarsimp - apply (case_tac arch_kernel_obj) - apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def o_def) - apply (clarsimp simp add: pte_relation_def) - apply (clarsimp simp add: pde_relation_def) - apply (clarsimp split: if_split_asm)+ - - apply (case_tac arch_kernel_obj) - apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def o_def) - using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def] - apply (erule_tac x=y in allE) - apply (clarsimp simp add: pte_relation_def absPageTable_def pt_bits_def pageBits_def) - apply (rule conjI) - prefer 2 - apply clarsimp - apply (rule sym) - apply (rule pspace_aligned_distinct_None'[OF pspace_aligned pspace_distinct]; simp) - apply (cut_tac x=ya and n="2^10" in - ucast_less_shiftl_helper[where 'a=32,simplified word_bits_conv]; simp) - apply (clarsimp simp add: word_gt_0) - apply clarsimp - apply (subgoal_tac "ucast ya << 2 = 0") - prefer 2 - apply (rule ccontr) - apply (frule_tac x=y in unaligned_helper, assumption) - apply (rule ucast_less_shiftl_helper; simp) - apply simp - apply simp - apply (rule ext) - apply (frule pspace_relation_absD[OF _ pspace_relation]) - apply simp - apply (erule_tac x=offs in allE) + apply (clarsimp simp: valid_obj_def valid_tcb_def + split: option.splits) + using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def] + apply (erule_tac x=y in allE) + apply (clarsimp simp add: cap_relation_imp_CapabilityMap valid_obj_def + valid_tcb_def ran_tcb_cap_cases valid_cap_def2 + arch_tcb_relation_imp_ArchTcnMap) + apply (simp add: absCNode_def cte_map_def) + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply (case_tac ko, simp_all add: tcb_relation_cut_def other_obj_relation_def + split: if_split_asm) + prefer 2 + apply (rename_tac arch_kernel_obj) + apply (case_tac arch_kernel_obj, simp_all add: other_obj_relation_def) apply (clarsimp simp add: pte_relation_def) - 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=offs in allE) - apply (rename_tac pte') - apply (case_tac pte', simp_all add: pte_relation_aligned_def)[1] - apply (clarsimp split: ARM_A.pte.splits) - apply (rule set_eqI, clarsimp) - apply (case_tac x; simp) - apply (clarsimp split: ARM_A.pte.splits) - apply (rule set_eqI, clarsimp) - apply (case_tac x; simp) apply (clarsimp simp add: pde_relation_def) apply (clarsimp split: if_split_asm) + apply (simp add: cte_map_def) + apply (clarsimp simp add: cte_relation_def) + apply (cut_tac a=y and n=sz in gsCNodes, clarsimp) + using pspace_aligned[simplified pspace_aligned_def] + apply (drule_tac x=y in bspec, clarsimp) + apply clarsimp + apply (case_tac "(of_bl ya::word32) * 2^cte_level_bits = 0", simp) + apply (rule ext) + apply simp + apply (rule conjI) + prefer 2 + using valid_objs[simplified valid_objs_def Ball_def dom_def + fun_app_def] + apply (erule_tac x=y in allE) + apply (clarsimp simp add: valid_obj_def valid_cs_def valid_cs_size_def + well_formed_cnode_n_def dom_def Collect_eq) + apply (frule_tac x=ya in spec, simp) + apply (erule_tac x=bl in allE) + apply clarsimp+ + apply (frule pspace_relation_absD[OF _ pspace_relation]) + apply (simp add: cte_map_def) + apply (drule_tac x="y + of_bl bl * 2^cte_level_bits" in spec) + apply clarsimp + apply (erule_tac x="cte_relation bl" in allE) + apply (erule impE) + apply (fastforce simp add: well_formed_cnode_n_def) + apply clarsimp + apply (clarsimp simp add: cte_relation_def) + apply (rule cap_relation_imp_CapabilityMap) + using valid_objs[simplified valid_objs_def Ball_def dom_def + fun_app_def] + apply (erule_tac x=y in allE) + apply (clarsimp simp: valid_obj_def valid_cs_def valid_cap_def2 ran_def) + apply (fastforce simp: cte_level_bits_def cteSizeBits_def)+ + apply (subgoal_tac "kheap s (y + of_bl ya * 2^cte_level_bits) = None") + prefer 2 + using valid_objs[simplified valid_objs_def Ball_def dom_def fun_app_def] + apply (erule_tac x=y in allE) + apply (clarsimp simp add: valid_obj_def valid_cs_def valid_cs_size_def) + apply (rule pspace_aligned_distinct_None'[OF + pspace_aligned pspace_distinct], assumption) + apply (clarsimp simp: word_neq_0_conv power_add cte_index_repair) + apply (simp add: well_formed_cnode_n_def dom_def Collect_eq) + apply (erule_tac x=ya in allE)+ + apply (rule word_mult_less_mono1) + apply (subgoal_tac "sz = length ya") + apply simp + apply (rule of_bl_length, (simp add: word_bits_def)+)[1] + apply fastforce + apply (simp add: cte_level_bits_def) + apply (simp add: word_bits_conv cte_level_bits_def) + apply (drule_tac a="2::nat" in power_strict_increasing, simp+) + apply (rule ccontr, clarsimp) + apply (cut_tac a="y + of_bl ya * 2^cte_level_bits" and n=yc in gsCNodes) + apply clarsimp + + (* mapping architecture-specific objects *) + apply clarsimp + apply (erule pspace_dom_relatedE[OF _ pspace_relation]) + apply (case_tac ko, simp_all add: tcb_relation_cut_def other_obj_relation_def) + apply (clarsimp simp add: cte_relation_def split: if_split_asm) + apply (rename_tac arch_kernel_object y ko P arch_kernel_obj) + apply (case_tac arch_kernel_object, simp_all add: absHeapArch_def + split: asidpool.splits) + apply clarsimp apply (case_tac arch_kernel_obj) - apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def o_def) + apply (simp add: other_obj_relation_def asid_pool_relation_def + inv_def o_def) apply (clarsimp simp add: pte_relation_def) - using pspace_aligned - apply (simp add: pspace_aligned_def dom_def) + apply (clarsimp simp add: pde_relation_def) + apply (clarsimp split: if_split_asm)+ + + apply (case_tac arch_kernel_obj) + apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def + o_def) + using pspace_aligned[simplified pspace_aligned_def Ball_def dom_def] apply (erule_tac x=y in allE) - apply (clarsimp simp add: pde_relation_def absPageDirectory_def pd_bits_def pageBits_def) + apply (clarsimp simp add: pte_relation_def absPageTable_def + pt_bits_def pageBits_def) apply (rule conjI) prefer 2 apply clarsimp apply (rule sym) - apply (rule pspace_aligned_distinct_None' [OF pspace_aligned pspace_distinct]; simp) - apply (cut_tac x=ya and n="2^14" in - ucast_less_shiftl_helper[where 'a=32, simplified word_bits_conv]; simp) + apply (rule pspace_aligned_distinct_None' + [OF pspace_aligned pspace_distinct], simp+) + apply (cut_tac x=ya and n="2^10" in + ucast_less_shiftl_helper[where 'a=32,simplified word_bits_conv], simp+) apply (clarsimp simp add: word_gt_0) apply clarsimp apply (subgoal_tac "ucast ya << 2 = 0") prefer 2 apply (rule ccontr) apply (frule_tac x=y in unaligned_helper, assumption) - apply (rule ucast_less_shiftl_helper; simp) - apply simp - apply simp + apply (rule ucast_less_shiftl_helper, simp_all) apply (rule ext) apply (frule pspace_relation_absD[OF _ pspace_relation]) apply simp apply (erule_tac x=offs in allE) - apply (clarsimp simp add: pde_relation_def) - - using valid_objs[simplified valid_objs_def fun_app_def dom_def,simplified] + apply (clarsimp simp add: pte_relation_def) + 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_pde_def) + apply (clarsimp simp add: valid_obj_def wellformed_pte_def) apply (erule_tac x=offs in allE) - apply (rename_tac pde') - apply (case_tac pde'; simp add: pde_relation_aligned_def) - apply (clarsimp split: ARM_A.pde.splits)+ - apply (fastforce simp add: subset_eq) - apply (clarsimp split: ARM_A.pde.splits) + apply (rename_tac pte') + apply (case_tac pte', simp_all add: pte_relation_aligned_def)[1] + apply (clarsimp split: ARM_A.pte.splits) apply (rule set_eqI, clarsimp) - apply (case_tac x; simp) - apply (clarsimp split: ARM_A.pde.splits) + apply (case_tac x, simp_all)[1] + apply (clarsimp split: ARM_A.pte.splits) apply (rule set_eqI, clarsimp) - apply (case_tac x; simp) - apply (clarsimp simp add: pde_relation_def split: if_split_asm) - - apply (rule relatedE, assumption, ko, ako) - apply (clarsimp simp: sc_relation_def scMap_def sc_replies_prevs_walk[OF replies]) - apply (intro conjI impI) - apply (prop_tac "valid_refills y s") - apply (fastforce intro: valid_refills active_scs_validE - simp: vs_all_heap_simps active_sc_def) - apply (clarsimp simp: valid_refills_def vs_all_heap_simps rr_valid_refills_def - split: if_splits) - apply (insert valid_refills) - apply (force simp: active_scs_valid_def valid_refills_def vs_all_heap_simps - active_sc_def - split: if_splits) - - apply (erule relatedE, ko, ako) - apply (clarsimp simp: reply_relation_def replyMap_def) + apply (case_tac x, simp_all)[1] + apply (clarsimp simp add: pde_relation_def) + apply (clarsimp split: if_split_asm)+ + + apply (case_tac arch_kernel_obj) + apply (simp add: other_obj_relation_def asid_pool_relation_def inv_def + o_def) + apply (clarsimp simp add: pte_relation_def) + using pspace_aligned + apply (simp add: pspace_aligned_def dom_def) + apply (erule_tac x=y in allE) + apply (clarsimp simp add: pde_relation_def absPageDirectory_def + pd_bits_def pageBits_def) + apply (rule conjI) + prefer 2 + apply clarsimp + apply (rule sym) + apply (rule pspace_aligned_distinct_None' + [OF pspace_aligned pspace_distinct], simp+) + apply (cut_tac x=ya and n="2^14" in + ucast_less_shiftl_helper[where 'a=32, simplified word_bits_conv], simp+) + apply (clarsimp simp add: word_gt_0) + apply clarsimp + apply (subgoal_tac "ucast ya << 2 = 0") + prefer 2 + apply (rule ccontr) + apply (frule_tac x=y in unaligned_helper, assumption) + apply (rule ucast_less_shiftl_helper, simp_all) + apply (rule ext) + apply (frule pspace_relation_absD[OF _ pspace_relation]) + apply simp + apply (erule_tac x=offs in allE) + apply (clarsimp simp add: pde_relation_def) + + 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_pde_def) + apply (erule_tac x=offs in allE) + apply (rename_tac pde') + apply (case_tac pde', simp_all add: pde_relation_aligned_def)[1] + apply (clarsimp split: ARM_A.pde.splits)+ + apply (fastforce simp add: subset_eq) + apply (clarsimp split: ARM_A.pde.splits) + apply (rule set_eqI, clarsimp) + apply (case_tac x, simp_all)[1] + apply (clarsimp split: ARM_A.pde.splits) + apply (rule set_eqI, clarsimp) + apply (case_tac x, simp_all)[1] + apply (clarsimp simp add: pde_relation_def split: if_split_asm) done qed -end +definition + "EtcbMap tcb \ + \tcb_priority = tcbPriority tcb, + time_slice = tcbTimeSlice tcb, + tcb_domain = tcbDomain tcb\" + +definition + absEkheap :: "(word32 \ Structures_H.kernel_object) \ obj_ref \ etcb option" + where + "absEkheap h \ \x. + case h x of + Some (KOTCB tcb) \ Some (EtcbMap tcb) + | _ \ None" + +lemma absEkheap_correct: +assumes pspace_relation: "pspace_relation (kheap s) (ksPSpace s')" +assumes ekheap_relation: "ekheap_relation (ekheap s) (ksPSpace s')" +assumes vetcbs: "valid_etcbs s" +shows + "absEkheap (ksPSpace s') = ekheap s" + apply (rule ext) + apply (clarsimp simp: absEkheap_def split: option.splits Structures_H.kernel_object.splits) + apply (subgoal_tac "\x. (\tcb. kheap s x = Some (TCB tcb)) = + (\tcb'. ksPSpace s' x = Some (KOTCB tcb'))") + using vetcbs ekheap_relation + apply (clarsimp simp: valid_etcbs_def is_etcb_at_def dom_def ekheap_relation_def st_tcb_at_def obj_at_def) + apply (erule_tac x=x in allE)+ + apply (rule conjI, force) + apply clarsimp + apply (rule conjI, clarsimp simp: EtcbMap_def etcb_relation_def)+ + apply clarsimp + using pspace_relation + apply (clarsimp simp add: pspace_relation_def pspace_dom_def UNION_eq + dom_def Collect_eq) + apply (rule iffI) + apply (erule_tac x=x in allE)+ + apply (case_tac "ksPSpace s' x", clarsimp) + apply (erule_tac x=x in allE, clarsimp) + apply clarsimp + apply (case_tac a, simp_all add: tcb_relation_cut_def other_obj_relation_def) + apply (insert pspace_relation) + apply (clarsimp simp: obj_at'_def projectKOs) + apply (erule(1) pspace_dom_relatedE) + apply (erule(1) obj_relation_cutsE) + apply (clarsimp simp: other_obj_relation_def + split: Structures_A.kernel_object.split_asm if_split_asm + ARM_A.arch_kernel_obj.split_asm)+ + done text \The following function can be used to reverse cte_map.\ definition @@ -968,11 +1028,12 @@ lemma TCB_implies_KOTCB: lemma cte_at_CNodeI: "\kheap s a = Some (CNode (length b) cs); well_formed_cnode_n (length b) cs\ \ cte_at (a,b) s" - apply (subgoal_tac "\y. cs b = Some y") - apply clarsimp - apply (rule_tac cte=y in cte_wp_at_cteI[of s _ "length b" cs]; simp) - apply (simp add: well_formed_cnode_n_def dom_def Collect_eq) - done +apply (subgoal_tac "\y. cs b = Some y") + apply clarsimp + apply (rule_tac cte=y in cte_wp_at_cteI[of s _ "length b" cs], + simp_all) +apply (simp add: well_formed_cnode_n_def dom_def Collect_eq) +done lemma cteMap_correct: assumes rel: "(s,s') \ state_relation" @@ -1396,7 +1457,7 @@ locale partial_sort_cdt = partial_sort "\ x y. m' \ cte_map begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma valid_list_2 : "valid_list_2 t m" apply (insert assms') @@ -1593,7 +1654,7 @@ lemma sort_cdt_list_correct: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition absCDTList where "absCDTList cnp h \ sort_cdt_list (absCDT cnp h) h" @@ -1735,6 +1796,13 @@ lemma absSchedulerAction_correct: definition "absExst s \ \work_units_completed_internal = ksWorkUnitsCompleted s, + scheduler_action_internal = absSchedulerAction (ksSchedulerAction s), + ekheap_internal = absEkheap (ksPSpace s), + domain_list_internal = ksDomSchedule s, + domain_index_internal = ksDomScheduleIdx s, + cur_domain_internal = ksCurDomain s, + domain_time_internal = ksDomainTime s, + ready_queues_internal = (\d p. heap_walk (tcbSchedNexts_of s) (tcbQueueHead (ksReadyQueues s (d, p))) []), cdt_list_internal = absCDTList (cteMap (gsCNodes s)) (ctes_of s)\" lemma absExst_correct: @@ -1742,11 +1810,15 @@ lemma absExst_correct: assumes rel: "(s, s') \ state_relation" shows "absExst s' = exst s" apply (rule det_ext.equality) - using rel invs invs' - apply (simp_all add: absExst_def absSchedulerAction_correct - absCDTList_correct[THEN fun_cong] state_relation_def invs_def valid_state_def - ready_queues_relation_def invs'_def - valid_pspace_def valid_sched_def valid_pspace'_def curry_def fun_eq_iff) + using rel invs invs' + apply (simp_all add: absExst_def absSchedulerAction_correct absEkheap_correct + absCDTList_correct[THEN fun_cong] state_relation_def invs_def + valid_state_def ready_queues_relation_def ready_queue_relation_def + invs'_def valid_state'_def + valid_pspace_def valid_sched_def valid_pspace'_def curry_def + fun_eq_iff) + apply (fastforce simp: absEkheap_correct) + apply (fastforce simp: list_queue_relation_def Let_def dest: heap_ls_is_walk) done @@ -1756,17 +1828,6 @@ definition cdt = absCDT (cteMap (gsCNodes s)) (ctes_of s), is_original_cap = absIsOriginalCap (cteMap (gsCNodes s)) (ksPSpace s), cur_thread = ksCurThread s, idle_thread = ksIdleThread s, - consumed_time = ksConsumedTime s, - cur_time = ksCurTime s, - cur_sc = ksCurSc s, - reprogram_timer = ksReprogramTimer s, - scheduler_action = absSchedulerAction (ksSchedulerAction s), - domain_list = ksDomSchedule s, - domain_index = ksDomScheduleIdx s, - cur_domain = ksCurDomain s, - domain_time = ksDomainTime s, - ready_queues = curry (ksReadyQueues s), - release_queue = ksReleaseQueue s, machine_state = observable_memory (ksMachineState s) (user_mem' s), interrupt_irq_node = absInterruptIRQNode (ksInterruptState s), interrupt_states = absInterruptStates (ksInterruptState s), diff --git a/proof/refine/ARM/ArchAcc_R.thy b/proof/refine/ARM/ArchAcc_R.thy index b8eeb52b8e..f1b1ebb412 100644 --- a/proof/refine/ARM/ArchAcc_R.thy +++ b/proof/refine/ARM/ArchAcc_R.thy @@ -26,7 +26,7 @@ method simp_to_elim = (drule fun_all, elim allE impE) end -context Arch begin global_naming ARM_A (*FIXME: arch_split*) +context Arch begin global_naming ARM_A (*FIXME: arch-split*) lemma asid_pool_at_ko: "asid_pool_at p s \ \pool. ko_at (ArchObj (ARM_A.ASIDPool pool)) p s" @@ -43,107 +43,38 @@ lemmas valid_arch_state_elims[rule_format, elim!] = conjuncts lemmas valid_vspace_obj_elims [rule_format, elim!] = valid_vspace_obj.simps[@simp_to_elim, @ \(drule bspec)?\] -lemmas Arch_objBits_simps' = pteBits_def pdeBits_def pageBits_def objBits_simps - -sublocale setObject_pte: simple_non_tcb_non_sc_non_reply_ko' "setObject :: _ \ pte \ _" getObject - by (unfold_locales, - simp add: projectKO_opts_defs archObjSize_def Arch_objBits_simps' | wp)+ - -sublocale setObject_pde: simple_non_tcb_non_sc_non_reply_ko' "setObject :: _ \ pde \ _" getObject - by (unfold_locales, - simp add: projectKO_opts_defs archObjSize_def Arch_objBits_simps' | wp)+ - -sublocale setObject_asidpool: simple_non_tcb_non_sc_non_reply_ko' "setObject :: _ \ asidpool \ _" getObject - by (unfold_locales, - simp add: projectKO_opts_defs archObjSize_def Arch_objBits_simps' | wp)+ - -sublocale storePDE: simple_non_tcb_non_sc_non_reply_ko' "storePDE" getObject - by (unfold_locales, - simp add: storePDE_def projectKO_opts_defs archObjSize_def Arch_objBits_simps' | wp)+ - -sublocale storePTE: simple_non_tcb_non_sc_non_reply_ko' "storePTE" getObject - by (unfold_locales, - simp add: storePTE_def projectKO_opts_defs archObjSize_def Arch_objBits_simps' | wp)+ - -lemmas storePTE_valid_objs'[wp] = - storePTE.valid_objs'[simplified valid_obj'_def pred_conj_def, simplified] -lemmas storePTE_valid_pspace'[wp] = - storePTE.valid_pspace'[simplified valid_obj'_def pred_conj_def, simplified] +end -lemmas storePDE_valid_objs'[wp] = - storePDE.valid_objs'[simplified valid_obj'_def pred_conj_def, simplified] -lemmas storePDE_valid_pspace'[wp] = - storePDE.valid_pspace'[simplified valid_obj'_def pred_conj_def, simplified] +context begin interpretation Arch . (*FIXME: arch-split*) -end +(*FIXME move *) -context begin interpretation Arch . (*FIXME: arch_split*) - -method readObject_arch_obj_at'_method - = clarsimp simp: readObject_def obind_def omonad_defs split_def loadObject_default_def obj_at'_def - objBits_simps archObjSize_def projectKOs bit_simps' typ_at_to_obj_at_arches - split: option.splits if_split_asm - -lemma readObject_misc_arch_ko_at'[simp, dest!]: - shows - readObject_ko_at'_pte: "readObject p s = Some (pte :: pte) \ ko_at' pte p s" and - readObject_ko_at'_pde: "readObject p s = Some (pde :: pde) \ ko_at' pde p s" and - readObject_ko_at'_asidpool: "readObject p s = Some (asidp :: asidpool) \ ko_at' asidp p s" - by readObject_arch_obj_at'_method+ - - -lemma readObject_misc_arch_obj_at'[simp]: - shows - readObject_pte_at'[simplified]: "bound (readObject p s ::pte option) \ pte_at' p s" and - readObject_pde_at'[simplified]: "bound (readObject p s ::pde option) \ pde_at' p s" and - readObject_asid_pool_at'[simplified]: "bound (readObject p s ::asidpool option) \ asid_pool_at' p s" - by readObject_arch_obj_at'_method+ - -method no_ofail_readObject_method = - clarsimp simp: obj_at'_def readObject_def obind_def omonad_defs split_def projectKO_eq no_ofail_def, - rule ps_clear_lookupAround2, assumption+, simp, - blast intro: is_aligned_no_overflow, - clarsimp simp: bit_simps' project_inject obj_at_simps lookupAround2_known1 split: option.splits - -lemma no_ofail_arch_obj_at'_readObject_pte[simp]: - "no_ofail (obj_at' (P::pte \ bool) p) (readObject p::pte kernel_r)" - by no_ofail_readObject_method - -lemma no_ofail_arch_obj_at'_readObject_pde[simp]: - "no_ofail (obj_at' (P::pde \ bool) p) (readObject p::pde kernel_r)" - by no_ofail_readObject_method - -lemma no_ofail_arch_obj_at'_readObject_asidpool[simp]: - "no_ofail (obj_at' (P::asidpool \ bool) p) (readObject p::asidpool kernel_r)" - by no_ofail_readObject_method - -lemma no_ofail_arch_misc_readObject: - shows - no_ofail_pte_at'_readObject[simp]: "no_ofail (pte_at' p) (readObject p::pte kernel_r)" and - no_ofail_pde_at'_readObject[simp]: "no_ofail (pde_at' p) (readObject p::pde kernel_r)" and - no_ofail_asidpool_at'_readObject[simp]: "no_ofail (asid_pool_at' p) (readObject p::asidpool kernel_r)" - by (clarsimp simp: typ_at_to_obj_at_arches no_ofail_def - dest!: no_ofailD[OF no_ofail_arch_obj_at'_readObject_pte] - no_ofailD[OF no_ofail_arch_obj_at'_readObject_pde] - no_ofailD[OF no_ofail_arch_obj_at'_readObject_asidpool])+ - -(* aliases for compatibility with master *) - -lemmas getPTE_wp = setObject_pte.get_wp -lemmas getPDE_wp = setObject_pde.get_wp -lemmas getASID_wp = setObject_asidpool.getObject_wp - -lemmas getObject_pte_inv[wp] = setObject_pte.getObject_inv -lemmas getObject_pde_inv[wp] = setObject_pde.getObject_inv -lemmas getObject_asidpool_inv = setObject_asidpool.getObject_inv - -lemmas get_pte_sp' = setObject_pte.getObject_sp' -lemmas get_pde_sp' = setObject_pde.getObject_sp' -lemmas get_asidpool_sp' = setObject_asidpool.getObject_sp' - -lemmas setObject_ASID_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF setObject_asidpool.ctes_of] -lemmas storePTE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePTE.ctes_of] -lemmas storePDE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePDE.ctes_of] +lemma pspace_relation_None: + "\pspace_relation p p'; p' ptr = None \ \ p ptr = None" + apply (rule not_Some_eq[THEN iffD1, OF allI, OF notI]) + apply (drule(1) pspace_relation_absD) + apply (case_tac y; clarsimp simp: cte_map_def of_bl_def well_formed_cnode_n_def split: if_splits) + subgoal for n + apply (drule spec[of _ ptr]) + apply (drule spec) + apply clarsimp + apply (drule spec[of _ "replicate n False"]) + apply (drule mp[OF _ refl]) + apply (drule mp) + subgoal premises by (induct n; simp) + apply clarsimp + done + subgoal for x + apply (cases x; clarsimp) + apply ((drule spec[of _ 0], fastforce)+)[2] + apply (drule spec[of _ ptr]) + apply (drule spec) + apply clarsimp + apply (drule mp[OF _ refl]) + apply (drule spec[of _ 0]) + subgoal for _ sz by (cases sz; simp add: pageBits_def) + done + done lemma no_0_obj'_abstract: "(s, s') \ state_relation \ no_0_obj' s' \ kheap s 0 = None" @@ -161,198 +92,46 @@ lemma asid_low_bits [simp]: "asidLowBits = asid_low_bits" by (simp add: asid_low_bits_def asidLowBits_def) -lemma pte_at_cross: - "\ pte_at p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s; pspace_distinct s \ - \ pte_at' p s'" - apply (drule (2) pspace_distinct_cross) - apply (clarsimp simp: pte_at_def obj_at_def typ_at'_def ko_wp_at'_def) - apply (prop_tac "p \ pspace_dom (kheap s)") - apply (clarsimp simp: pspace_dom_def) - apply (rule bexI) - prefer 2 - apply fastforce - apply (clarsimp simp: ran_def image_iff) - apply (rule_tac x="(UCAST(32 \ 8) (p && mask pt_bits >> 2))" in exI) - apply (simp add: mask_pt_bits_inner_beauty) - apply (clarsimp simp: pspace_relation_def) - apply (drule bspec, fastforce) - apply (clarsimp simp:) - apply (clarsimp simp: pte_relation_def) - apply (drule spec[where x="(UCAST(32 \ 8) (p && mask pt_bits >> 2))"]) - apply (clarsimp) - apply (simp add: mask_pt_bits_inner_beauty) - apply (clarsimp simp: objBitsKO_def archObjSize_def pteBits_def) - apply (clarsimp simp: pte_relation_aligned_def) - apply (frule (1) pspace_distinctD') - apply (clarsimp simp: objBitsKO_def archObjSize_def pteBits_def word_bits_def) - done - -lemma pde_at_cross: - "\ pde_at p s; pspace_relation (kheap s) (ksPSpace s'); pspace_aligned s; pspace_distinct s \ - \ pde_at' p s'" - apply (drule (2) pspace_distinct_cross) - apply (clarsimp simp: pde_at_def obj_at_def typ_at'_def ko_wp_at'_def) - apply (prop_tac "p \ pspace_dom (kheap s)") - apply (clarsimp simp: pspace_dom_def) - apply (rule bexI) - prefer 2 - apply fastforce - apply (clarsimp simp: ran_def image_iff) - apply (rule_tac x="(UCAST(32 \ 12) (p && mask pd_bits >> 2))" in exI) - apply (simp add: mask_pd_bits_inner_beauty) - apply (clarsimp simp: pspace_relation_def) - apply (drule bspec, fastforce) - apply (clarsimp simp:) - apply (clarsimp simp: pde_relation_def) - apply (drule spec[where x="(UCAST(32 \ 12) (p && mask pd_bits >> 2))"]) - apply (clarsimp) - apply (simp add: mask_pd_bits_inner_beauty) - apply (clarsimp simp: objBitsKO_def archObjSize_def pdeBits_def) - apply (clarsimp simp: pde_relation_aligned_def) - apply (frule (1) pspace_distinctD') - apply (clarsimp simp: objBitsKO_def archObjSize_def pdeBits_def word_bits_def) - done - -lemma asid_pool_at_cross: - "\ asid_pool_at p s; pspace_relation (kheap s) (ksPSpace s'); - pspace_aligned s; pspace_distinct s \ - \ asid_pool_at' p s'" - apply (drule (2) pspace_distinct_cross) - apply (clarsimp simp: obj_at_def typ_at'_def ko_wp_at'_def) - apply (prop_tac "p \ pspace_dom (kheap s)") - apply (clarsimp simp: pspace_dom_def) - apply (rule bexI) - prefer 2 - apply fastforce - apply clarsimp - apply (clarsimp simp: pspace_relation_def) - apply (drule bspec, fastforce) - apply (clarsimp simp: other_obj_relation_def split: kernel_object.splits arch_kernel_object.splits) - apply (clarsimp simp: objBits_simps) - apply (frule (1) pspace_alignedD) - apply (rule conjI, simp add: bit_simps archObjSize_def) - apply (clarsimp simp: pspace_distinct'_def) - apply (drule bspec, fastforce) - apply (simp add: objBits_simps archObjSize_def pageBits_def word_bits_def) - done - -lemma pte_relation_must_pte: - "pte_relation m (ArchObj (PageTable pt)) ko \ \pte. ko = (KOArch (KOPTE pte))" - apply (case_tac ko) - apply (simp_all add:pte_relation_def) - apply clarsimp - done - -lemma is_aligned_pte_offset: - "is_aligned pt_ptr pt_bits \ - is_aligned (pt_ptr + (i << pt_bits)) pt_bits" - apply (rule is_aligned_add) - apply (erule is_aligned_weaken, simp) - apply (simp add: is_aligned_shiftl) - done - -lemma page_table_at_cross: - "\ page_table_at p s; pspace_aligned s; pspace_distinct s; pspace_relation (kheap s) (ksPSpace s') \ \ - page_table_at' p s'" - apply (clarsimp simp: page_table_at'_def) - apply (rule context_conjI) - apply (clarsimp simp: obj_at_def) - apply (frule (1) pspace_alignedD) - apply (simp add: bit_simps') - apply clarsimp - apply (rule pte_at_cross; assumption?) - apply (clarsimp simp: obj_at_def pte_at_def is_aligned_pte_offset pt_bits_def pageBits_def) - apply (intro conjI) - apply (rule_tac x="ArchObj (PageTable pt)" in exI) - apply (intro conjI) - apply (subgoal_tac "p + (y << 2) && ~~ mask 10 = p", simp) - apply (subst is_aligned_mask_out_add_eq) - apply (clarsimp simp: obj_at_def pte_at_def is_aligned_pte_offset ptBits_def pteBits_def) - apply clarsimp - defer - apply (clarsimp simp: a_type_def) - apply (rule is_aligned_add) - apply (erule is_aligned_weaken) - apply (clarsimp simp: ptBits_def) - apply (clarsimp simp: is_aligned_shift) - apply (simp add: and_mask_0_iff_le_mask) - apply (rule le_mask_shiftl_le_mask[where n=8]; simp add: mask_def) - apply (frule word_less_sub_1, simp) - done - -lemma page_directory_at_cross: - "\ page_directory_at p s; pspace_aligned s; pspace_distinct s; pspace_relation (kheap s) (ksPSpace s') \ \ - page_directory_at' p s'" - apply (clarsimp simp: page_directory_at'_def) - apply (rule context_conjI) - apply (clarsimp simp: obj_at_def) - apply (frule (1) pspace_alignedD) - apply (simp add: bit_simps') - apply clarsimp - apply (rule pde_at_cross; assumption?) - apply (clarsimp simp: obj_at_def pde_at_def is_aligned_pte_offset pdBits_def pdeBits_def pd_bits_def pageBits_def) - apply (intro conjI) - apply (rule_tac x="ArchObj (PageDirectory pd)" in exI) - apply (intro conjI) - apply (subgoal_tac "p + (y << 2) && ~~ mask 14 = p", simp) - apply (subst is_aligned_mask_out_add_eq) - apply (clarsimp simp: obj_at_def pte_at_def is_aligned_pte_offset pdBits_def pdeBits_def) - apply clarsimp - defer - apply (clarsimp simp: a_type_def) - apply (rule is_aligned_add) - apply (erule is_aligned_weaken) - apply (clarsimp simp: ptBits_def) - apply (clarsimp simp: is_aligned_shift) - apply (simp add: and_mask_0_iff_le_mask) - apply (rule le_mask_shiftl_le_mask[where n=12]; simp add: mask_def) - apply (frule word_less_sub_1, simp) - done - -lemma corres_cross_over_asid_pool_at: - "\ \s. P s \ asid_pool_at p s \ pspace_distinct s \ pspace_aligned s; - corres r P (Q and asid_pool_at' p) f g \ \ - corres r P Q f g" - apply (rule corres_cross_over_guard[where Q="Q and asid_pool_at' p"]) - apply (drule meta_spec, drule (1) meta_mp, clarsimp) - apply (erule asid_pool_at_cross, clarsimp simp: state_relation_def; assumption) - apply assumption - done - -lemma corres_cross_over_pte_at: - "\ \s. P s \ pte_at p s \ pspace_distinct s \ pspace_aligned s; - corres r P (P' and pte_at' p) f g\ \ - corres r P P' f g" - apply (rule corres_cross_over_guard[where Q="P' and pte_at' p"]) - apply (drule meta_spec, drule (1) meta_mp, clarsimp) - apply (erule pte_at_cross; assumption?) - apply (simp add: state_relation_def) - apply assumption - done - - lemma getObject_ASIDPool_corres [corres]: "p = p' \ corres (\p p'. p = inv ASIDPool p' o ucast) (asid_pool_at p) (asid_pool_at' p') (get_asid_pool p) (getObject p')" apply (simp add: getObject_def get_asid_pool_def get_object_def split_def) apply (rule corres_no_failI) - apply wp - apply (fastforce simp: typ_at_to_obj_at_arches - dest: no_ofailD[OF no_ofail_asidpool_at'_readObject]) - apply (clarsimp simp: in_monad loadObject_default_def projectKOs gets_the_def) + apply (rule no_fail_pre, wp) + apply (clarsimp simp: typ_at'_def ko_wp_at'_def) + apply (case_tac ko; simp) + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object, simp_all)[1] + apply (clarsimp simp: lookupAround2_known1 + projectKOs) + apply (clarsimp simp: obj_at'_def projectKOs objBits_simps + archObjSize_def) + apply (erule (1) ps_clear_lookupAround2) + apply simp + apply (erule is_aligned_no_overflow) + apply simp + apply (clarsimp simp add: objBits_simps archObjSize_def + split: option.split) + apply (clarsimp simp: in_monad loadObject_default_def projectKOs) apply (simp add: bind_assoc exec_gets) apply (drule asid_pool_at_ko) apply (clarsimp simp: obj_at_def) apply (simp add: return_def) + apply (simp add: in_magnitude_check objBits_simps + archObjSize_def pageBits_def) apply (clarsimp simp: state_relation_def pspace_relation_def) apply (drule bspec, blast) - apply (clarsimp simp: other_obj_relation_def asid_pool_relation_def obj_at'_def projectKOs) + apply (clarsimp simp: other_obj_relation_def asid_pool_relation_def) done +lemmas aligned_distinct_asid_pool_atI' + = aligned_distinct_obj_atI'[where 'a=asidpool, + simplified, OF _ _ _ refl] + lemma aligned_distinct_relation_asid_pool_atI'[elim]: "\ asid_pool_at p s; pspace_relation (kheap s) (ksPSpace s'); - pspace_aligned' s'; pspace_distinct' s'\ + pspace_aligned' s'; pspace_distinct' s' \ \ asid_pool_at' p s'" apply (drule asid_pool_at_ko) apply (clarsimp simp add: obj_at_def) @@ -360,7 +139,7 @@ lemma aligned_distinct_relation_asid_pool_atI'[elim]: apply (clarsimp simp: other_obj_relation_def) apply (simp split: Structures_H.kernel_object.split_asm arch_kernel_object.split_asm) - apply (drule (2) aligned'_distinct'_ko_at'I[where 'a=asidpool]; fastforce?) + apply (drule(2) aligned_distinct_asid_pool_atI') apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def projectKOs) done @@ -369,22 +148,38 @@ lemma getObject_ASIDPool_corres': "corres (\p p'. p = inv ASIDPool p' o ucast) (asid_pool_at p) (pspace_aligned' and pspace_distinct') (get_asid_pool p) (getObject p)" - by (corresKsimp search: getObject_ASIDPool_corres) fastforce - -lemma setObject_asidpool_replies_of'[wp]: - "setObject c (asidpool::asidpool) \\s. P' (replies_of' s)\" - by setObject_easy_cases - -lemma setObject_pte_replies_of'[wp]: - "setObject c (pte::pte) \\s. P' (replies_of' s)\" - by setObject_easy_cases + apply (rule stronger_corres_guard_imp, + rule getObject_ASIDPool_corres) + apply auto + done -lemma setObject_pde_replies_of'[wp]: - "setObject c (pde::pde) \\s. P' (replies_of' s)\" - by setObject_easy_cases +lemma storePDE_cte_wp_at'[wp]: + "\\s. P (cte_wp_at' P' p s)\ + storePDE ptr val + \\rv s. P (cte_wp_at' P' p s)\" + apply (simp add: storePDE_def) + apply (wp setObject_cte_wp_at2'[where Q="\"]) + apply (clarsimp simp: updateObject_default_def in_monad + projectKO_opts_defs projectKOs) + apply (rule equals0I) + apply (clarsimp simp: updateObject_default_def in_monad + projectKOs projectKO_opts_defs) + apply simp + done -crunch storePDE, storePTE - for replies_of'[wp]: "\s. P (replies_of' s)" +lemma storePTE_cte_wp_at'[wp]: + "\\s. P (cte_wp_at' P' p s)\ + storePTE ptr val + \\rv s. P (cte_wp_at' P' p s)\" + apply (simp add: storePTE_def) + apply (wp setObject_cte_wp_at2'[where Q="\"]) + apply (clarsimp simp: updateObject_default_def in_monad + projectKO_opts_defs projectKOs) + apply (rule equals0I) + apply (clarsimp simp: updateObject_default_def in_monad + projectKOs projectKO_opts_defs) + apply simp + done crunch setIRQState for cte_wp_at'[wp]: "\s. P (cte_wp_at' P' p s)" @@ -393,7 +188,7 @@ crunch getIRQSlot lemma setObject_ASIDPool_corres [corres]: "p = p' \ a = inv ASIDPool a' o ucast \ - corres dc (asid_pool_at p) (asid_pool_at' p') + corres dc (asid_pool_at p and valid_etcbs) (asid_pool_at' p') (set_asid_pool p a) (setObject p' a')" apply (simp add: set_asid_pool_def) apply (corresKsimp search: setObject_other_corres[where P="\_. True"] @@ -405,7 +200,7 @@ lemma setObject_ASIDPool_corres [corres]: lemma setObject_ASIDPool_corres': "a = inv ASIDPool a' o ucast \ - corres dc (asid_pool_at p) (pspace_aligned' and pspace_distinct') + corres dc (asid_pool_at p and valid_etcbs) (pspace_aligned' and pspace_distinct') (set_asid_pool p a) (setObject p a')" apply (rule stronger_corres_guard_imp[OF setObject_ASIDPool_corres]) apply auto @@ -423,15 +218,23 @@ lemma getObject_PDE_corres [corres]: (get_pde p) (getObject p')" apply (simp add: getObject_def get_pde_def get_pd_def get_object_def split_def bind_assoc) apply (rule corres_no_failI) - apply wp - apply (fastforce simp: typ_at_to_obj_at_arches dest: no_ofailD[OF no_ofail_pde_at'_readObject]) + apply (rule no_fail_pre, wp) + apply (clarsimp simp: ko_wp_at'_def typ_at'_def lookupAround2_known1) + apply (case_tac ko; simp) + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object; simp add: projectKOs) + apply (clarsimp simp: objBits_def cong: option.case_cong) + apply (erule (1) ps_clear_lookupAround2) + apply simp + apply (erule is_aligned_no_overflow) + apply (simp add: objBits_simps archObjSize_def word_bits_def) apply simp - apply (clarsimp simp: in_monad loadObject_default_def projectKOs gets_the_def) + apply (clarsimp simp: in_monad loadObject_default_def projectKOs) apply (simp add: bind_assoc exec_gets) apply (clarsimp simp: pde_at_def obj_at_def) apply (clarsimp simp add: a_type_def return_def split: if_split_asm Structures_A.kernel_object.splits arch_kernel_obj.splits) - apply (clarsimp simp: obj_at'_def projectKOs) + apply (clarsimp simp: typ_at'_def ko_wp_at'_def) apply (simp add: in_magnitude_check objBits_simps archObjSize_def pageBits_def pdeBits_def) apply (clarsimp simp: state_relation_def pspace_relation_def) apply (drule bspec, blast) @@ -442,8 +245,8 @@ lemma getObject_PDE_corres [corres]: done lemmas aligned_distinct_pde_atI' - = aligned'_distinct'_ko_at'I[where 'a=pde, - simplified, OF _ _ _ _ refl] + = aligned_distinct_obj_atI'[where 'a=pde, + simplified, OF _ _ _ refl] lemma aligned_distinct_relation_pde_atI'[elim]: "\ pde_at p s; pspace_relation (kheap s) (ksPSpace s'); @@ -467,7 +270,7 @@ lemma aligned_distinct_relation_pde_atI'[elim]: apply (subst(asm) add.commute, subst(asm) word_plus_and_or_coroll2) apply (clarsimp simp: pde_relation_def) - apply (drule(2) aligned_distinct_pde_atI', simp) + apply (drule(2) aligned_distinct_pde_atI') apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def projectKOs) done @@ -503,10 +306,19 @@ lemma get_master_pde_corres [@lift_corres_args, corres]: apply (simp add: getObject_def get_pde_def get_pd_def get_object_def split_def bind_assoc pde_relation_aligned_def get_master_pde_def) apply (rule corres_no_failI) - apply wp - apply (fastforce simp: typ_at_to_obj_at_arches dest: no_ofailD[OF no_ofail_pde_at'_readObject]) - apply (clarsimp simp: in_monad loadObject_default_def gets_the_def - projectKOs and_not_mask_twice) + apply (rule no_fail_pre, wp) + apply (clarsimp simp: ko_wp_at'_def typ_at'_def lookupAround2_known1) + apply (case_tac ko, simp_all)[1] + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object, simp_all add: projectKOs)[1] + apply (clarsimp simp: objBits_def cong: option.case_cong) + apply (erule (1) ps_clear_lookupAround2) + apply simp + apply (erule is_aligned_no_overflow) + apply (simp add: objBits_simps archObjSize_def word_bits_def) + apply simp + apply (clarsimp simp: in_monad loadObject_default_def + projectKOs and_not_mask_twice) apply (simp add: bind_assoc exec_gets) apply (clarsimp simp: pde_at_def obj_at_def) apply (clarsimp split:ARM_A.pde.splits) @@ -515,14 +327,14 @@ lemma get_master_pde_corres [@lift_corres_args, corres]: apply (clarsimp simp add: a_type_def return_def get_pd_def bind_def get_pde_def get_object_def gets_def get_def split: if_split_asm Structures_A.kernel_object.splits arch_kernel_obj.splits) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (clarsimp simp: objBits_simps archObjSize_def pageBits_def pdeBits_def) + apply (clarsimp simp:typ_at'_def ko_wp_at'_def) + apply (clarsimp simp: in_magnitude_check objBits_simps archObjSize_def pageBits_def pdeBits_def) apply (clarsimp simp:state_relation_def) apply (frule_tac x = "(ucast (p && mask pd_bits >> 2))" in pde_relation_alignedD) apply assumption apply (simp add:mask_pd_bits_inner_beauty) - apply (clarsimp simp: pde_relation_aligned_def gets_the_def exec_gets return_def + apply (clarsimp simp: pde_relation_aligned_def split: if_splits ARM_H.pde.splits) apply (drule_tac p' = "p && ~~ mask 6" in valid_duplicates'_D[rotated]) apply (simp add:is_aligned_neg_mask is_aligned_weaken[where y = 2]) @@ -542,13 +354,13 @@ lemma get_master_pde_corres [@lift_corres_args, corres]: apply (clarsimp simp add: a_type_def return_def get_pd_def bind_def get_pde_def get_object_def gets_def get_def split: if_split_asm Structures_A.kernel_object.splits arch_kernel_obj.splits) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (clarsimp simp: objBits_simps archObjSize_def pageBits_def pdeBits_def) + apply (clarsimp simp:typ_at'_def ko_wp_at'_def) + apply (clarsimp simp: in_magnitude_check objBits_simps archObjSize_def pageBits_def pdeBits_def) apply (clarsimp simp:state_relation_def) apply (frule_tac x = "(ucast (p && mask pd_bits >> 2))" in pde_relation_alignedD) apply assumption apply (simp add:mask_pd_bits_inner_beauty) - apply (clarsimp simp:pde_relation_aligned_def gets_the_def exec_gets return_def + apply (clarsimp simp:pde_relation_aligned_def split:if_splits ARM_H.pde.splits) apply (drule_tac p' = "p && ~~ mask 6" in valid_duplicates'_D[rotated]) apply (simp add:is_aligned_neg_mask is_aligned_weaken[where y = 2]) @@ -566,13 +378,13 @@ lemma get_master_pde_corres [@lift_corres_args, corres]: apply (clarsimp simp add: a_type_def return_def get_pd_def bind_def get_pde_def get_object_def gets_def get_def split: if_split_asm Structures_A.kernel_object.splits arch_kernel_obj.splits) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (clarsimp simp: objBits_simps archObjSize_def pageBits_def pdeBits_def) + apply (clarsimp simp:typ_at'_def ko_wp_at'_def) + apply (clarsimp simp: in_magnitude_check objBits_simps archObjSize_def pageBits_def pdeBits_def) apply (clarsimp simp:state_relation_def) apply (frule_tac x = "(ucast (p && mask pd_bits >> 2))" in pde_relation_alignedD) apply assumption apply (simp add:mask_pd_bits_inner_beauty) - apply (clarsimp simp:pde_relation_aligned_def gets_the_def exec_gets return_def + apply (clarsimp simp:pde_relation_aligned_def split:if_splits ARM_H.pde.splits) apply (drule_tac p' = "p && ~~ mask 6" in valid_duplicates'_D[rotated]) apply (simp add:is_aligned_neg_mask is_aligned_weaken[where y = 2]) @@ -590,8 +402,8 @@ lemma get_master_pde_corres [@lift_corres_args, corres]: apply (clarsimp simp add: a_type_def return_def get_pd_def bind_def get_pde_def get_object_def gets_def get_def split: if_split_asm Structures_A.kernel_object.splits arch_kernel_obj.splits) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (clarsimp simp: objBits_simps archObjSize_def pageBits_def pdeBits_def) + apply (clarsimp simp:typ_at'_def ko_wp_at'_def) + apply (clarsimp simp: in_magnitude_check objBits_simps archObjSize_def pageBits_def pdeBits_def) apply (clarsimp simp:state_relation_def) apply (drule_tac s = a and s' = b and p = "p && ~~ mask 6" in aligned_distinct_relation_pde_atI'[rotated -1]) @@ -657,16 +469,24 @@ lemma getObject_PTE_corres [corres]: (get_pte p) (getObject p')" apply (simp add: getObject_def get_pte_def get_pt_def get_object_def split_def bind_assoc) apply (rule corres_no_failI) - apply wp - apply (fastforce simp: typ_at_to_obj_at_arches dest: no_ofailD[OF no_ofail_pte_at'_readObject]) + apply (rule no_fail_pre, wp) + apply (clarsimp simp: ko_wp_at'_def typ_at'_def lookupAround2_known1) + apply (case_tac ko, simp_all)[1] + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object, simp_all add: projectKOs)[1] + apply (clarsimp simp: objBits_def cong: option.case_cong) + apply (erule (1) ps_clear_lookupAround2) + apply simp + apply (erule is_aligned_no_overflow) + apply (simp add: objBits_simps archObjSize_def word_bits_def) apply simp apply (clarsimp simp: in_monad loadObject_default_def projectKOs) - apply (simp add: bind_assoc exec_gets gets_the_def) + apply (simp add: bind_assoc exec_gets) apply (clarsimp simp: obj_at_def pte_at_def) apply (clarsimp simp add: a_type_def return_def split: if_split_asm Structures_A.kernel_object.splits arch_kernel_obj.splits) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (simp add: objBits_simps archObjSize_def pageBits_def pteBits_def) + apply (clarsimp simp: typ_at'_def ko_wp_at'_def) + apply (simp add: in_magnitude_check objBits_simps archObjSize_def pageBits_def pteBits_def) apply (clarsimp simp: state_relation_def pspace_relation_def) apply (drule bspec, blast) apply (clarsimp simp: other_obj_relation_def pte_relation_def) @@ -688,8 +508,8 @@ lemma pte_relation_alignedD: done lemmas aligned_distinct_pte_atI' - = aligned'_distinct'_ko_at'I[where 'a=pte, - simplified, OF _ _ _ _ refl] + = aligned_distinct_obj_atI'[where 'a=pte, + simplified, OF _ _ _ refl] lemma aligned_distinct_relation_pte_atI'[elim]: "\ pte_at p s; pspace_relation (kheap s) (ksPSpace s'); @@ -713,7 +533,7 @@ lemma aligned_distinct_relation_pte_atI'[elim]: apply (subst(asm) add.commute, subst(asm) word_plus_and_or_coroll2) apply (clarsimp simp: pte_relation_def) - apply (drule(2) aligned_distinct_pte_atI', simp) + apply (drule(2) aligned_distinct_pte_atI') apply (clarsimp simp: obj_at'_def typ_at'_def ko_wp_at'_def projectKOs) done @@ -736,11 +556,19 @@ lemma get_master_pte_corres [@lift_corres_args, corres]: apply (simp add: getObject_def get_pte_def get_pt_def get_object_def split_def bind_assoc pte_relation_aligned_def get_master_pte_def) apply (rule corres_no_failI) - apply wp - apply (fastforce simp: typ_at_to_obj_at_arches dest: no_ofailD[OF no_ofail_pte_at'_readObject]) + apply (rule no_fail_pre, wp) + apply (clarsimp simp: ko_wp_at'_def typ_at'_def lookupAround2_known1) + apply (case_tac ko, simp_all)[1] + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object, simp_all add: projectKOs)[1] + apply (clarsimp simp: objBits_def cong: option.case_cong) + apply (erule (1) ps_clear_lookupAround2) + apply simp + apply (erule is_aligned_no_overflow) + apply (simp add: objBits_simps archObjSize_def word_bits_def) apply simp apply (clarsimp simp: in_monad loadObject_default_def - projectKOs and_not_mask_twice gets_the_def) + projectKOs and_not_mask_twice) apply (simp add: bind_assoc exec_gets) apply (clarsimp simp: pte_at_def obj_at_def) apply (clarsimp split:ARM_A.pte.splits) @@ -749,13 +577,13 @@ lemma get_master_pte_corres [@lift_corres_args, corres]: apply (clarsimp simp add: a_type_def return_def get_pt_def bind_def get_pte_def get_object_def gets_def get_def split: if_split_asm Structures_A.kernel_object.splits arch_kernel_obj.splits) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (clarsimp simp: objBits_simps archObjSize_def pageBits_def pteBits_def) + apply (clarsimp simp:typ_at'_def ko_wp_at'_def) + apply (clarsimp simp: in_magnitude_check objBits_simps archObjSize_def pageBits_def pteBits_def) apply (clarsimp simp:state_relation_def) apply (frule_tac x = "(ucast (p && mask pt_bits >> 2))" in pte_relation_alignedD) apply assumption apply (simp add:mask_pt_bits_inner_beauty) - apply (clarsimp simp:pte_relation_aligned_def gets_the_def exec_gets return_def + apply (clarsimp simp:pte_relation_aligned_def split:if_splits ARM_H.pte.splits) apply (drule_tac p' = "p && ~~ mask 6" in valid_duplicates'_D[rotated]) apply (simp add:is_aligned_weaken[where y = 2] is_aligned_neg_mask) @@ -773,8 +601,8 @@ lemma get_master_pte_corres [@lift_corres_args, corres]: apply (clarsimp simp add: a_type_def return_def get_pt_def bind_def get_pte_def get_object_def gets_def get_def split: if_split_asm Structures_A.kernel_object.splits arch_kernel_obj.splits) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (clarsimp simp: objBits_simps archObjSize_def pageBits_def pteBits_def) + apply (clarsimp simp:typ_at'_def ko_wp_at'_def) + apply (clarsimp simp: in_magnitude_check objBits_simps archObjSize_def pageBits_def pteBits_def) apply (clarsimp simp:state_relation_def) apply (drule_tac s = a and s' = b and p = "p && ~~ mask 6" in aligned_distinct_relation_pte_atI'[rotated -1]) @@ -806,15 +634,15 @@ lemma get_master_pte_corres [@lift_corres_args, corres]: bind_def get_pte_def get_object_def gets_def get_def split: if_split_asm Structures_A.kernel_object.splits arch_kernel_obj.splits) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (clarsimp simp: objBits_simps + apply (clarsimp simp:typ_at'_def ko_wp_at'_def) + apply (clarsimp simp: in_magnitude_check objBits_simps archObjSize_def pageBits_def pteBits_def) apply (clarsimp simp:state_relation_def) apply (frule_tac x = "(ucast (p && mask pt_bits >> 2))" in pte_relation_alignedD) apply assumption apply (simp add:mask_pt_bits_inner_beauty) - apply (clarsimp simp:pte_relation_aligned_def gets_the_def exec_gets return_def + apply (clarsimp simp:pte_relation_aligned_def split:if_splits ARM_H.pte.splits) apply (drule_tac p' = "p && ~~ mask 6" in valid_duplicates'_D[rotated]) apply (simp add:is_aligned_weaken[where y = 2] is_aligned_neg_mask) @@ -858,7 +686,7 @@ lemma get_master_pte_corres': lemma setObject_PD_corres [@lift_corres_args, corres]: "pde_relation_aligned (p>>2) pde pde' \ corres dc (ko_at (ArchObj (PageDirectory pd)) (p && ~~ mask pd_bits) - and pspace_aligned) + and pspace_aligned and valid_etcbs) (pde_at' p) (set_pd (p && ~~ mask pd_bits) (pd(ucast (p && mask pd_bits >> 2) := pde))) (setObject p pde')" @@ -874,8 +702,8 @@ lemma setObject_PD_corres [@lift_corres_args, corres]: apply (simp add: objBits_simps archObjSize_def word_bits_def) apply (clarsimp simp: setObject_def in_monad split_def updateObject_default_def projectKOs) apply (simp add: in_magnitude_check objBits_simps archObjSize_def pageBits_def pdeBits_def) - apply (clarsimp simp: obj_at_def gets_the_def) - apply (clarsimp simp: set_object_def bind_assoc exec_get exec_gets) + apply (clarsimp simp: obj_at_def exec_gets) + apply (clarsimp simp: set_object_def bind_assoc exec_get) apply (clarsimp simp: put_def) apply (clarsimp simp: state_relation_def mask_pd_bits_inner_beauty) apply (rule conjI) @@ -900,7 +728,8 @@ lemma setObject_PD_corres [@lift_corres_args, corres]: apply (drule bspec, assumption) apply clarsimp apply (erule (1) obj_relation_cutsE) - apply (simp+)[4] + apply simp + apply simp apply clarsimp apply (frule (1) pspace_alignedD) apply (drule_tac p=x in pspace_alignedD, assumption) @@ -917,9 +746,13 @@ lemma setObject_PD_corres [@lift_corres_args, corres]: apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.splits arch_kernel_obj.splits) apply (rule conjI) - 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 (rule conjI) + apply (clarsimp simp: ekheap_relation_def pspace_relation_def) + apply (drule(1) ekheap_kheap_dom) + apply clarsimp + apply (drule_tac x=p in bspec, erule domI) + apply (simp add: tcb_relation_cut_def + split: Structures_A.kernel_object.splits) + apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp add: ghost_relation_def) apply (erule_tac x="p && ~~ mask pd_bits" in allE)+ apply fastforce @@ -935,7 +768,7 @@ lemma setObject_PD_corres [@lift_corres_args, corres]: lemma setObject_PT_corres [@lift_corres_args, corres]: "pte_relation_aligned (p >> 2) pte pte' \ corres dc (ko_at (ArchObj (PageTable pt)) (p && ~~ mask pt_bits) - and pspace_aligned) + and pspace_aligned and valid_etcbs) (pte_at' p) (set_pt (p && ~~ mask pt_bits) (pt(ucast (p && mask pt_bits >> 2) := pte))) (setObject p pte')" @@ -951,8 +784,8 @@ lemma setObject_PT_corres [@lift_corres_args, corres]: apply (simp add: objBits_simps archObjSize_def word_bits_def) apply (clarsimp simp: setObject_def in_monad split_def updateObject_default_def projectKOs) apply (simp add: in_magnitude_check objBits_simps archObjSize_def pageBits_def pteBits_def) - apply (clarsimp simp: obj_at_def gets_the_def) - apply (clarsimp simp: set_object_def bind_assoc exec_get exec_gets) + apply (clarsimp simp: obj_at_def exec_gets) + apply (clarsimp simp: set_object_def bind_assoc exec_get) apply (clarsimp simp: put_def) apply (clarsimp simp: state_relation_def mask_pt_bits_inner_beauty) apply (rule conjI) @@ -975,7 +808,7 @@ lemma setObject_PT_corres [@lift_corres_args, corres]: apply (drule bspec, assumption) apply clarsimp apply (erule (1) obj_relation_cutsE) - apply (simp+)[3] + apply simp apply clarsimp apply (frule (1) pspace_alignedD) apply (drule_tac p=x in pspace_alignedD, assumption) @@ -993,9 +826,13 @@ lemma setObject_PT_corres [@lift_corres_args, corres]: apply (simp add: other_obj_relation_def split: Structures_A.kernel_object.splits arch_kernel_obj.splits) apply (rule conjI) - 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 (rule conjI) + apply (clarsimp simp: ekheap_relation_def pspace_relation_def) + apply (drule(1) ekheap_kheap_dom) + apply clarsimp + apply (drule_tac x=p in bspec, erule domI) + apply (simp add: tcb_relation_cut_def + split: Structures_A.kernel_object.splits) + 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 @@ -1011,18 +848,18 @@ lemma setObject_PT_corres [@lift_corres_args, corres]: lemma storePDE_corres [@lift_corres_args, corres]: "pde_relation_aligned (p >> 2) pde pde' \ - corres dc (pde_at p and pspace_aligned) (pde_at' p) (store_pde p pde) (storePDE p pde')" + corres dc (pde_at p and pspace_aligned and valid_etcbs) (pde_at' p) (store_pde p pde) (storePDE p pde')" apply (simp add: store_pde_def storePDE_def) apply (rule corres_symb_exec_l) apply (erule setObject_PD_corres[OF _ refl]) apply (clarsimp simp: exs_valid_def get_pd_def get_object_def exec_gets bind_assoc - obj_at_def pde_at_def gets_the_def) + obj_at_def pde_at_def) apply (clarsimp simp: a_type_def return_def split: Structures_A.kernel_object.splits arch_kernel_obj.splits if_split_asm) apply wp apply clarsimp apply (clarsimp simp: get_pd_def obj_at_def no_fail_def pde_at_def - get_object_def bind_assoc exec_gets gets_the_def) + get_object_def bind_assoc exec_gets) apply (clarsimp simp: a_type_def return_def split: Structures_A.kernel_object.splits arch_kernel_obj.splits if_split_asm) done @@ -1030,7 +867,7 @@ lemma storePDE_corres [@lift_corres_args, corres]: lemma storePDE_corres': "pde_relation_aligned (p >> 2) pde pde' \ corres dc - (pde_at p and pspace_aligned) (pspace_aligned' and pspace_distinct') + (pde_at p and pspace_aligned and valid_etcbs) (pspace_aligned' and pspace_distinct') (store_pde p pde) (storePDE p pde')" apply (rule stronger_corres_guard_imp, rule storePDE_corres) apply auto @@ -1038,25 +875,25 @@ lemma storePDE_corres': lemma storePTE_corres [@lift_corres_args, corres]: "pte_relation_aligned (p>>2) pte pte' \ - corres dc (pte_at p and pspace_aligned) (pte_at' p) (store_pte p pte) (storePTE p pte')" + corres dc (pte_at p and pspace_aligned and valid_etcbs) (pte_at' p) (store_pte p pte) (storePTE p pte')" apply (simp add: store_pte_def storePTE_def) apply (rule corres_symb_exec_l) apply (erule setObject_PT_corres[OF _ refl]) - apply (clarsimp simp: exs_valid_def get_pt_def get_object_def gets_the_def + apply (clarsimp simp: exs_valid_def get_pt_def get_object_def exec_gets bind_assoc obj_at_def pte_at_def) apply (clarsimp simp: a_type_def return_def split: Structures_A.kernel_object.splits arch_kernel_obj.splits if_split_asm) apply wp apply clarsimp apply (clarsimp simp: get_pt_def obj_at_def pte_at_def no_fail_def - get_object_def bind_assoc exec_gets gets_the_def) + get_object_def bind_assoc exec_gets) apply (clarsimp simp: a_type_def return_def split: Structures_A.kernel_object.splits arch_kernel_obj.splits if_split_asm) done lemma storePTE_corres': "pte_relation_aligned (p >> 2) pte pte' \ - corres dc (pte_at p and pspace_aligned) + corres dc (pte_at p and pspace_aligned and valid_etcbs) (pspace_aligned' and pspace_distinct') (store_pte p pte) (storePTE p pte')" apply (rule stronger_corres_guard_imp, rule storePTE_corres) @@ -1073,6 +910,13 @@ defs checkPDAt_def: defs checkPTAt_def: "checkPTAt pt \ stateAssert (page_table_at' pt) []" +lemma pte_relation_must_pte: + "pte_relation m (ArchObj (PageTable pt)) ko \ \pte. ko = (KOArch (KOPTE pte))" + apply (case_tac ko) + apply (simp_all add:pte_relation_def) + apply clarsimp + done + lemma pde_relation_must_pde: "pde_relation m (ArchObj (PageDirectory pd)) ko \ \pde. ko = (KOArch (KOPDE pde))" apply (case_tac ko) @@ -1110,11 +954,12 @@ lemma page_table_at_state_relation: split:if_splits) apply (drule pte_relation_must_pte) apply (drule(1) pspace_distinctD') - apply (clarsimp simp:objBits_simps archObjSize_def word_bits_def pteBits_def) + apply (clarsimp simp:objBits_simps archObjSize_def) apply (rule is_aligned_weaken) apply (erule aligned_add_aligned) apply (rule is_aligned_shiftl_self) - apply simp+ + apply simp + apply (simp add: pteBits_def) done lemma page_directory_at_state_relation: @@ -1145,13 +990,26 @@ lemma page_directory_at_state_relation: apply (clarsimp simp:ucast_ucast_len split:if_splits) apply (drule pde_relation_must_pde) apply (drule(1) pspace_distinctD') - apply (clarsimp simp:objBits_simps archObjSize_def word_bits_def pdeBits_def) + apply (clarsimp simp:objBits_simps archObjSize_def) apply (rule is_aligned_weaken) apply (erule aligned_add_aligned) apply (rule is_aligned_shiftl_self) - apply simp+ + apply simp + apply (simp add: pdeBits_def) done +lemma getPDE_wp: + "\\s. \ko. ko_at' (ko::pde) p s \ Q ko s\ getObject p \Q\" + by (clarsimp simp: getObject_def split_def loadObject_default_def + archObjSize_def in_magnitude_check pdeBits_def + projectKOs in_monad valid_def obj_at'_def objBits_simps) + +lemma getPTE_wp: + "\\s. \ko. ko_at' (ko::pte) p s \ Q ko s\ getObject p \Q\" + by (clarsimp simp: getObject_def split_def loadObject_default_def + archObjSize_def in_magnitude_check pteBits_def + projectKOs in_monad valid_def obj_at'_def objBits_simps) + lemmas get_pde_wp_valid = hoare_add_post'[OF get_pde_valid get_pde_wp] lemma page_table_at_lift: @@ -1180,16 +1038,36 @@ lemma lookupPTSlot_corres [@lift_corres_args, corres]: declare in_set_zip_refl[simp] +crunch storePDE + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps mapM_x_wp' simp: crunch_simps) + +crunch storePTE + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps mapM_x_wp' simp: crunch_simps) + +lemmas storePDE_typ_ats[wp] = typ_at_lifts [OF storePDE_typ_at'] +lemmas storePTE_typ_ats[wp] = typ_at_lifts [OF storePTE_typ_at'] + +lemma setObject_asid_typ_at' [wp]: + "\\s. P (typ_at' T p s)\ setObject p' (v::asidpool) \\_ s. P (typ_at' T p s)\" + by (wp setObject_typ_at') + +lemmas setObject_asid_typ_ats' [wp] = typ_at_lifts [OF setObject_asid_typ_at'] + +lemma getObject_pte_inv[wp]: + "\P\ getObject p \\rv :: pte. P\" + by (simp add: getObject_inv loadObject_default_inv) + +lemma getObject_pde_inv[wp]: + "\P\ getObject p \\rv :: pde. P\" + by (simp add: getObject_inv loadObject_default_inv) + crunch copyGlobalMappings 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: mapM_x_wp') -end - -sublocale Arch < copyGlobalMappings: typ_at_all_props' "copyGlobalMappings newPD" - by typ_at_props' -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas copyGlobalMappings_typ_ats[wp] = typ_at_lifts [OF copyGlobalMappings_typ_at'] lemma arch_cap_rights_update: "acap_relation c c' \ @@ -1273,13 +1151,13 @@ definition lemma createMappingEntries_valid_slots' [wp]: "\valid_objs' and - K (vmsz_aligned base sz \ vmsz_aligned vptr sz \ ptrFromPAddr base \ 0) \ + K (vmsz_aligned' base sz \ vmsz_aligned' vptr sz \ ptrFromPAddr base \ 0) \ createMappingEntries base vptr sz vm_rights attrib pd \\m. valid_slots' m\, -" apply (simp add: createMappingEntries_def) apply (rule hoare_pre) apply (wp|wpc|simp add: valid_slots'_def valid_mapping'_def)+ - apply (simp add: vmsz_aligned_def) + apply (simp add: vmsz_aligned'_def) apply auto done @@ -1312,6 +1190,12 @@ lemma page_directory_at_lift: lemmas checkPDAt_corres = corres_stateAssert_implied_frame[OF page_directory_at_lift, folded checkPDAt_def] +lemma getASID_wp: + "\\s. \ko. ko_at' (ko::asidpool) p s \ Q ko s\ getObject p \Q\" + by (clarsimp simp: getObject_def split_def loadObject_default_def + archObjSize_def in_magnitude_check pageBits_def + projectKOs in_monad valid_def obj_at'_def objBits_simps) + lemma find_pd_for_asid_corres [corres]: "asid = asid' \ corres (lfr \ (=)) ((\s. valid_arch_state s \ vspace_at_asid asid pd s) and valid_vspace_objs and pspace_aligned @@ -1384,6 +1268,83 @@ lemma setObject_arch: apply (wp X | simp)+ done +lemma setObject_ASID_arch [wp]: + "\\s. P (ksArchState s)\ setObject p (v::asidpool) \\_ s. P (ksArchState s)\" + apply (rule setObject_arch) + apply (simp add: updateObject_default_def) + apply wp + apply simp + done + +lemma setObject_PDE_arch [wp]: + "\\s. P (ksArchState s)\ setObject p (v::pde) \\_ s. P (ksArchState s)\" + apply (rule setObject_arch) + apply (simp add: updateObject_default_def) + apply wp + apply simp + done + +lemma setObject_PTE_arch [wp]: + "\\s. P (ksArchState s)\ setObject p (v::pte) \\_ s. P (ksArchState s)\" + apply (rule setObject_arch) + apply (simp add: updateObject_default_def) + apply wp + apply simp + done + +lemma setObject_ASID_valid_arch [wp]: + "\valid_arch_state'\ setObject p (v::asidpool) \\_. valid_arch_state'\" + by (rule valid_arch_state_lift'; wp) + +lemma setObject_PDE_valid_arch [wp]: + "\valid_arch_state'\ setObject p (v::pde) \\_. valid_arch_state'\" + by (rule valid_arch_state_lift') (wp setObject_typ_at')+ + +lemma setObject_PTE_valid_arch [wp]: + "\valid_arch_state'\ setObject p (v::pte) \\_. valid_arch_state'\" + by (rule valid_arch_state_lift') (wp setObject_typ_at')+ + +lemma setObject_ASID_ct [wp]: + "\\s. P (ksCurThread s)\ setObject p (e::asidpool) \\_ s. P (ksCurThread s)\" + apply (simp add: setObject_def updateObject_default_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setObject_PDE_ct [wp]: + "\\s. P (ksCurThread s)\ setObject p (e::pde) \\_ s. P (ksCurThread s)\" + apply (simp add: setObject_def updateObject_default_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setObject_pte_ct [wp]: + "\\s. P (ksCurThread s)\ setObject p (e::pte) \\_ s. P (ksCurThread s)\" + apply (simp add: setObject_def updateObject_default_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setObject_ASID_cur_tcb' [wp]: + "\\s. cur_tcb' s\ setObject p (e::asidpool) \\_ s. cur_tcb' s\" + apply (simp add: cur_tcb'_def) + apply (rule hoare_lift_Pf [where f=ksCurThread]) + apply wp+ + done + +lemma setObject_PDE_cur_tcb' [wp]: + "\\s. cur_tcb' s\ setObject p (e::pde) \\_ s. cur_tcb' s\" + apply (simp add: cur_tcb'_def) + apply (rule hoare_lift_Pf [where f=ksCurThread]) + apply wp+ + done + +lemma setObject_pte_cur_tcb' [wp]: + "\\s. cur_tcb' s\ setObject p (e::pte) \\_ s. cur_tcb' s\" + apply (simp add: cur_tcb'_def) + apply (rule hoare_lift_Pf [where f=ksCurThread]) + apply wp+ + done + + + lemma page_directory_pde_at_lookupI': "page_directory_at' pd s \ pde_at' (lookup_pd_slot pd vptr) s" apply (simp add: lookup_pd_slot_def Let_def) @@ -1404,6 +1365,50 @@ lemma page_table_pte_at_lookupI': apply (rule vptr_shiftr_le_2pt[simplified pt_bits_stuff]) done +lemma storePTE_ctes [wp]: + "\\s. P (ctes_of s)\ storePTE p pte \\_ s. P (ctes_of s)\" + apply (rule ctes_of_from_cte_wp_at [where Q=\, simplified]) + apply (rule storePTE_cte_wp_at') + done + +lemma storePDE_ctes [wp]: + "\\s. P (ctes_of s)\ storePDE p pte \\_ s. P (ctes_of s)\" + apply (rule ctes_of_from_cte_wp_at [where Q=\, simplified]) + apply (rule storePDE_cte_wp_at') + done + + +lemma storePDE_valid_objs [wp]: + "\valid_objs' and valid_pde' pde\ storePDE p pde \\_. valid_objs'\" + apply (simp add: storePDE_def doMachineOp_def split_def) + apply (rule hoare_pre) + apply (wp hoare_drop_imps|wpc|simp)+ + apply (rule setObject_valid_objs') + prefer 2 + apply assumption + apply (clarsimp simp: updateObject_default_def in_monad) + apply (clarsimp simp: valid_obj'_def) + done + +lemma setObject_ASID_cte_wp_at'[wp]: + "\\s. P (cte_wp_at' P' p s)\ + setObject ptr (asid::asidpool) + \\rv s. P (cte_wp_at' P' p s)\" + apply (wp setObject_cte_wp_at2'[where Q="\"]) + apply (clarsimp simp: updateObject_default_def in_monad + projectKO_opts_defs projectKOs) + apply (rule equals0I) + apply (clarsimp simp: updateObject_default_def in_monad + projectKOs projectKO_opts_defs) + apply simp + done + +lemma setObject_ASID_ctes_of'[wp]: + "\\s. P (ctes_of s)\ + setObject ptr (asid::asidpool) + \\rv s. P (ctes_of s)\" + by (rule ctes_of_from_cte_wp_at [where Q=\, simplified]) wp + lemma clearMemory_vms': "valid_machine_state' s \ \x\fst (clearMemory ptr bits (ksMachineState s)). @@ -1420,7 +1425,7 @@ lemma dmo_clearMemory_invs'[wp]: "\invs'\ doMachineOp (clearMemory w sz) \\_. invs'\" apply (simp add: doMachineOp_def split_def) apply wp - apply (clarsimp simp: invs'_def valid_dom_schedule'_def) + apply (clarsimp simp: invs'_def valid_state'_def) apply (rule conjI) apply (simp add: valid_irq_masks'_def, elim allEI, clarsimp) apply (drule use_valid) diff --git a/proof/refine/ARM/ArchMove_R.thy b/proof/refine/ARM/ArchMove_R.thy index 240cb37f0d..627391b298 100644 --- a/proof/refine/ARM/ArchMove_R.thy +++ b/proof/refine/ARM/ArchMove_R.thy @@ -17,4 +17,13 @@ lemmas cte_index_repair_sym = cte_index_repair[symmetric] lemmas of_nat_inj32 = of_nat_inj[where 'a=32, folded word_bits_def] +context begin +interpretation Arch . + +(* Move to Deterministic_AI*) +crunch copy_global_mappings + for valid_etcbs[wp]: valid_etcbs (wp: mapM_x_wp') + +end + end diff --git a/proof/refine/ARM/Arch_R.thy b/proof/refine/ARM/Arch_R.thy index 5197f7c394..3a05e92571 100644 --- a/proof/refine/ARM/Arch_R.thy +++ b/proof/refine/ARM/Arch_R.thy @@ -15,7 +15,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare is_aligned_shiftl [intro!] declare is_aligned_shiftr [intro!] @@ -69,12 +69,12 @@ lemma descendants_of'_helper: done lemma createObject_typ_at': - "\\s. koTypeOf ty = otype \ is_aligned ptr (objBitsKO ty) \ objBitsKO ty < word_bits \ - pspace_aligned' s \ pspace_bounded' s \ pspace_no_overlap' ptr (objBitsKO ty) s\ + "\\s. koTypeOf ty = otype \ is_aligned ptr (objBitsKO ty) \ + pspace_aligned' s \ pspace_no_overlap' ptr (objBitsKO ty) s\ createObjects' ptr (Suc 0) ty 0 \\rv s. typ_at' otype ptr s\" apply (clarsimp simp:createObjects'_def alignError_def split_def | wp unless_wp | wpc )+ - apply (clarsimp simp:obj_at'_def ko_wp_at'_def typ_at'_def)+ + apply (clarsimp simp:obj_at'_def ko_wp_at'_def typ_at'_def pspace_distinct'_def)+ apply (subgoal_tac "ps_clear ptr (objBitsKO ty) (s\ksPSpace := \a. if a = ptr then Some ty else ksPSpace s a\)") apply (simp add:ps_clear_def)+ @@ -87,11 +87,27 @@ lemma createObject_typ_at': apply (subgoal_tac "x \ {x..x + 2 ^ objBitsKO y - 1}") apply (fastforce simp: p_assoc_help) apply (rule first_in_uptoD) - apply (frule(1) pspace_alignedD') - apply (drule(1) pspace_boundedD') + apply (drule(1) pspace_alignedD') apply (clarsimp simp: is_aligned_no_wrap' p_assoc_help) done +lemma retype_region2_ext_retype_region_ArchObject: + "retype_region ptr n us (ArchObject x)= + retype_region2 ptr n us (ArchObject x)" + apply (rule ext) + apply (simp add:retype_region_def retype_region2_def bind_assoc + retype_region2_ext_def retype_region_ext_def default_ext_def) + apply (rule ext) + apply (intro monad_eq_split_tail ext)+ + apply simp + apply simp + apply (simp add:gets_def get_def bind_def return_def simpler_modify_def ) + apply (rule_tac x = xc in fun_cong) + apply (rule_tac f = do_extended_op in arg_cong) + apply (rule ext) + apply simp + apply simp + done lemma set_cap_device_and_range_aligned: "is_aligned ptr sz \ \\_. True\ @@ -138,12 +154,14 @@ lemma performASIDControlInvocation_corres: apply (rule corres_split) apply (erule deleteObjects_corres) apply (simp add:pageBits_def) - apply (rule corres_split[OF getSlotCap_corres], simp) + apply (rule corres_split[OF getSlotCap_corres]) + apply simp apply (rule_tac F = " pcap = (cap.UntypedCap False word1 pageBits idxa)" in corres_gen_asm) apply (rule corres_split[OF updateFreeIndex_corres]) apply (clarsimp simp:is_cap_simps) apply (simp add: free_index_of_def) apply (rule corres_split) + apply (simp add: retype_region2_ext_retype_region_ArchObject ) apply (rule corres_retype [where ty="Inl (KOArch (KOASIDPool F))", unfolded APIType_map2_def makeObjectKO_def, THEN createObjects_corres',simplified, @@ -186,7 +204,7 @@ lemma performASIDControlInvocation_corres: apply (simp cong: conj_cong) apply (wp createObjects_valid_pspace' [where sz = pageBits and ty="Inl (KOArch (KOASIDPool undefined))"]) - apply (simp add: makeObjectKO_def)+ + apply (simp add: makeObjectKO_def)+ apply (simp add:objBits_simps archObjSize_def range_cover_full)+ apply (clarsimp simp:valid_cap'_def) apply (wp createObject_typ_at' @@ -194,7 +212,6 @@ lemma performASIDControlInvocation_corres: apply (rule descendants_of'_helper) apply (wp createObjects_null_filter' [where sz = pageBits and ty="Inl (KOArch (KOASIDPool undefined))"]) - apply (clarsimp simp: conj_comms obj_bits_api_def arch_kobj_size_def objBits_simps archObjSize_def default_arch_object_def pred_conj_def) @@ -212,7 +229,7 @@ lemma performASIDControlInvocation_corres: makeObjectKO_def range_cover_full simp del: capFreeIndex_update.simps | strengthen invs_valid_pspace' invs_pspace_aligned' - invs_pspace_distinct' invs_pspace_bounded' + invs_pspace_distinct' exI[where x="makeObject :: asidpool"])+ apply (wp updateFreeIndex_forward_invs' updateFreeIndex_pspace_no_overlap' @@ -229,7 +246,7 @@ lemma performASIDControlInvocation_corres: apply wp+ apply (clarsimp simp: conj_comms) apply (clarsimp simp: conj_comms ex_disj_distrib - | strengthen invs_valid_pspace' invs_pspace_aligned' invs_pspace_bounded' + | strengthen invs_valid_pspace' invs_pspace_aligned' invs_pspace_distinct')+ apply (wp deleteObjects_invs'[where p="makePoolParent i'"] deleteObjects_cte_wp_at' @@ -245,27 +262,25 @@ lemma performASIDControlInvocation_corres: apply (wp deleteObjects_descendants[where p="makePoolParent i'"] deleteObjects_cte_wp_at' deleteObjects_null_filter[where p="makePoolParent i'"]) - apply (clarsimp simp:invs_mdb max_free_index_def invs_untyped_children schact_is_rct) - apply (subgoal_tac "detype_locale x y sa" for x y) - prefer 2 - apply (simp add:detype_locale_def) - apply (fastforce simp:cte_wp_at_caps_of_state descendants_range_def2 - empty_descendants_range_in invs_untyped_children) + apply (clarsimp simp:invs_mdb max_free_index_def invs_untyped_children) + apply (prop_tac "detype_locale x y sa" for x y) + apply (simp add: detype_locale_def) + apply (fastforce simp: cte_wp_at_caps_of_state descendants_range_def2 + empty_descendants_range_in invs_untyped_children) apply (intro conjI) apply (clarsimp) apply (erule(1) caps_of_state_valid) - subgoal by (fastforce simp: cte_wp_at_caps_of_state descendants_range_def2 - empty_descendants_range_in) + subgoal by (fastforce simp:cte_wp_at_caps_of_state + descendants_range_def2 empty_descendants_range_in) apply (fold_subgoals (prefix))[2] - subgoal premises prems using prems by (clarsimp simp:invs_def valid_state_def)+ + subgoal premises prems using prems by (clarsimp simp:invs_def valid_state_def)+ apply (clarsimp simp:cte_wp_at_caps_of_state) apply (drule detype_locale.non_null_present) apply (fastforce simp:cte_wp_at_caps_of_state) apply simp apply (frule_tac ptr = "(aa,ba)" in detype_invariants [rotated 3]) - apply fastforce - apply simp - apply (clarsimp simp: schact_is_rct) + apply fastforce + apply simp apply (simp add: cte_wp_at_caps_of_state) apply (simp add: is_cap_simps) apply (simp add:empty_descendants_range_in descendants_range_def2) @@ -297,7 +312,9 @@ lemma performASIDControlInvocation_corres: apply (rule conjI, rule pspace_no_overlap_subset, rule pspace_no_overlap_detype[OF caps_of_state_valid]) apply (simp add:invs_psp_aligned invs_valid_objs is_aligned_neg_mask_eq)+ - apply (simp add: detype_def clear_um_def) + apply (clarsimp simp: detype_def clear_um_def detype_ext_def valid_sched_def valid_etcbs_def + st_tcb_at_kh_def obj_at_kh_def st_tcb_at_def obj_at_def is_etcb_at_def) + apply (simp add: detype_def clear_um_def) apply (drule_tac x = "cte_map (aa,ba)" in pspace_relation_cte_wp_atI[OF state_relation_pspace_relation]) apply (simp add:invs_valid_objs)+ apply clarsimp @@ -329,8 +346,10 @@ lemma performASIDControlInvocation_corres: apply (drule (1) cte_cap_in_untyped_range) apply (fastforce simp add: cte_wp_at_ctes_of) apply assumption+ - apply (clarsimp simp: invs'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) - apply fastforce+ + apply (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) + apply fastforce + apply simp + apply clarsimp done definition @@ -383,12 +402,12 @@ lemma checkVPAlignment_corres: done lemma checkVP_wpR [wp]: - "\\s. vmsz_aligned w sz \ P () s\ + "\\s. vmsz_aligned' w sz \ P () s\ checkVPAlignment sz w \P\, -" apply (simp add: checkVPAlignment_def unlessE_whenE cong: vmpage_size.case_cong) apply (rule hoare_pre) apply (wp whenE_wp|wpc)+ - apply (simp add: is_aligned_mask vmsz_aligned_def) + apply (simp add: is_aligned_mask vmsz_aligned'_def) done lemma asidHighBits [simp]: @@ -508,7 +527,7 @@ lemma resolveVAddr_corres: done lemma decodeARMPageFlush_corres: - "\invocation_type (mi_label mi) = l; ARM_H.isPageFlushLabel l\ \ + "ARM_H.isPageFlushLabel (invocation_type (mi_label mi)) \ corres (ser \ archinv_relation) (invs and valid_cap (cap.ArchObjectCap (arch_cap.PageCap d word seta vmpage_size option)) and @@ -537,7 +556,7 @@ lemma decodeARMPageFlush_corres: returnOk $ arch_invocation.InvokePage $ ARM_A.page_invocation.PageFlush - (label_to_flush_type l) (start + vaddr) + (label_to_flush_type (invocation_type (mi_label mi))) (start + vaddr) (end + vaddr - 1) (addrFromPPtr word + start) pd asid odE else throwError ExceptionTypes_A.syscall_error.TruncatedMessage) @@ -797,7 +816,7 @@ shows apply (simp add: lookup_failure_map_def) apply simp apply (rule_tac P="\s. asid_table (asid_high_bits_of word2) = Some word1 \ asid_pool_at word1 s" and - P'="pspace_aligned' and pspace_distinct' and pspace_bounded'" in corres_inst) + P'="pspace_aligned' and pspace_distinct'" in corres_inst) apply (simp add: liftME_return) apply (rule whenE_throwError_corres_initial, simp) apply auto[1] @@ -869,7 +888,7 @@ shows apply (drule dom_hd_assocsD) apply (simp add: select_ext_fa[simplified free_asid_select_def] free_asid_select_def o_def returnOk_liftE[symmetric] - split del: if_split) + split del: if_split) apply (thin_tac "fst a \ b \ P" for a b P) apply (case_tac "isUntypedCap a \ capBlockSize a = objBits (makeObject::asidpool) \ \ capIsDevice a") @@ -977,7 +996,7 @@ shows apply (cases "ARM_H.isPageFlushLabel (invocation_type (mi_label mi))") apply (clarsimp simp: ARM_H.isPageFlushLabel_def split del: if_split) apply (clarsimp split: invocation_label.splits arch_invocation_label.splits split del: if_split) - apply (rule decodeARMPageFlush_corres[simplified]; + apply (rule decodeARMPageFlush_corres, clarsimp simp: ARM_H.isPageFlushLabel_def)+ apply (clarsimp simp: ARM_H.isPageFlushLabel_def split del: if_split) apply (cases "invocation_type (mi_label mi) = ArchInvocationLabel ARMPageGetAddress") @@ -1100,7 +1119,7 @@ shows apply (wp hoare_drop_imps)+ apply (clarsimp simp: valid_cap_simps mask_2pm1 linorder_not_le split: option.split) apply (intro conjI; (clarsimp)?) - apply (clarsimp simp: invs'_def valid_pspace'_def + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def split: option.splits) apply clarsimp done @@ -1111,7 +1130,6 @@ lemma arch_performInvocation_corres: (einvs and ct_active and valid_arch_inv ai and schact_is_rct) (invs' and ct_active' and valid_arch_inv' ai' and (\s. vs_valid_duplicates' (ksPSpace s))) (arch_perform_invocation ai) (Arch.performInvocation ai')" - apply add_cur_tcb' apply (clarsimp simp: arch_perform_invocation_def ARM_H.performInvocation_def performARMMMUInvocation_def) @@ -1193,7 +1211,7 @@ lemma performASIDControlInvocation_tcb_at': apply clarsimp apply (drule(1) cte_cap_in_untyped_range, fastforce simp add: cte_wp_at_ctes_of, assumption, simp_all) - apply (clarsimp simp: invs'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) + apply (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) apply clarsimp done @@ -1210,13 +1228,13 @@ lemma invokeArch_tcb_at': apply (wp, clarsimp simp: pred_tcb_at') done -end - -context begin interpretation Arch . - crunch setThreadState - for pspace_no_overlap'[wp]: "pspace_no_overlap' w s" - (simp: unless_def wp: crunch_wps) + for pspace_no_overlap'[wp]: "pspace_no_overlap' w s" + (simp: unless_def) + +lemma sts_cte_cap_to'[wp]: + "\ex_cte_cap_to' p\ setThreadState st t \\rv. ex_cte_cap_to' p\" + by (wp ex_cte_cap_to'_pres) lemma valid_slots_duplicated_lift': assumes ko_wp_at': @@ -1283,10 +1301,6 @@ crunch for vs_entry_align[wp]: "ko_wp_at' (\ko. P (vs_entry_align ko)) p" (wp: crunch_wps) -crunch setThreadState - for sc_at'_n[wp]: "sc_at'_n n p" - (simp: crunch_simps wp: crunch_wps) - lemma sts_valid_arch_inv': "\valid_arch_inv' ai\ setThreadState st t \\rv. valid_arch_inv' ai\" apply (cases ai, simp_all add: valid_arch_inv'_def) @@ -1302,7 +1316,7 @@ lemma sts_valid_arch_inv': apply clarsimp apply (clarsimp simp: valid_apinv'_def split: asidpool_invocation.splits) apply (rule hoare_pre, wp) - apply (simp add: o_def) + apply simp done lemma less_pptrBase_valid_pde_offset': @@ -1330,7 +1344,7 @@ lemmas less_pptrBase_valid_pde_offset'' = less_pptrBase_valid_pde_offset'[where x=0, simplified] lemma createMappingEntries_valid_pde_slots': - "\K (vmsz_aligned vptr sz \ is_aligned pd pdBits + "\K (vmsz_aligned' vptr sz \ is_aligned pd pdBits \ vptr < pptrBase)\ createMappingEntries base vptr sz vm_rights attrib pd \\rv s. valid_pde_slots' rv\,-" @@ -1340,7 +1354,7 @@ lemma createMappingEntries_valid_pde_slots': apply (clarsimp simp: lookup_pd_slot_def Let_def mask_add_aligned) apply (erule less_pptrBase_valid_pde_offset'') apply (rule hoare_pre, wp) - apply (clarsimp simp: vmsz_aligned_def superSectionPDEOffsets_def pdeBits_def del: ballI) + apply (clarsimp simp: vmsz_aligned'_def superSectionPDEOffsets_def pdeBits_def del: ballI) apply (subst p_0x3C_shift[symmetric]) apply (simp add: lookup_pd_slot_def Let_def) apply (erule aligned_add_aligned) @@ -1647,29 +1661,25 @@ lemma arch_decodeInvocation_wf[wp]: apply (wpsimp simp: valid_arch_inv'_def valid_page_inv'_def) apply (rule hoare_vcg_conj_liftE_R,(wp ensureSafeMapping_inv)[1])+ apply (wpsimp wp: whenE_throwError_wp checkVP_wpR hoare_vcg_const_imp_liftE_R - ensureSafeMapping_valid_slots_duplicated' + hoare_drop_impE_R ensureSafeMapping_valid_slots_duplicated' createMappingEntries_valid_pde_slots' findPDForASID_page_directory_at' simp: valid_arch_inv'_def valid_page_inv'_def)+ - apply (rule hoare_drop_impE_R) - apply (wpsimp wp: whenE_throwError_wp checkVP_wpR hoare_vcg_const_imp_liftE_R - ensureSafeMapping_valid_slots_duplicated' - createMappingEntries_valid_pde_slots' findPDForASID_page_directory_at' - simp: valid_arch_inv'_def valid_page_inv'_def)+ apply (clarsimp simp: neq_Nil_conv invs_valid_objs' linorder_not_le cte_wp_at_ctes_of) apply (drule ctes_of_valid', fastforce)+ apply (case_tac option; clarsimp, drule_tac t="cteCap cte" in sym, simp) apply (clarsimp simp: valid_cap'_def ptBits_def pageBits_def - is_arch_update'_def isCap_simps capAligned_def vmsz_aligned_def + is_arch_update'_def isCap_simps capAligned_def vmsz_aligned'_def cong: conj_cong) apply (rule conjI) - apply (erule is_aligned_addrFromPPtr_n, case_tac vmpage_size; simp) + apply (erule is_aligned_addrFromPPtr_n, case_tac vmpage_size, simp_all)[1] + apply (simp add: vmsz_aligned_def) apply (rule conjI) apply (erule order_le_less_trans[rotated]) apply (erule is_aligned_no_overflow'[simplified field_simps]) apply (clarsimp simp: page_directory_at'_def pdBits_eq lookup_pd_slot_eq)+ apply (clarsimp simp: valid_cap'_def ptBits_def pageBits_def - is_arch_update'_def isCap_simps capAligned_def vmsz_aligned_def + is_arch_update'_def isCap_simps capAligned_def vmsz_aligned'_def cong: conj_cong) apply (rule conjI) apply (erule is_aligned_addrFromPPtr_n, case_tac vmpage_size, simp_all)[1] @@ -1775,7 +1785,7 @@ lemma invs_asid_table_strengthen': "invs' s \ asid_pool_at' ap s \ asid \ 2 ^ asid_high_bits - 1 \ invs' (s\ksArchState := armKSASIDTable_update (\_. ((armKSASIDTable \ ksArchState) s)(asid \ ap)) (ksArchState s)\)" - apply (clarsimp simp: invs'_def valid_dom_schedule'_def) + apply (clarsimp simp: invs'_def valid_state'_def) apply (rule conjI) apply (clarsimp simp: valid_global_refs'_def global_refs'_def) apply (clarsimp simp: valid_arch_state'_def) @@ -1841,7 +1851,7 @@ lemma performASIDControlInvocation_invs' [wp]: cong: rev_conj_cong) apply (clarsimp simp:conj_comms descendants_of_null_filter' - | strengthen invs_pspace_aligned' invs_pspace_distinct' invs_pspace_bounded' + | strengthen invs_pspace_aligned' invs_pspace_distinct' invs_pspace_aligned' invs_valid_pspace')+ apply (wp updateFreeIndex_forward_invs' updateFreeIndex_cte_wp_at @@ -1852,7 +1862,7 @@ lemma performASIDControlInvocation_invs' [wp]: updateCap_cte_wp_at_cases hoare_weak_lift_imp getSlotCap_wp)+ apply (clarsimp simp:conj_comms ex_disj_distrib is_aligned_mask - | strengthen invs_valid_pspace' invs_pspace_aligned' invs_pspace_bounded' + | strengthen invs_valid_pspace' invs_pspace_aligned' invs_pspace_distinct' empty_descendants_range_in')+ apply (wp deleteObjects_invs'[where p="makePoolParent aci"] hoare_vcg_ex_lift diff --git a/proof/refine/ARM/Bits_R.thy b/proof/refine/ARM/Bits_R.thy index 26192f09c8..0cc0a36729 100644 --- a/proof/refine/ARM/Bits_R.thy +++ b/proof/refine/ARM/Bits_R.thy @@ -20,10 +20,9 @@ crunch_ignore (add: storeWordVM loadWord setRegister getRegister getRestartPC debugPrint setNextPC maskInterrupt clearMemory throw_on_false unifyFailure ignoreFailure empty_on_failure emptyOnFailure clearMemoryVM null_cap_on_failure - setNextPC getRestartPC assertDerived throw_on_false getObject setObject updateObject loadObject - ifM andM orM whenM whileM haskell_assert) + setNextPC getRestartPC assertDerived throw_on_false getObject setObject updateObject loadObject) -context Arch begin (*FIXME: arch_split*) +context Arch begin (*FIXME: arch-split*) crunch_ignore (add: invalidateLocalTLB_ASID invalidateLocalTLB_VAASID @@ -34,7 +33,7 @@ crunch_ignore (add: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma throwE_R: "\\\ throw f \P\,-" by (simp add: validE_R_def) wp @@ -57,9 +56,7 @@ lemma isCap_simps: "isNotificationCap v = (\v0 v1 v2 v3. v = NotificationCap v0 v1 v2 v3)" "isEndpointCap v = (\v0 v1 v2 v3 v4 v5. v = EndpointCap v0 v1 v2 v3 v4 v5)" "isUntypedCap v = (\d v0 v1 f. v = UntypedCap d v0 v1 f)" - "isReplyCap v = (\v0 v1. v = ReplyCap v0 v1)" - "isSchedContextCap v = (\v0 v1. v = SchedContextCap v0 v1)" - "isSchedControlCap v = (v = SchedControlCap)" + "isReplyCap v = (\v0 v1 v2. v = ReplyCap v0 v1 v2)" "isIRQControlCap v = (v = IRQControlCap)" "isIRQHandlerCap v = (\v0. v = IRQHandlerCap v0)" "isNullCap v = (v = NullCap)" @@ -97,27 +94,6 @@ lemma projectKO_ntfn: "(projectKO_opt ko = Some t) = (ko = KONotification t)" by (cases ko) (auto simp: projectKO_opts_defs) -lemma projectKO_reply: - "(projectKO_opt ko = Some t) = (ko = KOReply t)" - by (cases ko) (auto simp: projectKO_opts_defs) - -lemma reply_of'_KOReply[simp]: - "reply_of' (KOReply reply) = Some reply" - apply (clarsimp simp: projectKO_reply) - done - -lemma projectKO_sc: - "(projectKO_opt ko = Some t) = (ko = KOSchedContext t)" - by (cases ko) (auto simp: projectKO_opts_defs) - -lemma sc_of'_Sched[simp]: - "sc_of' (KOSchedContext sc) = Some sc" - by (simp add: projectKO_sc) - -lemma tcb_of'_TCB[simp]: - "tcb_of' (KOTCB tcb) = Some tcb" - by (simp add: projectKO_tcb) - lemma projectKO_ASID: "(projectKO_opt ko = Some t) = (ko = KOArch (KOASIDPool t))" by (cases ko) @@ -145,9 +121,9 @@ lemma projectKO_user_data_device: lemmas projectKOs = - projectKO_ntfn projectKO_ep projectKO_cte projectKO_tcb projectKO_reply projectKO_sc + projectKO_ntfn projectKO_ep projectKO_cte projectKO_tcb projectKO_ASID projectKO_PTE projectKO_PDE projectKO_user_data projectKO_user_data_device - projectKO_eq + projectKO_eq projectKO_eq2 lemma capAligned_epI: "ep_at' p s \ capAligned (EndpointCap p a b c d e)" @@ -175,25 +151,14 @@ lemma capAligned_tcbI: dest!: ko_wp_at_aligned simp: objBits_simps' projectKOs) done -lemma capAligned_replyI: - "reply_at' p s \ capAligned (ReplyCap p r)" +lemma capAligned_reply_tcbI: + "tcb_at' p s \ capAligned (ReplyCap p m r)" apply (clarsimp simp: obj_at'_real_def capAligned_def objBits_simps word_bits_def capUntypedPtr_def isCap_simps) apply (fastforce dest: ko_wp_at_norm dest!: ko_wp_at_aligned simp: objBits_simps' projectKOs) done -lemma capAligned_sched_contextI: - "\sc_at'_n r p s; sc_size_bounds r\ - \ capAligned (SchedContextCap p r)" - by (clarsimp simp: obj_at'_real_def capAligned_def sc_size_bounds_def ko_wp_at'_def isCap_simps - objBits_simps word_bits_def capUntypedPtr_def maxUntypedSizeBits_def) - -lemma sc_at'_n_sc_at': - "sc_at'_n n p s \ sc_at' p s" - apply (clarsimp simp: ko_wp_at'_def obj_at'_def projectKOs) - by (case_tac ko; clarsimp) - lemma ko_at_valid_objs': assumes ko: "ko_at' k p s" assumes vo: "valid_objs' s" @@ -202,39 +167,6 @@ lemma ko_at_valid_objs': by (clarsimp simp: valid_objs'_def obj_at'_def projectKOs project_inject ranI) -lemmas ko_at_valid_objs'_pre = - ko_at_valid_objs'[simplified project_inject, atomized, simplified, rule_format] - -lemmas ep_ko_at_valid_objs_valid_ep' = - ko_at_valid_objs'_pre[where 'a=endpoint, simplified injectKO_defs valid_obj'_def, simplified] - -lemmas ntfn_ko_at_valid_objs_valid_ntfn' = - ko_at_valid_objs'_pre[where 'a=notification, simplified injectKO_defs valid_obj'_def, - simplified] - -lemmas tcb_ko_at_valid_objs_valid_tcb' = - ko_at_valid_objs'_pre[where 'a=tcb, simplified injectKO_defs valid_obj'_def, simplified] - -lemmas cte_ko_at_valid_objs_valid_cte' = - ko_at_valid_objs'_pre[where 'a=cte, simplified injectKO_defs valid_obj'_def, simplified] - -lemmas sc_ko_at_valid_objs_valid_sc' = - ko_at_valid_objs'_pre[where 'a=sched_context, simplified injectKO_defs valid_obj'_def, - simplified] - -lemmas reply_ko_at_valid_objs_valid_reply' = - ko_at_valid_objs'_pre[where 'a=reply, simplified injectKO_defs valid_obj'_def, simplified] - -(* FIXME: arch split *) -lemmas pde_ko_at_valid_objs_valid_pde' = - ko_at_valid_objs'_pre[where 'a=pde, simplified injectKO_pde valid_obj'_def, simplified] - -lemmas pte_ko_at_valid_objs_valid_pte' = - ko_at_valid_objs'_pre[where 'a=pte, simplified injectKO_pde valid_obj'_def, simplified] - -lemmas asidpool_ko_at_valid_objs_valid_asid_pool' = - ko_at_valid_objs'_pre[where 'a=asidpool, simplified injectKO_pde valid_obj'_def, simplified] - lemma obj_at_valid_objs': "\ obj_at' P p s; valid_objs' s \ \ \k. P k \ @@ -270,9 +202,6 @@ lemma getIdleThread_corres [corres]: lemma git_wp [wp]: "\\s. P (ksIdleThread s) s\ getIdleThread \P\" by (unfold getIdleThread_def, wp) -lemma getIdleSc_wp [wp]: "\\s. P (ksIdleSC s) s\ getIdleSC \P\" - by (unfold getIdleSC_def, wp) - lemma gsa_wp [wp]: "\\s. P (ksSchedulerAction s) s\ getSchedulerAction \P\" by (unfold getSchedulerAction_def, wp) diff --git a/proof/refine/ARM/CNodeInv_R.thy b/proof/refine/ARM/CNodeInv_R.thy index 44035c0cb7..b33fcc3300 100644 --- a/proof/refine/ARM/CNodeInv_R.thy +++ b/proof/refine/ARM/CNodeInv_R.thy @@ -15,7 +15,7 @@ begin unbundle l4v_word_context -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec valid_cnode_inv' :: "Invocations_H.cnode_invocation \ kernel_state \ bool" @@ -43,6 +43,8 @@ where p_cap \ capability.NullCap) and (\s. src \ dest \ cte_wp_at' (\c. cteCap c = NullCap) dest s) and (\s. ex_cte_cap_to' pivot s \ ex_cte_cap_to' dest s))" +| "valid_cnode_inv' (SaveCaller slot) = + (ex_cte_cap_to' slot and cte_wp_at' (\c. cteCap c = NullCap) slot)" | "valid_cnode_inv' (CancelBadgedSends cap) = (valid_cap' cap and K (hasCancelSendRights cap))" @@ -66,6 +68,7 @@ where | "cnodeinv_relation (RotateCall sc pc src pvt dst) x = (\sc' pc'. cap_relation sc sc' \ cap_relation pc pc' \ x = Rotate sc' pc' (cte_map src) (cte_map pvt) (cte_map dst))" +| "cnodeinv_relation (SaveCall p) x = (x = SaveCaller (cte_map p))" | "cnodeinv_relation (CancelBadgedSendsCall c) x = (\c'. cap_relation c c' \ x = CancelBadgedSends c')" @@ -137,9 +140,9 @@ lemma get_cap_corres': by (simp add: get_cap_corres) lemma cnode_invok_case_cleanup: - "i \ {CNodeRevoke, CNodeDelete, CNodeCancelBadgedSends, CNodeRotate} + "i \ {CNodeRevoke, CNodeDelete, CNodeCancelBadgedSends, CNodeRotate, CNodeSaveCaller} \ (case i of CNodeRevoke \ P | CNodeDelete \ Q | CNodeCancelBadgedSends \ R - | CNodeRotate \ S + | CNodeRotate \ S | CNodeSaveCaller \ T | _ \ U) = U" by (simp split: gen_invocation_labels.split) @@ -162,76 +165,91 @@ lemma decodeCNodeInvocation_corres: cap' cs')" apply (rule decode_cnode_cases2[where args=args and exs=cs and label="mi_label mi"]) \ \Move / Insert\ - apply (clarsimp simp: list_all2_Cons1 decode_cnode_invocation_def - decodeCNodeInvocation_def split_def Let_def - unlessE_whenE isCNodeCap_CNodeCap - cnode_invok_case_cleanup - split del: if_split - cong: if_cong list.case_cong) - apply (rule corres_guard_imp) - apply (rule corres_splitEE) - apply (rule lookupSlotForCNodeOp_corres; simp) - apply (rule corres_splitEE) - apply (rule ensureEmptySlot_corres; simp) - apply (rule corres_splitEE) - apply (rule lookupSlotForCNodeOp_corres; simp) - apply (simp(no_asm) add: liftE_bindE del: de_Morgan_conj split del: if_split) - apply (rule corres_split[OF get_cap_corres']) - apply (simp add: split_def) - apply (rule whenE_throwError_corres) - apply (simp add: lookup_failure_map_def) - apply auto[1] - apply (rule_tac r'="\a b. fst b = rights_mask_map (fst a) - \ snd b = fst (snd a) - \ snd (snd a) = (gen_invocation_type (mi_label mi) - \ {CNodeMove, CNodeMutate})" - in corres_splitEE) - apply (rule corres_trivial) - subgoal by (auto split: list.split gen_invocation_labels.split, - auto simp: returnOk_def all_rights_def - rightsFromWord_correspondence) - apply (rule_tac r'=cap_relation in corres_splitEE) - apply (simp add: returnOk_def del: imp_disjL) - apply (rule conjI[rotated], rule impI) - apply (rule deriveCap_corres) - apply (clarsimp simp: cap_relation_mask - cap_map_update_data - split: option.split) - apply clarsimp - apply (clarsimp simp: cap_map_update_data - split: option.split) + apply (clarsimp simp: list_all2_Cons1 decode_cnode_invocation_def + decodeCNodeInvocation_def split_def Let_def + unlessE_whenE isCNodeCap_CNodeCap + cnode_invok_case_cleanup + split del: if_split + cong: if_cong list.case_cong) + apply (rule corres_guard_imp) + apply (rule corres_splitEE) + apply (rule lookupSlotForCNodeOp_corres; simp) + apply (rule corres_splitEE) + apply (rule ensureEmptySlot_corres; simp) + apply (rule corres_splitEE) + apply (rule lookupSlotForCNodeOp_corres; simp) + apply (simp(no_asm) add: liftE_bindE del: de_Morgan_conj split del: if_split) + apply (rule corres_split[OF get_cap_corres']) + apply (simp add: split_def) + apply (rule whenE_throwError_corres) + apply (simp add: lookup_failure_map_def) + apply auto[1] + apply (rule_tac r'="\a b. fst b = rights_mask_map (fst a) + \ snd b = fst (snd a) + \ snd (snd a) = (gen_invocation_type (mi_label mi) + \ {CNodeMove, CNodeMutate})" + in corres_splitEE) apply (rule corres_trivial) - subgoal by (auto simp add: whenE_def, auto simp add: returnOk_def) - apply (wp | wpc | simp(no_asm))+ - apply (wp hoare_vcg_const_imp_liftE_R hoare_vcg_const_imp_lift - hoare_vcg_all_liftE_R hoare_vcg_all_lift lsfco_cte_at' hoare_drop_imps - | clarsimp)+ - subgoal by (auto elim!: valid_cnode_capI) - apply (clarsimp simp: invs'_def valid_pspace'_def) - \ \Revoke\ + subgoal by (auto split: list.split gen_invocation_labels.split, + auto simp: returnOk_def all_rights_def + rightsFromWord_correspondence) + apply (rule_tac r'=cap_relation in corres_splitEE) + apply (simp add: returnOk_def del: imp_disjL) + apply (rule conjI[rotated], rule impI) + apply (rule deriveCap_corres) + apply (clarsimp simp: cap_relation_mask + cap_map_update_data + split: option.split) + apply clarsimp + apply (clarsimp simp: cap_map_update_data + split: option.split) + apply (rule corres_trivial) + subgoal by (auto simp add: whenE_def, auto simp add: returnOk_def) + apply (wp | wpc | simp(no_asm))+ + apply (wp hoare_vcg_const_imp_liftE_R hoare_vcg_const_imp_lift + hoare_vcg_all_liftE_R hoare_vcg_all_lift lsfco_cte_at' hoare_drop_imps + | clarsimp)+ + subgoal by (auto elim!: valid_cnode_capI) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + \ \Revoke\ + apply (simp add: decode_cnode_invocation_def decodeCNodeInvocation_def + isCap_simps Let_def unlessE_whenE del: ser_def split del: if_split) + apply (rule corres_guard_imp, rule corres_splitEE) + apply (rule lookupSlotForCNodeOp_corres; simp) + apply (simp add: split_beta) + apply (rule corres_returnOkTT) + apply simp + apply wp+ + apply (auto elim!: valid_cnode_capI)[1] + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + \ \Delete\ apply (simp add: decode_cnode_invocation_def decodeCNodeInvocation_def isCap_simps Let_def unlessE_whenE del: ser_def split del: if_split) - apply (rule corres_guard_imp, rule corres_splitEE) + apply (rule corres_guard_imp) + apply (rule corres_splitEE) apply (rule lookupSlotForCNodeOp_corres; simp) apply (simp add: split_beta) apply (rule corres_returnOkTT) apply simp apply wp+ apply (auto elim!: valid_cnode_capI)[1] - apply (clarsimp simp: invs'_def valid_pspace'_def) - \ \Delete\ + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + \ \SaveCall\ apply (simp add: decode_cnode_invocation_def decodeCNodeInvocation_def isCap_simps Let_def unlessE_whenE del: ser_def split del: if_split) apply (rule corres_guard_imp) apply (rule corres_splitEE) apply (rule lookupSlotForCNodeOp_corres; simp) apply (simp add: split_beta) - apply (rule corres_returnOkTT) - apply simp - apply wp+ + apply (rule corres_split_norE) + apply (rule ensureEmptySlot_corres) + apply simp + apply (rule corres_returnOkTT) + apply simp + apply (wp hoare_drop_imps)+ apply (auto elim!: valid_cnode_capI)[1] - apply (clarsimp simp: invs'_def valid_pspace'_def) - \ \CancelBadgedSends\ + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + \ \CancelBadgedSends\ apply (simp add: decode_cnode_invocation_def decodeCNodeInvocation_def isCap_simps Let_def unlessE_whenE del: ser_def split del: if_split) apply (rule corres_guard_imp) @@ -248,7 +266,7 @@ lemma decodeCNodeInvocation_corres: apply (rule hoare_trivE_R[where P="\"]) apply (wpsimp simp: cte_wp_at_ctes_of pred_conj_def) apply (fastforce elim!: valid_cnode_capI simp: invs_def valid_state_def valid_pspace_def) - apply (clarsimp simp: invs'_def valid_pspace'_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) \ \Rotate\ apply (frule list_all2_lengthD) apply (clarsimp simp: list_all2_Cons1) @@ -261,7 +279,7 @@ lemma decodeCNodeInvocation_corres: apply (rule corres_splitEE, (rule lookupSlotForCNodeOp_corres; simp))+ apply (rule_tac R = "\s. cte_at pivot_slot s \ cte_at dest_slot s \ cte_at src_slot s \ invs s" in - whenE_throwError_corres' [where R' = \]) + whenE_throwError_corres' [where R' = \]) apply simp apply (elim conjE) apply rule @@ -273,8 +291,7 @@ lemma decodeCNodeInvocation_corres: apply (drule (2) cte_map_inj_eq, clarsimp+)[1] apply (rule corres_split_norE) apply (rule_tac F = "(src_slot \ dest_slot) = (srcSlot \ destSlot)" - and P = "\s. cte_at src_slot s \ cte_at dest_slot s \ invs s" - and P' = invs' in corres_req) + and P = "\s. cte_at src_slot s \ cte_at dest_slot s \ invs s" and P' = invs' in corres_req) apply simp apply rule apply clarsimp @@ -303,9 +320,17 @@ lemma decodeCNodeInvocation_corres: apply simp apply (intro conjI) apply (erule cap_map_update_data)+ - apply (wp hoare_drop_imps hoare_vcg_if_lift_ER)+ - apply (fastforce elim!: valid_cnode_capI) - apply (clarsimp dest!: list_all2_lengthD simp: invs'_def valid_pspace'_def) + apply (wp hoare_drop_imps)+ + apply simp + apply (wp lsfco_cte_at' lookup_cap_valid lookup_cap_valid') + apply (simp add: if_apply_def2) + apply (wp hoare_drop_imps) + apply wp + apply simp + apply (wp lsfco_cte_at' lookup_cap_valid lookup_cap_valid' hoare_drop_imps + | simp add: if_apply_def2 del: de_Morgan_conj split del: if_split)+ + apply (auto elim!: valid_cnode_capI)[1] + apply (clarsimp dest!: list_all2_lengthD simp: invs'_def valid_state'_def valid_pspace'_def) \ \Errors\ apply (elim disjE) apply (simp add: decode_cnode_invocation_def decodeCNodeInvocation_def @@ -333,7 +358,7 @@ lemma decodeCNodeInvocation_corres: split del: if_split cong: if_cong) apply (rule corres_guard_imp) apply (rule corres_splitEE[OF lookupSlotForCNodeOp_corres _ wp_post_tautE wp_post_tautE]) - apply (clarsimp simp: list_all2_Cons1 split: list.split_asm) + apply simp apply simp apply (clarsimp simp: list_all2_Cons1 list_all2_Nil split: list.split_asm split del: if_split) @@ -405,44 +430,49 @@ lemma decodeCNodeInv_wf[wp]: (CNodeCap w n w2 n2) cs \valid_cnode_inv'\, -" apply (rule decode_cnode_cases2[where label=label and args=args and exs=cs]) - \ \Move/Insert\ - apply (simp add: decodeCNodeInvocation_def isCNodeCap_CNodeCap - split_def cnode_invok_case_cleanup unlessE_whenE + \ \Move/Insert\ + apply (simp add: decodeCNodeInvocation_def isCNodeCap_CNodeCap + split_def cnode_invok_case_cleanup unlessE_whenE + cong: if_cong bool.case_cong list.case_cong) + apply (rule hoare_pre) + apply (wp whenE_throwError_wp) + apply (rule deriveCap_Null_helper) + apply (simp add: imp_conjR) + apply ((wp deriveCap_derived deriveCap_untyped_derived + | wp (once) hoare_drop_imps)+)[1] + apply (wp whenE_throwError_wp getCTE_wp | wpc | simp(no_asm))+ + apply (rule_tac Q'="\rv. invs' and cte_wp_at' (\cte. cteCap cte = NullCap) destSlot + and ex_cte_cap_to' destSlot" + in hoare_strengthen_postE_R, wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (frule invs_valid_objs') + apply (simp add: ctes_of_valid' valid_updateCapDataI + weak_derived_updateCapData capBadge_updateCapData_True + badge_derived_updateCapData + badge_derived_mask untyped_derived_eq_maskCapRights + untyped_derived_eq_updateCapData + untyped_derived_eq_refl) + apply (auto simp:isCap_simps updateCapData_def)[1] + apply (wp ensureEmptySlot_stronger | simp | wp (once) hoare_drop_imps)+ + \ \Revoke\ + apply (simp add: decodeCNodeInvocation_def isCNodeCap_CNodeCap split_def + unlessE_whenE cong: if_cong bool.case_cong list.case_cong) apply (rule hoare_pre) - apply (wp whenE_throwError_wp) - apply (rule deriveCap_Null_helper) - apply (simp add: imp_conjR) - apply ((wp deriveCap_derived deriveCap_untyped_derived - | wp (once) hoare_drop_imps)+)[1] - apply (wp whenE_throwError_wp getCTE_wp | wpc | simp(no_asm))+ - apply (rule_tac Q'="\rv. invs' and cte_wp_at' (\cte. cteCap cte = NullCap) destSlot - and ex_cte_cap_to' destSlot" - in hoare_strengthen_postE_R, wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (frule invs_valid_objs') - apply (simp add: ctes_of_valid' valid_updateCapDataI - weak_derived_updateCapData capBadge_updateCapData_True - badge_derived_updateCapData - untyped_derived_eq_maskCapRights - untyped_derived_eq_updateCapData - untyped_derived_eq_refl) - apply (auto simp:isCap_simps updateCapData_def)[1] - apply (wp ensureEmptySlot_stronger | simp | wp (once) hoare_drop_imps)+ - \ \Revoke\ + apply (wp lsfco_cte_at' | simp)+ + apply clarsimp + \ \Delete\ apply (simp add: decodeCNodeInvocation_def isCNodeCap_CNodeCap split_def unlessE_whenE cong: if_cong bool.case_cong list.case_cong) apply (rule hoare_pre) apply (wp lsfco_cte_at' | simp)+ apply clarsimp - \ \Delete\ + \ \SaveCaller\ apply (simp add: decodeCNodeInvocation_def isCNodeCap_CNodeCap split_def - unlessE_whenE - cong: if_cong bool.case_cong list.case_cong) + unlessE_whenE) apply (rule hoare_pre) - apply (wp lsfco_cte_at' | simp)+ - apply clarsimp + apply (wp lsfco_cte_at' | simp | wp (once) hoare_drop_imps)+ \ \CancelBadgedSends\ apply (simp add: decodeCNodeInvocation_def isCNodeCap_CNodeCap split_def unlessE_whenE) @@ -485,29 +515,37 @@ lemma decodeCNodeInvocation_inv[wp]: fst_conv snd_conv, simp) apply (rule decode_cnode_cases2[where label=label and args=args and exs=cs]) apply (simp_all add: decodeCNodeInvocation_def isCNodeCap_CNodeCap split_def - Let_def whenE_def unlessE_def cnode_invok_case_cleanup)[5] - apply (fold_subgoals (prefix))[5] + Let_def whenE_def unlessE_def cnode_invok_case_cleanup + split del: if_split cong del: if_cong)[6] + apply (fold_subgoals (prefix))[6] subgoal premises prems by (safe intro!: hoare_pre[where P=P], (wp hoare_drop_imps | simp | wpcw)+) apply (elim disjE exE conjE, simp_all add: decodeCNodeInvocation_def isCNodeCap_CNodeCap cnode_invok_case_cleanup unlessE_whenE - split: list.split_asm) + split: list.split_asm split del: if_split) apply (simp_all split: list.split add: unlessE_whenE) apply safe apply (wp | simp)+ done + text \Various proofs about the two recursive deletion operations. These call out to various functions in Tcb and Ipc, and are thus better proved here than in CSpace_R.\ text \Proving the termination of rec_del\ +crunch cancel_ipc + for typ_at[wp]: "\s. P (typ_at T p s)" + (wp: crunch_wps hoare_vcg_if_splitE simp: crunch_simps) + declare if_split [split] text \Proving desired properties about rec_del/cap_delete\ +declare of_nat_power [simp del] + (* FIXME: pull up *) declare word_unat_power [symmetric, simp del] @@ -529,12 +567,6 @@ lemma not_recursive_ctes_irq_state_independent[simp, intro!]: "not_recursive_ctes (s \ ksMachineState := ksMachineState s \ irq_state := x \\) = not_recursive_ctes s" by (simp add: not_recursive_ctes_def) -lemma not_recursive_ctes_independent_simple[simp]: - "not_recursive_ctes (ksCurTime_update f s) = not_recursive_ctes s" - "not_recursive_ctes (ksConsumedTime_update f' s) = not_recursive_ctes s" - "not_recursive_ctes (ksMachineState_update f'' s) = not_recursive_ctes s" - by (simp add: not_recursive_ctes_def)+ - lemma capSwap_not_recursive: "\\s. card (not_recursive_ctes s) \ n \ cte_wp_at' (\cte. \ (isZombie (cteCap cte) \ capZombiePtr (cteCap cte) = p1)) p1 s @@ -586,46 +618,18 @@ lemma suspend_ctes_of_thread: apply (case_tac cte, simp) done -lemma schedContextUnbindTCB_ctes_of[wp]: - "\\s. P (ctes_of s)\ - schedContextUnbindTCB t - \\_ s. P (ctes_of s)\" - apply (wpsimp simp: schedContextUnbindTCB_def wp: threadSet_ctes_ofT) - apply (clarsimp simp: ran_def tcb_cte_cases_def split: if_splits) - by wpsimp+ - -crunch setConsumed, schedContextCompleteYieldTo, unbindNotification, unbindFromSC - for ctes_of[wp]: "\s. P (ctes_of s)" - (simp: crunch_simps wp: crunch_wps) - -lemma schedContextUnbindTCB_ctes_of_thread: - "schedContextUnbindTCB t' \\s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\" - by wp - -lemma schedContextCompleteYieldTo_ctes_of_thread: - "schedContextCompleteYieldTo t' \\s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\" - by wp - -lemma getSchedContext_ctes_of_thread: - "getSchedContext t' \\s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\" - by wpsimp - lemma unbindNotification_ctes_of_thread: - "unbindNotification t' \\s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\" - by wp - -lemma unbindFromSC_ctes_of_thread: - "unbindFromSC t' \\s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\" + "\\s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\ + unbindNotification t + \\rv s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\" by wp lemma prepareThreadDelete_ctes_of_thread: - "prepareThreadDelete t' \\s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\" + "\\s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\ + prepareThreadDelete t + \\rv s. \node. ctes_of s x = Some (CTE (ThreadCap t) node)\" by (wpsimp simp: prepareThreadDelete_def) -crunch schedContextCancelYieldTo, tcbReleaseRemove, tcbSchedDequeue, unbindFromSC - for cteCaps_of[wp]: "\s. P (cteCaps_of s)" - (wp: crunch_wps simp: crunch_simps) - lemma suspend_not_recursive_ctes: "\\s. P (not_recursive_ctes s)\ suspend t @@ -633,19 +637,28 @@ lemma suspend_not_recursive_ctes: apply (simp only: suspend_def not_recursive_ctes_def cteCaps_of_def) unfolding updateRestartPC_def apply (wp threadSet_ctes_of | simp add: unless_def del: o_apply)+ - apply (fold cteCaps_of_def) - apply (wp gts_wp' stateAssert_wp hoare_vcg_all_lift hoare_drop_imps)+ + apply (fold cteCaps_of_def) + apply (wp cancelIPC_cteCaps_of) apply (clarsimp elim!: rsubst[where P=P] intro!: set_eqI) + apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def) + apply (auto simp: isCap_simps finaliseCap_def Let_def) done -crunch schedContextUnbindTCB, schedContextCompleteYieldTo, unbindNotification, - prepareThreadDelete, unbindFromSC - for not_recursive_ctes[wp]: "\s. P (not_recursive_ctes s)" - (simp: not_recursive_ctes_def cteCaps_of_def wp: threadSet_ctes_of) +lemma unbindNotification_not_recursive_ctes: + "\\s. P (not_recursive_ctes s)\ + unbindNotification t + \\rv s. P (not_recursive_ctes s)\" + apply (simp only: not_recursive_ctes_def cteCaps_of_def) + apply wp + done -lemma preemptionPoint_not_recursive_ctes[wp]: - "preemptionPoint \\s. P (not_recursive_ctes s)\" - by (wpsimp wp: preemptionPoint_inv simp: not_recursive_ctes_def) +lemma prepareThreadDelete_not_recursive_ctes: + "\\s. P (not_recursive_ctes s)\ + prepareThreadDelete t + \\rv s. P (not_recursive_ctes s)\" + apply (simp only: prepareThreadDelete_def cteCaps_of_def) + apply wp + done definition finaliseSlot_recset :: "((word32 \ bool \ kernel_state) \ (word32 \ bool \ kernel_state)) set" @@ -665,8 +678,21 @@ lemma finaliseSlot_recset_wf: "wf finaliseSlot_recset" by (intro wf_sum_wf wf_rdcall_finalise_ord_lift wf_measure wf_inv_image wf_lex_prod wf_less_than) -crunch getRefills, isCurDomainExpired - for inv[wp]: P +lemma in_preempt': + "(Inr rv, s') \ fst (preemptionPoint s) \ + \f g. s' = ksWorkUnitsCompleted_update f + (s \ ksMachineState := ksMachineState s \ irq_state := g (irq_state (ksMachineState s)) \\)" + apply (simp add: preemptionPoint_def alternative_def in_monad eq_commute + getActiveIRQ_def doMachineOp_def split_def + select_f_def select_def getWorkUnits_def setWorkUnits_def + modifyWorkUnits_def return_def returnOk_def + split: option.splits if_splits) + apply (erule disjE) + apply (cases "workUnitsLimit \ ksWorkUnitsCompleted s + 1", drule (1) mp, + rule exI[where x="\x. 0"], rule exI[where x=Suc], force, + rule exI[where x="\x. x + 1"], rule exI[where x=id], force)+ + apply (rule exI[where x="\x. x + 1"], rule exI[where x=id], force) + done lemma updateCap_implies_cte_at: "(rv, s') \ fst (updateCap ptr cap s) @@ -682,16 +708,11 @@ lemma case_Zombie_assert_fold: = assertE (isZombie cap \ P (capZombiePtr cap))" by (cases cap, simp_all add: isCap_simps assertE_def) -lemma preemptionPoint_ctes_of: - "preemptionPoint \\s. P (ctes_of s)\" - apply (wpsimp wp: preemptionPoint_inv) - done - termination finaliseSlot' apply (rule finaliseSlot'.termination, rule finaliseSlot_recset_wf) apply (simp add: finaliseSlot_recset_def wf_sum_def) - apply (clarsimp simp: in_monad) + apply (clarsimp simp: in_monad dest!: in_preempt') apply (drule in_inv_by_hoareD [OF isFinalCapability_inv]) apply (frule use_valid [OF _ getCTE_cte_wp_at, OF _ TrueI]) apply (drule in_inv_by_hoareD [OF getCTE_inv]) @@ -702,7 +723,6 @@ termination finaliseSlot' apply (frule use_valid [OF _ getCTE_cte_wp_at, OF _ TrueI]) apply (drule in_inv_by_hoareD [OF getCTE_inv]) apply clarsimp - apply (erule use_valid [OF _ preemptionPoint_not_recursive_ctes]) apply (erule use_valid [OF _ capSwap_not_recursive]) apply (simp add: cte_wp_at_ctes_of) apply (frule updateCap_implies_cte_at) @@ -715,18 +735,14 @@ termination finaliseSlot' apply simp apply (clarsimp simp: finaliseCap_def Let_def isCap_simps in_monad getThreadCSpaceRoot_def locateSlot_conv) - apply (intro conjI) - apply (erule use_valid [OF _ prepareThreadDelete_not_recursive_ctes]) - apply (erule use_valid [OF _ suspend_not_recursive_ctes]) - apply (erule use_valid [OF _ unbindFromSC_not_recursive_ctes]) - apply (erule use_valid [OF _ unbindNotification_not_recursive_ctes]) - apply (erule use_valid [OF _ stateAssert_inv], simp) - apply (frule(1) use_valid [OF _ stateAssert_inv]) apply (frule(1) use_valid [OF _ unbindNotification_ctes_of_thread, OF _ exI]) - apply (frule(1) use_valid [OF _ unbindFromSC_ctes_of_thread]) apply (frule(1) use_valid [OF _ suspend_ctes_of_thread]) apply (frule(1) use_valid [OF _ prepareThreadDelete_ctes_of_thread]) apply clarsimp + apply (erule use_valid [OF _ prepareThreadDelete_not_recursive_ctes]) + apply (erule use_valid [OF _ suspend_not_recursive_ctes]) + apply (erule use_valid [OF _ unbindNotification_not_recursive_ctes]) + apply simp apply (clarsimp simp: finaliseCap_def Let_def isCap_simps in_monad) apply (clarsimp simp: finaliseCap_def Let_def isCap_simps in_monad) apply (clarsimp simp: in_monad Let_def locateSlot_conv @@ -735,7 +751,6 @@ termination finaliseSlot' apply (clarsimp split: if_split_asm simp: in_monad dest!: in_getCTE) - apply (erule use_valid[OF _ preemptionPoint_ctes_of]) apply (erule use_valid [OF _ updateCap_ctes_of_wp])+ apply (clarsimp simp: cte_wp_at_ctes_of modify_map_def) apply (case_tac ourCTE) @@ -743,15 +758,13 @@ termination finaliseSlot' apply (case_tac rv, simp) apply (rename_tac cap' node') apply (case_tac cap'; simp) - apply (erule use_valid[OF _ preemptionPoint_ctes_of]) apply (erule use_valid [OF _ updateCap_ctes_of_wp])+ apply (clarsimp simp: cte_wp_at_ctes_of modify_map_def) apply (frule use_valid [OF _ finaliseCap_cases], simp) apply (case_tac ourCTE, case_tac rv, clarsimp simp: isCap_simps) apply (elim disjE conjE exE, simp_all)[1] - apply (clarsimp simp: finaliseCap_def Let_def isCap_simps in_monad fst_cte_ptrs_def) - apply (erule use_valid[OF _ preemptionPoint_ctes_of]) + apply (clarsimp simp: finaliseCap_def Let_def isCap_simps in_monad) apply (frule use_valid [OF _ finaliseCap_cases], simp) apply (case_tac rv, case_tac ourCTE) apply (clarsimp simp: isCap_simps cte_wp_at_ctes_of) @@ -771,11 +784,7 @@ lemma finaliseSlot'_preservation: "\sl1 sl2. \P\ capSwapForDelete sl1 sl2 \\rv. P\" "\sl cap. \P\ updateCap sl cap \\rv. P\" "\f s. P (ksWorkUnitsCompleted_update f s) = P s" - assumes indep: "irq_state_independent_H P" - "updateTimeStamp_independent P" - "getCurrentTime_independent_H P" - "time_state_independent_H P" - "domain_time_independent_H P" + assumes irq: "irq_state_independent_H P" shows "st \ \P\ finaliseSlot' slot exposed \\rv. P\, \\rv. P\" proof (induct rule: finalise_spec_induct) @@ -789,7 +798,7 @@ proof (induct rule: finalise_spec_induct) apply (wp "1.hyps") apply (unfold Let_def split_def fst_conv snd_conv case_Zombie_assert_fold haskell_fail_def) - apply (wp wp preemptionPoint_inv| simp add: o_def indep)+ + apply (wp wp preemptionPoint_inv| simp add: o_def irq)+ apply (wp hoare_drop_imps) apply (wp wp | simp)+ apply (wp hoare_drop_imps | simp(no_asm))+ @@ -812,17 +821,13 @@ lemma cteDelete_preservation: "\sl1 sl2. \P\ capSwapForDelete sl1 sl2 \\rv. P\" "\sl cap. \P\ updateCap sl cap \\rv. P\" "\f s. P (ksWorkUnitsCompleted_update f s) = P s" - assumes indep: "irq_state_independent_H P" - "updateTimeStamp_independent P" - "getCurrentTime_independent_H P" - "time_state_independent_H P" - "domain_time_independent_H P" + assumes irq: "irq_state_independent_H P" shows "\P\ cteDelete p e \\rv. P\" apply (simp add: cteDelete_def whenE_def split_def) apply (wp wp) apply (simp only: simp_thms cases_simp) - apply (wp finaliseSlot_preservation wp indep) + apply (wp finaliseSlot_preservation wp irq) apply simp done @@ -1183,6 +1188,11 @@ lemma ctes_of_strng: \ (\cte. cte_wp_at' ((=) cte) ptr s \ P cte)" by (clarsimp simp: cte_wp_at_ctes_of) +lemma updateCap_valid_cap [wp]: + "\valid_cap' cap\ updateCap ptr cap' \\r. valid_cap' cap\" + unfolding updateCap_def + by (wp setCTE_valid_cap getCTE_wp) (clarsimp dest!: cte_at_cte_wp_atD) + lemma mdb_chain_0_trancl: assumes chain: "mdb_chain_0 m" and n0: "no_0 m" @@ -2067,7 +2077,8 @@ proof - done hence d2n: "dest2_node = dest_node" - unfolding dest2_node_def using dsneq by simp + unfolding dest2_node_def using dsneq + by simp from trancl obtain d where dnext: "m \ d \ src" and ncd: "m \ c \\<^sup>* d" by (clarsimp dest!: tranclD2) @@ -4483,6 +4494,12 @@ lemma untypedRange_new: lemmas range_simps [simp] = isUntyped_new capRange_new untypedRange_new +lemma isReplyMaster_eq: + "(isReplyCap new \ capReplyMaster new) + = (isReplyCap old \ capReplyMaster old)" + using derived + by (fastforce simp: weak_derived'_def isCap_simps) + end lemma master_eqE: @@ -4782,6 +4799,27 @@ lemma distinct_zombies_n: apply (clarsimp simp: weak_der'_def weak_derived'_def) done +lemma reply_masters_rvk_fb_m: + "reply_masters_rvk_fb m" + using valid by auto + +lemma reply_masters_rvk_fb_n: + "reply_masters_rvk_fb n" + using reply_masters_rvk_fb_m + weak_der'.isReplyMaster_eq[OF weak_der_src] + weak_der'.isReplyMaster_eq[OF weak_der_dest] + apply (simp add: reply_masters_rvk_fb_def) + apply (frule bspec, rule ranI, rule m_p) + apply (frule bspec, rule ranI, rule mdb_ptr_src.m_p) + apply (clarsimp simp: ball_ran_eq) + apply (case_tac cte, clarsimp) + apply (frule n_cap, frule revokable, frule badge_n) + apply (simp split: if_split_asm) + apply clarsimp + apply (elim allE, drule(1) mp) + apply simp + done + lemma cteSwap_valid_mdb_helper: assumes untyped_eq: "isUntypedCap src_cap \ scap = src_cap" "isUntypedCap dest_cap \ dcap = dest_cap" @@ -4789,7 +4827,7 @@ lemma cteSwap_valid_mdb_helper: using cteSwap_chain cteSwap_dlist_helper cteSwap_valid_badges cteSwap_chunked caps_contained untyped_mdb_n untyped_inc_n nullcaps_n ut_rev_n class_links_n irq_control_n - distinct_zombies_n + distinct_zombies_n reply_masters_rvk_fb_n by (auto simp:untyped_eq) end @@ -4835,9 +4873,9 @@ lemma cteSwap_iflive'[wp]: apply auto done -crunch updateMDB, updateCap - for valid_replies'[wp]: valid_replies' - (wp: valid_replies'_lift) +lemmas tcbSlots = + tcbCTableSlot_def tcbVTableSlot_def + tcbReplySlot_def tcbCallerSlot_def tcbIPCBufferSlot_def lemma cteSwap_valid_pspace'[wp]: "\valid_pspace' and @@ -4897,20 +4935,28 @@ lemma cteSwap_valid_pspace'[wp]: apply clarsimp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cteSwap - for tcb_at [wp]: "tcb_at' t" - and sch [wp]: "\s. P (ksSchedulerAction s)" - and inQ [wp]: "obj_at' (inQ d p) tcb" - and ksQ [wp]: "\s. P (ksReadyQueues s)" - and sym [wp]: "\s. sym_refs (state_refs_of' s)" - and cur [wp]: "\s. P (ksCurThread s)" - and ksCurDomain [wp]: "\s. P (ksCurDomain s)" - and ksDomSchedule [wp]: "\s. P (ksDomSchedule s)" - and it [wp]: "\s. P (ksIdleThread s)" - and ksIdleSC[wp]: "\s. P (ksIdleSC s)" - and tcbDomain_obj_at'[wp]: "obj_at' (\tcb. x = tcbDomain tcb) t" + for tcb_at[wp]: "tcb_at' t" +crunch cteSwap + for sch[wp]: "\s. P (ksSchedulerAction s)" +crunch cteSwap + for inQ[wp]: "obj_at' (inQ d p) tcb" +crunch cteSwap + for ksQ[wp]: "\s. P (ksReadyQueues s)" +crunch cteSwap + for sym[wp]: "\s. sym_refs (state_refs_of' s)" +crunch cteSwap + for cur[wp]: "\s. P (ksCurThread s)" +crunch cteSwap + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" +crunch cteSwap + for ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" +crunch cteSwap + for it[wp]: "\s. P (ksIdleThread s)" +crunch cteSwap + for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. x = tcbDomain tcb) t" lemma cteSwap_idle'[wp]: "\valid_idle'\ @@ -5007,19 +5053,33 @@ lemma cteSwap_urz[wp]: crunch cteSwap for valid_arch_state'[wp]: "valid_arch_state'" - and irq_states'[wp]: "valid_irq_states'" - and pde_mappings'[wp]: "valid_pde_mappings'" - and vq'[wp]: "valid_queues'" - and ksqsL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" - and ksqsL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" - 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 valid_release_queue[wp]: "valid_release_queue" - and valid_release_queue'[wp]: "valid_release_queue'" + +crunch cteSwap + for irq_states'[wp]: "valid_irq_states'" + +crunch cteSwap + for pde_mappings'[wp]: "valid_pde_mappings'" + +crunch cteSwap + for ksqsL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + +crunch cteSwap + for ksqsL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + +crunch cteSwap + for st_tcb_at'[wp]: "st_tcb_at' P t" + +crunch cteSwap + for vms'[wp]: "valid_machine_state'" + +crunch cteSwap + for pspace_domain_valid[wp]: "pspace_domain_valid" + +crunch cteSwap + for ct_not_inQ[wp]: "ct_not_inQ" + +crunch cteSwap + for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" crunch cteSwap for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers @@ -5037,14 +5097,14 @@ lemma cteSwap_invs'[wp]: K (c1 \ c2)\ cteSwap c c1 c' c2 \\rv. invs'\" - apply (simp add: invs'_def valid_dom_schedule'_def pred_conj_def) + apply (simp add: invs'_def valid_state'_def pred_conj_def) apply (rule hoare_pre) apply (wp hoare_vcg_conj_lift sch_act_wf_lift valid_queues_lift cur_tcb_lift valid_irq_node_lift irqs_masked_lift tcb_in_cur_domain'_lift ct_idle_or_in_cur_domain'_lift2) apply (clarsimp simp: cte_wp_at_ctes_of weak_derived_zobj weak_derived_cte_refs - weak_derived_capRange_capBits o_def) + weak_derived_capRange_capBits) done lemma capSwap_invs'[wp]: @@ -5498,17 +5558,13 @@ lemma make_zombie_invs': (\p \ threadCapRefs (cteCap cte). st_tcb_at' ((=) Inactive) 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 - \ \RT warning: The previous two conjuncts are new, they were - inserted to fix this lemma.\ \ obj_at' (Not \ tcbQueued) p s \ obj_at' (\tcb. tcbSchedNext tcb = None \ tcbSchedPrev tcb = None) p s)) sl s\ updateCap sl cap \\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 (simp add: invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def + valid_irq_handlers'_def irq_issued'_def) apply (wp updateCap_ctes_of_wp sch_act_wf_lift valid_queues_lift cur_tcb_lift updateCap_iflive' updateCap_ifunsafe' updateCap_idle' valid_arch_state_lift' valid_irq_node_lift ct_idle_or_in_cur_domain'_lift2 @@ -5516,40 +5572,36 @@ lemma make_zombie_invs': | simp)+ apply clarsimp apply (intro conjI[rotated]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (auto simp: untypedZeroRange_def isCap_simps)[1] - apply (clarsimp simp: modify_map_def ran_def split del: if_split - split: if_split_asm) - apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of isCap_simps) - subgoal by auto + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (auto simp: untypedZeroRange_def isCap_simps)[1] + apply (clarsimp simp: modify_map_def ran_def split del: if_split + split: if_split_asm) + apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of isCap_simps) + apply auto[1] - apply (clarsimp simp: disj_comms cte_wp_at_ctes_of - dest!: ztc_phys capBits_capUntyped_capRange) - apply (frule(1) capBits_capUntyped_capRange, simp) - apply (clarsimp dest!: valid_global_refsD_with_objSize) + apply (clarsimp simp: disj_comms cte_wp_at_ctes_of + dest!: ztc_phys capBits_capUntyped_capRange) + apply (frule(1) capBits_capUntyped_capRange, simp) + apply (clarsimp dest!: valid_global_refsD_with_objSize) - apply (clarsimp simp: disj_comms cte_wp_at_ctes_of - dest!: ztc_phys capBits_capUntyped_capRange) - apply (frule(1) capBits_capUntyped_capRange, simp) - apply (clarsimp dest!: valid_global_refsD_with_objSize) + apply (clarsimp simp: disj_comms cte_wp_at_ctes_of + dest!: ztc_phys capBits_capUntyped_capRange) + apply (frule(1) capBits_capUntyped_capRange, simp) + apply (clarsimp dest!: valid_global_refsD_with_objSize) - subgoal by (auto elim: if_unsafe_then_capD' simp: isCap_simps) + apply (auto elim: if_unsafe_then_capD' simp: isCap_simps)[1] apply (clarsimp simp: cte_wp_at_ctes_of) 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") - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def ko_wp_at'_def projectKOs) - subgoal by (auto dest!: isCapDs) - - apply (simp only: fold_list_refs_of_replies') - + 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 + \ obj_at' (\tcb. tcbSchedNext tcb = None + \ tcbSchedPrev tcb = None) p' s") + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def ko_wp_at'_def projectKOs) + apply (auto dest!: isCapDs)[1] apply (clarsimp simp: cte_wp_at_ctes_of disj_ac dest!: isCapDs) apply (frule ztc_phys[where cap=cap]) @@ -5627,15 +5679,19 @@ lemma make_zombie_invs': simp add: cteCaps_of_def, simp_all add: disj_ac)[1] apply (erule(1) ctes_of_valid_cap') + apply (rule conjI) apply (subgoal_tac "cap \ IRQControlCap") apply (clarsimp simp: irq_control_def) apply (clarsimp simp: isCap_simps) + apply (simp add: reply_masters_rvk_fb_def, erule ball_ran_fun_updI) + apply (clarsimp simp: isCap_simps) apply (clarsimp simp: modify_map_apply) apply (erule(1) ztc_replace_update_final, simp_all) apply (simp add: cteCaps_of_def) apply (erule(1) ctes_of_valid_cap') done + lemma isFinal_Zombie: "isFinal (Zombie p' b n) p cs" by (simp add: isFinal_def sameObjectAs_def isCap_simps) @@ -5657,10 +5713,38 @@ lemma shrink_zombie_invs': apply (rule ccontr, simp add: linorder_not_less mult.commute mult.left_commute) done +crunch suspend + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps getObject_inv_tcb simp: crunch_simps) + lemma cte_wp_at_cteCap_norm: "(cte_wp_at' (\c. P (cteCap c)) p s) = (\cap. cte_wp_at' (\c. cteCap c = cap) p s \ P cap)" by (auto simp add: cte_wp_at'_def) +crunch cancelAllIPC + for cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: crunch_wps mapM_x_wp simp: crunch_simps) + +crunch cancelAllIPC + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps mapM_x_wp simp: crunch_simps) + +crunch cancelAllSignals + for cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: crunch_wps mapM_x_wp simp: crunch_simps) + +crunch cancelAllSignals + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps mapM_x_wp simp: crunch_simps) + +crunch doMachineOp + for cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: crunch_wps mapM_x_wp simp: crunch_simps) + +crunch doMachineOp + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps mapM_x_wp simp: crunch_simps) + lemma valid_Zombie_cte_at': "\ s \' Zombie p zt m; n < zombieCTEs zt \ \ cte_at' (p + (of_nat n * 2^cteSizeBits)) s" apply (clarsimp simp: valid_cap'_def split: zombie_type.split_asm) @@ -5761,6 +5845,15 @@ lemma updateCap_cap_to': apply (clarsimp simp: modify_map_def cte_wp_at_ctes_of cteCaps_of_def) done +lemmas setNotification_cap_to'[wp] + = ex_cte_cap_to'_pres [OF setNotification_cte_wp_at' set_ntfn_ksInterrupt] + +lemmas setEndpoint_cap_to'[wp] + = ex_cte_cap_to'_pres [OF setEndpoint_cte_wp_at' setEndpoint_ksInterruptState] + +lemmas setThreadState_cap_to'[wp] + = ex_cte_cap_to'_pres [OF setThreadState_cte_wp_at' setThreadState_ksInterruptState] + crunch cancelSignal for cap_to'[wp]: "ex_cte_cap_wp_to' P p" (simp: crunch_simps wp: crunch_wps) @@ -5773,8 +5866,6 @@ lemma emptySlot_deletes [wp]: apply (clarsimp split: option.splits simp: modify_map_def) done -lemmas emptySlot_sch_act_simple[wp] = sch_act_simple_lift[OF emptySlot_nosch] - lemma capCylicZombieD[dest!]: "capCyclicZombie cap slot \ \zb n. cap = Zombie slot zb n" by (clarsimp simp: capCyclicZombie_def split: capability.split_asm) @@ -5808,9 +5899,10 @@ lemmas finaliseSlot_abort_cases = use_spec(2) [OF finaliseSlot_abort_cases', folded validE_R_def finaliseSlot_def] +crunch emptySlot + for it[wp]: "\s. P (ksIdleThread s)" crunch capSwapForDelete for it[wp]: "\s. P (ksIdleThread s)" - and ksIdleSC[wp]: "\s. P (ksIdleSC s)" lemma cteDelete_delete_cases: "\\\ @@ -5932,21 +6024,10 @@ definition "finalise_prop_stuff P = ((\s f. P (ksWorkUnitsCompleted_update f s) = P s) \ irq_state_independent_H P - \ updateTimeStamp_independent P - \ getCurrentTime_independent_H P - \ time_state_independent_H P - \ domain_time_independent_H P \ (\s f. P (gsUntypedZeroRanges_update f s) = P s) \ (\s f. P (ksInterruptState_update f s) = P s) \ (\s f. P (ksMachineState_update (irq_state_update f) s) = P s) - \ (\s f. P (ksMachineState_update (irq_masks_update f) s) = P s) - \ (\s f. P (s\ksMachineState := ksMachineState s \last_machine_time - := f (last_machine_time (ksMachineState s)) (time_state (ksMachineState s))\\) - = P s) - \ (\s f. P (ksMachineState_update (time_state_update f) s) = P s) - \ (\s f. P (ksCurTime_update f s) = P s) - \ (\s f. P (ksConsumedTime_update f s) = P s) - \ (\s f. P (ksDomainTime_update f s) = P s))" + \ (\s f. P (ksMachineState_update (irq_masks_update f) s) = P s))" lemma setCTE_no_cte_prop: "\no_cte_prop P\ setCTE sl cte \\_. no_cte_prop P\" @@ -6057,74 +6138,6 @@ lemmas preemptionPoint_invR = lemmas preemptionPoint_invE = valid_validE_E [OF preemptionPoint_inv] -lemma sch_act_simple_only_ksSchedulerAction: - "ksSchedulerAction (f s) = ksSchedulerAction s \ sch_act_simple (f s) = sch_act_simple s" - unfolding sch_act_simple_def - apply simp - done - -crunch schedContextCompleteYieldTo, unbindMaybeNotification, schedContextMaybeUnbindNtfn, - prepareThreadDelete, setMessageInfo, schedContextUpdateConsumed, isFinalCapability, - setQueue - for ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - -crunch tcbSchedEnqueue, replyClear, suspend, schedContextUnbindTCB, schedContextUnbindNtfn, - schedContextUnbindAllTCBs - for sch_act_simple[wp]: sch_act_simple - (wp: crunch_wps - simp: crunch_simps sch_act_simple_lift[OF setQueue_nosch] - sch_act_simple_only_ksSchedulerAction[where f="ksReadyQueuesL1Bitmap_update g" for g, - simplified] - sch_act_simple_only_ksSchedulerAction[where f="ksReadyQueuesL2Bitmap_update g" for g, - simplified]) - -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 finaliseCap_True_sch_act_simple[wp]: - "finaliseCap (cteCap x) y True \sch_act_simple\" - unfolding finaliseCap_def Let_def - apply (wpsimp wp: cancelAllIPC_sch_act_simple cancelAllSignals_sch_act_simple - hoare_drop_imp hoare_vcg_all_lift - comb: sch_act_simple_lift - simp: if_fun_split) - done - -lemma cteDeleteOne_sch_act_simple[wp]: - "cteDeleteOne cte_ptr \sch_act_simple\" - unfolding cteDeleteOne_def finaliseCapTrue_standin_simple_def - apply (wpsimp wp: haskell_assert_inv comb: sch_act_simple_lift) - done - -crunch deletingIRQHandler, unbindFromSC, schedContextSetInactive, schedContextUnbindYieldFrom, - schedContextUnbindReply - for sch_act_simple[wp]: sch_act_simple - (wp: crunch_wps simp: crunch_simps) - -lemma finaliseCap_False_sch_act_simple[wp]: - "finaliseCap (cteCap x) y False \sch_act_simple\" - unfolding finaliseCap_def Let_def - apply (wpsimp wp: cancelAllIPC_sch_act_simple cancelAllSignals_sch_act_simple - hoare_drop_imp hoare_vcg_all_lift - comb: sch_act_simple_lift - simp: if_fun_split) - done - lemma finaliseSlot_invs': assumes finaliseCap: "\cap final sl. \no_cte_prop Pr and invs' and sch_act_simple @@ -6195,7 +6208,7 @@ proof (induct arbitrary: P p rule: finalise_spec_induct2) apply (wp hyps) apply ((wp preemptionPoint_invE preemptionPoint_invR - | clarsimp simp: sch_act_simple_def ex_cte_cap_wp_to'_def + | clarsimp simp: sch_act_simple_def | simp cong: kernel_state.fold_congs machine_state.fold_congs)+)[1] apply (rule spec_strengthen_postE [OF reduceZombie_invs''[OF _ stuff]]) prefer 2 @@ -6257,10 +6270,10 @@ proof (induct arbitrary: P p rule: finalise_spec_induct2) apply clarsimp apply (clarsimp simp: cte_wp_at_ctes_of capRemovable_def) apply (subgoal_tac "final_matters' (cteCap rv) \ \ isUntypedCap (cteCap rv)") - apply (intro conjI impI - ; clarsimp? - ; erule_tac x=p in ballE - ; clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply clarsimp + apply (rule conjI) + apply clarsimp + apply clarsimp apply (case_tac "cteCap rv", simp_all add: isCap_simps final_matters'_def)[1] apply (wp isFinalCapability_inv hoare_weak_lift_imp | simp | wp (once) isFinal[where x=sl])+ @@ -6342,8 +6355,7 @@ lemma finaliseSlot_cte_wp_at: lemmas reduceZombie_invs' = reduceZombie_invs''[where Q=\, simplified no_cte_prop_top simp_thms - finalise_prop_stuff_def irq_state_independent_H_def updateTimeStamp_independent_def - getCurrentTime_independent_H_def time_state_independent_H_def domain_time_independent_H_def, + finalise_prop_stuff_def irq_state_independent_H_def, OF drop_spec_validE TrueI, OF hoare_weaken_preE, OF finaliseSlot_invs'', @@ -6400,19 +6412,15 @@ lemma cteDelete_invs': declare cases_simp_conj[simp] -end crunch capSwapForDelete 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) -crunch cteDelete - for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - (rule: cteDelete_preservation) +lemma cteDelete_typ_at' [wp]: + "\\s. P (typ_at' T p s)\ cteDelete slot exposed \\_ s. P (typ_at' T p s)\" + by (wp cteDelete_preservation | simp | fastforce)+ -global_interpretation cteDelete: typ_at_all_props' "cteDelete slot exposed" - by typ_at_props' +lemmas cteDelete_typ_at'_lifts [wp] = typ_at_lifts [OF cteDelete_typ_at'] lemma cteDelete_cte_at: "\\\ cteDelete slot bool \\rv. cte_at' slot\" @@ -6512,42 +6520,31 @@ lemma cteDelete_sch_act_simple: apply simp+ done -context begin interpretation Arch . (*FIXME: arch_split*) +crunch emptySlot + for st_tcb_at'[wp]: "st_tcb_at' P t" (simp: case_Null_If) -crunch "Arch.finaliseCap", unbindMaybeNotification, prepareThreadDelete, - schedContextMaybeUnbindNtfn, cleanReply +crunch "Arch.finaliseCap", unbindMaybeNotification, prepareThreadDelete for st_tcb_at'[wp]: "st_tcb_at' P t" - (simp: crunch_simps wp: crunch_wps getObject_inv) - -lemma replyPop_st_tcb_at': - assumes x[simp]: "\st. simple' st \ P st" - shows "replyPop a b \st_tcb_at' P t\" - unfolding replyPop_def - by (wpsimp wp: setThreadState_st_tcb_at'_test_unaffected replyUnlink_st_tcb_at' - hoare_drop_imp hoare_vcg_if_lift2 ) - -lemma replyRemove_st_tcb_at': - assumes x[simp]: "\st. simple' st \ P st" - shows "replyRemove a b \st_tcb_at' P t\" - unfolding replyRemove_def - by (wpsimp wp: setThreadState_st_tcb_at'_test_unaffected replyPop_st_tcb_at' - hoare_drop_imps hoare_vcg_if_lift2 replyUnlink_st_tcb_at') + (simp: crunch_simps wp: crunch_wps getObject_inv loadObject_default_inv) +end -lemma replyClear_st_tcb_at': - assumes x[simp]: "\st. simple' st \ P st" - shows "replyClear a b \st_tcb_at' P t\" - unfolding replyClear_def - by (wpsimp wp: replyUnlink_st_tcb_at' replyRemove_st_tcb_at' cancelIPC_st_tcb_at hoare_drop_imp) lemma finaliseCap2_st_tcb_at': assumes x[simp]: "\st. simple' st \ P st" - shows "finaliseCap cap final flag \st_tcb_at' P t\" + shows "\st_tcb_at' P t\ + finaliseCap cap final flag + \\rv. st_tcb_at' P t\" apply (simp add: finaliseCap_def Let_def getThreadCSpaceRoot deletingIRQHandler_def cong: if_cong split del: if_split) - apply (wpsimp wp: cancelAllIPC_st_tcb_at cancelAllSignals_st_tcb_at - replyClear_st_tcb_at' suspend_st_tcb_at' cteDeleteOne_st_tcb_at getCTE_wp' - hoare_drop_imp hoare_vcg_if_lift2 hoare_vcg_all_lift) + apply (rule hoare_pre) + apply ((wp cancelAllIPC_st_tcb_at cancelAllSignals_st_tcb_at + prepareThreadDelete_st_tcb_at' + suspend_st_tcb_at' cteDeleteOne_st_tcb_at getCTE_wp' + | simp add: isCap_simps getSlotCap_def getIRQSlot_def + locateSlot_conv getInterruptState_def + split del: if_split + | wpc))+ done crunch capSwapForDelete @@ -6622,24 +6619,31 @@ lemma capSwap_rvk_prog: apply arith done +lemmas setObject_ASID_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF setObject_ASID_ctes_of'] lemmas cancelAllIPC_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF cancelAllIPC_ctes_of] lemmas cancelAllSignals_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF cancelAllSignals_ctes_of] +lemmas setEndpoint_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_ep_ctes_of] +lemmas setNotification_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_ntfn_ctes_of] lemmas emptySlot_rvk_prog' = emptySlot_rvk_prog[unfolded o_def] lemmas threadSet_ctesCaps_of = ctes_of_cteCaps_of_lift[OF threadSet_ctes_of] +lemmas storePTE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePTE_ctes] +lemmas storePDE_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF storePDE_ctes] + +context begin interpretation Arch . (*FIXME: arch-split*) + context notes option.case_cong_weak[cong] begin crunch finaliseCap - for rvk_prog': "\s. revoke_progress_ord m (\x. option_map capToRPO (cteCaps_of s x))" - (wp: crunch_wps emptySlot_rvk_prog' threadSet_ctesCaps_of hoare_vcg_all_lift getObject_inv + for rvk_prog': "\s. revoke_progress_ord m (\x. option_map capToRPO (cteCaps_of s x))" + (wp: crunch_wps emptySlot_rvk_prog' threadSet_ctesCaps_of + getObject_inv loadObject_default_inv simp: crunch_simps unless_def o_def ignore: setCTE threadSet) end -end - lemmas finalise_induct3 = finaliseSlot'.induct[where P= "\sl exp s. P sl (finaliseSlot' sl exp) s" for P] @@ -6655,19 +6659,15 @@ proof (induct rule: finalise_induct3) apply (rule hoare_pre_spec_validE) apply wp apply ((wp | simp)+)[1] - apply (wp "1.hyps") - apply (unfold Let_def split_def fst_conv - snd_conv haskell_fail_def - case_Zombie_assert_fold) - apply (wp capSwap_rvk_prog | simp only: withoutPreemption_def)+ - apply (wp preemptionPoint_inv)[1] - apply force - apply force - apply (clarsimp simp: updateTimeStamp_independent_def) - apply (clarsimp simp: getCurrentTime_independent_H_def) - apply (clarsimp simp: time_state_independent_H_def) - apply (clarsimp simp: domain_time_independent_H_def) - apply (wp capSwap_rvk_prog | simp only: withoutPreemption_def)+ + apply (wp "1.hyps") + apply (unfold Let_def split_def fst_conv + snd_conv haskell_fail_def + case_Zombie_assert_fold) + apply (wp capSwap_rvk_prog | simp only: withoutPreemption_def)+ + apply (wp preemptionPoint_inv)[1] + apply force + apply force + apply (wp capSwap_rvk_prog | simp only: withoutPreemption_def)+ apply (wp getCTE_wp | simp)+ apply (rule hoare_strengthen_post [OF emptySlot_rvk_prog[where m=m]]) apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def o_def @@ -6875,8 +6875,6 @@ lemmas rec_del_concrete_unfold = rec_del_concrete.simps red_zombie_will_fail.simps if_True if_False ball_simps simp_thms -context begin interpretation Arch . (*FIXME: arch_split*) - lemma cap_relation_removables: "\ cap_relation cap cap'; isNullCap cap' \ isZombie cap'; s \ cap; cte_at slot s; invs s \ @@ -6884,7 +6882,7 @@ lemma cap_relation_removables: \ cap_cyclic_zombie cap slot = capCyclicZombie cap' (cte_map slot)" apply (clarsimp simp: capRemovable_def isCap_simps capCyclicZombie_def cap_cyclic_zombie_def - split: cap_relation_split_asm arch_cap.split_asm) + split: cap_relation_split_asm arch_cap.split_asm) apply (rule iffD1 [OF conj_commute], rule context_conjI) apply (rule iffI) apply (clarsimp simp: cte_map_replicate) @@ -6908,15 +6906,11 @@ lemma spec_corres_gen_asm2: unfolding spec_corres_def by (auto intro: corres_gen_asm2) -end - crunch reduceZombie for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" (simp: crunch_simps wp: crunch_wps) -global_interpretation reduceZombie: typ_at_all_props' "reduceZombie cap slot x" - by typ_at_props' +lemmas reduceZombie_typ_ats[wp] = typ_at_lifts [OF reduceZombie_typ_at'] lemma spec_corres_if: "\ G = G'; G \ spec_corres s r P P' a c; \ G \ spec_corres s r Q Q' b d\ @@ -6929,6 +6923,20 @@ lemma spec_corres_liftME2: = spec_corres s (f \ (\x. r x \ fn)) P P' m m'" by (simp add: spec_corres_def) + +lemma rec_del_ReduceZombie_emptyable: + "\invs + and (cte_wp_at ((=) cap) slot and is_final_cap' cap + and (\y. is_zombie cap)) and + (\s. \ ex \ ex_cte_cap_wp_to (\cp. cap_irqs cp = {}) slot s) and + emptyable slot and + (\s. \ cap_removeable cap slot \ (\t\obj_refs cap. halted_if_tcb t s))\ + rec_del (ReduceZombieCall cap slot ex) \\rv. emptyable slot\, -" + by (rule rec_del_emptyable [where args="ReduceZombieCall cap slot ex", simplified]) + +crunch cteDelete + for sch_act_simple[wp]: sch_act_simple + lemmas preemption_point_valid_list = preemption_point_inv'[where P="valid_list", simplified] lemma finaliseSlot_typ_at'[wp]: @@ -6940,17 +6948,16 @@ lemmas finaliseSlot_typ_ats[wp] = typ_at_lifts[OF finaliseSlot_typ_at'] lemmas rec_del_valid_list_irq_state_independent[wp] = rec_del_preservation[OF cap_swap_for_delete_valid_list set_cap_valid_list empty_slot_valid_list finalise_cap_valid_list preemption_point_valid_list] -context begin interpretation Arch . (*FIXME: arch_split*) - lemma rec_del_corres: "\C \ rec_del_concrete args. spec_corres s (dc \ (case args of FinaliseSlotCall _ _ \ (\r r'. fst r = fst r' \ cap_relation (snd r) (snd r') ) | _ \ dc)) - (einvs and valid_machine_time and simple_sched_action - and valid_rec_del_call args and current_time_bounded + (einvs and simple_sched_action + and valid_rec_del_call args and cte_at (slot_rdcall args) + and emptyable (slot_rdcall args) and (\s. \ exposed_rdcall args \ ex_cte_cap_wp_to (\cp. cap_irqs cp = {}) (slot_rdcall args) s) and (\s. case args of ReduceZombieCall cap sl ex \ \t\obj_refs cap. halted_if_tcb t s @@ -6980,8 +6987,8 @@ proof (induct rule: rec_del.induct, apply (rule corres_when, simp) apply simp apply (rule emptySlot_corres) - apply (wpsimp wp: rec_del_invs rec_del_valid_list rec_del_valid_sched rec_del_cte_at - finaliseSlot_invs hoare_drop_imps preemption_point_inv' + apply (wp rec_del_invs rec_del_valid_list rec_del_cte_at finaliseSlot_invs hoare_drop_imps + preemption_point_inv' | simp)+ done next @@ -7045,31 +7052,22 @@ next apply (rule "2.hyps"(2)[unfolded fun_app_def rec_del_concrete_unfold finaliseSlot_def], assumption+) - apply ((wpsimp wp: preemption_point_valid_machine_time - preemption_point_valid_list - preemption_point_valid_sched)+)[1] - apply (wpsimp wp: preemption_point_inv) - apply (clarsimp simp: ex_cte_cap_wp_to_def) + apply (wp preemption_point_inv')[1] apply clarsimp+ apply (wp preemptionPoint_invR) - apply simp - apply clarsimp - apply (clarsimp simp: sch_act_simple_def ex_cte_cap_wp_to'_def) - apply (clarsimp simp: sch_act_simple_def ex_cte_cap_wp_to'_def) - apply (clarsimp simp: sch_act_simple_def ex_cte_cap_wp_to'_def) - apply (clarsimp simp: sch_act_simple_def ex_cte_cap_wp_to'_def) - apply (wpsimp wp: rec_del_invs rec_del_cte_at reduce_zombie_cap_somewhere - reduceZombie_invs reduce_zombie_cap_to - DetSchedSchedule_AI_det_ext.rec_del_valid_sched - | strengthen invs_valid_objs invs_cur_sc_tcb invs_psp_aligned invs_distinct - valid_sched_active_scs_valid)+ - apply ((wpsimp wp: reduceZombie_cap_to reduceZombie_sch_act_simple - reduceZombie_invs | strengthen invs_valid_objs')+)[1] + apply simp + apply clarsimp + apply simp + apply (wp rec_del_invs rec_del_cte_at reduce_zombie_cap_somewhere + rec_del_ReduceZombie_emptyable + reduceZombie_invs reduce_zombie_cap_to | simp)+ + apply (wp reduceZombie_cap_to reduceZombie_sch_act_simple)+ apply simp apply ((wp replace_cap_invs final_cap_same_objrefs set_cap_cte_wp_at set_cap_cte_cap_wp_to hoare_vcg_const_Ball_lift hoare_weak_lift_imp - | simp add: conj_comms)+)[1] + | simp add: conj_comms + | erule finalise_cap_not_reply_master [simplified])+)[1] apply (simp(no_asm_use)) apply (wp make_zombie_invs' updateCap_cap_to' updateCap_cte_wp_at_cases @@ -7085,9 +7083,10 @@ next apply (clarsimp simp: conj_comms) apply (wp | simp)+ apply (rule hoare_strengthen_post) - apply (rule_tac Q="\fin s. einvs s \ valid_machine_time s \ simple_sched_action s - \ replaceable s slot (fst fin) rv \ current_time_bounded s + apply (rule_tac Q="\fin s. einvs s \ simple_sched_action s + \ replaceable s slot (fst fin) rv \ cte_wp_at ((=) rv) slot s \ s \ fst fin + \ emptyable slot s \ (\t\obj_refs (fst fin). halted_if_tcb t s)" in hoare_vcg_conj_lift) apply (wp finalise_cap_invs finalise_cap_replaceable @@ -7118,24 +7117,19 @@ next apply (clarsimp simp: capRemovable_def cte_wp_at_ctes_of) apply (clarsimp dest!: isCapDs simp: cte_wp_at_ctes_of) apply (case_tac "cteCap rv'", - auto simp add: isCap_simps is_cap_simps final_matters'_def pred_tcb_at'_def - obj_at'_def)[1] - apply (wpsimp wp: isFinal[where x="cte_map slot"] - simp: is_final_cap_def) - apply (wpsimp wp: isFinalCapability_inv hoare_weak_lift_imp isFinal - simp: is_final_cap_def) - apply (wpsimp wp: get_cap_wp) - apply (wpsimp wp: getCTE_wp') + auto simp add: isCap_simps is_cap_simps final_matters'_def)[1] + apply (wp isFinalCapability_inv hoare_weak_lift_imp + | simp add: is_final_cap_def conj_comms cte_wp_at_eq_simp)+ + apply (rule isFinal[where x="cte_map slot"]) + apply (wp get_cap_wp| simp add: conj_comms)+ + apply (wp getCTE_wp') apply clarsimp - apply (frule(1) cte_wp_at_valid_objs_valid_cap[where P="(=) cap" for cap, - OF _ invs_valid_objs]) - supply split_paired_Ex[simp del] - 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 (frule(1) ctes_of_valid') - apply fastforce + apply (frule cte_wp_at_valid_objs_valid_cap[where P="(=) cap" for cap]) + apply fastforce + apply (fastforce simp: cte_wp_at_caps_of_state) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (frule ctes_of_valid', clarsimp) + apply ((clarsimp | rule conjI)+)[1] done next @@ -7190,9 +7184,9 @@ next apply clarsimp apply (clarsimp simp: cte_wp_at_caps_of_state) apply (erule tcb_valid_nonspecial_cap, fastforce) - apply (clarsimp simp: ran_tcb_cap_cases is_cap_simps is_nondevice_page_cap_def + apply (clarsimp simp: ran_tcb_cap_cases is_cap_simps is_nondevice_page_cap_simps split: Structures_A.thread_state.split) - apply (clarsimp simp: is_nondevice_page_cap_def) + apply (simp add: ran_tcb_cap_cases is_cap_simps is_nondevice_page_cap_simps) apply fastforce apply wp apply (rule no_fail_pre, wp) @@ -7329,6 +7323,7 @@ next apply (frule cte_wp_valid_cap, clarsimp) apply (rule conjI, erule cte_at_nat_to_cref_zbits) apply simp + apply (simp add: halted_emptyable) apply (erule(1) zombie_is_cap_toE) apply simp apply simp @@ -7359,8 +7354,7 @@ qed lemma cteDelete_corres: "corres (dc \ dc) - (einvs and valid_machine_time and simple_sched_action - and current_time_bounded and cte_at ptr) + (einvs and simple_sched_action and cte_at ptr and emptyable ptr) (invs' and sch_act_simple and cte_at' (cte_map ptr)) (cap_delete ptr) (cteDelete (cte_map ptr) True)" unfolding cap_delete_def @@ -7390,7 +7384,7 @@ termination cteRevoke apply (rule cteRevoke.termination) apply (rule wf_cteRevoke_recset) apply (clarsimp simp add: cteRevoke_recset_def in_monad - dest!: in_getCTE) + dest!: in_getCTE in_preempt') apply (frule use_validE_R [OF _ cteDelete_rvk_prog]) apply (rule rpo_sym) apply (frule use_validE_R [OF _ cteDelete_deletes]) @@ -7401,41 +7395,34 @@ termination cteRevoke apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def capToRPO_def) apply (simp split: capability.split_asm) apply (case_tac rvb, clarsimp) - apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def capToRPO_def) - apply (erule (1) use_valid[OF _ preemptionPoint_ctes_of]) + apply assumption done lemma cteRevoke_preservation': assumes x: "\ptr. \P\ cteDelete ptr True \\rv. P\" assumes y: "\f s. P (ksWorkUnitsCompleted_update f s) = P s" - assumes indep: "irq_state_independent_H P" - "updateTimeStamp_independent P" - "getCurrentTime_independent_H P" - "time_state_independent_H P" - "domain_time_independent_H P" + assumes irq: "irq_state_independent_H P" shows "s \ \P\ cteRevoke ptr \\rv. P\,\\rv. P\" proof (induct rule: cteRevoke.induct) case (1 p s') show ?case apply (subst cteRevoke.simps) apply (wp "1.hyps") - apply (wp x y preemptionPoint_inv hoare_drop_imps indep | clarsimp)+ + apply (wp x y preemptionPoint_inv hoare_drop_imps irq | clarsimp)+ done qed lemmas cteRevoke_preservation = validE_valid [OF use_spec(2) [OF cteRevoke_preservation']] -crunch cteRevoke - for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - (rule: cteRevoke_preservation) +lemma cteRevoke_typ_at': + "\\s. P (typ_at' T p s)\ cteRevoke ptr \\rv s. P (typ_at' T p s)\" + by (wp cteRevoke_preservation | clarsimp)+ lemma cteRevoke_invs': "\invs' and sch_act_simple\ cteRevoke ptr \\rv. invs'\" apply (rule_tac Q'="\rv. invs' and sch_act_simple" in hoare_strengthen_post) - apply (wpsimp wp: cteRevoke_preservation cteDelete_invs' cteDelete_sch_act_simple - simp: sch_act_simple_def)+ + apply (wpsimp wp: cteRevoke_preservation cteDelete_invs' cteDelete_sch_act_simple)+ done declare cteRevoke.simps[simp del] @@ -7606,7 +7593,7 @@ lemma cap_revoke_mdb_stuff4: lemma cteRevoke_corres': "spec_corres s (dc \ dc) - (einvs and valid_machine_time and simple_sched_action and cte_at ptr and current_time_bounded) + (einvs and simple_sched_action and cte_at ptr) (invs' and sch_act_simple and cte_at' (cte_map ptr)) (cap_revoke ptr) (\s. cteRevoke (cte_map ptr) s)" proof (induct rule: cap_revoke.induct) @@ -7731,33 +7718,26 @@ proof (induct rule: cap_revoke.induct) apply (rule "1.hyps", (simp add: cte_wp_at_def in_monad select_def next_revoke_cap_def select_ext_def | assumption | rule conjI refl)+)[1] - apply (wpsimp - | wp preemptionPoint_invR preemption_point_inv')+ - apply (clarsimp simp: sch_act_simple_def)+ - apply (wpsimp wp: cteDelete_invs' cteDelete_sch_act_simple - | strengthen invs_valid_objs invs_cur_sc_tcb invs_psp_aligned invs_distinct - valid_sched_active_scs_valid invs_valid_objs')+ + apply (wp cap_delete_cte_at cteDelete_invs' cteDelete_sch_act_simple + preemptionPoint_invR preemption_point_inv' | clarsimp)+ apply (clarsimp simp: cte_wp_at_cte_at) - apply (drule next_childD, simp) - apply (clarsimp, drule child_descendant) + apply(drule next_childD, simp) + apply(clarsimp, drule child_descendant) + apply (fastforce simp: emptyable_def dest: reply_slot_not_descendant) apply (clarsimp elim!: cte_wp_at_weakenE') done qed lemmas cteRevoke_corres = use_spec_corres [OF cteRevoke_corres'] -end - crunch invokeCNode for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" (ignore: filterM finaliseSlot simp: crunch_simps filterM_mapM unless_def arch_recycleCap_improve_cases wp: crunch_wps undefined_valid finaliseSlot_preservation) -global_interpretation invokeCNode: typ_at_all_props' "invokeCNode i" - by typ_at_props' +lemmas invokeCNode_typ_ats [wp] = typ_at_lifts [OF invokeCNode_typ_at'] crunch cteMove for st_tcb_at'[wp]: "st_tcb_at' P t" @@ -7804,6 +7784,8 @@ lemma updateCap_valid_objs [wp]: apply (erule cte_at_cte_wp_atD) done +end + lemma (in mdb_move) [intro!]: shows "mdb_chain_0 m" using valid by (auto simp: valid_mdb_ctes_def) @@ -7868,7 +7850,7 @@ lemma (in mdb_move) m'_cap: context mdb_move begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma m_to_src: "m \ p \ src = (p \ 0 \ p = mdbPrev src_node)" @@ -8383,11 +8365,23 @@ proof apply (clarsimp simp: weak_derived'_def) done + have "reply_masters_rvk_fb m" using valid .. + thus "reply_masters_rvk_fb m'" using neq parency + apply (simp add: m'_def n_def reply_masters_rvk_fb_def + ball_ran_modify_map_eq) + apply (simp add: modify_map_apply m_p dest) + apply (intro ball_ran_fun_updI, simp_all) + apply (frule bspec, rule ranI, rule m_p) + apply (clarsimp simp: weak_derived'_def) + apply (drule master_eqE[where F=isReplyCap], simp add: isCap_Master) + apply (simp add: isCap_simps)+ + done + qed end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_iflive'[wp]: "\\s. if_live_then_nonz_cap' s @@ -8424,19 +8418,19 @@ lemma cteMove_valid_pspace' [wp]: apply (simp add: pred_conj_def valid_pspace'_def valid_mdb'_def) apply (wp sch_act_wf_lift valid_queues_lift cur_tcb_lift updateCap_no_0 updateCap_ctes_of_wp getCTE_wp | simp)+ - apply (clarsimp simp: invs'_def)+ + apply (clarsimp simp: invs'_def valid_state'_def)+ apply (clarsimp dest!: cte_at_cte_wp_atD) apply (rule_tac x = cte in exI) apply clarsimp apply (clarsimp dest!: cte_at_cte_wp_atD) apply (rule_tac x = ctea in exI) apply (clarsimp simp: isCap_simps) - apply (rule conjI) - apply (fastforce) + apply rule + apply (clarsimp elim!: valid_mdb_ctesE) apply (case_tac ctea) apply (case_tac cte) apply (rule_tac old_dest_node = "cteMDBNode cte" and src_cap = "cteCap ctea" in - mdb_move.cteMove_valid_mdb_helper) + mdb_move.cteMove_valid_mdb_helper) prefer 2 apply (clarsimp simp: cte_wp_at_ctes_of weak_derived'_def isCap_simps simp del: not_ex) apply unfold_locales @@ -8564,25 +8558,28 @@ crunch updateMDB for valid_bitmaps[wp]: valid_bitmaps (rule: valid_bitmaps_lift) -(* FIXME: arch_split *) +(* FIXME: arch-split *) lemma haskell_assert_inv: "haskell_assert Q L \P\" by wpsimp lemma cteMove_invs' [wp]: - "\\s. invs' s \ ex_cte_cap_to' word2 s \ - cte_wp_at' (\c. weak_derived' (cteCap c) capability) word1 s \ - cte_wp_at' (\c. isUntypedCap (cteCap c) \ capability = cteCap c) word1 s \ - cte_wp_at' (\c. (cteCap c) \ NullCap) word1 s \ - s \' capability \ - cte_wp_at' (\c. cteCap c = capability.NullCap) word2 s\ + "\\x. invs' x \ ex_cte_cap_to' word2 x \ + cte_wp_at' (\c. weak_derived' (cteCap c) capability) word1 x \ + cte_wp_at' (\c. isUntypedCap (cteCap c) \ capability = cteCap c) word1 x \ + cte_wp_at' (\c. (cteCap c) \ NullCap) word1 x \ + x \' capability \ + cte_wp_at' (\c. cteCap c = capability.NullCap) word2 x\ cteMove capability word1 word2 \\y. invs'\" - apply (simp add: invs'_def pred_conj_def valid_dom_schedule'_def) - apply (intro hoare_vcg_conj_lift_pre_fix - ; solves \wpsimp wp: cteMove_urz cteMove_ifunsafe' - | wpsimp simp: cteMove_def o_def - wp: valid_queues_lift hoare_drop_imps\) + apply (simp add: invs'_def valid_state'_def pred_conj_def) + apply (rule hoare_pre) + apply ((rule hoare_vcg_conj_lift, (wp cteMove_ifunsafe')[1]) + | rule hoare_vcg_conj_lift[rotated])+ + apply (unfold cteMove_def) + apply (wp cur_tcb_lift valid_queues_lift haskell_assert_inv + sch_act_wf_lift ct_idle_or_in_cur_domain'_lift2 tcb_in_cur_domain'_lift)+ + apply clarsimp done lemma cteMove_cte_wp_at: @@ -8615,10 +8612,7 @@ lemma cteMove_ex: apply clarsimp done -end - -global_interpretation cteMove: typ_at_all_props' "cteMove cap src dest" - by typ_at_props' +lemmas cteMove_typ_at_lifts [wp] = typ_at_lifts [OF cteMove_typ_at'] lemmas finalise_slot_corres' = rec_del_corres[where args="FinaliseSlotCall slot exp", @@ -8626,7 +8620,8 @@ lemmas finalise_slot_corres' simplified, folded finalise_slot_def] for slot exp lemmas finalise_slot_corres = use_spec_corres [OF finalise_slot_corres'] -context begin interpretation Arch . (*FIXME: arch_split*) +crunch updateCap + for ksMachine[wp]: "\s. P (ksMachineState s)" lemma cap_relation_same: "\ cap_relation cap cap'; cap_relation cap cap'' \ @@ -8635,89 +8630,141 @@ lemma cap_relation_same: arch_cap.split_asm) crunch updateCap - for gsUserPages[wp]: "\s. P (gsUserPages s)" + for gsUserPages[wp]: "\s. P (gsUserPages s)" crunch updateCap - for gsCNodes[wp]: "\s. P (gsCNodes s)" + for gsCNodes[wp]: "\s. P (gsCNodes s)" crunch updateCap - for ksWorkUnitsCompleted[wp]: "\s. P (ksWorkUnitsCompleted s)" + for ksWorkUnitsCompleted[wp]: "\s. P (ksWorkUnitsCompleted s)" crunch updateCap - for ksDomainTime[wp]: "\s. P (ksDomainTime s)" + for ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" +crunch updateCap + for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" +crunch updateCap + for ksDomainTime[wp]: "\s. P (ksDomainTime s)" declare corres_False' [simp] lemma invokeCNode_corres: "cnodeinv_relation ci ci' \ corres (dc \ dc) - (einvs and valid_machine_time and simple_sched_action and valid_cnode_inv ci - and current_time_bounded) + (einvs and simple_sched_action and valid_cnode_inv ci) (invs' and sch_act_simple and valid_cnode_inv' ci') (invoke_cnode ci) (invokeCNode ci')" apply (simp add: invoke_cnode_def invokeCNode_def) apply (cases ci, simp_all) + apply clarsimp + apply (rule corres_guard_imp) + apply (rule cteInsert_corres) + apply simp+ + apply (clarsimp simp: invs_def valid_state_def valid_pspace_def + elim!: cte_wp_at_cte_at) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) apply clarsimp apply (rule corres_guard_imp) - apply (rule cteInsert_corres) - apply simp+ - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def - elim!: cte_wp_at_cte_at) - apply (clarsimp simp: invs'_def valid_pspace'_def) - apply clarsimp - apply (rule corres_guard_imp) - apply (erule cteMove_corres) - apply (clarsimp simp: cte_wp_at_caps_of_state real_cte_tcb_valid) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (rule cteRevoke_corres) - apply (rule corres_guard_imp [OF cteDelete_corres]) - apply (clarsimp simp: cte_at_typ cap_table_at_typ) - apply simp - apply (rename_tac cap1 cap2 p1 p2 p3) - apply (elim conjE exE) - apply (intro impI conjI) - apply simp - apply (rule corres_guard_imp) - apply (rule_tac F="wellformed_cap cap1 \ wellformed_cap cap2" - in corres_gen_asm) - apply (erule (1) cteSwap_corres [OF refl refl], simp+) - apply (simp add: invs_def valid_state_def valid_pspace_def - real_cte_tcb_valid valid_cap_def2) - apply (clarsimp simp: invs'_def valid_pspace'_def - cte_wp_at_ctes_of weak_derived'_def) - apply (simp split del: if_split) - apply (rule_tac F = "cte_map p1 \ cte_map p3" in corres_req) - apply clarsimp - apply (drule (2) cte_map_inj_eq [OF _ cte_wp_at_cte_at cte_wp_at_cte_at]) + apply (erule cteMove_corres) + apply (clarsimp simp: cte_wp_at_caps_of_state real_cte_tcb_valid) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (rule cteRevoke_corres) + apply (rule corres_guard_imp [OF cteDelete_corres]) + apply (clarsimp simp: cte_at_typ cap_table_at_typ halted_emptyable) + apply simp + apply (rename_tac cap1 cap2 p1 p2 p3) + apply (elim conjE exE) + apply (intro impI conjI) + apply simp + apply (rule corres_guard_imp) + apply (rule_tac F="wellformed_cap cap1 \ wellformed_cap cap2" + in corres_gen_asm) + apply (erule (1) cteSwap_corres [OF refl refl], simp+) + apply (simp add: invs_def valid_state_def valid_pspace_def + real_cte_tcb_valid valid_cap_def2) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def + cte_wp_at_ctes_of weak_derived'_def) + apply (simp split del: if_split) + apply (rule_tac F = "cte_map p1 \ cte_map p3" in corres_req) + apply clarsimp + apply (drule (2) cte_map_inj_eq [OF _ cte_wp_at_cte_at cte_wp_at_cte_at]) + apply clarsimp apply clarsimp apply clarsimp - apply clarsimp + apply simp apply simp - apply simp - apply (rule corres_guard_imp) - apply (rule corres_split) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (erule cteMove_corres) apply (erule cteMove_corres) - apply (erule cteMove_corres) - apply wp - apply (simp add: cte_wp_at_caps_of_state) - apply (wp cap_move_caps_of_state cteMove_cte_wp_at [simplified o_def])+ - apply (simp add: real_cte_tcb_valid invs_def valid_state_def valid_pspace_def) + apply wp + apply (simp add: cte_wp_at_caps_of_state) + apply (wp cap_move_caps_of_state cteMove_cte_wp_at [simplified o_def])+ + apply (simp add: real_cte_tcb_valid invs_def valid_state_def valid_pspace_def) + apply (elim conjE exE) + apply (drule(3) real_cte_weak_derived_not_reply_masterD)+ + apply (clarsimp simp: cte_wp_at_caps_of_state + ex_cte_cap_to_cnode_always_appropriate_strg + cte_wp_at_conj) + apply (simp add: cte_wp_at_ctes_of) apply (elim conjE exE) - apply (clarsimp simp: cte_wp_at_caps_of_state - ex_cte_cap_to_cnode_always_appropriate_strg - cte_wp_at_conj) - apply (simp add: cte_wp_at_ctes_of) - apply (elim conjE exE) - apply (intro impI conjI) - apply fastforce - apply (fastforce simp: weak_derived'_def) - apply simp - apply (erule weak_derived_sym') - apply clarsimp - apply simp + apply (intro impI conjI) + apply fastforce + apply (fastforce simp: weak_derived'_def) + apply simp + apply (erule weak_derived_sym') + apply clarsimp + apply simp apply clarsimp apply simp apply clarsimp apply clarsimp - apply (rename_tac prod) - apply (case_tac "has_cancel_send_rights prod", + apply (rename_tac prod) + apply (simp add: getThreadCallerSlot_def locateSlot_conv objBits_simps) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getCurThread_corres]) + apply (subgoal_tac "thread + 2^cte_level_bits * tcbCallerSlot = cte_map (thread, tcb_cnode_index 3)") + prefer 2 + apply (simp add: cte_map_def tcb_cnode_index_def tcbCallerSlot_def cte_level_bits_def objBits_defs) + apply (rule corres_split[OF getSlotCap_corres]) + apply simp + apply (rule_tac P="\s. (is_reply_cap cap \ cap = cap.NullCap) \ + (is_reply_cap cap \ + (einvs and cte_at (threada, tcb_cnode_index 3) and + cte_wp_at (\c. c = cap.NullCap) prod and + real_cte_at prod and valid_cap cap and + K ((threada, tcb_cnode_index 3) \ prod)) s)" and + P'="\s. (isReplyCap rv' \ \ capReplyMaster rv') \ (invs' and + cte_wp_at' + (\c. weak_derived' rv' (cteCap c) \ + cteCap c \ capability.NullCap) + (cte_map (threada, tcb_cnode_index 3)) and + cte_wp_at' (\c. cteCap c = capability.NullCap) (cte_map prod)) s" in corres_inst) + apply (case_tac cap, simp_all add: isCap_simps is_cap_simps split: bool.split)[1] + apply clarsimp + apply (rule corres_guard_imp) + apply (rule cteMove_corres) + apply (simp add: real_cte_tcb_valid)+ + apply (wp get_cap_wp) + apply (simp add: getSlotCap_def) + apply (wp getCTE_wp)+ + apply clarsimp + apply (rule conjI) + apply (rule tcb_at_cte_at) + apply fastforce + apply (simp add: tcb_cap_cases_def) + apply (clarsimp simp: cte_wp_at_cte_at) + apply (rule conjI) + apply (frule tcb_at_invs) + apply (frule_tac ref="tcb_cnode_index 3" and Q="is_reply_cap or (=) cap.NullCap" + in tcb_cap_wp_at) + apply (clarsimp split: Structures_A.thread_state.split_asm)+ + apply (clarsimp simp: cte_wp_at_def is_cap_simps all_rights_def) + apply clarsimp + apply (rule conjI, simp add: cte_wp_valid_cap invs_valid_objs) + apply (clarsimp simp: cte_wp_at_def is_cap_simps all_rights_def) + apply clarsimp + apply (rule conjI, fastforce) + apply (rule conjI, fastforce) + apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) + apply clarsimp + apply (case_tac "has_cancel_send_rights x7", frule has_cancel_send_rights_ep_cap, simp add: is_cap_simps) apply (clarsimp simp: when_def unless_def isCap_simps) @@ -8743,14 +8790,14 @@ lemma updateCap_noop_irq_handlers: 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'\" - apply (simp add: invs'_def valid_dom_schedule'_def valid_pspace'_def valid_mdb'_def) + apply (simp add: invs'_def valid_state'_def + valid_pspace'_def valid_mdb'_def) apply (rule hoare_pre) apply (wp updateCap_ctes_of_wp updateCap_iflive' updateCap_ifunsafe' updateCap_idle' @@ -8761,7 +8808,7 @@ lemma updateCap_noop_invs: apply (strengthen untyped_ranges_zero_delta[where xs=Nil, mk_strg I E]) apply (case_tac cte) apply (clarsimp simp: fun_upd_idem cteCaps_of_def modify_map_apply - valid_mdb'_def o_def) + valid_mdb'_def) apply (frule(1) ctes_of_valid') apply (frule(1) valid_global_refsD_with_objSize) apply clarsimp @@ -8776,44 +8823,89 @@ lemmas make_zombie_or_noop_or_arch_invs hoare_vcg_disj_lift [OF make_zombie_invs' arch_update_updateCap_invs], simplified] -crunch cteMove - for sc_at'_n[wp]: "sc_at'_n n p" - (simp: crunch_simps wp: crunch_wps) - lemma invokeCNode_invs' [wp]: "\invs' and sch_act_simple and valid_cnode_inv' cinv\ invokeCNode cinv \\y. invs'\" unfolding invokeCNode_def apply (wpsimp wp: cteRevoke_invs' cteInsert_invs cteMove_ex cteMove_cte_wp_at - getCTE_wp cteDelete_invs' - simp: unless_def getSlotCap_def locateSlot_conv +getCTE_wp cteDelete_invs' + simp: unless_def getSlotCap_def getThreadCallerSlot_def locateSlot_conv split_del: if_split) apply (cases cinv; clarsimp) - apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def isCap_simps badge_derived'_def) - apply (erule(1) valid_irq_handlers_ctes_ofD) - apply (clarsimp simp: invs'_def) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (intro conjI impI; clarsimp elim!: weak_derived_sym') + apply (clarsimp simp: cte_wp_at_ctes_of is_derived'_def isCap_simps badge_derived'_def) + apply (erule(1) valid_irq_handlers_ctes_ofD) + apply (clarsimp simp: invs'_def valid_state'_def) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (intro conjI impI; clarsimp elim!: weak_derived_sym') + apply (clarsimp simp: cte_wp_at_ctes_of elim!: weak_derived_sym') apply (clarsimp simp: cte_wp_at_ctes_of elim!: weak_derived_sym') + apply (fastforce dest: ctes_of_valid') done declare withoutPreemption_lift [wp] crunch capSwapForDelete - for irq_states' [wp]: valid_irq_states' + for irq_states'[wp]: valid_irq_states' + crunch finaliseCap - for irq_states' [wp]: valid_irq_states' + for irq_states'[wp]: valid_irq_states' (wp: crunch_wps unless_wp getASID_wp no_irq no_irq_invalidateLocalTLB_ASID no_irq_setHardwareASID no_irq_set_current_pd no_irq_invalidateLocalTLB_VAASID - no_irq_cleanByVA_PoU hoare_vcg_all_lift + no_irq_cleanByVA_PoU simp: crunch_simps armv_contextSwitch_HWASID_def o_def setCurrentPD_to_abs) +lemma finaliseSlot_IRQInactive': + "s \ \valid_irq_states'\ finaliseSlot' a b + \\_. valid_irq_states'\, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" +proof (induct rule: finalise_spec_induct) + case (1 sl exp s) + show ?case + apply (rule hoare_pre_spec_validE) + apply (subst finaliseSlot'_simps_ext) + apply (simp only: split_def) + apply (wp "1.hyps") + apply (unfold Let_def split_def fst_conv snd_conv + case_Zombie_assert_fold haskell_fail_def) + apply (wp getCTE_wp' preemptionPoint_invR| simp add: o_def irq_state_independent_HI)+ + apply (rule hoare_post_imp[where Q'="\_. valid_irq_states'"]) + apply simp + apply wp[1] + apply (rule spec_strengthen_postE) + apply (rule "1.hyps", (assumption|rule refl)+) + apply simp + apply (wp hoare_drop_imps hoare_vcg_all_lift | simp add: locateSlot_conv)+ + done +qed + +lemma finaliseSlot_IRQInactive: + "\valid_irq_states'\ finaliseSlot a b + -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + apply (unfold validE_E_def) + apply (rule hoare_strengthen_postE) + apply (rule use_spec(2) [OF finaliseSlot_IRQInactive', folded finaliseSlot_def]) + apply (rule TrueI) + apply assumption + done + lemma finaliseSlot_irq_states': "\valid_irq_states'\ finaliseSlot a b \\rv. valid_irq_states'\" by (wp finaliseSlot_preservation | clarsimp)+ +lemma cteDelete_IRQInactive: + "\valid_irq_states'\ cteDelete x y + -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + apply (simp add: cteDelete_def split_def) + apply (wp whenE_wp) + apply (rule hoare_strengthen_postE) + apply (rule validE_E_validE) + apply (rule finaliseSlot_IRQInactive) + apply simp + apply simp + apply assumption + done + lemma cteDelete_irq_states': "\valid_irq_states'\ cteDelete x y \\rv. valid_irq_states'\" @@ -8827,6 +8919,47 @@ lemma cteDelete_irq_states': apply assumption done +lemma preemptionPoint_IRQInactive_spec: + "s \ \valid_irq_states'\ preemptionPoint + \\_. valid_irq_states'\, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + apply wp + apply (rule hoare_pre, wp preemptionPoint_invR) + apply clarsimp+ + done + +lemma cteRevoke_IRQInactive': + "s \ \valid_irq_states'\ cteRevoke x + \\_. \\, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" +proof (induct rule: cteRevoke.induct) + case (1 p s') + show ?case + apply (subst cteRevoke.simps) + apply (wp "1.hyps" unlessE_wp whenE_wp preemptionPoint_IRQInactive_spec + cteDelete_IRQInactive cteDelete_irq_states' getCTE_wp')+ + apply clarsimp + done +qed + +lemma cteRevoke_IRQInactive: + "\valid_irq_states'\ cteRevoke x + -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + apply (unfold validE_E_def) + apply (rule use_spec) + apply (rule cteRevoke_IRQInactive') + done + +lemma inv_cnode_IRQInactive: + "\valid_irq_states'\ invokeCNode cnode_inv + -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + apply (simp add: invokeCNode_def) + apply (rule hoare_pre) + apply (wp cteRevoke_IRQInactive finaliseSlot_IRQInactive + cteDelete_IRQInactive + whenE_wp + | wpc + | simp add: split_def)+ + done + end end diff --git a/proof/refine/ARM/CSpace1_R.thy b/proof/refine/ARM/CSpace1_R.thy index ffed3d374e..c6ec4df343 100644 --- a/proof/refine/ARM/CSpace1_R.thy +++ b/proof/refine/ARM/CSpace1_R.thy @@ -11,9 +11,10 @@ theory CSpace1_R imports CSpace_I + "AInvs.ArchDetSchedSchedule_AI" begin -context Arch begin global_naming ARM_A (*FIXME: arch_split*) +context Arch begin global_naming ARM_A (*FIXME: arch-split*) lemmas final_matters_def = final_matters_def[simplified final_matters_arch_def] @@ -24,7 +25,7 @@ lemmas final_matters_simps[simp] end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma isMDBParentOf_CTE1: "isMDBParentOf (CTE cap node) cte = @@ -136,7 +137,7 @@ lemma obj_size_relation: "\ cap_relation c c'; capClass c' = PhysicalClass \ \ obj_size c = capUntypedSize c'" apply (cases c, simp_all add: objBits_simps' zbits_map_def - cte_level_bits_def min_sched_context_bits_def + cte_level_bits_def split: option.splits sum.splits) apply (rename_tac arch_cap) apply (case_tac arch_cap, @@ -145,14 +146,25 @@ lemma obj_size_relation: done lemma same_region_as_relation: - "\ cap_relation c d; cap_relation c' d' \ \ same_region_as c c' = sameRegionAs d d'" + "\ cap_relation c d; cap_relation c' d' \ \ + same_region_as c c' = sameRegionAs d d'" apply (cases c) - apply clarsimp - apply (clarsimp simp: sameRegionAs_def isCap_simps Let_def is_phyiscal_relation) - apply (auto simp: obj_ref_of_relation obj_size_relation cong: conj_cong)[1] - apply ((cases c', auto simp: sameRegionAs_def isCap_simps Let_def)+)[11] - apply (cases c'; (clarsimp simp: same_arch_region_as_relation| - clarsimp simp: sameRegionAs_def isCap_simps Let_def)+) + apply clarsimp + apply (clarsimp simp: sameRegionAs_def isCap_simps Let_def is_phyiscal_relation) + apply (auto simp: obj_ref_of_relation obj_size_relation cong: conj_cong)[1] + apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1] + apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1] + apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1] + apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def bits_of_def)[1] + apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1] + apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1] + apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1] + apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1] + apply (cases c', auto simp: sameRegionAs_def isCap_simps Let_def)[1] + apply simp + apply (cases c') + apply (clarsimp simp: same_arch_region_as_relation| + clarsimp simp: sameRegionAs_def isCap_simps Let_def)+ done lemma can_be_is: @@ -180,20 +192,23 @@ lemma can_be_is: apply (auto simp: Let_def)[1] done -lemma no_ofail_cte_wp_at'_readObject[simp]: - "no_ofail (cte_wp_at' (P::cte \ bool) p) (readObject p::cte kernel_r)" - by (clarsimp simp: cte_wp_at'_def getObject_def readObject_def obind_def omonad_defs split_def - no_ofail_def gets_the_def gets_def get_def bind_def - return_def assert_opt_def fail_def - split: option.splits) - -lemma no_fail_getObject [wp]: - "no_fail (cte_at' p) (getObject p::cte kernel)" - by (clarsimp simp: getCTE_def getObject_def no_ofail_gets_the) - lemma no_fail_getCTE [wp]: "no_fail (cte_at' p) (getCTE p)" - by (wpsimp simp: getCTE_def) + apply (simp add: getCTE_def getObject_def split_def + loadObject_cte alignCheck_def unless_def + alignError_def is_aligned_mask[symmetric] + cong: kernel_object.case_cong) + apply (rule no_fail_pre, (wp | wpc)+) + apply (clarsimp simp: cte_wp_at'_def getObject_def + loadObject_cte split_def in_monad + dest!: in_singleton + split del: if_split) + apply (clarsimp simp: in_monad typeError_def objBits_simps + magnitudeCheck_def + split: kernel_object.split_asm if_split_asm option.split_asm + split del: if_split) + apply simp+ + done lemma tcb_cases_related: "tcb_cap_cases ref = Some (getF, setF, restr) \ @@ -215,7 +230,7 @@ lemma pspace_relation_cte_wp_at: 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 (drule(2) aligned_distinct_obj_atI'[where 'a=cte]) apply simp apply (drule ko_at_imp_cte_wp_at') apply (clarsimp elim!: cte_wp_at_weakenE') @@ -223,7 +238,7 @@ lemma pspace_relation_cte_wp_at: 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 (drule(2) aligned_distinct_obj_atI'[where 'a=tcb]) apply simp apply (drule tcb_cases_related) apply (clarsimp simp: obj_at'_def projectKOs objBits_simps) @@ -350,7 +365,8 @@ proof (induct rule: resolveAddressBits.induct) apply (elim exE conjE) apply (simp only: split: if_split_asm) apply (clarsimp simp: in_monad locateSlot_conv stateAssert_def) - apply (cases cap; simp add: isCap_defs) + apply (cases cap) + apply (simp_all add: isCap_defs)[12] apply (clarsimp simp add: valid_cap'_def objBits_simps' cte_level_bits_def split: option.split_asm) apply (simp only: in_bindE_R K_bind_def) @@ -360,7 +376,8 @@ proof (induct rule: resolveAddressBits.induct) apply (simp only: in_bindE_R K_bind_def) apply (frule (12) 1 [OF refl], (assumption | rule refl)+) apply (clarsimp simp: in_monad locateSlot_conv objBits_simps stateAssert_def) - apply (cases cap; simp add: isCap_defs) + apply (cases cap) + apply (simp_all add: isCap_defs)[12] apply (frule in_inv_by_hoareD [OF getSlotCap_inv]) apply simp apply (frule (1) post_by_hoare [OF getSlotCap_valid_cap]) @@ -369,7 +386,8 @@ proof (induct rule: resolveAddressBits.induct) apply (drule (1) bspec) apply simp apply (clarsimp simp: in_monad locateSlot_conv objBits_simps stateAssert_def) - apply (cases cap; simp add: isCap_defs) + apply (cases cap) + apply (simp_all add: isCap_defs)[12] apply (frule in_inv_by_hoareD [OF getSlotCap_inv]) apply (clarsimp simp: valid_cap'_def cte_level_bits_def objBits_defs) done @@ -410,15 +428,17 @@ proof - } note x = this from assms show ?thesis - apply (cases c; simp add: simps) - defer + apply (cases c) + apply (simp_all add: simps)[5] + defer + apply (simp_all add: simps)[4] apply (clarsimp simp: simps the_arch_cap_def) apply (rename_tac arch_cap) apply (case_tac arch_cap) - apply (simp_all add: arch_update_cap_data_def + apply (simp_all add: simps arch_update_cap_data_def ARM_H.updateCapData_def)[5] \ \CNodeCap\ - apply (simp add: word_bits_def the_cnode_cap_def andCapRights_def + apply (simp add: simps word_bits_def the_cnode_cap_def andCapRights_def rightsFromWord_def data_to_rights_def nth_ucast cteRightsBits_def cteGuardBits_def) apply (insert x) @@ -431,7 +451,6 @@ proof - done qed -end lemma cte_map_shift: assumes bl: "to_bl cref' = zs @ cref" @@ -586,8 +605,8 @@ proof (induct a arbitrary: c' cref' bits rule: resolve_address_bits'.induct) apply (simp add: caps isCap_defs Let_def whenE_bindE_throwError_to_if) apply (subst cnode_cap_case_if) apply (corresKsimp search: getSlotCap_corres IH - wp: get_cap_wp getSlotCap_valid hoare_drop_imps - simp: locateSlot_conv stateAssert_def) + wp: get_cap_wp getSlotCap_valid no_fail_stateAssert + simp: locateSlot_conv) apply (simp add: drop_postfix_eq) apply clarsimp apply (prop_tac "is_aligned ptr (cte_level_bits + cbits) \ cbits \ word_bits - cte_level_bits") @@ -618,15 +637,15 @@ proof (induct a arbitrary: c' cref' bits rule: resolve_address_bits'.induct) apply (erule (2) valid_CNodeCapE) apply (erule (3) cte_map_shift') apply simp - apply (erule (1) cte_map_shift; assumption?) - subgoal by simp - apply (clarsimp simp: cte_level_bits_def) - apply (rule conjI) - apply (clarsimp simp: valid_cap_def cap_table_at_gsCNodes isCap_simps) - apply (rule and_mask_less_size, simp add: word_bits_def word_size cte_level_bits_def) - apply (clarsimp split: if_splits) - done - done + apply (erule (1) cte_map_shift; assumption?) + subgoal by simp + apply (clarsimp simp: cte_level_bits_def) + apply (rule conjI) + apply (clarsimp simp: valid_cap_def cap_table_at_gsCNodes isCap_simps) + apply (rule and_mask_less_size, simp add: word_bits_def word_size cte_level_bits_def) + apply (clarsimp split: if_splits) + done + done } ultimately show ?thesis by fast @@ -707,7 +726,7 @@ lemma lookupSlotForThread_corres: prefer 2 apply (rule hoare_weaken_preE) apply (rule resolveAddressBits_cte_at') - apply (simp add: invs'_def valid_pspace'_def) + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) apply (simp add: returnOk_def split_def) done @@ -744,9 +763,9 @@ lemma lookupCap_corres: lemma setObject_cte_obj_at_tcb': assumes x: "\tcb f. P (tcbCTable_update f tcb) = P tcb" "\tcb f. P (tcbVTable_update f tcb) = P tcb" + "\tcb f. P (tcbReply_update f tcb) = P tcb" + "\tcb f. P (tcbCaller_update f tcb) = P tcb" "\tcb f. P (tcbIPCBufferFrame_update f tcb) = P tcb" - "\tcb f. P (tcbFaultHandler_update f tcb) = P tcb" - "\tcb f. P (tcbTimeoutHandler_update f tcb) = P tcb" shows "\\s. P' (obj_at' (P :: tcb \ bool) p s)\ setObject c (cte::cte) @@ -763,12 +782,17 @@ lemma setObject_cte_obj_at_tcb': Structures_H.kernel_object.split_asm) done -crunch setCTE - for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" +lemma setCTE_typ_at': + "\\s. P (typ_at' T p s)\ setCTE c cte \\_ s. P (typ_at' T p s)\" + by (clarsimp simp add: setCTE_def) (wp setObject_typ_at') + +lemmas setObject_typ_at [wp] = setObject_typ_at' [where P=id, simplified] + +lemma setCTE_typ_at [wp]: + "\typ_at' T p\ setCTE c cte \\_. typ_at' T p\" + by (clarsimp simp add: setCTE_def) wp -global_interpretation setCTE: typ_at_all_props' "setCTE p v" - by typ_at_props' +lemmas setCTE_typ_ats [wp] = typ_at_lifts [OF setCTE_typ_at'] lemma setObject_cte_ksCurDomain[wp]: "\\s. P (ksCurDomain s)\ setObject ptr (cte::cte) \\_ s. P (ksCurDomain s)\" @@ -868,7 +892,13 @@ lemma cap_insert_objs' [wp]: cteInsert cap src dest \\rv. valid_objs'\" including no_pre apply (simp add: cteInsert_def updateCap_def setUntypedCapAsFull_def bind_assoc split del: if_split) - apply (wpsimp wp: setCTE_valid_objs | rule hoare_drop_imp)+ + apply (wp setCTE_valid_objs) + apply simp + apply wp+ + apply (clarsimp simp: updateCap_def) + apply (wp|simp)+ + apply (rule hoare_drop_imp)+ + apply wp+ apply (rule hoare_strengthen_post[OF getCTE_sp]) apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps dest!: ctes_of_valid_cap'') @@ -884,7 +914,11 @@ lemma cteInsert_weak_cte_wp_at: apply (wp setCTE_weak_cte_wp_at updateMDB_weak_cte_wp_at hoare_weak_lift_imp | simp)+ apply (wp getCTE_ctes_wp)+ apply (clarsimp simp: isCap_simps split:if_split_asm| rule conjI)+ - done +done + +lemma setCTE_valid_cap: + "\valid_cap' c\ setCTE ptr cte \\r. valid_cap' c\" + by (rule typ_at_lifts, rule setCTE_typ_at') lemma set_is_modify: "m p = Some cte \ @@ -926,8 +960,6 @@ abbreviation abbreviation "revokable' a b \ global.isCapRevocable b a" -context begin interpretation Arch . (*FIXME: arch_split*) - declare arch_is_cap_revocable_def[simp] ARM_H.isCapRevocable_def[simp] lemmas revokable_def = is_cap_revocable_def is_cap_revocable_def[split_simps cap.split] @@ -1207,7 +1239,10 @@ definition capBadge cap = capBadge cap' \ capASID cap = capASID cap' \ cap_asid_base' cap = cap_asid_base' cap' \ - cap_vptr' cap = cap_vptr' cap'" + cap_vptr' cap = cap_vptr' cap' \ + \ \check all fields of ReplyCap except capReplyCanGrant\ + (isReplyCap cap \ capTCBPtr cap = capTCBPtr cap' \ + capReplyMaster cap = capReplyMaster cap')" lemma capASID_update [simp]: "capASID (RetypeDecls_H.updateCapData P x c) = capASID c" @@ -1262,10 +1297,14 @@ lemma updateCapData_Reply: done lemma weak_derived_updateCapData: - "\ updateCapData P x c \ NullCap; weak_derived' c c'; - capBadge (updateCapData P x c) = capBadge c' \ + "\ (updateCapData P x c) \ NullCap; weak_derived' c c'; + capBadge (updateCapData P x c) = capBadge c' \ \ weak_derived' (updateCapData P x c) c'" - by (clarsimp simp add: weak_derived'_def updateCapData_Master) + apply (clarsimp simp add: weak_derived'_def updateCapData_Master) + apply (clarsimp elim: impE dest!: iffD1[OF updateCapData_Reply]) + apply (clarsimp simp: isCap_simps) + apply (clarsimp simp: Let_def isCap_simps updateCapData_def) + done lemma maskCapRights_Reply[simp]: "isReplyCap (maskCapRights r c) = isReplyCap c" @@ -1659,35 +1698,41 @@ proof - done qed +definition pspace_relations where + "pspace_relations ekh kh kh' \ pspace_relation kh kh' \ ekheap_relation ekh kh'" + lemma set_cap_not_quite_corres_prequel: assumes cr: - "pspace_relation (kheap s) (ksPSpace s')" + "pspace_relations (ekheap s) (kheap s) (ksPSpace s')" "(x,t') \ fst (setCTE p' c' s')" "valid_objs s" "pspace_aligned s" "pspace_distinct s" "cte_at p s" "pspace_aligned' s'" "pspace_distinct' s'" assumes c: "cap_relation c (cteCap c')" assumes p: "p' = cte_map p" shows "\t. ((),t) \ fst (set_cap c p s) \ - pspace_relation (kheap t) (ksPSpace t')" + pspace_relations (ekheap t) (kheap t) (ksPSpace t')" using cr apply (clarsimp simp: setCTE_def setObject_def in_monad split_def) apply (drule(1) updateObject_cte_is_tcb_or_cte[OF _ refl, rotated]) apply (elim disjE exE conjE) - apply (clarsimp simp: lookupAround2_char1) + apply (clarsimp simp: lookupAround2_char1 pspace_relations_def) apply (frule(5) cte_map_pulls_tcb_to_abstract[OF p]) apply (simp add: domI) apply (frule tcb_cases_related2) apply (clarsimp simp: set_cap_def2 split_def bind_def get_object_def simpler_gets_def assert_def fail_def return_def - set_object_def get_def put_def gets_the_def) - apply (erule(2) pspace_relation_update_tcbs) - apply (simp add: c) - apply clarsimp + set_object_def get_def put_def) + apply (rule conjI) + apply (erule(2) pspace_relation_update_tcbs) + apply (simp add: c) + apply (clarsimp simp: ekheap_relation_def pspace_relation_def) + apply (drule bspec, erule domI) + apply (clarsimp simp: etcb_relation_def tcb_cte_cases_def split: if_split_asm) + apply (clarsimp simp: pspace_relations_def) apply (frule(5) cte_map_pulls_cte_to_abstract[OF p]) apply (clarsimp simp: set_cap_def split_def bind_def get_object_def simpler_gets_def assert_def fail_def return_def - set_object_def get_def put_def domI gets_the_def - a_type_def[split_simps kernel_object.split arch_kernel_obj.split]) + set_object_def get_def put_def domI a_type_def[split_simps kernel_object.split arch_kernel_obj.split]) apply (erule(1) valid_objsE) apply (clarsimp simp: valid_obj_def valid_cs_def valid_cs_size_def exI) apply (intro conjI impI) @@ -1705,6 +1750,9 @@ lemma set_cap_not_quite_corres_prequel: apply (simp add: cte_at_cases domI well_formed_cnode_invsI[OF cr(3)]) apply clarsimp apply (simp add: c) + apply (clarsimp simp: ekheap_relation_def pspace_relation_def) + apply (drule bspec, erule domI) + apply (clarsimp simp: etcb_relation_def tcb_cte_cases_def split: if_split_asm) apply (simp add: wf_cs_insert) done @@ -1717,20 +1765,15 @@ lemma setCTE_pspace_only: lemma set_cap_not_quite_corres: assumes cr: - "pspace_relation (kheap s) (ksPSpace s')" + "pspace_relations (ekheap s) (kheap s) (ksPSpace s')" "cur_thread s = ksCurThread s'" "idle_thread s = ksIdleThread s'" - "idle_sc_ptr = ksIdleSC s'" "machine_state s = ksMachineState s'" "work_units_completed s = ksWorkUnitsCompleted s'" "domain_index s = ksDomScheduleIdx s'" "domain_list s = ksDomSchedule s'" "cur_domain s = ksCurDomain s'" "domain_time s = ksDomainTime s'" - "consumed_time s = ksConsumedTime s'" - "cur_time s = ksCurTime s'" - "cur_sc s = ksCurSc s'" - "reprogram_timer s = ksReprogramTimer s'" "(x,t') \ fst (updateCap p' c' s')" "valid_objs s" "pspace_aligned s" "pspace_distinct s" "cte_at p s" "pspace_aligned' s'" "pspace_distinct' s'" @@ -1739,30 +1782,24 @@ lemma set_cap_not_quite_corres: assumes c: "cap_relation c c'" assumes p: "p' = cte_map p" shows "\t. ((),t) \ fst (set_cap c p s) \ - pspace_relation (kheap t) (ksPSpace t') \ + pspace_relations (ekheap t) (kheap t) (ksPSpace t') \ cdt t = cdt s \ cdt_list t = cdt_list s \ + ekheap t = ekheap s \ scheduler_action t = scheduler_action s \ ready_queues t = ready_queues s \ - release_queue t = release_queue s \ is_original_cap t = is_original_cap s \ interrupt_state_relation (interrupt_irq_node t) (interrupt_states t) (ksInterruptState t') \ (arch_state t, ksArchState t') \ arch_state_relation \ cur_thread t = ksCurThread t' \ idle_thread t = ksIdleThread t' \ - idle_sc_ptr = ksIdleSC t' \ machine_state t = ksMachineState t' \ work_units_completed t = ksWorkUnitsCompleted t' \ domain_index t = ksDomScheduleIdx t' \ domain_list t = ksDomSchedule t' \ cur_domain t = ksCurDomain t' \ - domain_time t = ksDomainTime t' \ - consumed_time t = ksConsumedTime t' \ - cur_time t = ksCurTime t' \ - cur_sc t = ksCurSc t' \ - reprogram_timer t = ksReprogramTimer t' \ - sc_replies_of t = sc_replies_of s" + domain_time t = ksDomainTime t'" 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]) @@ -1774,12 +1811,9 @@ lemma set_cap_not_quite_corres: apply (erule exEI) apply clarsimp 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 (clarsimp simp: set_cap_def split_def in_monad set_object_def - get_object_def) - apply (rename_tac obj ps' x' obj' kobj) - apply (case_tac obj; clarsimp simp: fail_def return_def split: if_split_asm) + get_object_def + split: Structures_A.kernel_object.split_asm if_split_asm) done lemma descendants_of_eq': @@ -1803,54 +1837,46 @@ lemma descendants_of_eq': apply simp done -\\ - This turned out to be the least-annoying way to deal with - the subgoal @{term - "ps' |> reply_of' |> replyNext_of = replyNexts_of s'" - } which shows up in the proof of `updateCap_corres`. +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)" + shows "P (ps |> tcb_of' |> tcbSchedPrev)" + using use_valid[OF step setObject_cte_tcbSchedPrevs_of(1)] pre + by auto - `ps'` here comes from `ksPSpace s''`, where `s''` is the new state - after `setObject`. Unforutnately, @{thm setObject_cte_replies_of'} is - specified in terms of `replies_of'`, which uses `ksPSpace` as an - accessor and so can't be used for a goal that refers to the PSpace - directly. -\ -lemma setObject_cte_replies_of'_use_valid_ksPSpace: +lemma setObject_cte_tcbSchedNexts_of_use_valid_ksPSpace: assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" - and pre: "P (replies_of' s)" - shows "P (ps |> reply_of')" - using use_valid[OF step setObject_cte_replies_of'] pre + assumes pre: "P (tcbSchedNexts_of s)" + shows "P (ps |> tcb_of' |> tcbSchedNext)" + using use_valid[OF step setObject_cte_tcbSchedNexts_of(1)] pre by auto -lemma setObject_cte_scs_of'_use_valid_ksPSpace: +lemma setObject_cte_inQ_of_use_valid_ksPSpace: assumes step: "(x, s\ksPSpace := ps\) \ fst (setObject p (cte :: cte) s)" - and pre: "P (scs_of' s)" - shows "P (ps |> sc_of')" - using use_valid[OF step setObject_scs_of'(1)] pre + assumes pre: "P (inQ domain priority |< tcbs_of' s)" + shows "P (inQ domain priority |< (ps |> tcb_of'))" + using use_valid[OF step setObject_cte_inQ(1)] pre by auto lemma updateCap_stuff: assumes "(x, s'') \ fst (updateCap p cap s')" - shows "ctes_of s'' = modify_map (ctes_of s') p (cteCap_update (K cap)) \ + shows "(ctes_of s'' = modify_map (ctes_of s') p (cteCap_update (K cap))) \ gsUserPages s'' = gsUserPages s' \ gsCNodes s'' = gsCNodes s' \ ksMachineState s'' = ksMachineState s' \ ksWorkUnitsCompleted s'' = ksWorkUnitsCompleted s' \ ksCurThread s'' = ksCurThread s' \ ksIdleThread s'' = ksIdleThread s' \ - ksIdleSC s'' = ksIdleSC s' \ ksReadyQueues s'' = ksReadyQueues s' \ - ksReleaseQueue s'' = ksReleaseQueue s' \ ksSchedulerAction s'' = ksSchedulerAction s' \ (ksArchState s'' = ksArchState s') \ (pspace_aligned' s' \ pspace_aligned' s'') \ (pspace_distinct' s' \ pspace_distinct' s'') \ - replyPrevs_of s'' = replyPrevs_of s' \ - scReplies_of s'' = scReplies_of s' \ - ksConsumedTime s'' = ksConsumedTime s' \ - ksCurTime s'' = ksCurTime s' \ - ksCurSc s'' = ksCurSc s' \ - ksReprogramTimer s'' = ksReprogramTimer s'" using assms + tcbSchedPrevs_of s'' = tcbSchedPrevs_of s' \ + tcbSchedNexts_of s'' = tcbSchedNexts_of s' \ + (\domain priority. + (inQ domain priority |< tcbs_of' s'') = (inQ domain priority |< tcbs_of' s'))" + using assms apply (clarsimp simp: updateCap_def in_monad) apply (drule use_valid [where P="\s. s2 = s" for s2, OF _ getCTE_sp refl]) apply (rule conjI) @@ -1859,16 +1885,11 @@ 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 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 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(1) use_valid [OF _ setObject_aligned]) + apply (erule(1) use_valid [OF _ setObject_distinct]) + 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) done (* FIXME: move *) @@ -2185,33 +2206,24 @@ lemma ctes_of_valid: apply (fastforce) done -lemma readObject_cte_at'[simplified]: - "bound (readObject p s :: cte option) \ cte_at' p s" - unfolding cte_wp_at'_def getObject_def - by (clarsimp simp: omonad_defs split_def gets_the_def exec_gets return_def) - -lemma readObject_cte_ko_at': - "readObject p s = Some (cte :: cte) \ cte_wp_at' ((=) cte) p s" - unfolding cte_wp_at'_def getObject_def - by (clarsimp simp: omonad_defs split_def gets_the_def exec_gets return_def) - -lemma no_fail_setObject_cte [wp]: - "no_fail (cte_at' t) (setObject t (t'::cte))" - unfolding setObject_def - apply (clarsimp simp: updateObject_cte gets_the_def alignCheck_def is_aligned_mask[symmetric] - split del: if_split cong: kernel_object.case_cong) - apply (wp|wpc)+ - apply (clarsimp simp: cte_wp_at'_def getObject_def split_def - in_monad loadObject_cte readObject_def omonad_defs - dest!: in_singleton split: option.splits split del: if_split) - by (fastforce simp: read_typeError_def objBits_simps - read_magnitudeCheck_def ohaskell_assert_def - split: kernel_object.split_asm if_split_asm - split del: if_split) - lemma no_fail_setCTE [wp]: "no_fail (cte_at' p) (setCTE p c)" - unfolding setCTE_def by wp + apply (clarsimp simp: setCTE_def setObject_def split_def unless_def + updateObject_cte alignCheck_def alignError_def + typeError_def is_aligned_mask[symmetric] + cong: kernel_object.case_cong) + apply (wp|wpc)+ + apply (clarsimp simp: cte_wp_at'_def getObject_def split_def + in_monad loadObject_cte + dest!: in_singleton + split del: if_split) + apply (clarsimp simp: typeError_def alignCheck_def alignError_def + in_monad is_aligned_mask[symmetric] objBits_simps + magnitudeCheck_def + split: kernel_object.split_asm if_split_asm option.splits + split del: if_split) + apply simp_all + done lemma no_fail_updateCap [wp]: "no_fail (cte_at' p) (updateCap p cap')" @@ -2264,20 +2276,23 @@ lemma is_final_untyped_ptrs: done lemma capClass_ztc_relation: - "\ is_zombie c \ is_cnode_cap c \ is_thread_cap c; cap_relation c c' \ - \ capClass c' = PhysicalClass" + "\ is_zombie c \ is_cnode_cap c \ is_thread_cap c; + cap_relation c c' \ \ capClass c' = PhysicalClass" by (auto simp: is_cap_simps) +lemma pspace_relationsD: + "\pspace_relation kh kh'; ekheap_relation ekh kh'\ \ pspace_relations ekh kh kh'" + by (simp add: pspace_relations_def) + lemma updateCap_corres: "\cap_relation cap cap'; is_zombie cap \ is_cnode_cap cap \ is_thread_cap cap \ - \ corres dc (\s. invs s - \ cte_wp_at - (\c. (is_zombie c \ is_cnode_cap c \ is_thread_cap c) - \ is_final_cap' c s - \ obj_ref_of c = obj_ref_of cap - \ obj_size c = obj_size cap) - slot s) + \ corres dc (\s. invs s \ + cte_wp_at (\c. (is_zombie c \ is_cnode_cap c \ + is_thread_cap c) \ + is_final_cap' c s \ + obj_ref_of c = obj_ref_of cap \ + obj_size c = obj_size cap) slot s) invs' (set_cap cap slot) (updateCap (cte_map slot) cap')" apply (rule corres_stronger_no_failI) @@ -2290,30 +2305,39 @@ lemma updateCap_corres: apply fastforce apply (clarsimp simp: cte_wp_at_ctes_of) apply (clarsimp simp add: state_relation_def) + apply (drule(1) pspace_relationsD) apply (frule (3) set_cap_not_quite_corres; fastforce?) apply (erule cte_wp_at_weakenE, rule TrueI) apply clarsimp apply (rule bexI) prefer 2 apply simp - apply (clarsimp simp: in_set_cap_cte_at_swp) + apply (clarsimp simp: in_set_cap_cte_at_swp pspace_relations_def) apply (drule updateCap_stuff) - apply (rename_tac abs conc conc' abs') - - (* FIXME RT: replace this with whatever comes out of VER-1248. *) + apply simp apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) - - apply (extract_conjunct \match conclusion in "sched_act_relation _ _" \ -\) - apply clarsimp - - apply (extract_conjunct \match conclusion in "cdt_relation _ _ _" \ -\) - apply (case_tac "ctes_of conc (cte_map slot)") - apply (simp add: modify_map_None) - apply (simp add: modify_map_apply) - apply (simp add: cdt_relation_def del: split_paired_All) + apply (rule conjI) + prefer 2 + apply (rule conjI) + apply (unfold cdt_list_relation_def)[1] + apply (intro allI impI) + apply (erule_tac x=c in allE) + apply (auto elim!: modify_map_casesE)[1] + apply (unfold revokable_relation_def)[1] + apply (drule set_cap_caps_of_state_monad) + apply (simp add: cte_wp_at_caps_of_state del: split_paired_All) apply (intro allI impI) - apply (rule use_update_ztc_one [OF descendants_of_update_ztc]) + apply (erule_tac x=c in allE) + apply (erule impE[where P="\y. v = Some y" for v]) + apply (clarsimp simp: null_filter_def is_zombie_def split: if_split_asm) + apply (auto elim!: modify_map_casesE del: disjE)[1] + apply (case_tac "ctes_of b (cte_map slot)") + apply (simp add: modify_map_None) + apply (simp add: modify_map_apply) + apply (simp add: cdt_relation_def del: split_paired_All) + apply (intro allI impI) + apply (rule use_update_ztc_one [OF descendants_of_update_ztc]) apply simp apply assumption apply (auto simp: is_cap_simps isCap_simps)[1] @@ -2331,45 +2355,21 @@ lemma updateCap_corres: apply (drule cte_wp_at_norm, clarsimp) apply (drule(1) pspace_relation_ctes_ofI, clarsimp+) apply (simp add: is_cap_simps, elim disjE exE, simp_all add: isCap_simps)[1] - apply clarsimp - - apply (extract_conjunct \match conclusion in "ready_queues_relation _ _" \ -\) - apply (case_tac "ctes_of conc (cte_map slot)") - apply (simp add: modify_map_None) - apply (simp add: modify_map_apply) - - apply (extract_conjunct \match conclusion in "cdt_list_relation _ _ _" \ -\) - apply (unfold cdt_list_relation_def)[1] - apply (intro allI impI) - apply (erule_tac x=c in allE) - apply (auto elim!: modify_map_casesE)[1] - - apply (extract_conjunct \match conclusion in "revokable_relation _ _ _" \ -\) - apply (unfold revokable_relation_def)[1] - apply (drule set_cap_caps_of_state_monad) - apply (simp add: cte_wp_at_caps_of_state del: split_paired_All) - apply (intro allI impI) - apply (erule_tac x=c in allE) - apply (erule impE[where P="\y. v = Some y" for v]) - apply (clarsimp simp: null_filter_def is_zombie_def split: if_split_asm) - apply (auto elim!: modify_map_casesE del: disjE)[1] - - apply (extract_conjunct \match conclusion in "release_queue_relation _ _" \ -\) - apply (clarsimp simp: release_queue_relation_def - elim!: use_valid[OF _ set_cap.valid_sched_pred]) - - apply (clarsimp simp: sc_replies_relation_def) + apply clarsimp done +lemma exst_set_cap: + "(x,s') \ fst (set_cap p c s) \ exst s' = exst s" + by (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def + split: if_split_asm Structures_A.kernel_object.splits) + lemma updateMDB_eqs: assumes "(x, s'') \ fst (updateMDB p f s')" shows "ksMachineState s'' = ksMachineState s' \ ksWorkUnitsCompleted s'' = ksWorkUnitsCompleted s' \ ksCurThread s'' = ksCurThread s' \ ksIdleThread s'' = ksIdleThread s' \ - ksIdleSC s'' = ksIdleSC s' \ ksReadyQueues s'' = ksReadyQueues s' \ - ksReleaseQueue s'' = ksReleaseQueue s' \ ksInterruptState s'' = ksInterruptState s' \ ksArchState s'' = ksArchState s' \ ksSchedulerAction s'' = ksSchedulerAction s' \ @@ -2434,6 +2434,24 @@ lemma updateMDB_pspace_relation: apply fastforce done +lemma updateMDB_ekheap_relation: + assumes "(x, s'') \ fst (updateMDB p f s')" + assumes "ekheap_relation (ekheap s) (ksPSpace s')" + shows "ekheap_relation (ekheap s) (ksPSpace s'')" using assms + apply (clarsimp simp: updateMDB_def Let_def setCTE_def setObject_def in_monad ekheap_relation_def etcb_relation_def split_def split: if_split_asm) + apply (drule(1) updateObject_cte_is_tcb_or_cte[OF _ refl, rotated]) + apply (drule_tac P="(=) s'" in use_valid [OF _ getCTE_sp], rule refl) + apply (drule bspec, erule domI) + apply (clarsimp simp: tcb_cte_cases_def lookupAround2_char1 split: if_split_asm) + done + +lemma updateMDB_pspace_relations: + assumes "(x, s'') \ fst (updateMDB p f s')" + assumes "pspace_relations (ekheap s) (kheap s) (ksPSpace s')" + assumes "pspace_aligned' s'" "pspace_distinct' s'" + shows "pspace_relations (ekheap s) (kheap s) (ksPSpace s'')" using assms + by (simp add: pspace_relations_def updateMDB_pspace_relation updateMDB_ekheap_relation) + lemma updateMDB_ctes_of: assumes "(x, s') \ fst (updateMDB p f s)" assumes "no_0 (ctes_of s)" @@ -2448,52 +2466,70 @@ lemma updateMDB_ctes_of: done crunch updateMDB - for replies_of'[wp]: "\s. P (replies_of' s)" - and scs_of'[wp]: "\s. P (scs_of' 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 aligned[wp]: pspace_aligned' - and pdistinct[wp]: pspace_distinct' + for aligned[wp]: "pspace_aligned'" +crunch updateMDB + for pdistinct[wp]: "pspace_distinct'" +crunch updateMDB + for tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" +crunch updateMDB + for tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" +crunch updateMDB + for inQ_opt_pred[wp]: "\s. P (inQ d p |< tcbs_of' s)" +crunch updateMDB + for inQ_opt_pred'[wp]: "\s. P (\d p. inQ d p |< tcbs_of' s)" +crunch updateMDB + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" (wp: crunch_wps simp: crunch_simps setObject_def updateObject_cte) +lemma setCTE_rdyq_projs[wp]: + "setCTE p f \\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + (\d p. inQ d p |< tcbs_of' s)\" + apply (rule hoare_lift_Pf2[where f=ksReadyQueues]) + apply (rule hoare_lift_Pf2[where f=tcbSchedNexts_of]) + apply (rule hoare_lift_Pf2[where f=tcbSchedPrevs_of]) + apply wpsimp+ + done + +crunch updateMDB + for rdyq_projs[wp]:"\s. P (ksReadyQueues s) (tcbSchedNexts_of s) (tcbSchedPrevs_of s) + (\d p. inQ d p |< tcbs_of' s)" + lemma updateMDB_the_lot: assumes "(x, s'') \ fst (updateMDB p f s')" - assumes "pspace_relation (kheap s) (ksPSpace s')" + assumes "pspace_relations (ekheap s) (kheap s) (ksPSpace s')" assumes "pspace_aligned' s'" "pspace_distinct' s'" "no_0 (ctes_of s')" shows "ctes_of s'' = modify_map (ctes_of s') p (cteMDBNode_update f) \ ksMachineState s'' = ksMachineState s' \ ksWorkUnitsCompleted s'' = ksWorkUnitsCompleted s' \ ksCurThread s'' = ksCurThread s' \ ksIdleThread s'' = ksIdleThread s' \ - ksIdleSC s'' = ksIdleSC s' \ ksReadyQueues s'' = ksReadyQueues s' \ - ksReleaseQueue s'' = ksReleaseQueue s' \ ksSchedulerAction s'' = ksSchedulerAction s' \ ksInterruptState s'' = ksInterruptState s' \ ksArchState s'' = ksArchState s' \ gsUserPages s'' = gsUserPages s' \ gsCNodes s'' = gsCNodes s' \ - pspace_relation (kheap s) (ksPSpace s'') \ + pspace_relations (ekheap s) (kheap s) (ksPSpace s'') \ pspace_aligned' s'' \ pspace_distinct' s'' \ no_0 (ctes_of s'') \ ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ ksDomainTime s'' = ksDomainTime s' \ - ksConsumedTime s'' = ksConsumedTime s' \ - ksCurTime s'' = ksCurTime s' \ - ksCurSc s'' = ksCurSc s' \ - ksReprogramTimer s'' = ksReprogramTimer s' \ - replyPrevs_of s'' = replyPrevs_of s' \ - scReplies_of s'' = scReplies_of s'" - using assms - apply (simp add: updateMDB_eqs updateMDB_pspace_relation split del: if_split) + tcbSchedNexts_of s'' = tcbSchedNexts_of s' \ + tcbSchedPrevs_of s'' = tcbSchedPrevs_of s' \ + (\domain priority. + (inQ domain priority |< tcbs_of' s'') = (inQ domain priority |< tcbs_of' s'))" +using assms + apply (simp add: updateMDB_eqs updateMDB_pspace_relations split del: if_split) apply (frule (1) updateMDB_ctes_of) apply clarsimp - apply (erule use_valid, wp) - apply simp + apply (rule conjI) + apply (erule use_valid) + apply wp + apply simp + apply (erule use_valid, wpsimp wp: hoare_vcg_all_lift) + apply (simp add: comp_def) done lemma revokable_eq: @@ -2630,7 +2666,20 @@ lemma subtree_next_0: definition "isArchCap P cap \ case cap of ArchObjectCap acap \ P acap | _ \ False" -lemmas isArchCap_simps[simp] = isArchCap_def[split_simps capability.split] +lemma isArchCap_simps[simp]: + "isArchCap P (capability.ThreadCap xc) = False" + "isArchCap P capability.NullCap = False" + "isArchCap P capability.DomainCap = False" + "isArchCap P (capability.NotificationCap xca xba xaa xd) = False" + "isArchCap P (capability.EndpointCap xda xcb xbb xab xe xi) = False" + "isArchCap P (capability.IRQHandlerCap xf) = False" + "isArchCap P (capability.Zombie xbc xac xg) = False" + "isArchCap P (capability.ArchObjectCap xh) = P xh" + "isArchCap P (capability.ReplyCap xad xi xia) = False" + "isArchCap P (capability.UntypedCap d xae xj f) = False" + "isArchCap P (capability.CNodeCap xfa xea xdb xcc) = False" + "isArchCap P capability.IRQControlCap = False" + by (simp add: isArchCap_def)+ definition vsCapRef :: "capability \ vs_ref list option" @@ -2678,6 +2727,8 @@ definition badge_derived' cap' cap \ (isUntypedCap cap \ descendants_of' p m = {}) \ (isReplyCap cap = isReplyCap cap') \ + (isReplyCap cap \ capReplyMaster cap) \ + (isReplyCap cap' \ \ capReplyMaster cap') \ (vsCapRef cap = vsCapRef cap' \ isArchCap isPageCap cap') \ ((isArchCap isPageTableCap cap \ isArchCap isPageDirectoryCap cap) \ capASID cap = capASID cap' \ capASID cap \ None)" @@ -2703,12 +2754,19 @@ lemma capBadge_ordering_relation: "\ cap_relation c c'; cap_relation d d' \ \ ((capBadge c', capBadge d') \ capBadge_ordering f) = ((cap_badge c, cap_badge d) \ capBadge_ordering f)" - by (cases c, auto simp add: cap_badge_def capBadge_ordering_def split: cap.splits) + apply (cases c) + apply (auto simp add: cap_badge_def capBadge_ordering_def split: cap.splits) + done lemma is_reply_cap_relation: - "cap_relation c c' \ is_reply_cap c = (isReplyCap c')" + "cap_relation c c' \ is_reply_cap c = (isReplyCap c' \ \ capReplyMaster c')" by (cases c, auto simp: is_cap_simps isCap_simps) +lemma is_reply_master_relation: + "cap_relation c c' \ + is_master_reply_cap c = (isReplyCap c' \ capReplyMaster c')" + by (cases c, auto simp add: is_cap_simps isCap_simps) + lemma cap_asid_cap_relation: "cap_relation c c' \ capASID c' = cap_asid c" by (auto simp: capASID_def cap_asid_def split: cap.splits arch_cap.splits) @@ -2727,28 +2785,30 @@ lemma is_derived_eq: apply (rule conjI) apply (clarsimp simp: is_cap_simps isCap_simps) apply (cases c, auto simp: isCap_simps cap_master_cap_def capMasterCap_def)[1] - apply (simp add:vsCapRef_def) - apply (simp add:vs_cap_ref_def) - apply (cases "isIRQControlCap d'") + apply (simp add:vsCapRef_def) + apply (simp add:vs_cap_ref_def) + apply (case_tac "isIRQControlCap d'") apply (frule(1) master_cap_relation) apply (clarsimp simp: isCap_simps cap_master_cap_def - is_zombie_def is_reply_cap_def + is_zombie_def is_reply_cap_def is_master_reply_cap_def split: cap_relation_split_asm arch_cap.split_asm)[1] apply (frule(1) master_cap_relation) apply (frule(1) cap_badge_relation) apply (frule cap_asid_cap_relation) apply (frule(1) capBadge_ordering_relation) - apply (case_tac d; simp add: isCap_simps is_cap_simps cap_master_cap_def - vs_cap_ref_def vsCapRef_def capMasterCap_def - split: cap_relation_split_asm arch_cap.split_asm) - apply ((auto split:arch_cap.splits arch_capability.splits)[3]) - apply (clarsimp split:option.splits arch_cap.splits arch_capability.splits) - apply (intro conjI|clarsimp)+ - apply fastforce - apply clarsimp+ + apply (case_tac d) + apply (simp_all add: isCap_simps is_cap_simps cap_master_cap_def + vs_cap_ref_def vsCapRef_def capMasterCap_def + split: cap_relation_split_asm arch_cap.split_asm) + apply fastforce + apply ((auto split:arch_cap.splits arch_capability.splits)[3]) apply (clarsimp split:option.splits arch_cap.splits arch_capability.splits) apply (intro conjI|clarsimp)+ - apply fastforce + apply fastforce + apply clarsimp+ + apply (clarsimp split:option.splits arch_cap.splits arch_capability.splits) + apply (intro conjI|clarsimp)+ + apply fastforce done end @@ -2756,7 +2816,7 @@ locale masterCap = fixes cap cap' assumes master: "capMasterCap cap = capMasterCap cap'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma isZombie [simp]: "isZombie cap' = isZombie cap" using master @@ -3339,7 +3399,7 @@ locale mdb_insert_sib = mdb_insert_der + (mdbRevocable_update (\a. revokable' src_cap c') (mdbPrev_update (\a. src) src_node))))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) (* If dest is inserted as sibling, src can not have had children. If it had had children, then dest_node which is just a derived copy @@ -3486,7 +3546,7 @@ lemma descendants: by (rule set_eqI) (simp add: descendants_of'_def parent_n_eq) end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma mdb_None: assumes F: "\p'. cte_map p \ descendants_of' p' m' \ False" assumes R: "cdt_relation (swp cte_at s) (cdt s) m'" @@ -3681,6 +3741,7 @@ lemma setCTE_UntypedCap_corres: apply (clarsimp simp: cte_wp_at_ctes_of) apply clarsimp apply (clarsimp simp add: state_relation_def split_def) + apply (drule (1) pspace_relationsD) apply (frule_tac c = "cap.UntypedCap dev r bits idx" in set_cap_not_quite_corres_prequel) apply assumption+ @@ -3691,26 +3752,41 @@ lemma setCTE_UntypedCap_corres: apply (rule bexI) prefer 2 apply assumption + apply (clarsimp simp: pspace_relations_def) + apply (subst conj_assoc[symmetric]) apply clarsimp - apply (rename_tac abs conc conc' abs') - - (* FIXME RT: replace this with whatever comes out of VER-1248. *) - apply (extract_conjunct \match conclusion in "ghost_relation _ _ _" \ -\) + apply (rule conjI) + apply (frule setCTE_pspace_only) + apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def + split: if_split_asm Structures_A.kernel_object.splits) + apply (extract_conjunct \match conclusion in "ready_queues_relation _ _" \ -\) + apply (clarsimp simp: ready_queues_relation_def Let_def) + apply (rule use_valid[OF _ setCTE_tcbSchedPrevs_of], assumption) + apply (rule use_valid[OF _ setCTE_tcbSchedNexts_of], assumption) + apply (rule use_valid[OF _ setCTE_ksReadyQueues], assumption) + apply (rule use_valid[OF _ setCTE_inQ_opt_pred], assumption) + apply (rule use_valid[OF _ set_cap_exst], assumption) + apply clarsimp + apply (rule conjI) apply (frule setCTE_pspace_only) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) - - apply (extract_conjunct \match conclusion in "cdt_list_relation _ _ _" \ -\) - apply (frule mdb_set_cap, frule exst_set_cap) - apply (erule use_valid [OF _ setCTE_ctes_of_wp]) - apply (clarsimp simp: cdt_list_relation_def cte_wp_at_ctes_of split: if_split_asm) - - apply (extract_conjunct \match conclusion in "revokable_relation _ _ _" \ -\) + apply (rule conjI) + prefer 2 + apply (rule conjI) + apply (frule mdb_set_cap, frule exst_set_cap) + apply (erule use_valid [OF _ setCTE_ctes_of_wp]) + apply (clarsimp simp: cdt_list_relation_def cte_wp_at_ctes_of split: if_split_asm) + apply (rule conjI) + prefer 2 + apply (frule setCTE_pspace_only) + apply clarsimp + apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def + split: if_split_asm Structures_A.kernel_object.splits) apply (frule set_cap_caps_of_state_monad) apply (drule is_original_cap_set_cap) apply clarsimp apply (erule use_valid [OF _ setCTE_ctes_of_wp]) apply (clarsimp simp: revokable_relation_def simp del: fun_upd_apply) - apply (rename_tac oref cidx cap' cap'' node) apply (clarsimp split: if_split_asm) apply (frule cte_map_inj_eq) prefer 2 @@ -3723,41 +3799,26 @@ lemma setCTE_UntypedCap_corres: apply fastforce apply clarsimp apply (simp add: null_filter_def split: if_split_asm) - apply (erule_tac x=oref in allE, erule_tac x=cidx in allE) + apply (erule_tac x=aa in allE, erule_tac x=bb in allE) apply (case_tac cte) apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps isCap_simps cte_wp_at_ctes_of) apply (simp add: null_filter_def cte_wp_at_caps_of_state split: if_split_asm) - apply (erule_tac x=oref in allE, erule_tac x=cidx in allE) + apply (erule_tac x=aa in allE, erule_tac x=bb in allE) apply (clarsimp) - - apply (extract_conjunct \match conclusion in "cdt_relation _ _ _" \ -\) - apply (clarsimp simp: cdt_relation_def) - apply (rename_tac oref cidx) - apply (frule set_cap_caps_of_state_monad) - apply (frule mdb_set_cap) - apply clarsimp - apply (erule use_valid [OF _ setCTE_ctes_of_wp]) - apply (frule cte_wp_at_norm) - apply (clarsimp simp:cte_wp_at_ctes_of simp del: fun_upd_apply) - apply (drule_tac slot = "cte_map (oref, cidx)" in updateUntypedCap_descendants_of) - apply (clarsimp simp:isCap_simps) - apply (drule_tac x = oref in spec) - apply (drule_tac x = cidx in spec) - apply (erule impE) - apply (clarsimp simp: cte_wp_at_caps_of_state split:if_splits) - apply auto[1] - - apply (extract_conjunct \match conclusion in "sc_replies_relation _ _" \ -\) - apply (clarsimp simp: sc_replies_relation_def - elim!: use_valid[OF _ set_cap.valid_sched_pred]) - apply (rule use_valid[OF _ setCTE_replies_of'], assumption) - apply (rule use_valid[OF _ setCTE_scs_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; - simp add: fail_def return_def split: if_split_asm) + apply (clarsimp simp: cdt_relation_def) + apply (frule set_cap_caps_of_state_monad) + apply (frule mdb_set_cap) + apply clarsimp + apply (erule use_valid [OF _ setCTE_ctes_of_wp]) + apply (frule cte_wp_at_norm) + apply (clarsimp simp:cte_wp_at_ctes_of simp del: fun_upd_apply) + apply (drule_tac slot = "cte_map (aa,bb)" in updateUntypedCap_descendants_of) + apply (clarsimp simp:isCap_simps) + apply (drule_tac x = aa in spec) + apply (drule_tac x = bb in spec) + apply (erule impE) + apply (clarsimp simp: cte_wp_at_caps_of_state split:if_splits) + apply auto done lemma getCTE_get: @@ -3797,7 +3858,20 @@ lemma setUntypedCapAsFull_corres: done (* FIXME: SELFOUR-421 move *) -lemmas isUntypedCap_simps[simp] = isUntypedCap_def[split_simps capability.split] +lemma isUntypedCap_simps[simp]: + "isUntypedCap (capability.UntypedCap uu uv uw ux) = True" + "isUntypedCap (capability.NullCap) = False" + "isUntypedCap (capability.EndpointCap v va vb vc vd ve) = False" + "isUntypedCap (capability.NotificationCap v va vb vc) = False" + "isUntypedCap (capability.ReplyCap v1 v2 v3) = False" + "isUntypedCap (capability.CNodeCap x1 x2 x3 x4) = False" + "isUntypedCap (capability.ThreadCap v) = False" + "isUntypedCap (capability.DomainCap) = False" + "isUntypedCap (capability.IRQControlCap) = False" + "isUntypedCap (capability.IRQHandlerCap y1) = False" + "isUntypedCap (capability.Zombie v va1 vb1) = False" + "isUntypedCap (capability.ArchObjectCap z) = False" + by (simp_all add: isUntypedCap_def split: capability.splits) lemma cap_relation_masked_as_full: "\cap_relation src_cap src_cap';cap_relation c c'\ \ @@ -4307,7 +4381,6 @@ lemma irq_control_preserve: apply (simp add:dom misc)+ done end - locale mdb_inv_preserve = fixes m m' assumes dom: "\x. (x\ dom m) = (x\ dom m')" @@ -4315,6 +4388,7 @@ locale mdb_inv_preserve = isUntypedCap (cteCap cte) = isUntypedCap (cteCap cte') \ isNullCap (cteCap cte) = isNullCap (cteCap cte') \ isReplyCap (cteCap cte) = isReplyCap (cteCap cte') + \ (isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte) = capReplyMaster (cteCap cte')) \ isNotificationCap (cteCap cte) = isNotificationCap (cteCap cte') \ (isNotificationCap (cteCap cte) \ (capNtfnBadge (cteCap cte) = capNtfnBadge (cteCap cte'))) \ (isEndpointCap (cteCap cte) = isEndpointCap (cteCap cte')) @@ -4333,7 +4407,7 @@ locale mdb_inv_preserve = \ (\x. sameRegionAs x (cteCap cte)) = (\x. sameRegionAs x (cteCap cte'))" assumes mdb_next:"\p. mdb_next m p = mdb_next m' p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma preserve_stuff: "valid_dlist m = valid_dlist m' \ ut_revocable' m = ut_revocable' m' @@ -4421,44 +4495,59 @@ lemma descendants_of: done lemma by_products: - "no_0 m = no_0 m' \ mdb_chain_0 m = mdb_chain_0 m'\ valid_nullcaps m = valid_nullcaps m'" - apply (intro conjI) - apply (clarsimp simp:no_0_def) - apply (rule ccontr) - apply (simp add:dom_in) - apply (subst (asm) dom[symmetric]) - apply fastforce + "reply_masters_rvk_fb m = reply_masters_rvk_fb m' + \ no_0 m = no_0 m' \ mdb_chain_0 m = mdb_chain_0 m' + \ valid_nullcaps m = valid_nullcaps m'" +apply (intro conjI) + apply (simp add:ran_dom reply_masters_rvk_fb_def mdb_inv_preserve_def dom misc sameRegion mdb_next) + apply (rule iffI) + apply clarsimp + apply (drule_tac x = y in bspec) + apply (rule iffD2[OF dom]) + apply clarsimp + apply (frule iffD2[OF dom,OF domI],rotate_tac) + apply (clarsimp simp:misc)+ + apply (drule_tac x = y in bspec) + apply (rule iffD1[OF dom]) + apply clarsimp + apply (frule iffD1[OF dom,OF domI],rotate_tac) + apply (clarsimp simp:misc)+ + apply (clarsimp simp:no_0_def) + apply (rule ccontr) + apply (simp add:dom_in) + apply (subst (asm) dom[symmetric]) + apply fastforce apply (rule iffI) - apply (clarsimp simp:mdb_chain_0_def) - apply (drule_tac x =x in bspec) - apply (rule iffD2[OF dom],clarsimp) - apply (erule_tac iffD1[OF connect_eqv_singleE,rotated]) - apply (cut_tac p = p in mdb_next) - apply (clarsimp simp: mdb_next_rel_def) apply (clarsimp simp:mdb_chain_0_def) - apply (drule_tac x =x in bspec) - apply (rule iffD1[OF dom],clarsimp) - apply (erule_tac iffD1[OF connect_eqv_singleE,rotated]) - apply (cut_tac p = p in mdb_next) - apply (clarsimp simp: mdb_next_rel_def) - apply (simp add:valid_nullcaps_def) - apply (rule forall_eq,clarsimp)+ - apply (rule iffI) - apply clarsimp - apply (frule iffD2[OF dom,OF domI]) - apply (clarsimp) - apply (case_tac y) - apply (drule misc) - apply assumption - apply (clarsimp simp:isCap_simps) - apply clarsimp - apply (frule iffD1[OF dom,OF domI]) - apply (clarsimp) - apply (case_tac y) - apply (drule misc) - apply assumption - apply (clarsimp simp:isCap_simps) - done + apply (drule_tac x =x in bspec) + apply (rule iffD2[OF dom],clarsimp) + apply (erule_tac iffD1[OF connect_eqv_singleE,rotated]) + apply (cut_tac p = p in mdb_next) + apply (clarsimp simp: mdb_next_rel_def) + apply (clarsimp simp:mdb_chain_0_def) + apply (drule_tac x =x in bspec) + apply (rule iffD1[OF dom],clarsimp) + apply (erule_tac iffD1[OF connect_eqv_singleE,rotated]) + apply (cut_tac p = p in mdb_next) + apply (clarsimp simp: mdb_next_rel_def) + apply (simp add:valid_nullcaps_def) + apply (rule forall_eq,clarsimp)+ + apply (rule iffI) + apply clarsimp + apply (frule iffD2[OF dom,OF domI]) + apply (clarsimp) + apply (case_tac y) + apply (drule misc) + apply assumption + apply (clarsimp simp:isCap_simps) + apply clarsimp + apply (frule iffD1[OF dom,OF domI]) + apply (clarsimp) + apply (case_tac y) + apply (drule misc) + apply assumption + apply (clarsimp simp:isCap_simps) +done end @@ -4503,7 +4592,7 @@ lemma updateCap_cte_wp_at': updateCap ptr cap \\rv s. Q (cte_wp_at' P' p s)\" apply (simp add:updateCap_def cte_wp_at_ctes_of) apply (wp setCTE_ctes_of_wp getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) + apply (clarsimp simp: cte_wp_at_ctes_of split del: if_split) apply (case_tac cte, auto split: if_split) done @@ -4603,6 +4692,22 @@ lemma updateCapFreeIndex_class_links: apply (clarsimp simp:cte_wp_at_ctes_of)+ done +lemma updateCapFreeIndex_reply_masters_rvk_fb: + assumes preserve:"\m m'. mdb_inv_preserve m m' \ mdb_inv_preserve (Q m) (Q m')" + shows + "\\s. P (reply_masters_rvk_fb (Q (ctes_of s))) \ cte_wp_at' (\c. c = srcCTE \ isUntypedCap (cteCap c)) src s\ + updateCap src (capFreeIndex_update (\_. index) (cteCap srcCTE)) + \\r s. P (reply_masters_rvk_fb (Q (ctes_of s)))\" + apply (wp updateCap_ctes_of_wp) + apply (subgoal_tac "mdb_inv_preserve (Q (ctes_of s)) (Q (modify_map (ctes_of s) src + (cteCap_update (\_. capFreeIndex_update (\_. index) (cteCap srcCTE)))))") + apply (drule mdb_inv_preserve.by_products) + apply simp + apply (rule preserve) + apply (rule mdb_inv_preserve_updateCap) + apply (clarsimp simp:cte_wp_at_ctes_of)+ +done + lemma updateCapFreeIndex_distinct_zombies: assumes preserve:"\m m'. mdb_inv_preserve m m' \ mdb_inv_preserve (Q m) (Q m')" shows @@ -4797,6 +4902,19 @@ setUntypedCapAsFull (cteCap srcCTE) cap src apply clarsimp done +lemma setUntypedCapAsFull_reply_masters_rvk_fb: + assumes preserve:"\m m'. mdb_inv_preserve m m' \ mdb_inv_preserve (Q m) (Q m')" + shows + "\\s. P (reply_masters_rvk_fb (Q (ctes_of s))) \ cte_wp_at' (\c. c = srcCTE) src s\ +setUntypedCapAsFull (cteCap srcCTE) cap src + \\r s. P (reply_masters_rvk_fb (Q (ctes_of s)))\" + apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits,intro conjI impI) + apply (wp updateCapFreeIndex_reply_masters_rvk_fb) + apply (clarsimp simp:cte_wp_at_ctes_of preserve)+ + apply wp + apply clarsimp +done + lemma modify_map_eq[simp]: "\m slot = Some srcCTE; cap = cteCap srcCTE\ \(modify_map m slot (cteCap_update (\_. cap))) = m" @@ -4823,10 +4941,11 @@ lemma setUntypedCapAsFull_valid_cap: "\valid_cap' cap and cte_wp_at' ((=) srcCTE) slot\ setUntypedCapAsFull (cteCap srcCTE) c slot \\r. valid_cap' cap\" - apply (clarsimp simp:setUntypedCapAsFull_def updateCap_def split:if_splits) + apply (clarsimp simp:setUntypedCapAsFull_def split:if_splits) apply (intro conjI impI) - apply wpsimp+ - done + apply (clarsimp simp:updateCap_def) + apply (wp|clarsimp)+ +done lemma cteCap_update_simps: "cteCap_update f srcCTE = CTE (f (cteCap srcCTE)) (cteMDBNode srcCTE)" @@ -4910,43 +5029,44 @@ crunch set_untyped_cap_as_full lemma updateMDB_the_lot': assumes "(x, s'') \ fst (updateMDB p f s')" - assumes "pspace_relation (kheap s) (ksPSpace s')" - assumes "pspace_aligned' s'" "pspace_distinct' s'" "no_0 (ctes_of s')" + assumes "pspace_relations (ekheap sa) (kheap s) (ksPSpace s')" + assumes "pspace_aligned' s'" "pspace_distinct' s'" "no_0 (ctes_of s')" "ekheap s = ekheap sa" shows "ctes_of s'' = modify_map (ctes_of s') p (cteMDBNode_update f) \ ksMachineState s'' = ksMachineState s' \ ksWorkUnitsCompleted s'' = ksWorkUnitsCompleted s' \ ksCurThread s'' = ksCurThread s' \ ksIdleThread s'' = ksIdleThread s' \ - ksIdleSC s'' = ksIdleSC s' \ ksReadyQueues s'' = ksReadyQueues s' \ - ksReleaseQueue s'' = ksReleaseQueue s' \ ksSchedulerAction s'' = ksSchedulerAction s' \ ksInterruptState s'' = ksInterruptState s' \ ksArchState s'' = ksArchState s' \ gsUserPages s'' = gsUserPages s' \ gsCNodes s'' = gsCNodes s' \ - pspace_relation (kheap s) (ksPSpace s'') \ + pspace_relations (ekheap s) (kheap s) (ksPSpace s'') \ pspace_aligned' s'' \ pspace_distinct' s'' \ no_0 (ctes_of s'') \ ksDomScheduleIdx s'' = ksDomScheduleIdx s' \ ksDomSchedule s'' = ksDomSchedule s' \ ksCurDomain s'' = ksCurDomain s' \ ksDomainTime s'' = ksDomainTime s' \ - ksConsumedTime s'' = ksConsumedTime s' \ - ksCurTime s'' = ksCurTime s' \ - ksCurSc s'' = ksCurSc s' \ - ksReprogramTimer s'' = ksReprogramTimer s' \ - replyPrevs_of s'' = replyPrevs_of s' \ - scReplies_of s'' = scReplies_of s'" - by (rule updateMDB_the_lot; fastforce intro: assms) + tcbSchedNexts_of s'' = tcbSchedNexts_of s' \ + tcbSchedPrevs_of s'' = tcbSchedPrevs_of s' \ + (\domain priority. + (inQ domain priority |< tcbs_of' s'') = (inQ domain priority |< tcbs_of' s'))" + apply (rule updateMDB_the_lot) + using assms + apply (fastforce simp: pspace_relations_def)+ + done lemma cte_map_inj_eq': - "\ cte_map p = cte_map p'; - cte_at p s \ cte_at p' s \ valid_objs s \ pspace_aligned s \ pspace_distinct s\ + "\(cte_map p = cte_map p'); + cte_at p s \ cte_at p' s \ + valid_objs s \ pspace_aligned s \ pspace_distinct s\ \ p = p'" - by (rule cte_map_inj_eq; fastforce) + apply (rule cte_map_inj_eq; fastforce) + done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_corres: notes split_paired_All[simp del] split_paired_Ex[simp del] trans_state_update'[symmetric,simp] @@ -5000,12 +5120,13 @@ lemma cteInsert_corres: apply (simp+)[3] apply (clarsimp simp: corres_underlying_def state_relation_def in_monad valid_mdb'_def valid_mdb_ctes_def) - apply (drule (22) set_cap_not_quite_corres) - apply fastforce + apply (drule (1) pspace_relationsD) + apply (drule (18) set_cap_not_quite_corres) apply (rule refl) apply (elim conjE exE) apply (rule bind_execI, assumption) - apply (prop_tac "mdb_insert_abs (cdt a) src dest") + apply (subgoal_tac "mdb_insert_abs (cdt a) src dest") + prefer 2 apply (erule mdb_insert_abs.intro) apply (rule mdb_Null_None) apply (simp add: op_equal) @@ -5013,34 +5134,32 @@ lemma cteInsert_corres: apply (rule mdb_Null_descendants) apply (simp add: op_equal) apply simp - apply (prop_tac "no_mloop (cdt a)") + apply (subgoal_tac "no_mloop (cdt a)") + prefer 2 apply (simp add: valid_mdb_def) - apply (clarsimp simp: exec_gets update_cdt_def bind_assoc - set_cdt_def exec_get exec_put set_original_def modify_def + apply (clarsimp simp: exec_gets update_cdt_def bind_assoc set_cdt_def + exec_get exec_put set_original_def modify_def simp del: fun_upd_apply - | (rule bind_execI[where f="cap_insert_ext x y z i p" for x y z i p], - clarsimp simp: exec_gets exec_get put_def - mdb_insert_abs.cap_insert_ext_det_def2 update_cdt_list_def - set_cdt_list_def, - rule refl))+ + | (rule bind_execI[where f="cap_insert_ext x y z i p" for x y z i p], clarsimp simp: exec_gets exec_get put_def mdb_insert_abs.cap_insert_ext_det_def2 update_cdt_list_def set_cdt_list_def, rule refl))+ apply (clarsimp simp: put_def state_relation_def) apply (drule updateCap_stuff) apply clarsimp apply (drule (3) updateMDB_the_lot', simp, simp, elim conjE) apply (drule (3) updateMDB_the_lot', simp, simp, elim conjE) - apply (drule (3) updateMDB_the_lot', simp, simp, elim conjE) + apply (drule (3) updateMDB_the_lot', simp, simp, elim conjE) apply (clarsimp simp: cte_wp_at_ctes_of nullPointer_def prev_update_modify_mdb_relation) - apply (prop_tac "cte_map dest \ 0") - apply (clarsimp simp: valid_mdb'_def - valid_mdb_ctes_def no_0_def) - apply (prop_tac "cte_map src \ 0") - apply (clarsimp simp: valid_mdb'_def - valid_mdb_ctes_def no_0_def) + apply (subgoal_tac "cte_map dest \ 0") + prefer 2 + apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def no_0_def) + apply (subgoal_tac "cte_map src \ 0") + prefer 2 + apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def no_0_def) apply (thin_tac "ksMachineState t = p" for p t)+ apply (thin_tac "ksCurThread t = p" for p t)+ apply (thin_tac "ksIdleThread t = p" for p t)+ apply (thin_tac "ksSchedulerAction t = p" for p t)+ + apply (clarsimp simp: pspace_relations_def) apply (rule conjI) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) @@ -5055,11 +5174,13 @@ lemma cteInsert_corres: apply (case_tac "rv'") apply (rename_tac dest_node) apply (clarsimp simp: in_set_cap_cte_at_swp) - apply (prop_tac "cte_at src a \ is_derived (cdt a) src c src_cap") + apply (subgoal_tac "cte_at src a \ is_derived (cdt a) src c src_cap") + prefer 2 apply (fastforce simp: cte_wp_at_def) apply (erule conjE) - apply (prop_tac "mdb_insert (ctes_of b) (cte_map src) (maskedAsFull src_cap' c') src_node + apply (subgoal_tac "mdb_insert (ctes_of b) (cte_map src) (maskedAsFull src_cap' c') src_node (cte_map dest) NullCap dest_node") + prefer 2 apply (rule mdb_insert.intro) apply (rule mdb_ptr.intro) apply (rule vmdb.intro, simp add: valid_mdb_ctes_def) @@ -5125,7 +5246,8 @@ lemma cteInsert_corres: subgoal by(fastforce) apply(simp) apply(rule impI) - apply(prop_tac "cte_at ca a") + apply(subgoal_tac "cte_at ca a") + prefer 2 apply(rule cte_at_next_slot) apply(simp_all)[4] apply(clarsimp simp: modify_map_def const_def) @@ -5211,7 +5333,7 @@ lemma cteInsert_corres: apply (subst is_derived_eq[symmetric]; assumption) apply assumption subgoal by (clarsimp simp: cte_wp_at_def is_derived_def is_cap_simps cap_master_cap_simps - dest!: cap_master_cap_eqDs) + dest!:cap_master_cap_eqDs) apply (subgoal_tac "is_original_cap a src = mdbRevocable src_node") apply (frule(4) iffD1[OF is_derived_eq]) apply (drule_tac src_cap' = src_cap' in @@ -5222,8 +5344,7 @@ lemma cteInsert_corres: apply simp apply (erule impE) apply (clarsimp simp: null_filter_def cte_wp_at_caps_of_state split: if_splits) - subgoal by (clarsimp simp: masked_as_full_def is_cap_simps free_index_update_def - split: if_splits) + subgoal by (clarsimp simp: masked_as_full_def is_cap_simps free_index_update_def split: if_splits) apply(simp) apply(subgoal_tac "cdt_list (a) src = []") @@ -5271,9 +5392,12 @@ lemma cteInsert_corres: apply(case_tac z) apply(erule_tac x="(aa, bb)" in allE)+ subgoal by(fastforce) - apply(drule cte_map_inj_eq'; simp) - apply(drule cte_map_inj_eq'; simp) - apply(drule cte_map_inj_eq'; simp) + apply(drule cte_map_inj_eq') + apply(simp_all)[2] + apply(drule cte_map_inj_eq') + apply(simp_all)[2] + apply(drule cte_map_inj_eq') + apply(simp_all)[2] apply(erule_tac x="(aa, bb)" in allE)+ subgoal by(fastforce) @@ -5332,7 +5456,8 @@ lemma cteInsert_corres: apply (clarsimp simp: revokable_relation_def split: if_split) apply (rule conjI) apply clarsimp - apply (prop_tac "mdbRevocable node = revokable' (cteCap srcCTE) c'") + apply (subgoal_tac "mdbRevocable node = revokable' (cteCap srcCTE) c'") + prefer 2 apply (case_tac rv') subgoal by (clarsimp simp add: const_def modify_map_def split: if_split_asm) apply simp @@ -5343,12 +5468,13 @@ lemma cteInsert_corres: apply assumption apply assumption subgoal by (clarsimp simp: cap_master_cap_simps cte_wp_at_def is_derived_def is_cap_simps - split: if_splits dest!:cap_master_cap_eqDs) + split:if_splits dest!:cap_master_cap_eqDs) apply clarsimp apply (case_tac srcCTE) apply (case_tac rv') apply clarsimp - apply (prop_tac "\cap' node'. ctes_of b (cte_map (aa,bb)) = Some (CTE cap' node')") + apply (subgoal_tac "\cap' node'. ctes_of b (cte_map (aa,bb)) = Some (CTE cap' node')") + prefer 2 apply (clarsimp simp: modify_map_def split: if_split_asm) apply (case_tac z) subgoal by clarsimp @@ -5356,11 +5482,11 @@ lemma cteInsert_corres: apply (drule set_cap_caps_of_state_monad)+ apply (subgoal_tac "null_filter (caps_of_state a) (aa,bb) \ None") prefer 2 - subgoal by (clarsimp simp: cte_wp_at_caps_of_state null_filter_def - split: if_splits) + subgoal by (clarsimp simp: cte_wp_at_caps_of_state null_filter_def split: if_splits) apply clarsimp - apply (prop_tac "cte_at (aa,bb) a") + apply (subgoal_tac "cte_at (aa,bb) a") + prefer 2 apply (drule null_filter_caps_of_stateD) apply (erule cte_wp_at_weakenE, rule TrueI) apply (subgoal_tac "mdbRevocable node = mdbRevocable node'") @@ -5368,7 +5494,6 @@ lemma cteInsert_corres: apply (subgoal_tac "cte_map (aa,bb) \ cte_map dest") subgoal by (clarsimp simp: modify_map_def split: if_split_asm) apply (erule (5) cte_map_inj) - apply (wp set_untyped_cap_full_valid_objs set_untyped_cap_as_full_valid_mdb set_untyped_cap_as_full_cte_wp_at setUntypedCapAsFull_valid_cap setUntypedCapAsFull_cte_wp_at | clarsimp simp: cte_wp_at_caps_of_state| wps)+ @@ -5385,11 +5510,13 @@ lemma cteInsert_corres: apply (case_tac "rv'") apply (rename_tac dest_node) apply (clarsimp simp: in_set_cap_cte_at_swp) - apply (prop_tac "cte_at src a \ is_derived (cdt a) src c src_cap") + apply (subgoal_tac "cte_at src a \ is_derived (cdt a) src c src_cap") + prefer 2 subgoal by (fastforce simp: cte_wp_at_def) apply (erule conjE) - apply (prop_tac "mdb_insert (ctes_of b) (cte_map src) (maskedAsFull src_cap' c') src_node + apply (subgoal_tac "mdb_insert (ctes_of b) (cte_map src) (maskedAsFull src_cap' c') src_node (cte_map dest) NullCap dest_node") + prefer 2 apply (rule mdb_insert.intro) apply (rule mdb_ptr.intro) subgoal by (rule vmdb.intro, simp add: valid_mdb_ctes_def) @@ -5408,10 +5535,12 @@ lemma cteInsert_corres: apply (rule mdb_insert_der_axioms.intro) apply (simp add: is_derived_eq) apply (simp (no_asm_simp) add: cdt_relation_def split: if_split) - apply (prop_tac "descendants_of dest (cdt a) = {}") + apply (subgoal_tac "descendants_of dest (cdt a) = {}") + prefer 2 apply (drule mdb_insert.dest_no_descendants) - subgoal by (fastforce simp add: cdt_relation_def) - apply (prop_tac "mdb_insert_abs (cdt a) src dest") + subgoal by (fastforce simp add: cdt_relation_def simp del: split_paired_All) + apply (subgoal_tac "mdb_insert_abs (cdt a) src dest") + prefer 2 apply (erule mdb_insert_abs.intro) apply (rule mdb_None) apply (erule(1) mdb_insert.descendants_not_dest) @@ -5444,11 +5573,11 @@ lemma cteInsert_corres: dest!:cap_master_cap_eqDs) apply (subgoal_tac "is_original_cap a src = mdbRevocable src_node") prefer 2 - apply (simp add: revokable_relation_def) + apply (simp add: revokable_relation_def del: split_paired_All) apply (erule_tac x=src in allE) apply (erule impE) apply (clarsimp simp: null_filter_def cte_wp_at_caps_of_state cap_master_cap_simps - split: if_splits dest!:cap_master_cap_eqDs) + split: if_splits dest!:cap_master_cap_eqDs) subgoal by (clarsimp simp: masked_as_full_def is_cap_simps free_index_update_def split: if_splits) subgoal by simp subgoal by clarsimp @@ -5458,7 +5587,7 @@ lemma cteInsert_corres: prefer 2 apply assumption apply (simp_all)[6] - apply (simp add: cdt_relation_def split: if_split) + apply (simp add: cdt_relation_def split: if_split del: split_paired_All) apply clarsimp apply (drule (5) cte_map_inj)+ apply simp @@ -5486,7 +5615,7 @@ lemma cteInsert_corres: dest!:cap_master_cap_eqDs) apply (subgoal_tac "is_original_cap a src = mdbRevocable src_node") subgoal by simp - apply (simp add: revokable_relation_def) + apply (simp add: revokable_relation_def del: split_paired_All) apply (erule_tac x=src in allE) apply (erule impE) apply (clarsimp simp: null_filter_def cte_wp_at_caps_of_state split: if_splits) @@ -5496,13 +5625,12 @@ lemma cteInsert_corres: apply (frule_tac p="(aa, bb)" in in_set_cap_cte_at) apply (rule conjI) apply (clarsimp simp: descendants_of_eq') - subgoal by (simp add: cdt_relation_def) + subgoal by (simp add: cdt_relation_def del: split_paired_All) apply (clarsimp simp: descendants_of_eq') - subgoal by (simp add: cdt_relation_def) + subgoal by (simp add: cdt_relation_def del: split_paired_All) done -(* FIXME RT: This is the sort of crap we should get rid of when possible, or - at least make it more localised. VER-1250 *) + declare if_split [split] lemma updateCap_no_0: @@ -6468,10 +6596,10 @@ lemma cteSwap_corres: apply (clarsimp simp: corres_underlying_def in_monad state_relation_def) apply (clarsimp simp: valid_mdb'_def) - apply (drule (16) set_cap_not_quite_corres) - apply fastforce - apply (erule cte_wp_at_weakenE, rule TrueI) - apply assumption+ + apply (drule(1) pspace_relationsD) + apply (drule (12) set_cap_not_quite_corres) + apply (erule cte_wp_at_weakenE, rule TrueI) + apply assumption+ apply (rule refl) apply (elim exE conjE) apply (rule bind_execI, assumption) @@ -6489,9 +6617,8 @@ lemma cteSwap_corres: use_valid [OF _ set_cap_distinct] cte_wp_at_weakenE) apply (elim conjE) - apply (drule (18) set_cap_not_quite_corres) - apply simp - apply fastforce + apply (drule (14) set_cap_not_quite_corres) + apply simp apply assumption+ apply (rule refl) apply (elim exE conjE) @@ -6505,19 +6632,20 @@ lemma cteSwap_corres: apply (simp cong: option.case_cong) apply (drule updateCap_stuff, elim conjE, erule(1) impE) apply (drule (2) updateMDB_the_lot') - apply (erule (1) impE, assumption) - apply (fastforce simp only: no_0_modify_map) + apply (erule (1) impE, assumption) + apply (fastforce simp only: no_0_modify_map) + apply assumption apply (elim conjE TrueE, simp only:) - apply (drule (2) updateMDB_the_lot', assumption, fastforce simp only: no_0_modify_map) - apply (drule in_getCTE, clarsimp) - apply (drule (2) updateMDB_the_lot', assumption, fastforce simp only: no_0_modify_map) + apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption) + apply (drule in_getCTE, elim conjE, simp only:) + apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption) apply (elim conjE TrueE, simp only:) - apply (drule (2) updateMDB_the_lot', assumption, fastforce simp only: no_0_modify_map) + apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption) apply (elim conjE TrueE, simp only:) - apply (drule (2) updateMDB_the_lot', assumption, fastforce simp only: no_0_modify_map) + apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption) apply (elim conjE TrueE, simp only:) - apply (drule (2) updateMDB_the_lot', assumption, fastforce simp only: no_0_modify_map) - apply (simp only: refl) + apply (drule (2) updateMDB_the_lot', fastforce, simp only: no_0_modify_map, assumption) + apply (simp only: pspace_relations_def refl) apply (rule conjI, rule TrueI)+ apply (thin_tac "ksMachineState t = p" for t p)+ apply (thin_tac "ksCurThread t = p" for t p)+ @@ -6551,7 +6679,6 @@ lemma cteSwap_corres: apply (erule weak_derived_sym') apply (erule weak_derived_sym') apply assumption - apply (rule conjI) subgoal by (simp only: simp_thms ghost_relation_typ_at set_cap_a_type_inv ARM.data_at_def) apply (thin_tac "ksMachineState t = p" for t p)+ @@ -6569,6 +6696,7 @@ lemma cteSwap_corres: apply (thin_tac "domain_index t = p" for t p)+ apply (thin_tac "domain_list t = p" for t p)+ apply (thin_tac "domain_time t = p" for t p)+ + apply (thin_tac "ekheap t = p" for t p)+ apply (thin_tac "scheduler_action t = p" for t p)+ apply (thin_tac "ksArchState t = p" for t p)+ apply (thin_tac "gsCNodes t = p" for t p)+ @@ -6577,6 +6705,7 @@ lemma cteSwap_corres: apply (thin_tac "ksIdleThread t = p" for t p)+ apply (thin_tac "gsUserPages t = p" for t p)+ apply (thin_tac "pspace_relation s s'" for s s')+ + apply (thin_tac "ekheap_relation e p" for e p)+ apply (thin_tac "interrupt_state_relation n s s'" for n s s')+ apply (thin_tac "(s,s') \ arch_state_relation" for s s')+ apply(subst conj_assoc[symmetric]) @@ -6718,35 +6847,54 @@ lemma cteSwap_corres: apply(fastforce split: option.split) apply(simp) apply(frule finite_depth) - apply(frule mdb_swap.n_next; (simp (no_asm_simp))?) + apply(frule mdb_swap.n_next) + apply(simp) apply(case_tac "(aa, bb)=src") apply(case_tac "next_slot dest (cdt_list (a)) (cdt a) = Some src") apply(simp) apply(erule_tac x="fst dest" in allE, erule_tac x="snd dest" in allE) apply(simp) apply(simp) - apply(case_tac "next_slot dest (cdt_list (a)) (cdt a)"; (simp (no_asm_simp))?) + apply(case_tac "next_slot dest (cdt_list (a)) (cdt a)") + apply(simp) + apply(simp) apply(erule_tac x="fst dest" in allE, erule_tac x="snd dest" in allE) apply(simp) apply(subgoal_tac "mdbNext dest_node \ cte_map src") apply(simp) apply(simp) - apply(rule_tac s=a in cte_map_inj; (simp (no_asm_simp))?) - apply(rule cte_at_next_slot'; (simp (no_asm_simp))?) - apply(erule cte_wp_at_weakenE, rule TrueI) + apply(rule_tac s=a in cte_map_inj) + apply(simp) + apply(rule cte_at_next_slot') + apply(simp) + apply(simp) + apply(simp) + apply(simp) + apply(erule cte_wp_at_weakenE, rule TrueI) + apply(simp_all)[3] apply(case_tac "(aa, bb)=dest") apply(case_tac "next_slot src (cdt_list (a)) (cdt a) = Some dest") apply(simp) apply(erule_tac x="fst src" in allE, erule_tac x="snd src" in allE) apply(simp) apply(simp) - apply(case_tac "next_slot src (cdt_list (a)) (cdt a)"; (simp (no_asm_simp))?) + apply(case_tac "next_slot src (cdt_list (a)) (cdt a)") + apply(simp) + apply(simp) apply(erule_tac x="fst src" in allE, erule_tac x="snd src" in allE) apply(simp) - apply(subgoal_tac "mdbNext src_node \ cte_map dest"; (simp (no_asm_simp))?) - apply(rule_tac s=a in cte_map_inj; (simp (no_asm_simp))?) - apply(rule cte_at_next_slot'; (simp (no_asm_simp))?) - apply(erule cte_wp_at_weakenE, rule TrueI) + apply(subgoal_tac "mdbNext src_node \ cte_map dest") + apply(simp) + apply(simp) + apply(rule_tac s=a in cte_map_inj) + apply(simp) + apply(rule cte_at_next_slot') + apply(simp) + apply(simp) + apply(simp) + apply(simp) + apply(erule cte_wp_at_weakenE, rule TrueI) + apply(simp_all)[3] apply(case_tac "next_slot (aa, bb) (cdt_list (a)) (cdt a) = Some src") apply(simp) apply(erule_tac x=aa in allE, erule_tac x=bb in allE) @@ -6757,20 +6905,24 @@ lemma cteSwap_corres: cte_map (aa, bb) = mdbPrev src_node") apply(clarsimp) apply(rule conjI) - apply(rule cte_map_inj; (simp (no_asm_simp))?) + apply(rule cte_map_inj) + apply(simp_all)[6] apply(erule cte_wp_at_weakenE, simp) apply(rule conjI) - apply(rule cte_map_inj; (simp (no_asm_simp))?) - apply(erule cte_wp_at_weakenE, simp (no_asm_simp)) - apply(frule mdb_swap.m_exists, simp (no_asm_simp)) + apply(rule cte_map_inj) + apply(simp_all)[6] + apply(erule cte_wp_at_weakenE, simp) + apply(frule mdb_swap.m_exists) + apply(simp) apply(clarsimp) apply(frule_tac cte="CTE cap' node'" in valid_mdbD1') apply(clarsimp) - apply(simp (no_asm_simp) add: valid_mdb'_def) + apply(simp add: valid_mdb'_def) apply(clarsimp) - apply(rule cte_at_next_slot; simp (no_asm_simp)) + apply(rule cte_at_next_slot) + apply(simp_all)[4] apply(case_tac "next_slot (aa, bb) (cdt_list (a)) (cdt a) = Some dest") - apply(simp (no_asm_simp)) + apply(simp) apply(erule_tac x=aa in allE, erule_tac x=bb in allE) apply(simp) apply(subgoal_tac "cte_at (aa, bb) a") @@ -6781,22 +6933,25 @@ lemma cteSwap_corres: apply(clarsimp) apply(clarsimp simp: mdb_swap.prev_dest_src) apply(rule conjI) - apply(rule cte_map_inj; (simp (no_asm_simp))?) - apply(erule cte_wp_at_weakenE, simp (no_asm_simp)) + apply(rule cte_map_inj) + apply(simp_all)[6] + apply(erule cte_wp_at_weakenE, simp) apply(rule conjI) - apply(rule cte_map_inj; (simp (no_asm_simp))?) - apply(erule cte_wp_at_weakenE, simp (no_asm_simp)) + apply(rule cte_map_inj) + apply(simp_all)[6] + apply(erule cte_wp_at_weakenE, simp) apply(frule mdb_swap.m_exists) - apply(simp (no_asm_simp)) + apply(simp) apply(clarsimp) apply(frule_tac cte="CTE cap' node'" in valid_mdbD1') apply(clarsimp) - apply(simp (no_asm_simp) add: valid_mdb'_def) + apply(simp add: valid_mdb'_def) apply(clarsimp) - apply(rule cte_at_next_slot; (simp (no_asm_simp))?) - apply(simp (no_asm_simp)) + apply(rule cte_at_next_slot) + apply(simp_all)[4] + apply(simp) apply(case_tac "next_slot (aa, bb) (cdt_list (a)) (cdt a)") - apply(simp (no_asm_simp)) + apply(simp) apply(clarsimp) apply(erule_tac x=aa in allE, erule_tac x=bb in allE) apply(simp) @@ -6807,37 +6962,39 @@ lemma cteSwap_corres: cte_map (aa, bb) \ mdbPrev dest_node") apply(clarsimp) apply(rule conjI) - apply(rule cte_map_inj; (simp (no_asm_simp))?) - apply(erule cte_wp_at_weakenE, simp (no_asm_simp)) + apply(rule cte_map_inj) + apply(simp_all)[6] + apply(erule cte_wp_at_weakenE, simp) apply(rule conjI) - apply(rule cte_map_inj; (simp (no_asm_simp))?) - apply(erule cte_wp_at_weakenE, simp (no_asm_simp)) + apply(rule cte_map_inj) + apply simp_all[6] + apply(erule cte_wp_at_weakenE, simp) apply(rule conjI) apply(frule mdb_swap.m_exists) - apply(simp (no_asm_simp)) + apply(simp) apply(clarsimp) apply(frule_tac cte="CTE src_cap src_node" in valid_mdbD2') - subgoal by (clarsimp) - apply(simp (no_asm_simp) add: valid_mdb'_def) + subgoal by (clarsimp) + apply(simp add: valid_mdb'_def) apply(clarsimp) - apply(drule cte_map_inj_eq; (simp (no_asm_simp))?) - apply(rule cte_at_next_slot'; simp (no_asm_simp)) - apply(erule cte_wp_at_weakenE, simp (no_asm_simp)) - apply simp + apply(drule cte_map_inj_eq) + apply(rule cte_at_next_slot') + apply(simp_all)[9] + apply(erule cte_wp_at_weakenE, simp) apply(frule mdb_swap.m_exists) - apply(simp (no_asm_simp)) + apply(simp) apply(clarsimp) apply(frule_tac cte="CTE dest_cap dest_node" in valid_mdbD2') apply(clarsimp) - apply(simp (no_asm_simp) add: valid_mdb'_def) + apply(simp add: valid_mdb'_def) apply(clarsimp) - apply(drule cte_map_inj_eq; (simp (no_asm_simp))?) - apply(rule cte_at_next_slot'; simp (no_asm_simp)) - apply(erule cte_wp_at_weakenE) - apply (simp (no_asm_simp)) - apply simp + apply(drule cte_map_inj_eq) + apply(rule cte_at_next_slot') + apply(simp_all)[9] + apply(erule cte_wp_at_weakenE, simp) by (rule cte_at_next_slot; simp) + lemma capSwapForDelete_corres: assumes "src' = cte_map src" "dest' = cte_map dest" shows "corres dc @@ -6891,7 +7048,7 @@ lemma subtree_no_parent: shows "False" using assms by induct (auto simp: parentOf_def mdb_next_unfold) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ensureNoChildren_corres: "p' = cte_map p \ diff --git a/proof/refine/ARM/CSpace_I.thy b/proof/refine/ARM/CSpace_I.thy index fe2cfdbb77..cfd89623cb 100644 --- a/proof/refine/ARM/CSpace_I.thy +++ b/proof/refine/ARM/CSpace_I.thy @@ -12,10 +12,23 @@ theory CSpace_I imports ArchAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) - -lemmas capUntypedPtr_simps[simp] = capUntypedPtr_def[split_simps capability.split, simplified PPtr_def id_def] -lemmas arch_capUntypedPtr_simps[simp] = ARM_H.capUntypedPtr_def[split_simps arch_capability.split, simplified PPtr_def id_def] +context begin interpretation Arch . (*FIXME: arch-split*) + +lemma capUntypedPtr_simps [simp]: + "capUntypedPtr (ThreadCap r) = r" + "capUntypedPtr (NotificationCap r badge a b) = r" + "capUntypedPtr (EndpointCap r badge a b c d) = r" + "capUntypedPtr (Zombie r bits n) = r" + "capUntypedPtr (ArchObjectCap x) = Arch.capUntypedPtr x" + "capUntypedPtr (UntypedCap d r n f) = r" + "capUntypedPtr (CNodeCap r n g n2) = r" + "capUntypedPtr (ReplyCap r m a) = r" + "Arch.capUntypedPtr (ARM_H.ASIDPoolCap r asid) = r" + "Arch.capUntypedPtr (ARM_H.PageCap d r rghts sz mapdata) = r" + "Arch.capUntypedPtr (ARM_H.PageTableCap r mapdata2) = r" + "Arch.capUntypedPtr (ARM_H.PageDirectoryCap r mapdata3) = r" + by (auto simp: capUntypedPtr_def + ARM_H.capUntypedPtr_def) lemma rights_mask_map_UNIV [simp]: "rights_mask_map UNIV = allRights" @@ -32,6 +45,14 @@ lemma maskCapRights_allRights [simp]: lemma getCTE_inv [wp]: "\P\ getCTE addr \\rv. P\" by (simp add: getCTE_def) wp +lemma getEndpoint_inv [wp]: + "\P\ getEndpoint ptr \\rv. P\" + by (simp add: getEndpoint_def getObject_inv loadObject_default_inv) + +lemma getNotification_inv [wp]: + "\P\ getNotification ptr \\rv. P\" + by (simp add: getNotification_def getObject_inv loadObject_default_inv) + lemma getSlotCap_inv [wp]: "\P\ getSlotCap addr \\rv. P\" by (simp add: getSlotCap_def, wp) @@ -499,6 +520,7 @@ lemma isPhysicalCap[simp]: by (simp add: isPhysicalCap_def ARM_H.isPhysicalCap_def split: capability.split arch_capability.split) +(* FIXME instead of a definition and then a simp rule in the simp set, we should use fun *) definition capMasterCap :: "capability \ capability" where @@ -507,7 +529,7 @@ where | NotificationCap ref bdg s r \ NotificationCap ref 0 True True | CNodeCap ref bits gd gs \ CNodeCap ref bits 0 0 | ThreadCap ref \ ThreadCap ref - | ReplyCap ref g \ ReplyCap ref True + | ReplyCap ref master g \ ReplyCap ref True True | UntypedCap d ref n f \ UntypedCap d ref n 0 | ArchObjectCap acap \ ArchObjectCap (case acap of PageCap d ref rghts sz mapdata \ @@ -521,7 +543,29 @@ where | _ \ acap) | _ \ cap" -lemmas capMasterCap_simps[simp] = capMasterCap_def[split_simps capability.split arch_capability.split] +lemma capMasterCap_simps[simp]: + "capMasterCap (EndpointCap ref bdg s r g gr) = EndpointCap ref 0 True True True True" + "capMasterCap (NotificationCap ref bdg s r) = NotificationCap ref 0 True True" + "capMasterCap (CNodeCap ref bits gd gs) = CNodeCap ref bits 0 0" + "capMasterCap (ThreadCap ref) = ThreadCap ref" + "capMasterCap capability.NullCap = capability.NullCap" + "capMasterCap capability.DomainCap = capability.DomainCap" + "capMasterCap (capability.IRQHandlerCap irq) = capability.IRQHandlerCap irq" + "capMasterCap (capability.Zombie word zombie_type n) = capability.Zombie word zombie_type n" + "capMasterCap (capability.ArchObjectCap (arch_capability.ASIDPoolCap word1 word2)) = + capability.ArchObjectCap (arch_capability.ASIDPoolCap word1 0)" + "capMasterCap (capability.ArchObjectCap arch_capability.ASIDControlCap) = + capability.ArchObjectCap arch_capability.ASIDControlCap" + "capMasterCap (capability.ArchObjectCap (arch_capability.PageCap d word vmrights vmpage_size pdata)) = + capability.ArchObjectCap (arch_capability.PageCap d word VMReadWrite vmpage_size None)" + "capMasterCap (capability.ArchObjectCap (arch_capability.PageTableCap word ptdata)) = + capability.ArchObjectCap (arch_capability.PageTableCap word None)" + "capMasterCap (capability.ArchObjectCap (arch_capability.PageDirectoryCap word pddata)) = + capability.ArchObjectCap (arch_capability.PageDirectoryCap word None)" + "capMasterCap (capability.UntypedCap d word n f) = capability.UntypedCap d word n 0" + "capMasterCap capability.IRQControlCap = capability.IRQControlCap" + "capMasterCap (capability.ReplyCap word m g) = capability.ReplyCap word True True" + by (simp_all add: capMasterCap_def) lemma capMasterCap_eqDs1: "capMasterCap cap = EndpointCap ref bdg s r g gr @@ -534,10 +578,6 @@ lemma capMasterCap_eqDs1: \ gd = 0 \ gs = 0 \ (\gd gs. cap = CNodeCap ref bits gd gs)" "capMasterCap cap = ThreadCap ref \ cap = ThreadCap ref" - "capMasterCap cap = SchedContextCap ref n - \ cap = SchedContextCap ref n" - "capMasterCap cap = SchedControlCap - \ cap = SchedControlCap" "capMasterCap cap = NullCap \ cap = NullCap" "capMasterCap cap = DomainCap @@ -550,8 +590,8 @@ lemma capMasterCap_eqDs1: \ cap = Zombie ref tp n" "capMasterCap cap = UntypedCap d ref bits 0 \ \f. cap = UntypedCap d ref bits f" - "capMasterCap cap = ReplyCap ref g - \ g \ (\g. cap = ReplyCap ref g)" + "capMasterCap cap = ReplyCap ref master g + \ master \ g \ (\master g. cap = ReplyCap ref master g)" "capMasterCap cap = ArchObjectCap (PageCap d ref rghts sz mapdata) \ rghts = VMReadWrite \ mapdata = None \ (\rghts mapdata. cap = ArchObjectCap (PageCap d ref rghts sz mapdata))" @@ -583,13 +623,11 @@ lemma capBadge_simps[simp]: "capBadge (NotificationCap ref badge s r) = Some badge" "capBadge (CNodeCap ref bits gd gs) = None" "capBadge (ThreadCap ref) = None" - "capBadge (SchedContextCap ref n) = None" - "capBadge (SchedControlCap) = None" "capBadge (Zombie ref b n) = None" "capBadge (ArchObjectCap cap) = None" "capBadge (IRQControlCap) = None" "capBadge (IRQHandlerCap irq) = None" - "capBadge (ReplyCap tcb g) = None" + "capBadge (ReplyCap tcb master g) = None" by (simp add: capBadge_def isCap_defs)+ lemma capClass_Master: @@ -613,8 +651,6 @@ lemma isCap_Master: "isCNodeCap (capMasterCap cap) = isCNodeCap cap" "isNotificationCap (capMasterCap cap) = isNotificationCap cap" "isEndpointCap (capMasterCap cap) = isEndpointCap cap" - "isSchedContextCap (capMasterCap cap) = isSchedContextCap cap" - "isSchedControlCap (capMasterCap cap) = isSchedControlCap cap" "isUntypedCap (capMasterCap cap) = isUntypedCap cap" "isReplyCap (capMasterCap cap) = isReplyCap cap" "isIRQControlCap (capMasterCap cap) = isIRQControlCap cap" @@ -667,7 +703,7 @@ lemma sameRegionAs_def2: split del: if_split cong: if_cong) apply (clarsimp simp: capRange_def Let_def) apply (simp add: range_subset_eq2 cong: conj_cong) - by (auto simp add: conj_comms) + by (simp add: conj_comms) lemma sameObjectAs_def2: "sameObjectAs cap cap' = (\cap cap'. @@ -746,9 +782,7 @@ lemma capUntypedSize_simps [simp]: "capUntypedSize (ArchObjectCap x) = Arch.capUntypedSize x" "capUntypedSize (UntypedCap d r n f) = 1 << n" "capUntypedSize (CNodeCap r n g n2) = 1 << (objBits (undefined::cte) + n)" - "capUntypedSize (ReplyCap r a) = 1 << objBits (undefined :: reply)" - "capUntypedSize (SchedContextCap sc sz) = 1 << sz" - "capUntypedSize SchedControlCap = 1" + "capUntypedSize (ReplyCap r m a) = 1 << objBits (undefined :: tcb)" "capUntypedSize IRQControlCap = 1" "capUntypedSize (IRQHandlerCap irq) = 1" by (auto simp add: capUntypedSize_def isCap_simps objBits_simps @@ -813,9 +847,14 @@ lemma capBadge_maskCapRights[simp]: lemma getObject_cte_det: "(r::cte,s') \ fst (getObject p s) \ fst (getObject p s) = {(r,s)} \ s' = s" - by (clarsimp simp: getObject_def in_monad split_def obind_def gets_def get_def - readObject_def omonad_defs bind_def return_def gets_the_def assert_opt_def - split: option.splits) + apply (clarsimp simp add: getObject_def bind_def get_def gets_def + return_def loadObject_cte split_def) + apply (clarsimp split: kernel_object.split_asm if_split_asm option.split_asm + simp: in_monad typeError_def alignError_def magnitudeCheck_def) + apply (simp_all add: bind_def return_def assert_opt_def split_def + alignCheck_def is_aligned_mask[symmetric] + unless_def when_def magnitudeCheck_def) + done lemma cte_wp_at_obj_cases': "cte_wp_at' P p s = @@ -823,7 +862,7 @@ lemma cte_wp_at_obj_cases': apply (simp add: cte_wp_at_cases' obj_at'_def) apply (rule iffI) apply (erule disjEI - | clarsimp simp: objBits_simps' cte_level_bits_def projectKOs word_bits_def + | clarsimp simp: objBits_simps' cte_level_bits_def projectKOs | rule rev_bexI, erule domI)+ apply fastforce done @@ -867,14 +906,6 @@ lemma valid_capAligned: "valid_cap' c s \ capAligned c" by (simp add: valid_cap'_def) -lemma valid_SchedContextCap_sc_at': - "\valid_cap' (SchedContextCap sc_ptr n) s\ \ sc_at' sc_ptr s" - apply (clarsimp simp: valid_cap'_def obj_at'_real_def) - apply (rule ko_wp_at'_weakenE) - apply (fastforce simp: objBits_simps - split: kernel_object.splits)+ - done - lemma caps_no_overlap'_no_region: "\ caps_no_overlap' m (capRange cap); valid_objs' s; m = ctes_of s; s \' cap; fresh_virt_cap_class (capClass cap) m \ \ @@ -1484,7 +1515,7 @@ lemma no_mdb_not_target: apply (simp add: no_mdb_def) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_dlist_init: "\ valid_dlist m; m p = Some cte; no_mdb cte \ \ valid_dlist (m (p \ CTE cap initMDBNode))" @@ -1682,7 +1713,7 @@ lemma untyped_inc_init: apply (rule untypedRange_in_capRange)+ apply (simp add:Int_ac) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_nullcaps_init: "\ valid_nullcaps m; cap \ NullCap \ \ valid_nullcaps (m(p \ CTE cap initMDBNode))" by (simp add: valid_nullcaps_def initMDBNode_def nullPointer_def) @@ -1742,7 +1773,7 @@ lemma distinct_zombies_copyE: lemmas distinct_zombies_sameE = distinct_zombies_copyE [where y=x and x=x for x, simplified, OF _ _ _ _ _] -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma capBits_Master: "capBits (capMasterCap cap) = capBits cap" by (clarsimp simp: capMasterCap_def split: capability.split arch_capability.split) @@ -1892,16 +1923,20 @@ lemma valid_mdb_ctes_init: apply clarsimp apply (case_tac ctea, clarsimp) apply (rule valid_capAligned, erule(1) ctes_of_valid_cap') - apply (erule (1) irq_control_init) + apply (rule conjI) + apply (erule (1) irq_control_init) + apply (simp add: ran_def reply_masters_rvk_fb_def) + apply (auto simp: initMDBNode_def)[1] done lemma setCTE_state_refs_of'[wp]: "\\s. P (state_refs_of' s)\ setCTE p cte \\rv s. P (state_refs_of' s)\" unfolding setCTE_def apply (rule setObject_state_refs_of_eq) - by (clarsimp simp: updateObject_cte in_monad typeError_def - in_magnitude_check objBits_simps - split: kernel_object.split_asm if_split_asm)+ + apply (clarsimp simp: updateObject_cte in_monad typeError_def + in_magnitude_check objBits_simps + split: kernel_object.split_asm if_split_asm) + done lemma setCTE_valid_mdb: fixes cap @@ -1926,11 +1961,12 @@ lemma setCTE_valid_objs'[wp]: unfolding setCTE_def apply (rule setObject_valid_objs') apply (clarsimp simp: prod_eq_iff lookupAround2_char1 updateObject_cte objBits_simps) - by (clarsimp simp: prod_eq_iff lookupAround2_char1 + apply (clarsimp simp: prod_eq_iff lookupAround2_char1 updateObject_cte in_monad typeError_def valid_obj'_def valid_tcb'_def valid_cte'_def tcb_cte_cases_def - split: kernel_object.split_asm if_split_asm)+ + split: kernel_object.split_asm if_split_asm) + done lemma getCTE_cte_wp_at: "\\\ getCTE p \\rv. cte_wp_at' (\c. c = rv) p\" @@ -1978,6 +2014,10 @@ lemma setCTE_no_0_obj' [wp]: declare mresults_fail[simp] +crunch get_object + for idle[wp]: "valid_idle" + (wp: crunch_wps simp: crunch_simps) + end diff --git a/proof/refine/ARM/CSpace_R.thy b/proof/refine/ARM/CSpace_R.thy index f19d6f755e..78933b0531 100644 --- a/proof/refine/ARM/CSpace_R.thy +++ b/proof/refine/ARM/CSpace_R.thy @@ -12,8 +12,10 @@ theory CSpace_R imports CSpace1_R begin -lemma setCTE_pred_tcb_at'[wp]: - "setCTE c cte \pred_tcb_at' proj P t\" +lemma setCTE_pred_tcb_at': + "\pred_tcb_at' proj P t\ + setCTE c cte + \\rv. pred_tcb_at' proj P t\" unfolding pred_tcb_at'_def setCTE_def apply (rule setObject_cte_obj_at_tcb') apply (simp add: tcb_to_itcb'_def)+ @@ -51,7 +53,7 @@ locale mdb_move = modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas src = m_p @@ -677,7 +679,8 @@ lemma updateCap_dynamic_duo: \ pspace_aligned' s' \ pspace_distinct' s'" unfolding updateCap_def apply (rule conjI) - by (erule use_valid | wpsimp)+ + apply (erule use_valid | wp | assumption)+ + done declare const_apply[simp] @@ -690,20 +693,16 @@ lemma next_slot_eq2: lemma set_cap_not_quite_corres': assumes cr: - "pspace_relation (kheap s) (ksPSpace s')" + "pspace_relations (ekheap (a)) (kheap s) (ksPSpace s')" + "ekheap (s) = ekheap (a)" "cur_thread s = ksCurThread s'" "idle_thread s = ksIdleThread s'" - "idle_sc_ptr = ksIdleSC s'" "machine_state s = ksMachineState s'" "work_units_completed s = ksWorkUnitsCompleted s'" "domain_index s = ksDomScheduleIdx s'" "domain_list s = ksDomSchedule s'" "cur_domain s = ksCurDomain s'" "domain_time s = ksDomainTime s'" - "consumed_time s = ksConsumedTime s'" - "cur_time s = ksCurTime s'" - "cur_sc s = ksCurSc s'" - "reprogram_timer s = ksReprogramTimer s'" "(x,t') \ fst (updateCap p' c' s')" "valid_objs s" "pspace_aligned s" "pspace_distinct s" "cte_at p s" "pspace_aligned' s'" "pspace_distinct' s'" @@ -712,34 +711,29 @@ lemma set_cap_not_quite_corres': assumes c: "cap_relation c c'" assumes p: "p' = cte_map p" shows "\t. ((),t) \ fst (set_cap c p s) \ - pspace_relation (kheap t) (ksPSpace t') \ + pspace_relations (ekheap t) (kheap t) (ksPSpace t') \ cdt t = cdt s \ cdt_list t = cdt_list (s) \ + ekheap t = ekheap (s) \ scheduler_action t = scheduler_action (s) \ ready_queues t = ready_queues (s) \ - release_queue t = release_queue s \ is_original_cap t = is_original_cap s \ interrupt_state_relation (interrupt_irq_node t) (interrupt_states t) (ksInterruptState t') \ (arch_state t, ksArchState t') \ arch_state_relation \ cur_thread t = ksCurThread t' \ idle_thread t = ksIdleThread t' \ - idle_sc_ptr = ksIdleSC t' \ machine_state t = ksMachineState t' \ work_units_completed t = ksWorkUnitsCompleted t' \ domain_index t = ksDomScheduleIdx t' \ domain_list t = ksDomSchedule t' \ cur_domain t = ksCurDomain t' \ - domain_time t = ksDomainTime t' \ - consumed_time t = ksConsumedTime t' \ - cur_time t = ksCurTime t' \ - cur_sc t = ksCurSc t' \ - reprogram_timer t = ksReprogramTimer t' \ - sc_replies_of t = sc_replies_of s" - using cr - by (rule set_cap_not_quite_corres; fastforce simp: c p) - -context begin interpretation Arch . (*FIXME: arch_split*) + domain_time t = ksDomainTime t'" + apply (rule set_cap_not_quite_corres) + using cr + apply (fastforce simp: c p pspace_relations_def)+ + done +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteMove_corres: assumes cr: "cap_relation cap cap'" notes trans_state_update'[symmetric,simp] @@ -808,6 +802,7 @@ lemma cteMove_corres: apply fastforce apply fastforce apply fastforce + apply (drule (1) pspace_relationsD) apply (drule_tac p=ptr' in set_cap_not_quite_corres, assumption+) apply fastforce apply fastforce @@ -858,7 +853,7 @@ lemma cteMove_corres: set_original_def bind_assoc modify_def |(rule bind_execI[where f="cap_move_ext x y z x'" for x y z x'], clarsimp simp: mdb_move_abs'.cap_move_ext_det_def2 update_cdt_list_def set_cdt_list_def put_def) | rule refl )+ apply (clarsimp simp: put_def) - apply (clarsimp simp: invs'_def) + apply (clarsimp simp: invs'_def valid_state'_def) apply (frule updateCap_dynamic_duo, fastforce, fastforce) apply (frule(2) updateCap_dynamic_duo [OF _ conjunct1 conjunct2]) apply (subgoal_tac "no_0 (ctes_of b)") @@ -867,7 +862,7 @@ lemma cteMove_corres: apply (frule(1) use_valid [OF _ updateCap_no_0]) apply (frule(2) use_valid [OF _ updateCap_no_0, OF _ use_valid [OF _ updateCap_no_0]]) apply (elim conjE) - apply (drule (4) updateMDB_the_lot', elim conjE) + apply (drule (5) updateMDB_the_lot', elim conjE) apply (drule (4) updateMDB_the_lot, elim conjE) apply (drule (4) updateMDB_the_lot, elim conjE) apply (drule (4) updateMDB_the_lot, elim conjE) @@ -897,6 +892,7 @@ lemma cteMove_corres: apply fastforce apply fastforce apply fastforce + apply (clarsimp simp: pspace_relations_def) apply (rule conjI) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) apply (thin_tac "gsCNodes t = p" for t p)+ @@ -923,6 +919,7 @@ lemma cteMove_corres: apply (thin_tac "ksDomainTime t = p" for t p)+ apply (thin_tac "ksDomSchedule t = p" for t p)+ apply (thin_tac "ctes_of t = p" for t p)+ + apply (thin_tac "ekheap_relation t p" for t p)+ apply (thin_tac "pspace_relation t p" for t p)+ apply (thin_tac "interrupt_state_relation s t p" for s t p)+ apply (thin_tac "ghost_relation s t p" for s t p)+ @@ -945,12 +942,14 @@ lemma cteMove_corres: subgoal by (clarsimp simp: cte_wp_at_caps_of_state null_filter_def split: if_split_asm) apply simp apply clarsimp - apply (prop_tac "null_filter (caps_of_state a) (aa,bb) \ None") + apply (subgoal_tac "null_filter (caps_of_state a) (aa,bb) \ None") + prefer 2 subgoal by (clarsimp simp only: null_filter_def cap.simps option.simps fun_upd_def simp_thms split: if_splits) apply clarsimp - apply (prop_tac "cte_at (aa,bb) a") + apply (subgoal_tac "cte_at (aa,bb) a") + prefer 2 apply (drule null_filter_caps_of_stateD) apply (erule cte_wp_cte_at) apply (frule_tac p="(aa,bb)" and p'="ptr'" in cte_map_inj, assumption+) @@ -965,7 +964,8 @@ lemma cteMove_corres: apply fastforce apply clarsimp subgoal by (simp add: null_filter_def split: if_splits) - apply (prop_tac "mdb_move (ctes_of b) (cte_map ptr) src_cap src_node (cte_map ptr') cap' old_dest_node") + apply (subgoal_tac "mdb_move (ctes_of b) (cte_map ptr) src_cap src_node (cte_map ptr') cap' old_dest_node") + prefer 2 apply (rule mdb_move.intro) apply (rule mdb_ptr.intro) apply (rule vmdb.intro) @@ -973,8 +973,8 @@ lemma cteMove_corres: apply (erule mdb_ptr_axioms.intro) apply (rule mdb_move_axioms.intro) apply assumption - apply (simp (no_asm_simp) add: nullPointer_def) - apply (simp (no_asm_simp) add: nullPointer_def) + apply (simp add: nullPointer_def) + apply (simp add: nullPointer_def) apply (erule weak_derived_sym') apply clarsimp apply assumption @@ -986,19 +986,22 @@ lemma cteMove_corres: apply (rule mdb_move_abs.intro) apply fastforce apply (fastforce elim!: cte_wp_at_weakenE) - apply (simp (no_asm_simp)) - apply (simp (no_asm_simp)) + apply simp + apply simp apply (case_tac "(aa,bb) = ptr", simp) - apply (prop_tac "cte_map (aa,bb) \ cte_map ptr") + apply (subgoal_tac "cte_map (aa,bb) \ cte_map ptr") + prefer 2 apply (erule (2) cte_map_inj, fastforce, fastforce, fastforce) apply (case_tac "(aa,bb) = ptr'") apply (simp add: cdt_relation_def del: split_paired_All) - apply (prop_tac "cte_map (aa,bb) \ cte_map ptr'") + apply (subgoal_tac "cte_map (aa,bb) \ cte_map ptr'") + prefer 2 apply (erule (2) cte_map_inj, fastforce, fastforce, fastforce) apply (simp only: if_False) apply simp - apply (prop_tac "descendants_of' (cte_map (aa, bb)) (ctes_of b) = + apply (subgoal_tac "descendants_of' (cte_map (aa, bb)) (ctes_of b) = cte_map ` descendants_of (aa, bb) (cdt a)") + prefer 2 subgoal by (simp add: cdt_relation_def del: split_paired_All) apply simp apply (rule conjI) @@ -1060,8 +1063,6 @@ lemma cteMove_corres: apply(erule_tac x=aa in allE, erule_tac x=bb in allE) by(clarsimp simp: cte_map_inj_eq valid_pspace_def split: if_split_asm) -end - lemmas cur_tcb_lift = hoare_lift_Pf [where f = ksCurThread and P = tcb_at', folded cur_tcb'_def] @@ -1111,19 +1112,12 @@ crunch cteInsert and norq[wp]: "\s. P (ksReadyQueues s)" and norqL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" and norqL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" - and norlq[wp]: "\s. P (ksReleaseQueue 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)" (wp: updateObject_cte_inv crunch_wps ignore_del: setObject) -global_interpretation updateMDB: typ_at_all_props' "updateMDB slot f" - by typ_at_props' - -global_interpretation updateCap: typ_at_all_props' "updateCap slot newCap" - by typ_at_props' - -global_interpretation cteInsert: typ_at_all_props' "cteInsert newCap srcSlot destSlot" - by typ_at_props' +lemmas updateMDB_typ_ats [wp] = typ_at_lifts [OF updateMDB_typ_at'] +lemmas updateCap_typ_ats [wp] = typ_at_lifts [OF updateCap_typ_at'] +lemmas cteInsert_typ_ats [wp] = typ_at_lifts [OF cteInsert_typ_at'] lemma setObject_cte_ct: "\\s. P (ksCurThread s)\ setObject t (v::cte) \\rv s. P (ksCurThread s)\" @@ -1132,10 +1126,10 @@ lemma setObject_cte_ct: crunch cteInsert for ct[wp]: "\s. P (ksCurThread s)" (wp: setObject_cte_ct hoare_drop_imps) - +end context mdb_insert begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma n_src_dest: "n \ src \ dest" by (simp add: n_direct_eq) @@ -1655,7 +1649,7 @@ lemma untyped_inc_prev_update: lemma is_derived_badge_derived': "is_derived' m src cap cap' \ badge_derived' cap cap'" by (simp add: is_derived'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_mdb_chain_0: "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and (\s. cte_wp_at' (is_derived' (ctes_of s) src cap \ cteCap) src s)\ @@ -2174,7 +2168,7 @@ lemma cteInsert_mdb' [wp]: setUntypedCapAsFull_valid_dlist setUntypedCapAsFull_distinct_zombies setUntypedCapAsFull_valid_badges setUntypedCapAsFull_caps_contained setUntypedCapAsFull_valid_nullcaps setUntypedCapAsFull_ut_revocable - setUntypedCapAsFull_class_links + setUntypedCapAsFull_class_links setUntypedCapAsFull_reply_masters_rvk_fb mdb_inv_preserve_fun_upd mdb_inv_preserve_modify_map getCTE_wp| simp del:fun_upd_apply)+ apply (clarsimp simp:cte_wp_at_ctes_of simp del:fun_upd_apply) @@ -2221,6 +2215,7 @@ proof - and class_links: "class_links ?m" and distinct_zombies: "distinct_zombies ?m" and irq: "irq_control ?m" + and reply_masters_rvk_fb: "reply_masters_rvk_fb ?m" and vn: "valid_nullcaps ?m" and ut_rev:"ut_revocable' ?m" @@ -2284,36 +2279,37 @@ proof - w2ned[symmetric] srcdest srcdest[symmetric] have mdb_next_disj: - "\p p'. (?C \ p \ p' \ + "\p p'. (?C \ p \ p' \ ?m \ p \ p' \ p \ src \ p'\ dest \ (p' = word1 \ p' = 0) \ p = src \ p' = dest \ p = dest \ p' = word1)" - apply (case_tac "p = src") - apply (clarsimp simp:mdb_next_unfold modify_map_cases) - apply (case_tac "p = dest") - apply (clarsimp simp:mdb_next_unfold modify_map_cases)+ - using cofs cofd vd no0 - apply (case_tac "p = word1") - apply clarsimp - apply (intro conjI) - apply clarsimp - apply (frule_tac p = "word1" and m = "?m" in valid_dlist_nextD) - apply clarsimp+ - apply (frule_tac p = "mdbNext node" and m = "?m" in valid_dlist_nextD) - apply clarsimp+ - apply (frule_tac p = "mdbNext node" in no_loops_no_l2_loop[OF _ no_loop]) - apply simp+ + apply (case_tac "p = src") + apply (clarsimp simp:mdb_next_unfold modify_map_cases) + apply (case_tac "p = dest") + apply (clarsimp simp:mdb_next_unfold modify_map_cases)+ + using cofs cofd vd no0 + apply - + apply (case_tac "p = word1") + apply clarsimp apply (intro conjI) apply clarsimp - apply (frule_tac p = p and m = "?m" in valid_dlist_nextD) - apply (clarsimp+)[3] - apply (intro impI) - apply (rule ccontr) - apply clarsimp - apply (frule_tac p = src and m = "?m" in valid_dlist_nextD) + apply (frule_tac p = "word1" and m = "?m" in valid_dlist_nextD) apply clarsimp+ - apply (frule_tac p = p and m = "?m" in valid_dlist_nextD) + apply (frule_tac p = "mdbNext node" and m = "?m" in valid_dlist_nextD) apply clarsimp+ - done + apply (frule_tac p = "mdbNext node" in no_loops_no_l2_loop[OF _ no_loop]) + apply simp+ + apply (intro conjI) + apply clarsimp + apply (frule_tac p = p and m = "?m" in valid_dlist_nextD) + apply (clarsimp+)[3] + apply (intro impI) + apply (rule ccontr) + apply clarsimp + apply (frule_tac p = src and m = "?m" in valid_dlist_nextD) + apply clarsimp+ + apply (frule_tac p = p and m = "?m" in valid_dlist_nextD) + apply clarsimp+ + done have ctes_ofD: "\p cte. \?C p = Some cte; p\ dest; p\ src\ \ \cteb. (?m p = Some cteb \ cteCap cte = cteCap cteb)" @@ -2321,160 +2317,179 @@ proof - show "valid_badges ?C" - using srcdest badge cofs badges cofd - unfolding valid_badges_def - apply (intro impI allI) - apply (drule mdb_next_disj) - apply (elim disjE) - defer - apply (clarsimp simp:modify_map_cases dest0 src0) - apply (clarsimp simp:revokable'_def badge_derived'_def) - subgoal by (case_tac src_cap,auto simp:isCap_simps sameRegionAs_def) - apply (clarsimp simp:modify_map_cases valid_badges_def) - apply (frule_tac x=src in spec, erule_tac x=word1 in allE, erule allE, erule impE) - apply fastforce - apply simp - apply (clarsimp simp:mdb_next_unfold badge_derived'_def split: if_split_asm) - apply (thin_tac "All P" for P) - subgoal by (cases src_cap, - auto simp:mdb_next_unfold isCap_simps sameRegionAs_def Let_def split: if_splits) - apply (case_tac "word1 = p'") + using srcdest badge cofs badges cofd + unfolding valid_badges_def + apply (intro impI allI) + apply (drule mdb_next_disj) + apply (elim disjE) + defer + apply (clarsimp simp:modify_map_cases dest0 src0) + apply (clarsimp simp:revokable'_def badge_derived'_def) + subgoal by (case_tac src_cap,auto simp:isCap_simps sameRegionAs_def) + apply (clarsimp simp:modify_map_cases valid_badges_def) + apply (frule_tac x=src in spec, erule_tac x=word1 in allE, erule allE, erule impE) + apply fastforce + apply simp + apply (clarsimp simp:mdb_next_unfold badge_derived'_def split: if_split_asm) + apply (thin_tac "All P" for P) + subgoal by (cases src_cap, + auto simp:mdb_next_unfold isCap_simps sameRegionAs_def Let_def split: if_splits) + apply (case_tac "word1 = p'") apply (clarsimp simp:modify_map_cases valid_badges_def mdb_next_unfold src0 dest0 no0)+ - apply (case_tac "p = dest") - apply (clarsimp simp:dest0 src0 no0)+ - apply (case_tac z) - apply (rename_tac capability mdbnode) - apply clarsimp - apply (drule_tac x = p in spec,drule_tac x = "mdbNext mdbnode" in spec) - by (auto simp:isCap_simps sameRegionAs_def) + apply (case_tac "p = dest") + apply (clarsimp simp:dest0 src0 no0)+ + apply (case_tac z) + apply (rename_tac capability mdbnode) + apply clarsimp + apply (drule_tac x = p in spec,drule_tac x = "mdbNext mdbnode" in spec) + by (auto simp:isCap_simps sameRegionAs_def) from badge have isUntyped_eq: "isUntypedCap cap = isUntypedCap src_cap" - apply (clarsimp simp:badge_derived'_def) - apply (case_tac cap,auto simp:isCap_simps) - done + apply (clarsimp simp:badge_derived'_def) + apply (case_tac cap,auto simp:isCap_simps) + done from badge have [simp]: "capRange cap = capRange src_cap" - apply (clarsimp simp:badge_derived'_def) - apply (case_tac cap; clarsimp simp:isCap_simps capRange_def) + apply (clarsimp simp:badge_derived'_def) + apply (case_tac cap) + apply (clarsimp simp:isCap_simps capRange_def)+ + (* 5 subgoals *) apply (rename_tac arch_capability) - apply (case_tac arch_capability; clarsimp simp:isCap_simps capRange_def) - done + apply (case_tac arch_capability) + (* 9 subgoals *) + apply (clarsimp simp:isCap_simps capRange_def)+ + done have [simp]: "untypedRange cap = untypedRange src_cap" - using badge - apply (clarsimp simp:badge_derived'_def dest!:capMaster_untypedRange) - done + using badge + apply (clarsimp simp:badge_derived'_def dest!:capMaster_untypedRange) + done from contained badge srcdest cofs cofd is_der no0 show "caps_contained' ?C" - apply (clarsimp simp add: caps_contained'_def) - apply (case_tac "p = dest") - apply (case_tac "p' = dest") - apply (clarsimp simp:modify_map_def split:if_splits) - apply (case_tac src_cap,auto)[1] - apply (case_tac "p' = src") - apply (clarsimp simp:modify_map_def split:if_splits) - apply (clarsimp simp:badge_derived'_def) - apply (case_tac src_cap,auto)[1] - apply (drule(2) ctes_ofD) - apply (clarsimp simp:modify_map_def split:if_splits) - apply (frule capRange_untyped) - apply (erule_tac x=src in allE, erule_tac x=p' in allE, simp) - apply (case_tac cteb) - apply (clarsimp) - apply blast - apply (case_tac "p' = dest") - apply (case_tac "p = src") - apply (clarsimp simp:modify_map_def split:if_splits) - apply (drule capRange_untyped) - subgoal by (case_tac cap,auto simp:isCap_simps badge_derived'_def) + apply (clarsimp simp add: caps_contained'_def) + apply (case_tac "p = dest") + apply (case_tac "p' = dest") + apply (clarsimp simp:modify_map_def split:if_splits) + apply (case_tac src_cap,auto)[1] + apply (case_tac "p' = src") + apply (clarsimp simp:modify_map_def split:if_splits) + apply (clarsimp simp:badge_derived'_def) + apply (case_tac src_cap,auto)[1] + apply (drule(2) ctes_ofD) + apply (clarsimp simp:modify_map_def split:if_splits) + apply (frule capRange_untyped) + apply (erule_tac x=src in allE, erule_tac x=p' in allE, simp) + apply (case_tac cteb) + apply (clarsimp) + apply blast + apply (case_tac "p' = dest") + apply (case_tac "p = src") apply (clarsimp simp:modify_map_def split:if_splits) - apply (drule_tac x = word1 in spec) - apply (drule_tac x = src in spec) - apply (case_tac z) - apply (clarsimp simp:isUntyped_eq) - apply blast - apply (drule_tac x = p in spec) - apply (drule_tac x = src in spec) - apply (frule capRange_untyped) - apply (clarsimp simp:isUntyped_eq) - apply blast - apply (drule_tac x = p in spec) - apply (drule_tac x = p' in spec) + apply (drule capRange_untyped) + subgoal by (case_tac cap,auto simp:isCap_simps badge_derived'_def) apply (clarsimp simp:modify_map_def split:if_splits) - apply ((case_tac z,fastforce)+)[5] - by fastforce+ - - show "valid_nullcaps ?C" - using is_der vn cofs vd no0 - apply (simp add: valid_nullcaps_def) - apply (clarsimp simp:modify_map_def is_derived'_def) - apply (rule conjI) - apply (clarsimp simp: is_derived'_def badge_derived'_def)+ apply (drule_tac x = word1 in spec) + apply (drule_tac x = src in spec) apply (case_tac z) - apply (clarsimp simp:nullMDBNode_def) - apply (drule(1) valid_dlist_nextD) - apply simp - apply clarsimp - apply (simp add:nullPointer_def src0) - done + apply (clarsimp simp:isUntyped_eq) + apply blast + apply (drule_tac x = p in spec) + apply (drule_tac x = src in spec) + apply (frule capRange_untyped) + apply (clarsimp simp:isUntyped_eq) + apply blast + apply (drule_tac x = p in spec) + apply (drule_tac x = p' in spec) + apply (clarsimp simp:modify_map_def split:if_splits) + apply ((case_tac z,fastforce)+)[5] + by fastforce+ + + show "valid_nullcaps ?C" + using is_der vn cofs vd no0 + apply (simp add: valid_nullcaps_def srcdest [symmetric]) + apply (clarsimp simp:modify_map_def is_derived'_def) + apply (rule conjI) + apply (clarsimp simp: is_derived'_def badge_derived'_def)+ + apply (drule_tac x = word1 in spec) + apply (case_tac z) + apply (clarsimp simp:nullMDBNode_def) + apply (drule(1) valid_dlist_nextD) + apply simp + apply clarsimp + apply (simp add:nullPointer_def src0) + done from vmdb srcdest cofs ut_rev show "ut_revocable' ?C" - apply (clarsimp simp: valid_mdb_ctes_def ut_revocable'_def modify_map_def) - apply (rule conjI) - apply clarsimp - apply (clarsimp simp: revokable'_def isCap_simps)+ - apply auto - apply (drule_tac x= src in spec) - apply clarsimp - apply (case_tac z) - apply clarsimp - done + apply (clarsimp simp: valid_mdb_ctes_def ut_revocable'_def modify_map_def) + apply (rule conjI) + apply clarsimp + apply (clarsimp simp: revokable'_def isCap_simps)+ + apply auto + apply (drule_tac x= src in spec) + apply clarsimp + apply (case_tac z) + apply clarsimp + done from class_links srcdest badge cofs cofd no0 vd show "class_links ?C" - unfolding class_links_def - apply (intro allI impI) - apply (drule mdb_next_disj) - apply (elim disjE) - apply (clarsimp simp:modify_map_def mdb_next_unfold split:if_split_asm) - apply (clarsimp simp: badge_derived'_def modify_map_def - split: if_split_asm) - apply (erule capMaster_capClass) - apply (clarsimp simp:modify_map_def split:if_splits) - apply (drule_tac x = src in spec) - apply (drule_tac x = word1 in spec) - apply (clarsimp simp:mdb_next_unfold) - apply (case_tac z) - apply (clarsimp simp:badge_derived'_def) - apply (drule capMaster_capClass) - apply simp - done + unfolding class_links_def + apply (intro allI impI) + apply (drule mdb_next_disj) + apply (elim disjE) + apply (clarsimp simp:modify_map_def mdb_next_unfold split:if_split_asm) + apply (clarsimp simp: badge_derived'_def modify_map_def + split: if_split_asm) + apply (erule capMaster_capClass) + apply (clarsimp simp:modify_map_def split:if_splits) + apply (drule_tac x = src in spec) + apply (drule_tac x = word1 in spec) + apply (clarsimp simp:mdb_next_unfold) + apply (case_tac z) + apply (clarsimp simp:badge_derived'_def) + apply (drule capMaster_capClass) + apply simp + done - from distinct_zombies badge - show "distinct_zombies ?C" - apply (simp add:distinct_zombies_nonCTE_modify_map) - apply (erule_tac distinct_zombies_copyMasterE[where x=src]) - apply (rule cofs) - apply (simp add: masters) - apply (simp add: notZomb1 notZomb2) - done + from distinct_zombies badge + show "distinct_zombies ?C" + apply (simp add:distinct_zombies_nonCTE_modify_map) + apply (erule_tac distinct_zombies_copyMasterE[where x=src]) + apply (rule cofs) + apply (simp add: masters) + apply (simp add: notZomb1 notZomb2) + done + + from reply_masters_rvk_fb is_der + show "reply_masters_rvk_fb ?C" + apply (clarsimp simp:reply_masters_rvk_fb_def) + apply (erule ranE) + apply (clarsimp simp:modify_map_def split:if_split_asm) + apply fastforce+ + apply (clarsimp simp:is_derived'_def isCap_simps) + apply fastforce + done qed crunch cteInsert for state_refs_of'[wp]: "\s. P (state_refs_of' s)" - and aligned'[wp]: pspace_aligned' - and distinct'[wp]: pspace_distinct' - and 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 pred_tcb_at'[wp]: "pred_tcb_at' proj P p" - and valid_replies' [wp]: valid_replies' - (wp: crunch_wps valid_replies'_lift) + (wp: crunch_wps) + +crunch cteInsert + for aligned'[wp]: pspace_aligned' + (wp: crunch_wps) + +crunch cteInsert + for distinct'[wp]: pspace_distinct' + (wp: crunch_wps) + +crunch cteInsert + for no_0_obj'[wp]: no_0_obj' + (wp: crunch_wps) lemma cteInsert_valid_pspace: "\valid_pspace' and valid_cap' cap and (\s. src \ dest) and valid_objs' and @@ -2748,15 +2763,6 @@ lemma setCTE_it'[wp]: apply (wp|wpc|simp del: hoare_fail_any)+ done -lemma setCTE_idldSC[wp]: - "setCTE c p \\s. P (ksIdleSC s)\" - apply (simp add: setCTE_def setObject_def split_def updateObject_cte) - apply (wp|wpc|simp del: hoare_fail_any)+ - done - -crunch setCTE - for idle_sc_at'[wp]: "\s. idle_sc_at' p s" - lemma setCTE_idle [wp]: "\valid_idle'\ setCTE p cte \\rv. valid_idle'\" apply (simp add: valid_idle'_def) @@ -2774,7 +2780,7 @@ lemma updateMDB_idle'[wp]: "\valid_idle'\ updateMDB p m \\rv. valid_idle'\" apply (clarsimp simp add: updateMDB_def) apply (rule hoare_pre) - apply (wp | simp add: valid_idle'_def)+ + apply (wp | simp add: valid_idle'_def)+ by fastforce lemma updateCap_idle': @@ -2879,6 +2885,11 @@ done lemma setCTE_valid_mappings'[wp]: "\valid_pde_mappings'\ setCTE x y \\rv. valid_pde_mappings'\" apply (wp valid_pde_mappings_lift' setCTE_typ_at') + apply (simp add: setCTE_def) + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_cte typeError_def in_monad + split: Structures_H.kernel_object.split_asm if_split_asm) + apply assumption done crunch cteInsert @@ -2910,8 +2921,20 @@ lemma setCTE_cteCaps_of[wp]: "\\s. P ((cteCaps_of s)(p \ cteCap cte))\ setCTE p cte \\rv s. P (cteCaps_of s)\" - unfolding cteCaps_of_def - by wp (force elim!: rsubst[where P=P]) + apply (simp add: cteCaps_of_def) + apply wp + apply (clarsimp elim!: rsubst[where P=P] intro!: ext) + done + +crunch setupReplyMaster + for inQ[wp]: "\s. P (obj_at' (inQ d p) t s)" + and norq[wp]: "\s. P (ksReadyQueues s)" + and ct[wp]: "\s. P (ksCurThread s)" + and state_refs_of'[wp]: "\s. P (state_refs_of' s)" + and it[wp]: "\s. P (ksIdleThread s)" + and nosch[wp]: "\s. P (ksSchedulerAction s)" + and irq_node'[wp]: "\s. P (irq_node' s)" + (wp: crunch_wps) lemmas setCTE_cteCap_wp_irq[wp] = hoare_use_eq_irq_node' [OF setCTE_ksInterruptState setCTE_cteCaps_of] @@ -2925,15 +2948,16 @@ lemma setUntypedCapAsFull_valid_refs'[wp]: "\\s. valid_refs' R (ctes_of s) \ cte_wp_at' ((=) srcCTE) src s\ setUntypedCapAsFull (cteCap srcCTE) cap src \\yb s. valid_refs' R (ctes_of s)\" - apply (clarsimp simp: valid_refs'_def setUntypedCapAsFull_def split del:if_split) + apply (clarsimp simp:valid_refs'_def setUntypedCapAsFull_def split del:if_splits) apply (rule hoare_pre) - apply (wp updateCap_ctes_of_wp) + apply (wp updateCap_ctes_of_wp) apply (clarsimp simp:ran_dom) apply (drule_tac x = y in bspec) - apply (drule_tac a = y in domI) - apply (simp add:modify_map_dom) - apply (clarsimp simp:modify_map_def cte_wp_at_ctes_of isCap_simps split:if_splits) - done + apply (drule_tac a = y in domI) + apply (simp add:modify_map_dom) + apply (clarsimp simp:modify_map_def cte_wp_at_ctes_of + isCap_simps split:if_splits) +done crunch setUntypedCapAsFull for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" @@ -2942,14 +2966,15 @@ lemma setUntypedCapAsFull_sizes[wp]: "\\s. valid_cap_sizes' sz (ctes_of s) \ cte_wp_at' ((=) srcCTE) src s\ setUntypedCapAsFull (cteCap srcCTE) cap src \\rv s. valid_cap_sizes' sz (ctes_of s)\" - apply (clarsimp simp: valid_cap_sizes'_def setUntypedCapAsFull_def split del: if_split) + apply (clarsimp simp:valid_cap_sizes'_def setUntypedCapAsFull_def split del:if_splits) apply (rule hoare_pre) - apply (wp updateCap_ctes_of_wp | wps)+ + apply (wp updateCap_ctes_of_wp | wps)+ apply (clarsimp simp:ran_dom) apply (drule_tac x = y in bspec) - apply (drule_tac a = y in domI) - apply (simp add:modify_map_dom) - apply (clarsimp simp:modify_map_def cte_wp_at_ctes_of isCap_simps split:if_splits) + apply (drule_tac a = y in domI) + apply (simp add:modify_map_dom) + apply (clarsimp simp:modify_map_def cte_wp_at_ctes_of + isCap_simps split:if_splits) done lemma setUntypedCapAsFull_valid_global_refs'[wp]: @@ -2958,9 +2983,9 @@ lemma setUntypedCapAsFull_valid_global_refs'[wp]: \\yb s. valid_global_refs' s\" apply (clarsimp simp: valid_global_refs'_def) apply (rule hoare_pre,wps) - apply wp + apply wp apply simp - done +done lemma capMaster_eq_capBits_eq: "capMasterCap cap = capMasterCap cap' \ capBits cap = capBits cap'" @@ -2986,6 +3011,14 @@ lemma cteInsert_valid_globals [wp]: apply simp done +crunch cteInsert + for arch[wp]: "\s. P (ksArchState s)" + (wp: crunch_wps simp: cte_wp_at_ctes_of) + +crunch cteInsert + for pde_mappings'[wp]: valid_pde_mappings' + (wp: crunch_wps) + lemma setCTE_ksMachine[wp]: "\\s. P (ksMachineState s)\ setCTE x y \\_ s. P (ksMachineState s)\" apply (clarsimp simp: setCTE_def) @@ -3017,8 +3050,8 @@ lemma setCTE_ct_not_inQ[wp]: 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 (wps setObject_cte_ct) + apply (rule setObject_cte_obj_at_tcb') apply (clarsimp simp add: obj_at'_def)+ done @@ -3052,8 +3085,7 @@ crunch cteInsert (wp: crunch_wps ) crunch cteInsert - for ksIdleThread[wp]: "\s. P (ksIdleThread s)" - and ksIdlSC[wp]: "\s. P (ksIdleSC s)" + for ksIdleThread[wp]: "\s. P (ksIdleThread s)" (wp: crunch_wps) crunch cteInsert @@ -3100,7 +3132,8 @@ crunch cteInsert (wp: setObject_ksPSpace_only updateObject_cte_inv crunch_wps) definition - "untyped_derived_eq cap cap' = (isUntypedCap cap \ cap = cap')" + "untyped_derived_eq cap cap' + = (isUntypedCap cap \ cap = cap')" lemma ran_split: "inj_on m (dom m) @@ -3235,17 +3268,12 @@ lemma cteInsert_untyped_ranges_zero[wp]: apply blast done -lemma updateCap_replies_of'[wp]: - "updateCap a b \\s. P (replies_of' s)\" - unfolding updateCap_def - by (wpsimp wp: setObject_cte_replies_of' simp: setCTE_def) - crunch cteInsert - for replies_of'[wp]: "\s. P (replies_of' s)" - and tcbInReleaseQueue[wp]: "\s. P (obj_at' tcbInReleaseQueue tcb s)" - (wp: crunch_wps setObject_cte_replies_of' simp: crunch_simps setCTE_def) - -lemmas fold_list_refs_of_replies' = comp_def[symmetric, where f=Some and g=list_refs_of_reply'] + for tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" + and tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (wp: crunch_wps rule: valid_bitmaps_lift) lemma cteInsert_invs: "\invs' and cte_wp_at' (\c. cteCap c=NullCap) dest and valid_cap' cap and @@ -3254,13 +3282,12 @@ lemma cteInsert_invs: and ex_cte_cap_to' dest and (\s. \irq. cap = IRQHandlerCap irq \ irq_issued' irq s)\ cteInsert cap src dest \\rv. invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) - apply (wpsimp wp: cur_tcb_lift tcb_in_cur_domain'_lift sch_act_wf_lift CSpace_R.valid_queues_lift - valid_irq_node_lift valid_queues_lift' valid_release_queue_lift - valid_release_queue'_lift irqs_masked_lift cteInsert_norq - simp: st_tcb_at'_def) - apply (subst fold_list_refs_of_replies') - by (auto simp: invs'_def valid_pspace'_def elim: valid_capAligned) + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) + apply (wpsimp wp: cur_tcb_lift tcb_in_cur_domain'_lift sch_act_wf_lift + valid_irq_node_lift irqs_masked_lift cteInsert_norq + sym_heap_sched_pointers_lift) + apply (auto simp: invs'_def valid_state'_def valid_pspace'_def elim: valid_capAligned) + done lemma deriveCap_corres: "\cap_relation c c'; cte = cte_map slot \ \ @@ -3331,7 +3358,7 @@ lemma lookupSlotForCNodeOp_inv'[wp]: lemma loadWordUser_inv [wp]: "\P\ loadWordUser p \\rv. P\" unfolding loadWordUser_def - by (wpsimp wp: dmo_inv' loadWord_inv) + by (wp dmo_inv' loadWord_inv) lemma capTransferFromWords_inv: "\P\ capTransferFromWords buffer \\_. P\" @@ -3492,7 +3519,7 @@ lemma deriveCap_untyped_derived: lemma setCTE_corres: "cap_relation cap (cteCap cte) \ - corres_underlying {(s, s'). pspace_relation (kheap s) (ksPSpace s')} False True dc + corres_underlying {(s, s'). pspace_relations (ekheap (s)) (kheap s) (ksPSpace s')} False True dc (pspace_distinct and pspace_aligned and valid_objs and cte_at p) (pspace_aligned' and pspace_distinct' and cte_at' (cte_map p)) (set_cap cap p) @@ -3537,10 +3564,8 @@ lemma ghost_relation_of_heap: done lemma corres_caps_decomposition: - assumes pspace_corres: - "corres_underlying {(s, s'). pspace_relation (kheap s) (ksPSpace s')} False True r P P' f g" - assumes updates: - "\P. \\s. P (new_caps s)\f \\rv s. P (caps_of_state s)\" + assumes x: "corres_underlying {(s, s'). pspace_relations (ekheap (s)) (kheap s) (ksPSpace s')} False True r P P' f g" + assumes u: "\P. \\s. P (new_caps s)\ f \\rv s. P (caps_of_state s)\" "\P. \\s. P (new_mdb s)\ f \\rv s. P (cdt s)\" "\P. \\s. P (new_list s)\ f \\rv s. P (cdt_list (s))\" "\P. \\s. P (new_rvk s)\ f \\rv s. P (is_original_cap s)\" @@ -3555,7 +3580,6 @@ lemma corres_caps_decomposition: "\P. \\s. P (new_as' s)\ g \\rv s. P (ksArchState s)\" "\P. \\s. P (new_id s)\ f \\rv s. P (idle_thread s)\" "\P. \\s. P (new_id' s)\ g \\rv s. P (ksIdleThread s)\" - "\P. \\s. P (new_idsc' s)\ g \\rv s. P (ksIdleSC s)\" "\P. \\s. P (new_irqn s)\ f \\rv s. P (interrupt_irq_node s)\" "\P. \\s. P (new_irqs s)\ f \\rv s. P (interrupt_states s)\" "\P. \\s. P (new_irqs' s)\ g \\rv s. P (ksInterruptState s)\" @@ -3566,65 +3590,50 @@ lemma corres_caps_decomposition: "\P. \\s. P (new_ready_queues s)\ f \\rv s. P (ready_queues s)\" "\P. \\s. P (new_action s)\ f \\rv s. P (scheduler_action s)\" "\P. \\s. P (new_sa' s)\ g \\rv s. P (ksSchedulerAction s)\" - "\P. \\s. P (new_rqs' s)\ g \\rv s. P (ksReadyQueues s)\" - "\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_release_queue s)\ f \\rv s. P (release_queue s)\" - "\P. \\s. P (new_sc_replies_of s)\ f \\rv s. P (sc_replies_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_ksReadyQueues s) (new_tcbSchedNexts_of s) (new_tcbSchedPrevs_of s) + (\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_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)\" "\P. \\s. P (new_dt s)\ f \\rv s. P (domain_time s)\" - "\P. \\s. P (new_cot s)\ f \\rv s. P (consumed_time s)\" - "\P. \\s. P (new_cut s)\ f \\rv s. P (cur_time s)\" - "\P. \\s. P (new_csc s)\ f \\rv s. P (cur_sc s)\" - "\P. \\s. P (new_rpt s)\ f \\rv s. P (reprogram_timer s)\" "\P. \\s. P (new_dsi' s)\ g \\rv s. P (ksDomScheduleIdx s)\" "\P. \\s. P (new_ds' s)\ g \\rv s. P (ksDomSchedule s)\" "\P. \\s. P (new_cd' s)\ g \\rv s. P (ksCurDomain s)\" "\P. \\s. P (new_dt' s)\ g \\rv s. P (ksDomainTime s)\" - "\P. \\s. P (new_cot' s)\ g \\rv s. P (ksConsumedTime s)\" - "\P. \\s. P (new_cut' s)\ g \\rv s. P (ksCurTime s)\" - "\P. \\s. P (new_csc' s)\ g \\rv s. P (ksCurSc s)\" - "\P. \\s. P (new_rpt' s)\ g \\rv s. P (ksReprogramTimer s)\" - assumes updated_relations: - "\s s'. \ P s; P' s'; (s, s') \ state_relation \ - \ cdt_relation ((\) None \ new_caps s) (new_mdb s) (new_ctes s') - \ 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) - \ release_queue_relation (new_release_queue s) (new_ksReleaseQueue s') - \ sched_act_relation (new_action s) (new_sa' s') - \ ready_queues_relation (new_queues s) (new_rqs' s') - \ revokable_relation (new_rvk s) (null_filter (new_caps s)) (new_ctes s') - \ interrupt_state_relation (new_irqn s) (new_irqs s) (new_irqs' s') - \ (new_as s, new_as' s') \ arch_state_relation - \ new_ct s = new_ct' s' - \ new_id s = new_id' s' - \ idle_sc_ptr = new_idsc' s' - \ new_ms s = new_ms' s' - \ new_di s = new_dsi' s' - \ new_dl s = new_ds' s' - \ new_cd s = new_cd' s' - \ new_dt s = new_dt' s' - \ new_cot s = new_cot' s' - \ new_cut s = new_cut' s' - \ new_csc s = new_csc' s' - \ new_rpt s = new_rpt' s' - \ new_wuc s = new_wuc' s' - \ new_ups s = new_ups' s' - \ new_cns s = new_cns' s'" + assumes z: "\s s'. \ P s; P' s'; (s, s') \ state_relation \ + \ cdt_relation ((\) None \ new_caps s) (new_mdb s) (new_ctes s')" + "\s s'. \ P s; P' s'; (s, s') \ state_relation \ + \ cdt_list_relation (new_list s) (new_mdb s) (new_ctes s')" + "\s s'. \ P s; P' s'; (s, s') \ state_relation \ + \ sched_act_relation (new_action s) (new_sa' s')" + "\s s'. \ P s; P' s'; (s, s') \ state_relation \ + \ 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')" + "\s s'. \ P s; P' s'; (s, s') \ state_relation \ + \ revokable_relation (new_rvk s) (null_filter (new_caps s)) (new_ctes s')" + "\s s'. \ P s; P' s'; (s, s') \ state_relation \ + \ (new_as s, new_as' s') \ arch_state_relation + \ interrupt_state_relation (new_irqn s) (new_irqs s) (new_irqs' s') + \ new_ct s = new_ct' s' \ new_id s = new_id' s' + \ new_ms s = new_ms' s' \ new_di s = new_dsi' s' + \ new_dl s = new_ds' s' \ new_cd s = new_cd' s' \ new_dt s = new_dt' s' \ new_wuc s = new_wuc' s'" + "\s s'. \ P s; P' s'; (s, s') \ state_relation \ + \ new_ups s = new_ups' s'" + "\s s'. \ P s; P' s'; (s, s') \ state_relation \ + \ new_cns s = new_cns' s'" shows "corres r P P' f g" proof - have all_ext: "\f f'. (\p. f p = f' p) = (f = f')" - by fastforce + by (fastforce intro!: ext) have mdb_wp': "\ctes. \\s. cdt_relation ((\) None \ new_caps s) (new_mdb s) ctes\ f \\rv s. \m ca. (\p. ca p = ((\) None \ caps_of_state s) p) \ m = cdt s \ cdt_relation ca m ctes\" - apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift updates) + apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift u) apply (subst all_ext) apply (simp add: o_def) done @@ -3634,7 +3643,7 @@ proof - f \\rv s. \m t. t = cdt_list s \ m = cdt s \ cdt_list_relation t m ctes\" - apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift updates) + apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift u) apply (simp add: o_def) done note list_wp = list_wp' [simplified all_ext simp_thms] @@ -3644,7 +3653,15 @@ proof - \\rv s. revokable_relation (is_original_cap s) (null_filter (caps_of_state s)) ctes\" unfolding revokable_relation_def apply (simp only: imp_conv_disj) - apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift hoare_vcg_disj_lift updates) + apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift hoare_vcg_disj_lift u) + done + have exs_wp': + "\ctes. \\s. revokable_relation (new_rvk s) (null_filter (new_caps s)) ctes\ + f + \\rv s. revokable_relation (is_original_cap s) (null_filter (caps_of_state s)) ctes\" + unfolding revokable_relation_def + apply (simp only: imp_conv_disj) + apply (wp hoare_vcg_ex_lift hoare_vcg_all_lift hoare_vcg_disj_lift u) done note rvk_wp = rvk_wp' [simplified all_ext simp_thms] have swp_cte_at: @@ -3653,18 +3670,18 @@ proof - have abs_irq_together': "\P. \\s. P (new_irqn s) (new_irqs s)\ f \\rv s. \irn. interrupt_irq_node s = irn \ P irn (interrupt_states s)\" - by (wp hoare_vcg_ex_lift updates, simp) + by (wp hoare_vcg_ex_lift u, simp) note abs_irq_together = abs_irq_together'[simplified] show ?thesis unfolding state_relation_def swp_cte_at - apply (rule corres_underlying_decomposition[OF pspace_corres]) + apply (subst conj_assoc[symmetric]) + apply (subst pspace_relations_def[symmetric]) + apply (rule corres_underlying_decomposition [OF x]) apply (simp add: ghost_relation_of_heap) - apply (wp hoare_vcg_conj_lift mdb_wp rvk_wp list_wp updates abs_irq_together) - apply (wpsimp wp: hoare_vcg_conj_lift updates simp: swp_cte_at) - apply (frule updated_relations) - apply fastforce - apply (fastforce simp: state_relation_def swp_cte_at) - apply (clarsimp simp: o_def) + apply (wp hoare_vcg_conj_lift mdb_wp rvk_wp list_wp u abs_irq_together)+ + apply (intro z[simplified o_def] conjI + | simp add: state_relation_def pspace_relations_def swp_cte_at + | (clarsimp, drule (1) z(6), simp add: state_relation_def))+ done qed @@ -3676,7 +3693,7 @@ lemma getCTE_symb_exec_r: done lemma updateMDB_symb_exec_r: - "corres_underlying {(s, s'). pspace_relation (kheap s) (ksPSpace s')} False nf' dc + "corres_underlying {(s, s'). pspace_relations (ekheap s) (kheap s) (ksPSpace s')} False nf' dc \ (pspace_aligned' and pspace_distinct' and (no_0 \ ctes_of) and (\s. p \ 0 \ cte_at' p s)) (return ()) (updateMDB p m)" using no_fail_updateMDB [of p m] @@ -3696,6 +3713,9 @@ lemma updateMDB_ctes_of_cases: apply (case_tac y, simp) done +crunch updateMDB + for ct[wp]: "\s. P (ksCurThread s)" + lemma setCTE_state_bits[wp]: "\\s. P (ksMachineState s)\ setCTE p v \\rv s. P (ksMachineState s)\" "\\s. Q (ksIdleThread s)\ setCTE p v \\rv s. Q (ksIdleThread s)\" @@ -3705,6 +3725,15 @@ lemma setCTE_state_bits[wp]: apply (wp updateObject_cte_inv | simp)+ done +crunch updateMDB + for ms'[wp]: "\s. P (ksMachineState s)" +crunch updateMDB + for idle'[wp]: "\s. P (ksIdleThread s)" +crunch updateMDB + for arch'[wp]: "\s. P (ksArchState s)" +crunch updateMDB + for int'[wp]: "\s. P (ksInterruptState s)" + lemma cte_map_eq_subst: "\ cte_at p s; cte_at p' s; valid_objs s; pspace_aligned s; pspace_distinct s \ \ (cte_map p = cte_map p') = (p = p')" @@ -3728,9 +3757,21 @@ lemma setCTE_gsCNodes[wp]: done lemma set_original_symb_exec_l': - "corres_underlying {(s, s'). f (kheap s) s'} False nf' dc P P' (set_original p b) (return x)" + "corres_underlying {(s, s'). f (ekheap s) (kheap s) s'} False nf' dc P P' (set_original p b) (return x)" by (simp add: corres_underlying_def return_def set_original_def in_monad Bex_def) +lemma setCTE_schedule_index[wp]: + "\\s. P (ksDomScheduleIdx s)\ setCTE p v \\rv s. P (ksDomScheduleIdx s)\" + apply (simp add: setCTE_def setObject_def split_def) + apply (wp updateObject_cte_inv crunch_wps | simp)+ + done + +lemma setCTE_schedule[wp]: + "\\s. P (ksDomSchedule s)\ setCTE p v \\rv s. P (ksDomSchedule s)\" + apply (simp add: setCTE_def setObject_def split_def) + apply (wp updateObject_cte_inv crunch_wps | simp)+ + done + lemma setCTE_domain_time[wp]: "\\s. P (ksDomainTime s)\ setCTE p v \\rv s. P (ksDomainTime s)\" apply (simp add: setCTE_def setObject_def split_def) @@ -3743,6 +3784,78 @@ lemma setCTE_work_units_completed[wp]: apply (wp updateObject_cte_inv crunch_wps | simp)+ done +lemma create_reply_master_corres: + "\ sl' = cte_map sl ; AllowGrant \ rights \ \ + corres dc + (cte_wp_at ((=) cap.NullCap) sl and valid_pspace and valid_mdb and valid_list) + (cte_wp_at' (\c. cteCap c = NullCap \ mdbPrev (cteMDBNode c) = 0) sl' + and valid_mdb' and valid_pspace') + (do + y \ set_original sl True; + set_cap (cap.ReplyCap thread True rights) sl + od) + (setCTE sl' (CTE (capability.ReplyCap thread True True) initMDBNode))" + apply clarsimp + apply (rule corres_caps_decomposition) + defer + apply (wp|simp add: o_def split del: if_splits)+ + apply (clarsimp simp: o_def cdt_relation_def cte_wp_at_ctes_of + split del: if_split cong: if_cong simp del: id_apply) + apply (case_tac cte, clarsimp) + apply (fold fun_upd_def) + apply (subst descendants_of_Null_update') + apply fastforce + apply fastforce + apply assumption + apply assumption + apply (simp add: nullPointer_def) + apply (subgoal_tac "cte_at (a, b) s") + prefer 2 + apply (drule not_sym, clarsimp simp: cte_wp_at_caps_of_state + split: if_split_asm) + apply (simp add: state_relation_def cdt_relation_def) + apply (clarsimp simp: o_def cdt_list_relation_def cte_wp_at_ctes_of + split del: if_split cong: if_cong simp del: id_apply) + apply (case_tac cte, clarsimp) + apply (clarsimp simp: state_relation_def cdt_list_relation_def) + apply (simp split: if_split_asm) + apply (erule_tac x=a in allE, erule_tac x=b in allE) + apply clarsimp + apply(case_tac "next_slot (a, b) (cdt_list s) (cdt s)") + apply(simp) + apply(simp) + apply(fastforce simp: valid_mdb'_def valid_mdb_ctes_def valid_nullcaps_def) + apply (clarsimp simp: state_relation_def) + apply (clarsimp simp: state_relation_def) + apply (clarsimp simp add: revokable_relation_def cte_wp_at_ctes_of + split del: if_split) + apply simp + apply (rule conjI) + apply (clarsimp simp: initMDBNode_def) + apply clarsimp + apply (subgoal_tac "null_filter (caps_of_state s) (a, b) \ None") + prefer 2 + apply (clarsimp simp: null_filter_def cte_wp_at_caps_of_state + split: if_split_asm) + apply (subgoal_tac "cte_at (a,b) s") + prefer 2 + apply clarsimp + apply (drule null_filter_caps_of_stateD) + apply (erule cte_wp_cte_at) + apply (clarsimp split: if_split_asm cong: conj_cong + simp: cte_map_eq_subst revokable_relation_simp + cte_wp_at_cte_at valid_pspace_def) + apply (clarsimp simp: state_relation_def) + apply (clarsimp elim!: state_relationE simp: ghost_relation_of_heap)+ + apply (rule corres_guard_imp) + apply (rule corres_underlying_symb_exec_l [OF set_original_symb_exec_l']) + apply (rule setCTE_corres) + apply simp + apply wp + apply (clarsimp simp: cte_wp_at_cte_at valid_pspace_def) + apply (clarsimp simp: valid_pspace'_def cte_wp_at'_def) + done + lemma cte_map_nat_to_cref: "\ n < 2 ^ b; b < word_bits \ \ cte_map (p, nat_to_cref b n) = p + (of_nat n * 2^cte_level_bits)" @@ -3785,16 +3898,222 @@ lemma valid_nullcaps_next: apply clarsimp done +defs noReplyCapsFor_def: + "noReplyCapsFor \ \t s. \sl m r. \ cte_wp_at' (\cte. cteCap cte = ReplyCap t m r) sl s" + +lemma pspace_relation_no_reply_caps: + assumes pspace: "pspace_relation (kheap s) (ksPSpace s')" + and invs: "invs s" + and tcb: "tcb_at t s" + and m_cte': "cte_wp_at' ((=) cte) sl' s'" + and m_null: "cteCap cte = capability.NullCap" + and m_sl: "sl' = cte_map (t, tcb_cnode_index 2)" + shows "noReplyCapsFor t s'" +proof - + from tcb have m_cte: "cte_at (t, tcb_cnode_index 2) s" + by (clarsimp elim!: tcb_at_cte_at) + have m_cte_null: + "cte_wp_at (\c. c = cap.NullCap) (t, tcb_cnode_index 2) s" + using pspace invs + apply (frule_tac pspace_relation_cte_wp_atI') + apply (rule assms) + apply clarsimp + apply (clarsimp simp: m_sl) + apply (frule cte_map_inj_eq) + apply (rule m_cte) + apply (erule cte_wp_cte_at) + apply clarsimp+ + apply (clarsimp elim!: cte_wp_at_weakenE simp: m_null) + done + have no_reply_caps: + "\sl m r. \ cte_wp_at (\c. c = cap.ReplyCap t m r) sl s" + by (rule no_reply_caps_for_thread [OF invs tcb m_cte_null]) + hence noReplyCaps: + "\sl m r. \ cte_wp_at' (\cte. cteCap cte = ReplyCap t m r) sl s'" + apply (intro allI) + apply (clarsimp simp: cte_wp_at_neg2 cte_wp_at_ctes_of simp del: split_paired_All) + apply (frule pspace_relation_cte_wp_atI [OF pspace _ invs_valid_objs [OF invs]]) + apply (clarsimp simp: cte_wp_at_neg2 simp del: split_paired_All) + apply (drule_tac x="(a, b)" in spec) + apply (clarsimp simp: cte_wp_cte_at cte_wp_at_caps_of_state) + apply (case_tac c, simp_all) + apply fastforce + done + thus ?thesis + by (simp add: noReplyCapsFor_def) +qed + +lemma setupReplyMaster_corres: + "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) + (setup_reply_master t) (setupReplyMaster t)" + apply (simp add: setupReplyMaster_def setup_reply_master_def) + apply (simp add: locateSlot_conv tcbReplySlot_def objBits_def objBitsKO_def) + apply (simp add: nullMDBNode_def, fold initMDBNode_def) + apply (rule_tac F="t + 2*2^cte_level_bits = cte_map (t, tcb_cnode_index 2)" in corres_req) + apply (clarsimp simp: tcb_cnode_index_def2 cte_map_nat_to_cref word_bits_def cte_level_bits_def) + apply (clarsimp simp: cte_level_bits_def) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF get_cap_corres]) + apply (rule corres_when) + apply fastforce + apply (rule_tac P'="einvs and tcb_at t" in corres_stateAssert_implied) + apply (rule create_reply_master_corres; simp) + apply (subgoal_tac "\cte. cte_wp_at' ((=) cte) (cte_map (t, tcb_cnode_index 2)) s' + \ cteCap cte = capability.NullCap") + apply (fastforce dest: pspace_relation_no_reply_caps + state_relation_pspace_relation) + apply (clarsimp simp: cte_map_def tcb_cnode_index_def cte_wp_at_ctes_of) + apply (rule_tac Q'="\rv. einvs and tcb_at t and + cte_wp_at ((=) rv) (t, tcb_cnode_index 2)" + in hoare_strengthen_post) + apply (wp hoare_drop_imps get_cap_wp) + apply (clarsimp simp: invs_def valid_state_def elim!: cte_wp_at_weakenE) + apply (rule_tac Q'="\rv. valid_pspace' and valid_mdb' and + cte_wp_at' ((=) rv) (cte_map (t, tcb_cnode_index 2))" + in hoare_strengthen_post) + apply (wp hoare_drop_imps getCTE_wp') + apply (rename_tac rv s) + apply (clarsimp simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def) + apply (case_tac rv, fastforce elim: valid_nullcapsE) + apply (fastforce elim: tcb_at_cte_at) + apply (clarsimp simp: cte_at'_obj_at' tcb_cte_cases_def cte_map_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + done + +crunch setupReplyMaster + for tcb'[wp]: "tcb_at' t" + (wp: crunch_wps) + +crunch setupReplyMaster + for idle'[wp]: "valid_idle'" + (* Levity: added (20090126 19:32:14) *) declare stateAssert_wp[wp] +lemma setupReplyMaster_valid_mdb: + "slot = t + 2 ^ objBits (undefined :: cte) * tcbReplySlot \ + \valid_mdb' and valid_pspace' and tcb_at' t\ + setupReplyMaster t + \\rv. valid_mdb'\" + apply (clarsimp simp: setupReplyMaster_def locateSlot_conv + nullMDBNode_def) + apply (fold initMDBNode_def) + apply (wp setCTE_valid_mdb getCTE_wp') + apply clarsimp + apply (intro conjI) + apply (case_tac cte) + apply (fastforce simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def + no_mdb_def + elim: valid_nullcapsE) + apply (frule obj_at_aligned') + apply (simp add: valid_cap'_def capAligned_def + objBits_simps' word_bits_def)+ + apply (clarsimp simp: valid_pspace'_def) + apply (clarsimp simp: caps_no_overlap'_def capRange_def) + apply (clarsimp simp: fresh_virt_cap_class_def + elim!: ranE) + apply (clarsimp simp add: noReplyCapsFor_def cte_wp_at_ctes_of) + apply (case_tac x) + apply (rename_tac capability mdbnode) + apply (case_tac capability; simp) + apply (rename_tac arch_capability) + apply (case_tac arch_capability; simp) + apply fastforce + done + +lemma setupReplyMaster_valid_objs [wp]: + "\ valid_objs' and pspace_aligned' and pspace_distinct' and tcb_at' t\ + setupReplyMaster t + \\_. valid_objs'\" + apply (simp add: setupReplyMaster_def locateSlot_conv) + apply (wp setCTE_valid_objs getCTE_wp') + apply (clarsimp) + apply (frule obj_at_aligned') + apply (simp add: valid_cap'_def capAligned_def + objBits_simps' word_bits_def)+ + done + +lemma setupReplyMaster_wps[wp]: + "\pspace_aligned'\ setupReplyMaster t \\rv. pspace_aligned'\" + "\pspace_distinct'\ setupReplyMaster t \\rv. pspace_distinct'\" + "slot = cte_map (t, tcb_cnode_index 2) \ + \\s. P ((cteCaps_of s)(slot \ (capability.ReplyCap t True True))) \ P (cteCaps_of s)\ + setupReplyMaster t + \\rv s. P (cteCaps_of s)\" + apply (simp_all add: setupReplyMaster_def locateSlot_conv) + apply (wp getCTE_wp | simp add: o_def cte_wp_at_ctes_of)+ + apply clarsimp + apply (rule_tac x=cte in exI) + apply (clarsimp simp: tcbReplySlot_def objBits_simps' fun_upd_def word_bits_def + tcb_cnode_index_def2 cte_map_nat_to_cref cte_level_bits_def) + done + +crunch setupReplyMaster + for no_0_obj'[wp]: no_0_obj' + (wp: crunch_wps simp: crunch_simps) + +lemma setupReplyMaster_valid_pspace': + "\valid_pspace' and tcb_at' t\ + setupReplyMaster t + \\rv. valid_pspace'\" + apply (simp add: valid_pspace'_def) + apply (wp setupReplyMaster_valid_mdb) + apply (simp_all add: valid_pspace'_def) + done + +lemma setupReplyMaster_ifunsafe'[wp]: + "slot = t + 2 ^ objBits (undefined :: cte) * tcbReplySlot \ + \if_unsafe_then_cap' and ex_cte_cap_to' slot\ + setupReplyMaster t + \\rv s. if_unsafe_then_cap' s\" + apply (simp add: ifunsafe'_def3 setupReplyMaster_def locateSlot_conv) + apply (wp getCTE_wp') + apply (clarsimp simp: ex_cte_cap_to'_def cte_wp_at_ctes_of cteCaps_of_def + cte_level_bits_def objBits_simps') + apply (drule_tac x=crefa in spec) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=cref in exI, fastforce) + apply clarsimp + apply (rule_tac x=cref' in exI, fastforce) + done + + +lemma setupReplyMaster_iflive'[wp]: + "\if_live_then_nonz_cap'\ setupReplyMaster t \\rv. if_live_then_nonz_cap'\" + apply (simp add: setupReplyMaster_def locateSlot_conv) + apply (wp setCTE_iflive' getCTE_wp') + apply (clarsimp elim!: cte_wp_at_weakenE') + done + +lemma setupReplyMaster_global_refs[wp]: + "\\s. valid_global_refs' s \ thread \ global_refs' s \ tcb_at' thread s + \ ex_nonz_cap_to' thread s \ valid_objs' s\ + setupReplyMaster thread + \\rv. valid_global_refs'\" + apply (simp add: setupReplyMaster_def locateSlot_conv) + apply (wp getCTE_wp') + apply (clarsimp simp: capRange_def cte_wp_at_ctes_of objBits_simps) + apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) + apply (rename_tac "prev_cte") + apply (case_tac prev_cte, simp) + apply (frule(1) ctes_of_valid_cap') + apply (drule(1) valid_global_refsD_with_objSize)+ + apply (clarsimp simp: valid_cap'_def objBits_simps obj_at'_def projectKOs + split: capability.split_asm) + done + +crunch setupReplyMaster + for valid_arch'[wp]: "valid_arch_state'" + (wp: crunch_wps simp: crunch_simps) + lemma ex_nonz_tcb_cte_caps': "\ex_nonz_cap_to' t s; tcb_at' t s; valid_objs' s; sl \ dom tcb_cte_cases\ \ ex_cte_cap_to' (t + sl) s" apply (clarsimp simp: ex_nonz_cap_to'_def ex_cte_cap_to'_def cte_wp_at_ctes_of) apply (subgoal_tac "s \' cteCap cte") apply (rule_tac x=cref in exI, rule_tac x=cte in exI) - apply (clarsimp simp: valid_cap'_def obj_at'_def projectKOs dom_def ko_wp_at'_def + apply (clarsimp simp: valid_cap'_def obj_at'_def projectKOs dom_def split: cte.split_asm capability.split_asm) apply (case_tac cte) apply (clarsimp simp: ctes_of_valid_cap') @@ -3815,6 +4134,10 @@ lemma ex_nonz_cap_not_global': apply (clarsimp simp: ctes_of_valid_cap') done +crunch setupReplyMaster + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps simp: crunch_simps) + lemma setCTE_irq_handlers': "\\s. valid_irq_handlers' s \ (\irq. cteCap cte = IRQHandlerCap irq \ irq_issued' irq s)\ setCTE ptr cte @@ -3824,13 +4147,100 @@ lemma setCTE_irq_handlers': apply (auto simp: ran_def) done +lemma setupReplyMaster_irq_handlers'[wp]: + "\valid_irq_handlers'\ setupReplyMaster t \\rv. valid_irq_handlers'\" + apply (simp add: setupReplyMaster_def locateSlot_conv) + apply (wp setCTE_irq_handlers' getCTE_wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +crunch setupReplyMaster + for irq_states'[wp]: valid_irq_states' + and irqs_masked' [wp]: irqs_masked' + and pde_mappings' [wp]: valid_pde_mappings' + and pred_tcb_at' [wp]: "pred_tcb_at' proj P t" + and ksMachine[wp]: "\s. P (ksMachineState s)" + and pspace_domain_valid[wp]: "pspace_domain_valid" + and ct_not_inQ[wp]: "ct_not_inQ" + and ksCurDomain[wp]: "\s. P (ksCurDomain s)" + and ksCurThread[wp]: "\s. P (ksCurThread s)" + and ksIdlethread[wp]: "\s. P (ksIdleThread s)" + and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" + and scheduler_action[wp]: "\s. P (ksSchedulerAction s)" + and obj_at'_inQ[wp]: "obj_at' (inQ d p) t" + and tcbDomain_inv[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" + and tcbPriority_inv[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t" + and ready_queues[wp]: "\s. P (ksReadyQueues s)" + and ready_queuesL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + and ready_queuesL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + and tcbSchedPrevs_of[wp]: "\s. P (tcbSchedPrevs_of s)" + and tcbSchedNexts_of[wp]: "\s. P (tcbSchedNexts_of s)" + and valid_sched_pointers[wp]: valid_sched_pointers + (wp: crunch_wps simp: crunch_simps rule: irqs_masked_lift) + +lemma setupReplyMaster_vms'[wp]: + "\valid_machine_state'\ setupReplyMaster t \\_. valid_machine_state'\" + apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def ) + apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift) + apply wp+ + done + +lemma setupReplyMaster_urz[wp]: + "\untyped_ranges_zero' and valid_mdb' and valid_objs'\ + setupReplyMaster t + \\rv. untyped_ranges_zero'\" + apply (simp add: setupReplyMaster_def locateSlot_conv) + apply (rule hoare_pre) + apply (wp untyped_ranges_zero_lift getCTE_wp' | simp)+ + apply (clarsimp simp: cte_wp_at_ctes_of fun_upd_def[symmetric]) + apply (subst untyped_ranges_zero_fun_upd, assumption, simp_all) + apply (clarsimp simp: cteCaps_of_def untypedZeroRange_def Let_def isCap_simps) + done + +lemma setupReplyMaster_invs'[wp]: + "\invs' and tcb_at' t and ex_nonz_cap_to' t\ + setupReplyMaster t + \\rv. invs'\" + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp setupReplyMaster_valid_pspace' sch_act_wf_lift tcb_in_cur_domain'_lift ct_idle_or_in_cur_domain'_lift + valid_queues_lift cur_tcb_lift hoare_vcg_disj_lift sym_heap_sched_pointers_lift + valid_bitmaps_lift + valid_irq_node_lift | simp)+ + apply (clarsimp simp: ex_nonz_tcb_cte_caps' valid_pspace'_def + objBits_simps' tcbReplySlot_def + ex_nonz_cap_not_global' dom_def) + done + +lemma setupReplyMaster_cte_wp_at'': + "\cte_wp_at' (\cte. P (cteCap cte)) p and K (\ P NullCap)\ + setupReplyMaster t + \\rv s. cte_wp_at' (P \ cteCap) p s\" + apply (simp add: setupReplyMaster_def locateSlot_conv tree_cte_cteCap_eq) + apply (wp getCTE_wp') + apply (fastforce simp: cte_wp_at_ctes_of cteCaps_of_def) + done + +lemmas setupReplyMaster_cte_wp_at' = setupReplyMaster_cte_wp_at''[unfolded o_def] + +lemma setupReplyMaster_cap_to'[wp]: + "\ex_nonz_cap_to' p\ setupReplyMaster t \\rv. ex_nonz_cap_to' p\" + apply (simp add: ex_nonz_cap_to'_def) + apply (rule hoare_pre) + apply (wp hoare_vcg_ex_lift setupReplyMaster_cte_wp_at') + apply clarsimp + done + definition is_arch_update' :: "capability \ cte \ bool" where "is_arch_update' cap cte \ isArchObjectCap cap \ capMasterCap cap = capMasterCap (cteCap cte)" lemma mdb_next_pres: - "\ m p = Some v; mdbNext (cteMDBNode x) = mdbNext (cteMDBNode v) \ \ + "\ m p = Some v; + mdbNext (cteMDBNode x) = mdbNext (cteMDBNode v) \ \ m(p \ x) \ a \ b = m \ a \ b" by (simp add: mdb_next_unfold) @@ -3980,6 +4390,8 @@ lemma arch_update_setCTE_mdb: apply (clarsimp simp: is_arch_update'_def isCap_simps) apply (rule conjI) apply clarsimp + apply (simp add: reply_masters_rvk_fb_def) + apply (erule ball_ran_fun_updI) apply (clarsimp simp add: is_arch_update'_def isCap_simps) done @@ -4052,15 +4464,13 @@ lemma arch_update_setCTE_invs: "\cte_wp_at' (is_arch_update' cap) p and cte_wp_at' ((=) oldcte) p and invs' and valid_cap' cap\ setCTE p (cteCap_update (\_. cap) oldcte) \\rv. invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) - apply (wp arch_update_setCTE_mdb valid_queues_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' - valid_queues_lift' setCTE_pred_tcb_at' irqs_masked_lift - setCTE_norq hoare_vcg_disj_lift untyped_ranges_zero_lift valid_replies'_lift - | simp add: pred_tcb_at'_def)+ - apply (subst fold_list_refs_of_replies') + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) + apply (wp arch_update_setCTE_mdb valid_queues_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' + setCTE_pred_tcb_at' irqs_masked_lift + hoare_vcg_disj_lift untyped_ranges_zero_lift valid_bitmaps_lift + | simp add: pred_tcb_at'_def)+ apply (clarsimp simp: valid_global_refs'_def is_arch_update'_def fun_upd_def[symmetric] cte_wp_at_ctes_of isCap_simps untyped_ranges_zero_fun_upd) apply (frule capMaster_eq_capBits_eq) @@ -4104,7 +4514,7 @@ locale mdb_insert_simple = mdb_insert + assumes safe_parent: "safe_parent_for' m src c'" assumes simple: "is_simple_cap' c'" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma dest_no_parent_n: "n \ dest \ p = False" using src simple safe_parent @@ -4294,7 +4704,7 @@ lemma maskedAsFull_revokable_safe_parent: apply (clarsimp simp:isCap_simps is_simple_cap'_def)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_corres: assumes "cap_relation c c'" "src' = cte_map src" "dest' = cte_map dest" notes trans_state_update'[symmetric,simp] @@ -4344,8 +4754,6 @@ lemma cteInsert_simple_corres: and (\s. safe_parent_for' (ctes_of s) src' c')" in corres_split[where r'=dc]) apply (rule setUntypedCapAsFull_corres; simp) - - apply (rule corres_stronger_no_failI) apply (rule no_fail_pre, wp hoare_weak_lift_imp) apply (clarsimp simp: cte_wp_at_ctes_of valid_mdb'_def valid_mdb_ctes_def) @@ -4353,8 +4761,8 @@ lemma cteInsert_simple_corres: apply (simp+)[3] apply (clarsimp simp: corres_underlying_def state_relation_def in_monad valid_mdb'_def valid_mdb_ctes_def) - apply (drule (22) set_cap_not_quite_corres) - apply fastforce + apply (drule (1) pspace_relationsD) + apply (drule (18) set_cap_not_quite_corres) apply (rule refl) apply (elim conjE exE) apply (rule bind_execI, assumption) @@ -4380,6 +4788,7 @@ lemma cteInsert_simple_corres: apply (drule (3) updateMDB_the_lot', simp only: no_0_modify_map, simp only:, elim conjE) apply (drule (3) updateMDB_the_lot', simp only: no_0_modify_map, simp only:, elim conjE) apply (drule (3) updateMDB_the_lot', simp only: no_0_modify_map, simp only:, elim conjE) + apply (clarsimp simp: pspace_relations_def) apply (thin_tac "gsCNodes t = p" for t p)+ apply (thin_tac "ksMachineState t = p" for t p)+ apply (thin_tac "ksCurThread t = p" for t p)+ @@ -4404,22 +4813,20 @@ lemma cteInsert_simple_corres: apply (thin_tac "ksDomainTime t = p" for t p)+ apply (thin_tac "ksDomSchedule t = p" for t p)+ apply (thin_tac "ctes_of t = p" for t p)+ + apply (thin_tac "ekheap_relation t p" for t p)+ apply (thin_tac "pspace_relation t p" for t p)+ apply (thin_tac "interrupt_state_relation s t p" for s t p)+ apply (thin_tac "sched_act_relation t p" for t p)+ apply (thin_tac "ready_queues_relation t p" for t p)+ - apply clarsimp apply (rule conjI) subgoal by (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) apply (clarsimp simp: cte_wp_at_ctes_of nullPointer_def prev_update_modify_mdb_relation) apply (subgoal_tac "cte_map dest \ 0") prefer 2 - apply (clarsimp simp: valid_mdb'_def - valid_mdb_ctes_def no_0_def) + apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def no_0_def) apply (subgoal_tac "cte_map src \ 0") prefer 2 - apply (clarsimp simp: valid_mdb'_def - valid_mdb_ctes_def no_0_def) + apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def no_0_def) apply (subgoal_tac "should_be_parent_of src_cap (is_original_cap a src) c (revokable src_cap c) = True") prefer 2 apply (subst should_be_parent_of_masked_as_full[symmetric]) @@ -4468,10 +4875,10 @@ lemma cteInsert_simple_corres: apply (subgoal_tac "cte_map (aa,bb) \ cte_map dest") subgoal by (clarsimp simp: modify_map_def split: if_split_asm) apply (erule (5) cte_map_inj) - - apply (wp set_untyped_cap_full_valid_objs set_untyped_cap_as_full_valid_mdb set_untyped_cap_as_full_valid_list - set_untyped_cap_as_full_cte_wp_at setUntypedCapAsFull_valid_cap - setUntypedCapAsFull_cte_wp_at setUntypedCapAsFull_safe_parent_for' | clarsimp | wps)+ + apply (wp set_untyped_cap_full_valid_objs set_untyped_cap_as_full_valid_mdb + set_untyped_cap_as_full_valid_list set_untyped_cap_as_full_cte_wp_at + setUntypedCapAsFull_valid_cap setUntypedCapAsFull_cte_wp_at setUntypedCapAsFull_safe_parent_for' + | clarsimp | wps)+ apply (clarsimp simp:cte_wp_at_caps_of_state ) apply (case_tac rv',clarsimp simp:cte_wp_at_ctes_of maskedAsFull_def) apply (wp getCTE_wp' get_cap_wp)+ @@ -4519,7 +4926,7 @@ lemma cteInsert_simple_corres: apply clarsimp apply (drule (5) cte_map_inj)+ apply simp - (* exact reproduction of proof in cteInsert_corres, + (* exact reproduction of proof in cteInsert_corres, as it does not used is_derived *) apply(simp add: cdt_list_relation_def del: split_paired_All split_paired_Ex) apply(subgoal_tac "no_mloop (cdt a) \ finite_depth (cdt a)") @@ -4677,7 +5084,7 @@ locale mdb_insert_simple' = mdb_insert_simple + fixes n' defines "n' \ modify_map n (mdbNext src_node) (cteMDBNode_update (mdbPrev_update (\_. dest)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [intro!]: "no_0 n'" by (auto simp: n'_def) lemmas n_0_simps' [iff] = no_0_simps [OF no_0_n'] @@ -5335,13 +5742,28 @@ lemma irq' [simp]: apply (erule (1) irq_controlD, rule irq_control) done +lemma reply_masters_rvk_fb: + "reply_masters_rvk_fb m" + using valid by (simp add: valid_mdb_ctes_def) + +lemma reply_masters_rvk_fb' [simp]: + "reply_masters_rvk_fb n'" + using reply_masters_rvk_fb simple + apply (simp add: reply_masters_rvk_fb_def n'_def + n_def ball_ran_modify_map_eq) + apply (subst ball_ran_modify_map_eq) + apply (clarsimp simp: modify_map_def m_p is_simple_cap'_def) + apply (simp add: ball_ran_modify_map_eq m_p is_simple_cap'_def + dest_cap isCap_simps) + done + lemma mdb: "valid_mdb_ctes n'" by (simp add: valid_mdb_ctes_def no_0_n' chain_n') end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma cteInsert_simple_mdb': "\valid_mdb' and pspace_aligned' and pspace_distinct' and (\s. src \ dest) and K (capAligned cap) and (\s. safe_parent_for' (ctes_of s) src cap) and K (is_simple_cap' cap) \ @@ -5400,13 +5822,12 @@ lemma cteInsert_simple_invs: cteInsert cap src dest \\rv. invs'\" apply (rule hoare_pre) - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) apply (wp cur_tcb_lift sch_act_wf_lift valid_queues_lift tcb_in_cur_domain'_lift - valid_irq_node_lift valid_queues_lift' valid_release_queue_lift - valid_release_queue'_lift irqs_masked_lift cteInsert_simple_mdb' - cteInsert_valid_globals_simple cteInsert_norq | simp add: pred_tcb_at'_def)+ - apply (subst fold_list_refs_of_replies') - apply (auto simp: invs'_def valid_pspace'_def valid_dom_schedule'_def + valid_irq_node_lift irqs_masked_lift sym_heap_sched_pointers_lift + cteInsert_simple_mdb' cteInsert_valid_globals_simple + cteInsert_norq | simp add: pred_tcb_at'_def)+ + apply (auto simp: invs'_def valid_state'_def valid_pspace'_def is_simple_cap'_def untyped_derived_eq_def o_def elim: valid_capAligned) done @@ -5542,35 +5963,26 @@ lemma arch_update_updateCap_invs: apply clarsimp done -lemma setCTE_set_cap_sc_replies_relation_valid_corres: - assumes pre: "sc_replies_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 "sc_replies_relation t t'" - using pre unfolding sc_replies_relation_def - apply clarsimp - apply (prop_tac "sc_replies_of t = sc_replies_of s") - apply (rule use_valid[OF step_abs set_cap.valid_sched_pred], simp) - apply (rule use_valid[OF step_conc setCTE_scs_of']) - apply (rule use_valid[OF step_conc setCTE_replies_of']) - apply clarsimp - done - -lemma setCTE_set_cap_release_queue_relation_valid_corres: - assumes pre: "release_queue_relation (release_queue s) (ksReleaseQueue s')" - and step_abs: "(x, t) \ fst (set_cap cap slot s)" - and step_conc: "(y, t') \ fst (setCTE slot' cap' s')" - shows "release_queue_relation (release_queue t)(ksReleaseQueue t')" - apply (rule use_valid[OF step_abs set_cap.valid_sched_pred]) - apply (rule use_valid[OF step_conc setCTE_ksReleaseQueue]) - apply (rule pre) - done +lemma setCTE_set_cap_ready_queues_relation_valid_corres: + assumes pre: "ready_queues_relation s s'" + assumes step_abs: "(x, t) \ fst (set_cap cap slot s)" + assumes step_conc: "(y, t') \ fst (setCTE slot' cap' s')" + shows "ready_queues_relation t t'" + apply (clarsimp simp: ready_queues_relation_def) + apply (insert pre) + apply (rule use_valid[OF step_abs set_cap_exst]) + apply (rule use_valid[OF step_conc setCTE_ksReadyQueues]) + apply (rule use_valid[OF step_conc setCTE_tcbSchedNexts_of]) + apply (rule use_valid[OF step_conc setCTE_tcbSchedPrevs_of]) + apply (clarsimp simp: ready_queues_relation_def Let_def) + using use_valid[OF step_conc setCTE_inQ_opt_pred] + by fast lemma updateCap_same_master: "\ cap_relation cap cap' \ \ corres dc (valid_objs and pspace_aligned and pspace_distinct and cte_wp_at (\c. cap_master_cap c = cap_master_cap cap \ - \is_reply_cap c \ + \is_reply_cap c \ \is_master_reply_cap c \ \is_ep_cap c \ \is_ntfn_cap c) slot) (pspace_aligned' and pspace_distinct' and cte_at' (cte_map slot)) (set_cap cap slot) @@ -5584,6 +5996,7 @@ lemma updateCap_same_master: apply (clarsimp simp: cte_wp_at_ctes_of) apply clarsimp apply (clarsimp simp add: state_relation_def) + apply (drule (1) pspace_relationsD) apply (frule (4) set_cap_not_quite_corres_prequel) apply (erule cte_wp_at_weakenE, rule TrueI) apply assumption @@ -5594,19 +6007,14 @@ lemma updateCap_same_master: apply (rule bexI) prefer 2 apply assumption - apply clarsimp - apply (extract_conjunct \match conclusion in "sc_replies_relation a b" for a b \ -\) - subgoal by (erule setCTE_set_cap_sc_replies_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 (clarsimp simp: pspace_relations_def) apply (subst conj_assoc[symmetric]) apply (extract_conjunct \match conclusion in "ready_queues_relation a b" for a b \ -\) subgoal by (erule setCTE_set_cap_ready_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) - apply (rename_tac obj ps' s'' obj' kobj; case_tac obj; - simp add: return_def fail_def split: if_split_asm) + apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def + split: if_split_asm Structures_A.kernel_object.splits) apply (rule conjI) apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv data_at_def) apply (intro allI conjI) @@ -5623,9 +6031,8 @@ lemma updateCap_same_master: prefer 2 apply (frule setCTE_pspace_only) apply clarsimp - apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def) - apply (rename_tac obj s'' obj' kobj; case_tac obj; - simp add: return_def fail_def split: if_split_asm) + apply (clarsimp simp: set_cap_def in_monad split_def get_object_def set_object_def + split: if_split_asm Structures_A.kernel_object.splits) apply (frule set_cap_caps_of_state_monad) apply (drule is_original_cap_set_cap) apply clarsimp @@ -5667,9 +6074,9 @@ lemma updateCap_same_master: apply (subst same_master_descendants) apply assumption apply (clarsimp simp: master_cap_relation) - apply (clarsimp simp: is_reply_cap_relation) apply (frule_tac d=c in master_cap_relation [symmetric], assumption) - apply (frule is_reply_cap_relation[symmetric]) + apply (frule is_reply_cap_relation[symmetric], + drule is_reply_master_relation[symmetric])+ apply simp apply (drule masterCap.intro) apply (drule masterCap.isReplyCap) @@ -5787,13 +6194,10 @@ lemma updateFreeIndex_forward_valid_objs': crunch updateFreeIndex 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 pred_tcb_at'[wp]: "pred_tcb_at' proj P p" - and valid_replies'[wp]: "valid_replies'" - (wp: valid_replies'_lift) +crunch updateFreeIndex + for pspace_distinct'[wp]: "pspace_distinct'" +crunch updateFreeIndex + for no_0_obj[wp]: "no_0_obj'" lemma updateFreeIndex_forward_valid_mdb': "\\s. valid_mdb' s \ valid_objs' s \ cte_wp_at' ((\cap. isUntypedCap cap @@ -5807,7 +6211,7 @@ lemma updateFreeIndex_forward_valid_mdb': apply (frule(1) CSpace1_R.ctes_of_valid) apply (clarsimp simp: cte_wp_at_ctes_of del: subsetI) apply (rule usableUntypedRange_mono2, - auto simp add: isCap_simps valid_cap_simps' capAligned_def) + auto simp add: isCap_simps valid_cap_simps' capAligned_def) done lemma updateFreeIndex_forward_invs': @@ -5816,7 +6220,7 @@ lemma updateFreeIndex_forward_invs': \ is_aligned (of_nat idx :: word32) minUntypedSizeBits) o cteCap) src s\ updateFreeIndex src idx \\r s. invs' s\" - apply (clarsimp simp: invs'_def valid_dom_schedule'_def) + apply (clarsimp simp:invs'_def valid_state'_def) apply (rule hoare_pre) apply (rule hoare_vcg_conj_lift) apply (simp add: valid_pspace'_def, wp updateFreeIndex_forward_valid_objs' @@ -5825,7 +6229,6 @@ lemma updateFreeIndex_forward_invs': apply (wp sch_act_wf_lift valid_queues_lift updateCap_iflive' tcb_in_cur_domain'_lift | 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) apply wp+ @@ -5845,7 +6248,6 @@ lemma updateFreeIndex_forward_invs': apply (clarsimp simp: cte_wp_at_ctes_of fun_upd_def[symmetric]) apply (clarsimp simp: isCap_simps valid_pspace'_def) apply (frule(1) valid_global_refsD_with_objSize) - apply (subst fold_list_refs_of_replies') apply clarsimp apply (intro conjI allI impI) apply (clarsimp simp: modify_map_def cteCaps_of_def ifunsafe'_def3 split:if_splits) diff --git a/proof/refine/ARM/Corres.thy b/proof/refine/ARM/Corres.thy index b566be9c94..85cf77f61a 100644 --- a/proof/refine/ARM/Corres.thy +++ b/proof/refine/ARM/Corres.thy @@ -12,23 +12,10 @@ text \Instantiating the corres framework to this particular state relation abbreviation "corres \ corres_underlying state_relation False True" -abbreviation - "cross_rel \ cross_rel_ul state_relation" - -lemmas cross_rel_def = cross_rel_ul_def - abbreviation "corresK \ corres_underlyingK state_relation False True" abbreviation "ex_abs \ ex_abs_underlying state_relation" -abbreviation "sr_inv P P' f \ sr_inv_ul state_relation P P' f" - -lemmas sr_inv_def = sr_inv_ul_def - -lemmas sr_inv_imp = sr_inv_ul_imp[of state_relation] - -lemmas sr_inv_bind = sr_inv_ul_bind[where sr=state_relation] - end diff --git a/proof/refine/ARM/Detype_R.thy b/proof/refine/ARM/Detype_R.thy index 9a5c89de16..5953bf6341 100644 --- a/proof/refine/ARM/Detype_R.thy +++ b/proof/refine/ARM/Detype_R.thy @@ -1,5 +1,4 @@ (* - * Copyright 2022, Proofcraft Pty Ltd * Copyright 2014, General Dynamics C4 Systems * * SPDX-License-Identifier: GPL-2.0-only @@ -9,7 +8,11 @@ theory Detype_R imports Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) + +text \Establishing that the invariants are maintained + when a region of memory is detyped, that is, + removed from the model.\ definition "descendants_range_in' S p \ @@ -83,18 +86,19 @@ lemma descendants_range_inD': done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma descendants_range'_def2: "descendants_range' cap p = descendants_range_in' (capRange cap) p" by (simp add: descendants_range_in'_def descendants_range'_def) + defs deletionIsSafe_def: - "deletionIsSafe \ \ptr bits s. \p. - (ko_wp_at' live' p s \ p \ {ptr .. ptr + 2 ^ bits - 1}) - \ (p \ set (ksReleaseQueue s) \ obj_at' (runnable' \ tcbState) p s) - \ (\ko. ksPSpace s p = Some (KOArch ko) \ p \ {ptr .. ptr + 2 ^ bits - 1} - \ 6 \ bits)" + "deletionIsSafe \ \ptr bits s. \p t m r. + (cte_wp_at' (\cte. cteCap cte = capability.ReplyCap t m r) p s \ + t \ {ptr .. ptr + 2 ^ bits - 1}) \ + (\ko. ksPSpace s p = Some (KOArch ko) \ p \ {ptr .. ptr + 2 ^ bits - 1} + \ 6 \ bits)" defs deletionIsSafe_delete_locale_def: "deletionIsSafe_delete_locale \ \ptr bits s. \p. ko_wp_at' live' p s \ p \ {ptr .. ptr + 2 ^ bits - 1}" @@ -110,17 +114,10 @@ defs cNodePartialOverlap_def: \ (\ {p .. p + 2 ^ (cte_level_bits + n) - 1} \ {p. inRange p} \ \ {p .. p + 2 ^ (cte_level_bits + n) - 1} \ {p. \ inRange p}))" -defs release_q_runnable_asrt_def: - "release_q_runnable_asrt \ - \s. \p. p \ set (ksReleaseQueue s) \ obj_at' (runnable' \ tcbState) p s" - (* FIXME: move *) lemma deleteObjects_def2: "is_aligned ptr bits \ deleteObjects ptr bits = do - stateAssert sym_refs_asrt []; - stateAssert valid_idle'_asrt []; - stateAssert release_q_runnable_asrt []; stateAssert (deletionIsSafe ptr bits) []; stateAssert (deletionIsSafe_delete_locale ptr bits) []; doMachineOp (freeMemory ptr bits); @@ -134,7 +131,9 @@ lemma deleteObjects_def2: stateAssert ksASIDMapSafe [] od" apply (simp add: deleteObjects_def is_aligned_mask[symmetric] unless_def deleteGhost_def) - apply (rule bind_eqI, rule ext)+ + apply (rule bind_eqI, rule ext) + apply (rule bind_eqI, rule ext) + apply (rule bind_eqI, rule ext) apply (simp add: bind_assoc[symmetric]) apply (rule bind_cong[rotated], rule refl) apply (simp add: bind_assoc modify_modify deleteRange_def gets_modify_def) @@ -153,9 +152,6 @@ lemma deleteObjects_def2: lemma deleteObjects_def3: "deleteObjects ptr bits = do - stateAssert sym_refs_asrt []; - stateAssert valid_idle'_asrt []; - stateAssert release_q_runnable_asrt []; assert (is_aligned ptr bits); stateAssert (deletionIsSafe ptr bits) []; stateAssert (deletionIsSafe_delete_locale ptr bits) []; @@ -180,14 +176,11 @@ lemma obj_relation_cuts_in_obj_range: kheap s x = Some ko; valid_objs s; pspace_aligned s \ \ y \ obj_range x ko" apply (cases ko, simp_all) apply (clarsimp split: if_split_asm) - apply (subgoal_tac "cte_at (x, ya) s") - apply (drule(2) cte_at_cte_map_in_obj_bits) - apply (simp add: obj_range_def) - apply (fastforce intro: cte_wp_at_cteI) - apply (prop_tac "y = x") - apply (meson old.prod.inject singletonD) - apply simp - apply (frule(1) pspace_alignedD) + apply (subgoal_tac "cte_at (x, ya) s") + apply (drule(2) cte_at_cte_map_in_obj_bits) + apply (simp add: obj_range_def) + apply (fastforce intro: cte_wp_at_cteI) + apply (frule(1) pspace_alignedD) apply (frule valid_obj_sizes, erule ranI) apply (rename_tac arch_kernel_obj) apply (case_tac arch_kernel_obj, simp_all) @@ -396,7 +389,7 @@ lemma cte_wp_at_delete': del: atLeastAtMost_iff) apply (simp add: objBits_simps) apply (frule(1) tcb_cte_cases_aligned_helpers) - apply (simp) + apply (simp add: is_aligned_neg_mask_eq) done lemma map_to_ctes_delete: @@ -437,9 +430,9 @@ next apply (subst card_Un_disjoint; simp) apply (clarsimp simp: field_simps) apply (subst suc) - apply (erule word_plus_mono_right2) + apply (erule word_plus_mono_right2) apply (simp add: field_simps) - apply simp + apply simp apply (simp add: unatSuc) done qed @@ -448,321 +441,94 @@ end locale detype_locale' = detype_locale + constrains s::"det_state" -context begin interpretation Arch . (*FIXME: arch_split*) - -text \Invariant preservation across concrete deletion\ - -lemma caps_containedD': - "\ ctes_of s p = Some cte; ctes_of s p' = Some cte'; - \ isUntypedCap (cteCap cte); capRange (cteCap cte) \ untypedRange (cteCap cte') \ {}; - caps_contained' (ctes_of s) \ \ - capRange (cteCap cte) \ untypedRange (cteCap cte')" - apply (cases cte, cases cte') - apply (simp add: caps_contained'_def) - apply blast - done - -lemma untyped_mdbD': - "\ ctes p = Some cte; ctes p' = Some cte'; - isUntypedCap (cteCap cte); capRange (cteCap cte') \ untypedRange (cteCap cte) \ {}; - \ isUntypedCap (cteCap cte'); - untyped_mdb' ctes \ \ p' \ descendants_of' p ctes" - by (cases cte, cases cte', simp add: untyped_mdb'_def) - -lemma ko_wp_at_state_refs_ofD: - "\ ko_wp_at' P p s \ \ (\ko. P ko \ state_refs_of' s p = refs_of' ko)" - by (fastforce simp: ko_wp_at'_def state_refs_of'_def) - -lemma sym_refs_ko_wp_atD: - "\ ko_wp_at' P p s; sym_refs (state_refs_of' s) \ - \ (\ko. P ko \ state_refs_of' s p = refs_of' ko - \ (\(x, tp) \ refs_of' ko. (p, symreftype tp) \ state_refs_of' s x))" - apply (clarsimp dest!: ko_wp_at_state_refs_ofD) - apply (rule exI, erule conjI) - apply (drule sym) - apply clarsimp - apply (erule(1) sym_refsD) - done - -lemma zobj_refs_capRange: - "capAligned c \ zobj_refs' c \ capRange c" - by (cases c, simp_all add: capRange_def capAligned_def is_aligned_no_overflow) -end - -locale delete_locale = - fixes s' and base and bits and ptr and idx and d - assumes cap: "cte_wp_at' (\cte. cteCap cte = UntypedCap d base bits idx) ptr s'" - and nodesc: "descendants_range' (UntypedCap d base bits idx) ptr (ctes_of s')" - and invs: "invs' s'" - and sym_refs: "sym_refs (state_refs_of' s')" - and valid_idle': "valid_idle' s'" - and ct_act: "ct_active' s'" - and sa_simp: "sch_act_simple s'" - and al: "is_aligned base bits" - and rlqrun: "\p. p \ set (ksReleaseQueue s') \ obj_at' (runnable' \ tcbState) p s'" - -context delete_locale -begin -interpretation Arch . (*FIXME: arch_split*) -lemma valid_objs: "valid_objs' s'" - and vreplies: "valid_replies' s'" - and pspace: "valid_pspace' s'" - and pa: "pspace_aligned' s'" - and pd: "pspace_distinct' s'" - and bd: "pspace_bounded' s'" - and vq: "valid_queues s'" - and vq': "valid_queues' s'" - and vrlq: "valid_release_queue s'" - and vrlq': "valid_release_queue' 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')" - and chain_0: "mdb_chain_0 (ctes_of s')" - and badges: "valid_badges (ctes_of s')" - and contained: "caps_contained' (ctes_of s')" - and chunked: "mdb_chunked (ctes_of s')" - and umdb: "untyped_mdb' (ctes_of s')" - and uinc: "untyped_inc' (ctes_of s')" - and nullcaps: "valid_nullcaps (ctes_of s')" - and ut_rev: "ut_revocable' (ctes_of s')" - and dist_z: "distinct_zombies (ctes_of s')" - and irq_ctrl: "irq_control (ctes_of s')" - and clinks: "class_links (ctes_of s')" - and refs: "valid_global_refs' s'" - and arch: "valid_arch_state' s'" - and virq: "valid_irq_node' (irq_node' s') s'" - and virqh: "valid_irq_handlers' s'" - and virqs: "valid_irq_states' s'" - and no_0_objs: "no_0_obj' s'" - and pde_maps: "valid_pde_mappings' s'" - and irqs_masked: "irqs_masked' s'" - and cdm: "ksCurDomain s' \ maxDomain" - and vds: "valid_dom_schedule' s'" - using invs - by (auto simp add: invs'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def) - -abbreviation - "base_bits \ {base .. base + (2 ^ bits - 1)}" - -abbreviation - "pspace' \ \x. if base \ x \ x \ base + (2 ^ bits - 1) then None else ksPSpace s' x" - -abbreviation - "state' \ (s' \ ksPSpace := pspace' \)" - -abbreviation - "replies' \ pspace' |> reply_of'" - -lemma ko_wp_at'[simp]: - "\P p. (ko_wp_at' P p state') = (ko_wp_at' P p s' \ p \ base_bits)" - by (fastforce simp add: ko_wp_at_delete'[OF pd]) - -lemma obj_at'[simp]: - "\P p. (obj_at' P p state') = (obj_at' P p s' \ p \ base_bits)" - by (fastforce simp add: obj_at'_real_def) - -lemma typ_at'[simp]: - "typ_at' P p state' = (typ_at' P p s' \ p \ base_bits)" - by (simp add: typ_at'_def) - -lemma valid_untyped[simp]: - "s' \' UntypedCap d base bits idx" - using cte_wp_at_valid_objs_valid_cap' [OF cap valid_objs] - by clarsimp - -lemma cte_wp_at'[simp]: - "\P p. (cte_wp_at' P p state') = (cte_wp_at' P p s' \ p \ base_bits)" - by (fastforce simp:cte_wp_at_delete'[where idx = idx,OF valid_untyped pd ]) - -(* the bits of caps they need for validity argument are within their capRanges *) -lemma valid_cap_ctes_pre: - "\c. s' \' c \ case c of CNodeCap ref bits g gs - \ \x. ref + (x && mask bits) * 2^cteSizeBits \ capRange c - | Zombie ref (ZombieCNode bits) n - \ \x. ref + (x && mask bits) * 2^cteSizeBits \ capRange c - | ArchObjectCap (PageTableCap ref data) - \ \x < 0x100. ref + x * 2^pteBits \ capRange c \ \number of entries in page table\ - | ArchObjectCap (PageDirectoryCap ref data) - \ \x < 0x1000. ref + x * 2^pdeBits \ capRange c \ \number of entries in page directory\ - | _ \ True" - apply (drule valid_capAligned) - apply (simp split: capability.split zombie_type.split arch_capability.split, safe) - using pre_helper[where a=cteSizeBits] - apply (clarsimp simp add: capRange_def capAligned_def objBits_simps field_simps) - apply (clarsimp simp add: capRange_def capAligned_def - simp del: atLeastAtMost_iff capBits.simps) - apply (rule pre_helper2, simp_all add: word_bits_def pteBits_def)[1] - apply (clarsimp simp add: capRange_def capAligned_def - simp del: atLeastAtMost_iff capBits.simps) - apply (rule pre_helper2, simp_all add: word_bits_def pdeBits_def)[1] - using pre_helper[where a=cteSizeBits] - apply (clarsimp simp add: capRange_def capAligned_def objBits_simps field_simps) - done - -lemma valid_cap': - "\p c. \ s' \' c; cte_wp_at' (\cte. cteCap cte = c) p s'; - capRange c \ {base .. base + (2 ^ bits - 1)} = {} \ \ state' \' c" - apply (subgoal_tac "capClass c = PhysicalClass \ capUntypedPtr c \ capRange c") - apply (subgoal_tac "capClass c = PhysicalClass \ - capUntypedPtr c \ {base .. base + (2 ^ bits - 1)}") - apply (frule valid_cap_ctes_pre) - apply (case_tac c, simp_all add: valid_cap'_def - del: atLeastAtMost_iff - split: zombie_type.split_asm) - apply (simp add: field_simps del: atLeastAtMost_iff) - apply blast - apply (rename_tac arch_capability) - apply (case_tac arch_capability, - simp_all add: ARM_H.capUntypedPtr_def - page_table_at'_def page_directory_at'_def - shiftl_t2n - del: atLeastAtMost_iff)[1] - apply (rename_tac word vmrights vmpage_size option) - apply (subgoal_tac "\p < 2 ^ (pageBitsForSize vmpage_size - pageBits). - word + p * 2 ^ pageBits \ capRange c") - apply blast - apply (clarsimp simp: capRange_def capAligned_def) - apply (frule word_less_power_trans2, - rule pbfs_atleast_pageBits, simp add: word_bits_def) - apply (rule context_conjI) - apply (erule(1) is_aligned_no_wrap') - apply (simp only: add_diff_eq[symmetric]) - apply (rule word_plus_mono_right) - apply simp - apply (erule is_aligned_no_overflow') - apply (simp add: field_simps pteBits_def del: atLeastAtMost_iff) - apply blast - apply (simp add: field_simps pdeBits_def del: atLeastAtMost_iff) - apply blast - apply (simp add: valid_untyped'_def) - apply (simp add: field_simps del: atLeastAtMost_iff) - apply blast - apply blast - apply (clarsimp simp: capAligned_capUntypedPtr) - done - -lemma objRefs_notrange: - assumes asms: "ctes_of s' p = Some c" "\ isUntypedCap (cteCap c)" - shows "capRange (cteCap c) \ base_bits = {}" +lemma (in detype_locale') deletionIsSafe: + assumes sr: "(s, s') \ state_relation" + and cap: "cap = cap.UntypedCap d base magnitude idx" + and vs: "valid_pspace s" + and al: "is_aligned base magnitude" + and vu: "valid_untyped (cap.UntypedCap d base magnitude idx) s" + shows "deletionIsSafe base magnitude s'" proof - - from cap obtain node - where ctes_of: "ctes_of s' ptr = Some (CTE (UntypedCap d base bits idx) node)" - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (case_tac cte, simp) - done - - show ?thesis using asms cap + interpret Arch . (* FIXME: arch-split *) + note [simp del] = atLeastatMost_subset_iff atLeastLessThan_iff atLeastAtMost_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + have "\t m r. \ptr. cte_wp_at ((=) (cap.ReplyCap t m r)) ptr s + \ t \ {base .. base + 2 ^ magnitude - 1}" + by (fastforce dest!: valid_cap2 simp: cap obj_reply_refs_def) + hence "\ptr t m r. cte_wp_at ((=) (cap.ReplyCap t m r)) ptr s + \ t \ {base .. base + 2 ^ magnitude - 1}" + by (fastforce simp del: split_paired_All) + hence "\t. t \ {base .. base + 2 ^ magnitude - 1} \ + (\ptr m r. \ cte_wp_at ((=) (cap.ReplyCap t m r)) ptr s)" + by fastforce + hence cte: "\t. t \ {base .. base + 2 ^ magnitude - 1} \ + (\ptr m r. \ cte_wp_at' (\cte. cteCap cte = ReplyCap t m r) ptr s')" + unfolding deletionIsSafe_def apply - - apply (rule ccontr) - apply (drule untyped_mdbD' [OF ctes_of _ _ _ _ umdb]) - apply (simp add: isUntypedCap_def) - apply (simp add: field_simps) - apply assumption - using nodesc - apply (simp add:descendants_range'_def2) - apply (drule(1) descendants_range_inD') - apply (simp add:asms) - apply (simp add:p_assoc_help) + apply (erule allEI) + apply (rule impI, drule(1) mp) + apply (thin_tac "t \ S" for S) + apply (intro allI) + apply (clarsimp simp: cte_wp_at_neg2 cte_wp_at_ctes_of + simp del: split_paired_All) + apply (frule pspace_relation_cte_wp_atI [rotated]) + apply (rule invs_valid_objs [OF invs]) + apply (rule state_relation_pspace_relation [OF sr]) + apply (clarsimp simp: cte_wp_at_neg2 simp del: split_paired_All) + apply (drule_tac x="(a,b)" in spec) + apply (clarsimp simp: cte_wp_cte_at cte_wp_at_caps_of_state) + apply (case_tac c, simp_all) + apply fastforce done -qed - -lemma ctes_of_valid [elim!]: - "ctes_of s' p = Some cte \ s' \' cteCap cte" - by (case_tac cte, simp add: ctes_of_valid_cap' [OF _ valid_objs]) - -lemma valid_cap2: - "\ cte_wp_at' (\cte. cteCap cte = c) p s' \ \ state' \' c" - apply (case_tac "isUntypedCap c") - apply (drule cte_wp_at_valid_objs_valid_cap' [OF _ valid_objs]) - apply (clarsimp simp: valid_cap'_def isCap_simps valid_untyped'_def) - apply (rule valid_cap'[rotated], assumption) - apply (clarsimp simp: cte_wp_at_ctes_of dest!: objRefs_notrange) - apply (clarsimp simp: cte_wp_at_ctes_of) - done - -lemma ex_nonz_cap_notRange: - "ex_nonz_cap_to' p s' \ p \ base_bits" - apply (clarsimp simp: ex_nonz_cap_to'_def cte_wp_at_ctes_of) - apply (case_tac "isUntypedCap (cteCap cte)") - apply (clarsimp simp: isCap_simps) - apply (drule subsetD[OF zobj_refs_capRange, rotated]) - apply (rule valid_capAligned, erule ctes_of_valid) - apply (drule(1) objRefs_notrange) - apply (drule_tac a=p in equals0D) - apply simp - done - -lemma live_notRange: - "\ ko_wp_at' P p s'; \ko. P ko \ live' ko \ \ p \ base_bits" - apply (drule if_live_then_nonz_capE' [OF iflive ko_wp_at'_weakenE]) - apply simp - apply (erule ex_nonz_cap_notRange) - done - -lemma deletionIsSafe_holds: - assumes sr: "(s, s') \ state_relation" - and cap: "cap = cap.UntypedCap d base bits idx" - and vs: "valid_pspace s" - and al: "is_aligned base bits" - and vu: "valid_untyped (cap.UntypedCap d base bits idx) s" - shows "deletionIsSafe base bits s'" -proof - - interpret Arch . (* FIXME: arch_split *) - have arch: "\ ko p. \ ksPSpace s' p = Some (KOArch ko); p \ {base..base + 2 ^ bits - 1} \ - \ 6 \ bits" + have arch: "\ ko p. \ ksPSpace s' p = Some (KOArch ko); p \ {base..base + 2 ^ magnitude - 1} \ + \ 6 \ magnitude" using sr vs vu apply (clarsimp simp: state_relation_def) - apply (erule (1) pspace_dom_relatedE) - apply (frule obj_relation_cuts_eqv_base_in_detype_range[symmetric]; simp?) - apply (clarsimp simp: valid_pspace_def)+ - apply (clarsimp simp: valid_untyped_def) + apply (erule(1) pspace_dom_relatedE) + apply (frule obj_relation_cuts_eqv_base_in_detype_range[symmetric]) + apply simp + apply (clarsimp simp:valid_pspace_def)+ + apply simp + apply (clarsimp simp:valid_untyped_def) apply (drule spec)+ apply (erule(1) impE) apply (erule impE) - apply (drule p_in_obj_range; fastforce) + apply (drule p_in_obj_range) + apply (clarsimp)+ + apply blast apply clarsimp apply (drule card_mono[rotated]) apply fastforce - apply (clarsimp simp: valid_pspace_def obj_range_def p_assoc_help) + apply (clarsimp simp:valid_pspace_def obj_range_def p_assoc_help) apply (subst (asm) word_range_card) apply (rule is_aligned_no_overflow') apply (erule(1) pspace_alignedD) apply (subst (asm) word_range_card) apply (rule is_aligned_no_overflow'[OF al]) apply (rule ccontr) - apply (simp add: not_le) - apply (prop_tac "obj_bits koa < 32") - apply (case_tac koa, simp_all add: objBits_simps word_bits_def) - apply (drule(1) valid_cs_size_objsI) - apply (clarsimp simp: valid_cs_size_def word_bits_def cte_level_bits_def) - apply (clarsimp split: if_splits) + apply (simp add:not_le) + apply (subgoal_tac "obj_bits koa < 32") + prefer 2 + apply (case_tac koa,simp_all add:objBits_simps word_bits_def) + apply (drule(1) valid_cs_size_objsI) + apply (clarsimp simp:valid_cs_size_def word_bits_def cte_level_bits_def) apply (rename_tac arch_kernel_obj) - apply (case_tac arch_kernel_obj; simp add: pageBits_def word_bits_def) - apply (simp add: pageBitsForSize_def split: vmpage_size.splits) - apply (case_tac koa - ; simp add: other_obj_relation_def objBits_simps cte_relation_def - split: if_splits) - apply (rename_tac arch_kernel_obj - , case_tac arch_kernel_obj - ; simp add: arch_kobj_size_def pageBits_def pageBitsForSize_def)+ + apply (case_tac arch_kernel_obj,simp_all add:pageBits_def word_bits_def) + apply (simp add:pageBitsForSize_def split:vmpage_size.splits) + apply (subgoal_tac "6 \ obj_bits koa") + apply simp + apply (case_tac koa, simp_all add: other_obj_relation_def + objBits_simps cte_relation_def + split: if_splits) + apply (rename_tac arch_kernel_obj, + case_tac arch_kernel_obj; + simp add: arch_kobj_size_def pageBits_def pageBitsForSize_def)+ done - - thus ?thesis - apply - - apply (clarsimp simp: deletionIsSafe_def) - apply (intro conjI; blast?) - apply (fastforce simp: x_power_minus_1 dest!: live_notRange) - apply (insert rlqrun) - apply simp - done + thus ?thesis using cte by (auto simp: deletionIsSafe_def) qed -end - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \Invariant preservation across concrete deletion\ @@ -813,7 +579,7 @@ locale delete_locale = and al: "is_aligned base bits" and safe: "deletionIsSafe base bits s'" -context delete_locale begin interpretation Arch . (*FIXME: arch_split*) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma valid_objs: "valid_objs' s'" and pa: "pspace_aligned' s'" @@ -1028,7 +794,7 @@ lemma refs_notRange: done end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ksASIDMapSafeI: "\ (s,s') \ state_relation; invs s; pspace_aligned' s' \ pspace_distinct' s' \ @@ -1069,6 +835,11 @@ lemma corres_machine_op: apply (simp_all add: state_relation_def swp_def) done +lemma ekheap_relation_detype: + "ekheap_relation ekh kh \ + ekheap_relation (\x. if P x then None else (ekh x)) (\x. if P x then None else (kh x))" + by (fastforce simp add: ekheap_relation_def split: if_split_asm) + lemma cap_table_at_gsCNodes_eq: "(s, s') \ state_relation \ (gsCNodes s' ptr = Some bits) = cap_table_at bits ptr s" @@ -1112,42 +883,6 @@ lemma sym_refs_hyp_refs_triv[simp]: "sym_refs (state_hyp_refs_of s)" apply (case_tac ko; clarsimp) done -lemma freeMemory_deletionIsSafe[wp]: - "doMachineOp (freeMemory base magnitude) \deletionIsSafe base magnitude\" - apply (clarsimp simp: doMachineOp_def) - apply wpsimp - apply (clarsimp simp: deletionIsSafe_def) - done - -lemma detype_ReplyPrevs_of: - "\pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; \p. p \ S \ \ ko_wp_at' live' p s'\ - \ ((\x. if x \ S then None else ksPSpace s' x) |> reply_of' |> replyPrev) - = replyPrevs_of s'" - apply (prop_tac "\p reply_ptr. (replyPrevs_of s' p = Some reply_ptr) \ p \ S") - apply (clarsimp simp: opt_map_def split: option.splits) - apply (drule_tac x=p in spec) - apply (clarsimp simp: ko_wp_at'_def pred_neg_def live'_def projectKOs live_reply'_def - split: Structures_H.kernel_object.splits) - using pspace_alignedD' pspace_distinctD' pspace_boundedD' apply clarsimp - apply (rule ext) - apply (clarsimp simp: vs_all_heap_simps opt_map_def in_opt_map_eq - split: option.splits) - by force - -lemma detype_sc_replies_relation: - "\pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; \p. p \ {lower..upper} \ \ ko_wp_at' live' p s'; - sc_replies_relation s s'\ - \ sc_replies_relation_2 (sc_replies_of (detype {lower..upper} s)) - ((\x. if lower \ x \ x \ upper - then None else ksPSpace s' x) |> sc_of' |> scReply) - ((\x. if lower \ x \ x \ upper - then None else ksPSpace s' x) |> reply_of' |> replyPrev)" - apply (clarsimp simp: sc_replies_relation_def detype_def) - apply (frule detype_ReplyPrevs_of[where S="{lower..upper}"]; simp) - apply (clarsimp simp: vs_all_heap_simps opt_map_def in_opt_map_eq - split: if_splits Structures_A.kernel_object.splits) - done - crunch doMachineOp for deletionIsSafe_delete_locale[wp]: "deletionIsSafe_delete_locale base magnitude" (simp: deletionIsSafe_delete_locale_def) @@ -1232,23 +967,23 @@ lemma deleteObjects_corres: \ ct_active' s' \ 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_release_q_runnable apply (simp add: deleteObjects_def2) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: sym_refs_asrt_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: release_q_runnable_asrt_def) - apply (rule corres_stateAssert_add_assertion) + apply (rule corres_stateAssert_implied[where P'=\, simplified]) 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)?) + apply (rule_tac cap="cap.UntypedCap d base magnitude idx" and ptr="(a,b)" and s=s + in detype_locale'.deletionIsSafe, + simp_all add: detype_locale'_def detype_locale_def invs_valid_pspace)[1] + apply (simp add: valid_cap_simps) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply (rule_tac ptr=ptr and idx=idx and d=d in delete_locale.deletionIsSafe_delete_locale_holds) + apply (clarsimp simp: delete_locale_def) + apply (intro conjI) + apply (fastforce simp: sch_act_simple_def state_relation_def schact_is_rct_def) + apply (rule_tac cap="cap.UntypedCap d base magnitude idx" and ptr="(a,b)" and s=s + in detype_locale'.deletionIsSafe, + simp_all add: detype_locale'_def detype_locale_def invs_valid_pspace)[1] + apply (simp add:valid_cap_simps) apply (simp add: bind_assoc[symmetric]) apply (rule corres_stateAssert_implied2) defer @@ -1257,22 +992,24 @@ lemma deleteObjects_corres: apply (rule delete_objects_invs) apply fastforce apply (simp add: doMachineOp_def split_def) - apply wpsimp - apply (frule invs_valid_pspace') - apply (rule conjI - ; clarsimp simp: pspace_distinct'_def ps_clear_def dom_if_None Diff_Int_distrib - valid_pspace'_def pspace_aligned'_def) + apply wp + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def pspace_distinct'_def + pspace_aligned'_def) + apply (rule conjI) + subgoal by fastforce + apply (clarsimp simp add: pspace_distinct'_def ps_clear_def + dom_if_None Diff_Int_distrib) apply (simp add: delete_objects_def) apply (rule_tac Q="\_ s. valid_objs s \ valid_list s \ (\cref. cte_wp_at ((=) (cap.UntypedCap d base magnitude idx)) cref s \ - descendants_range (cap.UntypedCap d base magnitude idx) cref s) \ + descendants_range (cap.UntypedCap d base magnitude idx) cref s ) \ s \ cap.UntypedCap d base magnitude idx \ pspace_aligned s \ valid_mdb s \ pspace_distinct s \ if_live_then_nonz_cap s \ zombies_final s \ sym_refs (state_refs_of s) \ untyped_children_in_mdb s \ if_unsafe_then_cap s \ - valid_global_refs s \ valid_replies s \ fault_tcbs_valid_states s" and - Q'="\_ s. s \' UntypedCap d base magnitude idx \ - valid_pspace' s \ deletionIsSafe base magnitude s" + valid_global_refs s" + and Q'="\_ s. s \' capability.UntypedCap d base magnitude idx \ + valid_pspace' s \ deletionIsSafe_delete_locale base magnitude s" in corres_underlying_split) apply (rule corres_bind_return) apply (rule corres_guard_imp[where r=dc]) @@ -1286,9 +1023,14 @@ 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 (intro exI, fastforce) - apply (rule ext, clarsimp simp add: null_filter_def) + apply (simp add: detype_def, rule state.equality; simp add: detype_ext_def) + apply (intro exI, 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) @@ -1300,107 +1042,29 @@ lemma deleteObjects_corres: apply (frule_tac cref="(aa, ba)" in cte_map_untyped_range, erule cte_wp_at_weakenE[OF _ TrueI], assumption+) 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 - 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 (erule state_relation_sc_replies_relation) + 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 (fastforce simp add: detype_def detype_ext_def intro!: ekheap_relation_detype) + apply (rule detype_ready_queues_relation; blast?) + apply (clarsimp simp: deletionIsSafe_delete_locale_def) + apply (frule state_relation_ready_queues_relation) + apply (simp add: ready_queues_relation_def Let_def) apply (clarsimp simp: state_relation_def ghost_relation_of_heap detype_def) apply (drule_tac t="gsUserPages s'" in sym) apply (drule_tac t="gsCNodes s'" in sym) - apply (auto simp: ups_of_heap_def cns_of_heap_def ext - split: option.splits kernel_object.splits)[1] + apply (auto simp add: ups_of_heap_def cns_of_heap_def ext + split: option.splits kernel_object.splits)[1] apply (simp add: valid_mdb_def) - apply (wp hoare_vcg_ex_lift hoare_vcg_ball_lift - | wps - | simp add: invs_def valid_state_def valid_pspace_def descendants_range_def - valid_cap_simps - | wp (once) hoare_drop_imps)+ - apply (rule invs_valid_pspace') - apply simp + apply (wp hoare_vcg_ex_lift hoare_vcg_ball_lift | wps | + simp add: invs_def valid_state_def valid_pspace_def + descendants_range_def | wp (once) hoare_drop_imps)+ + apply fastforce done end -context delete_locale -begin -interpretation Arch . (*FIXME: arch_split*) - -lemma live_idle_untyped_range': - "\ ko_wp_at' P p s' \ p = idle_thread_ptr \ p = idle_sc_ptr; \ko. P ko \ live' ko \ - \ p \ base_bits" - apply (case_tac "ko_wp_at' P p s'") - apply (drule if_live_then_nonz_capE'[OF iflive ko_wp_at'_weakenE]) - apply simp - apply (erule ex_nonz_cap_notRange) - apply clarsimp - apply (insert invs_valid_global'[OF invs] cap valid_idle' - idle_is_global[where s = s]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (drule (1) valid_global_refsD') - apply (clarsimp simp: valid_idle'_def) - using atLeastAtMost_iff apply (simp add: p_assoc_help) - by fastforce - -lemma untyped_range_live_idle': - "p \ base_bits \ \ (ko_wp_at' live' p s' \ p = idle_thread_ptr \ p = idle_sc_ptr)" - using live_idle_untyped_range' by blast - -lemma refs_of': - "\ko p. ko_wp_at' ((=) (injectKOS ko)) p s' \ sym_refs (state_refs_of' s') - \ refs_of' (injectKOS ko) \ (UNIV - base_bits \ UNIV)" - apply (case_tac "p = idle_sc_ptr \ p = idle_thread_ptr") - apply (insert valid_idle') - apply (clarsimp simp: valid_idle'_def) - apply (elim disjE) - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) - using live_idle_untyped_range' apply simp - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs idle_tcb'_def) - using live_idle_untyped_range' apply simp - apply (prop_tac "ko_at' ko p s'") - apply (fastforce simp: ko_wp_at'_def obj_at'_def projectKOs project_inject) - apply (frule sym_refs_ko_atD') - apply (fastforce intro: refs_of_live' dest!: live_notRange)+ - done - -lemma list_refs_of_replies_live': - "\ (x, tp) \ list_refs_of_replies' s' p; pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s' \ - \ ko_wp_at' live' p s'" - apply (clarsimp simp: ko_wp_at'_def list_refs_of_replies'_def list_refs_of_reply'_def pspace_bounded'_def - pspace_aligned'_def pspace_distinct'_def get_refs_def projectKOs - split: option.splits - elim!: opt_mapE) - by (metis live_reply'_def not_in_domIff option.discI option.sel)+ - -lemma replyPrev_list_refs_of_replies: - "\ko_at' reply p s'; replyPrev reply = Some reply_ptr\ - \ (reply_ptr, ReplyPrev) \ list_refs_of_replies' s' p" - by (clarsimp simp: list_refs_of_replies'_def list_refs_of_reply'_def opt_map_def projectKOs - obj_at'_def - split: option.splits) - -lemma replyNext_list_refs_of_replies: - "\ko_at' reply p s'; replyNext reply = Some next_ptr; next_ptr = Next reply_ptr\ - \ (reply_ptr, ReplyNext) \ list_refs_of_replies' s' p" - by (clarsimp simp: list_refs_of_replies'_def list_refs_of_reply'_def opt_map_def projectKOs - obj_at'_def - split: option.splits) +context delete_locale begin interpretation Arch . (*FIXME: arch-split*) lemma live_idle_untyped_range': "ko_wp_at' live' p s' \ p = idle_thread_ptr \ p \ base_bits" @@ -1421,150 +1085,64 @@ lemma untyped_range_live_idle': using live_idle_untyped_range' by blast lemma valid_obj': - "\ valid_obj' obj s'; ko_wp_at' ((=) obj) p s'; sym_refs (state_refs_of' s'); - sym_refs (list_refs_of_replies' s'); pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'\ + "\ valid_obj' obj s'; ko_wp_at' ((=) obj) p s'; sym_heap_sched_pointers s' \ \ valid_obj' obj state'" apply (case_tac obj, simp_all add: valid_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) - apply (frule refs_of') - apply (frule (2) sym_refs_ko_wp_atD) - apply (clarsimp simp: valid_tcb'_def ko_wp_at'_def objBits_simps) - apply (rule conjI) - apply (erule ballEI, clarsimp elim!: ranE) - apply (rule_tac p="p + x" in valid_cap2) - apply (erule (2) cte_wp_at_tcbI') - apply fastforce - apply simp - apply (clarsimp simp: valid_tcb_state'_def valid_bound_reply'_def - split: option.splits thread_state.splits) - apply (clarsimp simp: valid_cte'_def) - apply (rule_tac p=p in valid_cap2) - apply (clarsimp simp: ko_wp_at'_def objBits_simps' cte_level_bits_def[symmetric]) - apply (erule(2) cte_wp_at_cteI') + apply (rename_tac endpoint) + apply (case_tac endpoint, simp_all add: valid_ep'_def)[1] + apply (clarsimp dest!: sym_refs_ko_wp_atD [OF _ sym_refs]) + apply (drule(1) bspec)+ + apply (clarsimp dest!: refs_notRange) + apply (clarsimp dest!: sym_refs_ko_wp_atD [OF _ sym_refs]) + apply (drule(1) bspec)+ + apply (clarsimp dest!: refs_notRange) + apply (rename_tac notification) + apply (case_tac notification, simp_all add: valid_ntfn'_def valid_bound_tcb'_def)[1] + apply (rename_tac ntfn bound) + apply (case_tac ntfn, simp_all split:option.splits)[1] + apply ((clarsimp dest!: sym_refs_ko_wp_atD [OF _ sym_refs] refs_notRange)+)[4] + apply (drule(1) bspec)+ + apply (clarsimp dest!: refs_notRange) + apply (clarsimp dest!: sym_refs_ko_wp_atD [OF _ sym_refs] refs_notRange) + apply (frule sym_refs_ko_wp_atD [OF _ sym_refs]) + apply (clarsimp simp: valid_tcb'_def ko_wp_at'_def + objBits_simps) + apply (rule conjI) + apply (erule ballEI, clarsimp elim!: ranE) + apply (rule_tac p="p + x" in valid_cap2) + apply (erule(2) cte_wp_at_tcbI') + apply fastforce apply simp - apply (rename_tac arch_kernel_object) - apply (case_tac "arch_kernel_object", simp_all) - apply (rename_tac asidpool) - apply (case_tac asidpool, clarsimp simp: page_directory_at'_def) - apply (rename_tac pte) - apply (case_tac pte, simp_all add: valid_mapping'_def) - apply (rename_tac pde) - apply (case_tac pde, simp_all add: valid_mapping'_def) - apply (clarsimp dest!: refs_of' simp flip: injectKO_sc) - apply (clarsimp simp: valid_sched_context'_def valid_bound_obj'_def split: option.splits) - apply (rename_tac reply) - apply (clarsimp simp flip: injectKO_reply) - apply (frule (1) refs_of') - apply (clarsimp simp: ko_wp_at'_def valid_reply'_def valid_bound_tcb'_def) - apply (rule conjI; (solves \clarsimp split: option.splits\)?)+ - apply (case_tac "replyPrev reply = None"; clarsimp?) - apply (frule replyPrev_list_refs_of_replies[rotated]) - apply (simp add: obj_at'_def projectKOs) - using sym_refs_def live_notRange list_refs_of_replies_live' apply fastforce - apply (case_tac "replyNext reply = None"; clarsimp?) - apply (rename_tac reply_next) - apply (case_tac reply_next; clarsimp) - apply (frule replyNext_list_refs_of_replies[rotated], simp) - apply (simp add: obj_at'_def projectKOs) - using sym_refs_def live_notRange list_refs_of_replies_live' apply fastforce - done - -lemma state_refs_for_state': - "\ pspace_aligned' s'; pspace_distinct' s'; pspace_distinct' state' \ - \ state_refs_of' state' = (\x. if x \ base_bits then {} else state_refs_of' s' x)" - apply (rule ext) - by (auto simp: state_refs_of'_def intro!: pspace_distinctD' split: option.splits) - -lemma sc_tcb_not_idle_thread'_helper: - "\ pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; scTCB sc = Some tp; - ksPSpace s' scp = Some (KOSchedContext sc); sym_refs (state_refs_of' s') \ - \ (scp, TCBSchedContext) \ state_refs_of' s' tp" - apply (clarsimp simp: state_refs_of'_def - elim!: sym_refsE) - by (simp add: pspace_alignedD' pspace_distinctD' pspace_boundedD') - -lemma sc_tcb_not_idle_thread': - "\ pspace_aligned' s'; pspace_distinct' s'; ksPSpace s' scp = Some (KOSchedContext sc); - scp \ idle_sc_ptr; valid_global_refs' s'; valid_pspace' s'; - if_live_then_nonz_cap' s'; sym_refs (state_refs_of' s')\ - \ scTCB sc \ Some (ksIdleThread s')" - apply (frule (1) global'_no_ex_cap) - apply (rule valid_objsE'; fastforce?) - apply (clarsimp simp: valid_obj_def valid_sched_context_def is_tcb obj_at_def) - apply (frule sc_tcb_not_idle_thread'_helper; blast?) - apply (insert valid_idle') - apply (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def projectKOs state_refs_of'_def - live'_def idle_tcb'_def - dest!: sc_tcb_not_idle_thread'_helper if_live_then_nonz_capD') - done - -lemma thread_not_idle_implies_sc_not_idle'_helper: - "\ pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; tcbSchedContext tcb = Some scp; - ksPSpace s' tp = Some (KOTCB tcb); sym_refs (state_refs_of' s') \ - \ (tp, SCTcb) \ state_refs_of' s' scp" - apply (clarsimp simp: state_refs_of'_def - elim!: sym_refsE) - by (simp add: pspace_alignedD' pspace_distinctD' pspace_boundedD') - -lemma thread_not_idle_implies_sc_not_idle': - "\ pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; ksPSpace s' tp = Some (KOTCB tcb); - tp \ idle_thread_ptr; valid_global_refs' s'; valid_objs' s'; - valid_idle' s'; if_live_then_nonz_cap' s'; sym_refs (state_refs_of' s') \ - \ tcbSchedContext tcb \ Some idle_sc_ptr" - apply (frule global'_sc_no_ex_cap) - apply (blast intro: pspace) - apply (rule valid_objsE'; simp?) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def is_sc_obj_def obj_at'_def) - apply (rename_tac ko obj) - apply (case_tac ko; clarsimp simp: projectKOs) - apply (drule (5) thread_not_idle_implies_sc_not_idle'_helper) - apply (drule if_live_then_nonz_capE'[where p=idle_sc_ptr]) - apply (fastforce simp: ko_wp_at'_def live_sc'_def state_refs_of'_def - dest!: thread_not_idle_implies_sc_not_idle_helper) - apply fastforce - done - -lemma state_refs: - "\pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; - pspace_distinct' state'; sym_refs (state_refs_of' s')\ - \ (state_refs_of' state') = (state_refs_of' s')" - apply (rule ext) - apply (clarsimp simp: state_refs_for_state') - apply (rename_tac x) - apply (prop_tac "x \ base_bits", simp) - apply (frule untyped_range_live_idle') - 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) - apply (fastforce simp: ntfn_q_refs_of'_def ko_wp_at'_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') - apply (fastforce simp: state_refs_of'_def) - apply (fastforce simp: ko_wp_at'_def) - apply (frule (6) sc_tcb_not_idle_thread') - apply (fastforce simp: state_refs_of'_def) - apply (clarsimp simp: ko_wp_at'_def live_sc'_def valid_idle'_def) - apply (clarsimp simp: ko_wp_at'_def live_reply'_def) - done - - -lemma list_refs_of_reply'_state': - "\pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; pspace_distinct' state'\ - \ (map_set (replies' ||> list_refs_of_reply')) = (list_refs_of_replies' s')" - apply (rule ext) - apply (clarsimp simp: list_refs_of_replies'_def list_refs_of_reply'_def opt_map_def - split: option.splits) - apply (rename_tac x reply_ptr reply) - apply (prop_tac "x \ base_bits", simp) - apply (frule untyped_range_live_idle') - apply (clarsimp simp: live'_def ko_wp_at'_def live_reply'_def projectKOs) - using pspace_alignedD' pspace_distinctD' pspace_boundedD' apply clarsimp + apply (intro conjI) + apply (rename_tac tcb) + apply (case_tac "tcbState tcb"; clarsimp simp: valid_tcb_state'_def dest!: refs_notRange) + apply (rename_tac tcb) + apply (case_tac "tcbState tcb"; + clarsimp simp: valid_tcb_state'_def valid_bound_ntfn'_def + dest!: refs_notRange split: option.splits) + apply (clarsimp simp: none_top_bool_cases) + apply (rename_tac prev) + apply (cut_tac P=live' and p=prev in live_notRange; fastforce?) + apply (fastforce dest: sym_heapD2[where p'=p] + simp: opt_map_def ko_wp_at'_def obj_at'_def projectKOs) + apply (clarsimp simp: none_top_bool_cases) + apply (rename_tac "next") + apply (cut_tac P=live' and p="next" in live_notRange; fastforce?) + apply (fastforce dest!: sym_heapD1[where p=p] + simp: opt_map_def ko_wp_at'_def obj_at'_def projectKOs) + apply (clarsimp simp: valid_cte'_def) + apply (rule_tac p=p in valid_cap2) + apply (clarsimp simp: ko_wp_at'_def objBits_simps' cte_level_bits_def[symmetric]) + apply (erule(2) cte_wp_at_cteI') + apply simp + apply (rename_tac arch_kernel_object) + apply (case_tac "arch_kernel_object", simp_all) + apply (rename_tac asidpool) + apply (case_tac asidpool, clarsimp simp: page_directory_at'_def) + apply (rename_tac pte) + apply (case_tac pte, simp_all add: valid_mapping'_def) + apply(rename_tac pde) + apply (case_tac pde, simp_all add: valid_mapping'_def) done lemma tcbSchedNexts_of_pspace': @@ -1792,17 +1370,15 @@ lemma exists_disj: by auto lemma (in delete_locale) delete_invs': - assumes "\t. t \ set (ksReleaseQueue s) \ obj_at' (runnable' \ tcbState) t s" - and "sym_refs (state_refs_of' s')" - shows "invs' (ksMachineState_update - (\ms. underlying_memory_update - (\m x. if base \ x \ x \ base + (2 ^ bits - 1) then 0 else m x) ms) - state')" (is "invs' (?state'')") + "invs' (ksMachineState_update + (\ms. underlying_memory_update + (\m x. if base \ x \ x \ base + (2 ^ bits - 1) then 0 else m x) ms) + state')" (is "invs' (?state'')") using vds -proof (simp add: invs'_def valid_pspace'_def (* FIXME: do not simp here *) +proof (simp add: invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def, safe) - interpret Arch . (*FIXME: arch_split*) + interpret Arch . (*FIXME: arch-split*) let ?s = state' let ?ran = base_bits @@ -1813,66 +1389,25 @@ proof (simp add: invs'_def valid_pspace'_def (* FIXME: do not simp here *) by (clarsimp simp add: pspace_distinct'_def ps_clear_def dom_if_None Diff_Int_distrib) - show "pspace_bounded' ?s" using bd - by (simp add: pspace_bounded'_def dom_def) - - show "valid_objs' ?s" using valid_objs assms + show "valid_objs' ?s" using valid_objs sym_sched apply (clarsimp simp: valid_objs'_def ran_def) - apply (insert list_refs pa pd bd) - apply (rule_tac p=a in valid_obj'; fastforce?) - apply (frule pspace_alignedD'[OF _ pa]) - apply (frule pspace_distinctD'[OF _ pd]) - apply (frule pspace_boundedD'[OF _ bd]) - apply (clarsimp simp: ko_wp_at'_def) - done - - show "valid_replies' ?s" using vreplies assms - apply (clarsimp simp: valid_replies'_def simp del: imp_disjL) - apply (prop_tac "rptr \ base_bits") - apply (clarsimp simp: opt_map_def) - apply (drule_tac x=rptr in spec, drule mp) - apply (fastforce simp: opt_map_def) - apply clarsimp - apply (prop_tac "tptr \ base_bits") - apply (rule live_notRange[where P=live']; clarsimp?) - apply (fastforce simp: ko_wp_at'_def pred_tcb_at'_def obj_at'_def projectKOs) - apply (clarsimp simp: pred_tcb_at'_def opt_map_def) - done - - show "sym_refs (map_set (replies' ||> list_refs_of_reply'))" - apply (insert pa pd bd pspace_distinct'_state' list_refs) - by (subst list_refs_of_reply'_state'; blast?) - - from vq show "valid_queues ?s" - apply (clarsimp simp: valid_queues_def bitmapQ_defs) - apply (clarsimp simp: valid_queues_no_bitmap_def) - apply (drule spec, drule spec, drule conjunct1, drule(1) bspec) - apply (clarsimp simp: obj_at'_real_def) - apply (frule if_live_then_nonz_capE'[OF iflive, OF ko_wp_at'_weakenE]) - apply (clarsimp simp: projectKOs inQ_def) - apply (clarsimp dest!: ex_nonz_cap_notRange) + apply (rule_tac p=a in valid_obj') + apply fastforce + apply (frule pspace_alignedD'[OF _ pa]) + apply (frule pspace_distinctD'[OF _ pd]) + apply (clarsimp simp: ko_wp_at'_def) + apply fastforce done - from vq' show "valid_queues' ?s" - by (simp add: valid_queues'_def) - - from rlqrun show "valid_release_queue ?s" - apply (clarsimp simp: valid_release_queue_def) - apply (insert assms vrlq) - apply (drule_tac x=t and P="\t. t \ set (ksReleaseQueue s) - \ obj_at' (runnable' \ tcbState) t s" - in spec) - apply (clarsimp simp: obj_at'_real_def) - apply (drule_tac x=t in spec, simp) - apply (frule live_notRange) - apply (fastforce simp: projectKOs live'_def ko_wp_at'_def obj_at'_def - split: Structures_H.thread_state.splits) - apply (clarsimp simp: valid_release_queue_def obj_at'_real_def) + from sym_refs show "sym_refs (state_refs_of' ?s)" + apply - + apply (clarsimp simp: state_refs_ko_wp_at_eq + elim!: rsubst[where P=sym_refs]) + apply (rule ext) + apply safe + apply (simp add: refs_notRange[simplified] state_refs_ko_wp_at_eq) done - from vrlq' show "valid_release_queue' ?s" - by (simp add: valid_release_queue'_def) - show "if_live_then_nonz_cap' ?s" using iflive apply (clarsimp simp: if_live_then_nonz_cap'_def) apply (drule spec, drule(1) mp) @@ -1892,6 +1427,19 @@ proof (simp add: invs'_def valid_pspace'_def (* FIXME: do not simp here *) apply (simp add: cte_wp_at_ctes_of valid_global_refs'_def valid_refs'_def) apply blast done + with idle show "valid_idle' ?s" + apply (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def projectKOs) + apply (clarsimp simp add: ps_clear_def dom_if_None Diff_Int_distrib) + done + + from tcb_at_invs' [OF invs] ct_act + show "cur_tcb' ?s" unfolding cur_tcb'_def + apply (clarsimp simp: cur_tcb'_def ct_in_state'_def) + apply (drule st_tcb) + apply simp + apply simp + apply (simp add: pred_tcb_at'_def) + done let ?ctes' = ctes' @@ -2015,6 +1563,11 @@ proof (simp add: invs'_def valid_pspace'_def (* FIXME: do not simp here *) apply clarsimp done + show "reply_masters_rvk_fb ?ctes'" + using rep_r_fb + by (simp add: tree_to_ctes reply_masters_rvk_fb_def + ball_ran_eq) + from virqs show "valid_irq_states' s'" . @@ -2030,13 +1583,20 @@ proof (simp add: invs'_def valid_pspace'_def (* FIXME: do not simp here *) show "irqs_masked' state'" by (simp add: irqs_masked'_def) + from sa_simp ct_act + show "sch_act_wf (ksSchedulerAction s') state'" + apply (simp add: sch_act_simple_def) + apply (case_tac "ksSchedulerAction s'", simp_all add: ct_in_state'_def) + apply (fastforce dest!: st_tcb elim!: pred_tcb'_weakenE) + done + from invs - have "pspace_domain_valid s'" by (simp add: invs'_def) + have "pspace_domain_valid s'" by (simp add: invs'_def valid_state'_def) thus "pspace_domain_valid state'" by (simp add: pspace_domain_valid_def) from invs - have "valid_machine_state' s'" by (simp add: invs'_def) + have "valid_machine_state' s'" by (simp add: invs'_def valid_state'_def) thus "valid_machine_state' ?state''" apply (clarsimp simp: valid_machine_state'_def) apply (drule_tac x=p in spec) @@ -2059,10 +1619,42 @@ proof (simp add: invs'_def valid_pspace'_def (* FIXME: do not simp here *) apply (auto simp add: x_power_minus_1) done + from sa_simp ctnotinQ + show "ct_not_inQ state'" + apply (clarsimp simp: ct_not_inQ_def pred_tcb_at'_def) + apply (drule obj_at'_and + [THEN iffD2, OF conjI, + OF ct_act [unfolded ct_in_state'_def pred_tcb_at'_def]]) + apply (clarsimp simp: obj_at'_real_def) + apply (frule if_live_then_nonz_capE'[OF iflive, OF ko_wp_at'_weakenE]) + apply (clarsimp simp: projectKOs) + apply (case_tac "tcbState obj") + apply (clarsimp simp: projectKOs)+ + apply (clarsimp dest!: ex_nonz_cap_notRange) + done + + from ctcd show "ct_idle_or_in_cur_domain' state'" + apply (simp add: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) + apply (intro impI) + apply (elim disjE impE) + apply simp+ + apply (intro impI) + apply (rule disjI2) + apply (drule obj_at'_and + [THEN iffD2, OF conjI, + OF ct_act [unfolded ct_in_state'_def st_tcb_at'_def]]) + apply (clarsimp simp: obj_at'_real_def) + apply (frule if_live_then_nonz_capE'[OF iflive, OF ko_wp_at'_weakenE]) + apply (clarsimp simp: projectKOs) + apply (case_tac "tcbState obj") + apply (clarsimp simp: projectKOs)+ + apply (clarsimp dest!: ex_nonz_cap_notRange elim!: ko_wp_at'_weakenE) + done + from cdm show "ksCurDomain s' \ maxDomain" . from invs - have urz: "untyped_ranges_zero' s'" by (simp add: invs'_def) + have urz: "untyped_ranges_zero' s'" by (simp add: invs'_def valid_state'_def) show "untyped_ranges_zero_inv (cteCaps_of state') (gsUntypedZeroRanges s')" apply (simp add: untyped_zero_ranges_cte_def @@ -2130,6 +1722,7 @@ lemma deleteObjects_null_filter: and K (bits < word_bits \ is_aligned ptr bits)\ deleteObjects ptr bits \\rv s. P (null_filter' (ctes_of s))\" + apply (simp add: deleteObjects_def3) apply (simp add: deleteObjects_def3 doMachineOp_def split_def) apply wp apply clarsimp @@ -2141,7 +1734,6 @@ lemma deleteObjects_null_filter: apply (subgoal_tac "ksPSpace (s\ksMachineState := snd ((), b)\) = ksPSpace s", simp only:, simp) apply (unfold_locales, simp_all) - apply (clarsimp simp: deletionIsSafe_def sym_refs_asrt_def valid_idle'_asrt_def)+ done lemma deleteObjects_descendants: @@ -2163,8 +1755,7 @@ lemma doMachineOp_modify: apply (rule ext) apply (simp add: simpler_gets_def simpler_modify_def bind_def) done - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma deleteObjects_invs': "\cte_wp_at' (\c. cteCap c = UntypedCap d ptr bits idx) p and invs' and ct_active' and sch_act_simple @@ -2186,11 +1777,8 @@ proof - apply (simp cong: if_cong) apply (subgoal_tac "is_aligned ptr bits \ 2 \ 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 (rule subst[rotated, where P=invs'], erule delete_locale.delete_invs') - apply (clarsimp simp: deletionIsSafe_def) - apply blast - apply blast + apply (frule(2) delete_locale.intro, simp_all)[1] + apply (rule subst[rotated, where P=invs'], erule delete_locale.delete_invs') apply (simp add: field_simps) apply clarsimp apply (drule invs_valid_objs') @@ -2220,12 +1808,12 @@ lemma deleteObjects_st_tcb_at': apply (fastforce elim: ko_wp_at'_weakenE) apply (erule if_live_then_nonz_capD' [rotated]) apply (clarsimp simp: projectKOs) - apply (clarsimp simp: invs'_def) + apply (clarsimp simp: invs'_def valid_state'_def) apply (clarsimp simp: pred_tcb_at'_def obj_at'_real_def 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) done lemma deleteObjects_cap_to': @@ -2251,14 +1839,14 @@ 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) done lemma valid_untyped_no_overlap: "\ valid_untyped' d ptr bits idx s; is_aligned ptr bits; valid_pspace' s \ \ pspace_no_overlap' ptr bits (s\ksPSpace := ksPSpace s |` (- {ptr .. ptr + 2 ^ bits - 1})\)" apply (clarsimp simp del: atLeastAtMost_iff - simp: pspace_no_overlap'_def valid_cap'_def valid_untyped'_def) + simp: pspace_no_overlap'_def valid_cap'_def valid_untyped'_def is_aligned_neg_mask_eq) apply (drule_tac x=x in spec) apply (drule restrict_map_Some_iff[THEN iffD1]) apply clarsimp @@ -2266,8 +1854,6 @@ lemma valid_untyped_no_overlap: apply (simp add: valid_pspace'_def) apply (frule pspace_distinctD') apply (simp add: valid_pspace'_def) - apply (frule pspace_boundedD') - apply (simp add: valid_pspace'_def) apply (unfold ko_wp_at'_def obj_range'_def) apply (drule (1) aligned_ranges_subset_or_disjoint) apply (clarsimp simp del: Int_atLeastAtMost atLeastAtMost_iff atLeastatMost_subset_iff) @@ -2334,19 +1920,13 @@ lemma deleteObjects_invs_derivatives: and (\s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) and K (bits < word_bits \ is_aligned ptr bits)\ deleteObjects ptr bits - \\rv. pspace_aligned'\" - "\cte_wp_at' (\c. cteCap c = UntypedCap d ptr bits idx) p - and invs' and ct_active' and sch_act_simple - and (\s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) - and K (bits < word_bits \ is_aligned ptr bits)\ - deleteObjects ptr bits - \\rv. pspace_distinct'\" + \\rv. pspace_aligned'\" "\cte_wp_at' (\c. cteCap c = UntypedCap d ptr bits idx) p and invs' and ct_active' and sch_act_simple and (\s. descendants_range' (UntypedCap d ptr bits idx) p (ctes_of s)) and K (bits < word_bits \ is_aligned ptr bits)\ deleteObjects ptr bits - \\rv. pspace_bounded'\" + \\rv. pspace_distinct'\" by (safe intro!: hoare_strengthen_post [OF deleteObjects_invs']) lemma deleteObjects_nosch: @@ -2371,45 +1951,35 @@ definition pspace_no_overlap_cell' where lemma pspace_no_overlap'_lift: assumes typ_at:"\slot P Q. \\s. P (typ_at' Q slot s)\ f \\r s. P (typ_at' Q slot s) \" - assumes sz: "\p n. \\s. sc_at'_n n p s\ f \\rv s. sc_at'_n n p s\" - assumes ps :"\Q and pspace_aligned' and pspace_distinct' and pspace_bounded'\ - f \\r s. pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\" - shows "\Q and pspace_aligned' and pspace_distinct' and pspace_bounded' and pspace_no_overlap' ptr sz\ - f \\r. pspace_no_overlap' ptr sz\" + assumes ps :"\Q\ f \\r s. pspace_aligned' s \ pspace_distinct' s \" + shows "\Q and pspace_no_overlap' ptr sz \ f \\r. pspace_no_overlap' ptr sz\" proof - - note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps + note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex show ?thesis apply (clarsimp simp:valid_def pspace_no_overlap'_def) apply (drule_tac x = x in spec) apply (subgoal_tac "\ko'. ksPSpace s x = Some ko' \ koTypeOf ko = koTypeOf ko'") - apply (clarsimp, frule koType_objBitsKO; clarsimp) - apply (frule_tac p1=x and n1="objBitsKO ko'" in use_valid[OF _ sz]) - apply (fastforce simp: ko_wp_at'_def dest: pspace_alignedD' pspace_distinctD' pspace_boundedD') - apply (clarsimp simp: ko_wp_at'_def) + apply (clarsimp dest!:objBits_type) apply (rule ccontr) apply clarsimp apply (frule_tac slot1 = x and Q1 = "koTypeOf ko" and P1 = "\a. \ a" in use_valid[OF _ typ_at]) - apply (clarsimp simp:typ_at'_def ko_wp_at'_def)+ - apply (frule use_valid[OF _ ps]) - apply (clarsimp simp:valid_pspace'_def)+ + apply (clarsimp simp:typ_at'_def ko_wp_at'_def)+ + apply (frule(1) use_valid[OF _ ps]) + apply (clarsimp simp:valid_pspace'_def) apply (frule(1) pspace_alignedD') - apply (frule(1) pspace_distinctD') - apply (drule(1) pspace_boundedD') + apply (drule(1) pspace_distinctD') apply simp - done + done qed -lemmas pspace_no_overlap'_lift2 = pspace_no_overlap'_lift[where Q=\, simplified] - -crunch setCTE, insertNewCap - for sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - (simp: crunch_simps wp: crunch_wps) - lemma setCTE_pspace_no_overlap': - "\pspace_aligned' and pspace_distinct' and pspace_bounded' and pspace_no_overlap' ptr sz\ + "\pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\ setCTE cte src \\r. pspace_no_overlap' ptr sz\" - by (rule pspace_no_overlap'_lift2; wpsimp wp: setCTE_typ_at') + apply (rule pspace_no_overlap'_lift; wp setCTE_typ_at') + apply auto + done lemma getCTE_commute: assumes cte_at_modify: @@ -2457,12 +2027,12 @@ qed definition "cte_check \ \b src a next. (case b of KOTCB tcb \ (is_aligned a (objBits tcb) - \ (case next of None \ True | Some z \ 2^objBits tcb \ z - a)) \ + \ (case next of None \ True | Some z \ 2^(objBits tcb) \ z - a)) \ (src - a = tcbVTableSlot << cteSizeBits \ src - a = tcbCTableSlot << cteSizeBits - \ src - a = tcbIPCBufferSlot << cteSizeBits - \ src - a = tcbFaultHandlerSlot << cteSizeBits - \ src - a = tcbTimeoutHandlerSlot << cteSizeBits) + \ src - a = tcbReplySlot << cteSizeBits + \ src - a = tcbCallerSlot << cteSizeBits + \ src - a = tcbIPCBufferSlot << cteSizeBits ) | KOCTE v1 \ ( src = a \ (is_aligned a (objBits (makeObject::cte))) \ (case next of None \ True | Some z \ 2^(objBits (makeObject::cte)) \ z - a)) | _ \ False)" @@ -2478,11 +2048,11 @@ definition locateCTE where definition cte_update where "cte_update \ \cte b src a. (case b of - KOTCB tcb \ if src - a = tcbVTableSlot << cteSizeBits then KOTCB (tcbVTable_update (\_. cte) tcb) - else if src - a = tcbCTableSlot << cteSizeBits then KOTCB (tcbCTable_update (\_. cte) tcb) - else if src - a = tcbIPCBufferSlot << cteSizeBits then KOTCB (tcbIPCBufferFrame_update (\_. cte) tcb) - else if src - a = tcbFaultHandlerSlot << cteSizeBits then KOTCB (tcbFaultHandler_update (\_. cte) tcb) - else if src - a = tcbTimeoutHandlerSlot << cteSizeBits then KOTCB (tcbTimeoutHandler_update (\_. cte) tcb) + KOTCB tcb \ if (src - a = tcbVTableSlot << cteSizeBits) then KOTCB (tcbVTable_update (\_. cte) tcb) + else if (src - a = tcbCTableSlot << cteSizeBits) then KOTCB (tcbCTable_update (\_. cte) tcb) + else if (src - a = tcbReplySlot << cteSizeBits) then KOTCB (tcbReply_update (\_. cte) tcb) + else if (src - a = tcbCallerSlot << cteSizeBits) then KOTCB (tcbCaller_update (\_. cte) tcb) + else if (src - a = tcbIPCBufferSlot << cteSizeBits) then KOTCB (tcbIPCBufferFrame_update (\_. cte) tcb) else KOTCB tcb | KOCTE v1 \ KOCTE cte | x \ x)" @@ -2492,15 +2062,21 @@ lemma simpler_updateObject_def: (\s. (if (cte_check b src a next) then ({(cte_update cte b src a,s)}, False) else fail s))" apply (rule ext) - apply (clarsimp simp: ObjectInstances_H.updateObject_cte objBits_simps) - apply (case_tac b; simp add: cte_check_def typeError_def fail_def tcbSlot_defs cteSizeBits_def) - by (intro conjI; - clarsimp simp: alignCheck_def unless_def when_def not_less[symmetric] - alignError_def is_aligned_mask magnitudeCheck_def assert_def - cte_update_def return_def tcbSlot_defs objBits_simps cteSizeBits_def - read_alignCheck_def ounless_def read_magnitudeCheck_def read_alignError_def - split:option.splits; - fastforce simp:return_def fail_def bind_def)+ + apply (clarsimp simp:ObjectInstances_H.updateObject_cte objBits_simps) + apply (case_tac b) + apply (simp_all add:cte_check_def typeError_def fail_def + tcbIPCBufferSlot_def + tcbCallerSlot_def tcbReplySlot_def + tcbCTableSlot_def tcbVTableSlot_def) + by (intro conjI impI; + clarsimp simp:alignCheck_def unless_def when_def not_less[symmetric] + alignError_def is_aligned_mask magnitudeCheck_def + cte_update_def return_def tcbIPCBufferSlot_def + tcbCallerSlot_def tcbReplySlot_def + tcbCTableSlot_def tcbVTableSlot_def objBits_simps + cteSizeBits_def split:option.splits; + fastforce simp:return_def fail_def bind_def)+ + lemma setCTE_def2: "(setCTE src cte) = @@ -2529,9 +2105,10 @@ lemma pspace_no_overlapD3': lemma singleton_locateCTE: "a \ fst (locateCTE src s) = ({a} = fst (locateCTE src s))" - apply (clarsimp simp: locateCTE_def assert_opt_def assert_def gets_def get_def bind_def return_def - split_def) - apply (clarsimp simp: return_def fail_def split: if_splits option.splits)+ + apply (clarsimp simp:locateCTE_def assert_opt_def assert_def + gets_def get_def bind_def return_def split_def) + apply (clarsimp simp:return_def fail_def + split:if_splits option.splits)+ done lemma locateCTE_inv: @@ -2552,19 +2129,35 @@ lemma locateCTE_case: done lemma cte_wp_at_top: - "cte_wp_at' \ src s - = (\a b. fst (lookupAround2 src (ksPSpace s)) = Some (a, b) \ - cte_check b src a (snd (lookupAround2 src (ksPSpace s))))" - apply (simp add: cte_wp_at'_def getObject_def gets_def get_def bind_def return_def split_def - assert_opt_def fail_def gets_the_def readObject_def omonad_defs obind_def - split: option.splits) - apply (clarsimp simp: loadObject_cte) - by (case_tac b; - simp add: typeError_def read_typeError_def obind_def omonad_defs cte_check_def - read_alignCheck_def read_magnitudeCheck_def read_alignError_def is_aligned_mask - objBits_simps tcbSlot_defs cteSizeBits_def - split: option.split; - fastforce) + "(cte_wp_at' \ src s) + = (\a b. ( fst (lookupAround2 src (ksPSpace s)) = Some (a, b) \ + cte_check b src a (snd (lookupAround2 src (ksPSpace s)))))" + apply (simp add:cte_wp_at'_def getObject_def gets_def + get_def bind_def return_def split_def + assert_opt_def fail_def + split:option.splits) + apply (clarsimp simp:loadObject_cte) + apply (case_tac b,simp_all) + apply ((simp add: typeError_def fail_def cte_check_def + split: Structures_H.kernel_object.splits)+)[5] + apply (simp add:loadObject_cte cte_check_def + tcbIPCBufferSlot_def tcbCallerSlot_def + tcbReplySlot_def tcbCTableSlot_def + tcbVTableSlot_def objBits_simps cteSizeBits_def) + apply (simp add:alignCheck_def bind_def + alignError_def fail_def return_def objBits_simps + magnitudeCheck_def in_monad is_aligned_mask + when_def unless_def split:option.splits) + apply (intro conjI impI allI,simp_all add:not_le) + apply (clarsimp simp:cte_check_def) + apply (simp add:alignCheck_def bind_def + alignError_def fail_def return_def objBits_simps + magnitudeCheck_def in_monad is_aligned_mask + when_def unless_def split:option.splits) + apply (intro conjI impI allI,simp_all add:not_le) + apply (simp add:typeError_def fail_def + cte_check_def split:Structures_H.kernel_object.splits)+ + done lemma locateCTE_monad: assumes ko_wp_at: "\Q dest. @@ -2577,12 +2170,9 @@ lemma locateCTE_monad: "\\s. P3 s \ f \\a s. pspace_distinct' s\" assumes psp_aligned: "\\s. P4 s \ f \\a s. pspace_aligned' s\" - assumes psp_bounded: - "\\s. P5 s \ f \\a s. pspace_bounded' s\" shows "\{(ptr, s)} = fst (locateCTE src s); - (r, s') \ fst (f s);pspace_aligned' s;pspace_distinct' s; pspace_bounded' s; - (P1 and P2 and P3 and P4 and P5) s\ + (r, s') \ fst (f s);pspace_aligned' s;pspace_distinct' s;(P1 and P2 and P3 and P4) s\ \ {(ptr,s')} = fst (locateCTE src s')" proof - have src_in_range: @@ -2591,16 +2181,20 @@ proof - fix obj src a m show "\s'. \cte_check obj src a m; ksPSpace s' a = Some obj\ \ src \ {a..a + 2 ^ objBitsKO obj - 1}" by (case_tac obj) - (auto simp add: cte_check_def objBits_simps' diff_eq_eq add.commute[where b=a] - word_plus_mono_right is_aligned_no_wrap' tcbSlot_defs) + (auto simp add: cte_check_def objBits_simps' diff_eq_eq + add.commute[where b=a] + word_plus_mono_right is_aligned_no_wrap' + tcbVTableSlot_def tcbCTableSlot_def tcbReplySlot_def + tcbCallerSlot_def tcbIPCBufferSlot_def ) qed - note blah[simp del] = usableUntypedRange.simps atLeastAtMost_simps + note blah[simp del] = usableUntypedRange.simps atLeastAtMost_iff + atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex have step1: "\(ptr, s) \ fst (locateCTE src s); - (r, s') \ fst (f s); pspace_aligned' s; pspace_distinct' s; pspace_bounded' s; - (P1 and P2 and P3 and P4 and P5) s\ + (r, s') \ fst (f s); pspace_aligned' s; pspace_distinct' s; (P1 and P2 and P3 and P4) s\ \ (ptr,s') \ fst (locateCTE src s')" apply (frule use_valid[OF _ locateCTE_case]) apply simp @@ -2616,7 +2210,6 @@ proof - apply (frule_tac dest1 = ptr and Q1 = "\x. x = objBitsKO b" in use_valid[OF _ ko_wp_at]) apply (frule(1) pspace_alignedD') apply (frule(1) pspace_distinctD') - apply (frule(1) pspace_boundedD') apply (auto simp add:ko_wp_at'_def)[1] apply (clarsimp simp add:ko_wp_at'_def) apply (rule ccontr) @@ -2624,8 +2217,6 @@ proof - apply simp apply (frule use_valid[OF _ psp_aligned]) apply simp - apply (frule use_valid[OF _ psp_bounded]) - apply simp apply (frule_tac x = a in pspace_distinctD') apply simp apply (frule_tac s = s' and a = ptr in rule_out_intv[rotated]) @@ -2638,11 +2229,10 @@ proof - apply (drule(1) src_in_range)+ apply (drule base_member_set[OF pspace_alignedD']) apply simp - apply (simp add: word_bits_def) - apply (frule base_member_set[OF pspace_alignedD']) + apply (simp add:objBitsKO_bounded2[unfolded word_bits_def,simplified]) + apply (drule base_member_set[OF pspace_alignedD']) apply simp - apply (fold word_bits_def) - apply (erule (1) pspace_boundedD') + apply (simp add:objBitsKO_bounded2[unfolded word_bits_def,simplified]) apply (clarsimp simp: field_simps) apply (elim disjE; fastforce simp: mask_def p_assoc_help) done @@ -2651,8 +2241,7 @@ proof - "(r, s') \ fst (f s)" "pspace_aligned' s" "pspace_distinct' s" - "pspace_bounded' s" - "(P1 and P2 and P3 and P4 and P5) s" + "(P1 and P2 and P3 and P4) s" thus ?thesis using assms step1 by (clarsimp simp:singleton_locateCTE) @@ -2672,17 +2261,14 @@ lemma locateCTE_commute: assumes nf: "no_fail P0 f" "no_fail P1 (locateCTE src)" and psp_distinct: "\\s. P2 s \ f \\a s. pspace_distinct' s\" and psp_aligned: "\\s. P3 s \ f \\a s. pspace_aligned' s\" - and psp_bounded: "\\s. P4 s \ f \\a s. pspace_bounded' s\" assumes ko_wp_at: "\Q dest. \\s. (P0 and P1 and P2 and P3) s \ ko_wp_at' (\obj. Q (objBitsKO obj)) dest s \ f \\a s. ko_wp_at' (\obj. Q (objBitsKO obj)) dest s\" and cte_wp_at: "\ dest. \\s. (P0 and P1 and P2 and P3) s \ cte_wp_at' \ dest s \ f \\a s. cte_wp_at' \ dest s\" - shows "monad_commute - (P0 and P1 and P2 and P3 and P4 and P5 - and pspace_aligned' and pspace_distinct' and pspace_bounded') - (locateCTE src) f" + shows "monad_commute (P0 and P1 and P2 and P3 and P4 and P5 and pspace_aligned' and pspace_distinct') + (locateCTE src) f" proof - have same: "\ptr val next s s'. (ptr, s') \ fst (locateCTE src s) @@ -2697,7 +2283,7 @@ proof - apply (clarsimp) apply (rule bexI[rotated], assumption) apply (frule singleton_locateCTE[THEN iffD1]) - apply (frule locateCTE_monad [OF ko_wp_at cte_wp_at psp_distinct psp_aligned psp_bounded]) + apply (frule locateCTE_monad [OF ko_wp_at cte_wp_at psp_distinct psp_aligned]) apply assumption+ apply simp apply (clarsimp) @@ -2713,7 +2299,7 @@ proof - apply (frule_tac s = s in same) apply clarsimp apply (frule_tac s1 = s in singleton_locateCTE[THEN iffD1]) - apply (frule locateCTE_monad [OF ko_wp_at cte_wp_at psp_distinct psp_aligned psp_bounded]) + apply (frule locateCTE_monad [OF ko_wp_at cte_wp_at psp_distinct psp_aligned]) apply assumption+ apply simp apply (rule bexI[rotated],assumption) @@ -2735,7 +2321,7 @@ proof - apply (frule same) apply simp apply (frule singleton_locateCTE[THEN iffD1]) - apply (frule locateCTE_monad [OF ko_wp_at cte_wp_at psp_distinct psp_aligned psp_bounded]) + apply (frule locateCTE_monad [OF ko_wp_at cte_wp_at psp_distinct psp_aligned]) apply assumption+ apply simp apply (clarsimp) @@ -2754,28 +2340,31 @@ lemma createObject_cte_wp_at': "\\s. Types_H.getObjectSize ty us < word_bits \ is_aligned ptr (Types_H.getObjectSize ty us) \ pspace_no_overlap' ptr (Types_H.getObjectSize ty us) s \ - (ty = APIObjectType SchedContextObject \ sc_size_bounds us) \ - cte_wp_at' (\c. P c) slot s \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ + cte_wp_at' (\c. P c) slot s \ pspace_aligned' s \ + pspace_distinct' s\ RetypeDecls_H.createObject ty ptr us d \\r s. cte_wp_at' (\c. P c) slot s \" apply (simp add:createObject_def) apply (rule hoare_pre) - by (wpc - | wp createObjects_orig_cte_wp_at'[where sz = "(Types_H.getObjectSize ty us)"] - threadSet_cte_wp_at' - | simp add: ARM_H.createObject_def placeNewDataObject_def unless_def placeNewObject_def2 - objBits_simps range_cover_full curDomain_def pageBits_def ptBits_def pdBits_def - getObjSize_simps archObjSize_def apiGetObjectSize_def tcbBlockSizeBits_def - epSizeBits_def ntfnSizeBits_def scBits_simps cteSizeBits_def pteBits_def pdeBits_def - | intro conjI impI | clarsimp dest!: arch_toAPIType_simps)+ + apply (wpc + | wp createObjects_orig_cte_wp_at'[where sz = "(Types_H.getObjectSize ty us)"] + threadSet_cte_wp_at' + | simp add: ARM_H.createObject_def placeNewDataObject_def + unless_def placeNewObject_def2 objBits_simps range_cover_full + curDomain_def pageBits_def ptBits_def + pdBits_def getObjSize_simps archObjSize_def + apiGetObjectSize_def tcbBlockSizeBits_def + epSizeBits_def ntfnSizeBits_def + cteSizeBits_def pteBits_def pdeBits_def + | intro conjI impI | clarsimp dest!: arch_toAPIType_simps)+ + done lemma createObject_getCTE_commute: "monad_commute - (cte_wp_at' (\_. True) dests and pspace_aligned' and pspace_distinct' and pspace_bounded' and + (cte_wp_at' (\_. True) dests and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and K (ptr \ dests) and K (Types_H.getObjectSize ty us < word_bits) and - K (is_aligned ptr (Types_H.getObjectSize ty us)) and - K (ty = APIObjectType SchedContextObject \ sc_size_bounds us)) + K (is_aligned ptr (Types_H.getObjectSize ty us))) (RetypeDecls_H.createObject ty ptr us d) (getCTE dests)" apply (rule monad_commute_guard_imp[OF commute_commute]) apply (rule getCTE_commute) @@ -2803,7 +2392,7 @@ lemma simpler_placeNewObject_def: apply clarsimp apply (drule(1) pspace_alignedD') apply (simp add:is_aligned_no_overflow) - apply (clarsimp simp: shiftL_nat p_assoc_help) + apply (clarsimp simp: is_aligned_neg_mask_eq shiftL_nat p_assoc_help) apply simp done @@ -2812,17 +2401,15 @@ lemma fail_set: "fst (fail s) = {}" lemma locateCTE_cte_no_fail: "no_fail (cte_at' src) (locateCTE src)" - apply (clarsimp simp: no_fail_def cte_wp_at'_def getObject_def - locateCTE_def return_def gets_def get_def bind_def split_def - gets_the_def readObject_def omonad_defs obind_def - assert_opt_def assert_def fail_set - split: option.splits) + apply (clarsimp simp:no_fail_def cte_wp_at'_def getObject_def + locateCTE_def return_def gets_def get_def bind_def split_def + assert_opt_def assert_def in_fail fail_set split:option.splits) apply (clarsimp simp:cte_check_def ObjectInstances_H.loadObject_cte) + apply (drule in_singleton) by (auto simp: objBits_simps cteSizeBits_def alignError_def - alignCheck_def in_monad is_aligned_mask magnitudeCheck_def - typeError_def read_typeError_def read_magnitudeCheck_def - ohaskell_fail_def ohaskell_assert_def - cong: if_cong split: if_splits option.splits kernel_object.splits) + alignCheck_def in_monad is_aligned_mask magnitudeCheck_def + typeError_def + cong: if_cong split: if_splits option.splits kernel_object.splits) lemma not_in_new_cap_addrs: "\is_aligned ptr (objBitsKO obj + us); @@ -2849,14 +2436,14 @@ lemma not_in_new_cap_addrs: lemma placeNewObject_pspace_aligned': "\K (is_aligned ptr (objBitsKO (injectKOS val) + us) \ objBitsKO (injectKOS val) + us < word_bits) and - pspace_aligned' and pspace_distinct' and pspace_bounded' and + pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us)\ placeNewObject ptr val us \\r s. pspace_aligned' s\" apply (clarsimp simp:valid_def) apply (simp add:simpler_placeNewObject_def simpler_modify_def) apply (subst data_map_insert_def[symmetric])+ - apply (erule (3) Retype_R.retype_aligned_distinct' [unfolded data_map_insert_def[symmetric]]) + apply (erule(2) Retype_R.retype_aligned_distinct' [unfolded data_map_insert_def[symmetric]]) apply (rule range_cover_rel[OF range_cover_full]) apply simp+ done @@ -2865,28 +2452,14 @@ lemma placeNewObject_pspace_distinct': "\\s. objBitsKO (injectKOS val) + us < word_bits \ is_aligned ptr (objBitsKO (injectKOS val) + us) \ pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ + pspace_aligned' s \ pspace_distinct' s\ placeNewObject ptr val us \\a. pspace_distinct'\" apply (clarsimp simp:valid_def) apply (simp add:simpler_placeNewObject_def simpler_modify_def) apply (subst data_map_insert_def[symmetric])+ - apply (erule (3) Retype_R.retype_aligned_distinct'[unfolded data_map_insert_def[symmetric]]) - apply (rule range_cover_rel[OF range_cover_full]) - apply simp+ - done - -lemma placeNewObject_pspace_bounded': - "\\s. objBitsKO (injectKOS val) + us < word_bits \ - is_aligned ptr (objBitsKO (injectKOS val) + us) \ - pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ - placeNewObject ptr val us - \\a. pspace_bounded'\" - apply (clarsimp simp:valid_def) - apply (simp add:simpler_placeNewObject_def simpler_modify_def) - apply (subst data_map_insert_def[symmetric])+ - apply (erule (3) Retype_R.retype_aligned_distinct'[unfolded data_map_insert_def[symmetric]]) + apply (erule(2) Retype_R.retype_aligned_distinct' + [unfolded data_map_insert_def[symmetric]]) apply (rule range_cover_rel[OF range_cover_full]) apply simp+ done @@ -2898,7 +2471,7 @@ lemma placeNewObject_ko_wp_at': objBitsKO (injectKOS val) + us < word_bits \ is_aligned ptr (objBitsKO (injectKOS val) + us) \ pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ + pspace_aligned' s \ pspace_distinct' s\ placeNewObject ptr val us \\a. ko_wp_at' P slot\" apply (clarsimp simp:valid_def split del:if_split) @@ -2937,7 +2510,7 @@ lemma placeNewObject_cte_wp_at': "\K (is_aligned ptr (objBitsKO (injectKOS val) + us) \ objBitsKO (injectKOS val) + us < word_bits) and K (ptr \ src) and cte_wp_at' P src and - pspace_aligned' and pspace_distinct' and pspace_bounded' and + pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us)\ placeNewObject ptr val us \\r s. cte_wp_at' P src s\" @@ -2952,7 +2525,7 @@ lemma placeNewObject_cte_wp_at'': objBitsKO (injectKOS val) + us < word_bits \ is_aligned ptr (objBitsKO (injectKOS val) + us) \ pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) s \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ + pspace_aligned' s \ pspace_distinct' s\ placeNewObject ptr val us \\a s. cte_wp_at' P slot s\" apply (simp add:cte_wp_at_cases_mask' obj_at'_real_def) apply (wp hoare_vcg_disj_lift placeNewObject_ko_wp_at') @@ -2982,14 +2555,13 @@ lemma placeNewObject_locateCTE_commute: (K (is_aligned ptr (objBitsKO (injectKOS val) + us) \ (objBitsKO (injectKOS val) + us) < word_bits \ ptr \ src) and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and - pspace_aligned' and pspace_distinct' and pspace_bounded' and cte_at' src) + pspace_aligned' and pspace_distinct' and cte_at' src) (placeNewObject ptr val us) (locateCTE src)" apply (rule monad_commute_guard_imp) apply (rule commute_commute[OF locateCTE_commute]) apply (wp no_fail_placeNewObject locateCTE_cte_no_fail placeNewObject_pspace_aligned' placeNewObject_pspace_distinct' - placeNewObject_pspace_bounded' placeNewObject_ko_wp_at' | simp)+ apply (clarsimp simp:ko_wp_at'_def) apply (drule(3) not_in_new_cap_addrs) @@ -3054,7 +2626,8 @@ lemma placeNewObject_modify_commute: apply simp apply (drule_tac x = ptr' in in_empty_interE) apply (clarsimp simp:is_aligned_no_overflow) - apply (clarsimp simp:range_cover_def ptr_add_def obj_range'_def p_assoc_help) + apply (clarsimp simp:range_cover_def ptr_add_def + is_aligned_neg_mask_eq obj_range'_def p_assoc_help) apply simp done @@ -3080,9 +2653,9 @@ lemma locateCTE_ko_wp_at': \\rv. ko_wp_at' \ rv \" apply (clarsimp simp:locateCTE_def split_def) apply wp - apply (clarsimp simp: cte_wp_at'_def getObject_def gets_the_def obind_def omonad_defs - gets_def split_def get_def bind_def return_def readObject_def - ko_wp_at'_def lookupAround2_char1 assert_opt_def) + apply (clarsimp simp:cte_wp_at'_def getObject_def + gets_def split_def get_def bind_def return_def + ko_wp_at'_def lookupAround2_char1 assert_opt_def) apply (clarsimp split:option.splits simp:fail_def return_def lookupAround2_char1) apply (case_tac ba) @@ -3090,10 +2663,10 @@ lemma locateCTE_ko_wp_at': apply (clarsimp simp:lookupAround2_char1 objBits_simps cte_update_def) apply (drule(1) pspace_distinctD')+ - apply (simp add: objBits_simps' word_bits_def) + apply (simp add:objBits_simps) apply (clarsimp simp:objBits_simps cte_update_def) apply (drule(1) pspace_distinctD')+ - apply (simp add: objBits_simps' word_bits_def) + apply (simp add:objBits_simps) done @@ -3102,7 +2675,7 @@ lemma setCTE_placeNewObject_commute: (K (is_aligned ptr (objBitsKO (injectKOS val) + us) \ objBitsKO (injectKOS val) + us < word_bits) and K(ptr \ src) and cte_wp_at' (\_. True) src and - pspace_aligned' and pspace_distinct' and pspace_bounded' and + pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us)) (setCTE src cte) (placeNewObject ptr val us)" apply (clarsimp simp: setCTE_def2 split_def) @@ -3122,29 +2695,65 @@ lemma doMachineOp_upd_heap_commute: done lemma magnitudeCheck_det: - "\ksPSpace s ptr = Some ko; is_aligned ptr (objBitsKO ko); objBitsKO ko < word_bits; + "\ksPSpace s ptr = Some ko; is_aligned ptr (objBitsKO ko); ps_clear ptr (objBitsKO ko) s\ - \ magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) (objBitsKO ko) s = + \ magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) + (objBitsKO ko) s = ({((), s)},False)" - apply (frule in_magnitude_check'[THEN iffD2]; simp) - apply (subgoal_tac "\ snd (magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) (objBitsKO ko) s)") + apply (frule in_magnitude_check'[THEN iffD2]) + apply (case_tac ko) + apply (simp add: objBits_simps' pageBits_def)+ + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object) + apply (simp add:archObjSize_def pageBits_def pteBits_def pdeBits_def)+ + apply (subgoal_tac + "\ snd (magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) (objBitsKO ko) s)") apply (drule singleton_in_magnitude_check) apply (drule_tac x = s in spec) - apply (case_tac "(magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) (objBitsKO ko) s)") - apply simp + apply (case_tac + "(magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) (objBitsKO ko) s)") + apply simp apply (rule ccontr) - apply (clarsimp simp: magnitudeCheck_assert assert_def fail_def return_def - split: if_splits option.splits) + apply (clarsimp simp:magnitudeCheck_assert assert_def fail_def return_def + split:if_splits option.splits) done lemma getPDE_det: "ko_wp_at' ((=) (KOArch (KOPDE pde))) p s \ getObject p s = ({((pde::ARM_H.pde),s)},False)" - by (clarsimp simp: getObject_def split_def gets_the_def ko_wp_at'_def obj_at'_def - bind_def gets_def return_def get_def projectKOs - assert_opt_def fail_def typ_at'_def - no_ofailD[OF no_ofail_pde_at'_readObject] - split: if_splits option.splits) + apply (clarsimp simp:ko_wp_at'_def getObject_def split_def + bind_def gets_def return_def get_def + assert_opt_def split:if_splits) + + apply (clarsimp simp: fail_def return_def lookupAround2_known1) + apply (simp add: loadObject_default_def) + apply (clarsimp simp:projectKO_def projectKO_opt_pde alignCheck_def + is_aligned_mask objBits_simps unless_def) + apply (clarsimp simp:bind_def return_def) + apply (intro conjI) + apply (intro set_eqI iffI) + apply clarsimp + apply (subst (asm) in_magnitude_check') + apply (simp add:archObjSize_def is_aligned_mask pteBits_def pdeBits_def)+ + apply (rule bexI[rotated]) + apply (rule in_magnitude_check'[THEN iffD2]) + apply (simp add:is_aligned_mask)+ + apply (clarsimp simp:image_def) + apply (clarsimp simp:magnitudeCheck_assert assert_def + objBits_def archObjSize_def + return_def fail_def lookupAround2_char2 split:option.splits if_split_asm) + apply (rule ccontr) + apply (simp add:ps_clear_def field_simps pteBits_def pdeBits_def) + apply (erule_tac x = x2 in in_empty_interE) + apply (clarsimp simp:less_imp_le) + apply (rule conjI) + apply (subst add.commute) + apply (rule word_diff_ls') + apply (clarsimp simp: not_le plus_one_helper) + apply (subst add.commute) + apply (simp add: is_aligned_no_wrap' is_aligned_mask) + apply auto + done lemma in_dom_eq: "m a = Some obj \ dom (\b. if b = a then Some g else m b) = dom m" @@ -3223,7 +2832,7 @@ lemma getPDE_doMachineOp_commute: lemma getPDE_placeNewObject_commute: "monad_commute - (pde_at' src and pspace_distinct' and pspace_aligned' and pspace_bounded' and + (pde_at' src and pspace_distinct' and pspace_aligned' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + sz) and K (is_aligned ptr (objBitsKO (injectKOS val) + sz) \ objBitsKO (injectKOS val) + sz < word_bits) ) @@ -3259,15 +2868,15 @@ lemma storePDE_det: \ storePDE ptr (new_pde::ARM_H.pde) s = modify (ksPSpace_update (\_. (ksPSpace s)(ptr \ KOArch (KOPDE new_pde)))) s" - apply (clarsimp simp: ko_wp_at'_def storePDE_def split_def - bind_def gets_def return_def - get_def setObject_def - assert_opt_def split:if_splits) - apply (clarsimp simp: lookupAround2_known1 return_def alignCheck_def - updateObject_default_def split_def gets_the_def - archObjSize_def unless_def projectKO_def read_alignCheck_def - projectKO_opt_pde bind_def when_def omonad_defs - is_aligned_mask[symmetric] objBits_simps) + apply (clarsimp simp:ko_wp_at'_def storePDE_def split_def + bind_def gets_def return_def + get_def setObject_def + assert_opt_def split:if_splits) + apply (clarsimp simp:lookupAround2_known1 return_def alignCheck_def + updateObject_default_def split_def + archObjSize_def unless_def projectKO_def + projectKO_opt_pde bind_def when_def + is_aligned_mask[symmetric] objBits_simps) apply (drule magnitudeCheck_det) apply (simp add:objBits_simps archObjSize_def)+ apply (simp add:simpler_modify_def) @@ -3350,28 +2959,13 @@ lemma modify_pde_pspace_aligned': apply simp done -lemma modify_pde_pspace_bounded': - "\pde_at' ptr and pspace_bounded'\ - modify (ksPSpace_update (\ps. ps(ptr \ KOArch (KOPDE new_pde)))) - \\a. pspace_bounded'\" - apply (clarsimp simp: simpler_modify_def ko_wp_at'_def valid_def typ_at'_def) - apply (case_tac ko,simp_all) - apply (rename_tac arch_kernel_object) - apply (case_tac arch_kernel_object,simp_all) - apply (subst pspace_bounded'_def) - apply (intro ballI) - apply (erule domE) - apply (clarsimp split:if_splits) - apply (simp add:objBits_simps archObjSize_def) - apply (fastforce dest!: pspace_boundedD') - done - lemma modify_pde_psp_no_overlap': "\pde_at' ptr and pspace_no_overlap' ptr' sz\ modify (ksPSpace_update (\ps. ps(ptr \ KOArch (KOPDE new_pde)))) \\a. pspace_no_overlap' ptr' sz\" proof - - note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps + note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex show ?thesis apply (clarsimp simp:simpler_modify_def ko_wp_at'_def valid_def typ_at'_def) @@ -3454,7 +3048,7 @@ lemma doMachineOp_storePDE_commute: lemma storePDE_placeNewObject_commute: "monad_commute - (pde_at' src and pspace_distinct' and pspace_aligned' and pspace_bounded' and + (pde_at' src and pspace_distinct' and pspace_aligned' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + sz) and K (is_aligned ptr (objBitsKO (injectKOS val) + sz) \ objBitsKO (injectKOS val) + sz < word_bits) ) @@ -3516,7 +3110,9 @@ lemma modify_obj_commute': done lemma cte_wp_at_modify_pde: - notes blah[simp del] = atLeastAtMost_simps + notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + atLeastAtMost_iff shows "\ksPSpace s ptr' = Some (KOArch (KOPDE pde)); pspace_aligned' s;cte_wp_at' \ ptr s\ \ cte_wp_at' \ ptr (s\ksPSpace := (ksPSpace s)(ptr' \ (KOArch (KOPDE pde')))\)" @@ -3526,9 +3122,11 @@ lemma cte_wp_at_modify_pde: apply (rule disjI1) apply (clarsimp simp add:ko_wp_at'_def) apply (intro conjI impI) - apply (simp add:objBits_simps archObjSize_def) - apply (clarsimp simp:projectKO_opt_cte) - apply (clarsimp simp: ps_clear_def objBits_simps archObjSize_def)+ + apply (simp add:objBits_simps archObjSize_def) + apply (clarsimp simp:projectKO_opt_cte) + apply (simp add:ps_clear_def)+ + apply (clarsimp simp:objBits_simps archObjSize_def) + apply (simp add:ps_clear_def) apply (rule ccontr) apply simp apply (erule in_emptyE, blast) @@ -3536,9 +3134,11 @@ lemma cte_wp_at_modify_pde: apply (rule disjI2) apply (clarsimp simp:ko_wp_at'_def) apply (intro conjI impI) - apply (simp add:objBits_simps archObjSize_def)+ - apply (clarsimp simp:projectKO_opt_cte projectKO_opt_tcb) - apply (clarsimp simp: ps_clear_def objBits_simps archObjSize_def)+ + apply (simp add:objBits_simps archObjSize_def)+ + apply (clarsimp simp:projectKO_opt_cte projectKO_opt_tcb) + apply (simp add:ps_clear_def)+ + apply (clarsimp simp:objBits_simps archObjSize_def) + apply (simp add:ps_clear_def) apply (rule ccontr) apply simp apply (erule in_emptyE) @@ -3546,9 +3146,11 @@ lemma cte_wp_at_modify_pde: done lemma storePDE_setCTE_commute: - notes blah[simp del] = atLeastAtMost_simps + notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + atLeastAtMost_iff shows "monad_commute - (pde_at' ptr and pspace_distinct' and pspace_aligned' and pspace_bounded' and + (pde_at' ptr and pspace_distinct' and pspace_aligned' and cte_wp_at' (\_. True) src) (setCTE src cte) (storePDE ptr (new_pde::ARM_H.pde))" apply (rule commute_name_pre_state) @@ -3570,38 +3172,33 @@ lemma storePDE_setCTE_commute: apply (rule monad_commute_split) apply (subst modify_specify) apply (rule modify_obj_commute') - apply (subst modify_specify) apply (rule commute_commute[OF locateCTE_commute]) - apply (rule no_fail_modify) - apply (rule locateCTE_cte_no_fail) - apply (rule modify_pde_pspace_distinct') - apply (rule modify_pde_pspace_aligned') - apply (rule modify_pde_pspace_bounded') - apply (wpsimp wp: modify_wp) - apply (case_tac "dest = ptr"; clarsimp?) - apply (subst non_sc_same_typ_at'_ko_wp_at'_set_ko'_iff[unfolded unfold_set_ko', - unfolded fun_upd_def]; - force?) - apply (clarsimp simp: ko_wp_at'_def typ_at'_def) - apply (erule_tac P=Q in rsubst) - apply (rule koType_objBitsKO; simp) - apply (subst ko_wp_at'_set_ko'_distinct[simplified unfold_set_ko', - unfolded fun_upd_def]; - clarsimp simp: ko_wp_at'_def typ_at'_def) - apply (clarsimp simp: simpler_modify_def valid_def) - apply (frule typ_at'_ksPSpace_exI, clarsimp) - apply (rule cte_wp_at_modify_pde[unfolded unfold_set_ko']; simp) + apply (wp locateCTE_cte_no_fail no_fail_modify + modify_pde_pspace_distinct' + modify_pde_pspace_aligned'| subst modify_specify)+ + apply (clarsimp simp:simpler_modify_def valid_def typ_at'_def) + apply (clarsimp simp:ko_wp_at'_def dest!: koTypeOf_pde) + apply (intro conjI impI) + apply (clarsimp simp:objBits_simps archObjSize_def)+ + apply (simp add:ps_clear_def in_dom_eq) + apply (simp add:ps_clear_def in_dom_eq) + apply (clarsimp simp:simpler_modify_def valid_def) + apply (clarsimp simp:typ_at'_def ko_wp_at'_def) + apply (case_tac ko,simp_all add:koTypeOf_def )[1] + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object,simp_all add:archTypeOf_def)[1] + apply (erule(2) cte_wp_at_modify_pde) apply wp apply (thin_tac "cte_wp_at' P src s" for P s)+ apply (clarsimp simp: typ_at'_def cte_wp_at_obj_cases_mask obj_at'_real_def) apply (wp locateCTE_ret_neq locateCTE_ko_wp_at') - apply (clarsimp simp: ko_wp_at'_def objBits_simps archObjSize_def typ_at'_def) + apply (clarsimp simp:ko_wp_at'_def objBits_simps archObjSize_def typ_at'_def) apply fastforce done lemma setCTE_gets_globalPD_commute: "monad_commute - (cte_wp_at' (\_. True) src and pspace_distinct' and pspace_aligned' and pspace_bounded') + (cte_wp_at' (\_. True) src and pspace_distinct' and pspace_aligned') (setCTE src cte) (gets (armKSGlobalPD \ ksArchState))" apply (simp add:setCTE_def2) apply (rule monad_commute_guard_imp) @@ -3611,6 +3208,7 @@ lemma setCTE_gets_globalPD_commute: apply (wp locateCTE_cte_no_fail)+ apply clarsimp apply (wp|clarsimp)+ + apply fastforce done lemma placeNewObject_gets_globalPD_commute: @@ -3634,7 +3232,7 @@ lemma placeNewObject_gets_globalPD_commute: lemma copyGlobalMappings_setCTE_commute: "monad_commute - (valid_arch_state' and pspace_distinct' and pspace_aligned' and pspace_bounded' and + (valid_arch_state' and pspace_distinct' and pspace_aligned' and cte_wp_at' (\_. True) src and page_directory_at' ptr) (copyGlobalMappings ptr) (setCTE src cte)" apply (clarsimp simp:copyGlobalMappings_def) @@ -3653,15 +3251,9 @@ lemma copyGlobalMappings_setCTE_commute: apply (clarsimp simp: pteBits_def pdeBits_def) done -lemma dmo_bounded'[wp]: - "doMachineOp f \pspace_bounded'\" - apply (simp add: doMachineOp_def split_def) - apply wpsimp - done - lemma setCTE_doMachineOp_commute: assumes nf: "no_fail Q (doMachineOp x)" - shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and pspace_bounded' and Q) + shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) (setCTE dest cte) (doMachineOp x)" apply (simp add:setCTE_def2 split_def) @@ -3674,10 +3266,21 @@ lemma setCTE_doMachineOp_commute: apply (wp|clarsimp|fastforce)+ done +lemma setCTE_when_doMachineOp_commute: + assumes nf: "no_fail Q (doMachineOp x)" + shows "monad_commute (cte_at' dest and pspace_aligned' and pspace_distinct' and Q) + (setCTE dest cte) + (when P (doMachineOp x))" + apply (cases P; simp add: setCTE_doMachineOp_commute nf) + apply (rule monad_commute_guard_imp) + apply (rule return_commute[THEN commute_commute]) + apply simp + done + lemma placeNewObject_valid_arch_state: "\valid_arch_state' and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and - pspace_aligned' and pspace_distinct' and pspace_bounded' and + pspace_aligned' and pspace_distinct' and K (is_aligned ptr (objBitsKO (injectKOS val) + us)) and K ( (objBitsKO (injectKOS val)+ us)< word_bits)\ placeNewObject ptr val us @@ -3692,7 +3295,7 @@ lemma placeNewObject_valid_arch_state: lemma placeNewObject_pd_at': "\K (is_aligned ptr pdBits) and pspace_no_overlap' ptr pdBits and - pspace_aligned' and pspace_distinct' and pspace_bounded'\ + pspace_aligned' and pspace_distinct'\ placeNewObject ptr (makeObject::ARM_H.pde) (pdBits - objBits (makeObject::ARM_H.pde)) \\rv s. page_directory_at' ptr s\" @@ -3729,10 +3332,39 @@ lemma setCTE_modify_gsUserPages_commute: lemma getTCB_det: "ko_wp_at' ((=) (KOTCB tcb)) p s \ getObject p s = ({(tcb,s)},False)" - by (clarsimp simp: ko_wp_at'_def getObject_def split_def gets_the_def - bind_def gets_def return_def get_def fail_def assert_opt_def - no_ofailD[OF no_ofail_tcb_at'_readObject] obj_at'_def projectKOs - split: if_splits option.split dest!: readObject_misc_ko_at') + apply (clarsimp simp:ko_wp_at'_def getObject_def split_def + bind_def gets_def return_def get_def + assert_opt_def split:if_splits) + apply (clarsimp simp: fail_def return_def lookupAround2_known1) + apply (simp add:loadObject_default_def) + apply (clarsimp simp:projectKO_def projectKO_opt_tcb alignCheck_def + is_aligned_mask objBits_simps' unless_def) + apply (clarsimp simp:bind_def return_def) + apply (intro conjI) + apply (intro set_eqI iffI) + apply clarsimp + apply (subst (asm) in_magnitude_check') + apply (simp add:archObjSize_def is_aligned_mask)+ + apply (rule bexI[rotated]) + apply (rule in_magnitude_check'[THEN iffD2]) + apply (simp add:is_aligned_mask)+ + apply (clarsimp simp:image_def) + apply (clarsimp simp:magnitudeCheck_assert assert_def + objBits_def archObjSize_def + return_def fail_def lookupAround2_char2 split:option.splits if_split_asm) + apply (rule ccontr) + apply (simp add:ps_clear_def field_simps) + apply (erule_tac x = x2 in in_empty_interE) + apply (clarsimp simp:less_imp_le) + apply (rule conjI) + apply (subst add.commute) + apply (rule word_diff_ls') + apply (clarsimp simp:field_simps not_le plus_one_helper) + apply (subst add.commute) + apply (simp add: is_aligned_no_wrap' is_aligned_mask) + apply simp + apply auto + done lemma threadSet_det: "tcb_at' ptr s @@ -3746,10 +3378,10 @@ lemma threadSet_det: apply (clarsimp simp:setObject_def gets_def get_def) apply (subst bind_def) apply (clarsimp simp:split_def) - apply (simp add:lookupAround2_known1 bind_assoc projectKO_def gets_the_def - assert_opt_def updateObject_default_def projectKO_opt_tcb omonad_defs) - apply (clarsimp simp: read_alignCheck_def omonad_defs - alignCheck_def unless_def when_def gets_the_def + apply (simp add:lookupAround2_known1 bind_assoc projectKO_def + assert_opt_def updateObject_default_def projectKO_opt_tcb) + apply (clarsimp simp add: + alignCheck_def unless_def when_def is_aligned_mask objBits_simps) apply (clarsimp simp:magnitudeCheck_det bind_def) apply (cut_tac ko = "KOTCB obj" in magnitudeCheck_det) @@ -3760,11 +3392,12 @@ lemma threadSet_det: lemma setCTE_modify_tcbDomain_commute: " monad_commute - (tcb_at' ptr and cte_wp_at' (\_. True) src and pspace_distinct' and pspace_aligned' and pspace_bounded') - (setCTE src cte) + (tcb_at' ptr and cte_wp_at' (\_. True) src and pspace_distinct' and pspace_aligned') (setCTE src cte) (threadSet (tcbDomain_update (\_. ra)) ptr)" proof - - note blah[simp del] = atLeastAtMost_simps + note blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + atLeastAtMost_iff have hint: "\P ptr a cte b src ra. monad_commute (tcb_at' ptr and ko_wp_at' P a ) @@ -3777,16 +3410,15 @@ lemma setCTE_modify_tcbDomain_commute: prefer 2 apply (clarsimp simp:obj_at'_def) apply (intro conjI impI) - apply simp - apply (clarsimp simp: projectKO_eq projectKO_opt_tcb - split: Structures_H.kernel_object.split_asm) - apply (simp add:cte_update_def) - apply (clarsimp simp: projectKO_eq projectKO_opt_tcb - split: Structures_H.kernel_object.split_asm) - apply (simp add:ps_clear_def) - apply clarsimp - apply (clarsimp simp: projectKO_eq projectKO_opt_tcb - split: Structures_H.kernel_object.split_asm) + apply simp + apply (clarsimp simp:projectKO_eq + projectKO_opt_tcb split:Structures_H.kernel_object.split_asm) + apply (simp add:cte_update_def) + apply (clarsimp simp:projectKO_eq + projectKO_opt_tcb split:Structures_H.kernel_object.split_asm) + apply (simp add:ps_clear_def) + apply (clarsimp simp:projectKO_eq + projectKO_opt_tcb split:Structures_H.kernel_object.split_asm) apply (simp add:ps_clear_def) apply (rule ccontr,simp) apply (erule in_emptyE) @@ -3851,23 +3483,24 @@ crunch curDomain for inv[wp]: P lemma placeNewObject_tcb_at': - "\pspace_aligned' and pspace_distinct' - and pspace_no_overlap' ptr (objBits (makeObject::tcb)) - and K (is_aligned ptr (objBits (makeObject::tcb))) \ - placeNewObject ptr (makeObject::tcb) 0 - \\rv s. tcb_at' ptr s \" + notes [simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex atLeastAtMost_iff + shows "\ pspace_aligned' and pspace_distinct' + and pspace_no_overlap' ptr (objBits (makeObject::tcb)) + and K(is_aligned ptr (objBits (makeObject::tcb))) \ + placeNewObject ptr (makeObject::tcb) 0 + \\_ s. tcb_at' ptr s \" apply (simp add: placeNewObject_def placeNewObject'_def split_def) - apply (wp unless_wp | wpc | simp add: alignError_def)+ - apply (auto simp: obj_at'_def is_aligned_mask lookupAround2_None1 lookupAround2_char1 field_simps - projectKO_opt_tcb projectKO_def return_def ps_clear_def objBits_simps' oassert_opt_def - word_bits_def - split: if_splits - dest!: pspace_no_overlap_disjoint') - done + apply (wp unless_wp |wpc | simp add:alignError_def)+ + by (auto simp: obj_at'_def is_aligned_mask lookupAround2_None1 + lookupAround2_char1 field_simps objBits_simps + projectKO_opt_tcb projectKO_def return_def ps_clear_def + split: if_splits + dest!: pspace_no_overlap_disjoint') lemma monad_commute_if_weak_r: - "\monad_commute P1 f h1; monad_commute P2 f h2\ \ - monad_commute (P1 and P2) f (if d then h1 else h2)" +"\monad_commute P1 f h1; monad_commute P2 f h2\ \ + monad_commute (P1 and P2) f (if d then h1 else h2)" apply (clarsimp) apply (intro conjI impI) apply (erule monad_commute_guard_imp,simp)+ @@ -3876,13 +3509,11 @@ lemma monad_commute_if_weak_r: lemma createObject_setCTE_commute: "monad_commute (cte_wp_at' (\_. True) src and - pspace_aligned' and pspace_distinct' and pspace_bounded' and + pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and valid_arch_state' and K (ptr \ src) and K (is_aligned ptr (Types_H.getObjectSize ty us)) and - K (Types_H.getObjectSize ty us < word_bits) and - K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ - sc_size_bounds us)) + K (Types_H.getObjectSize ty us < word_bits)) (RetypeDecls_H.createObject ty ptr us d) (setCTE src cte)" apply (rule commute_grab_asm)+ @@ -3894,54 +3525,54 @@ lemma createObject_setCTE_commute: simp_all add: ARM_H.toAPIType_def) apply (rename_tac apiobject_type) apply (case_tac apiobject_type) - apply (simp_all add: ARM_H.getObjectSize_def apiGetObjectSize_def - tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def - cteSizeBits_def) - \ \Untyped\ - apply (simp add: monad_commute_guard_imp[OF return_commute]) - \ \TCB\ - apply (rule monad_commute_guard_imp[OF commute_commute]) - apply (rule monad_commute_split[OF monad_commute_split[OF commute_commute]]) - apply (rule return_commute) - apply (rule setCTE_placeNewObject_commute) + apply (simp_all add: + ARM_H.getObjectSize_def apiGetObjectSize_def + tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def + cteSizeBits_def) + \ \Untyped\ + apply (simp add: monad_commute_guard_imp[OF return_commute]) + \ \TCB, EP, NTFN\ + apply (rule monad_commute_guard_imp[OF commute_commute]) + apply (rule monad_commute_split[OF monad_commute_split]) + apply (rule monad_commute_split[OF commute_commute[OF return_commute]]) + apply (rule setCTE_modify_tcbDomain_commute) apply wp apply (rule curDomain_commute) - apply (wpsimp simp: objBits_simps')+ - \ \EP, NTFN\ - apply (rule monad_commute_guard_imp[OF commute_commute], - rule monad_commute_split[OF commute_commute[OF return_commute]], - rule setCTE_placeNewObject_commute, - (wpsimp simp: objBits_simps')+)+ - \ \CNode\ - apply (rule monad_commute_guard_imp[OF commute_commute]) - apply (rule monad_commute_split)+ - apply (rule return_commute[THEN commute_commute]) - apply (rule setCTE_modify_gsCNode_commute[of \]) - apply (rule hoare_triv[of \]) - apply wp - apply (rule setCTE_placeNewObject_commute) - apply (wpsimp simp: objBits_simps')+ - \ \SchedContext, Reply\ - apply (rule monad_commute_guard_imp[OF commute_commute], - rule monad_commute_split[OF commute_commute[OF return_commute]], - rule setCTE_placeNewObject_commute, - (wpsimp simp: objBits_simps' scBits_simps)+)+ + apply wp+ + apply (rule setCTE_placeNewObject_commute) + apply (wp placeNewObject_tcb_at' placeNewObject_cte_wp_at' + placeNewObject_pspace_distinct' + placeNewObject_pspace_aligned' + | clarsimp simp: objBits_simps')+ + apply (rule monad_commute_guard_imp[OF commute_commute] + ,rule monad_commute_split[OF commute_commute[OF return_commute]] + ,rule setCTE_placeNewObject_commute + ,(wp|clarsimp simp: objBits_simps')+)+ + \ \CNode\ + apply (rule monad_commute_guard_imp[OF commute_commute]) + apply (rule monad_commute_split)+ + apply (rule return_commute[THEN commute_commute]) + apply (rule setCTE_modify_gsCNode_commute[of \]) + apply (rule hoare_triv[of \]) + apply wp + apply (rule setCTE_placeNewObject_commute) + apply (wp|clarsimp simp: objBits_simps')+ \ \Arch Objects\ - apply ((rule monad_commute_guard_imp[OF commute_commute], - rule monad_commute_split[OF commute_commute[OF return_commute]], - clarsimp simp: ARM_H.createObject_def - placeNewDataObject_def bind_assoc split - del: if_splits, - (rule monad_commute_split return_commute[THEN commute_commute] + apply ((rule monad_commute_guard_imp[OF commute_commute] + , rule monad_commute_split[OF commute_commute[OF return_commute]] + , clarsimp simp: ARM_H.createObject_def + placeNewDataObject_def bind_assoc split + del: if_splits + ,(rule monad_commute_split return_commute[THEN commute_commute] setCTE_modify_gsUserPages_commute[of \] modify_wp[of "%_. \"] setCTE_doMachineOp_commute + setCTE_when_doMachineOp_commute setCTE_placeNewObject_commute monad_commute_if_weak_r copyGlobalMappings_setCTE_commute[THEN commute_commute] | wp placeNewObject_pspace_distinct' placeNewObject_pspace_aligned' - placeNewObject_pspace_bounded' placeNewObject_cte_wp_at' placeNewObject_valid_arch_state placeNewObject_pd_at' | erule is_aligned_weaken @@ -3955,12 +3586,10 @@ lemma createObject_updateMDB_commute: "monad_commute ((\s. src \ 0 \ cte_wp_at' (\_. True) src s) and pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and - pspace_aligned' and pspace_distinct' and pspace_bounded' and valid_arch_state' and + pspace_aligned' and pspace_distinct' and valid_arch_state' and K (ptr \ src) and K (is_aligned ptr (Types_H.getObjectSize ty us)) and - K ((Types_H.getObjectSize ty us) < word_bits) and - K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ - sc_size_bounds us)) + K ((Types_H.getObjectSize ty us)< word_bits)) (updateMDB src f) (RetypeDecls_H.createObject ty ptr us d)" apply (clarsimp simp:updateMDB_def split:if_split_asm) apply (intro conjI impI) @@ -3970,11 +3599,11 @@ lemma createObject_updateMDB_commute: apply (rule createObject_setCTE_commute) apply (rule createObject_getCTE_commute) apply wp - apply (auto simp:range_cover_full sc_size_bounds_def) + apply (auto simp:range_cover_full) done lemma updateMDB_pspace_no_overlap': - "\pspace_aligned' and pspace_distinct' and pspace_bounded' and pspace_no_overlap' ptr sz\ + "\pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\ updateMDB slot f \\rv s. pspace_no_overlap' ptr sz s\" apply (rule hoare_pre) @@ -4069,14 +3698,13 @@ lemma threadSet_gsUntypedZeroRanges_commute': "monad_commute \ (threadSet fn ptr) (modify (\s. s \ gsUntypedZeroRanges := f (gsUntypedZeroRanges s) \ ))" - apply (simp add: threadSet_def getObject_def setObject_def readObject_def) + apply (simp add: threadSet_def getObject_def setObject_def) apply (rule commute_commute) apply (strengthen monad_commute_guard_imp[OF monad_commute_split[where P="\" and Q="\\"], OF _ _ hoare_vcg_prop] - | simp add: modify_commute updateObject_default_def alignCheck_assert obind_def + | simp add: modify_commute updateObject_default_def alignCheck_assert magnitudeCheck_assert return_commute return_commute[THEN commute_commute] - projectKO_def assert_commute2 assert_commute2[THEN commute_commute] - assert_opt_def2 loadObject_default_def gets_the_def omonad_defs - read_magnitudeCheck_assert + projectKO_def2 assert_commute2 assert_commute2[THEN commute_commute] + assert_opt_def2 loadObject_default_def split: option.split prod.split)+ apply (simp add: monad_commute_def exec_gets exec_modify) done @@ -4100,13 +3728,12 @@ lemma copyGlobalMappings_gsUntypedZeroRanges_commute': apply (rule monad_commute_guard_imp) apply (rule commute_commute[OF monad_commute_split[where P="\"]]) apply (rule mapM_x_commute[where f = id and P="\\"]) - apply (simp add: storePDE_def getObject_def setObject_def readObject_def cong: bind_cong) + apply (simp add: storePDE_def getObject_def setObject_def cong: bind_cong) apply (strengthen monad_commute_guard_imp[OF monad_commute_split[where P="\" and Q="\\"], OF _ _ hoare_vcg_prop] | simp add: modify_commute updateObject_default_def alignCheck_assert magnitudeCheck_assert return_commute return_commute[THEN commute_commute] - projectKO_def assert_commute2 assert_commute2[THEN commute_commute] - assert_opt_def2 loadObject_default_def gets_the_def - read_magnitudeCheck_assert omonad_defs obind_def + projectKO_def2 assert_commute2 assert_commute2[THEN commute_commute] + assert_opt_def2 loadObject_default_def split: option.split prod.split)+ apply (simp add: monad_commute_def exec_gets exec_modify) apply wp @@ -4115,6 +3742,13 @@ lemma copyGlobalMappings_gsUntypedZeroRanges_commute': apply simp done +lemma dmo_gsUntypedZeroRanges_commute: + "monad_commute \ (modify (\s. s\gsUntypedZeroRanges := f (gsUntypedZeroRanges s)\)) + (doMachineOp m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def) + apply monad_eq + by (auto simp: select_f_def) + lemma createObject_gsUntypedZeroRanges_commute: "monad_commute \ @@ -4152,9 +3786,8 @@ lemma case_eq_if_isUntypedCap: lemma createObject_updateTrackedFreeIndex_commute: "monad_commute (cte_wp_at' (\_. True) slot and pspace_aligned' and pspace_distinct' and - pspace_bounded' and pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and + pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and valid_arch_state' and - K (ty = APIObjectType SchedContextObject \ sc_size_bounds us) and K (ptr \ slot) and K (Types_H.getObjectSize ty us < word_bits) and K (is_aligned ptr (Types_H.getObjectSize ty us))) (RetypeDecls_H.createObject ty ptr us dev) (updateTrackedFreeIndex slot idx)" @@ -4170,9 +3803,8 @@ lemma createObject_updateTrackedFreeIndex_commute: lemma createObject_updateNewFreeIndex_commute: "monad_commute (cte_wp_at' (\_. True) slot and pspace_aligned' and pspace_distinct' and - pspace_bounded' and pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and + pspace_no_overlap' ptr (Types_H.getObjectSize ty us) and valid_arch_state' and - K (ty = APIObjectType SchedContextObject \ sc_size_bounds us) and K (ptr \ slot) and K (Types_H.getObjectSize ty us < word_bits) and K (is_aligned ptr (Types_H.getObjectSize ty us))) (RetypeDecls_H.createObject ty ptr us dev) (updateNewFreeIndex slot)" @@ -4189,7 +3821,7 @@ lemma createObject_updateNewFreeIndex_commute: lemma new_cap_object_comm_helper: "monad_commute - (pspace_aligned' and pspace_distinct' and pspace_bounded' and (\s. no_0 (ctes_of s)) and + (pspace_aligned' and pspace_distinct' and (\s. no_0 (ctes_of s)) and (\s. weak_valid_dlist (ctes_of s)) and (\s. valid_nullcaps (ctes_of s)) and cte_wp_at' (\c. isUntypedCap (cteCap c)) parent and @@ -4198,9 +3830,7 @@ lemma new_cap_object_comm_helper: valid_arch_state' and K (Types_H.getObjectSize ty us capability.NullCap) and - K (is_aligned ptr (Types_H.getObjectSize ty us) \ ptr \ 0 \ parent \ 0) and - K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ - sc_size_bounds us)) + K (is_aligned ptr (Types_H.getObjectSize ty us) \ ptr \ 0 \ parent \ 0)) (RetypeDecls_H.createObject ty ptr us d) (insertNewCap parent slot cap)" apply (clarsimp simp:insertNewCap_def bind_assoc liftM_def) apply (rule monad_commute_guard_imp) @@ -4212,13 +3842,13 @@ lemma new_cap_object_comm_helper: apply (rule createObject_updateNewFreeIndex_commute) apply (wp getCTE_wp hoare_vcg_imp_lift hoare_vcg_disj_lift valid_arch_state'_updateMDB updateMDB_pspace_no_overlap' setCTE_pspace_no_overlap' - | clarsimp simp: conj_comms)+ + | clarsimp simp:conj_comms)+ apply (clarsimp simp:cte_wp_at_ctes_of) apply (frule_tac slot = slot in pspace_no_overlapD2') apply simp+ apply (frule_tac slot = parent in pspace_no_overlapD2') apply simp+ - apply (case_tac ctea, clarsimp simp: sc_size_bounds_def) + apply (case_tac ctea,clarsimp) apply (frule_tac p = slot in nullcapsD') apply simp+ apply (subgoal_tac "(mdbNext (cteMDBNode cte) = 0 \ @@ -4235,11 +3865,14 @@ lemma new_cap_object_comm_helper: crunch updateNewFreeIndex for pspace_aligned'[wp]: "pspace_aligned'" - and pspace_distinct'[wp]: "pspace_distinct'" - and pspace_bounded'[wp]: "pspace_bounded'" - and valid_arch_state'[wp]: "valid_arch_state'" - and pspace_no_overlap'[wp]: "pspace_no_overlap' ptr n" - and ctes_of[wp]: "\s. P (ctes_of s)" +crunch updateNewFreeIndex + for pspace_distinct'[wp]: "pspace_distinct'" +crunch updateNewFreeIndex + for valid_arch_state'[wp]: "valid_arch_state'" +crunch updateNewFreeIndex + for pspace_no_overlap'[wp]: "pspace_no_overlap' ptr n" +crunch updateNewFreeIndex + for ctes_of[wp]: "\s. P (ctes_of s)" lemma updateNewFreeIndex_cte_wp_at[wp]: "\\s. P (cte_wp_at' P' p s)\ updateNewFreeIndex slot \\rv s. P (cte_wp_at' P' p s)\" @@ -4254,9 +3887,7 @@ lemma new_cap_object_commute: K (distinct (map fst (zip list caps))) and K (\cap \ set caps. cap \ capability.NullCap) and K (Types_H.getObjectSize ty us ptr \ 0) and - K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ - sc_size_bounds us)) + K (is_aligned ptr (Types_H.getObjectSize ty us) \ ptr \ 0)) (RetypeDecls_H.createObject ty ptr us d) (zipWithM_x (insertNewCap parent) list caps)" apply (clarsimp simp:zipWithM_x_mapM_x) @@ -4265,9 +3896,9 @@ lemma new_cap_object_commute: apply (simp add:split_def) apply (rule new_cap_object_comm_helper) apply (clarsimp simp:insertNewCap_def split_def) - apply (wpsimp wp: updateMDB_weak_cte_wp_at updateMDB_pspace_no_overlap' - getCTE_wp valid_arch_state'_updateMDB - setCTE_weak_cte_wp_at setCTE_pspace_no_overlap') + apply (wp updateMDB_weak_cte_wp_at updateMDB_pspace_no_overlap' + getCTE_wp valid_arch_state'_updateMDB + setCTE_weak_cte_wp_at setCTE_pspace_no_overlap') apply (clarsimp simp:cte_wp_at_ctes_of simp del:fun_upd_apply) apply (case_tac "parent \ aa") prefer 2 @@ -4314,7 +3945,9 @@ lemma createObjects'_pspace_no_overlap: createObjects' ptr (Suc n) val us \\addrs s. pspace_no_overlap' (ptr + (1 + of_nat n << gz)) gz s\" proof - - note simps [simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps + note simps [simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff + atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex assume "gz = (objBitsKO val) + us" thus ?thesis apply - @@ -4386,13 +4019,13 @@ lemma createNewCaps_not_nc: by (wpsimp simp: Arch_createNewCaps_def split_del: if_split) lemma doMachineOp_psp_no_overlap: - "\\s. pspace_no_overlap' ptr sz s \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ + "\\s. pspace_no_overlap' ptr sz s \ pspace_aligned' s \ pspace_distinct' s \ doMachineOp f \\y s. pspace_no_overlap' ptr sz s\" - by (wpsimp wp: pspace_no_overlap'_lift2) + by (wp pspace_no_overlap'_lift,simp) lemma createObjects'_psp_distinct: - "\pspace_aligned' and pspace_distinct' and pspace_bounded' and + "\pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and K (range_cover ptr sz ((objBitsKO ko) + us) n \ n \ 0 \ is_aligned ptr (objBitsKO ko + us) \ objBitsKO ko + us < word_bits)\ @@ -4409,7 +4042,7 @@ lemma createObjects'_psp_distinct: apply clarsimp apply (subst data_map_insert_def[symmetric])+ apply (simp add: range_cover.unat_of_nat_n_shift) - apply (drule (3) retype_aligned_distinct'(1)[where ko = ko and n= "n*2^us" ]) + apply (drule(2) retype_aligned_distinct'(1)[where ko = ko and n= "n*2^us" ]) apply (erule range_cover_rel) apply simp apply clarsimp @@ -4417,7 +4050,7 @@ lemma createObjects'_psp_distinct: done lemma createObjects'_psp_aligned: - "\pspace_aligned' and pspace_distinct' and pspace_bounded' and + "\pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and K (range_cover ptr sz ((objBitsKO ko) + us) n \ n \ 0 \ is_aligned ptr (objBitsKO ko + us) \ objBitsKO ko + us < word_bits)\ @@ -4432,31 +4065,7 @@ lemma createObjects'_psp_aligned: apply (rule hoare_pre) apply (wpc|wp|simp add: unless_def alignError_def del: fun_upd_apply hoare_fail_any)+ apply clarsimp - apply (frule (3) retype_aligned_distinct'(3)[where ko = ko and n= "n*2^us" ]) - apply (erule range_cover_rel) - apply simp - apply clarsimp - apply (subst data_map_insert_def[symmetric])+ - apply (simp add: range_cover.unat_of_nat_n_shift) - done - -lemma createObjects'_psp_bounded: - "\pspace_aligned' and pspace_distinct' and pspace_bounded' and - pspace_no_overlap' ptr sz and - K (range_cover ptr sz ((objBitsKO ko) + us) n \ n \ 0 - \ is_aligned ptr (objBitsKO ko + us) \ objBitsKO ko + us < word_bits)\ - createObjects' ptr n ko us - \\rv s. pspace_bounded' s\" - apply (rule hoare_name_pre_state) - apply (clarsimp simp: createObjects'_def split_def) - apply (subst new_cap_addrs_fold') - apply (drule range_cover_not_zero_shift[where gbits = us,rotated]) - apply simp+ - apply unat_arith - apply (rule hoare_pre) - apply (wpc|wp|simp add: unless_def alignError_def del: fun_upd_apply hoare_fail_any)+ - apply clarsimp - apply (frule (3) retype_aligned_distinct'(2)[where ko = ko and n= "n*2^us" ]) + apply (frule(2) retype_aligned_distinct'(2)[where ko = ko and n= "n*2^us" ]) apply (erule range_cover_rel) apply simp apply clarsimp @@ -4465,12 +4074,12 @@ lemma createObjects'_psp_bounded: done lemma copyGlobalMappings_pspace_no_overlap': - "\pspace_aligned' and pspace_distinct' and pspace_bounded' and pspace_no_overlap' ptr sz\ + "\pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\ copyGlobalMappings xa \\ya. pspace_no_overlap' ptr sz\" apply (rule hoare_pre) apply (clarsimp simp:copyGlobalMappings_def) - apply (wpsimp wp: mapM_x_wp_inv pspace_no_overlap'_lift2) + apply (wp mapM_x_wp_inv pspace_no_overlap'_lift) apply clarsimp done @@ -4479,7 +4088,8 @@ lemma pspace_no_overlap'_le: assumes b: "sz < word_bits" shows "pspace_no_overlap' ptr sz' s" proof - - note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps + note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex have diff_cancel: "\a b c. (a::word32) + b - c = b + (a - c)" by simp have bound :"(ptr && ~~ mask sz') - (ptr && ~~ mask sz) \ 2 ^ sz - 2 ^ sz'" @@ -4508,7 +4118,8 @@ lemma pspace_no_overlap'_le2: assumes "pspace_no_overlap' ptr sz s" "ptr \ ptr'" "ptr' &&~~ mask sz = ptr && ~~ mask sz" shows "pspace_no_overlap' ptr' sz s" proof - - note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps + note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex show ?thesis using assms apply (clarsimp simp:pspace_no_overlap'_def) @@ -4530,8 +4141,7 @@ lemma pspace_no_overlap'_tail: lemma createNewCaps_pspace_no_overlap': "\\s. range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (Suc n)) \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ pspace_no_overlap' ptr sz s \ - (ty = APIObjectType SchedContextObject \ sc_size_bounds us) \ + pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ ptr \ 0\ createNewCaps ty ptr (Suc n) us d \\r s. pspace_no_overlap' @@ -4558,22 +4168,19 @@ lemma createNewCaps_pspace_no_overlap': createObjects_def) apply (rule hoare_pre) apply wpc - apply (clarsimp simp: apiGetObjectSize_def curDomain_def ARM_H.toAPIType_def - tcbBlockSizeBits_def ARM_H.getObjectSize_def objBits_simps - epSizeBits_def ntfnSizeBits_def cteSizeBits_def pageBits_def - ptBits_def archObjSize_def pdBits_def createObjects_def - Arch_createNewCaps_def scBits_simps word_bits_def - range_cover_le[where n = "Suc n"] range_cover.aligned - split: apiobject_type.splits - | wp doMachineOp_psp_no_overlap - createObjects'_pspace_no_overlap[where sz = sz] - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] - copyGlobalMappings_pspace_aligned' mapM_x_wp_inv - copyGlobalMappings_pspace_no_overlap'[where sz = sz] - | (frule range_cover_sz'; fastforce simp: untypedBits_defs) - | assumption)+ - apply ((clarsimp simp: apiGetObjectSize_def + apply (clarsimp simp: apiGetObjectSize_def curDomain_def + ARM_H.toAPIType_def tcbBlockSizeBits_def + ARM_H.getObjectSize_def objBits_simps epSizeBits_def ntfnSizeBits_def + cteSizeBits_def pageBits_def ptBits_def archObjSize_def pdBits_def + createObjects_def Arch_createNewCaps_def + split: apiobject_type.splits + | wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap[where sz = sz] + createObjects'_psp_aligned[where sz = sz] createObjects'_psp_distinct[where sz = sz] + copyGlobalMappings_pspace_aligned' mapM_x_wp_inv + copyGlobalMappings_pspace_no_overlap'[where sz = sz] | assumption)+ + apply (intro conjI range_cover_le[where n = "Suc n"] | simp)+ + apply ((simp add:objBits_simps pageBits_def range_cover_def word_bits_def)+)[5] + by ((clarsimp simp: apiGetObjectSize_def ARM_H.toAPIType_def tcbBlockSizeBits_def ARM_H.getObjectSize_def objBits_simps epSizeBits_def ntfnSizeBits_def cteSizeBits_def pageBits_def ptBits_def archObjSize_def pdBits_def @@ -4583,12 +4190,10 @@ lemma createNewCaps_pspace_no_overlap': split: apiobject_type.splits | wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap createObjects'_psp_aligned createObjects'_psp_distinct - createObjects'_psp_bounded copyGlobalMappings_pspace_aligned' mapM_x_wp_inv copyGlobalMappings_pspace_no_overlap' | assumption | clarsimp simp: word_bits_def | intro conjI range_cover_le[where n = "Suc n"] range_cover.aligned)+)[6] - done lemma objSize_eq_capBits: "Types_H.getObjectSize ty us = APIType_capBits ty us" @@ -4617,7 +4222,8 @@ lemma createNewCaps_ret_len: erule hoare_strengthen_post[OF createObjects_ret],clarsimp+ | intro conjI impI)+ apply (rule hoare_pre, ((wp+) - | simp add: Arch_createNewCaps_def toAPIType_def unat_of_nat_minus_1 + | simp add: Arch_createNewCaps_def toAPIType_def + ARM_H.toAPIType_def unat_of_nat_minus_1 | erule hoare_strengthen_post[OF createObjects_ret],clarsimp+ | intro conjI impI)+)+ done @@ -4754,7 +4360,8 @@ lemma pspace_no_overlap'_modify: (((1::word32) + of_nat n << objBitsKO val + us) + ptr) (objBitsKO val + us)\" proof - - note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps + note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex show ?thesis apply (clarsimp simp:simpler_modify_def valid_def pspace_no_overlap'_def) apply (frule(1) range_cover_tail_mask) @@ -4787,7 +4394,7 @@ qed lemma placeNewObject_copyGlobalMapping_commute: "monad_commute - (valid_arch_state' and pspace_distinct' and pspace_aligned' and pspace_bounded' and + (valid_arch_state' and pspace_distinct' and pspace_aligned' and page_directory_at' r and pspace_no_overlap' ptr (objBitsKO (injectKOS val) + us) and K (objBitsKO (injectKOS val) + us < word_bits \ @@ -4800,7 +4407,7 @@ lemma placeNewObject_copyGlobalMapping_commute: apply (rule monad_commute_split[OF _ getPDE_placeNewObject_commute]) apply (rule storePDE_placeNewObject_commute) apply wp - apply (wp pspace_no_overlap'_lift2 | clarsimp)+ + apply (wp pspace_no_overlap'_lift | clarsimp)+ apply (rule placeNewObject_gets_globalPD_commute) apply wp apply clarsimp @@ -4812,7 +4419,7 @@ lemma placeNewObject_copyGlobalMapping_commute: lemma createObjects_Cons: "\range_cover ptr sz (objBitsKO val + us) (Suc (Suc n)); - pspace_distinct' s;pspace_aligned' s; pspace_bounded' s; + pspace_distinct' s;pspace_aligned' s; pspace_no_overlap' ptr sz s;pspace_aligned' s; ptr \ 0\ \ createObjects' ptr (Suc (Suc n)) val us s = (do createObjects' ptr (Suc n) val us; @@ -4889,7 +4496,7 @@ lemma createObjects_Cons: apply (simp add:range_cover_def) apply (erule range_cover.sz(1)[where 'a=32, folded word_bits_def]) apply (subst data_map_insert_def[symmetric]) - apply (drule(3) retype_aligned_distinct'(3)) + apply (drule(2) retype_aligned_distinct'(2)) prefer 2 apply (simp cong: kernel_state.fold_congs) apply (drule range_cover_le[where n = "Suc n"]) @@ -4910,7 +4517,7 @@ lemma placeNewObject_doMachineOp_commute: "monad_commute (K (us < word_bits \ is_aligned ptr (objBitsKO (injectKOS ty) + us) \ objBitsKO (injectKOS ty) + us < word_bits) and - pspace_aligned' and pspace_distinct' and pspace_bounded' and + pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr ((objBitsKO (injectKOS ty)) + us)) (placeNewObject ptr ty us) (doMachineOp f)" apply (rule commute_name_pre_state) @@ -4945,29 +4552,100 @@ lemma doMachineOp_ksArchState_commute: apply clarsimp+ done +lemma doMachineOp_ksPSpace: + "monad_commute \ (doMachineOp f) (gets ksPSpace)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp add: select_f_def) + done + +lemma doMachineOp_assert_opt: + "empty_fail f \ monad_commute \ (doMachineOp f) (assert_opt m)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (force simp add: select_f_def empty_fail_def) + done + +lemma doMachineOp_assert: + "empty_fail f \ monad_commute \ (doMachineOp f) (assert P)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (force simp add: select_f_def empty_fail_def) + done + +lemma doMachineOp_projectKO_pde: + "empty_fail f \ monad_commute \ (doMachineOp f) (projectKO ko :: pde kernel)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc projectKO_def) + apply monad_eq + by (force split: option.splits simp: fail_def return_def select_f_def empty_fail_def) + +lemma doMachineOp_alignCheck: + "empty_fail f \ monad_commute \ (doMachineOp f) (alignCheck ko n)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc alignCheck_def split_def + alignError_def unless_def) + apply monad_eq + by (force simp: select_f_def empty_fail_def) + +lemma doMachineOp_magnitudeCheck: + "empty_fail f \ monad_commute \ (doMachineOp f) (magnitudeCheck x y n)" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc magnitudeCheck_def split_def) + apply monad_eq + apply (force simp: select_f_def empty_fail_def return_def when_def fail_def split: option.splits) + done + +lemma doMachineOp_storePDE_commute_T: + "empty_fail f \ monad_commute \ (doMachineOp f) (storePDE src pde)" + apply (clarsimp simp: storePDE_def setObject_def updateObject_default_def bind_assoc split_def) + apply (rule monad_commute_guard_imp) + apply (rule monad_commute_split [OF _ doMachineOp_ksPSpace]) + apply (rule monad_commute_split [OF _ doMachineOp_assert_opt]) + apply (rule monad_commute_split [OF _ doMachineOp_assert]) + apply (rule monad_commute_split [OF _ doMachineOp_projectKO_pde]) + apply (rule monad_commute_split [OF _ doMachineOp_alignCheck]) + apply (rule monad_commute_split [OF _ doMachineOp_magnitudeCheck]) + apply (rule doMachineOp_upd_heap_commute) + apply (assumption | wp)+ + apply simp + done + +lemma getPDE_doMachineOp_commute_T: + "empty_fail f \ monad_commute \ (doMachineOp f) (getObject src :: pde kernel)" + apply (clarsimp simp: storePDE_def getObject_def loadObject_default_def bind_assoc split_def) + apply (rule monad_commute_guard_imp) + apply (rule monad_commute_split [OF _ doMachineOp_ksPSpace]) + apply (rule monad_commute_split [OF _ doMachineOp_assert_opt]) + apply (rule monad_commute_split [OF _ doMachineOp_assert]) + apply (rule monad_commute_split [OF _ doMachineOp_projectKO_pde]) + apply (rule monad_commute_split [OF _ doMachineOp_alignCheck]) + apply (rule monad_commute_split [OF _ doMachineOp_magnitudeCheck]) + apply (rule commute_commute, rule return_commute) + apply (assumption | wp)+ + apply simp + done + lemma doMachineOp_copyGlobalMapping_commute: - "monad_commute (valid_arch_state' and page_directory_at' r) - (doMachineOp f) (copyGlobalMappings r)" - apply (clarsimp simp:copyGlobalMappings_def) + "empty_fail f \ monad_commute \ (doMachineOp f) (copyGlobalMappings r)" + apply (clarsimp simp: copyGlobalMappings_def) apply (rule monad_commute_guard_imp) apply (rule monad_commute_split) - apply (rule mapM_x_commute[where f = id]) - apply (rule monad_commute_split[OF _ getPDE_doMachineOp_commute]) - apply (rule doMachineOp_storePDE_commute) - apply wp+ - apply clarsimp + apply (rule commute_commute, rule mapM_x_commute_T) + apply (rule commute_commute) + apply (rule monad_commute_guard_imp) + apply (rule monad_commute_split[OF _ getPDE_doMachineOp_commute_T]) + apply (rule doMachineOp_storePDE_commute_T) + apply (assumption | wp)+ + apply simp apply (rule doMachineOp_ksArchState_commute) apply wp apply clarsimp - apply (clarsimp simp: valid_arch_state'_def page_directory_at'_def objBits_simps archObjSize_def - pdBits_def pageBits_def) - apply (drule le_m1_iff_lt[where x = "(0x1000::word32)",simplified,THEN iffD1]) - apply (clarsimp simp: pdeBits_def) done +lemmas mapM_doMachineOp_copyGlobalMapping_commute = + doMachineOp_copyGlobalMapping_commute[THEN mapM_x_commute_T] + lemma createObjects'_page_directory_at': "\K (range_cover ptr sz 14 (Suc n)) and - pspace_aligned' and pspace_distinct' and pspace_bounded' and pspace_no_overlap' ptr sz\ + pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\ createObjects' ptr (Suc n) (KOArch (KOPDE makeObject)) 12 \\rv s. (\x\of_nat n. page_directory_at' (ptr + (x << 14)) s)\" apply (rule createObjects'_wp_subst) @@ -5078,7 +4756,7 @@ lemma createObjects_setDomain_commute: "monad_commute (\s. range_cover ptr' (objBitsKO (KOTCB makeObject)) (objBitsKO (KOTCB makeObject) + 0) (Suc 0) \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr' (objBitsKO (KOTCB makeObject)) s \ tcb_at' ptr s \ is_aligned ptr' (objBitsKO (KOTCB makeObject))) (createObjects' ptr' (Suc 0) (KOTCB makeObject) 0) @@ -5095,6 +4773,35 @@ lemma createObjects_setDomain_commute: apply (clarsimp split:Structures_H.kernel_object.splits) done + +lemma createObjects_setDomains_commute: + "monad_commute + (\s. \x\ set xs. tcb_at' (f x) s \ + range_cover ptr (objBitsKO (KOTCB makeObject)) (objBitsKO (KOTCB makeObject)) (Suc 0) \ + pspace_aligned' s \ + pspace_distinct' s \ + pspace_no_overlap' ptr (objBitsKO (KOTCB makeObject)) s \ + is_aligned ptr (objBitsKO (KOTCB makeObject))) + (mapM_x (threadSet (tcbDomain_update (\_. r))) (map f xs)) + (createObjects' ptr (Suc 0) (KOTCB makeObject) 0)" + proof (induct xs) + case Nil + show ?case + apply (simp add:monad_commute_def mapM_x_Nil) + done + next + case (Cons x xs) + show ?case + apply (simp add:mapM_x_Cons) + apply (rule monad_commute_guard_imp) + apply (rule commute_commute[OF monad_commute_split]) + apply (rule commute_commute[OF Cons.hyps]) + apply (rule createObjects_setDomain_commute) + apply (wp hoare_vcg_ball_lift) + apply clarsimp + done + qed + lemma createObjects'_pspace_no_overlap2: "\pspace_no_overlap' (ptr + (1 + of_nat n << gz)) sz and K (gz = (objBitsKO val) + us) @@ -5102,7 +4809,8 @@ lemma createObjects'_pspace_no_overlap2: createObjects' ptr (Suc n) val us \\addrs s. pspace_no_overlap' (ptr + (1 + of_nat n << gz)) sz s\" proof - - note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps + note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex show ?thesis apply (rule hoare_gen_asm)+ apply (clarsimp simp:createObjects'_def split_def new_cap_addrs_fold') @@ -5160,6 +4868,85 @@ proof - done qed +lemma dmo'_when_fail_comm: + assumes "empty_fail f" + shows "doMachineOp f >>= (\x. when P fail >>= (\_. m x)) = + when P fail >>= (\_. doMachineOp f >>= m)" + apply (rule ext) + apply (cut_tac ef_dmo'[OF assms]) + apply (auto simp add: empty_fail_def when_def fail_def return_def + bind_def split_def image_def, fastforce) + done + +lemma dmo'_gets_ksPSpace_comm: + "doMachineOp f >>= (\y. gets ksPSpace >>= m y) = + gets ksPSpace >>= (\x. doMachineOp f >>= (\y. m y x))" + apply (rule ext) + apply (clarsimp simp: doMachineOp_def simpler_modify_def simpler_gets_def + return_def select_f_def bind_def split_def image_def + cong: SUP_cong_simp) + apply (rule conjI; clarsimp) + apply (rule equalityI; clarsimp; + rule exI, rule conjI[rotated], assumption, + (rule exI)+, + rule conjI, rule bexI, rule refl, assumption, fastforce) + apply (rule iffI; clarsimp; + (rule exI)+, + rule conjI, + erule bexI[rotated], rule refl, + fastforce dest: prod_injects)+ + done + +lemma dmo'_ksPSpace_update_comm': + assumes "empty_fail f" + shows "doMachineOp f >>= (\x. modify (ksPSpace_update g) >>= (\_. m x)) = + modify (ksPSpace_update g) >>= (\_. doMachineOp f >>= m)" +proof - + have ksMachineState_ksPSpace_update: + "\s. ksMachineState (ksPSpace_update g s) = ksMachineState s" + by simp + have updates_independent: + "\f. ksPSpace_update g \ ksMachineState_update f = + ksMachineState_update f \ ksPSpace_update g" + by (rule ext) simp + from assms + show ?thesis + apply (simp add: doMachineOp_def split_def bind_assoc) + apply (simp add: gets_modify_comm2[OF ksMachineState_ksPSpace_update]) + apply (rule arg_cong_bind1) + apply (simp add: empty_fail_def select_f_walk[OF empty_fail_modify] + modify_modify_bind updates_independent) + done +qed + +lemma dmo'_createObjects'_commute: + assumes ef: "empty_fail f" + shows "monad_commute \ (doMachineOp f) (createObjects' ptr n obj us)" + apply (clarsimp simp: createObjects'_def bind_assoc split_def unless_def + alignError_def monad_commute_def + dmo'_when_fail_comm[OF ef] + dmo'_gets_ksPSpace_comm + dmo'_ksPSpace_update_comm'[OF ef, symmetric]) + apply (rule_tac x=s in fun_cong) + apply (rule arg_cong_bind1) + apply (rule arg_cong_bind1) + apply (rename_tac u w) + apply (case_tac "fst (lookupAround2 (ptr + of_nat (shiftL n (objBitsKO obj + + us) - Suc 0)) w)", clarsimp+) + apply (simp add: assert_into_when dmo'_when_fail_comm[OF ef]) + done + +lemmas map_dmo'_createObjects'_comm = dmo'_createObjects'_commute[THEN mapM_x_commute_T] + +lemma dmo'_gsUserPages_upd_commute: + "monad_commute \ (doMachineOp f) (modify (gsUserPages_update g))" + apply (clarsimp simp: monad_commute_def doMachineOp_def bind_assoc) + apply monad_eq + apply (auto simp: select_f_def) + done + +lemmas dmo'_gsUserPages_upd_map_commute = dmo'_gsUserPages_upd_commute[THEN mapM_x_commute_T] + lemma new_cap_addrs_def2: "n < 2 ^ 32 \ new_cap_addrs (Suc n) ptr obj @@ -5167,11 +4954,11 @@ lemma new_cap_addrs_def2: by (simp add:new_cap_addrs_def upto_enum_word unat_of_nat Fun.comp_def) lemma createTCBs_tcb_at': - "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ range_cover ptr sz - (objBitsKO (KOTCB (tcbDomain_update (\_. curdom) makeObject))) (Suc n) \ - createObjects' ptr (Suc n) (KOTCB (tcbDomain_update (\_. curdom) makeObject)) 0 + (objBitsKO (KOTCB makeObject)) (Suc n) \ + createObjects' ptr (Suc n) (KOTCB makeObject) 0 \\rv s. (\x\set [0.e.of_nat n]. tcb_at' (ptr + x * 2^tcbBlockSizeBits) s)\" apply (simp add:createObjects'_def split_def alignError_def) @@ -5180,8 +4967,8 @@ lemma createTCBs_tcb_at': apply clarsimp apply (subgoal_tac "(\x\of_nat n. tcb_at' (ptr + x * 2^tcbBlockSizeBits) (s\ksPSpace := - foldr (\addr. data_map_insert addr (KOTCB (tcbDomain_update (\_. curdom) makeObject))) - (new_cap_addrs (Suc n) ptr (KOTCB (tcbDomain_update (\_. curdom) makeObject))) + foldr (\addr. data_map_insert addr (KOTCB makeObject)) + (new_cap_addrs (Suc n) ptr (KOTCB makeObject)) (ksPSpace s)\))") apply (subst (asm) new_cap_addrs_def2) apply (drule range_cover.weak) @@ -5197,39 +4984,10 @@ lemma createTCBs_tcb_at': apply (simp add: objBits_simps shiftl_t2n) done -lemma curDomain_createObjects'_comm: - "do x \ createObjects' ptr n obj us; - y \ curDomain; - m x y - od = - do y \ curDomain; - x \ createObjects' ptr n obj us; - m x y - od" - apply (rule ext) - apply (case_tac x) - by (auto simp: createObjects'_def split_def bind_assoc return_def unless_def - when_def simpler_gets_def alignError_def fail_def assert_def - bind_def curDomain_def modify_def get_def put_def - split: option.splits) - -lemma curDomain_twice_simp: - "do x \ curDomain; - y \ curDomain; - m x y - od = - do x \ curDomain; - m x x - od" - apply (rule ext) - apply (case_tac x) - by (auto simp: simpler_gets_def bind_def curDomain_def) - lemma createNewCaps_Cons: assumes cover:"range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (Suc n))" and "valid_pspace' s" "valid_arch_state' s" and "pspace_no_overlap' ptr sz s" - and "ty = APIObjectType SchedContextObject \ sc_size_bounds us" and "ptr \ 0" shows "createNewCaps ty ptr (Suc (Suc n)) us d s = (do x \ createNewCaps ty ptr (Suc n) us d; @@ -5312,325 +5070,315 @@ proof - Arch_createNewCaps_def) apply (rename_tac apiobject_type) apply (case_tac apiobject_type) - apply (simp_all add: bind_assoc ARM_H.toAPIType_def) - \ \Untyped\ - apply (simp add: - bind_assoc ARM_H.getObjectSize_def - mapM_def sequence_def Retype_H.createObject_def - ARM_H.toAPIType_def - createObjects_def ARM_H.createObject_def - Arch_createNewCaps_def comp_def - apiGetObjectSize_def shiftl_t2n field_simps - shiftL_nat mapM_x_def sequence_x_def append - fromIntegral_def integral_inv[unfolded Fun.comp_def]) - \ \TCB\ - apply (simp add: - bind_assoc ARM_H.getObjectSize_def - mapM_def sequence_def Retype_H.createObject_def - ARM_H.toAPIType_def objBitsKO_def - createObjects_def ARM_H.createObject_def - Arch_createNewCaps_def comp_def append - apiGetObjectSize_def shiftl_t2n field_simps - shiftL_nat fromIntegral_def integral_inv[unfolded Fun.comp_def]) - apply (subst curDomain_createObjects'_comm) - apply (subst curDomain_twice_simp) - apply (simp add: monad_eq_simp_state) - apply (intro conjI; clarsimp simp: in_monad) - apply ((fastforce simp: curDomain_def simpler_gets_def return_def placeNewObject_def2 - field_simps shiftl_t2n bind_assoc objBits_simps in_monad - createObjects_Cons[where - val="KOTCB (tcbDomain_update (\_. ksCurDomain s) makeObject)" - and s=s, simplified objBitsKO_def])+)[2] - apply ((clarsimp simp: curDomain_def simpler_gets_def return_def split_def bind_def - field_simps shiftl_t2n bind_assoc objBits_simps placeNewObject_def2 - createObjects_Cons[where - val="KOTCB (tcbDomain_update (\_. ksCurDomain s) makeObject)" - and s=s, simplified objBitsKO_def])+)[1] - \ \EP, NTFN\ - apply (((simp add: - ARM_H.getObjectSize_def - mapM_def sequence_def Retype_H.createObject_def - ARM_H.toAPIType_def - createObjects_def ARM_H.createObject_def - Arch_createNewCaps_def comp_def - apiGetObjectSize_def shiftl_t2n field_simps - shiftL_nat mapM_x_def sequence_x_def append - fromIntegral_def integral_inv[unfolded Fun.comp_def])+ - , subst monad_eq, rule createObjects_Cons - , (simp add: field_simps shiftl_t2n bind_assoc pageBits_def - objBits_simps' placeNewObject_def2)+)+)[2] - \ \CNode\ - apply (simp add: cteSizeBits_def pageBits_def tcbBlockSizeBits_def - epSizeBits_def ntfnSizeBits_def pdBits_def bind_assoc - ARM_H.getObjectSize_def - mapM_def sequence_def Retype_H.createObject_def - ARM_H.toAPIType_def - createObjects_def ARM_H.createObject_def - Arch_createNewCaps_def comp_def - apiGetObjectSize_def shiftl_t2n field_simps - shiftL_nat mapM_x_def sequence_x_def append - fromIntegral_def integral_inv[unfolded Fun.comp_def])+ - apply (subst monad_eq, rule createObjects_Cons) - apply (simp add: field_simps shiftl_t2n bind_assoc pageBits_def - objBits_simps' placeNewObject_def2)+ - apply (subst gsCNodes_update gsCNodes_upd_createObjects'_comm)+ - apply (simp add: modify_modify_bind) - apply (rule fun_cong[where x=s]) - apply (rule arg_cong_bind[OF refl ext])+ - apply (rule arg_cong_bind[OF _ refl]) - apply (rule arg_cong[where f=modify, OF ext], simp) - apply (rule arg_cong2[where f=gsCNodes_update, OF ext refl]) - apply (rule ext) - apply simp - \ \SC, Reply\ - apply ((simp add: cteSizeBits_def pageBits_def tcbBlockSizeBits_def scBits_simps - epSizeBits_def ntfnSizeBits_def pdBits_def bind_assoc objBits_simps - mapM_def sequence_def Retype_H.createObject_def ARM_H.toAPIType_def - createObjects_def ARM_H.createObject_def Arch_createNewCaps_def comp_def - apiGetObjectSize_def shiftl_t2n field_simps shiftL_nat mapM_x_def - sequence_x_def append fromIntegral_def ARM_H.getObjectSize_def - integral_inv[unfolded Fun.comp_def], - subst monad_eq, rule createObjects_Cons; - fastforce simp: field_simps shiftl_t2n bind_assoc pageBits_def objBits_simps' - placeNewObject_def2 scBits_simps)+)[2] + apply (simp_all add: bind_assoc ARM_H.toAPIType_def + ) + \ \Untyped\ + apply (simp add: + bind_assoc ARM_H.getObjectSize_def + mapM_def sequence_def Retype_H.createObject_def + ARM_H.toAPIType_def + createObjects_def ARM_H.createObject_def + Arch_createNewCaps_def comp_def + apiGetObjectSize_def shiftl_t2n field_simps + shiftL_nat mapM_x_def sequence_x_def append + fromIntegral_def integral_inv[unfolded Fun.comp_def]) + \ \TCB, EP, NTFN\ + apply (simp add: bind_assoc + ARM_H.getObjectSize_def + sequence_def Retype_H.createObject_def + ARM_H.toAPIType_def + createObjects_def ARM_H.createObject_def + Arch_createNewCaps_def comp_def + apiGetObjectSize_def shiftl_t2n field_simps + shiftL_nat append mapM_x_append2 + fromIntegral_def integral_inv[unfolded Fun.comp_def])+ + apply (subst monad_eq) + apply (rule createObjects_Cons) + apply (simp add: field_simps shiftl_t2n bind_assoc pageBits_def + objBits_simps placeNewObject_def2)+ + apply (rule_tac Q = "\r s. pspace_aligned' s \ + pspace_distinct' s \ + pspace_no_overlap' (ptr + (2^tcbBlockSizeBits + of_nat n * 2^tcbBlockSizeBits)) (objBitsKO (KOTCB makeObject)) s \ + range_cover (ptr + 2^tcbBlockSizeBits) sz + (objBitsKO (KOTCB makeObject)) (Suc n) + \ (\x\set [0.e.of_nat n]. tcb_at' (ptr + x * 2^tcbBlockSizeBits) s)" + in monad_eq_split2) + apply simp + apply (subst monad_commute_simple[symmetric]) + apply (rule commute_commute[OF curDomain_commute]) + apply (wpsimp+)[2] + apply (rule_tac Q = "\r s. r = (ksCurDomain s) \ + pspace_aligned' s \ + pspace_distinct' s \ + pspace_no_overlap' (ptr + (2^tcbBlockSizeBits + of_nat n * 2^tcbBlockSizeBits)) (objBitsKO (KOTCB makeObject)) s \ + range_cover (ptr + 2^tcbBlockSizeBits) sz + (objBitsKO (KOTCB makeObject)) (Suc n) + \ (\x\set [0.e.of_nat n]. tcb_at' (ptr + x * 2^tcbBlockSizeBits) s) + " in monad_eq_split) + apply (subst monad_commute_simple[symmetric]) + apply (rule createObjects_setDomains_commute) + apply (clarsimp simp:objBits_simps) + apply (rule conj_impI) + apply (erule aligned_add_aligned) + apply (rule aligned_add_aligned[where n = tcbBlockSizeBits]) + apply (simp add:is_aligned_def objBits_defs) + apply (cut_tac is_aligned_shift[where m = tcbBlockSizeBits and k = "of_nat n", + unfolded shiftl_t2n,simplified]) + apply (simp add:field_simps)+ + apply (erule range_cover_full) + apply (simp add: word_bits_conv objBits_defs) + apply (rule_tac Q = "\x s. (ksCurDomain s) = ra" in monad_eq_split2) + apply simp + apply (rule_tac Q = "\x s. (ksCurDomain s) = ra" in monad_eq_split) + apply (subst rewrite_step[where f = curDomain and + P ="\s. ksCurDomain s = ra" and f' = "return ra"]) + apply (simp add:curDomain_def bind_def gets_def get_def) + apply simp + apply (simp add:mapM_x_singleton) + apply wp + apply simp + apply (wp mapM_x_wp') + apply simp + apply (simp add:curDomain_def,wp) + apply simp + apply (wp createObjects'_psp_aligned[where sz = sz] + createObjects'_psp_distinct[where sz = sz]) + apply (rule hoare_vcg_conj_lift) + apply (rule hoare_post_imp[OF _ createObjects'_pspace_no_overlap + [unfolded shiftl_t2n,where gz = tcbBlockSizeBits and sz = sz,simplified]]) + apply (simp add:objBits_simps field_simps) + apply (simp add: objBits_simps) + apply (wp createTCBs_tcb_at') + apply (clarsimp simp:objBits_simps word_bits_def field_simps) + apply (frule range_cover_le[where n = "Suc n"],simp+) + apply (drule range_cover_offset[where p = 1,rotated]) + apply simp + apply (simp add: objBits_defs) + apply (((simp add: + ARM_H.getObjectSize_def + mapM_def sequence_def Retype_H.createObject_def + ARM_H.toAPIType_def + createObjects_def ARM_H.createObject_def + Arch_createNewCaps_def comp_def + apiGetObjectSize_def shiftl_t2n field_simps + shiftL_nat mapM_x_def sequence_x_def append + fromIntegral_def integral_inv[unfolded Fun.comp_def])+ + , subst monad_eq, rule createObjects_Cons + , (simp add: field_simps shiftl_t2n bind_assoc pageBits_def + objBits_simps' placeNewObject_def2)+)+)[2] + \ \CNode\ + apply (simp add: cteSizeBits_def pageBits_def tcbBlockSizeBits_def + epSizeBits_def ntfnSizeBits_def pdBits_def bind_assoc + ARM_H.getObjectSize_def + mapM_def sequence_def Retype_H.createObject_def + ARM_H.toAPIType_def + createObjects_def ARM_H.createObject_def + Arch_createNewCaps_def comp_def + apiGetObjectSize_def shiftl_t2n field_simps + shiftL_nat mapM_x_def sequence_x_def append + fromIntegral_def integral_inv[unfolded Fun.comp_def])+ + apply (subst monad_eq, rule createObjects_Cons) + apply (simp add: field_simps shiftl_t2n bind_assoc pageBits_def + objBits_simps' placeNewObject_def2)+ + apply (subst gsCNodes_update gsCNodes_upd_createObjects'_comm)+ + apply (simp add: modify_modify_bind) + apply (rule fun_cong[where x=s]) + apply (rule arg_cong_bind[OF refl ext])+ + apply (rule arg_cong_bind[OF _ refl]) + apply (rule arg_cong[where f=modify, OF ext], simp) + apply (rule arg_cong2[where f=gsCNodes_update, OF ext refl]) + apply (rule ext) + apply simp + \ \SmallPageObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_H.toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+)[1] - apply (subst monad_eq, rule createObjects_Cons) + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) + apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def - pageBits_def add.commute append) - apply (subst gsUserPages_update gsCNodes_update + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) + apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+ + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+ \ \LargePageObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - ARM_H.toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_H.getObjectSize_def objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ - \ \SectionObject\ + \ \SectionObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_H.getObjectSize_def objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \SuperSectionObject\ apply (simp add: Arch_createNewCaps_def - Retype_H.createObject_def createObjects_def bind_assoc - toAPIType_def ARM_H.toAPIType_def + Retype_H.createObject_def createObjects_def bind_assoc toAPIType_def ARM_H.createObject_def placeNewDataObject_def) apply (intro conjI impI) + (* device *) apply (subst monad_eq, rule createObjects_Cons) - apply (simp_all add: field_simps shiftl_t2n pageBits_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - getObjectSize_def ARM_H.getObjectSize_def + apply (simp_all add: field_simps shiftl_t2n pageBits_def + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def pageBits_def add.commute append) apply ((subst gsUserPages_update gsCNodes_update - gsUserPages_upd_createObjects'_comm - | simp add: modify_modify_bind o_def)+)[1] + gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] + | simp add: modify_modify_bind o_def)+)[1] + (* not device *) apply (subst monad_eq, rule createObjects_Cons) apply (simp_all add: field_simps shiftl_t2n pageBits_def - ARM_H.getObjectSize_def objBits_simps)[7] - apply (simp add: bind_assoc placeNewObject_def2 objBits_simps - ARM_H.getObjectSize_def - pageBits_def add.commute append) + getObjectSize_def objBits_simps)[6] + apply (simp add: bind_assoc placeNewObject_def2 objBits_simps getObjectSize_def + pageBits_def add.commute append mapM_x_append mapM_x_singleton) apply (subst gsUserPages_update gsCNodes_update gsUserPages_upd_createObjects'_comm + monad_commute_simple'[OF map_dmo'_createObjects'_comm] + monad_commute_simple'[OF dmo'_gsUserPages_upd_map_commute] | simp add: modify_modify_bind o_def)+ \ \PageTableObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_H.toAPIType_def - ARM_H.createObject_def) - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n pageBits_def archObjSize_def - getObjectSize_def ARM_H.getObjectSize_def - objBits_simps ptBits_def)+)[7] - apply (simp add:bind_assoc placeNewObject_def2) - apply (simp add: pageBits_def field_simps - getObjectSize_def ptBits_def archObjSize_def - ARM_H.getObjectSize_def placeNewObject_def2 - objBits_simps append) - -\ \PageDirectoryObject\ - apply (simp add:Arch_createNewCaps_def Retype_H.createObject_def - createObjects_def bind_assoc ARM_H.toAPIType_def - ARM_H.createObject_def) - apply (subgoal_tac "distinct (map (\n. ptr + (n << 14)) [0.e.((of_nat n)::word32)])") - prefer 2 - apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def pageBits_def - ARM_H.getObjectSize_def) - apply (subst upto_enum_word) - apply (clarsimp simp:distinct_map) - apply (frule range_cover.range_cover_n_le) - apply (frule range_cover.range_cover_n_less) - apply (rule conjI) - apply (clarsimp simp:inj_on_def) - apply (rule ccontr) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add: word_of_nat_le word_bits_def pdeBits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def pdeBits_def) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply (rule ccontr) - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (clarsimp) - apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) - apply simp - apply (simp add:word_bits_def) - apply (simp add:word_of_nat_less word_bits_def pdeBits_def) - apply (erule less_le_trans[OF word_of_nat_less]) - apply (simp add:word_of_nat_le word_bits_def pdeBits_def) - apply (rule ccontr) - apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) - apply simp - apply simp - apply (drule of_nat_inj32[THEN iffD1,rotated -1]) - apply (simp_all add: word_bits_def)[3] - apply (subst monad_eq,rule createObjects_Cons) - apply ((simp add: field_simps shiftl_t2n pageBits_def archObjSize_def - ARM_H.getObjectSize_def pdBits_def - objBits_simps ptBits_def)+)[7] - apply (simp add:objBits_simps archObjSize_def pdBits_def pageBits_def ARM_H.getObjectSize_def) - apply (simp add:bind_assoc) - apply (simp add: placeNewObject_def2[where val = "makeObject::ARM_H.pde",simplified,symmetric]) - apply (rule_tac Q = "\r s. valid_arch_state' s \ - (\x\of_nat n. page_directory_at' (ptr + (x << 14)) s) \ Q s" for Q in monad_eq_split) - apply (rule sym) - apply (subst bind_assoc[symmetric]) - apply (subst monad_commute_simple) - apply (rule commute_commute[OF monad_commute_split]) - apply (rule placeNewObject_doMachineOp_commute) - apply (rule mapM_x_commute[where f = id]) - apply (rule placeNewObject_copyGlobalMapping_commute) - apply (rule hoare_pre) - apply (wp copyGlobalMappings_pspace_no_overlap' mapM_x_wp'| clarsimp simp: pdeBits_def)+ - apply (clarsimp simp:objBits_simps archObjSize_def pdBits_def pageBits_def word_bits_conv) - apply assumption (* resolve assumption , yuck *) - apply (simp add:append mapM_x_append bind_assoc pdeBits_def) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ (\r \ of_nat n. page_directory_at' (ptr + (r << 14)) s) - \ page_directory_at' (ptr + ((1 + of_nat n) << 14)) s"]) - apply (subst monad_commute_simple) - apply (rule doMachineOp_copyGlobalMapping_commute) - apply (clarsimp simp:field_simps) - apply (simp add:field_simps mapM_x_singleton) - apply (rule monad_eq_split[where Q = "\ r s. pspace_aligned' s \ pspace_distinct' s - \ valid_arch_state' s \ page_directory_at' (ptr + (1 + of_nat n << 14)) s"]) - apply (subst doMachineOp_bind) - apply (wp empty_fail_mapM_x empty_fail_cleanCacheRange_PoU)+ - apply (simp add:bind_assoc objBits_simps field_simps archObjSize_def shiftL_nat) - apply wp - apply simp - apply (rule mapM_x_wp') - apply (rule hoare_pre) - apply (wp copyGlobalMappings_pspace_no_overlap' | clarsimp)+ - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift) - apply ((clarsimp simp:page_directory_at'_def)+)[2] - apply (wp placeNewObject_pspace_aligned' placeNewObject_pspace_distinct') - apply (simp add:placeNewObject_def2 field_simps) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = 14]) - apply (rule hoare_vcg_conj_lift) - apply (clarsimp simp:page_directory_at'_def) - apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift createObjects'_typ_at[where sz = 14]) - apply (rule hoare_strengthen_post[OF createObjects'_page_directory_at'[where sz = 14]]) - apply simp - apply (clarsimp simp:objBits_simps page_directory_at'_def pdeBits_def - field_simps archObjSize_def word_bits_conv range_cover_full - aligned_add_aligned range_cover.aligned is_aligned_shiftl_self) - apply (simp add: pdeBits_def) - apply (frule pspace_no_overlap'_le2[where ptr' = "(ptr + (1 + of_nat n << 14))"]) - apply (subst shiftl_t2n,subst mult.commute, subst suc_of_nat) - apply (rule order_trans[OF range_cover_bound,where n1 = "1 + n"]) - apply (erule range_cover_le,simp) - apply simp - apply (rule word_sub_1_le) - apply (drule(1) range_cover_no_0[where p = "n+1"]) - apply simp - apply simp - apply (erule(1) range_cover_tail_mask) - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects'_wp_subst) - apply (wp createObjects_valid_arch[where sz = sz]) - apply (wp createObjects'_page_directory_at'[where sz = sz] - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_bounded[where sz = sz] - createObjects'_psp_distinct[where sz = sz] hoare_vcg_imp_lift - createObjects'_pspace_no_overlap[where sz = sz] - | simp add:objBits_simps archObjSize_def field_simps pdeBits_def)+ - apply (drule range_cover_le[where n = "Suc n"]) - apply simp - apply (clarsimp simp:word_bits_def valid_pspace'_def) - apply (clarsimp simp:aligned_add_aligned[OF range_cover.aligned] is_aligned_shiftl_self word_bits_def)+ - done + apply (simp add: Arch_createNewCaps_def Retype_H.createObject_def createObjects_def bind_assoc + ARM_H.toAPIType_def ARM_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons) + apply ((simp add: field_simps shiftl_t2n archObjSize_def + getObjectSize_def objBits_simps ptBits_def)+)[6] + apply (simp add: bind_assoc placeNewObject_def2) + apply (simp add: field_simps bind_assoc gets_modify_def + getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton archObjSize_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: pteBits_def ptBits_def) + + \ \PageDirectoryObject\ + apply (simp add: Arch_createNewCaps_def toAPIType_def bind_assoc + createObjects_def createObject_def ARM_H.createObject_def) + apply (subst monad_eq, rule createObjects_Cons; simp?) + apply (simp add: objBits_simps getObjectSize_def archObjSize_def pdeBits_def pdBits_def) + apply (simp add: getObjectSize_def placeNewObject_def2 objBits_simps append mapM_x_append + mapM_x_singleton bind_assoc archObjSize_def pdBits_def pdeBits_def) + apply (subst monad_commute_simple'[OF map_dmo'_createObjects'_comm] + | simp add: modify_modify_bind o_def + | simp only: o_def cong: if_cong)+ + apply (simp add: placeNewObject_def2[where val = "makeObject::ARM_H.pde",simplified,symmetric]) + apply (rule_tac Q = "\r s. valid_arch_state' s \ + (\x\of_nat n. page_directory_at' (ptr + (x << 14)) s) \ Q s" for Q + in monad_eq_split) + apply (subst monad_commute_simple) + apply (rule mapM_x_commute[where f=id]) + apply (rule placeNewObject_copyGlobalMapping_commute) + apply (wp copyGlobalMappings_pspace_no_overlap') + apply clarsimp + apply (clarsimp simp:objBits_simps archObjSize_def pdBits_def pageBits_def word_bits_conv) + apply (erule TrueE) (* resolve schematic assumption P *) + apply assumption (* resolve schematic assumption Q *) + apply clarsimp + apply (subst monad_commute_simple'[OF mapM_doMachineOp_copyGlobalMapping_commute], simp) + apply (simp add: field_simps) + apply (wpsimp wp: createObjects'_wp_subst[OF createObjects_valid_arch] hoare_vcg_const_imp_lift + createObjects'_page_directory_at'[where sz=sz] + createObjects'_psp_aligned[where sz=sz] + createObjects'_psp_distinct[where sz=sz] + createObjects'_pspace_no_overlap[where sz=sz] + simp: field_simps pdeBits_def objBits_simps archObjSize_def) + apply clarsimp + apply (drule range_cover_le[where n = "Suc n"], simp) + apply (rule conjI, assumption) + apply (clarsimp simp: objBits_simps archObjSize_def pdeBits_def word_bits_def cong: conj_cong) + apply (clarsimp simp: aligned_add_aligned[OF range_cover.aligned] is_aligned_shiftl_self) + (* distinct (map (\n. ptr + (n << 14)) [0 .e. word_of_nat n]) *) + apply (subst upto_enum_word) + apply (clarsimp simp:distinct_map) + apply (frule range_cover.range_cover_n_le) + apply (frule range_cover.range_cover_n_less) + apply (rule conjI) + apply (clarsimp simp:inj_on_def) + apply (rule ccontr) + apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) + apply simp + apply (simp add:word_bits_def) + apply (erule less_le_trans[OF word_of_nat_less]) + apply (simp add: word_of_nat_le word_bits_def pdeBits_def) + apply (erule less_le_trans[OF word_of_nat_less]) + apply (simp add:word_of_nat_le word_bits_def pdeBits_def) + apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) + apply simp + apply (rule ccontr) + apply simp + apply (drule of_nat_inj32[THEN iffD1,rotated -1]) + apply (simp_all add: word_bits_def)[3] + apply (clarsimp) + apply (erule_tac bnd = "2^(word_bits - 14)" in shift_distinct_helper[rotated 3]) + apply simp + apply (simp add:word_bits_def) + apply (simp add:word_of_nat_less word_bits_def pdeBits_def) + apply (erule less_le_trans[OF word_of_nat_less]) + apply (simp add:word_of_nat_le word_bits_def pdeBits_def) + apply (rule ccontr) + apply (frule range_cover.unat_of_nat_n[OF range_cover_le[where n = n]]) + apply simp + apply simp + apply (drule of_nat_inj32[THEN iffD1,rotated -1]; simp add: word_bits_def) + done qed lemma createObject_def2: @@ -5670,8 +5418,7 @@ lemma createNewObjects_def2: valid_arch_state' s; range_cover ptr sz (Types_H.getObjectSize ty us) (length dslots); ptr \ 0; - ksCurDomain s \ maxDomain; - ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ sc_size_bounds us\ + ksCurDomain s \ maxDomain\ \ createNewObjects ty parent dslots ptr us d s = insertNewCaps ty parent dslots ptr us d s" apply (clarsimp simp:insertNewCaps_def createNewObjects_def neq_Nil_conv) @@ -5693,8 +5440,6 @@ lemma createNewObjects_def2: {ptr..ptr + (1 + of_nat (length ys)) * 2 ^ (Types_H.getObjectSize ty us) - 1} s" assume range_cover: "range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (length ys))" assume unt_at: "cte_wp_at' (\c. isUntypedCap (cteCap c)) parent s" - assume min_sched_bits: "ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ - sc_size_bounds us" show "zipWithM_x (\num slot. RetypeDecls_H.createObject ty ((num << Types_H.getObjectSize ty us) + ptr) us d >>= @@ -5743,8 +5488,8 @@ lemma createNewObjects_def2: apply (simp add:snoc.hyps bind_assoc) apply (rule sym) apply (subst monad_eq) - apply (erule createNewCaps_Cons[OF _ valid_psp valid_arch_state psp_no_overlap min_sched_bits - not_0]) + apply (erule createNewCaps_Cons[OF _ valid_psp valid_arch_state psp_no_overlap not_0]) + apply (rule sym) apply (simp add:bind_assoc del:upto_enum_nat) apply (rule_tac Q = "(\r s. (\cap\set r. cap \ capability.NullCap) \ cte_wp_at' (\c. isUntypedCap (cteCap c)) parent s \ @@ -5752,37 +5497,40 @@ lemma createNewObjects_def2: (\slot\set as. cte_wp_at' (\c. cteCap c = capability.NullCap) slot s) \ pspace_no_overlap' (ptr + (1 + of_nat (length as) << Types_H.getObjectSize ty us)) (Types_H.getObjectSize ty us) s - \ valid_pspace' s \ valid_arch_state' s - \ (ty = APIObjectType SchedContextObject \ sc_size_bounds us) - \ Q r s)" for Q in monad_eq_split) + \ valid_pspace' s \ valid_arch_state' s \ Q r s)" for Q in monad_eq_split) apply (subst append_Cons[symmetric]) - apply (subst zipWithM_x_append1) - apply clarsimp - apply assumption + apply (subst zipWithM_x_append1) + apply clarsimp + apply assumption apply (clarsimp simp:field_simps) - apply (subst monad_commute_simple) + apply (subst monad_commute_simple[OF commute_commute]) apply (rule new_cap_object_commute) - apply (frule_tac p = "1 + length as" in range_cover_no_0[rotated]; clarsimp) - apply (intro conjI) - apply (simp add:range_cover_def word_bits_def) - apply (rule aligned_add_aligned[OF range_cover.aligned],simp) - apply (rule is_aligned_shiftl_self) - apply simp - apply (metis range_cover_ptr_le snoc(8) word_le_0_iff) - apply (clarsimp simp: createNewCaps_def min_sched_bits) + apply (clarsimp) + apply (frule_tac p = "1 + length as" in range_cover_no_0[rotated]) + apply clarsimp + apply simp + apply (subst (asm) Abs_fnat_hom_add[symmetric]) + apply (intro conjI) + apply (simp add:range_cover_def word_bits_def) + apply (rule aligned_add_aligned[OF range_cover.aligned],simp) + apply (rule is_aligned_shiftl_self) + apply (simp add:range_cover_def) + apply (simp add:range_cover_def) + apply (clarsimp simp:field_simps shiftl_t2n) + apply (clarsimp simp:createNewCaps_def) apply (wp createNewCaps_not_nc createNewCaps_pspace_no_overlap'[where sz = sz] createNewCaps_cte_wp_at'[where sz = sz] hoare_vcg_ball_lift createNewCaps_valid_pspace[where sz = sz] createNewCaps_obj_at'[where sz=sz]) apply simp apply (rule range_cover_le) - apply (simp add:objSize_eq_capBits caps_r min_sched_bits)+ + apply (simp add:objSize_eq_capBits caps_r)+ apply (wp createNewCaps_ret_len createNewCaps_valid_arch_state) apply (frule range_cover_le[where n = "Suc (length as)"]) apply simp+ using psp_no_overlap caps_r valid_psp unt_at caps_no_overlap valid_arch_state - apply (clarsimp simp: valid_pspace'_def objSize_eq_capBits min_sched_bits) - apply (auto simp: kscd min_sched_bits[unfolded sc_size_bounds_def]) + apply (clarsimp simp: valid_pspace'_def objSize_eq_capBits) + apply (auto simp: kscd) done qed qed @@ -5798,8 +5546,7 @@ assumes check: "distinct dslots" \ caps_no_overlap'' ptr sz s \ caps_overlap_reserved' {ptr..ptr + of_nat (length dslots) * 2^ (Types_H.getObjectSize ty us) - 1} s - \ valid_pspace' s \ valid_arch_state' s \ ksCurDomain s \ maxDomain - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ sc_size_bounds us))" + \ valid_pspace' s \ valid_arch_state' s \ ksCurDomain s \ maxDomain)" shows "corres r P P' f (createNewObjects ty parent dslots ptr us d)" using check cover not_0 apply (clarsimp simp:corres_underlying_def) @@ -5825,10 +5572,7 @@ lemma createNewObjects_wp_helper: and valid_pspace' and valid_arch_state' and caps_overlap_reserved' - {ptr..ptr + of_nat (length dslots) * 2^ (Types_H.getObjectSize ty us) - 1} - and (\s. ksCurDomain s \ maxDomain) - and K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ - sc_size_bounds us)) + {ptr..ptr + of_nat (length dslots) * 2^ (Types_H.getObjectSize ty us) - 1} and (\s. ksCurDomain s \ maxDomain)) \ (createNewObjects ty parent dslots ptr us d) \Q\" using assms apply (clarsimp simp:valid_def) @@ -5849,28 +5593,26 @@ lemma createObject_def3: lemma ArchCreateObject_pspace_no_overlap': "\\s. pspace_no_overlap' (ptr + (of_nat n << APIType_capBits ty userSize)) sz s \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + pspace_aligned' s \ pspace_distinct' s \ range_cover ptr sz (APIType_capBits ty userSize) (n + 2) \ ptr \ 0\ ARM_H.createObject ty (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d \\archCap. pspace_no_overlap' (ptr + (1 + of_nat n << APIType_capBits ty userSize)) sz\" - apply (rule hoare_pre) - apply (clarsimp simp:ARM_H.createObject_def) - apply wpc - apply (wp doMachineOp_psp_no_overlap - createObjects'_pspace_no_overlap2 hoare_when_weak_wp - copyGlobalMappings_pspace_no_overlap' - createObjects'_psp_aligned[where sz = sz] - createObjects'_psp_distinct[where sz = sz] - createObjects'_psp_bounded[where sz = sz] - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewObject_def2 word_shiftl_add_distrib - | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib - field_simps split del: if_split - | clarsimp simp add: add.assoc[symmetric],wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] - | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ - + supply if_split[split del] + apply (clarsimp simp:ARM_H.createObject_def) + apply wpc + apply (wp doMachineOp_psp_no_overlap + createObjects'_pspace_no_overlap2 + createObjects'_psp_aligned[where sz = sz] + createObjects'_psp_distinct[where sz = sz] + copyGlobalMappings_pspace_no_overlap' + | simp add: placeNewObject_def2 word_shiftl_add_distrib + | simp add: placeNewDataObject_def placeNewObject_def2 word_shiftl_add_distrib + field_simps + | clarsimp simp add: add.assoc[symmetric], + wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] + | clarsimp simp add: APIType_capBits_def objBits_simps pageBits_def)+ apply (clarsimp simp: conj_comms) apply (frule(1) range_cover_no_0[where p = n]) apply simp @@ -5886,7 +5628,7 @@ lemma ArchCreateObject_pspace_no_overlap': apply simp apply (frule pspace_no_overlap'_le2) apply (rule range_cover_compare_offset) - apply simp+ + apply simp+ apply (clarsimp simp:word_shiftl_add_distrib ,simp add:field_simps) apply (clarsimp simp:add.assoc[symmetric]) @@ -5909,9 +5651,8 @@ lemma to_from_apiTypeD: "toAPIType ty = Some x \ ty = fromAPITyp lemma createObject_pspace_no_overlap': "\\s. pspace_no_overlap' (ptr + (of_nat n << APIType_capBits ty userSize)) sz s \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + pspace_aligned' s \ pspace_distinct' s \ range_cover ptr sz (APIType_capBits ty userSize) (n + 2) - \ (ty = APIObjectType SchedContextObject \ sc_size_bounds userSize) \ ptr \ 0\ createObject ty (ptr + (of_nat n << APIType_capBits ty userSize)) userSize d \\rv s. pspace_no_overlap' @@ -5921,19 +5662,35 @@ lemma createObject_pspace_no_overlap': apply wpc apply (wp ArchCreateObject_pspace_no_overlap') apply wpc - apply wp - \ \TCB\ - apply (wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified] - | simp add: curDomain_def placeNewObject_def2 word_shiftl_add_distrib field_simps)+ - apply (simp add:add.assoc[symmetric]) - apply (wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified]) - apply (wpsimp simp: curDomain_def) - \ \other objects\ - apply ((wp createObjects'_pspace_no_overlap2 - | simp add: placeNewObject_def2 word_shiftl_add_distrib field_simps)+, - simp add:add.assoc[symmetric], - wp createObjects'_pspace_no_overlap2[where n =0 and sz = sz,simplified])+ - \ \Cleanup\ + apply wp + apply (simp add:placeNewObject_def2) + apply (wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap2 + | simp add: placeNewObject_def2 curDomain_def word_shiftl_add_distrib + field_simps)+ + apply (simp add:add.assoc[symmetric]) + apply (wp createObjects'_pspace_no_overlap2 + [where n =0 and sz = sz,simplified]) + apply (simp add:placeNewObject_def2) + apply (wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap2 + | simp add: placeNewObject_def2 word_shiftl_add_distrib + field_simps)+ + apply (simp add:add.assoc[symmetric]) + apply (wp createObjects'_pspace_no_overlap2 + [where n =0 and sz = sz,simplified]) + apply (simp add:placeNewObject_def2) + apply (wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap2 + | simp add: placeNewObject_def2 word_shiftl_add_distrib + field_simps)+ + apply (simp add:add.assoc[symmetric]) + apply (wp createObjects'_pspace_no_overlap2 + [where n =0 and sz = sz,simplified]) + apply (simp add:placeNewObject_def2) + apply (wp doMachineOp_psp_no_overlap createObjects'_pspace_no_overlap2 + | simp add: placeNewObject_def2 word_shiftl_add_distrib + field_simps)+ + apply (simp add:add.assoc[symmetric]) + apply (wp createObjects'_pspace_no_overlap2 + [where n =0 and sz = sz,simplified]) apply clarsimp apply (frule(1) range_cover_no_0[where p = n]) apply simp @@ -5951,30 +5708,29 @@ lemma createObject_pspace_no_overlap': apply (simp add:shiftl_t2n field_simps) apply (frule range_cover_offset[rotated,where p = n]) apply simp+ - by (auto simp: word_shiftl_add_distrib field_simps shiftl_t2n elim: range_cover_le) - (auto simp add: APIType_capBits_def fromAPIType_def objBits_def scBits_simps objBits_simps - dest!: to_from_apiTypeD) + apply (auto simp: word_shiftl_add_distrib field_simps shiftl_t2n elim: range_cover_le, + auto simp add: APIType_capBits_def fromAPIType_def objBits_def + dest!: to_from_apiTypeD) + done lemma createObject_pspace_aligned_distinct': - "\pspace_aligned' and K (is_aligned ptr (APIType_capBits ty us)) and pspace_bounded' + "\pspace_aligned' and K (is_aligned ptr (APIType_capBits ty us)) and pspace_distinct' and pspace_no_overlap' ptr (APIType_capBits ty us) - and K (ty = APIObjectType apiobject_type.CapTableObject \ us < 28) - and K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ - sc_size_bounds us)\ + and K (ty = APIObjectType apiobject_type.CapTableObject \ us < 28)\ createObject ty ptr us d - \\xa s. pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\" + \\xa s. pspace_aligned' s \ pspace_distinct' s\" apply (rule hoare_pre) apply (wp placeNewObject_pspace_aligned' unless_wp - placeNewObject_pspace_distinct' placeNewObject_pspace_bounded' + placeNewObject_pspace_distinct' | simp add:ARM_H.createObject_def Retype_H.createObject_def objBits_simps curDomain_def placeNewDataObject_def split del: if_split | wpc | intro conjI impI)+ - by (auto simp: APIType_capBits_def pdBits_def objBits_simps' pteBits_def pdeBits_def - pageBits_def word_bits_def archObjSize_def ptBits_def ARM_H.toAPIType_def - untypedBits_defs scBits_simps - split: ARM_H.object_type.splits apiobject_type.splits) + apply (auto simp:APIType_capBits_def pdBits_def objBits_simps' pteBits_def pdeBits_def + pageBits_def word_bits_def archObjSize_def ptBits_def ARM_H.toAPIType_def + split:ARM_H.object_type.splits apiobject_type.splits) + done declare objSize_eq_capBits [simp] @@ -6030,23 +5786,22 @@ lemma insertNewCap_wps[wp]: insertNewCap parent slot cap \\rv s. P (cteCaps_of s)\" apply (simp_all add: insertNewCap_def) - apply (wpsimp wp: hoare_drop_imps)+ + apply (wp hoare_drop_imps + | simp add: o_def)+ apply (fastforce elim!: rsubst[where P=P]) done crunch insertNewCap for typ_at'[wp]: "\s. P (typ_at' T p s)" - and pspace_bounded'[wp]: pspace_bounded' (wp: crunch_wps) lemma createNewObjects_pspace_no_overlap': - "\pspace_no_overlap' ptr sz and pspace_aligned' and pspace_distinct' and pspace_bounded' + "\pspace_no_overlap' ptr sz and pspace_aligned' and pspace_distinct' and K (range_cover ptr sz (Types_H.getObjectSize ty us) (Suc (length dests))) and K (ptr \ 0) - and K (ty = APIObjectType apiobject_type.CapTableObject \ us < 28) - and K (ty = APIObjectType apiobject_type.SchedContextObject \ sc_size_bounds us)\ + and K (ty = APIObjectType apiobject_type.CapTableObject \ us < 28)\ createNewObjects ty src dests ptr us d - \\rv s. pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + \\rv s. pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ((of_nat (length dests) << APIType_capBits ty us) + ptr) sz s\" apply (rule hoare_gen_asm)+ proof (induct rule:rev_induct ) @@ -6065,39 +5820,41 @@ lemma createNewObjects_pspace_no_overlap': apply (subst createNewObjects_Cons) apply (drule range_cover.weak) apply (simp add: word_bits_def) - apply (wpsimp wp: pspace_no_overlap'_lift2) - apply (simp add: conj_comms) - apply (subst conj_assoc[symmetric]) - apply (subst conj_assoc[symmetric]) - apply (rule hoare_vcg_conj_lift) - apply (rule hoare_post_imp[OF _ createObject_pspace_aligned_distinct']) - apply simp - apply (simp add:field_simps) - apply (wp createObject_pspace_no_overlap') - apply (clarsimp simp: conj_comms) - apply (rule hoare_pre) - apply (subst conj_assoc[symmetric]) - apply (subst conj_assoc[symmetric]) - apply (rule hoare_vcg_conj_lift) - apply (rule hoare_post_imp[OF _ snoc.hyps]) - apply (simp add:snoc)+ - apply wp - apply (simp add: conj_comms field_simps) - apply (rule hoare_post_imp) - apply (erule context_conjI) - apply (intro conjI) - apply (rule aligned_add_aligned[OF range_cover.aligned - is_aligned_shiftl_self]) + apply (wp pspace_no_overlap'_lift) + apply (simp add: conj_comms) + apply (rule hoare_vcg_conj_lift) + apply (rule hoare_post_imp[OF _ createObject_pspace_aligned_distinct']) + apply simp + apply (rule hoare_vcg_conj_lift) + apply (rule hoare_post_imp[OF _ createObject_pspace_aligned_distinct']) + apply simp + apply (simp add:field_simps) + apply (wp createObject_pspace_no_overlap') + apply (clarsimp simp: conj_comms) + apply (rule hoare_pre) + apply (rule hoare_vcg_conj_lift) + apply (rule hoare_post_imp[OF _ snoc.hyps]) + apply (simp add:snoc)+ + apply (rule hoare_vcg_conj_lift) + apply (rule hoare_post_imp[OF _ snoc.hyps]) + apply (simp add:snoc)+ + apply wp + apply (simp add: conj_comms field_simps) + apply (rule hoare_post_imp) + apply (erule context_conjI) + apply (intro conjI) + apply (rule aligned_add_aligned[OF range_cover.aligned + is_aligned_shiftl_self]) apply simp apply simp apply simp - apply (erule pspace_no_overlap'_le) - apply (simp add: range_cover.sz[where 'a=32, folded word_bits_def])+ - apply (rule hoare_post_imp[OF _ snoc.hyps]) - apply (simp add:field_simps snoc)+ - using snoc - apply simp - done + apply (erule pspace_no_overlap'_le) + apply (simp add: range_cover.sz[where 'a=32, folded word_bits_def])+ + apply (rule hoare_post_imp[OF _ snoc.hyps]) + apply (simp add:field_simps snoc)+ + using snoc + apply simp + done qed end diff --git a/proof/refine/ARM/EmptyFail.thy b/proof/refine/ARM/EmptyFail.thy index 259d293eb3..9db1629920 100644 --- a/proof/refine/ARM/EmptyFail.thy +++ b/proof/refine/ARM/EmptyFail.thy @@ -12,26 +12,38 @@ begin Unless there is a good reason, they should all be [intro!, wp, simp] *) lemma empty_fail_projectKO [simp, intro!]: - "empty_fail (gets_the $ projectKO v)" by wpsimp + "empty_fail (projectKO v)" + unfolding empty_fail_def projectKO_def + by (simp add: return_def fail_def split: option.splits) lemma empty_fail_alignCheck [intro!, wp, simp]: "empty_fail (alignCheck a b)" - unfolding alignCheck_def by wpsimp + unfolding alignCheck_def + by (fastforce simp: alignError_def) lemma empty_fail_magnitudeCheck [intro!, wp, simp]: "empty_fail (magnitudeCheck a b c)" - unfolding magnitudeCheck_def by wpsimp + unfolding magnitudeCheck_def + by (fastforce split: option.splits) lemma empty_fail_loadObject_default [intro!, wp, simp]: - shows "empty_fail (gets_the $ loadObject_default x b c d)" by wpsimp + shows "empty_fail (loadObject_default x b c d)" + by (auto simp: loadObject_default_def + split: option.splits) lemma empty_fail_threadGet [intro!, wp, simp]: "empty_fail (threadGet f p)" - by (wpsimp simp: threadGet_def) + by (fastforce simp: threadGet_def getObject_def split_def) lemma empty_fail_getCTE [intro!, wp, simp]: "empty_fail (getCTE slot)" - by (wpsimp simp: getCTE_def getObject_def) + apply (simp add: getCTE_def getObject_def split_def) + apply (intro empty_fail_bind, simp_all) + apply (simp add: loadObject_cte typeError_def alignCheck_def alignError_def + magnitudeCheck_def + split: Structures_H.kernel_object.split) + apply (auto split: option.split) + done lemma empty_fail_updateObject_cte [intro!, wp, simp]: "empty_fail (updateObject (v :: cte) ko a b c)" @@ -50,16 +62,18 @@ lemma empty_fail_getSlotCap [intro!, wp, simp]: "empty_fail (getSlotCap a)" unfolding getSlotCap_def by fastforce -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma empty_fail_getObject: - "empty_fail (getObject x :: 'a :: pspace_storable kernel)" - apply (wpsimp simp: getObject_def split_def) + assumes "\b c d. empty_fail (loadObject x b c d::'a :: pspace_storable kernel)" + shows "empty_fail (getObject x :: 'a :: pspace_storable kernel)" + apply (simp add: getObject_def split_def) + apply (safe intro!: assms) done lemma empty_fail_getObject_tcb [intro!, wp, simp]: shows "empty_fail (getObject x :: tcb kernel)" - by (wpsimp wp: empty_fail_getObject) + by (auto intro: empty_fail_getObject) lemma empty_fail_updateTrackedFreeIndex [intro!, wp, simp]: shows "empty_fail (updateTrackedFreeIndex p idx)" @@ -82,7 +96,7 @@ lemma empty_fail_getIRQSlot [intro!, wp, simp]: lemma empty_fail_getObject_ntfn [intro!, wp, simp]: "empty_fail (getObject p :: Structures_H.notification kernel)" - by (wpsimp wp: empty_fail_getObject) + by (simp add: empty_fail_getObject) lemma empty_fail_getNotification [intro!, wp, simp]: "empty_fail (getNotification ep)" @@ -96,11 +110,11 @@ lemma empty_fail_lookupIPCBuffer [intro!, wp, simp]: lemma empty_fail_updateObject_default [intro!, wp, simp]: "empty_fail (updateObject_default v ko a b c)" - by (wpsimp simp: updateObject_default_def) + by (fastforce simp: updateObject_default_def typeError_def unless_def split: kernel_object.splits) lemma empty_fail_threadSet [intro!, wp, simp]: "empty_fail (threadSet f p)" - by (wpsimp simp: threadSet_def setObject_def) + by (fastforce simp: threadSet_def getObject_def setObject_def split_def) lemma empty_fail_getThreadState[iff]: "empty_fail (getThreadState t)" diff --git a/proof/refine/ARM/EmptyFail_H.thy b/proof/refine/ARM/EmptyFail_H.thy index 3468e6b262..b2327d07fb 100644 --- a/proof/refine/ARM/EmptyFail_H.thy +++ b/proof/refine/ARM/EmptyFail_H.thy @@ -9,11 +9,11 @@ imports Refine begin crunch_ignore (empty_fail) - (add: handleE' getCTE getObject updateObject ifM andM orM whileM ifM + (add: handleE' getCTE getObject updateObject CSpaceDecls_H.resolveAddressBits doMachineOp suspend restart schedule) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas forM_empty_fail[intro!, wp, simp] = empty_fail_mapM[simplified forM_def[symmetric]] lemmas forM_x_empty_fail[intro!, wp, simp] = empty_fail_mapM_x[simplified forM_x_def[symmetric]] @@ -93,10 +93,6 @@ lemma empty_fail_getObject_ep [intro!, wp, simp]: "empty_fail (getObject p :: endpoint kernel)" by (simp add: empty_fail_getObject) -lemma empty_fail_getObject_reply [intro!, wp, simp]: - "empty_fail (getObject p :: reply kernel)" - by (simp add: empty_fail_getObject) - lemma getEndpoint_empty_fail [intro!, wp, simp]: "empty_fail (getEndpoint ep)" by (simp add: getEndpoint_def) @@ -167,22 +163,14 @@ lemma ignoreFailure_empty_fail[intro!, wp, simp]: "empty_fail x \ empty_fail (ignoreFailure x)" by (simp add: ignoreFailure_def empty_fail_catch) -lemma empty_fail_getObject_sc [intro!, wp, simp]: - "empty_fail (getObject p :: sched_context kernel)" - by (simp add: empty_fail_getObject) - -crunch "SchedContextDecls_H.postpone" - for (empty_fail) "_H_empty_fail"[intro!, wp, simp] - (simp: getSchedContext_def) - context notes option.case_cong_weak[cong] begin crunch - cancelIPC, setThreadState, tcbSchedDequeue, isStopped, possibleSwitchTo, tcbSchedAppend, - refillUnblockCheck, schedContextResume, ifCondRefillUnblockCheck - for (empty_fail) empty_fail[intro!, wp, simp] - (simp: Let_def wp: empty_fail_whileLoop) + cancelIPC, setThreadState, tcbSchedDequeue, setupReplyMaster, isStopped, + possibleSwitchTo, tcbSchedAppend + for (empty_fail) empty_fail[intro!, wp, simp] + (simp: crunch_simps) end crunch "ThreadDecls_H.suspend" @@ -191,7 +179,7 @@ crunch "ThreadDecls_H.suspend" lemma ThreadDecls_H_restart_empty_fail[intro!, wp, simp]: "empty_fail (ThreadDecls_H.restart target)" - unfolding restart_def getCurSc_def by wpsimp + by (fastforce simp: restart_def) crunch finaliseCap, preemptionPoint, capSwapForDelete for (empty_fail) empty_fail[intro!, wp, simp] @@ -271,44 +259,24 @@ lemma catchError_empty_fail[intro!, wp, simp]: by fastforce crunch - chooseThread, getDomainTime, nextDomain, isHighestPrio, switchSchedContext, setNextInterrupt - for (empty_fail) empty_fail[intro!, wp, simp] - (wp: empty_fail_catch empty_fail_setDeadline empty_fail_whileLoop) - -crunch tcbReleaseDequeue - for (empty_fail) empty_fail[intro!, wp, simp] - -lemma awaken_empty_fail[intro!, wp, simp]: - "empty_fail awaken" - apply (clarsimp simp: awaken_def awakenBody_def) - apply (wpsimp wp: empty_fail_whileLoop) - done + chooseThread, getDomainTime, nextDomain, isHighestPrio + for (empty_fail) empty_fail[intro!, wp, simp] + (wp: empty_fail_catch) lemma ThreadDecls_H_schedule_empty_fail[intro!, wp, simp]: "empty_fail schedule" - apply (simp add: schedule_def scAndTimer_def checkDomainTime_def) - apply (clarsimp simp: scheduleChooseNewThread_def split: if_split | wp | wpc | intro conjI impI)+ + apply (simp add: schedule_def) + apply (clarsimp simp: scheduleChooseNewThread_def split: if_split | wp | wpc)+ done -lemma tcbEPFindIndex_empty_fail[intro!, wp, simp]: - "empty_fail (tcbEPFindIndex t qs ci)" - by (induct ci; subst tcbEPFindIndex.simps; wpsimp) - crunch callKernel - for (empty_fail) empty_fail + for (empty_fail) empty_fail (wp: empty_fail_catch) theorem call_kernel_serial: "\ (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and - schact_is_rct and - current_time_bounded and - consumed_time_bounded and - valid_machine_time and - ct_not_in_release_q and - cur_sc_active and - (\s. cur_sc_offset_ready (consumed_time s) s) and - (\s. cur_sc_offset_sufficient (consumed_time s) s) and - (\s. 0 < domain_time s \ valid_domain_list s)) s; + schact_is_rct and + (\s. 0 < domain_time s \ valid_domain_list s)) s; \s'. (s, s') \ state_relation \ (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and (\s. ksSchedulerAction s = ResumeCurrentThread) and diff --git a/proof/refine/ARM/Finalise_R.thy b/proof/refine/ARM/Finalise_R.thy index 7d7f44acc0..3d04c44a1e 100644 --- a/proof/refine/ARM/Finalise_R.thy +++ b/proof/refine/ARM/Finalise_R.thy @@ -10,7 +10,7 @@ imports InterruptAcc_R Retype_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare doUnbindNotification_def[simp] @@ -37,8 +37,6 @@ lemma updateCap_cte_wp_at_cases: crunch postCapDeletion, updateTrackedFreeIndex for cte_wp_at'[wp]: "cte_wp_at' P p" -end - lemma updateFreeIndex_cte_wp_at: "\\s. cte_at' p s \ P (cte_wp_at' (if p = p' then P' o (cteCap_update (capFreeIndex_update (K idx))) else P') p' s)\ @@ -66,13 +64,10 @@ lemma emptySlot_cte_wp_cap_other: | wp (once) hoare_drop_imps)+ done -crunch clearUntypedFreeIndex - for sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - -global_interpretation clearUntypedFreeIndex: typ_at_all_props' "clearUntypedFreeIndex slot" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) +crunch emptySlot + for typ_at'[wp]: "\s. P (typ_at' T p s)" +lemmas clearUntypedFreeIndex_typ_ats[wp] + = typ_at_lifts[OF clearUntypedFreeIndex_typ_at'] crunch postCapDeletion for tcb_at'[wp]: "tcb_at' t" @@ -83,26 +78,20 @@ crunch clearUntypedFreeIndex (wp: cur_tcb_lift) crunch emptySlot - for ksRQ[wp]: "\s. P (ksReadyQueues s)" + for ksRQ[wp]: "\s. P (ksReadyQueues s)" crunch emptySlot - for ksRLQ[wp]: "\s. P (ksReleaseQueue s)" + for ksRQL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" crunch emptySlot - for ksRQL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" -crunch emptySlot - for ksRQL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + for ksRQL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" crunch postCapDeletion - for obj_at'[wp]: "\s. Q (obj_at' P p s)" + for obj_at'[wp]: "obj_at' P p" crunch clearUntypedFreeIndex - for inQ[wp]: "\s. P (obj_at' (inQ d p) t s)" -crunch clearUntypedFreeIndex - for tcbInReleaseQueue[wp]: "\s. P (obj_at' (tcbInReleaseQueue) t s)" + for inQ[wp]: "\s. P (obj_at' (inQ d p) t s)" crunch clearUntypedFreeIndex - for tcbDomain[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" -crunch clearUntypedFreeIndex - for tcbPriority[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t" + for tcbDomain[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" crunch clearUntypedFreeIndex - for tcbQueued[wp]: "obj_at' (\tcb. P (tcbQueued tcb)) t" + for tcbPriority[wp]: "obj_at' (\tcb. P (tcbPriority tcb)) t" crunch emptySlot for nosch[wp]: "\s. P (ksSchedulerAction s)" @@ -161,8 +150,9 @@ lemma mdb_chunked2D: done lemma nullPointer_eq_0_simp[simp]: + "(nullPointer = 0) = True" "(0 = nullPointer) = True" - by (simp add: nullPointer_def) + by (simp add: nullPointer_def)+ lemma no_0_no_0_lhs_trancl [simp]: "no_0 m \ \ m \ 0 \\<^sup>+ x" @@ -191,7 +181,7 @@ locale mdb_empty = slot (cteCap_update (%_. capability.NullCap))) slot (cteMDBNode_update (const nullMDBNode))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas m_slot_prev = m_p_prev lemmas m_slot_next = m_p_next @@ -1068,6 +1058,24 @@ lemma irq_control_n [simp]: "irq_control n" apply (erule (1) irq_controlD, rule irq_control) done +lemma reply_masters_rvk_fb_m: "reply_masters_rvk_fb m" + using valid by auto + +lemma reply_masters_rvk_fb_n [simp]: "reply_masters_rvk_fb n" + using reply_masters_rvk_fb_m + apply (simp add: reply_masters_rvk_fb_def n_def + ball_ran_modify_map_eq + modify_map_comp[symmetric]) + apply (subst ball_ran_modify_map_eq) + apply (frule bspec, rule ranI, rule slot) + apply (simp add: nullMDBNode_def isCap_simps modify_map_def + slot) + apply (subst ball_ran_modify_map_eq) + apply (clarsimp simp add: modify_map_def) + apply fastforce + apply (simp add: ball_ran_modify_map_eq) + done + lemma vmdb_n: "valid_mdb_ctes n" by (simp add: valid_mdb_ctes_def valid_dlist_n no_0_n mdb_chain_0_n valid_badges_n @@ -1109,8 +1117,9 @@ 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) + by (fastforce intro!: ext + 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)\ @@ -1128,9 +1137,21 @@ lemma updateCap_ko_wp_at_live[wp]: unfolding updateCap_def by wp -fun threadCapRefs :: "capability \ word32 set" where - "threadCapRefs (ThreadCap r) = {r}" -| "threadCapRefs _ = {}" +primrec + threadCapRefs :: "capability \ word32 set" +where + "threadCapRefs (ThreadCap r) = {r}" +| "threadCapRefs (ReplyCap t m x) = {}" +| "threadCapRefs NullCap = {}" +| "threadCapRefs (UntypedCap d r n i) = {}" +| "threadCapRefs (EndpointCap r badge x y z t) = {}" +| "threadCapRefs (NotificationCap r badge x y) = {}" +| "threadCapRefs (CNodeCap r b g gsz) = {}" +| "threadCapRefs (Zombie r b n) = {}" +| "threadCapRefs (ArchObjectCap ac) = {}" +| "threadCapRefs (IRQHandlerCap irq) = {}" +| "threadCapRefs (IRQControlCap) = {}" +| "threadCapRefs (DomainCap) = {}" definition "isFinal cap p m \ @@ -1191,7 +1212,8 @@ lemma emptySlot_iflive'[wp]: 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 (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") @@ -1199,13 +1221,16 @@ lemma emptySlot_iflive'[wp]: 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) + dest!: capMaster_same_refs) apply fastforce apply clarsimp apply (drule(1) bspec) apply (clarsimp simp: ko_wp_at'_def) done +crunch doMachineOp + for irq_node'[wp]: "\s. P (irq_node' s)" + 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) @@ -1250,7 +1275,10 @@ lemma emptySlot_ifunsafe'[wp]: lemma ctes_of_valid'[elim]: "\ctes_of s p = Some cte; valid_objs' s\ \ s \' cteCap cte" - by (rule ctes_of_valid_cap'') + by (cases cte, simp) (rule ctes_of_valid_cap') + +crunch postCapDeletion + for ksrq[wp]: "\s. P (ksReadyQueues s)" crunch setInterruptState for valid_idle'[wp]: "valid_idle'" @@ -1298,7 +1326,7 @@ lemma emptySlot_valid_global_refs[wp]: done lemmas doMachineOp_irq_handlers[wp] - = valid_irq_handlers_lift'' [OF doMachineOp_ctes doMachineOp_ksInterrupt] + = valid_irq_handlers_lift'' [OF doMachineOp_ctes doMachineOp_ksInterruptState] lemma deletedIRQHandler_irq_handlers'[wp]: "\\s. valid_irq_handlers' s \ (IRQHandlerCap irq \ ran (cteCaps_of s))\ @@ -1358,15 +1386,9 @@ lemma deletedIRQHandler_irqs_masked'[wp]: apply (simp add: irqs_masked'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma setObject_cte_irq_masked'[wp]: - "setObject p (v::cte) \irqs_masked'\" - unfolding setObject_def - by (wpsimp simp: irqs_masked'_def Ball_def wp: hoare_vcg_all_lift hoare_vcg_imp_lift' updateObject_cte_inv) - +context begin interpretation Arch . (*FIXME: arch-split*) crunch emptySlot - for irqs_masked'[wp]: "irqs_masked'" + for irqs_masked'[wp]: "irqs_masked'" lemma setIRQState_umm: "\\s. P (underlying_memory (ksMachineState s))\ @@ -1387,8 +1409,30 @@ lemma emptySlot_vms'[wp]: crunch emptySlot for pspace_domain_valid[wp]: "pspace_domain_valid" - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + +crunch emptySlot + for nosch[wp]: "\s. P (ksSchedulerAction s)" +crunch emptySlot + for ct[wp]: "\s. P (ksCurThread s)" +crunch emptySlot + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" +crunch emptySlot + for ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" +crunch emptySlot + for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + +lemma deletedIRQHandler_ct_not_inQ[wp]: + "\ct_not_inQ\ deletedIRQHandler irq \\_. ct_not_inQ\" + apply (rule ct_not_inQ_lift [OF deletedIRQHandler_nosch]) + apply (rule hoare_weaken_pre) + apply (wps deletedIRQHandler_ct) + apply (simp add: deletedIRQHandler_def setIRQState_def) + apply (wp) + apply (simp add: comp_def) + done + +crunch emptySlot + for ct_not_inQ[wp]: "ct_not_inQ" crunch emptySlot for tcbDomain[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" @@ -1430,18 +1474,21 @@ lemma emptySlot_untyped_ranges[wp]: done crunch emptySlot - for replies_of'[wp]: "\s. P (replies_of' s)" - and pspace_bounded'[wp]: pspace_bounded' + for valid_bitmaps[wp]: valid_bitmaps + and tcbQueued_opt_pred[wp]: "\s. P (tcbQueued |< tcbs_of' s)" + and valid_sched_pointers[wp]: valid_sched_pointers + and sched_projs[wp]: "\s. P (tcbSchedNexts_of s) (tcbSchedPrevs_of s)" + (wp: valid_bitmaps_lift) lemma emptySlot_invs'[wp]: "\\s. invs' s \ cte_wp_at' (\cte. removeable' sl s (cteCap cte)) sl s \ (\sl'. info \ NullCap \ sl' \ sl \ cteCaps_of s sl' \ Some info)\ emptySlot sl info \\rv. invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) apply (rule hoare_pre) - apply (wp valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift valid_replies'_lift) - apply (clarsimp simp: cte_wp_at_ctes_of o_def) + apply (wp valid_arch_state_lift' valid_irq_node_lift cur_tcb_lift) + apply (clarsimp simp: cte_wp_at_ctes_of) done lemma deletedIRQHandler_corres: @@ -1467,7 +1514,7 @@ lemma set_cap_trans_state: "((),s') \ fst (set_cap c p s) \ ((),trans_state f s') \ fst (set_cap c p (trans_state f s))" apply (cases p) apply (clarsimp simp add: set_cap_def in_monad set_object_def get_object_def) - apply (rename_tac obj s'' obj' kobj; case_tac obj) + apply (case_tac y) apply (auto simp add: in_monad set_object_def split: if_split_asm) done @@ -1490,7 +1537,8 @@ lemma clearUntypedFreeIndex_noop_corres: lemma clearUntypedFreeIndex_valid_pspace'[wp]: "\valid_pspace'\ clearUntypedFreeIndex slot \\rv. valid_pspace'\" apply (simp add: valid_pspace'_def) - apply (wpsimp wp: valid_replies'_lift valid_mdb'_lift) + apply (rule hoare_pre) + apply (wp | simp add: valid_mdb'_def)+ done lemma emptySlot_corres: @@ -1540,20 +1588,36 @@ lemma emptySlot_corres: apply (simp add: put_def) apply (simp add: exec_gets exec_get exec_put del: fun_upd_apply | subst bind_def)+ apply (clarsimp simp: state_relation_def) - apply (drule updateMDB_the_lot, fastforce, fastforce, fastforce) - apply (clarsimp simp: invs'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def) + apply (drule updateMDB_the_lot, fastforce simp: pspace_relations_def, fastforce, fastforce) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def + valid_mdb'_def valid_mdb_ctes_def) apply (elim conjE) apply (drule (4) updateMDB_the_lot, elim conjE) apply clarsimp - apply (drule_tac s'=s''a and c=cap.NullCap in set_cap_not_quite_corres; (simp (no_asm_simp))?) - subgoal by fastforce - subgoal by fastforce - subgoal by fastforce - apply (erule cte_wp_at_weakenE, rule TrueI) + apply (drule_tac s'=s''a and c=cap.NullCap in set_cap_not_quite_corres) + subgoal by simp + subgoal by simp + subgoal by simp + subgoal by fastforce + subgoal by fastforce + subgoal by fastforce + subgoal by fastforce + subgoal by fastforce + apply fastforce + subgoal by fastforce + subgoal by fastforce + subgoal by fastforce + apply (erule cte_wp_at_weakenE, rule TrueI) + apply assumption + subgoal by simp + subgoal by simp + subgoal by simp + subgoal by simp + apply (rule refl) apply clarsimp apply (drule updateCap_stuff, elim conjE, erule (1) impE) apply clarsimp - apply (drule updateMDB_the_lot, force, assumption+, simp) + apply (drule updateMDB_the_lot, force simp: pspace_relations_def, assumption+, simp) apply (rule bexI) prefer 2 apply (simp only: trans_state_update[symmetric]) @@ -1577,11 +1641,11 @@ lemma emptySlot_corres: apply (rule mdb_empty.intro) apply (rule mdb_ptr.intro) apply (rule vmdb.intro) - subgoal by (simp add: invs'_def valid_pspace'_def valid_mdb'_def) + subgoal by (simp add: invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def) apply (rule mdb_ptr_axioms.intro) subgoal by simp apply (clarsimp simp: ghost_relation_typ_at set_cap_a_type_inv) - + apply (simp add: pspace_relations_def) apply (rule conjI) apply (clarsimp simp: data_at_def ghost_relation_typ_at set_cap_a_type_inv) apply (rule conjI) @@ -1614,7 +1678,7 @@ lemma emptySlot_corres: prefer 2 apply(drule_tac cte="CTE s_cap s_node" in valid_mdbD2') subgoal by (clarsimp simp: valid_mdb_ctes_def no_0_def) - subgoal by (clarsimp simp: invs'_def valid_pspace'_def) + subgoal by (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) apply(clarsimp) apply(rule cte_map_inj_eq) apply(assumption) @@ -1734,9 +1798,7 @@ where "final_matters' cap \ case cap of EndpointCap ref bdg s r g gr \ True | NotificationCap ref bdg s r \ True - | ReplyCap ref gr \ True | ThreadCap ref \ True - | SchedContextCap ref sz \ True | CNodeCap ref bits gd gs \ True | Zombie ptr zb n \ True | IRQHandlerCap irq \ True @@ -1957,7 +2019,7 @@ lemma (in vmdb) isFinal_untypedParent: sameObjectAs_sym) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma no_fail_isFinalCapability [wp]: "no_fail (valid_mdb' and cte_wp_at' ((=) cte) p) (isFinalCapability cte)" @@ -2011,13 +2073,6 @@ lemma obj_refs_Master: by (clarsimp simp: isCap_simps split: cap_relation_split_asm arch_cap.split_asm) -(* FIXME RT: this should maybe replace is_sc_obj_def in is_obj_defs *) -lemma is_sc_obj_def': - "is_sc_obj n ko = (\sc. ko = kernel_object.SchedContext sc n \ valid_sched_context_size n)" - unfolding is_sc_obj_def - apply (case_tac ko; simp) - by fastforce - lemma isFinalCapability_corres': "final_matters' (cteCap cte) \ corres (=) (invs and cte_wp_at ((=) cap) ptr) @@ -2094,12 +2149,11 @@ lemma isFinalCapability_corres': apply (rule classical) apply (frule(1) zombies_finalD2[OF _ _ _ invs_zombies], simp?, clarsimp, assumption+) - apply (clarsimp simp: sameObjectAs_def3 isCap_simps valid_cap_def is_sc_obj_def' - obj_at_def is_obj_defs a_type_def final_matters'_def - simp del: is_sc_obj_def - split: cap.split_asm arch_cap.split_asm - option.split_asm if_split_asm, - simp_all add: is_cap_defs) + subgoal by (clarsimp simp: sameObjectAs_def3 isCap_simps valid_cap_def + obj_at_def is_obj_defs a_type_def final_matters'_def + split: cap.split_asm arch_cap.split_asm + option.split_asm if_split_asm, + simp_all add: is_cap_defs) apply (rule classical) by (clarsimp simp: cap_irqs_def cap_irq_opt_def sameObjectAs_def3 isCap_simps arch_gen_obj_refs_def split: cap.split_asm) @@ -2129,6 +2183,11 @@ definition finaliseCapTrue_standin_simple_def: "finaliseCapTrue_standin cap fin \ finaliseCap cap fin True" +context +begin + +declare if_cong [cong] + lemmas finaliseCapTrue_standin_def = finaliseCapTrue_standin_simple_def [unfolded finaliseCap_def, simplified] @@ -2140,16 +2199,14 @@ lemmas cteDeleteOne_def crunch cteDeleteOne, suspend, prepareThreadDelete 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 hoare_vcg_if_lift2 hoare_vcg_all_lift + (wp: crunch_wps getObject_inv loadObject_default_inv simp: crunch_simps unless_def o_def) end -global_interpretation cancelIPC: typ_at_all_props' "cancelIPC x" by typ_at_props' -global_interpretation cancelAllIPC: typ_at_all_props' "cancelAllIPC x" by typ_at_props' -global_interpretation cancelAllSignals: typ_at_all_props' "cancelAllSignals x" by typ_at_props' -global_interpretation suspend: typ_at_all_props' "suspend x" by typ_at_props' +lemmas cancelAllIPC_typs[wp] = typ_at_lifts [OF cancelAllIPC_typ_at'] +lemmas cancelAllSignals_typs[wp] = typ_at_lifts [OF cancelAllSignals_typ_at'] +lemmas suspend_typs[wp] = typ_at_lifts [OF suspend_typ_at'] definition arch_cap_has_cleanup' :: "arch_capability \ bool" @@ -2187,24 +2244,32 @@ lemma finaliseCap_cases[wp]: apply (auto simp add: isCap_simps cap_has_cleanup'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) - crunch finaliseCap for aligned'[wp]: "pspace_aligned'" - and distinct'[wp]:"pspace_distinct'" - 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 it'[wp]: "\s. P (ksIdleThread s)" - and irq_node'[wp]: "\s. P (irq_node' s)" - (wp: crunch_wps setObject_asidpool.getObject_inv hoare_vcg_all_lift simp: crunch_simps) + (simp: crunch_simps assertE_def unless_def o_def + wp: getObject_inv loadObject_default_inv crunch_wps) -end +crunch finaliseCap + for distinct'[wp]: "pspace_distinct'" + (simp: crunch_simps assertE_def unless_def o_def + wp: getObject_inv loadObject_default_inv crunch_wps) + +crunch finaliseCap + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (simp: crunch_simps assertE_def + wp: getObject_inv loadObject_default_inv crunch_wps) +lemmas finaliseCap_typ_ats[wp] = typ_at_lifts[OF finaliseCap_typ_at'] + +crunch finaliseCap + for it'[wp]: "\s. P (ksIdleThread s)" + (wp: mapM_x_wp_inv mapM_wp' hoare_drop_imps getObject_inv loadObject_default_inv + simp: crunch_simps o_def) -global_interpretation unbindFromSC: typ_at_all_props' "unbindFromSC t" - by typ_at_props' +crunch flush_space + for vs_lookup[wp]: "\s. P (vs_lookup s)" + (wp: crunch_wps) -global_interpretation finaliseCap: typ_at_all_props' "finaliseCap cap final x" - by typ_at_props' +declare doUnbindNotification_def[simp] lemma ntfn_q_refs_of'_mult: "ntfn_q_refs_of' ntfn = (case ntfn of Structures_H.WaitingNtfn q \ set q | _ \ {}) \ {NTFNSignal}" @@ -2215,566 +2280,112 @@ lemma tcb_st_not_Bound: "(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) - -lemma tcb_bound_refs'_not_Bound: - "(y, TCBBound) \ tcb_bound_refs' None sc_ptr yieldto_ptr" - by (clarsimp simp: tcb_bound_refs'_def 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) lemma unbindNotification_invs[wp]: - "unbindNotification tcb \invs'\" - apply (simp add: unbindNotification_def invs'_def valid_dom_schedule'_def) + "\invs'\ unbindNotification tcb \\rv. invs'\" + apply (simp add: unbindNotification_def invs'_def valid_state'_def) apply (rule bind_wp[OF _ gbn_sp']) 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' sbn_valid_queues valid_irq_node_lift - irqs_masked_lift setBoundNotification_ct_not_inQ - untyped_ranges_zero_lift | clarsimp simp: cteCaps_of_def o_def)+ + 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 projectKOs - split: ntfn.splits) - apply (rule conjI) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (clarsimp elim!: obj_atE' + simp: projectKOs + dest!: pred_tcb_at') apply (clarsimp simp: pred_tcb_at' conj_comms) + apply (frule bound_tcb_ex_cap'', clarsimp+) + apply (frule(1) sym_refs_bound_tcb_atD') + apply (frule(1) sym_refs_obj_atD') + apply (clarsimp simp: refs_of_rev') + apply normalise_obj_at' + apply (subst delta_sym_refs, assumption) + apply (auto split: if_split_asm)[1] + apply (auto simp: tcb_st_not_Bound ntfn_q_refs_of'_mult split: if_split_asm)[1] + apply (frule obj_at_valid_objs', clarsimp+) + apply (simp add: valid_ntfn'_def valid_obj'_def projectKOs + split: ntfn.splits) apply (erule if_live_then_nonz_capE') - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs live_ntfn'_def) + apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) done lemma ntfn_bound_tcb_at': - "\sym_refs (state_refs_of' s); ko_at' ntfn ntfnptr s; + "\sym_refs (state_refs_of' s); valid_objs' s; ko_at' ntfn ntfnptr s; ntfnBoundTCB ntfn = Some tcbptr; P (Some ntfnptr)\ \ bound_tcb_at' P tcbptr s" apply (drule_tac x=ntfnptr in sym_refsD[rotated]) apply (clarsimp simp: obj_at'_def projectKOs) apply (fastforce simp: state_refs_of'_def) - apply (auto simp: state_refs_of'_def pred_tcb_at'_def obj_at'_def - refs_of_rev' projectKOs + apply (auto simp: pred_tcb_at'_def obj_at'_def valid_obj'_def valid_ntfn'_def + state_refs_of'_def refs_of_rev' projectKOs + simp del: refs_of_simps + elim!: valid_objsE split: option.splits if_split_asm) done + lemma unbindMaybeNotification_invs[wp]: - "unbindMaybeNotification ntfnptr \invs'\" - apply (simp add: unbindMaybeNotification_def invs'_def valid_dom_schedule'_def) + "\invs'\ unbindMaybeNotification ntfnptr \\rv. invs'\" + apply (simp add: unbindMaybeNotification_def invs'_def valid_state'_def) apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (wpsimp wp: sbn'_valid_pspace'_inv sbn_sch_act' sbn_valid_queues - valid_irq_node_lift irqs_masked_lift setBoundNotification_ct_not_inQ - untyped_ranges_zero_lift - simp: cteCaps_of_def) - by (auto simp: pred_tcb_at' valid_pspace'_def projectKOs valid_obj'_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) - -lemma setNotification_invs': - "\invs' - and (\s. live_ntfn' ntfn \ ex_nonz_cap_to' ntfnPtr s) - and valid_ntfn' ntfn\ - setNotification ntfnPtr ntfn - \\rv. invs'\" - apply (simp add: invs'_def valid_dom_schedule'_def) - apply (wpsimp wp: valid_pde_mappings_lift' untyped_ranges_zero_lift simp: cteCaps_of_def o_def) - done - -lemma schedContextUnbindNtfn_valid_objs'[wp]: - "schedContextUnbindNtfn scPtr \valid_objs'\" - unfolding schedContextUnbindNtfn_def - apply (wpsimp wp: getNotification_wp hoare_vcg_all_lift hoare_vcg_imp_lift') - apply normalise_obj_at' - apply (rename_tac ntfnPtr ntfn sc) - apply (frule_tac k=ntfn in ko_at_valid_objs'; clarsimp simp: projectKOs) - apply (frule_tac k=sc in ko_at_valid_objs'; clarsimp simp: projectKOs valid_obj'_def) - by (auto simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps' - valid_ntfn'_def - split: ntfn.splits) - -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 - apply (wpsimp wp: getNotification_wp hoare_vcg_all_lift hoare_vcg_imp_lift' - typ_at_lifts valid_ntfn_lift' valid_pde_mappings_lift') - by (auto simp: ko_wp_at'_def obj_at'_def projectKOs live_sc'_def live_ntfn'_def o_def - elim!: if_live_then_nonz_capE') - -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 - by wpsimp - -crunch replyRemove - for 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' - 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 irqs_masked'[wp]: irqs_masked' - and valid_queues'[wp]: valid_queues' - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - and ct_not_inQ[wp]: ct_not_inQ - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and valid_pde_mappings'[wp]: valid_pde_mappings' - 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 valid_dom_schedule'[wp]: valid_dom_schedule' - and pspace_bounded'[wp]: pspace_bounded' - (simp: crunch_simps) - -context begin interpretation Arch . (*FIXME: arch_split*) - -crunch replyRemove, handleFaultReply - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" - (wp: crunch_wps simp: crunch_simps) - -end - -global_interpretation replyRemove: typ_at_all_props' "replyRemove replyPtr tcbPtr" - by typ_at_props' - -lemma replyNext_update_valid_objs': - "\valid_objs' and - (\s. ((\r. next_opt = Some (Next r) \ reply_at' r s) \ - (\sc. next_opt = Some (Head sc) \ sc_at' sc s)))\ - updateReply replyPtr (replyNext_update (\_. next_opt)) - \\_. valid_objs'\" - apply (case_tac next_opt - ; wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def) - by (case_tac a; clarsimp) - -lemma replyPop_valid_objs'[wp]: - "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_const) - apply (clarsimp simp: obj_at'_def) - apply (wpsimp wp: replyNext_update_valid_objs' hoare_drop_imp hoare_vcg_if_lift2)+ - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift2 )+ - apply (simp add: isHead_to_head) - apply (drule_tac k=x in ko_at_valid_objs'; clarsimp simp: projectKOs valid_obj'_def - valid_sched_context'_def valid_sched_context_size'_def objBits_def objBitsKO_def) - apply (drule_tac k=ko in ko_at_valid_objs'; clarsimp simp: projectKOs valid_obj'_def - valid_sched_context'_def valid_sched_context_size'_def objBits_def objBitsKO_def) - apply (clarsimp simp: valid_reply'_def) - done - -lemma replyRemove_valid_objs'[wp]: - "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 - | intro conjI impI)+ - done - -lemma replyPop_valid_replies'[wp]: - "\\s. valid_replies' s \ pspace_aligned' s \ pspace_distinct' s - \ sym_refs (list_refs_of_replies' s)\ - replyPop replyPtr tcbPtr - \\_. valid_replies'\" - unfolding replyPop_def - supply if_split[split del] - apply (wpsimp wp: hoare_vcg_imp_lift) - apply (wpsimp wp: updateReply_valid_replies'_bound hoare_vcg_imp_lift - hoare_vcg_all_lift hoare_vcg_ex_lift hoare_vcg_if_lift)+ - apply (rename_tac prevReplyPtr) - apply (drule_tac rptr=prevReplyPtr in valid_replies'D) - apply (frule reply_sym_heap_Prev_Next) - apply (frule_tac p=replyPtr in sym_heapD1) - apply (fastforce simp: opt_map_def obj_at'_def projectKOs) - apply clarsimp - apply (fastforce simp: obj_at'_def projectKOs elim!: opt_mapE) - done - -lemma replyRemove_valid_replies'[wp]: - "\\s. valid_replies' s \ pspace_aligned' s \ pspace_distinct' s - \ sym_refs (list_refs_of_replies' s)\ - replyRemove replyPtr tcbPtr - \\_. valid_replies'\" - unfolding replyRemove_def - by (wpsimp wp: hoare_vcg_imp_lift') - -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')+ - -lemma replyRemove_valid_mdb'[wp]: - "replyRemove replyPtr tcbPtr \valid_mdb'\" - unfolding replyRemove_def - by (wpsimp wp: gts_wp')+ - -lemma replyPop_valid_pspace'[wp]: - "\\s. valid_pspace' s \ sym_refs (list_refs_of_replies' s)\ - replyPop replyPtr tcbPtr - \\_. valid_pspace'\" - by (wpsimp simp: valid_pspace'_def) - -lemma replyRemove_valid_pspace'[wp]: - "\\s. valid_pspace' s \ sym_refs (list_refs_of_replies' s)\ - replyRemove replyPtr tcbPtr - \\_. valid_pspace'\" - by (wpsimp simp: valid_pspace'_def) - -lemma replyPop_valid_queues[wp]: - "\valid_queues and valid_objs'\ replyPop replyPtr tcbPtr \\_. valid_queues\" - supply if_split[split del] - apply (clarsimp simp: replyPop_def) - apply (wpsimp wp: schedContextDonate_valid_queues hoare_vcg_if_lift2 hoare_vcg_conj_lift - hoare_vcg_imp_lift' threadGet_const) - apply (wp updateReply_obj_at'_only_st_qd_ft) - apply (wpsimp wp: replyNext_update_valid_objs') - apply (wpsimp wp: hoare_vcg_imp_lift updateReply_obj_at'_only_st_qd_ft) - apply (wpsimp wp: replyNext_update_valid_objs') - apply (wpsimp wp: hoare_vcg_imp_lift updateReply_obj_at'_only_st_qd_ft) - apply (rule_tac Q= - "\_ s. valid_queues s \ valid_objs' s \ - (\r. replyNext reply = Some (Next r) \ reply_at' r s) \ - (\sc. replyNext reply = Some (Head sc) \ sc_at' sc s) \ - (obj_at' ((\rv. rv = None) \ tcbSchedContext) tcbPtr s \ valid_queues s)" - in hoare_post_imp) - apply (clarsimp split: if_split) - apply (wpsimp wp: set_sc'.set_no_update gts_wp' schedContextDonate_valid_pspace' - hoare_vcg_imp_lift')+ - apply (case_tac reply; clarsimp) - apply (wpfix add: reply.sel) - apply (wpsimp wp: hoare_vcg_disj_lift hoare_vcg_all_lift replyNext_update_valid_objs' - updateReply_obj_at'_only_st_qd_ft) - apply (wpsimp wp: hoare_vcg_disj_lift hoare_vcg_imp_lift - updateReply_obj_at'_only_st_qd_ft) - apply (wpsimp wp: hoare_vcg_disj_lift hoare_vcg_imp_lift hoare_vcg_all_lift - hoare_vcg_if_lift2) - apply (wpsimp wp: hoare_vcg_imp_lift set_sc'.valid_queues) - apply (wpsimp wp: gts_wp')+ - apply (simp add: isHead_to_head split: if_splits) - apply (drule_tac k=ko in ko_at_valid_objs'; clarsimp simp: projectKOs valid_obj'_def - valid_sched_context'_def valid_sched_context_size'_def objBits_def objBitsKO_def) - apply (drule_tac k=koa in ko_at_valid_objs'; clarsimp simp: projectKOs valid_obj'_def - valid_sched_context'_def valid_sched_context_size'_def objBits_def objBitsKO_def) - apply (clarsimp simp: valid_reply'_def) - done - -lemma replyRemove_valid_queues[wp]: - "\valid_queues and valid_objs'\ - replyRemove replyPtr tcbPtr - \\_. valid_queues\" - apply (clarsimp simp: replyRemove_def) - apply (wpsimp wp: gts_wp') - done - -lemma replyPop_list_refs_of_replies'[wp]: - "\\s. sym_refs (list_refs_of_replies' s) \ obj_at' (\reply. replyNext reply \ None) replyPtr s\ - replyPop replyPtr tcbPtr - \\_ s. sym_refs (list_refs_of_replies' s)\" - unfolding replyPop_def - apply (rule bind_wp_fwd_skip, wpsimp) - apply clarsimp - apply (rule bind_wp[OF _ get_reply_sp']) - apply (rule bind_wp_fwd_skip, solves \wpsimp\, simp?)+ - apply (rule bind_wp) - apply (wpsimp wp: cleanReply_list_refs_of_replies') - apply (rule hoare_when_cases) - apply (clarsimp simp: obj_at'_def) - apply (rule bind_wp[OF _ assert_sp]) - apply (rule bind_wp_fwd_skip, solves \wpsimp simp: comp_def\, simp?)+ - apply (subst bind_assoc[symmetric]) - apply (rule bind_wp) - apply (rule bind_wp_fwd_skip, solves \wpsimp\, simp?) - apply (wpsimp wp: hoare_when_cases) - apply (wp updateReply_list_refs_of_replies' hoare_vcg_all_lift hoare_drop_imp) - apply (clarsimp simp: isHead_def split: reply_next.splits) - apply (intro conjI impI) - apply clarsimp - apply (rename_tac prevReplyPtr prevReply) - apply (frule_tac reply=prevReply in ko_at'_replies_of') - apply (frule_tac rp=prevReplyPtr and rp'=replyPtr in sym_refs_replyNext_replyPrev_sym) - apply (clarsimp?, - erule delta_sym_refs - ; clarsimp simp: isHead_def obj_at'_def projectKOs list_refs_of_reply'_def - list_refs_of_replies'_def opt_map_def get_refs_def - split: if_splits option.splits)+ - done - -\ \An almost exact duplicate of replyRemoveTCB_list_refs_of_replies'\ -lemma replyRemove_list_refs_of_replies'[wp]: - "replyRemove replyPtr tcbPtr \\s. sym_refs (list_refs_of_replies' s)\" - unfolding replyRemove_def decompose_list_refs_of_replies' - supply if_cong[cong] - apply (wpsimp wp: cleanReply_list_refs_of_replies' hoare_vcg_if_lift hoare_vcg_imp_lift' gts_wp' - haskell_assert_wp - replyPop_list_refs_of_replies'[simplified decompose_list_refs_of_replies'] - simp: pred_tcb_at'_def - split_del: if_split) - unfolding decompose_list_refs_of_replies'[symmetric] protected_sym_refs_def[symmetric] - \\ opt_mapE will sometimes destroy the @{term "(|>)"} inside @{term replyNexts_of} - and @{term replyPrevs_of}, but we're using those as our local normal form. \ - supply opt_mapE[rule del] - apply (intro conjI impI allI) - \\ Our 6 cases correspond to various cases of @{term replyNext} and @{term replyPrev}. - We use @{thm ks_reply_at'_repliesD} to turn those cases into facts about - @{term replyNexts_of} and @{term replyPrevs_of}. \ - apply (all \normalise_obj_at'\) - apply (all \drule(1) ks_reply_at'_repliesD[OF ko_at'_replies_of', - folded protected_sym_refs_def] - , clarsimp simp: projectKO_reply isHead_to_head\) - \\ Now, for each case we can blow open @{term sym_refs}, which will give us enough new - @{term "(replyNexts_of, replyPrevs_of)"} facts that we can throw it all at metis. \ - apply (clarsimp simp: sym_refs_def split_paired_Ball in_get_refs - , intro conjI impI allI - ; metis sym_refs_replyNext_replyPrev_sym[folded protected_sym_refs_def] option.sel - option.inject)+ - done - -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\ - \ ko_wp_at' live' (theHeadScPtr (Some reply_next)) s" - apply (clarsimp simp: theHeadScPtr_def getHeadScPtr_def isHead_def - split: reply_next.splits) - apply (rename_tac head) - apply (prop_tac "(head, ReplySchedContext) \ state_refs_of' s replyPtr") - apply (clarsimp simp: state_refs_of'_def get_refs_def2 obj_at'_def projectKOs) - 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 projectKOs ko_wp_at'_def - live_sc'_def) - done - -lemma replyPop_iflive: - "\(if_live_then_nonz_cap' and valid_objs' and ex_nonz_cap_to' tcbPtr) - and (\s. sym_refs (list_refs_of_replies' s))\ - replyPop replyPtr tcbPtr - \\_. if_live_then_nonz_cap'\" - (is "valid (?pred and _) _ ?post") - apply (clarsimp simp: replyPop_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - 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_tac Q'="?post" in bind_wp; (solves wpsimp)?) - apply clarsimp - apply (rename_tac reply tptr state) - apply (rule hoare_when_cases, simp) - apply (intro bind_wp[OF _ get_sc_sp'] - bind_wp[OF _ assert_sp] - bind_wp[OF _ assert_opt_sp]) - - apply (rule_tac Q'="\_ s. ?pred s \ sym_refs (list_refs_of_replies' s) \ ko_at' reply replyPtr s - \ isHead (replyNext reply) - \ ex_nonz_cap_to' (theHeadScPtr (replyNext reply)) s" - in bind_wp_fwd) - apply (wpsimp wp: setSchedContext_iflive' schedContextDonate_if_live_then_nonz_cap') - apply (frule (1) sc_ko_at_valid_objs_valid_sc') - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (clarsimp simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps - comp_def valid_reply'_def getReplyNextPtr_def sym_refs_asrt_def) - apply (fastforce elim: if_live_then_nonz_capE' - intro: live'_HeadScPtr) - - apply clarsimp - apply (rename_tac reply_next) - apply (subst bind_assoc[symmetric]) - apply (rule_tac Q'="\_ s. ?pred s \ ex_nonz_cap_to' (theHeadScPtr (Some reply_next)) s" - in bind_wp_fwd) - - apply (clarsimp simp: when_def) - apply (intro conjI impI) - apply clarsimp - apply (rename_tac replyPrevPtr) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) - apply (rule_tac Q'="\_ s. ?pred s \ ex_nonz_cap_to' replyPtr s" in bind_wp_fwd) - apply (wpsimp wp: updateReply_iflive'_strong updateReply_valid_objs') - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (clarsimp simp: valid_reply'_def getReplyNextPtr_def) - apply (rule conjI) - apply (clarsimp simp: live_reply'_def valid_reply'_def isHead_def - split: reply_next.splits) - apply (erule if_live_then_nonz_capE') - apply (prop_tac "(replyPrevPtr, ReplyPrev) \ list_refs_of_replies' s replyPtr") - apply (clarsimp simp: list_refs_of_replies'_def get_refs_def2 obj_at'_def projectKOs - comp_def opt_map_def list_refs_of_reply'_def) - apply (prop_tac "(replyPtr, ReplyNext) \ list_refs_of_replies' s replyPrevPtr") - apply (fastforce simp: sym_refs_def) - apply (clarsimp simp: ko_wp_at'_def obj_at'_def projectKOs list_refs_of_replies'_def - opt_map_def list_refs_of_reply'_def) - apply (fastforce elim: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def projectKOs live_reply'_def) - apply (clarsimp simp: obj_at'_def) - apply (wpsimp wp: updateReply_iflive'_strong updateReply_valid_objs') - apply (rule_tac Q'="\_. valid_objs'" in bind_wp_fwd) - apply (wpsimp wp: updateReply_valid_objs' hoare_vcg_all_lift) - apply (fastforce dest: reply_ko_at_valid_objs_valid_reply' - simp: valid_reply'_def getReplyNextPtr_def valid_bound_obj'_def) - apply (wpsimp wp: updateReply_valid_objs' hoare_vcg_all_lift) - apply (clarsimp simp: valid_reply'_def getReplyNextPtr_def valid_bound_obj'_def) - - apply (wpsimp wp: updateReply_iflive'_strong updateReply_valid_objs') - apply (fastforce elim: if_live_then_nonz_capE' - simp: valid_reply'_def ko_wp_at'_def obj_at'_def projectKOs live_reply'_def) - - apply (rule bind_wp[OF _ threadGet_sp]) - apply (wpsimp wp: schedContextDonate_if_live_then_nonz_cap') - done - -lemma replyRemove_if_live_then_nonz_cap': - "\if_live_then_nonz_cap' and valid_objs' and ex_nonz_cap_to' tcbPtr - and (\s. sym_refs (list_refs_of_replies' s))\ - 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 projectKOs 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) - done - -lemma replyPop_valid_idle': - "\\s. valid_idle' s - \ tcbPtr \ ksIdleThread s - \ (\scPtr. obj_at' (\r. replyNext r = Some (Head scPtr)) replyPtr s - \ obj_at' (\sc. scTCB sc \ Some idle_thread_ptr) scPtr s)\ - replyPop replyPtr tcbPtr - \\_. valid_idle'\" - apply (clarsimp simp: replyPop_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - 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_tac Q'="\_. valid_idle' and (\s. tcbPtr \ ksIdleThread s)" in bind_wp) - apply wpsimp - apply (rule hoare_when_cases, simp) - apply clarsimp - apply (rename_tac reply_next) - apply (rule bind_wp[OF _ assert_sp]) - apply (rule bind_wp[OF _ get_sc_sp']) - apply (rule_tac Q'="\_ s. valid_idle' s \ tcbPtr \ idle_thread_ptr - \ obj_at' (\sc. scTCB sc \ Some idle_thread_ptr) - (theHeadScPtr (Some reply_next)) s" - in bind_wp) - apply (wpsimp wp: schedContextDonate_valid_idle' hoare_vcg_if_lift2 hoare_vcg_imp_lift' - threadGet_const updateReply_obj_at'_only_st_qd_ft) - apply (clarsimp simp: valid_idle'_def) - apply (wpsimp wp: setSchedContext_valid_idle' - | wpsimp wp: set_sc'.set_wp)+ - apply (auto simp: valid_idle'_def obj_at'_def projectKOs isHead_def objBits_simps ps_clear_def - split: reply_next.splits) - done - -lemma replyRemove_valid_idle'[wp]: - "\\s. valid_idle' s \ tcbPtr \ ksIdleThread s \ valid_objs' s\ - replyRemove replyPtr tcbPtr - \\_. valid_idle'\" - apply (clarsimp simp: replyRemove_def) - apply (wpsimp wp: replyPop_valid_idle' gts_wp') - apply (rename_tac reply scPtr reply_next) - apply (clarsimp simp: sym_refs_asrt_def) - apply (rule ccontr) - apply (prop_tac "obj_at' (\sc. scTCB sc = Some idle_thread_ptr) scPtr s") - apply (prop_tac "sc_at' scPtr s") - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (fastforce simp: obj_at'_def valid_reply'_def) - apply (fastforce simp: obj_at'_def) - apply (prop_tac "replySCs_of s replyPtr = Some scPtr") - apply (clarsimp simp: opt_map_def obj_at'_def projectKOs) - apply (prop_tac "(idle_thread_ptr, SCTcb) \ state_refs_of' s scPtr") - apply (clarsimp simp: state_refs_of'_def get_refs_def2 obj_at'_def projectKOs) - apply (prop_tac "scPtr = idle_sc_ptr") - apply (frule idle'_only_sc_refs) - apply (fastforce dest: sym_refsD - simp: valid_idle'_def) - apply (prop_tac "(scPtr, ReplySchedContext) \ state_refs_of' s replyPtr") - apply (clarsimp simp: state_refs_of'_def obj_at'_def projectKOs) - apply (prop_tac "(replyPtr, SCReply) \ state_refs_of' s scPtr") - apply (fastforce simp: sym_refs_def) - apply (auto simp: valid_idle'_def obj_at'_def projectKOs state_refs_of'_def) - done - -lemma replyPop_invs': - "\invs' and obj_at' (\reply. replyNext reply \ None) replyPtr - and ex_nonz_cap_to' tcbPtr\ - replyPop replyPtr tcbPtr - \\_. invs'\" - unfolding invs'_def - apply (wpsimp wp: replyPop_iflive simp: valid_pspace'_def) - done - -lemma replyRemove_invs': - "\invs' and ex_nonz_cap_to' tcbPtr\ - replyRemove replyPtr tcbPtr - \\_. invs'\" - unfolding invs'_def - apply (wpsimp wp: replyRemove_if_live_then_nonz_cap' replyRemove_valid_idle') - done - -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 - apply (fastforce simp: pred_tcb_at'_def obj_at'_def ko_wp_at'_def projectKOs) + apply (rule hoare_pre) + apply (wp sbn'_valid_pspace'_inv sbn_sch_act' sym_heap_sched_pointers_lift valid_irq_node_lift + irqs_masked_lift setBoundNotification_ct_not_inQ + untyped_ranges_zero_lift + | wpc | clarsimp simp: cteCaps_of_def o_def)+ + apply safe[1] + defer 3 + defer 7 + apply (fold_subgoals (prefix))[8] + subgoal premises prems using prems by (auto simp: pred_tcb_at' valid_pspace'_def projectKOs valid_obj'_def valid_ntfn'_def + ko_wp_at'_def + elim!: obj_atE' valid_objsE' if_live_then_nonz_capE' + split: option.splits ntfn.splits) + apply (rule delta_sym_refs, assumption) + apply (fold_subgoals (prefix))[2] + subgoal premises prems using prems by (fastforce simp: symreftype_inverse' ntfn_q_refs_of'_def + split: ntfn.splits if_split_asm + dest!: ko_at_state_refs_ofD')+ + apply (rule delta_sym_refs, assumption) + apply (clarsimp split: if_split_asm) + apply (frule ko_at_state_refs_ofD', simp) + apply (clarsimp split: if_split_asm) + apply (frule_tac P="(=) (Some ntfnptr)" in ntfn_bound_tcb_at', simp_all add: valid_pspace'_def)[1] + subgoal by (fastforce simp: ntfn_q_refs_of'_def state_refs_of'_def tcb_ntfn_is_bound'_def + tcb_st_refs_of'_def + dest!: bound_tcb_at_state_refs_ofD' + split: ntfn.splits thread_state.splits) + apply (frule ko_at_state_refs_ofD', simp) done (* Ugh, required to be able to split out the abstract invs *) -lemma finaliseCap_True_invs'[wp]: - "finaliseCap cap final True \invs'\" - unfolding finaliseCap_def sym_refs_asrt_def - apply (wpsimp wp: irqs_masked_lift simp: Let_def split_del: if_split) - apply clarsimp +lemma finaliseCap_True_invs[wp]: + "\invs'\ finaliseCap cap final True \\rv. invs'\" + apply (simp add: finaliseCap_def Let_def) + apply safe + apply (wp irqs_masked_lift| simp | wpc)+ done -context begin interpretation Arch . (*FIXME: arch_split*) - crunch flushSpace - for invs'[wp]: "invs'" (ignore: doMachineOp) + for invs'[wp]: "invs'" (ignore: doMachineOp) lemma invs_asid_update_strg': "invs' s \ tab = armKSASIDTable (ksArchState s) \ invs' (s\ksArchState := armKSASIDTable_update (\_. tab (asid := None)) (ksArchState s)\)" apply (simp add: invs'_def) - apply (simp add: valid_global_refs'_def global_refs'_def valid_arch_state'_def - valid_asid_table'_def valid_machine_state'_def ct_idle_or_in_cur_domain'_def - tcb_in_cur_domain'_def valid_dom_schedule'_def) + apply (simp add: valid_state'_def) + apply (simp add: valid_global_refs'_def global_refs'_def valid_arch_state'_def valid_asid_table'_def valid_machine_state'_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) apply (auto simp add: ran_def split: if_split_asm) done @@ -2785,7 +2396,7 @@ lemma invalidateASIDEntry_invs' [wp]: apply (wp loadHWASID_wp | simp)+ apply (clarsimp simp: fun_upd_def[symmetric]) apply (rule conjI) - apply (clarsimp simp: invs'_def valid_dom_schedule'_def) + apply (clarsimp simp: invs'_def valid_state'_def) apply (rule conjI) apply (simp add: valid_global_refs'_def global_refs'_def) @@ -2797,12 +2408,13 @@ lemma invalidateASIDEntry_invs' [wp]: valid_asid_map'_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) subgoal by (auto elim!: subset_inj_on) - apply (clarsimp simp: invs'_def valid_dom_schedule'_def) + apply (clarsimp simp: invs'_def valid_state'_def) apply (rule conjI) apply (simp add: valid_global_refs'_def global_refs'_def) apply (rule conjI) - apply (simp add: valid_arch_state'_def ran_def valid_asid_table'_def + apply (simp add: valid_arch_state'_def ran_def + valid_asid_table'_def None_upd_eq fun_upd_def[symmetric] comp_upd_simp) apply (simp add: valid_machine_state'_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) done @@ -2811,8 +2423,10 @@ lemma deleteASIDPool_invs[wp]: "\invs'\ deleteASIDPool asid pool \\rv. invs'\" apply (simp add: deleteASIDPool_def) apply wp - apply (strengthen invs_asid_update_strg') - apply (wpsimp wp: mapM_wp' getObject_inv)+ + apply (simp del: fun_upd_apply) + apply (strengthen invs_asid_update_strg') + apply (wp mapM_wp' getObject_inv loadObject_default_inv + | simp)+ done lemma invalidateASIDEntry_valid_ap' [wp]: @@ -2824,12 +2438,7 @@ lemma invalidateASIDEntry_valid_ap' [wp]: apply (clarsimp simp del: fun_upd_apply) done -end - -sublocale Arch < flushSpace: typ_at_all_props' "flushSpace asid" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas flushSpace_typ_ats' [wp] = typ_at_lifts [OF flushSpace_typ_at'] lemma deleteASID_invs'[wp]: "\invs'\ deleteASID asid pd \\rv. invs'\" @@ -2848,8 +2457,9 @@ lemma deleteASID_invs'[wp]: apply (drule subsetD, blast) apply clarsimp apply (auto dest!: ran_del_subset)[1] - apply (wpsimp wp: getObject_valid_obj getObject_inv - simp: objBits_simps archObjSize_def pageBits_def)+ + apply (wp getObject_valid_obj getObject_inv loadObject_default_inv + | simp add: objBits_simps archObjSize_def pageBits_def)+ + apply clarsimp done lemma arch_finaliseCap_invs[wp]: @@ -2887,9 +2497,11 @@ lemma prepares_delete_helper'': apply (clarsimp simp: removeable'_def) done +lemmas ctes_of_cteCaps_of_lift = cteCaps_of_ctes_of_lift + crunch finaliseCapTrue_standin, unbindNotification for ctes_of[wp]: "\s. P (ctes_of s)" - (wp: crunch_wps getObject_inv simp: crunch_simps) + (wp: crunch_wps getObject_inv loadObject_default_inv simp: crunch_simps) lemma cteDeleteOne_cteCaps_of: "\\s. (cte_wp_at' (\cte. \final. finaliseCap (cteCap cte) final True \ fail) p s \ @@ -2921,26 +2533,15 @@ lemma cteDeleteOne_isFinal: apply (clarsimp simp: isFinal_def sameObjectAs_def2) done -lemmas setEndpoint_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_ep'.ctes_of] -lemmas setNotification_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_ntfn'.ctes_of] -lemmas setSchedContext_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_sc'.ctes_of] -lemmas setReply_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_reply'.ctes_of] -lemmas setQueue_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF setQueue_ctes_of] -lemmas sts_cteCaps_of[wp] = ctes_of_cteCaps_of_lift[OF sts_ctes_of] - -crunch replyRemoveTCB - for ctes_of[wp]: "\s. P (ctes_of s)" - (simp: crunch_simps st_tcb_at'_def wp: crunch_wps) - -lemmas replyRemoveTCB_cteCaps_of[wp] = ctes_of_cteCaps_of_lift[OF replyRemoveTCB_ctes_of] +lemmas setEndpoint_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_ep_ctes_of] +lemmas setNotification_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_ntfn_ctes_of] +lemmas threadSet_cteCaps_of = ctes_of_cteCaps_of_lift [OF threadSet_ctes_of] -crunch - suspend, prepareThreadDelete, schedContextUnbindTCB, schedContextCompleteYieldTo, - unbindFromSC - for isFinal[wp]: "\s. isFinal cap slot (cteCaps_of s)" +crunch suspend, prepareThreadDelete + for isFinal: "\s. isFinal cap slot (cteCaps_of s)" (ignore: threadSet wp: threadSet_cteCaps_of crunch_wps - simp: crunch_simps) + simp: crunch_simps unless_def o_def) lemma isThreadCap_threadCapRefs_tcbptr: "isThreadCap cap \ threadCapRefs cap = {capTCBPtr cap}" @@ -2957,6 +2558,12 @@ lemma cteDeleteOne_deletes[wp]: apply clarsimp done +crunch finaliseCap + for irq_node'[wp]: "\s. P (irq_node' s)" + (wp: mapM_x_wp crunch_wps getObject_inv loadObject_default_inv + updateObject_default_inv setObject_ksInterrupt + simp: crunch_simps unless_def o_def) + lemma deletingIRQHandler_removeable': "\invs' and (\s. isFinal (IRQHandlerCap irq) slot (cteCaps_of s)) and K (cap = IRQHandlerCap irq)\ @@ -2979,10 +2586,16 @@ lemma finaliseCap_cte_refs: apply (simp add: finaliseCap_def Let_def getThreadCSpaceRoot ARM_H.finaliseCap_def cong: if_cong split del: if_split) - apply wpsimp + apply (rule hoare_pre) + apply (wp | wpc | simp only: o_def)+ apply (frule valid_capAligned) apply (cases cap, simp_all add: isCap_simps) - by (auto simp: capAligned_def objBits_simps shiftL_nat cte_refs'_def tcb_cte_cases_def word_count_from_top objBits_defs) + apply (clarsimp simp: tcb_cte_cases_def word_count_from_top objBits_defs) + apply clarsimp + apply (rule ext, simp) + apply (rule image_cong [OF _ refl]) + apply (fastforce simp: capAligned_def objBits_simps shiftL_nat) + done lemma deletingIRQHandler_final: "\\s. isFinal cap slot (cteCaps_of s) @@ -3007,13 +2620,16 @@ lemma unbindNotification_valid_objs'_helper': by (clarsimp simp: valid_bound_tcb'_def valid_ntfn'_def split: option.splits ntfn.splits) +lemmas setNotification_valid_tcb' = typ_at'_valid_tcb'_lift [OF setNotification_typ_at'] + lemma unbindNotification_valid_objs'[wp]: "\valid_objs'\ unbindNotification t \\rv. valid_objs'\" apply (simp add: unbindNotification_def) apply (rule hoare_pre) - apply (wp threadSet_valid_objs' gbn_wp' set_ntfn_valid_objs' hoare_vcg_all_lift getNotification_wp + apply (wp threadSet_valid_objs' gbn_wp' set_ntfn_valid_objs' hoare_vcg_all_lift + setNotification_valid_tcb' getNotification_wp | wpc | clarsimp simp: setBoundNotification_def unbindNotification_valid_objs'_helper)+ apply (clarsimp elim!: obj_atE' simp: projectKOs) apply (rule valid_objsE', assumption+) @@ -3027,7 +2643,8 @@ lemma unbindMaybeNotification_valid_objs'[wp]: apply (simp add: unbindMaybeNotification_def) 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 + apply (wp threadSet_valid_objs' gbn_wp' set_ntfn_valid_objs' hoare_vcg_all_lift + setNotification_valid_tcb' getNotification_wp | wpc | clarsimp simp: setBoundNotification_def unbindNotification_valid_objs'_helper)+ apply (clarsimp elim!: obj_atE' simp: projectKOs) apply (rule valid_objsE', assumption+) @@ -3048,9 +2665,9 @@ lemma valid_cong: \ \P\ f \Q\ = \P'\ f' \Q'\" by (clarsimp simp add: valid_def, blast) -lemma unbindMaybeNotification_obj_at'_ntfnBound: +lemma unbindMaybeNotification_obj_at'_bound: "\\\ - unbindMaybeNotification r + unbindMaybeNotification r \\_ s. obj_at' (\ntfn. ntfnBoundTCB ntfn = None) r s\" apply (simp add: unbindMaybeNotification_def) apply (rule bind_wp[OF _ get_ntfn_sp']) @@ -3063,187 +2680,61 @@ lemma unbindMaybeNotification_obj_at'_ntfnBound: apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) 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 _ get_ntfn_sp']) - apply (rule hoare_pre) - apply (wp obj_at_setObject2 - | wpc - | simp add: setBoundNotification_def threadSet_def updateObject_default_def in_monad projectKOs)+ - apply (simp add: setNotification_def obj_at'_real_def cong: valid_cong) - apply (wp setObject_ko_wp_at, (simp add: objBits_simps')+) - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) - done - context notes option.case_cong_weak[cong] begin crunch unbindNotification, unbindMaybeNotification for isFinal[wp]: "\s. isFinal cap slot (cteCaps_of s)" - (wp: threadSet_cteCaps_of crunch_wps ignore: threadSet) + (wp: sts_bound_tcb_at' threadSet_cteCaps_of crunch_wps getObject_inv loadObject_default_inv + ignore: threadSet) +end crunch cancelSignal, cancelAllIPC for bound_tcb_at'[wp]: "bound_tcb_at' P t" - and bound_sc_tcb_at'[wp]: "bound_sc_tcb_at' P t" - (wp: crunch_wps) - -lemma setSchedContext_pde_mappings'[wp]: - "setSchedContext p sc \valid_pde_mappings'\" - by (wp valid_pde_mappings_lift') - -lemma schedContextUnbindTCB_invs'_helper: - "\\s. invs' s \ valid_idle' s \ cur_tcb' s \ scPtr \ idle_sc_ptr - \ ko_at' sc scPtr s - \ scTCB sc = Some tcbPtr - \ bound_sc_tcb_at' ((=) (Some scPtr)) tcbPtr s - \ (\a b. tcbPtr \ set (ksReadyQueues s (a, b)))\ - do threadSet (tcbSchedContext_update (\_. Nothing)) tcbPtr; - setSchedContext scPtr $ scTCB_update (\_. Nothing) sc - od - \\_. invs'\" - unfolding schedContextUnbindTCB_def invs'_def - apply (wp threadSet_valid_queues_no_state threadSet_valid_queues'_no_state - threadSet_valid_release_queue threadSet_valid_release_queue' - threadSet_not_inQ threadSet_idle' threadSet_iflive' threadSet_ifunsafe'T - threadSet_valid_pspace'T threadSet_sch_actT_P[where P=False, simplified] - threadSet_ctes_ofT threadSet_ct_idle_or_in_cur_domain' threadSet_cur - threadSet_global_refsT irqs_masked_lift untyped_ranges_zero_lift - valid_irq_node_lift valid_irq_handlers_lift'' - | (rule hoare_vcg_conj_lift, rule threadSet_wp) - | clarsimp simp: tcb_cte_cases_def cteCaps_of_def valid_dom_schedule'_def)+ - apply (frule ko_at_valid_objs'_pre[where p=scPtr], clarsimp) - (* slow 60s *) - by (auto elim!: ex_cap_to'_after_update[OF if_live_state_refsE[where p=scPtr]] - elim: valid_objs_sizeE'[OF valid_objs'_valid_objs_size'] ps_clear_domE - split: option.splits - simp: pred_tcb_at'_def ko_wp_at'_def obj_at'_def objBits_def objBitsKO_def - projectKO_eq projectKO_tcb projectKO_ntfn projectKO_reply projectKO_sc - tcb_cte_cases_def valid_sched_context'_def valid_sched_context_size'_def - valid_bound_obj'_def valid_obj'_def valid_obj_size'_def valid_idle'_def - valid_release_queue'_def valid_pspace'_def untyped_ranges_zero_inv_def - idle_tcb'_def state_refs_of'_def comp_def valid_idle'_asrt_def) - -crunch tcbReleaseRemove, tcbSchedDequeue - for cur_tcb'[wp]: cur_tcb' - (wp: cur_tcb_lift) - -lemma schedContextUnbindTCB_invs'[wp]: - "\\s. invs' s \ scPtr \ idle_sc_ptr\ schedContextUnbindTCB scPtr \\_. invs'\" - unfolding schedContextUnbindTCB_def - apply (rule schedContextUnbindTCB_invs'_helper[simplified] bind_wp | clarsimp)+ - apply (wpsimp wp: tcbReleaseRemove_invs' tcbReleaseRemove_not_queued - tcbSchedDequeue_nonq tcbSchedDequeue_invs' hoare_vcg_all_lift)+ - apply (fastforce dest: sym_refs_obj_atD' - simp: invs_queues invs_valid_objs' invs'_valid_tcbs' valid_idle'_asrt_def - sym_refs_asrt_def if_cancel_eq_True ko_wp_at'_def refs_of_rev' - pred_tcb_at'_def obj_at'_def projectKO_eq projectKO_tcb cur_tcb'_asrt_def) - done - -(* FIXME RT: bound_tcb_at' is an outdated name? *) -lemma threadSet_sc_bound_tcb_at'[wp]: - "threadSet (tcbSchedContext_update f) t' \bound_tcb_at' P t\" - by (wpsimp wp: threadSet_pred_tcb_no_state) - -lemma threadSet_fault_bound_tcb_at'[wp]: - "threadSet (tcbFault_update f) t' \bound_tcb_at' P t\" - by (wpsimp wp: threadSet_pred_tcb_no_state) - -crunch replyClear - for bound_tcb_at'[wp]: "bound_tcb_at' P t" - (wp: crunch_wps simp: crunch_simps ignore: threadSet) + (wp: sts_bound_tcb_at' threadSet_cteCaps_of crunch_wps getObject_inv + loadObject_default_inv) lemma finaliseCapTrue_standin_bound_tcb_at': - "\\s. bound_tcb_at' P t s \ (\tt r. cap = ReplyCap tt r) \ + "\\s. bound_tcb_at' P t s \ (\tt b r. cap = ReplyCap tt b r) \ finaliseCapTrue_standin cap final \\_. bound_tcb_at' P t\" - apply (case_tac cap; simp add: finaliseCapTrue_standin_def isCap_simps) - by wpsimp + apply (case_tac cap, simp_all add:finaliseCapTrue_standin_def) + apply (clarsimp simp: isNotificationCap_def) + apply (wp, clarsimp) + done lemma capDeleteOne_bound_tcb_at': "\bound_tcb_at' P tptr and cte_wp_at' (isReplyCap \ cteCap) callerCap\ - cteDeleteOne callerCap - \\_. bound_tcb_at' P tptr\" + cteDeleteOne callerCap \\rv. bound_tcb_at' P tptr\" apply (simp add: cteDeleteOne_def unless_def) apply (rule hoare_pre) - apply (wp finaliseCapTrue_standin_bound_tcb_at' hoare_vcg_all_lift - hoare_vcg_if_lift2 getCTE_cteCap_wp - | clarsimp simp: isFinalCapability_def Let_def cteCaps_of_def isReplyCap_def - cte_wp_at_ctes_of - split: option.splits - | intro conjI impI | wp (once) hoare_drop_imp)+ - apply (case_tac "cteCap cte", simp_all) - done - -crunch cleanReply - for bound_sc_tcb_at'[wp]: "bound_sc_tcb_at' P t" - -lemma replyRemoveTCB_bound_sc_tcb_at'[wp]: - "replyRemoveTCB t \bound_sc_tcb_at' P tptr\" - unfolding replyRemoveTCB_def - by (wpsimp wp: hoare_drop_imp hoare_vcg_all_lift threadSet_pred_tcb_no_state) - -lemma schedContextCancelYieldTo_bound_tcb_at[wp]: - "schedContextCancelYieldTo t \ bound_tcb_at' P tptr \" - unfolding schedContextCancelYieldTo_def - by (wpsimp wp: threadSet_pred_tcb_no_state hoare_vcg_if_lift2 hoare_drop_imp) - -crunch prepareThreadDelete - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - -crunch suspend - for bound_tcb_at'[wp]: "bound_tcb_at' P t" - and bound_sc_tcb_at'[wp]: "bound_sc_tcb_at' P t" - (wp: threadSet_pred_tcb_no_state crunch_wps simp: crunch_simps) - -lemma schedContextCancelYieldTo_bound_yt_tcb_at'_None: - "\\_. True\ schedContextCancelYieldTo t \\rv. bound_yt_tcb_at' ((=) None) t\" - apply (simp add: schedContextCancelYieldTo_def) - apply (wpsimp wp: threadSet_pred_tcb_at_state threadGet_wp) - apply (auto simp: pred_tcb_at'_def obj_at'_def) - done - -lemma suspend_bound_yt_tcb_at'_None: - "\\_. True\ suspend t \\rv. bound_yt_tcb_at' ((=) None) t\" - apply (simp add: suspend_def) - apply (wpsimp wp: schedContextCancelYieldTo_bound_yt_tcb_at'_None) - done - -crunch schedContextCompleteYieldTo - for bound_sc_tcb_at'[wp]: "bound_sc_tcb_at' P p" - and sch_act_simple[wp]: sch_act_simple - (simp: crunch_simps wp: crunch_wps) - -lemma bound_sc_tcb_at'_sym_refsD: - "\bound_sc_tcb_at' (\scPtr'. scPtr' = Some scPtr) tcbPtr s; sym_refs (state_refs_of' s)\ - \ obj_at' (\sc. scTCB sc = Some tcbPtr) scPtr s" - apply (clarsimp simp: pred_tcb_at'_def) - apply (drule (1) sym_refs_obj_atD') - apply (auto simp: state_refs_of'_def ko_wp_at'_def obj_at'_def - refs_of_rev' projectKOs) - done - -lemma schedContextUnbindTCB_bound_sc_tcb_at'_None: - "\bound_sc_tcb_at' (\sc_opt. sc_opt = (Some sc)) t\ - schedContextUnbindTCB sc - \\rv. bound_sc_tcb_at' ((=) None) t\" - apply (simp add: schedContextUnbindTCB_def sym_refs_asrt_def) - apply (wpsimp wp: threadSet_pred_tcb_at_state hoare_vcg_imp_lift) - apply (drule (1) bound_sc_tcb_at'_sym_refsD) - apply (auto simp: obj_at'_def) + apply (wp finaliseCapTrue_standin_bound_tcb_at' hoare_vcg_all_lift + hoare_vcg_if_lift2 getCTE_cteCap_wp + | wpc | simp | wp (once) hoare_drop_imp)+ + apply (clarsimp simp: cteCaps_of_def projectKOs isReplyCap_def cte_wp_at_ctes_of + split: option.splits) + apply (case_tac "cteCap cte", simp_all) + done + +lemma cancelIPC_bound_tcb_at'[wp]: + "\bound_tcb_at' P tptr\ cancelIPC t \\rv. bound_tcb_at' P tptr\" + apply (simp add: cancelIPC_def Let_def) + apply (rule bind_wp[OF _ gts_sp']) + apply (case_tac "state", simp_all) + defer 2 + apply (rule hoare_pre) + apply ((wp sts_bound_tcb_at' getEndpoint_wp | wpc | simp)+)[8] + apply (simp add: getThreadReplySlot_def locateSlot_conv liftM_def) + apply (rule hoare_pre) + apply (wp capDeleteOne_bound_tcb_at' getCTE_ctes_of) + apply (rule_tac Q'="\_. bound_tcb_at' P tptr" in hoare_post_imp) + apply (clarsimp simp: capHasProperty_def cte_wp_at_ctes_of) + apply (wp threadSet_pred_tcb_no_state | simp)+ done -lemma unbindFromSC_bound_sc_tcb_at'_None: - "\\\ - unbindFromSC t - \\rv. bound_sc_tcb_at' ((=) None) t\" - apply (simp add: unbindFromSC_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (wpsimp wp: schedContextUnbindTCB_bound_sc_tcb_at'_None threadGet_wp get_sc_inv' - hoare_drop_imp) - apply (auto simp: pred_tcb_at'_def obj_at'_def) - done +crunch suspend, prepareThreadDelete + for bound_tcb_at'[wp]: "bound_tcb_at' P t" + (wp: sts_bound_tcb_at' cancelIPC_bound_tcb_at') lemma unbindNotification_bound_tcb_at': "\\_. True\ unbindNotification t \\rv. bound_tcb_at' ((=) None) t\" @@ -3253,7 +2744,6 @@ lemma unbindNotification_bound_tcb_at': 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'\" @@ -3280,298 +2770,40 @@ crunch prepareThreadDelete end -lemma ntfnSc_sym_refsD: - "\obj_at' (\ntfn. ntfnSc ntfn = Some scPtr) ntfnPtr s; sym_refs (state_refs_of' s)\ - \ obj_at' (\sc. scNtfn sc = Some ntfnPtr) scPtr s" - apply (drule (1) sym_refs_obj_atD') - apply (auto simp: state_refs_of'_def ko_wp_at'_def obj_at'_def - refs_of_rev' projectKOs) - 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 projectKOs) - apply (frule_tac p=ntfnPtr in obj_at_valid_objs', assumption) - apply (clarsimp simp: valid_obj'_def valid_ntfn'_def projectKOs) - 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 projectKOs 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\" - apply (simp add: schedContextUnbindNtfn_def sym_refs_asrt_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?) - apply (clarsimp simp: obj_at'_def projectKOs) - done - -lemma schedContextMaybeUnbindNtfn_obj_at'_ntfnSc: - "\\\ - schedContextMaybeUnbindNtfn ntfnPtr - \\_ s. obj_at' (\ntfn. ntfnSc ntfn = None) ntfnPtr s\" - apply (simp add: schedContextMaybeUnbindNtfn_def) - apply (wpsimp wp: schedContextUnbindNtfn_obj_at'_ntfnSc getNotification_wp) - apply (clarsimp simp: obj_at'_def) - done - -lemma replyUnlink_makes_unlive: - "\\s. \ is_reply_linked rptr' s \ replySCs_of s rptr' = None - \ weak_sch_act_wf (ksSchedulerAction s) s \ rptr' = rptr\ - replyUnlink rptr tptr - \\_. ko_wp_at' (Not \ live') rptr'\" - apply (simp add: replyUnlink_def) - apply (wpsimp wp: setThreadState_Inactive_unlive updateReply_wp_all gts_wp') - by (auto simp: ko_wp_at'_def obj_at'_def projectKOs opt_map_def objBitsKO_def - live'_def live_reply'_def weak_sch_act_wf_def pred_tcb_at'_def - replyNext_None_iff) - -lemma cleanReply_obj_at_next_prev_none: - "\K (rptr' = rptr)\ - cleanReply rptr - \\_ s. \ is_reply_linked rptr s \ replySCs_of s rptr = None\" - apply (simp add: cleanReply_def ) - apply (wpsimp wp: updateReply_wp_all) - apply (auto simp: obj_at'_def projectKOs objBitsKO_def) - done - -lemma replyPop_makes_unlive: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - replyPop rptr tptr - \\_. ko_wp_at' (Not \ live') rptr\" - apply (simp add: replyPop_def) - by (wpsimp wp: replyUnlink_makes_unlive cleanReply_obj_at_next_prev_none - hoare_vcg_if_lift - | wp (once) hoare_drop_imps)+ - -lemma replyRemove_makes_unlive: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - replyRemove rptr tptr - \\_. ko_wp_at' (Not \ live') rptr\" - apply (simp add: replyRemove_def) - by (wpsimp wp: replyPop_makes_unlive replyUnlink_makes_unlive cleanReply_obj_at_next_prev_none - hoare_vcg_if_lift threadGet_wp gts_wp' hoare_drop_imps) - -lemma replyRemoveTCB_makes_unlive: - "\\s. st_tcb_at' (\st. replyObject st = Some rptr) tptr s - \ weak_sch_act_wf (ksSchedulerAction s) s\ - replyRemoveTCB tptr - \\_. ko_wp_at' (Not \ live') rptr\" - apply (simp add: replyRemoveTCB_def) - apply (wpsimp wp: replyUnlink_makes_unlive cleanReply_obj_at_next_prev_none - hoare_vcg_if_lift threadGet_wp gts_wp' hoare_drop_imps) - by (clarsimp simp: pred_tcb_at'_def obj_at'_def) - -method cancelIPC_makes_unlive_hammer = - (normalise_obj_at', - frule (2) sym_ref_replyTCB_Receive_or_Reply, - fastforce simp: weak_sch_act_wf_def pred_tcb_at'_def obj_at'_def projectKOs) - -lemma obj_at_replyTCBs_of: - "obj_at' (\reply. replyTCB reply = tptr_opt) rptr s - \ replyTCBs_of s rptr = tptr_opt" - by (clarsimp simp: obj_at'_def projectKOs opt_map_def) - -lemma cancelIPC_makes_unlive: - "\\s. obj_at' (\reply. replyTCB reply = Some tptr) rptr s - \ weak_sch_act_wf (ksSchedulerAction s) s \ valid_replies' s - \ valid_replies'_sc_asrt rptr s\ - cancelIPC tptr - \\_. ko_wp_at' (Not \ live') rptr\" - unfolding cancelIPC_def blockedCancelIPC_def Let_def getBlockingObject_def sym_refs_asrt_def - apply simp - apply (intro bind_wp[OF _ stateAssert_sp] bind_wp[OF _ gts_sp'])+ - apply (case_tac state; clarsimp) - (* BlockedOnReceive*) - apply (rename_tac ep pl rp) - apply (case_tac rp; clarsimp) - apply (wpsimp wp: hoare_pre_cont, cancelIPC_makes_unlive_hammer) - apply (wpsimp wp: setThreadState_unlive_other replyUnlink_makes_unlive - hoare_vcg_all_lift hoare_drop_imps threadSet_weak_sch_act_wf) - apply (frule obj_at_replyTCBs_of, - frule (1) valid_replies'_other_state; - clarsimp simp: valid_replies'_sc_asrt_replySC_None) - apply cancelIPC_makes_unlive_hammer - (* BlockedOnReply*) - apply (wpsimp wp: replyRemoveTCB_makes_unlive threadSet_pred_tcb_no_state - threadSet_weak_sch_act_wf) - apply cancelIPC_makes_unlive_hammer - (* All other states are impossible *) - apply (wpsimp wp: hoare_pre_cont, cancelIPC_makes_unlive_hammer)+ - done - -lemma replyClear_makes_unlive: - "\\s. obj_at' (\reply. replyTCB reply = Some tptr) rptr s - \ weak_sch_act_wf (ksSchedulerAction s) s \ valid_replies' s - \ valid_replies'_sc_asrt rptr s\ - replyClear rptr tptr - \\_. ko_wp_at' (Not \ live') rptr\" - apply (simp add: replyClear_def) - apply (wpsimp wp: replyRemove_makes_unlive cancelIPC_makes_unlive gts_wp' haskell_fail_wp) - done - -crunch unbindFromSC - for bound_tcb_at'[wp]: "bound_tcb_at' P p" - (ignore: threadSet simp: crunch_simps wp: crunch_wps) - -lemma schedContextUnbindTCB_valid_queues[wp]: - "\valid_queues and valid_objs' and sch_act_simple\ - schedContextUnbindTCB scPtr - \\_. valid_queues\" - unfolding schedContextUnbindTCB_def - apply (wpsimp wp: threadSet_valid_queues tcbReleaseRemove_valid_queues - hoare_vcg_all_lift tcbSchedDequeue_valid_queues - rescheduleRequired_oa_queued tcbSchedDequeue_nonq - | wp (once) hoare_drop_imps)+ - apply (auto simp: valid_obj'_def valid_sched_context'_def - elim: valid_objs'_maxDomain valid_objs'_maxPriority - dest!: ko_at_valid_objs'_pre) - done - -crunch setConsumed - for valid_queues[wp]: valid_queues - and ksQ[wp]: "\s. P (ksReadyQueues s p)" - (simp: crunch_simps wp: crunch_wps) - -lemma schedContextCompleteYieldTo_valid_queues[wp]: - "schedContextCompleteYieldTo tptr \valid_queues\" - unfolding schedContextCompleteYieldTo_def - apply (wpsimp wp: hoare_vcg_all_lift threadGet_wp simp: inQ_def cong: conj_cong) - apply (clarsimp simp: obj_at'_def) - done +lemma tcbQueueRemove_tcbSchedNext_tcbSchedPrev_None_obj_at': + "\\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 projectKOs opt_map_def ps_clear_def objBits_simps + split: if_splits) + +lemma tcbSchedDequeue_tcbSchedNext_tcbSchedPrev_None_obj_at': + "\valid_sched_pointers\ + tcbSchedDequeue t + \\_ s. obj_at' (\tcb. tcbSchedNext tcb = None \ tcbSchedPrev tcb = None) t s\" + unfolding tcbSchedDequeue_def + by (wpsimp wp: tcbQueueRemove_tcbSchedNext_tcbSchedPrev_None_obj_at' threadGet_wp) + (fastforce simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def + valid_sched_pointers_def opt_pred_def opt_map_def projectKOs + split: option.splits) -crunch unbindFromSC - for valid_queues[wp]: valid_queues +crunch updateRestartPC, cancelIPC + for valid_sched_pointers[wp]: valid_sched_pointers (simp: crunch_simps wp: crunch_wps) -crunch schedContextCompleteYieldTo, unbindNotification, unbindMaybeNotification - for sch_act_simple[wp]: sch_act_simple - (simp: crunch_simps wp: crunch_wps rule: sch_act_simple_lift) - -lemma schedContextSetInactive_unlive[wp]: - "schedContextSetInactive scPtr \\s. P (ko_wp_at' (Not \ live') p s)\" - unfolding schedContextSetInactive_def - apply (wpsimp wp: set_sc'.set_wp simp: updateSchedContext_def simp_del: fun_upd_apply) - apply (clarsimp simp: ko_wp_at'_def obj_at'_def live_sc'_def - ps_clear_upd objBits_simps scBits_simps projectKOs) - done - -crunch setMessageInfo, setMRs - for obj_at'_sc[wp]: "obj_at' (P :: sched_context \ bool) p" - (wp: crunch_wps simp: crunch_simps) - -lemma schedContextUpdateConsumed_obj_at'_not_consumed: - "(\ko f. P (scConsumed_update f ko) = P ko) - \ schedContextUpdateConsumed scPtr \obj_at' P t\" - apply (simp add: schedContextUpdateConsumed_def) - apply (wpsimp wp: set_sc'.obj_at'_strongest) - by (auto simp: obj_at'_def) - -lemma setConsumed_obj_at'_not_consumed: - "(\ko f. P (scConsumed_update f ko) = P ko) - \ setConsumed scPtr buffer \obj_at' P t\" - apply (clarsimp simp: setConsumed_def) - apply (wpsimp wp: schedContextUpdateConsumed_obj_at'_not_consumed) - done - -lemma schedContextCancelYieldTo_makes_unlive: - "\obj_at' (\sc. scTCB sc = None) scPtr and obj_at' (\sc. scNtfn sc = None) scPtr and - obj_at' (\sc. scReply sc = None) scPtr and bound_yt_tcb_at' (\yieldTo. yieldTo = Some scPtr) tptr\ - schedContextCancelYieldTo tptr - \\_. ko_wp_at' (Not \ live') scPtr\" - unfolding schedContextCancelYieldTo_def updateSchedContext_def - apply (wpsimp wp: threadSet_unlive_other set_sc'.ko_wp_at threadGet_wp) - apply (auto simp: pred_tcb_at'_def obj_at'_def ko_wp_at'_def projectKOs live_sc'_def) - done - -lemma schedContextCompleteYieldTo_makes_unlive: - "\obj_at' (\sc. scTCB sc = None) scPtr and obj_at' (\sc. scNtfn sc = None) scPtr and - obj_at' (\sc. scReply sc = None) scPtr and bound_yt_tcb_at' ((=) (Some scPtr)) tptr\ - schedContextCompleteYieldTo tptr - \\_. ko_wp_at' (Not \ live') scPtr\" - unfolding schedContextCompleteYieldTo_def - apply (wpsimp wp: schedContextCancelYieldTo_makes_unlive haskell_fail_wp - setConsumed_obj_at'_not_consumed hoare_drop_imps threadGet_wp) - apply (auto simp: pred_tcb_at'_def obj_at'_def) - done - -lemma sym_ref_scYieldFrom: - "\ko_at' sc scp s; scYieldFrom sc = Some tp; sym_refs (state_refs_of' s)\ - \ \tcb. ko_at' tcb tp s \ tcbYieldTo tcb = Some scp" - apply (drule (1) sym_refs_ko_atD') - apply (auto simp: state_refs_of'_def ko_wp_at'_def obj_at'_def - refs_of_rev' projectKOs) - done - -lemma schedContextUnbindYieldFrom_makes_unlive: - "\obj_at' (\sc. scTCB sc = None) scPtr and obj_at' (\sc. scNtfn sc = None) scPtr and - obj_at' (\sc. scReply sc = None) scPtr\ - schedContextUnbindYieldFrom scPtr - \\_. ko_wp_at' (Not \ live') scPtr\" - unfolding schedContextUnbindYieldFrom_def sym_refs_asrt_def - apply (wpsimp wp: schedContextCompleteYieldTo_makes_unlive) - apply (rule conjI; clarsimp) - apply (drule (2) sym_ref_scYieldFrom) - apply (auto simp: pred_tcb_at'_def obj_at'_def ko_wp_at'_def projectKOs live_sc'_def) - done - -lemma schedContextUnbindReply_obj_at'_not_reply: - "(\ko f. P (scReply_update f ko) = P ko) - \ schedContextUnbindReply scPtr \obj_at' P p\" - apply (clarsimp simp: schedContextUnbindReply_def) - apply (wpsimp wp: set_sc'.obj_at'_strongest updateReply_wp_all) - by (auto simp: obj_at'_def projectKOs) - -lemma schedContextUnbindReply_obj_at'_reply_None: - "\\\ schedContextUnbindReply scPtr \\_. obj_at' (\sc. scReply sc = None) scPtr\" - apply (clarsimp simp: schedContextUnbindReply_def) - apply (wpsimp wp: set_sc'.obj_at'_strongest) - by (auto simp: obj_at'_def) - -lemma schedContextUnbindNtfn_obj_at'_not_ntfn: - "(\ko f. P (scNtfn_update f ko) = P ko) - \ schedContextUnbindNtfn scPtr \obj_at' P p\" - apply (clarsimp simp: schedContextUnbindNtfn_def) - apply (wpsimp wp: set_sc'.obj_at'_strongest set_ntfn'.set_wp getNotification_wp) - by (auto simp: obj_at'_def projectKOs) - -lemma schedContextUnbindNtfn_obj_at'_ntfn_None: - "\\\ schedContextUnbindNtfn scPtr \\_. obj_at' (\sc. scNtfn sc = None) scPtr\" - apply (clarsimp simp: schedContextUnbindNtfn_def) - apply (wpsimp wp: set_sc'.obj_at'_strongest) - by (auto simp: obj_at'_def) - -lemma schedContextUnbindTCB_obj_at'_tcb_None: - "\\\ schedContextUnbindTCB scPtr \\_. obj_at' (\sc. scTCB sc = None) scPtr\" - apply (clarsimp simp: schedContextUnbindTCB_def) - by (wpsimp wp: set_sc'.obj_at'_strongest) - -lemma schedContextUnbindAllTCBs_obj_at'_tcb_None: - "\\\ schedContextUnbindAllTCBs scPtr \\_. obj_at' (\sc. scTCB sc = None) scPtr\" - apply (clarsimp simp: schedContextUnbindAllTCBs_def) - apply (wpsimp wp: schedContextUnbindTCB_obj_at'_tcb_None) - by (auto simp: obj_at'_def) - -lemmas schedContextSetInactive_removeable' - = prepares_delete_helper'' [OF schedContextSetInactive_unlive - [where p=scPtr and scPtr=scPtr for scPtr]] - -crunch schedContextMaybeUnbindNtfn - for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - -end +lemma suspend_tcbSchedNext_tcbSchedPrev_None: + "\invs'\ suspend t \\_ s. obj_at' (\tcb. tcbSchedNext tcb = None \ tcbSchedPrev tcb = None) t s\" + unfolding suspend_def + by (wpsimp wp: hoare_drop_imps tcbSchedDequeue_tcbSchedNext_tcbSchedPrev_None_obj_at') lemma (in delete_one_conc_pre) finaliseCap_replaceable: "\\s. invs' s \ cte_wp_at' (\cte. cteCap cte = cap) slot s \ (final_matters' cap \ (final = isFinal cap slot (cteCaps_of s))) - \ sch_act_simple s\ + \ weak_sch_act_wf (ksSchedulerAction s) s\ finaliseCap cap final flag \\rv s. (isNullCap (fst rv) \ removeable' slot s cap \ (snd rv \ NullCap \ snd rv = cap \ cap_has_cleanup' cap @@ -3587,65 +2819,41 @@ lemma (in delete_one_conc_pre) finaliseCap_replaceable: \ (\p \ threadCapRefs cap. st_tcb_at' ((=) Inactive) p s \ obj_at' (Not \ tcbQueued) p s \ bound_tcb_at' ((=) None) p s - \ (\pr. p \ set (ksReadyQueues s pr)) - \ 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))\" apply (simp add: finaliseCap_def Let_def getThreadCSpaceRoot cong: if_cong split del: if_split) apply (rule hoare_pre) - apply (wpsimp wp: prepares_delete_helper'' [OF cancelAllIPC_unlive] - prepares_delete_helper'' [OF cancelAllSignals_unlive] - 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_nonq - prepareThreadDelete_inactive - suspend_makes_inactive - suspend_nonq - 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: isCap_simps) - apply (wpsimp wp: deletingIRQHandler_removeable' - deletingIRQHandler_final[where slot=slot])+ - apply (frule cte_wp_at_valid_objs_valid_cap'; clarsimp) + apply (wp prepares_delete_helper'' [OF cancelAllIPC_unlive] + prepares_delete_helper'' [OF cancelAllSignals_unlive] + suspend_isFinal prepareThreadDelete_unqueued + prepareThreadDelete_inactive prepareThreadDelete_isFinal + suspend_makes_inactive + deletingIRQHandler_removeable' + deletingIRQHandler_final[where slot=slot ] + unbindMaybeNotification_obj_at'_bound + getNotification_wp + suspend_bound_tcb_at' + unbindNotification_bound_tcb_at' + suspend_tcbSchedNext_tcbSchedPrev_None + | simp add: isZombie_Null isThreadCap_threadCapRefs_tcbptr + isArchObjectCap_Cap_capCap + | (rule hoare_strengthen_post [OF arch_finaliseCap_removeable[where slot=slot]], + clarsimp simp: isCap_simps) + | wpc)+ + + apply clarsimp + apply (frule cte_wp_at_valid_objs_valid_cap', clarsimp+) apply (case_tac "cteCap cte", simp_all add: isCap_simps capRange_def cap_has_cleanup'_def final_matters'_def 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) - (* NotificationCap *) - apply (fastforce simp: obj_at'_def sch_act_wf_asrt_def) - (* EndpointCap *) - apply (fastforce simp: sch_act_wf_asrt_def) - (* ArchObjectCap *) - apply (fastforce simp: obj_at'_def sch_act_wf_asrt_def) - (* ReplyCap *) - apply (rule conjI; clarsimp) - apply (fastforce simp: obj_at'_def sch_act_wf_asrt_def) - apply (frule (1) obj_at_replyTCBs_of[OF ko_at_obj_at', simplified]) - apply (frule valid_replies'_no_tcb, clarsimp) - apply (clarsimp simp: ko_wp_at'_def obj_at'_def live_reply'_def projectKOs opt_map_def - valid_replies'_sc_asrt_def replyNext_None_iff) + (* thread *) + apply (frule capAligned_capUntypedPtr [OF valid_capAligned], simp) + apply (clarsimp simp: valid_cap'_def) + apply (drule valid_globals_cte_wpD'[rotated], clarsimp) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + apply (clarsimp simp: obj_at'_def | rule conjI)+ done lemma cteDeleteOne_cte_wp_at_preserved: @@ -3658,70 +2866,81 @@ lemma cteDeleteOne_cte_wp_at_preserved: apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of x) done -lemma cancelIPC_cteCaps_of[wp]: - "cancelIPC t \\s. P (cteCaps_of s)\" - apply (simp add: cancelIPC_def Let_def capHasProperty_def locateSlot_conv) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp_fwd_skip, wpsimp) +crunch cancelSignal + for ctes_of[wp]: "\s. P (ctes_of s)" + (simp: crunch_simps wp: crunch_wps) + +lemma cancelIPC_cteCaps_of: + "\\s. (\p. cte_wp_at' (\cte. \final. finaliseCap (cteCap cte) final True \ fail) p s \ + P ((cteCaps_of s)(p \ NullCap))) \ + P (cteCaps_of s)\ + cancelIPC t + \\rv s. P (cteCaps_of s)\" + apply (simp add: cancelIPC_def Let_def capHasProperty_def + getThreadReplySlot_def locateSlot_conv) apply (rule hoare_pre) - apply (wp getCTE_wp' | wpcw - | simp add: cte_wp_at_ctes_of - | wp (once) hoare_drop_imps ctes_of_cteCaps_of_lift)+ + apply (wp cteDeleteOne_cteCaps_of getCTE_wp' | wpcw + | simp add: cte_wp_at_ctes_of + | wp (once) hoare_drop_imps ctes_of_cteCaps_of_lift)+ apply (wp hoare_convert_imp hoare_vcg_all_lift threadSet_ctes_of threadSet_cteCaps_of | clarsimp)+ + apply (wp cteDeleteOne_cteCaps_of getCTE_wp' | wpcw | simp + | wp (once) hoare_drop_imps ctes_of_cteCaps_of_lift)+ + apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def) + apply (drule_tac x="mdbNext (cteMDBNode x)" in spec) + apply clarsimp + apply (auto simp: o_def map_option_case fun_upd_def[symmetric]) done -lemma cancelIPC_cte_wp_at'[wp]: - "cancelIPC t \\s. cte_wp_at' (\cte. P (cteCap cte)) p s\" +lemma cancelIPC_cte_wp_at': + assumes x: "\cap final. P cap \ finaliseCap cap final True = fail" + shows "\\s. cte_wp_at' (\cte. P (cteCap cte)) p s\ + cancelIPC t + \\rv s. cte_wp_at' (\cte. P (cteCap cte)) p s\" apply (simp add: tree_cte_cteCap_eq[unfolded o_def]) - apply wpsimp + apply (rule hoare_pre, wp cancelIPC_cteCaps_of) + apply (clarsimp simp: cteCaps_of_def cte_wp_at_ctes_of x) done -crunch schedContextCancelYieldTo, tcbReleaseRemove +crunch tcbSchedDequeue for cte_wp_at'[wp]: "cte_wp_at' P p" - (wp: crunch_wps simp: crunch_simps) + (wp: crunch_wps) lemma suspend_cte_wp_at': - "suspend t \cte_wp_at' (\cte. P (cteCap cte)) p\" - unfolding updateRestartPC_def suspend_def - apply (wpsimp wp: hoare_vcg_imp_lift hoare_disjI2[where Q'="\_. cte_wp_at' a b" for a b]) + assumes x: "\cap final. P cap \ finaliseCap cap final True = fail" + shows "\cte_wp_at' (\cte. P (cteCap cte)) p\ + suspend t + \\rv. cte_wp_at' (\cte. P (cteCap cte)) p\" + apply (simp add: suspend_def) + unfolding updateRestartPC_def + apply (rule hoare_pre) + apply (wp threadSet_cte_wp_at' cancelIPC_cte_wp_at' + | simp add: x)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch deleteASIDPool for cte_wp_at'[wp]: "cte_wp_at' P p" (simp: crunch_simps assertE_def - wp: crunch_wps getObject_inv) + wp: crunch_wps getObject_inv loadObject_default_inv) lemma deleteASID_cte_wp_at'[wp]: "\cte_wp_at' P p\ deleteASID param_a param_b \\_. cte_wp_at' P p\" apply (simp add: deleteASID_def invalidateHWASIDEntry_def invalidateASID_def cong: option.case_cong) - apply (wp setObject_cte_wp_at'[where Q="\"] getObject_inv setVMRoot_cte_wp_at' + apply (wp setObject_cte_wp_at'[where Q="\"] getObject_inv + loadObject_default_inv setVMRoot_cte_wp_at' | clarsimp simp: updateObject_default_def in_monad projectKOs | rule equals0I | wpc)+ done -crunch unmapPageTable, unmapPage, unbindNotification, cancelAllIPC, cancelAllSignals, - unbindMaybeNotification, schedContextMaybeUnbindNtfn, replyRemove, - unbindFromSC, schedContextSetInactive, schedContextUnbindYieldFrom, - schedContextUnbindReply, schedContextUnbindAllTCBs +crunch unmapPageTable, unmapPage, unbindNotification, finaliseCapTrue_standin for cte_wp_at'[wp]: "cte_wp_at' P p" - (simp: crunch_simps wp: crunch_wps getObject_inv) - -lemma replyClear_standin_cte_preserved[wp]: - "replyClear rptr tptr \cte_wp_at' (\cte. P (cteCap cte)) p\" - unfolding replyClear_def - by (wpsimp wp: gts_wp') - -lemma finaliseCapTrue_standin_cte_preserved[wp]: - "finaliseCapTrue_standin cap fin \cte_wp_at' (\cte. P (cteCap cte)) p\" - unfolding finaliseCapTrue_standin_def Let_def - by (wpsimp wp: replyClear_standin_cte_preserved simp:) + (simp: crunch_simps wp: crunch_wps getObject_inv loadObject_default_inv) lemma arch_finaliseCap_cte_wp_at[wp]: "\cte_wp_at' P p\ Arch.finaliseCap cap fin \\rv. cte_wp_at' P p\" @@ -3729,12 +2948,10 @@ lemma arch_finaliseCap_cte_wp_at[wp]: apply (safe ; wpsimp wp: unmapPage_cte_wp_at') done -end - lemma deletingIRQHandler_cte_preserved: assumes x: "\cap final. P cap \ finaliseCap cap final True = fail" shows "\cte_wp_at' (\cte. P (cteCap cte)) p\ - deletingIRQHandler irq + deletingIRQHandler irq \\rv. cte_wp_at' (\cte. P (cteCap cte)) p\" apply (simp add: deletingIRQHandler_def getSlotCap_def getIRQSlot_def locateSlot_conv getInterruptState_def) @@ -3744,12 +2961,14 @@ lemma deletingIRQHandler_cte_preserved: lemma finaliseCap_equal_cap[wp]: "\cte_wp_at' (\cte. cteCap cte = cap) sl\ - finaliseCap cap fin flag + finaliseCap cap fin flag \\rv. cte_wp_at' (\cte. cteCap cte = cap) sl\" apply (simp add: finaliseCap_def Let_def cong: if_cong split del: if_split) - apply (wpsimp wp: suspend_cte_wp_at' deletingIRQHandler_cte_preserved - simp: finaliseCap_def)+ + apply (rule hoare_pre) + apply (wp suspend_cte_wp_at' deletingIRQHandler_cte_preserved + | clarsimp simp: finaliseCap_def | wpc)+ + apply (case_tac cap) apply auto done @@ -3765,16 +2984,9 @@ lemma setThreadState_st_tcb_at_simplish': lemmas setThreadState_st_tcb_at_simplish = setThreadState_st_tcb_at_simplish'[unfolded pred_disj_def] -lemma replyUnlink_st_tcb_at_simplish: - "replyUnlink r t' \st_tcb_at' (\st. P st \ simple' st) t\" - supply if_split [split del] - unfolding replyUnlink_def - apply (wpsimp wp: sts_st_tcb' hoare_vcg_if_lift2 hoare_vcg_imp_lift' gts_wp') - done - crunch cteDeleteOne - for st_tcb_at_simplish: "st_tcb_at' (\st. P st \ simple' st) t" - (wp: crunch_wps getObject_inv threadSet_pred_tcb_no_state + for st_tcb_at_simplish: "st_tcb_at' (\st. P st \ simple' st) t" + (wp: crunch_wps getObject_inv loadObject_default_inv threadSet_pred_tcb_no_state simp: crunch_simps unless_def) lemma cteDeleteOne_st_tcb_at[wp]: @@ -3784,366 +2996,170 @@ lemma cteDeleteOne_st_tcb_at[wp]: apply (clarsimp simp: pred_disj_def) apply (rule cteDeleteOne_st_tcb_at_simplish) apply (rule_tac x=P in exI) - apply (auto) + apply (auto intro!: ext) done +lemma cteDeleteOne_reply_pred_tcb_at: + "\\s. pred_tcb_at' proj P t s \ (\t' r. cte_wp_at' (\cte. cteCap cte = ReplyCap t' False r) slot s)\ + cteDeleteOne slot + \\rv. pred_tcb_at' proj P t\" + apply (simp add: cteDeleteOne_def unless_def isFinalCapability_def) + apply (rule bind_wp [OF _ getCTE_sp]) + apply (rule hoare_assume_pre) + apply (clarsimp simp: cte_wp_at_ctes_of when_def isCap_simps + Let_def finaliseCapTrue_standin_def) + apply (intro impI conjI, (wp | simp)+) + done + +context +notes option.case_cong_weak[cong] +begin +crunch cteDeleteOne, unbindNotification + for sch_act_simple[wp]: sch_act_simple + (wp: crunch_wps ssa_sch_act_simple sts_sch_act_simple getObject_inv + loadObject_default_inv + simp: crunch_simps unless_def + rule: sch_act_simple_lift) +end + lemma rescheduleRequired_sch_act_not[wp]: "\\\ rescheduleRequired \\rv. sch_act_not t\" apply (simp add: rescheduleRequired_def setSchedulerAction_def) apply (wp hoare_TrueI | simp)+ done -lemma rescheduleRequired_oa_queued': - "\obj_at' (\tcb. Q (tcbDomain tcb) (tcbPriority tcb)) t'\ - rescheduleRequired - \\_. obj_at' (\tcb. Q (tcbDomain tcb) (tcbPriority tcb)) t'\" - apply (simp add: rescheduleRequired_def) - by (wpsimp wp: tcbSchedEnqueue_not_st isSchedulable_wp) - -crunch cancelAllIPC, cancelAllSignals, unbindMaybeNotification - for tcbDomain_obj_at': "obj_at' (\tcb. P (tcbDomain tcb)) t'" - (wp: crunch_wps simp: crunch_simps) - -lemma cancelAllIPC_valid_queues[wp]: - "\valid_queues and valid_tcbs'\ - cancelAllIPC ep_ptr - \\_. valid_queues\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) - unfolding cancelAllIPC_loop_body_def restartThreadIfNoFault_def - apply (wpsimp wp: mapM_x_wp' getEndpoint_wp - simp: valid_tcb_state'_def) - done - -lemma cancelAllSignals_valid_queues[wp]: - "\valid_queues and valid_tcbs'\ - cancelAllSignals ntfn - \\_. valid_queues\" - apply (simp add: cancelAllSignals_def) - apply (wpsimp wp: mapM_x_wp' getNotification_wp - simp: valid_tcb_state'_def) - done - -lemma setBoundNotification_valid_tcbs'[wp]: - "\valid_tcbs' and valid_bound_ntfn' ntfn\ setBoundNotification ntfn t \\rv. valid_tcbs'\" - apply (wpsimp simp: setBoundNotification_def wp: threadSet_valid_tcbs') - by (simp add: valid_tcb'_def tcb_cte_cases_def) - -lemma unbindMaybeNotification_valid_tcbs'[wp]: - "unbindMaybeNotification ntfnPtr \valid_tcbs'\" - by (wpsimp simp: unbindMaybeNotification_def) - -crunch schedContextMaybeUnbindNtfn - for valid_queues[wp]: valid_queues - -lemma setSchedContext_valid_tcbs'[wp]: - "setSchedContext ptr val \valid_tcbs'\" - apply (clarsimp simp: setSchedContext_def) - apply (wpsimp wp: setObject_valid_tcbs' - simp: updateObject_default_def in_monad projectKOs project_inject) - done - -crunch schedContextUnbindNtfn, schedContextMaybeUnbindNtfn - for valid_tcbs'[wp]: valid_tcbs' - (wp: setSchedContext_valid_tcbs') - -lemma removeFromBitmap_valid_sched_context'[wp]: - "removeFromBitmap tdom prio \valid_sched_context' sc\" - by (wpsimp simp: bitmap_fun_defs) - -lemma setQueue_valid_sched_context'[wp]: - "setQueue tdom prio q \valid_sched_context' sc\" - apply (wpsimp simp: setQueue_def valid_sched_context'_def valid_bound_obj'_def - split: option.splits) - done - -lemma threadSet_valid_sched_context'[wp]: - "threadSet f y \valid_sched_context' sc\" - apply (wpsimp wp: threadSet_wp) - by (clarsimp simp: valid_sched_context'_def valid_bound_obj'_def - split: option.splits - ; fastforce simp: obj_at'_def projectKOs objBitsKO_def) - -lemma addToBitmap_valid_sched_context[wp]: - "addToBitmap tdom prio \valid_sched_context' sc\" - apply (clarsimp simp: addToBitmap_def) - apply (wpsimp simp: bitmap_fun_defs) - apply (clarsimp simp: valid_sched_context'_def valid_bound_obj'_def - split: option.splits) - done - -crunch tcbSchedDequeue, tcbSchedEnqueue - for valid_sched_context'[wp]: "\s. valid_sched_context' sc' s" - -lemma setQueue_valid_reply'[wp]: - "setQueue domain prio q \valid_reply' reply\" - apply (clarsimp simp: setQueue_def) - apply wpsimp - apply (fastforce simp: valid_reply'_def valid_bound_obj'_def split: option.splits) - done - -crunch replyClear - for valid_queues[wp]: valid_queues - -lemma finaliseCapTrue_standin_valid_queues[wp]: - "\valid_queues and valid_objs'\ - finaliseCapTrue_standin cap final - \\_. valid_queues\" - apply (simp add: finaliseCapTrue_standin_def Let_def) - apply (intro conjI impI; wpsimp) - done - -crunch isFinalCapability - for valid_queues[wp]: "Invariants_H.valid_queues" - and sch_act[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - and weak_sch_act[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (simp: crunch_simps) - -lemma cteDeleteOne_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\ - cteDeleteOne sl - \\_. Invariants_H.valid_queues\" (is "\?PRE\ _ \_\") - apply (simp add: cteDeleteOne_def unless_def split_def) - apply (wp isFinalCapability_inv getCTE_wp | rule hoare_drop_imps | simp)+ - apply (clarsimp simp: cte_wp_at'_def) - done - -lemma valid_inQ_queues_lift: - assumes tat: "\d p tcb. f \obj_at' (inQ d p) tcb\" - and prq: "\P. f \\s. P (ksReadyQueues s)\" - shows "f \valid_inQ_queues\" - apply (insert assms) - apply (clarsimp simp: valid_inQ_queues_def) - apply (fastforce intro: hoare_vcg_all_lift hoare_vcg_ball_lift2) - done - -lemma emptySlot_valid_inQ_queues [wp]: - "\valid_inQ_queues\ emptySlot sl opt \\rv. valid_inQ_queues\" - unfolding emptySlot_def - by (wp opt_return_pres_lift | wpcw | wp valid_inQ_queues_lift | simp)+ - -context begin interpretation Arch . - -crunch cancelAllIPC, cancelAllSignals, unbindNotification, unbindMaybeNotification, - schedContextMaybeUnbindNtfn, isFinalCapability - for valid_inQ_queues[wp]: "valid_inQ_queues" - (wp: crunch_wps simp: crunch_simps) +crunch cteDeleteOne + for sch_act_not[wp]: "sch_act_not t" + (simp: crunch_simps case_Null_If unless_def + wp: crunch_wps getObject_inv loadObject_default_inv) -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 +lemma cancelAllIPC_mapM_x_weak_sch_act: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ + mapM_x (\t. do + y \ setThreadState Structures_H.thread_state.Restart t; + tcbSchedEnqueue t + od) q + \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (rule mapM_x_wp_inv) + apply (wp) + apply (clarsimp) done -lemma valid_inQ_queues_exceptI[intro]: - "valid_inQ_queues s \ valid_inQ_queues_except t s" - by (simp add: valid_inQ_queues_except_def valid_inQ_queues_def) - -lemma threadSet_valid_inQ_queues_dequeue_wp: - "\valid_inQ_queues_except t and (\s. \d p. t \ set (ksReadyQueues s (d,p)))\ - threadSet (tcbQueued_update (\_. False)) t - \\_. valid_inQ_queues \" - unfolding threadSet_def - apply (rule bind_wp[OF _ getObject_tcb_sp]) - apply (simp add: valid_inQ_queues_def) - apply (wpsimp wp: hoare_Ball_helper hoare_vcg_all_lift setObject_tcb_strongest) - apply (clarsimp simp: valid_inQ_queues_except_def) +lemma cancelAllIPC_mapM_x_valid_objs': + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + mapM_x (\t. do + y \ setThreadState Structures_H.thread_state.Restart t; + tcbSchedEnqueue t + od) q + \\_. valid_objs'\" + apply (rule hoare_strengthen_post) + apply (rule mapM_x_wp') + apply (wpsimp wp: sts_valid_objs') + apply (clarsimp simp: valid_tcb_state'_def)+ done -lemma removeFromBitmap_valid_inQ_queues_except[wp]: - "removeFromBitmap d p \valid_inQ_queues_except t\" - unfolding bitmapQ_defs valid_inQ_queues_except_def - by (wpsimp simp: bitmap_fun_defs)+ +lemma cancelAllIPC_mapM_x_tcbDomain_obj_at': + "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ + mapM_x (\t. do + y \ setThreadState Structures_H.thread_state.Restart t; + tcbSchedEnqueue t + od) q + \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" + by (wpsimp wp: mapM_x_wp') -lemma setQueue_valid_inQ_queues_except_dequeue_wp: - "\\s. valid_inQ_queues_except t s \ (\t' \ set ts. obj_at' (inQ d p) t' s)\ - setQueue d p ts - \\_. valid_inQ_queues_except t\" - unfolding setQueue_def valid_inQ_queues_except_def null_def +lemma rescheduleRequired_oa_queued': + "rescheduleRequired \obj_at' (\tcb. Q (tcbDomain tcb) (tcbPriority tcb)) t\" + unfolding rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def by wpsimp -lemma valid_queues_no_bitmap_correct_queueI[intro]: - "valid_inQ_queues s \ correct_queue t s" - by (fastforce simp: correct_queue_def valid_inQ_queues_def obj_at'_def inQ_def) - -lemma tcbSchedDequeue_valid_inQ_queues_weak: - "\valid_inQ_queues_except t and correct_queue t and tcb_at' t\ - tcbSchedDequeue t - \\_. valid_inQ_queues\" - unfolding tcbSchedDequeue_def null_def valid_inQ_queues_def - apply wp (* stops on threadSet *) - apply (rule hoare_post_eq[OF _ threadSet_valid_inQ_queues_dequeue_wp] - , simp add: valid_inQ_queues_def) - apply (wp hoare_vcg_if_lift)+ - apply (wp hoare_vcg_imp_lift setQueue_valid_inQ_queues_except_dequeue_wp - threadGet_const_tcb_at)+ - (* wp done *) - apply normalise_obj_at' - apply (clarsimp simp: correct_queue_def) - apply normalise_obj_at' - apply (fastforce simp add: valid_inQ_queues_except_def valid_inQ_queues_def elim: obj_at'_weaken) - done - -lemma tcbSchedDequeue_valid_inQ_queues: - "\valid_inQ_queues and tcb_at' t\ - tcbSchedDequeue t - \\_. valid_inQ_queues\" - apply (rule hoare_pre, rule tcbSchedDequeue_valid_inQ_queues_weak) - apply (fastforce simp: valid_inQ_queues_def obj_at'_def inQ_def) - done - -lemma threadSet_tcbSchedContext_update_valid_inQ_queues[wp]: - "threadSet (tcbSchedContext_update sc_opt) tcbPtr \valid_inQ_queues\" - apply (wpsimp wp: threadSet_wp) - apply (fastforce simp: valid_inQ_queues_def obj_at'_def inQ_def projectKOs objBitsKO_def) - done - -lemma threadSet_tcbInReleaseQueue_update_valid_inQ_queues[wp]: - "\valid_inQ_queues\ - threadSet (tcbInReleaseQueue_update sc_opt) tcbPtr - \\_. valid_inQ_queues\" - apply (wpsimp wp: threadSet_wp) - apply (fastforce simp: valid_inQ_queues_def obj_at'_def inQ_def projectKOs objBitsKO_def) - done - -crunch setReprogramTimer, setReleaseQueue, tcbReleaseRemove - for valid_inQ_queues[wp]: valid_inQ_queues - (simp: tcbReleaseRemove_def) - -lemma schedContextDonate_valid_inQ_queues: - "\valid_inQ_queues and valid_objs' and tcb_at' tcbPtr\ - schedContextDonate scPtr tcbPtr - \\_. valid_inQ_queues\" - (is "valid ?pre _ _") - apply (clarsimp simp: schedContextDonate_def) - apply (rule bind_wp[OF _ get_sc_sp'], rename_tac sc) - apply (rule_tac Q'="\_. ?pre" in bind_wp_fwd) - apply (rule hoare_when_cases, clarsimp) - apply (rule_tac Q'="\_. ?pre" in bind_wp_fwd) - apply (wpsimp wp: tcbSchedDequeue_valid_inQ_queues) - apply (fastforce dest!: sc_ko_at_valid_objs_valid_sc' - simp: valid_sched_context'_def) - apply (rule bind_wp_fwd_skip) - apply wpsimp - apply (rule bind_wp_fwd_skip) - apply (wpsimp wp: threadSet_valid_objs') - apply (fastforce simp: valid_tcb'_def tcb_cte_cases_def) - apply wpsimp+ - done - -lemma replyPop_valid_inQ_queues[wp]: - "\valid_inQ_queues and valid_objs'\ - replyPop replyPtr tcbPtr - \\_. valid_inQ_queues\" - (is "valid ?pre _ _") - apply (clarsimp simp: replyPop_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ get_reply_sp']) - apply (repeat_unless \rule bind_wp[OF _ gts_sp']\ - \rule bind_wp_fwd_skip, solves wpsimp\) - apply (rule_tac P'="?pre and tcb_at' tcbPtr and ko_at' reply replyPtr" - in hoare_weaken_pre[rotated]) - apply fastforce - apply (rule bind_wp[OF _ assert_sp]) - apply (rule bind_wp[OF _ assert_sp]) - apply (case_tac "replyNext reply"; simp add: bind_assoc) - apply wpsimp - apply (rule bind_wp[OF _ assert_sp]) - apply (rule hoare_gen_asm_conj) - apply (clarsimp simp: isHead_def split: reply_next.split_asm) - apply (rename_tac scp) - apply (rule bind_wp[OF _ get_sc_sp']) - apply (wpsimp wp: schedContextDonate_valid_inQ_queues replyUnlink_valid_objs') - apply (rule_tac Q'="\_. valid_inQ_queues and valid_objs' and tcb_at' tcbPtr" in hoare_strengthen_post[rotated]) - apply clarsimp - apply wpsimp - apply (wpsimp wp: updateReply_valid_objs') - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def) - apply (rule_tac Q'="\_. valid_inQ_queues and valid_objs' and tcb_at' tcbPtr and - (\s. bound (replyPrev reply) \ - (\r. valid_reply' r s \ - valid_reply' (replyNext_update (\_. Some (Head scp)) r) s))" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_reply'_def) - apply wpsimp - apply (wpsimp wp: set_sc'.set_wp) - apply clarsimp - apply (frule (1) sc_ko_at_valid_objs_valid_sc'[rotated]) - apply (frule (1) reply_ko_at_valid_objs_valid_reply'[rotated]) - apply (clarsimp simp: valid_sched_context'_def valid_reply'_def) - apply (clarsimp simp: obj_at'_def projectKOs objBits_simps' ps_clear_upd - valid_sched_context_size'_def) - done +lemma cancelAllIPC_tcbDomain_obj_at': + "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ + cancelAllIPC epptr + \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" +apply (simp add: cancelAllIPC_def) +apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift + rescheduleRequired_oa_queued' cancelAllIPC_mapM_x_tcbDomain_obj_at' + getEndpoint_wp + | wpc + | simp)+ +done -crunch replyRemove, replyClear - for valid_inQ_queues[wp]: valid_inQ_queues - (wp: crunch_wps simp: crunch_simps) +lemma cancelAllSignals_tcbDomain_obj_at': + "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ + cancelAllSignals epptr + \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" +apply (simp add: cancelAllSignals_def) +apply (wp hoare_vcg_conj_lift hoare_vcg_const_Ball_lift + rescheduleRequired_oa_queued' cancelAllIPC_mapM_x_tcbDomain_obj_at' + getNotification_wp + | wpc + | simp)+ +done -lemma finaliseCapTrue_standin_valid_inQ_queues[wp]: - "\valid_inQ_queues and valid_objs'\ - finaliseCapTrue_standin cap final - \\_. valid_inQ_queues\" - unfolding finaliseCapTrue_standin_def Let_def - by wpsimp +lemma unbindMaybeNotification_tcbDomain_obj_at': + "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ + unbindMaybeNotification r + \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding unbindMaybeNotification_def + by (wpsimp wp: getNotification_wp gbn_wp' simp: setBoundNotification_def)+ crunch isFinalCapability - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps simp: crunch_simps) + for sch_act[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" + (simp: crunch_simps) -lemma cteDeleteOne_valid_inQ_queues[wp]: - "\valid_inQ_queues and valid_objs'\ - cteDeleteOne sl - \\_. valid_inQ_queues\" - apply (simp add: cteDeleteOne_def unless_def) - apply (wpsimp wp: hoare_drop_imp hoare_vcg_all_lift hoare_vcg_if_lift2) - done +crunch + isFinalCapability + for weak_sch_act[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" + (simp: crunch_simps) crunch cteDeleteOne - for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t'" + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" (wp: crunch_wps simp: crunch_simps unless_def) +lemma cteDeleteOne_tcbDomain_obj_at': + "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ cteDeleteOne slot \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" + apply (simp add: cteDeleteOne_def unless_def split_def) + apply (wp emptySlot_tcbDomain cancelAllIPC_tcbDomain_obj_at' cancelAllSignals_tcbDomain_obj_at' + isFinalCapability_inv getCTE_wp + unbindMaybeNotification_tcbDomain_obj_at' + | rule hoare_drop_imp + | simp add: finaliseCapTrue_standin_def Let_def + split del: if_split + | wpc)+ + apply (clarsimp simp: cte_wp_at'_def) + done + end global_interpretation delete_one_conc_pre - by (unfold_locales, wp) - (wp cteDeleteOne_tcbDomain_obj_at' cteDeleteOne_typ_at' | simp)+ + by (unfold_locales, wp) (wp cteDeleteOne_tcbDomain_obj_at' cteDeleteOne_typ_at' cteDeleteOne_reply_pred_tcb_at | simp)+ lemma cteDeleteOne_invs[wp]: - "\invs' and sch_act_simple\ cteDeleteOne ptr \\rv. invs'\" + "\invs'\ cteDeleteOne ptr \\rv. invs'\" apply (simp add: cteDeleteOne_def unless_def split_def finaliseCapTrue_standin_simple_def) apply wp - apply (rule hoare_strengthen_post) - apply (rule hoare_vcg_conj_lift) - apply (rule finaliseCap_True_invs') - apply (rule hoare_vcg_conj_lift) - apply (rule finaliseCap_replaceable[where slot=ptr]) - apply (rule hoare_vcg_conj_lift) - apply (rule finaliseCap_cte_refs) - apply (rule finaliseCap_equal_cap[where sl=ptr]) - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (erule disjE) - apply simp - apply (clarsimp dest!: isCapDs simp: capRemovable_def) - apply (clarsimp simp: removeable'_def fun_eq_iff[where f="cte_refs' cap" for cap] - del: disjCI) - apply (rule disjI2) - apply (rule conjI) - apply fastforce - apply (fastforce dest!: isCapDs simp: pred_tcb_at'_def obj_at'_def projectKOs ko_wp_at'_def) - apply (wp isFinalCapability_inv getCTE_wp' hoare_weak_lift_imp - | wp (once) isFinal[where x=ptr])+ + apply (rule hoare_strengthen_post) + apply (rule hoare_vcg_conj_lift) + apply (rule finaliseCap_True_invs) + apply (rule hoare_vcg_conj_lift) + apply (rule finaliseCap_replaceable[where slot=ptr]) + apply (rule hoare_vcg_conj_lift) + apply (rule finaliseCap_cte_refs) + apply (rule finaliseCap_equal_cap[where sl=ptr]) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (erule disjE) + apply simp + apply (clarsimp dest!: isCapDs simp: capRemovable_def) + apply (clarsimp simp: removeable'_def fun_eq_iff[where f="cte_refs' cap" for cap] + del: disjCI) + apply (rule disjI2) + apply (rule conjI) + subgoal by auto + subgoal by (auto dest!: isCapDs simp: pred_tcb_at'_def obj_at'_def projectKOs + ko_wp_at'_def) + apply (wp isFinalCapability_inv getCTE_wp' hoare_weak_lift_imp + | wp (once) isFinal[where x=ptr])+ apply (fastforce simp: cte_wp_at_ctes_of) done @@ -4153,114 +3169,51 @@ global_interpretation delete_one_conc_fr: delete_one_conc declare cteDeleteOne_invs[wp] lemma deletingIRQHandler_invs' [wp]: - "\invs' and sch_act_simple\ deletingIRQHandler i \\_. invs'\" + "\invs'\ deletingIRQHandler i \\_. invs'\" apply (simp add: deletingIRQHandler_def getSlotCap_def getIRQSlot_def locateSlot_conv getInterruptState_def) apply (wp getCTE_wp') apply simp done -crunch - unbindFromSC, schedContextUnbindReply, schedContextUnbindNtfn, schedContextUnbindAllTCBs - for sch_act_simple[wp]: sch_act_simple - (simp: crunch_simps wp: crunch_wps) - -lemma unbindFromSC_invs'[wp]: - "\invs' and sch_act_simple and tcb_at' t and K (t \ idle_thread_ptr)\ - unbindFromSC t - \\_. invs'\" - apply (clarsimp simp: unbindFromSC_def sym_refs_asrt_def) - apply (wpsimp split_del: if_split) - apply (rule_tac Q'="\_. sc_at' y and invs' and sch_act_simple" in hoare_post_imp) - apply (fastforce simp: projectKOs valid_obj'_def valid_sched_context'_def - dest!: ko_at_valid_objs') - apply (wpsimp wp: typ_at_lifts threadGet_wp)+ - apply (drule obj_at_ko_at', clarsimp) - apply (frule ko_at_valid_objs'; clarsimp simp: valid_obj'_def valid_tcb'_def projectKOs) - apply (rule_tac x=ko in exI, clarsimp) - apply (frule sym_refs_tcbSchedContext; assumption?) - apply (subgoal_tac "ex_nonz_cap_to' idle_sc_ptr s") - apply (fastforce simp: invs'_def global'_sc_no_ex_cap) - apply (fastforce intro!: if_live_then_nonz_capE' - simp: projectKOs obj_at'_def ko_wp_at'_def live_sc'_def) - done - -lemma schedContextSetInactive_invs'[wp]: - "schedContextSetInactive scPtr \invs'\" - apply (clarsimp simp: schedContextSetInactive_def updateSchedContext_def) - apply (rule bind_wp_fwd_skip) - apply (wpsimp wp: setSchedContext_invs' hoare_vcg_all_lift) - apply (fastforce dest: invs'_ko_at_valid_sched_context' intro!: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def live_sc'_def projectKOs - valid_sched_context'_def valid_sched_context_size'_def objBits_simps') - apply (wpsimp wp: setSchedContext_invs' hoare_vcg_all_lift hoare_vcg_imp_lift' ) - apply (fastforce dest: invs'_ko_at_valid_sched_context' intro!: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def live_sc'_def projectKOs - valid_sched_context'_def valid_sched_context_size'_def objBits_simps') - done - -lemma schedContextUnbindYieldFrom_invs'[wp]: - "schedContextUnbindYieldFrom scPtr \invs'\" - apply (clarsimp simp: schedContextUnbindYieldFrom_def) - apply wpsimp - done - -lemma schedContextUnbindReply_invs'[wp]: - "schedContextUnbindReply scPtr \invs'\" - unfolding schedContextUnbindReply_def - apply (wpsimp wp: setSchedContext_invs' updateReply_replyNext_None_invs' - hoare_vcg_imp_lift typ_at_lifts) - apply (clarsimp simp: invs'_def valid_pspace'_def sym_refs_asrt_def) - apply (frule (1) ko_at_valid_objs', clarsimp simp: projectKOs) - apply (frule (3) sym_refs_scReplies) - apply (intro conjI) - apply (fastforce simp: obj_at'_def opt_map_def projectKOs sym_heap_def split: option.splits) - apply (fastforce elim: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def projectKOs live_sc'_def) - apply (auto simp: valid_obj'_def valid_sched_context'_def valid_sched_context_size'_def - objBits_simps') - done - -lemma schedContextUnbindAllTCBs_invs'[wp]: - "\invs' and K (scPtr \ idle_sc_ptr)\ - schedContextUnbindAllTCBs scPtr - \\rv. invs'\" - apply (clarsimp simp: schedContextUnbindAllTCBs_def) - by wpsimp +crunch unbindNotification, unbindMaybeNotification + for tcb_at'[wp]: "tcb_at' t" lemma finaliseCap_invs: "\invs' and sch_act_simple and valid_cap' cap - and cte_wp_at' (\cte. cteCap cte = cap) sl\ - finaliseCap cap fin flag + and cte_wp_at' (\cte. cteCap cte = cap) sl\ + finaliseCap cap fin flag \\rv. invs'\" apply (simp add: finaliseCap_def Let_def cong: if_cong split del: if_split) apply (rule hoare_pre) - apply (wpsimp wp: hoare_vcg_all_lift) - apply (case_tac cap; clarsimp simp: isCap_simps) - apply (frule invs_valid_global', drule(1) valid_globals_cte_wpD'_idleThread) - apply (frule valid_capAligned, drule capAligned_capUntypedPtr) - apply clarsimp - apply (clarsimp dest!: simp: valid_cap'_def valid_idle'_def valid_idle'_asrt_def) - apply (subgoal_tac "ex_nonz_cap_to' (ksIdleThread s) s") - apply (fastforce simp: invs'_def global'_no_ex_cap) - apply (frule invs_valid_global', drule(1) valid_globals_cte_wpD'_idleSC) - apply (frule valid_capAligned, drule capAligned_capUntypedPtr) - apply clarsimp + apply (wp hoare_drop_imps hoare_vcg_all_lift | simp only: o_def | wpc)+ + apply clarsimp + apply (intro conjI impI) + apply (clarsimp dest!: isCapDs simp: valid_cap'_def) + apply (drule invs_valid_global', drule(1) valid_globals_cte_wpD') + apply (drule valid_capAligned, drule capAligned_capUntypedPtr) + apply (clarsimp dest!: isCapDs) + apply (clarsimp dest!: isCapDs) + apply (clarsimp dest!: isCapDs) done lemma finaliseCap_zombie_cap[wp]: - "finaliseCap cap fin flag \cte_wp_at' (\cte. (P and isZombie) (cteCap cte)) sl\" + "\cte_wp_at' (\cte. (P and isZombie) (cteCap cte)) sl\ + finaliseCap cap fin flag + \\rv. cte_wp_at' (\cte. (P and isZombie) (cteCap cte)) sl\" apply (simp add: finaliseCap_def Let_def cong: if_cong split del: if_split) - apply (wpsimp wp: suspend_cte_wp_at' deletingIRQHandler_cte_preserved - simp: finaliseCap_def isCap_simps) + apply (rule hoare_pre) + apply (wp suspend_cte_wp_at' + deletingIRQHandler_cte_preserved + | clarsimp simp: finaliseCap_def isCap_simps | wpc)+ done lemma finaliseCap_zombie_cap': "\cte_wp_at' (\cte. (P and isZombie) (cteCap cte)) sl\ - finaliseCap cap fin flag + finaliseCap cap fin flag \\rv. cte_wp_at' (\cte. P (cteCap cte)) sl\" apply (rule hoare_strengthen_post) apply (rule finaliseCap_zombie_cap) @@ -4268,22 +3221,26 @@ lemma finaliseCap_zombie_cap': done lemma finaliseCap_cte_cap_wp_to[wp]: - "finaliseCap cap fin flag \ex_cte_cap_wp_to' P sl\" + "\ex_cte_cap_wp_to' P sl\ finaliseCap cap fin flag \\rv. ex_cte_cap_wp_to' P sl\" apply (simp add: ex_cte_cap_to'_def) apply (rule hoare_pre, rule hoare_use_eq_irq_node' [OF finaliseCap_irq_node']) apply (simp add: finaliseCap_def Let_def cong: if_cong split del: if_split) - apply (wpsimp wp: suspend_cte_wp_at' deletingIRQHandler_cte_preserved - hoare_vcg_ex_lift - simp: finaliseCap_def isCap_simps - | rule conjI)+ + apply (wp suspend_cte_wp_at' + deletingIRQHandler_cte_preserved + hoare_vcg_ex_lift + | clarsimp simp: finaliseCap_def isCap_simps + | rule conjI + | wpc)+ apply fastforce done -global_interpretation unbindNotification: typ_at_all_props' "unbindNotification tcb" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) +context +notes option.case_cong_weak[cong] +begin +crunch unbindNotification + for valid_cap'[wp]: "valid_cap' cap" +end lemma finaliseCap_valid_cap[wp]: "\valid_cap' cap\ finaliseCap cap final flag \\rv. valid_cap' (fst rv)\" @@ -4291,15 +3248,30 @@ lemma finaliseCap_valid_cap[wp]: getThreadCSpaceRoot ARM_H.finaliseCap_def cong: if_cong split del: if_split) - apply wpsimp - by (auto simp: valid_cap'_def isCap_simps capAligned_def objBits_simps shiftL_nat) + apply (rule hoare_pre) + apply (wp | simp only: valid_NullCap o_def fst_conv | wpc)+ + apply simp + apply (intro conjI impI) + apply (clarsimp simp: valid_cap'_def isCap_simps capAligned_def + objBits_simps shiftL_nat)+ + done + + +context begin interpretation Arch . (*FIXME: arch-split*) crunch "Arch.finaliseCap" for nosch[wp]: "\s. P (ksSchedulerAction s)" (wp: crunch_wps getObject_inv simp: loadObject_default_def updateObject_default_def) +crunch finaliseCap + for sch_act_simple[wp]: sch_act_simple + (simp: crunch_simps + rule: sch_act_simple_lift + wp: getObject_inv loadObject_default_inv crunch_wps) + end + lemma interrupt_cap_null_or_ntfn: "invs s \ cte_wp_at (\cp. is_ntfn_cap cp \ cp = cap.NullCap) (interrupt_irq_node s irq, []) s" @@ -4320,9 +3292,7 @@ lemma interrupt_cap_null_or_ntfn: done lemma (in delete_one) deletingIRQHandler_corres: - "corres dc - (einvs and simple_sched_action and current_time_bounded) - invs' + "corres dc (einvs) (invs') (deleting_irq_handler irq) (deletingIRQHandler irq)" apply (simp add: deleting_irq_handler_def deletingIRQHandler_def) apply (rule corres_guard_imp) @@ -4331,7 +3301,7 @@ lemma (in delete_one) deletingIRQHandler_corres: apply (rule_tac P'="cte_at' (cte_map slot)" in corres_symb_exec_r_conj) apply (rule_tac F="isNotificationCap rv \ rv = capability.NullCap" and P="cte_wp_at (\cp. is_ntfn_cap cp \ cp = cap.NullCap) slot - and einvs and simple_sched_action and current_time_bounded" + and einvs" and P'="invs' and cte_wp_at' (\cte. cteCap cte = rv) (cte_map slot)" in corres_req) apply (clarsimp simp: cte_wp_at_caps_of_state state_relation_def) @@ -4349,7 +3319,7 @@ lemma (in delete_one) deletingIRQHandler_corres: apply (clarsimp simp: cte_wp_at_ctes_of) done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma arch_finaliseCap_corres: "\ final_matters' (ArchObjectCap cap') \ final = final'; acap_relation cap cap' \ @@ -4363,7 +3333,6 @@ lemma arch_finaliseCap_corres: (final_matters' (ArchObjectCap cap') \ final' = isFinal (ArchObjectCap cap') (cte_map sl) (cteCaps_of s))) (arch_finalise_cap cap final) (Arch.finaliseCap cap' final')" - apply add_cur_tcb' apply (cases cap; clarsimp simp: arch_finalise_cap_def ARM_H.finaliseCap_def final_matters'_def case_bool_If liftM_def[symmetric] @@ -4379,296 +3348,129 @@ lemma arch_finaliseCap_corres: apply simp apply (clarsimp simp: valid_cap_def valid_unmap_def) apply (auto simp: vmsz_aligned_def pbfs_atleast_pageBits mask_def - elim: is_aligned_weaken)[2] + elim: is_aligned_weaken invs_valid_asid_map)[2] apply (rule corres_guard_imp, rule unmapPageTable_corres) apply (auto simp: valid_cap_def valid_cap'_def mask_def - elim!: is_aligned_weaken)[2] + elim!: is_aligned_weaken invs_valid_asid_map)[2] apply (rule corres_guard_imp, rule deleteASID_corres) - apply (auto simp: mask_def valid_cap_def)[2] + apply (auto elim!: invs_valid_asid_map simp: mask_def valid_cap_def)[2] done lemma unbindNotification_corres: "corres dc - (invs and tcb_at t) - invs' - (unbind_notification t) - (unbindNotification t)" - supply option.case_cong_weak[cong] + (invs and tcb_at t) + invs' + (unbind_notification t) + (unbindNotification t)" apply (simp add: unbind_notification_def unbindNotification_def) - 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 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 (rule corres_split[OF getNotification_corres]) + apply clarsimp apply (rule corres_split[OF setNotification_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 setBoundNotification_corres) - apply (wpsimp wp: gbn_wp' gbn_wp get_ntfn_ko' 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) - apply (metis obj_at_simps(1) valid_bound_obj_Some) + apply (wp gbn_wp' gbn_wp)+ + apply (clarsimp elim!: obj_at_valid_objsE + dest!: bound_tcb_at_state_refs_ofD invs_valid_objs + simp: valid_obj_def is_tcb tcb_ntfn_is_bound_def obj_at_def + valid_tcb_def valid_bound_ntfn_def invs_psp_aligned invs_distinct + split: option.splits) apply (clarsimp dest!: obj_at_valid_objs' bound_tcb_at_state_refs_ofD' invs_valid_objs' - simp: projectKOs valid_obj'_def valid_tcb'_def valid_bound_ntfn'_def + simp: valid_obj'_def valid_tcb'_def valid_bound_ntfn'_def tcb_ntfn_is_bound'_def + projectKOs split: option.splits) done lemma unbindMaybeNotification_corres: "corres dc - (invs and ntfn_at ntfnptr) - invs' + (invs and ntfn_at ntfnptr) (invs' and ntfn_at' ntfnptr) (unbind_maybe_notification ntfnptr) (unbindMaybeNotification ntfnptr)" apply (simp add: unbind_maybe_notification_def unbindMaybeNotification_def) - 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 (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) 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 getNotification_wp)+ + apply (rule corres_split[OF setNotification_corres]) + apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) apply (rule setBoundNotification_corres) - apply (wpsimp simp: obj_at_def is_ntfn wp: get_simple_ko_wp getNotification_wp)+ - apply (frule invs_valid_objs) - apply (erule (1) pspace_valid_objsE) - apply (clarsimp simp: valid_obj_def valid_ntfn_def obj_at_def split: option.splits) - 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)" - 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]) - apply (simp add: get_sc_obj_ref_def) - apply (rule 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 (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_tac f'="scNtfn_update (\_. None)" - in update_sc_no_reply_stack_update_ko_at'_corres) - apply (clarsimp simp: sc_relation_def objBits_def objBitsKO_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 + apply (wp get_simple_ko_wp getNotification_wp)+ + apply (clarsimp elim!: obj_at_valid_objsE + dest!: bound_tcb_at_state_refs_ofD invs_valid_objs + simp: valid_obj_def is_tcb tcb_ntfn_is_bound_def invs_psp_aligned invs_distinct + valid_tcb_def valid_bound_ntfn_def valid_ntfn_def split: option.splits) - apply (clarsimp split: option.splits) - apply (frule (1) scNtfn_sym_refsD[OF ko_at_obj_at', simplified]) - apply clarsimp+ - apply normalise_obj_at' - apply (clarsimp simp: sym_refs_asrt_def) - done - -lemma sched_context_maybe_unbind_ntfn_corres: - "corres dc - (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) - 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_tac f'="scNtfn_update (\_. None)" - in update_sc_no_reply_stack_update_ko_at'_corres) - apply (clarsimp simp: sc_relation_def objBits_def objBitsKO_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 (clarsimp simp: sym_refs_asrt_def) - apply (wpsimp wp: get_simple_ko_wp getNotification_wp split: option.splits)+ - done - -lemma replyClear_corres: - "corres dc - (invs and valid_ready_qs and st_tcb_at is_reply_state tp - and active_scs_valid and weak_valid_sched_action) - (invs' and st_tcb_at' (\st. replyObject st = Some rptr) tp) - (do - state \ get_thread_state tp; - case state of - Structures_A.thread_state.BlockedOnReply r \ reply_remove tp r - | _ \ cancel_ipc tp - od) - (replyClear rptr tp)" - apply (clarsimp simp: replyClear_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres]) - apply (rename_tac st st') - apply (rule_tac R="is_blocked_on_receive st" in corres_cases_lhs; - clarsimp simp: thread_state_relation_def is_blocked_thread_state_defs) - apply (rule cancel_ipc_corres) - apply (rule_tac R="is_blocked_on_reply st" in corres_cases_lhs; - clarsimp simp: is_blocked_thread_state_defs) - apply (wpfix add: Structures_H.thread_state.sel) - apply (rule corres_guard_imp) - apply (rule_tac st="Structures_A.BlockedOnReply reply" - and st'="BlockedOnReply (Some reply)" - in replyRemove_corres) - apply simp - apply simp - apply simp - apply simp - apply (rule corres_False'[where P'=\]) - apply (wpsimp wp: gts_wp gts_wp')+ - apply (clarsimp simp: pred_tcb_at_def obj_at_def is_obj_defs invs_def valid_pspace_def valid_state_def) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def invs'_def valid_pspace'_def opt_map_Some_eta_fold) + apply (clarsimp dest!: obj_at_valid_objs' bound_tcb_at_state_refs_ofD' invs_valid_objs' + simp: valid_obj'_def valid_tcb'_def valid_bound_ntfn'_def + tcb_ntfn_is_bound'_def valid_ntfn'_def + split: option.splits) done lemma fast_finaliseCap_corres: "\ final_matters' cap' \ final = final'; cap_relation cap cap'; can_fast_finalise cap \ \ corres dc - (\s. invs s \ valid_sched s \ s \ cap \ current_time_bounded s + (\s. invs s \ valid_sched s \ s \ cap \ cte_wp_at ((=) cap) sl s) (\s. invs' s \ s \' cap') (fast_finalise cap final) - (finaliseCap cap' final' True)" - apply add_sch_act_wf - apply (cases cap, simp_all add: finaliseCap_def isCap_simps final_matters'_def + (do + p \ finaliseCap cap' final' True; + assert (capRemovable (fst p) (cte_map ptr) \ snd p = NullCap) + od)" + apply (cases cap, simp_all add: finaliseCap_def isCap_simps corres_liftM2_simp[unfolded liftM_def] o_def dc_def[symmetric] when_def can_fast_finalise_def capRemovable_def split del: if_split cong: if_cong) - (* EndpointCap *) - apply clarsimp - apply (rule corres_stateAssert_assume; (simp add: sch_act_wf_asrt_def)?) - apply (rule corres_guard_imp) - apply (rule cancelAllIPC_corres) - apply (simp add: valid_cap_def) - apply (simp add: valid_cap'_def) - (* NotificationCap *) - apply clarsimp - apply (rule corres_stateAssert_assume; (simp add: sch_act_wf_asrt_def)?) + apply (clarsimp simp: final_matters'_def) apply (rule corres_guard_imp) - apply (rule corres_split[OF sched_context_maybe_unbind_ntfn_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)+ - apply (clarsimp simp: valid_cap_def) - apply (clarsimp simp: valid_cap'_def) - (* ReplyCap *) - apply clarsimp - apply (rename_tac rptr rs) - apply (add_sym_refs, add_valid_replies rptr simp: valid_cap_def, add_sch_act_wf) - apply (rule corres_stateAssert_assume; (simp add: sym_refs_asrt_def)?) - apply (rule corres_stateAssert_assume; simp?) - apply (rule corres_stateAssert_assume; (simp add: sch_act_wf_asrt_def)?) + apply (rule corres_rel_imp) + apply (rule ep_cancel_corres) + apply simp + apply (simp add: valid_cap_def) + apply (simp add: valid_cap'_def) + apply (clarsimp simp: final_matters'_def) apply (rule corres_guard_imp) - apply (rule corres_split[OF getReply_TCB_corres]) - apply (simp split del: if_split) - apply (rule_tac R="tptrOpt = None" in corres_cases'; - clarsimp simp del: corres_return) - apply (rule corres_return_trivial) - apply wpfix - apply (rule replyClear_corres) - apply (wpsimp wp: get_simple_ko_wp)+ - apply (clarsimp simp: valid_cap_def valid_sched_valid_ready_qs) - apply (drule reply_tcb_state_refs; - fastforce simp: pred_tcb_at_def obj_at_def is_blocked_thread_state_defs - elim: reply_object.elims) - apply (clarsimp simp: valid_cap'_def) - apply (rule pred_tcb'_weakenE, erule sym_ref_replyTCB_Receive_or_Reply; fastforce) - done - -lemma finaliseCap_true_removable[wp]: - "\\\ - finaliseCap cap final True - \\rv s. capRemovable (fst rv) (cte_map slot) \ snd rv = capability.NullCap\" - by (cases cap; wpsimp simp: finaliseCap_def isCap_simps capRemovable_def) + apply (rule corres_split[OF unbindMaybeNotification_corres]) + apply (rule cancelAllSignals_corres) + apply (wp abs_typ_at_lifts unbind_maybe_notification_invs typ_at_lifts hoare_drop_imps getNotification_wp + | wpc)+ + apply (clarsimp simp: valid_cap_def) + apply (clarsimp simp: valid_cap'_def projectKOs valid_obj'_def + dest!: invs_valid_objs' obj_at_valid_objs' ) + done lemma cap_delete_one_corres: - "corres dc - (einvs and simple_sched_action and cte_wp_at can_fast_finalise slot - and current_time_bounded) - (invs' and cte_at' (cte_map slot)) - (cap_delete_one slot) (cteDeleteOne (cte_map slot))" + "corres dc (einvs and cte_wp_at can_fast_finalise ptr) + (invs' and cte_at' (cte_map ptr)) + (cap_delete_one ptr) (cteDeleteOne (cte_map ptr))" apply (simp add: cap_delete_one_def cteDeleteOne_def' unless_def when_def) - apply (rule corres_cross[OF sch_act_simple_cross_rel], clarsimp) apply (rule corres_guard_imp) apply (rule corres_split[OF get_cap_corres]) apply (rule_tac F="can_fast_finalise cap" in corres_gen_asm) apply (rule corres_if) apply fastforce - apply (rule corres_split[OF isFinalCapability_corres[where ptr=slot]]) - apply (rule corres_split) - apply (rule fast_finaliseCap_corres[where sl=slot]; clarsimp) - apply clarsimp - apply wpfix - apply (rule corres_assert_assume_r) - apply (rule emptySlot_corres) - apply (wpsimp wp: hoare_drop_imps fast_finalise_invs fast_finalise_valid_sched)+ - apply (wp isFinalCapability_inv) + apply (rule corres_split[OF isFinalCapability_corres[where ptr=ptr]]) + apply (simp add: split_def bind_assoc [THEN sym]) + apply (rule corres_split[OF fast_finaliseCap_corres[where sl=ptr]]) + apply simp+ + apply (rule emptySlot_corres, simp) + apply (wp hoare_drop_imps)+ + apply (wp isFinalCapability_inv | wp (once) isFinal[where x="cte_map ptr"])+ apply (rule corres_trivial, simp) apply (wp get_cap_wp getCTE_wp)+ - apply (fastforce simp: cte_wp_at_caps_of_state can_fast_finalise_Null - simp del: split_paired_Ex - elim!: caps_of_state_valid_cap) - apply (fastforce simp: cte_wp_at_ctes_of) + apply (clarsimp simp: cte_wp_at_caps_of_state can_fast_finalise_Null + elim!: caps_of_state_valid_cap) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply fastforce done - end (* FIXME: strengthen locale instead *) @@ -4679,335 +3481,61 @@ global_interpretation delete_one apply auto done -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 - 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_implied[where P'=\, simplified]) - apply (rule corres_stateAssert_add_assertion[rotated], simp)+ - 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]) - 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) - apply (rule_tac sc'=sc' in update_sc_no_reply_stack_update_ko_at'_corres) - apply (clarsimp simp: sc_relation_def objBits_def objBitsKO_def)+ - apply wpsimp+ - apply (case_tac sc'; clarsimp) - apply (wpfix add: sched_context.sel) - apply simp - apply wpsimp+ - apply (frule invs_valid_objs) - apply (fastforce 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 projectKOs - 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)" - 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: projectKOs valid_obj'_def valid_sched_context'_def - dest!: ko_at_valid_objs') - apply (wpsimp wp: typ_at_lifts get_tcb_obj_ref_wp threadGet_wp)+ - 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)?) - 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 (rule_tac x=ko in exI, 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: projectKOs obj_at'_def ko_wp_at'_def live_sc'_def) - apply (clarsimp simp: sym_refs_asrt_def) - 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)" - apply (clarsimp simp: sched_context_unbind_all_tcbs_def schedContextUnbindAllTCBs_def) - apply (rule corres_gen_asm, clarsimp) - apply (rule 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 (clarsimp simp: obj_at'_def) - done - -lemma replyNext_update_corres_empty: - "corres dc (reply_at rptr) (reply_at' rptr) - (set_reply_obj_ref reply_sc_update rptr None) - (updateReply rptr (\reply. replyNext_update (\_. None) reply))" - unfolding update_sk_obj_ref_def updateReply_def - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_reply_corres set_reply_corres]) - apply (clarsimp simp: reply_relation_def) - apply wpsimp+ - apply (clarsimp simp: obj_at'_def replyPrev_same_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)" - 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))" - 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) - apply clarsimp - apply (rule corres_split[OF replyNext_update_corres_empty]) - apply (rule update_sc_reply_stack_update_ko_at'_corres) - apply wpsimp+ - 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 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 projectKOs 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)+ - done - -lemma schedContextUnbindYieldFrom_corres: - "corres dc (einvs and sc_at scPtr and K (scPtr \ idle_sc_ptr)) (invs' and sc_at' scPtr) - (sched_context_unbind_yield_from scPtr) (schedContextUnbindYieldFrom scPtr)" - apply (clarsimp simp: sched_context_unbind_yield_from_def schedContextUnbindYieldFrom_def - maybeM_when) - 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]) - apply (rename_tac sc sc') - apply (case_tac sc') - apply (clarsimp simp: sc_relation_def) - apply (wpfix add: sched_context.sel) - apply (rule corres_when) - apply (clarsimp simp: sc_relation_def) - apply (rule schedContextCompleteYieldTo_corres) - apply wpsimp+ - apply (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) - done - -lemma schedContextSetInactive_corres: - "corres dc (\s. sc_at scPtr s) (sc_at' scPtr) - (sched_context_set_inactive scPtr) (schedContextSetInactive scPtr)" - apply (clarsimp simp: sched_context_set_inactive_def schedContextSetInactive_def) - apply (rule corres_guard_imp) - - \ \collect the update of the sc_refills, sc_refill_max, and the sc_budget fields\ - apply (subst bind_assoc[symmetric]) - apply (subst bind_assoc[symmetric]) - apply (subst bind_dummy_ret_val, subst update_sched_context_decompose[symmetric]) - apply (subst bind_dummy_ret_val, subst update_sched_context_decompose[symmetric]) - - apply (rule corres_split) - apply (rule updateSchedContext_corres) - apply (clarsimp simp: opt_map_red opt_pred_def obj_at_simps is_sc_obj) - apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - 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 obj_at_simps is_sc_obj_def - split: Structures_A.kernel_object.splits) - apply (clarsimp simp: objBits_simps) - apply (rule updateSchedContext_corres) - apply (clarsimp simp: opt_map_red opt_pred_def obj_at_simps is_sc_obj) - apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - 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 obj_at_simps is_sc_obj_def - split: Structures_A.kernel_object.splits) - apply (clarsimp simp: objBits_simps) - apply (wpsimp wp: get_sched_context_wp getSchedContext_wp)+ - done - -lemma can_fast_finalise_finalise_cap: - "can_fast_finalise cap - \ finalise_cap cap final - = do fast_finalise cap final; return (cap.NullCap, cap.NullCap) od" - by (cases cap; simp add: can_fast_finalise_def liftM_def) - -lemma can_fast_finalise_finaliseCap: - "is_ReplyCap cap \ is_EndpointCap cap \ is_NotificationCap cap \ cap = NullCap - \ finaliseCap cap final flag - = do finaliseCap cap final True; return (NullCap, NullCap) od" - by (cases cap; simp add: finaliseCap_def isCap_simps) - -context begin interpretation Arch . (*FIXME: arch_split*) - lemma finaliseCap_corres: "\ final_matters' cap' \ final = final'; cap_relation cap cap'; flag \ can_fast_finalise cap \ \ corres (\x y. cap_relation (fst x) (fst y) \ cap_relation (snd x) (snd y)) (\s. einvs s \ s \ cap \ (final_matters cap \ final = is_final_cap' cap s) - \ cte_wp_at ((=) cap) sl s \ simple_sched_action s - \ current_time_bounded s) - (\s. invs' s \ s \' cap' - \ (final_matters' cap' \ - final' = isFinal cap' (cte_map sl) (cteCaps_of s)) - \ sch_act_simple s) + \ cte_wp_at ((=) cap) sl s) + (\s. invs' s \ s \' cap' \ + (final_matters' cap' \ + final' = isFinal cap' (cte_map sl) (cteCaps_of s))) (finalise_cap cap final) (finaliseCap cap' final' flag)" - apply (case_tac "can_fast_finalise cap") - apply (simp add: can_fast_finalise_finalise_cap) - apply (subst can_fast_finalise_finaliseCap, - clarsimp simp: can_fast_finalise_def split: cap.splits) - apply (rule corres_guard_imp) - apply (rule corres_split[OF fast_finaliseCap_corres[where sl=sl]]; assumption?) - apply simp - apply (simp only: K_bind_def) - apply (rule corres_returnTT) - apply wpsimp+ apply (cases cap, simp_all add: finaliseCap_def isCap_simps corres_liftM2_simp[unfolded liftM_def] o_def dc_def[symmetric] when_def can_fast_finalise_def split del: if_split cong: if_cong) - (* CNodeCap *) - apply (fastforce simp: final_matters'_def shiftL_nat zbits_map_def) - (* ThreadCap *) - apply add_valid_idle' - apply (rename_tac tptr) - apply (clarsimp simp: final_matters'_def getThreadCSpaceRoot - liftM_def[symmetric] o_def zbits_map_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (rule_tac P="K (tptr \ idle_thread_ptr)" and P'="K (tptr \ idle_thread_ptr)" - in corres_add_guard) - apply clarsimp - apply (frule(1) valid_global_refsD[OF invs_valid_global_refs _ idle_global]) - apply (clarsimp dest!: invs_valid_idle simp: valid_idle_def cap_range_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF unbindNotification_corres]) - apply (rule corres_split[OF unbindFromSC_corres]) - apply (rule corres_split[OF suspend_corres]) - apply (clarsimp simp: liftM_def[symmetric] o_def dc_def[symmetric] zbits_map_def) - apply (rule prepareThreadDelete_corres) - apply (wp unbind_notification_invs unbind_from_sc_valid_sched)+ - apply (clarsimp simp: valid_cap_def) - apply (clarsimp simp: valid_cap'_def) - (* SchedContextCap *) - apply (rename_tac scptr n) - apply (clarsimp simp: final_matters'_def liftM_def[symmetric] - o_def dc_def[symmetric]) - apply (rule_tac P="K (scptr \ idle_sc_ptr)" and P'="K (scptr \ idle_sc_ptr)" - in corres_add_guard) - 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 (clarsimp simp: final_matters'_def) + apply (rule corres_guard_imp) + apply (rule ep_cancel_corres) + apply (simp add: valid_cap_def) + apply (simp add: valid_cap'_def) + apply (clarsimp simp add: final_matters'_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF unbindMaybeNotification_corres]) + apply (rule cancelAllSignals_corres) + apply (wp abs_typ_at_lifts unbind_maybe_notification_invs typ_at_lifts hoare_drop_imps hoare_vcg_all_lift | wpc)+ + apply (clarsimp simp: valid_cap_def) + apply (clarsimp simp: valid_cap'_def) + apply (fastforce simp: final_matters'_def shiftL_nat zbits_map_def) + apply (clarsimp simp add: final_matters'_def getThreadCSpaceRoot + liftM_def[symmetric] o_def zbits_map_def + dc_def[symmetric]) apply (rule corres_guard_imp) - apply (rule corres_split[OF schedContextUnbindAllTCBs_corres]) - apply (rule corres_split[OF schedContextUnbindNtfn_corres]) - apply (rule corres_split[OF schedContextUnbindReply_corres]) - apply (rule corres_split[OF schedContextUnbindYieldFrom_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 (clarsimp simp: valid_cap'_def sc_at'_n_sc_at') - (* IRQHandlerCap *) - apply (clarsimp simp: final_matters'_def liftM_def[symmetric] - o_def dc_def[symmetric]) - apply (rule corres_guard_imp) + apply (rule corres_split[OF unbindNotification_corres]) + apply (rule corres_split[OF suspend_corres]) + apply (clarsimp simp: liftM_def[symmetric] o_def dc_def[symmetric] zbits_map_def) + apply (rule prepareThreadDelete_corres) + apply (wp unbind_notification_invs unbind_notification_simple_sched_action)+ + apply (simp add: valid_cap_def) + apply (simp add: valid_cap'_def) + apply (simp add: final_matters'_def liftM_def[symmetric] + o_def dc_def[symmetric]) + apply (intro impI, rule corres_guard_imp) apply (rule deletingIRQHandler_corres) apply simp apply simp - (* ZombieCap *) apply (clarsimp simp: final_matters'_def) apply (rule_tac F="False" in corres_req) apply clarsimp apply (frule zombies_finalD, (clarsimp simp: is_cap_simps)+) apply (clarsimp simp: cte_wp_at_caps_of_state) apply simp - (* ArchObjectCap *) apply (clarsimp split del: if_split simp: o_def) - apply (rule corres_guard_imp [OF arch_finaliseCap_corres], (fastforce simp: valid_sched_def)+)[1] + apply (rule corres_guard_imp [OF arch_finaliseCap_corres], (fastforce simp: valid_sched_def)+) done - +context begin interpretation Arch . (*FIXME: arch-split*) lemma arch_recycleCap_improve_cases: "\ \ isPageCap cap; \ isPageTableCap cap; \ isPageDirectoryCap cap; \ isASIDControlCap cap \ \ (if isASIDPoolCap cap then v else undefined) = v" @@ -5037,78 +3565,76 @@ crunch copyGlobalMappings for ct__in_cur_domain'[wp]: ct_idle_or_in_cur_domain' (wp: crunch_wps) +crunch copyGlobalMappings + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: crunch_wps) + 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 +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 crunch invalidateTLBByASID - for valid_arch_state'[wp]: "valid_arch_state'" - -end - -sublocale Arch < invalidateTLBByASID: typ_at_all_props' "invalidateTLBByASID asid" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) + for typ_at'[wp]: "\s. P (typ_at' T p s)" +crunch invalidateTLBByASID + for valid_arch_state'[wp]: "valid_arch_state'" +lemmas invalidateTLBByASID_typ_ats[wp] = typ_at_lifts [OF invalidateTLBByASID_typ_at'] crunch invalidateTLBByASID for cteCaps_of: "\s. P (cteCaps_of s)" +crunch invalidate_tlb_by_asid + for valid_etcbs[wp]: valid_etcbs + +lemma cteCaps_of_ctes_of_lift: + "(\P. \\s. P (ctes_of s)\ f \\_ s. P (ctes_of s)\) \ \\s. P (cteCaps_of s) \ f \\_ s. P (cteCaps_of s)\" + unfolding cteCaps_of_def . + lemmas final_matters'_simps = final_matters'_def [split_simps capability.split arch_capability.split] -lemma cancelAll_ct_not_ksQ_helper: - "\(\s. ksCurThread s \ set (ksReadyQueues s p)) and (\s. ksCurThread s \ set q) \ - mapM_x (\t. do - y \ setThreadState Structures_H.thread_state.Restart t; - tcbSchedEnqueue t - od) q - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (rule mapM_x_inv_wp2, simp) - apply (wp) - apply (wps tcbSchedEnqueue_ct') - apply (wp tcbSchedEnqueue_ksQ) - apply (wps setThreadState_ct') - apply (wp sts_ksQ') - apply (clarsimp) - done +crunch deleteCallerCap + for idle_thread[wp]: "\s. P (ksIdleThread s)" + (wp: crunch_wps) +crunch deleteCallerCap + for sch_act_simple: sch_act_simple + (wp: crunch_wps) +crunch deleteCallerCap + for sch_act_not[wp]: "sch_act_not t" + (wp: crunch_wps) +crunch deleteCallerCap + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) +lemmas deleteCallerCap_typ_ats[wp] = typ_at_lifts [OF deleteCallerCap_typ_at'] -lemma unbindMaybeNotification_ct_not_ksQ: - "\invs' and ct_in_state' simple' and sch_act_sane - and (\s. ksCurThread s \ set (ksReadyQueues s p))\ - unbindMaybeNotification t - \\rv s. ksCurThread s \ set (ksReadyQueues s p)\" - apply (simp add: unbindMaybeNotification_def) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (case_tac "ntfnBoundTCB ntfn", simp, wp, simp+) - apply (rule hoare_pre) - apply wp - apply (wps setBoundNotification.ct) - apply (wp sbn_ksQ) - apply (wps set_ntfn'.ct, wp) - apply clarsimp - done +crunch emptySlot + for ksQ[wp]: "\s. P (ksReadyQueues s p)" + +lemma setEndpoint_sch_act_not_ct[wp]: + "\\s. sch_act_not (ksCurThread s) s\ + setEndpoint ptr val \\_ s. sch_act_not (ksCurThread s) s\" + by (rule hoare_weaken_pre, wps setEndpoint_ct', wp, simp) lemma sbn_ct_in_state'[wp]: "\ct_in_state' P\ setBoundNotification ntfn t \\_. ct_in_state' P\" apply (simp add: ct_in_state'_def) apply (rule hoare_pre) - apply (wps setBoundNotification.ct) - apply wpsimp+ + apply (wps setBoundNotification_ct') + apply (wp sbn_st_tcb', clarsimp) done lemma set_ntfn_ct_in_state'[wp]: "\ct_in_state' P\ setNotification a ntfn \\_. ct_in_state' P\" apply (simp add: ct_in_state'_def) - apply (wp_pre, wps, wp, clarsimp) + apply (rule hoare_pre) + apply (wps setNotification_ksCurThread, wp, clarsimp) done lemma unbindMaybeNotification_ct_in_state'[wp]: diff --git a/proof/refine/ARM/InitLemmas.thy b/proof/refine/ARM/InitLemmas.thy index ae88c1fd5f..cf63858484 100644 --- a/proof/refine/ARM/InitLemmas.thy +++ b/proof/refine/ARM/InitLemmas.thy @@ -23,8 +23,8 @@ declare unless_True[simp] declare maybe_fail_bind_fail[simp] crunch setPriority - for cte_wp_at'[wp]: "cte_wp_at' P p" - and irq_node'[wp]: "\s. P (irq_node' s)" - (simp: crunch_simps wp: crunch_wps) + for cte_wp_at'[wp]: "cte_wp_at' P p" (simp: crunch_simps) +crunch setPriority + for irq_node'[wp]: "\s. P (irq_node' s)" (simp: crunch_simps) end diff --git a/proof/refine/ARM/Init_R.thy b/proof/refine/ARM/Init_R.thy index b1e31d437d..ba7f14c7cf 100644 --- a/proof/refine/ARM/Init_R.thy +++ b/proof/refine/ARM/Init_R.thy @@ -10,7 +10,7 @@ imports begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* This provides a very simple witness that the state relation used in the first refinement proof is @@ -50,17 +50,6 @@ definition zeroed_main_abstract_state :: is_original_cap = (K True), cur_thread = 0, idle_thread = 0, - consumed_time = 0, - cur_time = 0, - cur_sc = 0, - reprogram_timer = False, - scheduler_action = resume_cur_thread, - domain_list = [], - domain_index = 0, - cur_domain = 0, - domain_time = 0, - ready_queues = (\d p. []), - release_queue = [], machine_state = init_machine_state, interrupt_irq_node = (\irq. ucast irq << cte_level_bits), interrupt_states = (K irq_state.IRQInactive), @@ -72,6 +61,13 @@ definition zeroed_extended_state :: where "zeroed_extended_state \ \ work_units_completed_internal = 0, + scheduler_action_internal = resume_cur_thread, + ekheap_internal = K None, + domain_list_internal = [], + domain_index_internal = 0, + cur_domain_internal = 0, + domain_time_internal = 0, + ready_queues_internal = (\_ _. []), cdt_list_internal = K [] \" @@ -100,16 +96,10 @@ definition zeroed_intermediate_state :: ksCurDomain = 0, ksDomainTime = 0, ksReadyQueues = K (TcbQueue None None), - ksReleaseQueue = TcbQueue None None, ksReadyQueuesL1Bitmap = K 0, ksReadyQueuesL2Bitmap = K 0, ksCurThread = 0, ksIdleThread = 0, - ksIdleSC = idle_sc_ptr, - ksConsumedTime = 0, - ksCurTime = 0, - ksCurSc = 0, - ksReprogramTimer = False, ksSchedulerAction = ResumeCurrentThread, ksInterruptState = (InterruptState 0 (K IRQInactive)), ksWorkUnitsCompleted = 0, @@ -126,10 +116,11 @@ 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) - apply (clarsimp simp: release_queue_relation_def) + apply (clarsimp simp: pspace_relation_def pspace_dom_def) + apply (clarsimp simp: ekheap_relation_def) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def queue_end_valid_def + opt_pred_def list_queue_relation_def tcbQueueEmpty_def + prev_queue_head_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/ARM/InterruptAcc_R.thy b/proof/refine/ARM/InterruptAcc_R.thy index 00f0cc8d94..3ab201d6fe 100644 --- a/proof/refine/ARM/InterruptAcc_R.thy +++ b/proof/refine/ARM/InterruptAcc_R.thy @@ -18,8 +18,12 @@ lemma getIRQSlot_corres: ucast_nat_def shiftl_t2n) done +crunch get_irq_slot + for inv[wp]: "P" +crunch getIRQSlot + for inv[wp]: "P" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setIRQState_corres: "irq_state_relation state state' \ @@ -49,25 +53,27 @@ lemma setIRQState_invs[wp]: \\rv. invs'\" apply (simp add: setIRQState_def setInterruptState_def getInterruptState_def) apply (wp dmo_maskInterrupt) - apply (clarsimp simp: invs'_def cur_tcb'_def - Invariants_H.valid_queues_def valid_queues'_def valid_release_queue_def - valid_release_queue'_def valid_dom_schedule'_def - valid_irq_node'_def + apply (clarsimp simp: invs'_def valid_state'_def cur_tcb'_def + valid_idle'_def valid_irq_node'_def valid_arch_state'_def valid_global_refs'_def global_refs'_def valid_machine_state'_def if_unsafe_then_cap'_def ex_cte_cap_to'_def valid_irq_handlers'_def irq_issued'_def cteCaps_of_def valid_irq_masks'_def - bitmapQ_defs valid_queues_no_bitmap_def irqs_masked'_def) - apply fastforce + bitmapQ_defs valid_bitmaps_def) + apply (rule conjI, clarsimp) + apply (clarsimp simp: irqs_masked'_def ct_not_inQ_def) + apply (rule conjI) + apply fastforce + apply (simp add: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) done lemma getIRQSlot_real_cte[wp]: "\invs'\ getIRQSlot irq \real_cte_at'\" apply (simp add: getIRQSlot_def getInterruptState_def locateSlot_conv) apply wp - apply (clarsimp simp: invs'_def valid_irq_node'_def cteSizeBits_def shiftl_t2n - cte_level_bits_def ucast_nat_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_irq_node'_def + cte_level_bits_def ucast_nat_def cteSizeBits_def shiftl_t2n) done lemma getIRQSlot_cte_at[wp]: @@ -89,295 +95,38 @@ lemma work_units_and_irq_state_state_relationI [intro!]: \ state_relation" by (simp add: state_relation_def swp_def) -lemma update_work_units_corres[corres]: - "corres (dc \ dc) \ \ (liftE update_work_units) (liftE (modifyWorkUnits (\op. op + 1)))" - apply (clarsimp simp: update_work_units_def modifyWorkUnits_def) - apply (rule corres_modify) - apply (clarsimp simp: state_relation_def) - done - -lemma getCurTime_corres[corres]: - "corres (=) \ \ (gets cur_time) getCurTime" - apply (simp add: getCurTime_def state_relation_def) - done - -lemma getDomainTime_corres[corres]: - "corres (=) \ \ (gets domain_time) getDomainTime" - apply (simp add: getDomainTime_def state_relation_def) - done - -lemma getCurTime_sp: - "\P\ getCurTime \\rv s. rv = ksCurTime s \ P s\" - apply wpsimp - done - -lemma updateTimeStamp_corres[corres]: - "corres dc \ \ update_time_stamp updateTimeStamp" - apply (clarsimp simp: update_time_stamp_def updateTimeStamp_def setConsumedTime_def) - apply (prop_tac "minBudget = MIN_BUDGET") - apply (clarsimp simp: minBudget_def MIN_BUDGET_def kernelWCETTicks_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurTime_sp]) - apply corresKsimp - apply (rule corres_underlying_split[where r'="(=)"]) - apply (rule corres_guard_imp) - apply (rule corres_machine_op) - apply corresKsimp - apply (wpsimp simp: getCurrentTime_def) - apply simp - apply simp - apply simp - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (clarsimp simp: setCurTime_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF corres_modify]) - apply (clarsimp simp: state_relation_def cdt_relation_def) - apply (clarsimp simp: setConsumedTime_def) - apply (rule_tac Q'="\rv s. rv = ksConsumedTime s" in corres_symb_exec_r) - apply (rule corres_guard_imp) - apply (rule corres_split[OF corres_modify]) - apply (simp add: state_relation_def cdt_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule corres_split[OF getDomainTime_corres]) - apply (rule corres_when, rule refl) - apply (fastforce intro: setDomainTime_corres) - apply (wpsimp simp: getConsumedTime_def)+ - done - -lemma refillSufficient_corres: - "sc_ptr = scPtr - \ corres (=) (valid_objs and pspace_aligned and pspace_distinct - and sc_refills_sc_at (\refills. refills \ []) sc_ptr) - valid_objs' - (get_sc_refill_sufficient sc_ptr consumed) - (refillSufficient scPtr consumed)" - apply (rule corres_cross[where Q' = "sc_at' scPtr", OF sc_at'_cross_rel]) - apply (fastforce simp: obj_at_def is_sc_obj_def valid_obj_def valid_pspace_def sc_at_pred_n_def) - apply (clarsimp simp: get_sc_refill_sufficient_def refillSufficient_def getCurTime_def) - apply (rule corres_guard_imp) - apply (rule corres_symb_exec_r) - apply (rule_tac R="\sc s. sc_refills sc \ []" - and R'= "\sc' s. valid_objs' s \ ko_at' sc' scPtr s \ refills = scRefills sc'" - in corres_split[OF get_sc_corres]) - apply (rename_tac sc sc') - apply clarsimp - apply (prop_tac "r_amount (refill_hd sc) = rAmount (refillHd sc')") - apply (fastforce dest: sc_ko_at_valid_objs_valid_sc' - refill_hd_relation2) - apply (clarsimp simp: refill_sufficient_def sufficientRefills_def refillHd_def - refill_capacity_def refillsCapacity_def MIN_BUDGET_def - minBudget_def kernelWCETTicks_def) - apply (wpsimp wp: get_sc_inv' - simp: getRefills_def)+ - apply (fastforce dest: valid_objs_valid_sched_context_size - simp: sc_at_pred_n_def obj_at_def is_sc_obj_def) - apply (clarsimp simp: obj_at'_def projectKOs) - done - -lemma modifyWorkUnits_valid_objs'[wp]: - "modifyWorkUnits f \valid_objs'\" - apply (clarsimp simp: modifyWorkUnits_def) - apply wpsimp - done - -lemma setWorkUnits_corres[corres]: - "corres dc \ \ reset_work_units (setWorkUnits 0)" - apply (clarsimp simp: reset_work_units_def setWorkUnits_def) - apply (rule corres_modify) - apply (clarsimp simp: state_relation_def) - done - -crunch updateTimeStamp - for valid_objs'[wp]: valid_objs' - -lemma getCurSc_sp: - "\P\ getCurSc \\rv s. rv = ksCurSc s \ P s\" - apply (wpsimp wp: getCurSc_def) - done - -lemma getConsumedTime_sp: - "\P\ getConsumedTime \\rv s. rv = ksConsumedTime s \ P s\" - apply wpsimp - done - -lemma scActive_corres: - "corres (=) (sc_at scPtr and pspace_aligned and pspace_distinct) - \ - (get_sc_active scPtr) - (scActive scPtr)" - apply (rule corres_cross[where Q' = "sc_at' scPtr", OF sc_at'_cross_rel]) - apply (fastforce simp: obj_at_def is_sc_obj_def valid_obj_def valid_pspace_def sc_at_pred_n_def) - apply (corresKsimp corres: get_sc_corres - simp: sc_relation_def get_sc_active_def scActive_def active_sc_def) - done - -lemma getConsumedTime_corres[corres]: - "corres (=) \ \ (gets consumed_time) getConsumedTime" - apply (simp add: getConsumedTime_def state_relation_def) - done - -lemma isCurDomainExpired_corres[corres]: - "corres (=) \ \ (gets is_cur_domain_expired) isCurDomainExpired" - apply (simp add: is_cur_domain_expired_def isCurDomainExpired_def getDomainTime_def - getConsumedTime_def) - apply (clarsimp simp: corres_underlying_def gets_def bind_def get_def return_def - state_relation_def) - done - -lemma get_sc_active_sp: - "\P\ - get_sc_active sc_ptr - \\rv s. P s - \ (\sc n. ko_at (kernel_object.SchedContext sc n) sc_ptr s \ rv = (0 < sc_refill_max sc))\" - apply (simp add: get_sc_active_def) - apply wpsimp - apply (clarsimp simp: obj_at_def active_sc_def) - done - -lemma scActive_sp: - "\P\ - scActive scPtr - \\rv s. P s \ (\sc. ko_at' sc scPtr s \ rv = (0 < scRefillMax sc))\" - apply (simp add: scActive_def) - apply (rule bind_wp_fwd) - apply (rule get_sc_sp') - apply (wp hoare_return_sp) - apply (clarsimp simp: obj_at'_def projectKOs) - done - lemma preemptionPoint_corres: - "corres (dc \ dc) - (\s. valid_objs s \ cur_sc_tcb s \ pspace_aligned s \ pspace_distinct s - \ active_scs_valid s \ valid_machine_time s) - valid_objs' - preemption_point - preemptionPoint" - (is "corres _ ?abs ?conc _ _") - supply if_split[split del] + "corres (dc \ dc) \ \ preemption_point preemptionPoint" apply (simp add: preemption_point_def preemptionPoint_def) - apply (rule corres_splitEE_skip - ; corresKsimp corres: update_work_units_corres - simp: update_work_units_def) - apply (clarsimp simp: bindE_def liftE_def) - apply (rule_tac Q'="\rv s. rv = ksWorkUnitsCompleted s \ ?conc s" in corres_symb_exec_r[rotated]) - apply (wpsimp simp: getWorkUnits_def)+ - apply (rename_tac work_units) - apply (clarsimp simp: OR_choiceE_def whenE_def work_units_limit_reached_def bindE_def liftE_def) - apply (rule_tac Q="\rv s. rv = s \ ?abs s" in corres_symb_exec_l[rotated]) - apply wpsimp+ - apply (rename_tac ex) - apply (rule_tac Q="\s. ex = s \ work_units = work_units_completed s \ ?abs s" - and Q'="\s. work_units = ksWorkUnitsCompleted s \ valid_objs' s" - in stronger_corres_guard_imp[rotated]) - apply (clarsimp simp: state_relation_def) - apply simp - apply (rule_tac Q="\rv s. \rv'' t. rv = (rv'', s) \ rv'' = (workUnitsLimit \ work_units) \ ?abs s" - in corres_symb_exec_l[rotated]) - apply (clarsimp simp: select_f_def mk_ef_def bind_def gets_def exs_valid_def get_def return_def - wrap_ext_bool_det_ext_ext_def) - apply wpsimp - apply (clarsimp simp: select_f_def mk_ef_def bind_def gets_def get_def return_def - work_units_limit_def wrap_ext_bool_det_ext_ext_def Kernel_Config.workUnitsLimit_def) - apply wpsimp - apply (clarsimp simp: select_f_def mk_ef_def bind_def gets_def exs_valid_def get_def return_def - work_units_limit_def wrap_ext_bool_det_ext_ext_def Kernel_Config.workUnitsLimit_def) - apply (case_tac rv; clarsimp) - apply (rename_tac bool state) - apply (rule_tac F="bool = (workUnitsLimit \ work_units) \ ?abs state" in corres_req) - apply simp - apply (rule corres_guard_imp) - apply (rule corres_if3) - apply clarsimp - apply (rule_tac P="?abs" and P'="?conc" in corres_inst) - apply (rule corres_split_skip) - apply (wpsimp simp: reset_work_units_def) - apply (wpsimp simp: setWorkUnits_def) - apply (corresKsimp corres: setWorkUnits_corres) - apply (rule corres_split_skip) - apply wpsimp - apply wpsimp - apply (corresKsimp corres: updateTimeStamp_corres) - apply (rule corres_split_skip) - apply (wpsimp simp: cur_sc_tcb_def) - apply wpsimp - apply (corresKsimp corres: corres_machine_op) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurSc_sp]) - apply (corresKsimp corres: getCurSc_corres) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getConsumedTime_sp]) - apply (corresKsimp corres: getConsumedTime_corres) - apply (clarsimp simp: andM_def ifM_def bind_assoc) - apply (rule corres_underlying_split[rotated 2, OF get_sc_active_sp scActive_sp]) - apply (corresKsimp corres: scActive_corres) - apply (fastforce dest: valid_objs_valid_sched_context_size - simp: cur_sc_tcb_def obj_at_def is_sc_obj_def sc_at_pred_n_def) - apply (clarsimp split: if_split) - apply (intro conjI impI) - apply (rule corres_guard_imp) - apply (rule corres_split[OF refillSufficient_corres]; simp) - apply (rule corres_split[OF isCurDomainExpired_corres]) - apply (clarsimp simp: returnOk_def - split: if_split) - apply wpsimp - apply (wpsimp simp: isCurDomainExpired_def)+ - apply (prop_tac "is_active_sc (cur_sc s) s") - apply (clarsimp simp: obj_at_def vs_all_heap_simps active_sc_def) - apply (frule (1) active_scs_validE) - apply (clarsimp simp: obj_at_def is_sc_obj_def sc_at_pred_n_def vs_all_heap_simps - active_sc_def sc_valid_refills_def rr_valid_refills_def - split: if_splits) - apply simp - apply corresKsimp - apply (fastforce intro: corres_returnOkTT) - apply (clarsimp split: if_split) - apply (clarsimp split: if_split) - done + by (auto simp: preemption_point_def preemptionPoint_def o_def gets_def liftE_def whenE_def getActiveIRQ_def + corres_underlying_def select_def bind_def get_def bindE_def select_f_def modify_def + alternative_def throwError_def returnOk_def return_def lift_def doMachineOp_def split_def + put_def getWorkUnits_def setWorkUnits_def modifyWorkUnits_def do_machine_op_def -lemma updateTimeStamp_inv: - "\updateTimeStamp_independent P; time_state_independent_H P; getCurrentTime_independent_H P; - domain_time_independent_H P\ - \ updateTimeStamp \P\" - apply (simp add: updateTimeStamp_def doMachineOp_def getCurrentTime_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (fastforce simp: time_state_independent_H_def getCurrentTime_independent_H_def in_monad) - apply (rule bind_wp_fwd_skip, wpsimp simp: setCurTime_def) - apply (clarsimp simp: updateTimeStamp_independent_def) - apply (drule_tac x="\_. curTime'" in spec) - apply (drule_tac x=id in spec) - apply fastforce - apply (wpsimp simp: setConsumedTime_def setDomainTime_def getDomainTime_def) - apply (clarsimp simp: updateTimeStamp_independent_def) - apply (drule_tac x=id in spec) - apply (fastforce simp: update_time_stamp_independent_A_def domain_time_independent_H_def) - done + update_work_units_def wrap_ext_bool_det_ext_ext_def work_units_limit_def workUnitsLimit_def + work_units_limit_reached_def OR_choiceE_def reset_work_units_def mk_ef_def + elim: state_relationE) + (* what? *) + (* who says our proofs are not automatic.. *) lemma preemptionPoint_inv: assumes "(\f s. P (ksWorkUnitsCompleted_update f s) = P s)" "irq_state_independent_H P" - "updateTimeStamp_independent P" - "getCurrentTime_independent_H P" - "time_state_independent_H P" - "domain_time_independent_H P" - shows "preemptionPoint \P\" - using assms - apply (simp add: preemptionPoint_def setWorkUnits_def getWorkUnits_def modifyWorkUnits_def - setConsumedTime_def setCurTime_def) - apply (rule validE_valid) - apply (rule bindE_wp_fwd_skip, solves wpsimp)+ - apply (clarsimp simp: whenE_def) - apply (intro conjI impI; (solves wpsimp)?) - apply (rule bindE_wp_fwd_skip, solves wpsimp)+ - apply (rename_tac preempt) - apply (case_tac preempt; clarsimp) - apply (rule bindE_wp_fwd_skip) - apply (wpsimp wp: updateTimeStamp_inv) - apply (rule bindE_wp_fwd_skip, solves wpsimp)+ - apply (wpsimp wp: getRefills_wp hoare_drop_imps - simp: isCurDomainExpired_def getDomainTime_def refillSufficient_def) + shows "\P\ preemptionPoint \\_. P\" using assms + apply (simp add: preemptionPoint_def setWorkUnits_def getWorkUnits_def modifyWorkUnits_def) + apply (wpc + | wp whenE_wp bind_wp [OF _ select_inv] hoare_drop_imps + | simp)+ done -lemma ct_in_state_machine_state_independent[intro!, simp]: - "ct_in_state P (machine_state_update f s) = ct_in_state P s" +lemma ct_running_irq_state_independent[intro!, simp]: + "ct_running (s \machine_state := machine_state s \irq_state := f (irq_state (machine_state s)) \ \) + = ct_running s" + by (simp add: ct_in_state_def) + +lemma ct_idle_irq_state_independent[intro!, simp]: + "ct_idle (s \machine_state := machine_state s \irq_state := f (irq_state (machine_state s)) \ \) + = ct_idle s" by (simp add: ct_in_state_def) lemma typ_at'_irq_state_independent[simp, intro!]: @@ -390,39 +139,28 @@ lemma sch_act_simple_irq_state_independent[intro!, simp]: sch_act_simple s" by (simp add: sch_act_simple_def) -method invs'_independent_method - = (clarsimp simp: irq_state_independent_H_def invs'_def - valid_pspace'_def valid_replies'_def sch_act_wf_def - valid_queues_def sym_refs_def state_refs_of'_def - if_live_then_nonz_cap'_def if_unsafe_then_cap'_def - valid_global_refs'_def - valid_arch_state'_def valid_irq_node'_def - valid_irq_handlers'_def valid_irq_states'_def - irqs_masked'_def bitmapQ_defs valid_queues_no_bitmap_def - valid_queues'_def valid_pde_mappings'_def - pspace_domain_valid_def cur_tcb'_def - valid_machine_state'_def tcb_in_cur_domain'_def ex_cte_cap_wp_to'_def - valid_mdb'_def ct_in_state'_def - valid_release_queue_def valid_release_queue'_def valid_dom_schedule'_def - cong: if_cong option.case_cong) - -lemma - shows invs'_irq_state_independent [simp, intro!]: +lemma invs'_irq_state_independent [simp, intro!]: "invs' (s\ksMachineState := ksMachineState s - \irq_state := f (irq_state (ksMachineState s))\\) - = invs' s" - and invs'_updateTimeStamp_independent [simp, intro!]: - "invs' (s\ksCurTime := f' (ksCurTime s), ksConsumedTime := g (ksConsumedTime s)\) - = invs' s" - and invs'_getCurrentTime_independent [simp, intro!]: - "invs' (s\ksMachineState - := ksMachineState s \last_machine_time - := f'' (last_machine_time (ksMachineState s)) (time_state (ksMachineState s))\\) - = invs' s" - and invs'_time_state_independent [simp, intro!]: - "invs' (s\ksMachineState := ksMachineState s \time_state := f''' (time_state (ksMachineState s))\\) - = invs' s" - by invs'_independent_method+ + \irq_state := f (irq_state (ksMachineState s))\\) = + invs' s" + apply (clarsimp simp: irq_state_independent_H_def invs'_def valid_state'_def + valid_pspace'_def sch_act_wf_def + valid_queues_def sym_refs_def state_refs_of'_def + if_live_then_nonz_cap'_def if_unsafe_then_cap'_def + valid_idle'_def valid_global_refs'_def + valid_arch_state'_def valid_irq_node'_def + valid_irq_handlers'_def valid_irq_states'_def + irqs_masked'_def bitmapQ_defs valid_pde_mappings'_def + pspace_domain_valid_def cur_tcb'_def + valid_machine_state'_def tcb_in_cur_domain'_def + ct_not_inQ_def ct_idle_or_in_cur_domain'_def + cong: if_cong option.case_cong) + apply (rule iffI[rotated]) + apply (clarsimp) + apply (case_tac "ksSchedulerAction s", simp_all) + apply clarsimp + apply (case_tac "ksSchedulerAction s", simp_all) + done lemma preemptionPoint_invs [wp]: "\invs'\ preemptionPoint \\_. invs'\" diff --git a/proof/refine/ARM/Interrupt_R.thy b/proof/refine/ARM/Interrupt_R.thy index 2b763c0d48..62d38ae486 100644 --- a/proof/refine/ARM/Interrupt_R.thy +++ b/proof/refine/ARM/Interrupt_R.thy @@ -14,7 +14,7 @@ begin context Arch begin -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types irqcontrol_invocation @@ -22,11 +22,11 @@ lemmas [crunch_def] = decodeIRQControlInvocation_def performIRQControl_def context begin global_naming global -(*FIXME: arch_split: move up *) +(*FIXME: arch-split: move up *) requalify_types Invocations_H.irqcontrol_invocation -(*FIXME: arch_split*) +(*FIXME: arch-split*) requalify_facts Interrupt_H.decodeIRQControlInvocation_def Interrupt_H.performIRQControl_def @@ -90,7 +90,7 @@ where ex_cte_cap_to' ptr and real_cte_at' ptr and (Not o irq_issued' irq) and K (irq \ maxIRQ))" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma decodeIRQHandlerInvocation_corres: "\ list_all2 cap_relation (map fst caps) (map fst caps'); @@ -129,7 +129,7 @@ lemma decode_irq_handler_valid'[wp]: apply (rule conjI) apply (clarsimp simp: cte_wp_at_ctes_of) apply (drule (1) valid_irq_handlers_ctes_ofD) - apply (simp add: invs'_def) + apply (simp add: invs'_def valid_state'_def) apply (simp add: irq_issued'_def) apply clarsimp done @@ -144,7 +144,8 @@ lemma is_irq_active_corres: split: irqstate.split_asm irq_state.split_asm) done -crunch isIRQActive for inv: "P" +crunch isIRQActive + for inv: "P" lemma isIRQActive_wp: "\\s. \rv. (irq_issued' irq s \ rv) \ Q rv s\ isIRQActive irq \Q\" @@ -295,8 +296,24 @@ crunch "InterruptDecls_H.decodeIRQControlInvocation" for inv[wp]: "P" (simp: crunch_simps) + +(* Levity: added (20090201 10:50:27) *) declare ensureEmptySlot_stronger [wp] +lemma lsfco_real_cte_at'[wp]: + "\valid_objs' and valid_cap' croot\ + lookupSlotForCNodeOp is_src croot ptr depth + \\rv s. real_cte_at' rv s\,-" + apply (simp add: lookupSlotForCNodeOp_def split_def unlessE_def + whenE_def + split del: if_split + cong: if_cong list.case_cong capability.case_cong) + apply (rule hoare_pre) + apply (wp resolveAddressBits_real_cte_at' + | simp + | wpc | wp (once) hoare_drop_imps)+ + done + lemma arch_decode_irq_control_valid'[wp]: "\\s. invs' s \ (\cap \ set caps. s \' cap) \ (\cap \ set caps. \r \ cte_refs' cap (irq_node' s). ex_cte_cap_to' r s) @@ -360,8 +377,8 @@ lemma arch_invokeIRQHandler_corres: lemma invokeIRQHandler_corres: "irq_handler_inv_relation i i' \ - corres dc (einvs and irq_handler_inv_valid i and simple_sched_action and current_time_bounded) - (invs' and irq_handler_inv_valid' i' and sch_act_simple) + corres dc (einvs and irq_handler_inv_valid i) + (invs' and irq_handler_inv_valid' i') (invoke_irq_handler i) (InterruptDecls_H.invokeIRQHandler i')" supply arch_invoke_irq_handler.simps[simp del] @@ -375,11 +392,11 @@ lemma invokeIRQHandler_corres: apply (rule corres_split_nor[OF cap_delete_one_corres]) apply (rule cteInsert_corres, simp+) apply (rule_tac Q'="\rv s. einvs s \ cte_wp_at (\c. c = cap.NullCap) irq_slot s - \ (a, b) \ irq_slot \ current_time_bounded s + \ (a, b) \ irq_slot \ cte_wp_at (is_derived (cdt s) (a, b) cap) (a, b) s" in hoare_post_imp) apply fastforce - apply (wp cap_delete_one_still_derived cap_delete_one_valid_sched)+ + apply (wp cap_delete_one_still_derived)+ apply (strengthen invs_mdb_strengthen') apply wp+ apply (simp add: conj_comms eq_commute) @@ -427,15 +444,13 @@ lemma isnt_irq_handler_strg: lemma invoke_arch_irq_handler_invs'[wp]: "\invs' and irq_handler_inv_valid' i\ ARM_H.invokeIRQHandler i \\rv. invs'\" apply (cases i; wpsimp wp: dmo_maskInterrupt simp: ARM_H.invokeIRQHandler_def) - apply (clarsimp simp: invs'_def valid_dom_schedule'_def valid_irq_masks'_def - valid_machine_state'_def ct_not_inQ_def - ct_in_current_domain_ksMachineState) + apply (clarsimp simp: invs'_def valid_state'_def valid_irq_masks'_def + valid_machine_state'_def ct_not_inQ_def) done lemma invoke_irq_handler_invs'[wp]: - "\invs' and sch_act_simple and irq_handler_inv_valid' i\ - InterruptDecls_H.invokeIRQHandler i - \\rv. invs'\" + "\invs' and irq_handler_inv_valid' i\ + InterruptDecls_H.invokeIRQHandler i \\rv. invs'\" apply (cases i; simp add: Interrupt_H.invokeIRQHandler_def) apply wpsimp apply (wp cteInsert_invs)+ @@ -492,7 +507,7 @@ lemma arch_performIRQControl_corres: apply (clarsimp simp: invs_def valid_state_def valid_pspace_def cte_wp_at_caps_of_state is_simple_cap_def is_cap_simps arch_irq_control_inv_valid_def safe_parent_for_def) - apply (clarsimp simp: invs'_def valid_pspace'_def IRQHandler_valid + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def IRQHandler_valid IRQHandler_valid' is_simple_cap'_def isCap_simps IRQ_def) apply (clarsimp simp: safe_parent_for'_def cte_wp_at_ctes_of) apply (case_tac ctea) @@ -515,7 +530,7 @@ lemma performIRQControl_corres: apply (clarsimp simp: invs_def valid_state_def valid_pspace_def cte_wp_at_caps_of_state is_simple_cap_def is_cap_simps safe_parent_for_def) - apply (clarsimp simp: invs'_def valid_pspace'_def + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def IRQHandler_valid IRQHandler_valid' is_simple_cap'_def isCap_simps) apply (clarsimp simp: safe_parent_for'_def cte_wp_at_ctes_of) @@ -553,10 +568,6 @@ lemma dmo_setIRQTrigger_invs'[wp]: machine_rest_lift_def split_def | wp)+ done -crunch doMachineOp - for ex_cte_cap_wp_to'[wp]: "ex_cte_cap_wp_to' P ptr" - (wp: ex_cte_cap_to'_pres) - lemma arch_invoke_irq_control_invs'[wp]: "\invs' and arch_irq_control_inv_valid' i\ ARM_H.performIRQControl i \\rv. invs'\" apply (simp add: ARM_H.performIRQControl_def) @@ -569,7 +580,7 @@ lemma arch_invoke_irq_control_invs'[wp]: apply (rule conjI, clarsimp simp: cte_wp_at_ctes_of) apply (case_tac ctea) apply (auto dest: valid_irq_handlers_ctes_ofD - simp: invs'_def IRQ_def) + simp: invs'_def valid_state'_def IRQ_def) done lemma invoke_irq_control_invs'[wp]: @@ -582,7 +593,7 @@ lemma invoke_irq_control_invs'[wp]: safe_parent_for'_def sameRegionAs_def3) apply (case_tac ctea) apply (auto dest: valid_irq_handlers_ctes_ofD - simp: invs'_def) + simp: invs'_def valid_state'_def) done lemma getIRQState_corres: @@ -603,8 +614,9 @@ lemma getIRQState_prop: lemma decDomainTime_corres: "corres dc \ \ dec_domain_time decDomainTime" - apply (simp add:dec_domain_time_def corres_underlying_def decDomainTime_def simpler_modify_def) - apply (clarsimp simp:state_relation_def cdt_relation_def) + apply (simp add:dec_domain_time_def corres_underlying_def + decDomainTime_def simpler_modify_def) + apply (clarsimp simp:state_relation_def) done lemma thread_state_case_if: @@ -617,27 +629,98 @@ lemma threadState_case_if: (if state = Structures_H.thread_state.Running then f else g)" by (case_tac state,auto) -lemmas corres_eq_trivial = corres_Id[where f = h and g = h for h, simplified] +lemma ready_qs_distinct_domain_time_update[simp]: + "ready_qs_distinct (domain_time_update f s) = ready_qs_distinct s" + by (clarsimp simp: ready_qs_distinct_def) -lemma doMachineOp_ackDeadlineIRQ_invs'[wp]: - "doMachineOp ackDeadlineIRQ \invs'\" - apply (wpsimp simp: ackDeadlineIRQ_def wp: dmo_invs' ackInterrupt_irq_masks) - apply (drule_tac P4="\m'. underlying_memory m' p = underlying_memory m p" - in use_valid[where P=P and Q="\_. P" for P]) - apply wpsimp+ +lemma timerTick_corres: + "corres dc + (cur_tcb and valid_sched and pspace_aligned and pspace_distinct) invs' + timer_tick timerTick" + apply (simp add: timerTick_def timer_tick_def) + apply (simp add: thread_state_case_if threadState_case_if) + apply (rule_tac Q="cur_tcb and valid_sched and pspace_aligned and pspace_distinct" + and Q'=invs' + in corres_guard_imp) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getCurThread_corres]) + apply simp + apply (rule corres_split[OF getThreadState_corres]) + apply (rename_tac state state') + apply (rule corres_split[where r' = dc]) + apply (rule corres_if[where Q = \ and Q' = \]) + apply (case_tac state,simp_all)[1] + apply (rule_tac r'="(=)" in corres_split[OF ethreadget_corres]) + apply (simp add:etcb_relation_def) + apply (rename_tac ts ts') + apply (rule_tac R="1 < ts" in corres_cases) + apply (simp) + apply (unfold thread_set_time_slice_def) + apply (rule ethread_set_corres, simp+) + apply (clarsimp simp: etcb_relation_def) + apply simp + apply (rule corres_split[OF ethread_set_corres]) + apply (simp add: sch_act_wf_weak etcb_relation_def pred_conj_def)+ + apply (rule corres_split[OF tcbSchedAppend_corres], simp) + apply (rule rescheduleRequired_corres) + apply wp + apply ((wpsimp wp: tcbSchedAppend_sym_heap_sched_pointers + tcbSchedAppend_valid_objs' + | strengthen valid_objs'_valid_tcbs')+)[1] + apply ((wp thread_set_time_slice_valid_queues + | strengthen valid_queues_in_correct_ready_q + valid_queues_ready_qs_distinct)+)[1] + apply ((wpsimp wp: threadSet_sched_pointers threadSet_valid_sched_pointers + threadSet_valid_objs' + | strengthen valid_objs'_valid_tcbs')+)[1] + apply wpsimp+ + apply (rule corres_when, simp) + apply (rule corres_split[OF decDomainTime_corres]) + apply (rule corres_split[OF getDomainTime_corres]) + apply (rule corres_when,simp) + apply (rule rescheduleRequired_corres) + apply (wp hoare_drop_imp)+ + apply (wpsimp simp: dec_domain_time_def) + apply (wpsimp simp: decDomainTime_def) + apply (wpsimp wp: hoare_weak_lift_imp threadSet_timeslice_invs + tcbSchedAppend_valid_objs' + threadSet_pred_tcb_at_state threadSet_weak_sch_act_wf + rescheduleRequired_weak_sch_act_wf)+ + apply (strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct) + apply (wpsimp wp: thread_set_time_slice_valid_queues) + apply ((wpsimp wp: thread_set_time_slice_valid_queues + | strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct)+)[1] + apply wpsimp + apply wpsimp + apply ((wpsimp wp: threadSet_sched_pointers threadSet_valid_sched_pointers + threadSet_valid_objs' + | strengthen valid_objs'_valid_tcbs' + | wp (once) hoare_drop_imp)+)[1] + apply (wpsimp wp: gts_wp gts_wp')+ + apply (clarsimp simp: cur_tcb_def) + apply (frule valid_sched_valid_etcbs) + apply (frule (1) tcb_at_is_etcb_at) + apply (frule valid_sched_valid_queues) + apply (fastforce simp: pred_tcb_at_def obj_at_def valid_sched_weak_strg) + apply (clarsimp simp: etcb_at_def split: option.splits) + apply fastforce + apply (fastforce simp: valid_state'_def ct_not_inQ_def) + apply fastforce done +lemmas corres_eq_trivial = corres_Id[where f = h and g = h for h, simplified] + lemma handleInterrupt_corres: "corres dc - (einvs and current_time_bounded) (invs' and (\s. intStateIRQTable (ksInterruptState s) irq \ IRQInactive)) + (einvs) (invs' and (\s. intStateIRQTable (ksInterruptState s) irq \ IRQInactive)) (handle_interrupt irq) (handleInterrupt irq)" - (is "corres dc ?Q ?P' ?f ?g") + (is "corres dc (einvs) ?P' ?f ?g") apply (simp add: handle_interrupt_def handleInterrupt_def ) apply (rule conjI[rotated]; rule impI) apply (rule corres_guard_imp) apply (rule corres_split[OF getIRQState_corres, - where R="\rv. ?Q" + where R="\rv. einvs" and R'="\rv. invs' and (\s. rv \ IRQInactive)"]) defer apply (wp getIRQState_prop getIRQState_inv do_machine_op_bind doMachineOp_bind | simp add: do_machine_op_bind doMachineOp_bind )+ @@ -652,7 +735,7 @@ lemma handleInterrupt_corres: apply (rule corres_split[OF getIRQSlot_corres]) apply simp apply (rule corres_split[OF get_cap_corres, - where R="\rv. ?Q and valid_cap rv" + where R="\rv. einvs and valid_cap rv" and R'="\rv. invs' and valid_cap' (cteCap rv)"]) apply (rule corres_underlying_split[where r'=dc]) apply (case_tac xb, simp_all add: doMachineOp_return)[1] @@ -666,24 +749,82 @@ lemma handleInterrupt_corres: apply ((wp | simp)+) apply clarsimp apply fastforce - apply (corresKsimp corres: corres_machine_op reprogram_timer_corres - simp: ackDeadlineIRQ_def) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_split[OF timerTick_corres corres_machine_op]) + apply (rule corres_eq_trivial, simp+) + apply wp+ + apply (rule corres_machine_op) + apply (rule corres_eq_trivial, (simp add: no_fail_ackInterrupt)+) + apply wp+ + apply fastforce + apply clarsimp done -crunch rescheduleRequired, tcbSchedAppend +lemma threadSet_ksDomainTime[wp]: + "\\s. P (ksDomainTime s)\ threadSet f ptr \\rv s. P (ksDomainTime s)\" + apply (simp add: threadSet_def setObject_def split_def) + apply (wp crunch_wps | simp add:updateObject_default_def)+ + done + +crunch rescheduleRequired + for ksDomainTime[wp]: "\s. P (ksDomainTime s)" +(simp:tcbSchedEnqueue_def wp:unless_wp) + +crunch tcbSchedAppend for ksDomainTime[wp]: "\s. P (ksDomainTime s)" - (simp: tcbSchedEnqueue_def wp: crunch_wps) +(simp:tcbSchedEnqueue_def wp:unless_wp) + +lemma updateTimeSlice_valid_pspace[wp]: + "\valid_pspace'\ threadSet (tcbTimeSlice_update (\_. ts')) thread + \\r. valid_pspace'\" + apply (wp threadSet_valid_pspace'T) + apply (auto simp:tcb_cte_cases_def) + done + +lemma updateTimeSlice_sch_act_wf[wp]: + "\\s. sch_act_wf (ksSchedulerAction s) s \ + threadSet (tcbTimeSlice_update (\_. ts')) thread + \\r s. sch_act_wf (ksSchedulerAction s) s\" + by (wp threadSet_sch_act,simp) (* catch up tcbSchedAppend to tcbSchedEnqueue, which has these from crunches on possibleSwitchTo *) crunch tcbSchedAppend for irq_handlers'[wp]: valid_irq_handlers' - and irqs_masked'[wp]: irqs_masked' (simp: unless_def tcb_cte_cases_def wp: crunch_wps) - +crunch tcbSchedAppend + for irqs_masked'[wp]: irqs_masked' + (simp: unless_def wp: crunch_wps) crunch tcbSchedAppend for ct[wp]: cur_tcb' (wp: cur_tcb_lift crunch_wps) +lemma timerTick_invs'[wp]: + "timerTick \invs'\" + apply (simp add: timerTick_def) + apply (wpsimp wp: threadSet_invs_trivial threadSet_pred_tcb_no_state + rescheduleRequired_all_invs_but_ct_not_inQ + simp: tcb_cte_cases_def) + apply (rule_tac Q'="\rv. invs'" in hoare_post_imp) + apply (clarsimp simp: invs'_def valid_state'_def) + apply (simp add: decDomainTime_def) + apply wp + apply simp + apply wpc + apply (wp add: threadGet_wp threadSet_cur threadSet_timeslice_invs + rescheduleRequired_all_invs_but_ct_not_inQ + hoare_vcg_imp_lift threadSet_ct_idle_or_in_cur_domain')+ + apply (rule hoare_strengthen_post[OF tcbSchedAppend_all_invs_but_ct_not_inQ']) + apply (wpsimp simp: invs'_def valid_state'_def valid_pspace'_def sch_act_wf_weak)+ + apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post) + apply (wpsimp wp: threadSet_pred_tcb_no_state threadSet_tcbDomain_triv + threadSet_valid_objs' threadSet_timeslice_invs)+ + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + apply (wpsimp simp: invs'_def valid_state'_def valid_pspace'_def sch_act_wf_weak)+ + apply (wp gts_wp')+ + apply (auto simp: invs'_def st_tcb_at'_def obj_at'_def valid_state'_def cong: conj_cong) + done + lemma resetTimer_invs'[wp]: "\invs'\ doMachineOp resetTimer \\_. invs'\" apply (wp dmo_invs' no_irq no_irq_resetTimer) @@ -697,7 +838,7 @@ lemma resetTimer_invs'[wp]: done lemma dmo_ackInterrupt[wp]: - "\invs'\ doMachineOp (ackInterrupt irq) \\y. invs'\" +"\invs'\ doMachineOp (ackInterrupt irq) \\y. invs'\" apply (wp dmo_invs' no_irq no_irq_ackInterrupt) apply safe apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" @@ -707,8 +848,9 @@ lemma dmo_ackInterrupt[wp]: done lemma hint_invs[wp]: - "handleInterrupt irq \invs'\" - apply (simp add: handleInterrupt_def getSlotCap_def cong: irqstate.case_cong) + "\invs'\ InterruptDecls_H.handleInterrupt irq \\rv. invs'\" + apply (simp add: Interrupt_H.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 )+ @@ -720,6 +862,11 @@ lemma hint_invs[wp]: apply (assumption)+ done + +crunch timerTick + for st_tcb_at'[wp]: "st_tcb_at' P t" + (wp: threadSet_pred_tcb_no_state) + end end diff --git a/proof/refine/ARM/InvariantUpdates_H.thy b/proof/refine/ARM/InvariantUpdates_H.thy index d1fec7fe1a..1e6db0685c 100644 --- a/proof/refine/ARM/InvariantUpdates_H.thy +++ b/proof/refine/ARM/InvariantUpdates_H.thy @@ -38,10 +38,29 @@ lemma invs'_machine: proof - show ?thesis apply (cases "ksSchedulerAction s") - apply (simp_all add: invs'_def cur_tcb'_def ct_in_state'_def - ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def - valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs - vms ct_not_inQ_def valid_dom_schedule'_def + apply (simp_all add: invs'_def valid_state'_def cur_tcb'_def ct_in_state'_def + ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def + valid_bitmaps_def bitmapQ_defs + vms ct_not_inQ_def + state_refs_of'_def ps_clear_def + valid_irq_node'_def mask + cong: option.case_cong) + done +qed + +lemma invs_no_cicd'_machine: + assumes mask: "irq_masks (f (ksMachineState s)) = + irq_masks (ksMachineState s)" + assumes vms: "valid_machine_state' (ksMachineState_update f s) = + valid_machine_state' s" + shows "invs_no_cicd' (ksMachineState_update f s) = invs_no_cicd' s" +proof - + show ?thesis + apply (cases "ksSchedulerAction s") + apply (simp_all add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def + cur_tcb'_def ct_in_state'_def ct_idle_or_in_cur_domain'_def + tcb_in_cur_domain'_def valid_bitmaps_def bitmapQ_defs + vms ct_not_inQ_def state_refs_of'_def ps_clear_def valid_irq_node'_def mask cong: option.case_cong) @@ -77,6 +96,14 @@ lemma valid_tcb'_tcbFault_update[simp]: "valid_tcb' tcb s \ valid_tcb' (tcbFault_update f tcb) s" by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) +lemma valid_tcb'_tcbTimeSlice_update[simp]: + "valid_tcb' (tcbTimeSlice_update f tcb) s = valid_tcb' tcb s" + by (simp add:valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + +lemma valid_bitmaps_ksSchedulerAction_update[simp]: + "valid_bitmaps (ksSchedulerAction_update f s) = valid_bitmaps s" + by (simp add: valid_bitmaps_def bitmapQ_defs) + lemma ex_cte_cap_wp_to'_gsCNodes_update[simp]: "ex_cte_cap_wp_to' P p (gsCNodes_update f s') = ex_cte_cap_wp_to' P p s'" by (simp add: ex_cte_cap_wp_to'_def) @@ -130,10 +157,6 @@ lemma valid_bitmaps_ksWorkUnitsCompleted[simp]: "valid_bitmaps (ksWorkUnitsCompleted_update f s) = valid_bitmaps s" by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_queues_ksReprogramTimer[simp]: - "valid_queues (ksReprogramTimer_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs) - lemma valid_irq_node'_ksCurDomain[simp]: "valid_irq_node' w (ksCurDomain_update f s) = valid_irq_node' w s" by (simp add: valid_irq_node'_def) @@ -154,58 +177,6 @@ lemma valid_irq_node'_ksWorkUnitsCompleted[simp]: "valid_irq_node' w (ksWorkUnitsCompleted_update f s) = valid_irq_node' w s" by (simp add: valid_irq_node'_def) -lemma valid_irq_node'_ksReprogramTimer[simp]: - "valid_irq_node' w (ksReprogramTimer_update f s) = valid_irq_node' w s" - by (simp add: valid_irq_node'_def) - -lemma valid_release_queue_ksWorkUnitsCompleted[simp]: - "valid_release_queue (ksWorkUnitsCompleted_update f s) = valid_release_queue s" - by (simp add: valid_release_queue_def) - -lemma valid_release_queue_ksReprogramTimer[simp]: - "valid_release_queue (ksReprogramTimer_update f s) = valid_release_queue s" - by (simp add: valid_release_queue_def) - -lemma valid_release_queue_ksDomainTime[simp]: - "valid_release_queue (ksDomainTime_update f s) = valid_release_queue s" - by (simp add: valid_release_queue_def) - -lemma valid_release_queue_ksCurDomain[simp]: - "valid_release_queue (ksCurDomain_update f s) = valid_release_queue s" - by (simp add: valid_release_queue_def) - -lemma valid_release_queue_ksDomScheduleIdx[simp]: - "valid_release_queue (ksDomScheduleIdx_update f s) = valid_release_queue s" - by (simp add: valid_release_queue_def) - -lemma valid_release_queue_ksSchedulerAction[simp]: - "valid_release_queue (ksSchedulerAction_update f s) = valid_release_queue s" - by (simp add: valid_release_queue_def) - -lemma valid_release_queue'_ksSchedulerAction[simp]: - "valid_release_queue' (ksSchedulerAction_update f s) = valid_release_queue' s" - by (simp add: valid_release_queue'_def) - -lemma valid_release_queue'_ksWorkUnitsCompleted[simp]: - "valid_release_queue' (ksWorkUnitsCompleted_update f s) = valid_release_queue' s" - by (simp add: valid_release_queue'_def) - -lemma valid_release_queue'_ksReprogramTimer[simp]: - "valid_release_queue' (ksReprogramTimer_update f s) = valid_release_queue' s" - by (simp add: valid_release_queue'_def) - -lemma valid_release_queue'_ksDomainTime[simp]: - "valid_release_queue' (ksDomainTime_update f s) = valid_release_queue' s" - by (simp add: valid_release_queue'_def) - -lemma valid_release_queue'_ksCurDomain[simp]: - "valid_release_queue' (ksCurDomain_update f s) = valid_release_queue' s" - by (simp add: valid_release_queue'_def) - -lemma valid_release_queue'_ksDomScheduleIdx[simp]: - "valid_release_queue' (ksDomScheduleIdx_update f s) = valid_release_queue' s" - by (simp add: valid_release_queue'_def) - lemma ex_cte_cap_wp_to_work_units[simp]: "ex_cte_cap_wp_to' P slot (ksWorkUnitsCompleted_update f s) = ex_cte_cap_wp_to' P slot s" @@ -287,23 +258,18 @@ lemma ct_in_state_ksSched[simp]: apply auto done -lemma invs'_wu[simp]: +lemma invs'_wu [simp]: "invs' (ksWorkUnitsCompleted_update f s) = invs' s" - apply (simp add: invs'_def cur_tcb'_def valid_queues_def - valid_queues'_def valid_release_queue_def valid_release_queue'_def - valid_irq_node'_def valid_machine_state'_def ct_not_inQ_def - ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def bitmapQ_defs - valid_queues_no_bitmap_def valid_dom_schedule'_def) + apply (simp add: invs'_def cur_tcb'_def valid_state'_def valid_bitmaps_def + valid_irq_node'_def valid_machine_state'_def + ct_not_inQ_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def + bitmapQ_defs) done lemma valid_arch_state'_interrupt[simp]: "valid_arch_state' (ksInterruptState_update f s) = valid_arch_state' s" by (simp add: valid_arch_state'_def cong: option.case_cong) -lemma valid_inQ_queues_ksSchedulerAction_update[simp]: - "valid_inQ_queues (ksSchedulerAction_update f s) = valid_inQ_queues s" - by (simp add: valid_inQ_queues_def) - lemma valid_bitmapQ_ksSchedulerAction_upd[simp]: "valid_bitmapQ (ksSchedulerAction_update f s) = valid_bitmapQ s" unfolding bitmapQ_defs by simp @@ -349,15 +315,8 @@ lemma sch_act_simple_ksReadyQueuesL2Bitmap[simp]: lemma ksDomainTime_invs[simp]: "invs' (ksDomainTime_update f s) = invs' s" - by (simp add: invs'_def cur_tcb'_def - valid_release_queue_def valid_release_queue'_def - valid_machine_state'_def ct_not_inQ_def - ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def valid_dom_schedule'_def) - -lemma ksSchedulerAction_invs'[simp]: - "invs' (ksSchedulerAction_update f s) = invs' s" - by (auto simp: invs'_def valid_release_queue_def valid_release_queue'_def - valid_machine_state'_def valid_irq_node'_def valid_dom_schedule'_def) + by (simp add: invs'_def valid_state'_def cur_tcb'_def ct_not_inQ_def ct_idle_or_in_cur_domain'_def + tcb_in_cur_domain'_def valid_machine_state'_def bitmapQ_defs) lemma valid_machine_state'_ksDomainTime[simp]: "valid_machine_state' (ksDomainTime_update f s) = valid_machine_state' s" @@ -385,98 +344,7 @@ lemma ct_not_inQ_update_stt[simp]: lemma invs'_update_cnt[elim!]: "invs' s \ invs' (s\ksSchedulerAction := ChooseNewThread\)" - by (clarsimp simp: invs'_def cur_tcb'_def valid_dom_schedule'_def - valid_release_queue_def valid_release_queue'_def - valid_irq_node'_def valid_machine_state'_def ct_not_inQ_def - ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) - -lemma ksReprogramTimer_update_misc[simp]: - "\f. valid_machine_state' (ksReprogramTimer_update f s) = valid_machine_state' s" - "\f. ct_not_inQ (ksReprogramTimer_update f s) = ct_not_inQ s" - "\f. ct_idle_or_in_cur_domain' (ksReprogramTimer_update f s) = ct_idle_or_in_cur_domain' s" - "\f. cur_tcb' (ksReprogramTimer_update f s) = cur_tcb' s" - apply (clarsimp simp: valid_machine_state'_def ct_not_inQ_def ct_idle_or_in_cur_domain'_def - tcb_in_cur_domain'_def cur_tcb'_def)+ - done - -lemma valid_machine_state'_ksReleaseQueue[simp]: - "valid_machine_state' (ksReleaseQueue_update f s) = valid_machine_state' s" - unfolding valid_machine_state'_def - by simp - -lemma ct_idle_or_in_cur_domain'_ksReleaseQueue[simp]: - "ct_idle_or_in_cur_domain' (ksReleaseQueue_update f s) = ct_idle_or_in_cur_domain' s" - unfolding ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def - by simp - -lemma valid_inQ_queues_updates[simp]: - "\f. valid_inQ_queues (ksReprogramTimer_update f s) = valid_inQ_queues s" - "\f. valid_inQ_queues (ksReleaseQueue_update f s) = valid_inQ_queues s" - by (auto simp: valid_inQ_queues_def) - -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) - -lemma valid_irq_node'_ksReleaseQueue_upd[simp]: - "valid_irq_node' (irq_node' s) (ksReleaseQueue_update f s) = valid_irq_node' (irq_node' s) s" - by (simp add: valid_irq_node'_def) - -lemma cur_tcb'_ksReleaseQueue_upd[simp]: - "cur_tcb' (ksReleaseQueue_update f s) = cur_tcb' s" - by (simp add: cur_tcb'_def) - -lemma valid_queues_ksReleaseQueue_upd[simp]: - "valid_queues (ksReleaseQueue_update f s) = valid_queues s" - by (simp add: valid_queues_def valid_queues_no_bitmap_def valid_bitmapQ_def - bitmapQ_def bitmapQ_no_L1_orphans_def bitmapQ_no_L2_orphans_def) - -lemma valid_queues'_ksReleaseQueue_upd[simp]: - "valid_queues' (ksReleaseQueue_update f s) = valid_queues' s" - by (simp add: valid_queues'_def) - -lemma sch_act_sane_ksReprogramTimer[simp]: - "sch_act_sane (ksReprogramTimer_update f s) = sch_act_sane s" - by (simp add: sch_act_sane_def) - -lemma valid_obj'_scPeriod_update[simp]: - "valid_obj' (KOSchedContext (scPeriod_update (\_. period) sc')) = valid_obj' (KOSchedContext sc')" - by (fastforce simp: valid_obj'_def valid_sched_context'_def valid_sched_context_size'_def objBits_simps) - -lemma valid_sched_context_size'_scReply_update[simp]: - "valid_sched_context_size' (scReply_update f sc) = valid_sched_context_size' sc" - by (clarsimp simp: valid_sched_context_size'_def objBits_simps) - -lemma valid_sched_context'_scBadge_update[simp]: - "valid_sched_context' (scBadge_update f ko) s = valid_sched_context' ko s" - by (clarsimp simp: valid_sched_context'_def) - -lemma valid_sched_context_size'_scBadge_update[simp]: - "valid_sched_context_size' (scBadge_update f sc) = valid_sched_context_size' sc" - by (clarsimp simp: valid_sched_context_size'_def objBits_simps) - -lemma valid_sched_context'_scSporadic_update[simp]: - "valid_sched_context' (scSporadic_update f ko) s = valid_sched_context' ko s" - by (clarsimp simp: valid_sched_context'_def) - -lemma valid_sched_context_size'_scSporadic_update[simp]: - "valid_sched_context_size' (scSporadic_update f sc) = valid_sched_context_size' sc" - by (clarsimp simp: valid_sched_context_size'_def objBits_simps) - -lemma valid_tcb_yield_to_update[elim!]: - "valid_tcb tp tcb s \ sc_at scp s \ valid_tcb tp (tcb_yield_to_update (\_. Some scp) tcb) s" - by (auto simp: valid_tcb_def tcb_cap_cases_def) - -lemma valid_ipc_buffer_ptr'_ks_updates[simp]: - "valid_ipc_buffer_ptr' buf (ksSchedulerAction_update f s) = valid_ipc_buffer_ptr' buf s" - "valid_ipc_buffer_ptr' buf (ksReprogramTimer_update g s) = valid_ipc_buffer_ptr' buf s" - "valid_ipc_buffer_ptr' buf (ksReleaseQueue_update h s) = valid_ipc_buffer_ptr' buf s" - by (simp add: valid_ipc_buffer_ptr'_def)+ + by (clarsimp simp: invs'_def valid_state'_def valid_irq_node'_def cur_tcb'_def + ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def bitmapQ_defs) -end +end \ No newline at end of file diff --git a/proof/refine/ARM/Invariants_H.thy b/proof/refine/ARM/Invariants_H.thy index 52ea6db418..6998f10290 100644 --- a/proof/refine/ARM/Invariants_H.thy +++ b/proof/refine/ARM/Invariants_H.thy @@ -7,16 +7,12 @@ theory Invariants_H imports LevityCatch + "AInvs.Deterministic_AI" "AInvs.AInvs" "Lib.AddUpdSimps" - ArchMove_R - "Lib.Heap_List" + Lib.Heap_List begin -(* FIXME: this should go somewhere in spec *) -translations - (type) "'a kernel" <=(type) "kernel_state \ ('a \ kernel_state) set \ bool" - context Arch begin lemmas [crunch_def] = deriveCap_def finaliseCap_def @@ -51,7 +47,7 @@ lemma le_maxDomain_eq_less_numDomains: by (auto simp: Kernel_Config.numDomains_def maxDomain_def word_le_nat_alt) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) \ \---------------------------------------------------------------------------\ section "Invariants on Executable Spec" @@ -66,18 +62,9 @@ definition definition "ko_wp_at' P p s \ \ko. ksPSpace s p = Some ko \ is_aligned p (objBitsKO ko) \ P ko \ - ps_clear p (objBitsKO ko) s \ objBitsKO ko < word_bits" - -lemma valid_sz_simps: - "objBitsKO ko < word_bits = - (case ko of - KOSchedContext sc \ minSchedContextBits + scSize sc < word_bits - | _ \ True)" - by (cases ko; - clarsimp simp: objBits_def objBitsKO_def word_size_def archObjSize_def pageBits_def word_bits_def - tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def cteSizeBits_def word_size - pdeBits_def pteBits_def wordSizeCase_def wordBits_def replySizeBits_def - split: arch_kernel_object.splits) + ps_clear p (objBitsKO ko) s" + + definition obj_at' :: "('a::pspace_storable \ bool) \ word32 \ kernel_state \ bool" @@ -91,17 +78,13 @@ where "typ_at' T \ ko_wp_at' (\ko. koTypeOf ko = T)" abbreviation - "ep_at' \ obj_at' (\_ :: endpoint. True)" -abbreviation - "ntfn_at' \ obj_at' (\_:: notification. True)" + "ep_at' \ obj_at' ((\x. True) :: endpoint \ bool)" abbreviation - "tcb_at' \ obj_at' (\_:: tcb. True)" + "ntfn_at' \ obj_at' ((\x. True) :: Structures_H.notification \ bool)" abbreviation - "real_cte_at' \ obj_at' (\_ :: cte. True)" + "tcb_at' \ obj_at' ((\x. True) :: tcb \ bool)" abbreviation - "sc_at' \ obj_at' (\_ :: sched_context. True)" -abbreviation - "reply_at' \ obj_at' (\_ :: reply. True)" + "real_cte_at' \ obj_at' ((\x. True) :: cte \ bool)" abbreviation "ko_at' v \ obj_at' (\k. k = v)" @@ -112,60 +95,49 @@ abbreviation "pte_at' \ typ_at' (ArchT PTET)" end - record itcb' = - itcbState :: thread_state - itcbIPCBuffer :: vptr - itcbBoundNotification :: "word32 option" - itcbPriority :: priority - itcbFault :: "fault option" - itcbMCP :: priority - itcbSchedContext :: "obj_ref option" - itcbYieldTo :: "obj_ref option" - -definition tcb_to_itcb' :: "tcb \ itcb'" where - "tcb_to_itcb' tcb \ \ itcbState = tcbState tcb, - itcbIPCBuffer = tcbIPCBuffer tcb, - itcbBoundNotification = tcbBoundNotification tcb, - itcbPriority = tcbPriority tcb, - itcbFault = tcbFault tcb, - itcbMCP = tcbMCP tcb, - itcbSchedContext = tcbSchedContext tcb, - itcbYieldTo = tcbYieldTo tcb\" - -lemma itcbState[simp]: - "itcbState (tcb_to_itcb' tcb) = tcbState tcb" + itcbState :: thread_state + itcbFaultHandler :: cptr + itcbIPCBuffer :: vptr + itcbBoundNotification :: "word32 option" + itcbPriority :: priority + itcbFault :: "fault option" + itcbTimeSlice :: nat + itcbMCP :: priority + +definition "tcb_to_itcb' tcb \ \ itcbState = tcbState tcb, + itcbFaultHandler = tcbFaultHandler tcb, + itcbIPCBuffer = tcbIPCBuffer tcb, + itcbBoundNotification = tcbBoundNotification tcb, + itcbPriority = tcbPriority tcb, + itcbFault = tcbFault tcb, + itcbTimeSlice = tcbTimeSlice tcb, + itcbMCP = tcbMCP tcb\" + +lemma [simp]: "itcbState (tcb_to_itcb' tcb) = tcbState tcb" by (auto simp: tcb_to_itcb'_def) -lemma itcbIPCBuffer[simp]: - "itcbIPCBuffer (tcb_to_itcb' tcb) = tcbIPCBuffer tcb" +lemma [simp]: "itcbFaultHandler (tcb_to_itcb' tcb) = tcbFaultHandler tcb" by (auto simp: tcb_to_itcb'_def) -lemma itcbBoundNotification[simp]: - "itcbBoundNotification (tcb_to_itcb' tcb) = tcbBoundNotification tcb" +lemma [simp]: "itcbIPCBuffer (tcb_to_itcb' tcb) = tcbIPCBuffer tcb" by (auto simp: tcb_to_itcb'_def) -lemma itcbPriority[simp]: - "itcbPriority (tcb_to_itcb' tcb) = tcbPriority tcb" +lemma [simp]: "itcbBoundNotification (tcb_to_itcb' tcb) = tcbBoundNotification tcb" by (auto simp: tcb_to_itcb'_def) -lemma itcbFault[simp]: - "itcbFault (tcb_to_itcb' tcb) = tcbFault tcb" +lemma [simp]: "itcbPriority (tcb_to_itcb' tcb) = tcbPriority tcb" by (auto simp: tcb_to_itcb'_def) -lemma itcbMCP[simp]: - "itcbMCP (tcb_to_itcb' tcb) = tcbMCP tcb" +lemma [simp]: "itcbFault (tcb_to_itcb' tcb) = tcbFault tcb" by (auto simp: tcb_to_itcb'_def) -lemma itcbSchedContext[simp]: - "itcbSchedContext (tcb_to_itcb' tcb) = tcbSchedContext tcb" +lemma [simp]: "itcbTimeSlice (tcb_to_itcb' tcb) = tcbTimeSlice tcb" by (auto simp: tcb_to_itcb'_def) -lemma itcbYieldTo[simp]: - "itcbYieldTo (tcb_to_itcb' tcb) = tcbYieldTo tcb" +lemma [simp]: "itcbMCP (tcb_to_itcb' tcb) = tcbMCP tcb" by (auto simp: tcb_to_itcb'_def) - definition pred_tcb_at' :: "(itcb' \ 'a) \ ('a \ bool) \ word32 \ kernel_state \ bool" where @@ -173,18 +145,12 @@ where abbreviation "st_tcb_at' \ pred_tcb_at' itcbState" abbreviation "bound_tcb_at' \ pred_tcb_at' itcbBoundNotification" -abbreviation "bound_sc_tcb_at' \ pred_tcb_at' itcbSchedContext" -abbreviation "bound_yt_tcb_at' \ pred_tcb_at' itcbYieldTo" abbreviation "mcpriority_tcb_at' \ pred_tcb_at' itcbMCP" lemma st_tcb_at'_def: "st_tcb_at' test \ obj_at' (test \ tcbState)" by (simp add: pred_tcb_at'_def o_def) -definition - active_sc_at' :: "word32 \ kernel_state \ bool" -where - "active_sc_at' \ obj_at' (\ko :: sched_context. 0 < scRefillMax ko)" text \cte with property at\ definition @@ -193,105 +159,6 @@ definition abbreviation "cte_at' \ cte_wp_at' \" -text \replyNext aliases\ - -abbreviation - "replySC \ \r. getHeadScPtr (replyNext r)" - -abbreviation - "replyNext_of \ \r. getReplyNextPtr (replyNext r)" - -lemma getReplyNextPtr_None[simp]: - "getReplyNextPtr None = None" by (simp add: getReplyNextPtr_def) - -lemma getHeadScPtr_None[simp]: - "getHeadScPtr None = None" by (simp add: getHeadScPtr_def) - -lemma getReplyNextPtr_Some_Next[simp]: - "getReplyNextPtr (Some (Next rn)) = Some rn" by (simp add: getReplyNextPtr_def) - -lemma getHeadScPtr_Some_Head[simp]: - "getHeadScPtr (Some (Head sc)) = Some sc" by (simp add: getHeadScPtr_def) - -lemma theReplyNextPtr_Some_Next[simp]: - "theReplyNextPtr (Some (Next rn)) = rn" by (simp add: theReplyNextPtr_def) - -lemma theHeadScPtr_Some_Head[simp]: - "theHeadScPtr (Some (Head sc)) = sc" by (simp add: theHeadScPtr_def) - -lemma getReplyNextPtr_Some_iff[iff]: - "(getReplyNextPtr x) = (Some rn) \ x = Some (Next rn)" - by (cases x; clarsimp simp: getReplyNextPtr_def split: reply_next.split) - -lemma getHeadScPtr_Some_iff[iff]: - "(getHeadScPtr x) = (Some rn) \ x = Some (Head rn)" - by (cases x; clarsimp simp: getHeadScPtr_def split: reply_next.split) - -lemma getReplyNextPtr_None_iff: - "(getReplyNextPtr x) = None \ (\rn. x \ Some (Next rn))" - by (cases x; clarsimp simp: getReplyNextPtr_def split: reply_next.split) - -lemma getHeadScPtr_None_iff: - "(getHeadScPtr x) = None \ (\rn. x \ Some (Head rn))" - by (cases x; clarsimp simp: getHeadScPtr_def split: reply_next.split) - -lemma replyNext_None_iff: - "replyNext r = None \ replyNext_of r = None \ replySC r = None" - apply (cases "replyNext r"; clarsimp) - apply (case_tac a; clarsimp) - done - -lemma getReplyNextPtr_Head_None[simp]: - "getReplyNextPtr (Some (Head rn)) = None" by (simp add: getReplyNextPtr_def) - -lemma getHeadScPtr_Next_None[simp]: - "getHeadScPtr (Some (Next sc)) = None" by (simp add: getHeadScPtr_def) - -text \Heap projections:\ -abbreviation reply_of' :: "kernel_object \ reply option" where - "reply_of' \ projectKO_opt" - -abbreviation replies_of' :: "kernel_state \ obj_ref \ reply option" where - "replies_of' s \ ksPSpace s |> reply_of'" - -abbreviation replyNexts_of :: "kernel_state \ obj_ref \ obj_ref option" where - "replyNexts_of s \ replies_of' s |> replyNext_of" - -abbreviation replyPrevs_of :: "kernel_state \ obj_ref \ obj_ref option" where - "replyPrevs_of s \ replies_of' s |> replyPrev" - -abbreviation replyTCBs_of :: "kernel_state \ obj_ref \ obj_ref option" where - "replyTCBs_of s \ replies_of' s |> replyTCB" - -abbreviation replySCs_of :: "kernel_state \ obj_ref \ obj_ref option" where - "replySCs_of s \ replies_of' s |> replySC" - -abbreviation sc_of' :: "kernel_object \ sched_context option" where - "sc_of' \ projectKO_opt" - -abbreviation scs_of' :: "kernel_state \ obj_ref \ sched_context option" where - "scs_of' s \ ksPSpace s |> sc_of'" - -abbreviation scReplies_of :: "kernel_state \ obj_ref \ obj_ref option" where - "scReplies_of s \ scs_of' s |> scReply" - -abbreviation tcb_of' :: "kernel_object \ tcb option" where - "tcb_of' \ projectKO_opt" - -abbreviation tcbs_of' :: "kernel_state \ obj_ref \ tcb option" where - "tcbs_of' s \ ksPSpace s |> tcb_of'" - -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 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 tcb_of' :: "kernel_object \ tcb option" where "tcb_of' \ projectKO_opt" @@ -317,169 +184,137 @@ where 64 \ (tcbIPCBufferFrame, tcbIPCBufferFrame_update) ]" definition - tcb_cte_cases :: "word32 \ ((tcb \ cte) \ ((cte \ cte) \ tcb \ tcb))" where - "tcb_cte_cases \ [ 0 \ (tcbCTable, tcbCTable_update), - 0x10 \ (tcbVTable, tcbVTable_update), - 0x20 \ (tcbIPCBufferFrame, tcbIPCBufferFrame_update), - 0x30 \ (tcbFaultHandler, tcbFaultHandler_update), - 0x40 \ (tcbTimeoutHandler, tcbTimeoutHandler_update) - ]" - -definition - max_ipc_words :: word32 where + max_ipc_words :: word32 +where "max_ipc_words \ capTransferDataSize + msgMaxLength + msgMaxExtraCaps + 2" -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 - Running => {} - | Inactive => {} - | Restart => {} - | (BlockedOnReply r) => if bound r then {(the r, TCBReply)} else {} - | IdleThreadState => {} - | (BlockedOnReceive x _ r) => if bound r then {(x, TCBBlockedRecv), (the r, TCBReply)} - else {(x, TCBBlockedRecv)} - | (BlockedOnSend x _ _ _ _) => {(x, TCBBlockedSend)} - | (BlockedOnNotification x) => {(x, TCBSignal)}" +definition + tcb_st_refs_of' :: "Structures_H.thread_state \ (word32 \ reftype) set" +where + "tcb_st_refs_of' z \ case z of (Running) => {} + | (Inactive) => {} + | (Restart) => {} + | (BlockedOnReceive x a) => {(x, TCBBlockedRecv)} + | (BlockedOnSend x a b c d) => {(x, TCBBlockedSend)} + | (BlockedOnNotification x) => {(x, TCBSignal)} + | (BlockedOnReply) => {} + | (IdleThreadState) => {}" definition - tcb_bound_refs' :: - "word32 option \ word32 option \ word32 option \ ref_set" where - "tcb_bound_refs' ntfn sc yt \ get_refs TCBBound ntfn - \ get_refs TCBSchedContext sc - \ get_refs TCBYieldTo yt" - -definition refs_of_tcb' :: "tcb \ ref_set" where - "refs_of_tcb' tcb \ - tcb_st_refs_of' (tcbState tcb) - \ tcb_bound_refs' (tcbBoundNotification tcb) (tcbSchedContext tcb) (tcbYieldTo tcb)" - -definition ep_q_refs_of' :: "endpoint \ ref_set" where + ep_q_refs_of' :: "Structures_H.endpoint \ (word32 \ reftype) set" +where "ep_q_refs_of' x \ case x of - IdleEP => {} - | (RecvEP q) => set q \ {EPRecv} - | (SendEP q) => set q \ {EPSend}" + IdleEP => {} + | (RecvEP q) => set q \ {EPRecv} + | (SendEP q) => set q \ {EPSend}" -definition ntfn_q_refs_of' :: "ntfn \ ref_set" where - "ntfn_q_refs_of' x \ case x of - IdleNtfn => {} - | (WaitingNtfn q) => set q \ {NTFNSignal} - | (ActiveNtfn b) => {}" +definition + ntfn_q_refs_of' :: "Structures_H.ntfn \ (word32 \ reftype) set" +where + "ntfn_q_refs_of' x \ case x of IdleNtfn => {} + | (WaitingNtfn q) => set q \ {NTFNSignal} + | (ActiveNtfn b) => {}" -definition ntfn_bound_refs' :: "word32 option \ ref_set" where +definition + ntfn_bound_refs' :: "word32 option \ (word32 \ 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)" - -definition refs_of_sc' :: "sched_context \ ref_set" where - "refs_of_sc' sc \ get_refs SCNtfn (scNtfn sc) - \ get_refs SCTcb (scTCB sc) - \ get_refs SCYieldFrom (scYieldFrom sc) - \ get_refs SCReply (scReply sc)" - -definition refs_of_reply' :: "reply \ ref_set" where - "refs_of_reply' r \ get_refs ReplySchedContext (replySC r) - \ get_refs ReplyTCB (replyTCB r)" - -definition list_refs_of_reply' :: "reply \ ref_set" where - "list_refs_of_reply' r = get_refs ReplyNext (replyNext_of r) \ get_refs ReplyPrev (replyPrev r)" - -abbreviation list_refs_of_replies_opt' :: "kernel_state \ obj_ref \ ref_set option" where - "list_refs_of_replies_opt' s \ replies_of' s ||> list_refs_of_reply'" - -abbreviation list_refs_of_replies' :: "kernel_state \ obj_ref \ ref_set" where - "list_refs_of_replies' s \ map_set (list_refs_of_replies_opt' s)" - -lemmas list_refs_of_replies'_def = map_set_def - -lemmas refs_of'_defs[simp] = refs_of_tcb'_def refs_of_ntfn'_def refs_of_sc'_def refs_of_reply'_def +definition + tcb_bound_refs' :: "word32 option \ (word32 \ reftype) set" +where + "tcb_bound_refs' a \ set_option a \ {TCBBound}" -definition refs_of' :: "kernel_object \ ref_set" where +definition + refs_of' :: "Structures_H.kernel_object \ (word32 \ reftype) set" +where "refs_of' x \ case x of - (KOTCB tcb) => refs_of_tcb' tcb + (KOTCB tcb) => tcb_st_refs_of' (tcbState tcb) \ tcb_bound_refs' (tcbBoundNotification tcb) | (KOCTE cte) => {} | (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 - | _ => {}" - -definition state_refs_of' :: "kernel_state \ word32 \ ref_set" where - "state_refs_of' s \ \x. case ksPSpace s x of - None \ {} - | Some ko \ - if is_aligned x (objBitsKO ko) \ ps_clear x (objBitsKO ko) s - \ objBitsKO ko < word_bits - then refs_of' ko - else {}" - -defs sym_refs_asrt_def: - "sym_refs_asrt \ \s. sym_refs (state_refs_of' s)" - -definition live_sc' :: "sched_context \ bool" where - "live_sc' sc \ bound (scTCB sc) \ scTCB sc \ Some idle_thread_ptr - \ 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)" - -definition live_reply' :: "reply \ bool" where - "live_reply' reply \ bound (replyTCB reply) \ bound (replyNext reply) \ bound (replyPrev reply)" - -primrec live' :: "Structures_H.kernel_object \ bool" where + | (KONotification ntfn) => ntfn_q_refs_of' (ntfnObj ntfn) \ ntfn_bound_refs' (ntfnBoundTCB ntfn) + | (KOUserData) => {} + | (KOUserDataDevice) => {} + | (KOKernelData) => {} + | (KOArch ako) => {}" + +definition + state_refs_of' :: "kernel_state \ word32 \ (word32 \ reftype) set" +where + "state_refs_of' s \ (\x. case (ksPSpace s x) + of None \ {} + | Some ko \ + (if is_aligned x (objBitsKO ko) \ ps_clear x (objBitsKO ko) s + then refs_of' ko + else {}))" + +primrec + live' :: "Structures_H.kernel_object \ bool" +where "live' (KOTCB tcb) = - (bound (tcbBoundNotification tcb) \ - bound (tcbSchedContext tcb) \ tcbSchedContext tcb \ Some idle_sc_ptr \ - bound (tcbYieldTo tcb) \ - tcbState tcb \ Inactive \ tcbState tcb \ IdleThreadState \ - tcbQueued tcb)" + (bound (tcbBoundNotification tcb) + \ tcbSchedPrev tcb \ None \ tcbSchedNext tcb \ None + \ tcbQueued tcb + \ (tcbState tcb \ Inactive \ tcbState tcb \ IdleThreadState))" | "live' (KOCTE cte) = False" | "live' (KOEndpoint ep) = (ep \ IdleEP)" -| "live' (KONotification ntfn) = live_ntfn' ntfn" -| "live' (KOSchedContext sc) = live_sc' sc" -| "live' (KOReply r) = live_reply' r" +| "live' (KONotification ntfn) = (bound (ntfnBoundTCB ntfn) \ (\ts. ntfnObj ntfn = WaitingNtfn ts))" | "live' (KOUserData) = False" | "live' (KOUserDataDevice) = False" | "live' (KOKernelData) = False" | "live' (KOArch ako) = False" -fun zobj_refs' :: "capability \ word32 set" where - "zobj_refs' (EndpointCap r _ _ _ _ _) = {r}" -| "zobj_refs' (NotificationCap r _ _ _) = {r}" -| "zobj_refs' (ThreadCap r) = {r}" -| "zobj_refs' (SchedContextCap r _) = {r}" -| "zobj_refs' (ReplyCap r _) = {r}" -| "zobj_refs' _ = {}" - -definition ex_nonz_cap_to' :: "word32 \ kernel_state \ bool" where - "ex_nonz_cap_to' ref \ \s. \cref. cte_wp_at' (\c. ref \ zobj_refs' (cteCap c)) cref s" - -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" - -primrec cte_refs' :: "capability \ word32 \ word32 set" where - "cte_refs' (UntypedCap _ _ _ _) _ = {}" -| "cte_refs' NullCap _ = {}" -| "cte_refs' DomainCap _ = {}" -| "cte_refs' (EndpointCap _ _ _ _ _ _) _ = {}" -| "cte_refs' (NotificationCap _ _ _ _) _ = {}" -| "cte_refs' (CNodeCap ref bits _ _) x = (\x. ref + (x * 2^cteSizeBits)) ` {0 .. 2 ^ bits - 1}" -| "cte_refs' (ThreadCap ref) x = (\x. ref + x) ` (dom tcb_cte_cases)" -| "cte_refs' (Zombie r _ n) x = (\x. r + (x * 2 ^ cteSizeBits)) ` {0 ..< of_nat n}" -| "cte_refs' (ArchObjectCap _) _ = {}" -| "cte_refs' (IRQControlCap) _ = {}" -| "cte_refs' (IRQHandlerCap irq) x = {x + (ucast irq) * 16}" -| "cte_refs' (ReplyCap _ _) _ = {}" -| "cte_refs' (SchedContextCap _ _) _ = {}" -| "cte_refs' SchedControlCap _ = {}" +primrec + zobj_refs' :: "capability \ word32 set" +where + "zobj_refs' NullCap = {}" +| "zobj_refs' DomainCap = {}" +| "zobj_refs' (UntypedCap d r n f) = {}" +| "zobj_refs' (EndpointCap r badge x y z t) = {r}" +| "zobj_refs' (NotificationCap r badge x y) = {r}" +| "zobj_refs' (CNodeCap r b g gsz) = {}" +| "zobj_refs' (ThreadCap r) = {r}" +| "zobj_refs' (Zombie r b n) = {}" +| "zobj_refs' (ArchObjectCap ac) = {}" +| "zobj_refs' (IRQControlCap) = {}" +| "zobj_refs' (IRQHandlerCap irq) = {}" +| "zobj_refs' (ReplyCap tcb m x) = {}" + +definition + ex_nonz_cap_to' :: "word32 \ kernel_state \ bool" +where + "ex_nonz_cap_to' ref \ + (\s. \cref. cte_wp_at' (\c. ref \ zobj_refs' (cteCap c)) cref s)" + +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" + + +primrec + cte_refs' :: "capability \ word32 \ word32 set" +where + "cte_refs' (UntypedCap d p n f) x = {}" +| "cte_refs' (NullCap) x = {}" +| "cte_refs' (DomainCap) x = {}" +| "cte_refs' (EndpointCap ref badge s r g gr) x = {}" +| "cte_refs' (NotificationCap ref badge s r) x = {}" +| "cte_refs' (CNodeCap ref bits g gs) x = + (\x. ref + (x * 2 ^ cteSizeBits)) ` {0 .. 2 ^ bits - 1}" +| "cte_refs' (ThreadCap ref) x = + (\x. ref + x) ` (dom tcb_cte_cases)" +| "cte_refs' (Zombie r b n) x = + (\x. r + (x * 2 ^ cteSizeBits)) ` {0 ..< of_nat n}" +| "cte_refs' (ArchObjectCap cap) x = {}" +| "cte_refs' (IRQControlCap) x = {}" +| "cte_refs' (IRQHandlerCap irq) x = {x + (ucast irq) * 16}" +| "cte_refs' (ReplyCap tcb m g) x = {}" + abbreviation - "irq_node' s \ intStateIRQNode (ksInterruptState s)" + "irq_node' s \ intStateIRQNode (ksInterruptState s)" definition ex_cte_cap_wp_to' :: "(capability \ bool) \ word32 \ kernel_state \ bool" @@ -499,7 +334,7 @@ where section "Valid caps and objects (Haskell)" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec acapBits :: "arch_capability \ nat" where @@ -517,27 +352,28 @@ where "zBits (ZombieCNode n) = objBits (undefined::cte) + n" | "zBits (ZombieTCB) = tcbBlockSizeBits" -primrec capBits :: "capability \ nat" where +primrec + capBits :: "capability \ nat" +where "capBits NullCap = 0" | "capBits DomainCap = 0" | "capBits (UntypedCap d r b f) = b" | "capBits (EndpointCap r b x y z t) = objBits (undefined::endpoint)" -| "capBits (NotificationCap r b x y) = objBits (undefined::notification)" +| "capBits (NotificationCap r b x y) = objBits (undefined::Structures_H.notification)" | "capBits (CNodeCap r b g gs) = objBits (undefined::cte) + b" | "capBits (ThreadCap r) = objBits (undefined::tcb)" | "capBits (Zombie r z n) = zBits z" | "capBits (IRQControlCap) = 0" | "capBits (IRQHandlerCap irq) = 0" -| "capBits (ReplyCap tcb m) = objBits (undefined :: reply)" -| "capBits (SchedContextCap sc n) = n" -| "capBits SchedControlCap = 0" +| "capBits (ReplyCap tcb m x) = objBits (undefined :: tcb)" | "capBits (ArchObjectCap x) = acapBits x" lemmas objBits_defs = - tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def cteSizeBits_def replySizeBits_def + tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def cteSizeBits_def -definition capAligned :: "capability \ bool" where - "capAligned c \ is_aligned (capUntypedPtr c) (capBits c) \ capBits c < word_bits" +definition + "capAligned c \ + is_aligned (capUntypedPtr c) (capBits c) \ capBits c < word_bits" definition "obj_range' (p::word32) ko \ {p .. p + 2 ^ objBitsKO ko - 1}" @@ -555,7 +391,7 @@ definition -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition page_table_at' :: "word32 \ kernel_state \ bool" @@ -572,15 +408,16 @@ where abbreviation "asid_pool_at' \ typ_at' (ArchT ASIDPoolT)" +(* FIXME: duplicated with vmsz_aligned *) +definition + "vmsz_aligned' ref sz \ is_aligned ref (pageBitsForSize sz)" + primrec zombieCTEs :: "zombie_type \ nat" where "zombieCTEs ZombieTCB = 5" | "zombieCTEs (ZombieCNode n) = (2 ^ n)" -abbreviation - "sc_at'_n n \ ko_wp_at' (\ko. koTypeOf ko = SchedContextT \ objBitsKO ko = n)" - definition valid_cap' :: "capability \ kernel_state \ bool" where valid_cap'_def: @@ -598,12 +435,9 @@ where valid_cap'_def: guard && mask guard_sz = guard \ (\addr. real_cte_at' (r + 2^cteSizeBits * (addr && mask bits)) s) | Structures_H.ThreadCap r \ tcb_at' r s - | Structures_H.ReplyCap r m \ reply_at' r s + | Structures_H.ReplyCap r m x \ tcb_at' r s | Structures_H.IRQControlCap \ True | Structures_H.IRQHandlerCap irq \ irq \ maxIRQ - | Structures_H.SchedControlCap \ True - | Structures_H.SchedContextCap sc n \ sc_at'_n n sc s - \ minSchedContextBits \ n \ n \ maxUntypedSizeBits | Structures_H.Zombie r b n \ n \ zombieCTEs b \ zBits b < word_bits \ (case b of ZombieTCB \ tcb_at' r s | ZombieCNode n \ n \ 0 \ (\addr. real_cte_at' (r + 2^cteSizeBits * (addr && mask n)) s)) @@ -615,7 +449,7 @@ where valid_cap'_def: (\p < 2 ^ (pageBitsForSize sz - pageBits). typ_at' (if d then UserDataDeviceT else UserDataT) (ref + p * 2 ^ pageBits) s) \ (case mapdata of None \ True | Some (asid, ref) \ - 0 < asid \ asid \ 2 ^ asid_bits - 1 \ vmsz_aligned ref sz \ ref < pptrBase) + 0 < asid \ asid \ 2 ^ asid_bits - 1 \ vmsz_aligned' ref sz \ ref < pptrBase) | PageTableCap ref mapdata \ page_table_at' ref s \ (case mapdata of None \ True | Some (asid, ref) \ @@ -634,36 +468,27 @@ definition where "valid_cte' cte s \ s \' (cteCap cte)" -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_ntfn' \ valid_bound_obj' ntfn_at'" - -abbreviation - "valid_bound_tcb' \ valid_bound_obj' tcb_at'" - -abbreviation - "valid_bound_sc' \ valid_bound_obj' sc_at'" - -abbreviation - "valid_bound_reply' \ valid_bound_obj' reply_at'" - -definition valid_tcb_state' :: "thread_state \ kernel_state \ bool" where +definition + valid_tcb_state' :: "Structures_H.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 + Structures_H.BlockedOnReceive ref a \ ep_at' ref s + | Structures_H.BlockedOnSend ref a b d c \ ep_at' ref s + | Structures_H.BlockedOnNotification ref \ ntfn_at' ref s | _ \ True" - definition valid_ipc_buffer_ptr' :: "word32 \ kernel_state \ bool" where "valid_ipc_buffer_ptr' a s \ is_aligned a msg_align_bits \ typ_at' UserDataT (a && ~~ mask pageBits) s" +definition + valid_bound_ntfn' :: "word32 option \ kernel_state \ bool" +where + "valid_bound_ntfn' ntfn_opt s \ case ntfn_opt of + None \ True + | Some a \ ntfn_at' a s" + definition is_device_page_cap' :: "capability \ bool" where @@ -671,21 +496,24 @@ where capability.ArchObjectCap (arch_capability.PageCap dev _ _ _ _) \ dev | _ \ False" +abbreviation opt_tcb_at' :: "machine_word option \ kernel_state \ bool" where + "opt_tcb_at' \ none_top tcb_at'" + +lemmas opt_tcb_at'_def = none_top_def -definition valid_tcb' :: "tcb \ kernel_state \ bool" where +definition + valid_tcb' :: "Structures_H.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 - \ valid_bound_sc' (tcbYieldTo t) s \ tcbDomain t \ maxDomain \ tcbPriority t \ maxPriority \ tcbMCP t \ maxPriority \ opt_tcb_at' (tcbSchedPrev t) s \ opt_tcb_at' (tcbSchedNext t) s" - definition valid_ep' :: "Structures_H.endpoint \ kernel_state \ bool" where @@ -695,37 +523,23 @@ where | Structures_H.RecvEP ts \ (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts)" +definition + valid_bound_tcb' :: "word32 option \ kernel_state \ bool" +where + "valid_bound_tcb' tcb_opt s \ case tcb_opt of + None \ True + | Some t \ tcb_at' t s" + definition valid_ntfn' :: "Structures_H.notification \ kernel_state \ bool" where "valid_ntfn' ntfn s \ (case ntfnObj ntfn of Structures_H.IdleNtfn \ True | Structures_H.WaitingNtfn ts \ - ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts - \ (case ntfnBoundTCB ntfn of Some tcb \ ts = [tcb] | _ \ True) + (ts \ [] \ (\t \ set ts. tcb_at' t s) \ distinct ts + \ (case ntfnBoundTCB ntfn of Some tcb \ ts = [tcb] | _ \ True)) | Structures_H.ActiveNtfn b \ True) - \ 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) - \ (0 < scRefillMax sc \ scRefillHead sc < scRefillMax sc - \ scRefillCount sc \ scRefillMax sc - \ 0 < scRefillCount sc)" - -definition valid_reply' :: "reply \ kernel_state \ bool" where - "valid_reply' reply s \ - valid_bound_tcb' (replyTCB reply) s - \ valid_bound_sc' (replySC reply) s - \ valid_bound_reply' (replyPrev reply) s - \ valid_bound_reply' (replyNext_of reply) s" + \ valid_bound_tcb' (ntfnBoundTCB ntfn) s" definition valid_mapping' :: "word32 \ vmpage_size \ kernel_state \ bool" @@ -762,20 +576,12 @@ where | "valid_arch_obj' (KOPDE pde) = valid_pde' pde" | "valid_arch_obj' (KOPTE pte) = valid_pte' pte" -definition sc_size_bounds :: "nat \ bool" where - "sc_size_bounds us \ - minSchedContextBits \ us \ us \ maxUntypedSizeBits" - -definition valid_sched_context_size' :: "sched_context \ bool" where - "valid_sched_context_size' sc \ sc_size_bounds (objBits sc)" - - -definition valid_obj' :: "kernel_object \ kernel_state \ bool" where +definition + valid_obj' :: "Structures_H.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 - | KOSchedContext sc \ valid_sched_context' sc s \ valid_sched_context_size' sc - | KOReply reply \ valid_reply' reply s | KOKernelData \ False | KOUserData \ True | KOUserDataDevice \ True @@ -795,30 +601,11 @@ where "pspace_distinct' s \ \x \ dom (ksPSpace s). ps_clear x (objBitsKO (the (ksPSpace s x))) s" -definition pspace_bounded' :: "kernel_state \ bool" where - "pspace_bounded' s \ - \x \ dom (ksPSpace s). objBitsKO (the (ksPSpace s x)) < word_bits" - definition valid_objs' :: "kernel_state \ bool" where "valid_objs' s \ \obj \ ran (ksPSpace s). valid_obj' obj s" -definition valid_obj_size' :: "kernel_object \ kernel_state \ bool" where - "valid_obj_size' ko s \ case ko of - KOSchedContext sc \ valid_sched_context_size' sc - | _ \ True" - -definition - valid_objs_size' :: "kernel_state \ bool" -where - "valid_objs_size' s \ \obj \ ran (ksPSpace s). valid_obj_size' obj s" - -lemma valid_objs'_valid_objs_size': - "valid_objs' s \ valid_objs_size' s" - by (clarsimp simp: valid_objs'_def valid_objs_size'_def valid_obj'_def valid_obj_size'_def) - (fastforce split: kernel_object.splits) - type_synonym cte_heap = "word32 \ cte option" definition @@ -906,14 +693,12 @@ where | "capClass (UntypedCap d p n f) = PhysicalClass" | "capClass (EndpointCap ref badge s r g gr) = PhysicalClass" | "capClass (NotificationCap ref badge s r) = PhysicalClass" -| "capClass (SchedContextCap _ _) = PhysicalClass" | "capClass (CNodeCap ref bits g gs) = PhysicalClass" | "capClass (ThreadCap ref) = PhysicalClass" | "capClass (Zombie r b n) = PhysicalClass" | "capClass (IRQControlCap) = IRQClass" -| "capClass (SchedControlCap) = SchedControlClass" | "capClass (IRQHandlerCap irq) = IRQClass" -| "capClass (ReplyCap tcb m) = PhysicalClass" +| "capClass (ReplyCap tcb m g) = ReplyClass tcb" | "capClass (ArchObjectCap cap) = acapClass cap" definition @@ -1046,6 +831,13 @@ definition where "distinct_zombies m \ distinct_zombie_caps (option_map cteCap \ m)" +definition + reply_masters_rvk_fb :: "cte_heap \ bool" +where + "reply_masters_rvk_fb ctes \ \cte \ ran ctes. + isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte) + \ mdbRevocable (cteMDBNode cte) \ mdbFirstBadged (cteMDBNode cte)" + definition valid_mdb_ctes :: "cte_heap \ bool" where @@ -1054,7 +846,7 @@ where mdb_chunked m \ untyped_mdb' m \ untyped_inc' m \ valid_nullcaps m \ ut_revocable' m \ class_links m \ distinct_zombies m - \ irq_control m" + \ irq_control m \ reply_masters_rvk_fb m" definition valid_mdb' :: "kernel_state \ bool" @@ -1077,31 +869,12 @@ definition "vs_valid_duplicates' \ \h. x && ~~ mask (vs_ptr_align ko) = y && ~~ mask (vs_ptr_align ko) \ h x = h y" -abbreviation - "is_reply_linked rptr s \ replyNexts_of s rptr \ None \ replyPrevs_of s rptr \ None" - -definition valid_replies'_except :: "obj_ref set \ kernel_state \ bool" where - "valid_replies'_except RS s \ - (\rptr. rptr \ RS \ is_reply_linked rptr s - \ (\tptr. replyTCBs_of s rptr = Some tptr - \ st_tcb_at' ((=) (BlockedOnReply (Some rptr))) tptr s))" - -definition [simplified empty_iff simp_thms valid_replies'_except_def]: - "valid_replies' s \ valid_replies'_except {} s" - -defs valid_replies'_sc_asrt_def: - "valid_replies'_sc_asrt \ \rptr s. - replySCs_of s rptr \ None - \ (\tptr. replyTCBs_of s rptr = Some tptr - \ st_tcb_at' ((=) (BlockedOnReply (Some rptr))) tptr s)" definition valid_pspace' :: "kernel_state \ bool" where "valid_pspace' \ valid_objs' and - valid_replies' and pspace_aligned' and pspace_distinct' and - pspace_bounded' and no_0_obj' and valid_mdb'" @@ -1112,8 +885,8 @@ where | "runnable' (Structures_H.Inactive) = False" | "runnable' (Structures_H.Restart) = True" | "runnable' (Structures_H.IdleThreadState) = False" -| "runnable' (Structures_H.BlockedOnReceive _ _ _) = False" -| "runnable' (Structures_H.BlockedOnReply _) = False" +| "runnable' (Structures_H.BlockedOnReceive a b) = False" +| "runnable' (Structures_H.BlockedOnReply) = False" | "runnable' (Structures_H.BlockedOnSend a b c d e) = False" | "runnable' (Structures_H.BlockedOnNotification x) = False" @@ -1135,7 +908,6 @@ where "bitmapQ d p s \ ksReadyQueuesL1Bitmap s d !! prioToL1Index p \ ksReadyQueuesL2Bitmap s (d, invertL1Index (prioToL1Index p)) !! unat (p && mask wordRadix)" - definition (* A priority is used as a two-part key into the bitmap structure. If an L2 bitmap entry is set without an L1 entry, updating the L1 entry (shared by many priorities) may make @@ -1216,21 +988,6 @@ lemma valid_sched_pointersD: \ tcbSchedPrevs_of s t = None \ tcbSchedNexts_of s t = None" by (fastforce simp: valid_sched_pointers_def in_opt_pred opt_map_red) -definition - valid_release_queue :: "kernel_state \ bool" -where - "valid_release_queue \ \s. \t. t \ set (ksReleaseQueue s) \ obj_at' (tcbInReleaseQueue) t s" - -definition - valid_release_queue' :: "kernel_state \ bool" -where - "valid_release_queue' \ \s. \t. obj_at' (tcbInReleaseQueue) t s \ t \ set (ksReleaseQueue s)" - -abbreviation - valid_release_queue_iff :: "kernel_state \ bool" -where - "valid_release_queue_iff \ valid_release_queue and valid_release_queue'" - definition tcb_in_cur_domain' :: "32 word \ kernel_state \ bool" where "tcb_in_cur_domain' t \ \s. obj_at' (\tcb. ksCurDomain s = tcbDomain tcb) t s" @@ -1239,26 +996,19 @@ definition "ct_idle_or_in_cur_domain' \ \s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s = ksIdleThread s \ tcb_in_cur_domain' (ksCurThread s) s" -definition ct_in_state' :: "(thread_state \ bool) \ kernel_state \ bool" where +definition "ct_in_state' test \ \s. st_tcb_at' test (ksCurThread s) s" definition "ct_not_inQ \ \s. ksSchedulerAction s = ResumeCurrentThread \ obj_at' (Not \ tcbQueued) (ksCurThread s) s" -defs ct_not_inQ_asrt_def: - "ct_not_inQ_asrt \ \s. ct_not_inQ s" - abbreviation "idle' \ \st. st = Structures_H.IdleThreadState" abbreviation "activatable' st \ runnable' st \ idle' st" -defs rct_imp_activatable'_asrt_def: - "rct_imp_activatable'_asrt \ \s. ksSchedulerAction s = ResumeCurrentThread \ - ct_in_state' activatable' s" - primrec sch_act_wf :: "scheduler_action \ kernel_state \ bool" where @@ -1266,9 +1016,6 @@ where | "sch_act_wf ChooseNewThread = \" | "sch_act_wf (SwitchToThread t) = (\s. st_tcb_at' runnable' t s \ tcb_in_cur_domain' t s)" -defs sch_act_wf_asrt_def: - "sch_act_wf_asrt \ \s. sch_act_wf (ksSchedulerAction s) s" - definition sch_act_simple :: "kernel_state \ bool" where @@ -1284,45 +1031,19 @@ where abbreviation "sch_act_not t \ \s. ksSchedulerAction s \ SwitchToThread t" -definition - idle_tcb'_2 :: "Structures_H.thread_state \ 32 word option \ 32 word option \ 32 word option - \ bool" -where - "idle_tcb'_2 \ \(st, ntfn_opt, sc_opt, yt_opt). - (idle' st \ ntfn_opt = None \ sc_opt = Some idle_sc_ptr \ yt_opt = None)" +definition idle_tcb'_2 :: "Structures_H.thread_state \ machine_word option \ bool" where + "idle_tcb'_2 \ \(st, ntfn_opt). (idle' st \ ntfn_opt = None)" abbreviation - "idle_tcb' tcb \ - idle_tcb'_2 (tcbState tcb, tcbBoundNotification tcb, tcbSchedContext tcb, tcbYieldTo tcb)" + "idle_tcb' tcb \ idle_tcb'_2 (tcbState tcb, tcbBoundNotification tcb)" lemmas idle_tcb'_def = idle_tcb'_2_def -abbreviation idle_sc' :: "sched_context \ bool" where - "idle_sc' sc \ - scPeriod sc = 0 - \ scTCB sc = Some idle_thread_ptr - \ scNtfn sc = None - \ scRefillMax sc = MIN_REFILLS - \ scBadge sc = 0 - \ scYieldFrom sc = None - \ scReply sc = None" - -abbreviation - "idle_sc_at' \ obj_at' idle_sc'" - -definition - valid_idle' :: "kernel_state \ bool" -where - "valid_idle' \ - \s. obj_at' idle_tcb' (ksIdleThread s) s - \ idle_sc_at' idle_sc_ptr s - \ idle_thread_ptr = ksIdleThread s" - -defs valid_idle'_asrt_def: - "valid_idle'_asrt \ \s. valid_idle' s" +definition valid_idle' :: "kernel_state \ bool" where + "valid_idle' \ \s. obj_at' idle_tcb' (ksIdleThread s) s \ idle_thread_ptr = ksIdleThread s" lemma valid_idle'_tcb_at': - "valid_idle' s \ obj_at' idle_tcb' (ksIdleThread s) s \ idle_sc_at' idle_sc_ptr s" + "valid_idle' s \ obj_at' idle_tcb' (ksIdleThread s) s" by (clarsimp simp: valid_idle'_def) definition valid_irq_node' :: "word32 \ kernel_state \ bool" where @@ -1348,7 +1069,7 @@ definition global_refs' :: "kernel_state \ obj_ref set" where "global_refs' \ \s. - {ksIdleThread s, idle_sc_ptr} \ + {ksIdleThread s} \ page_directory_refs' (armKSGlobalPD (ksArchState s)) \ (\pt \ set (armKSGlobalPTs (ksArchState s)). page_table_refs' pt) \ range (\irq :: irq. irq_node' s + (ucast irq << cteSizeBits))" @@ -1470,51 +1191,49 @@ abbreviation "untyped_ranges_zero' s \ untyped_ranges_zero_inv (cteCaps_of s) (gsUntypedZeroRanges s)" +(* FIXME: this really should be a definition like the above. *) (* The schedule is invariant. *) -definition +abbreviation "valid_dom_schedule' \ \s. ksDomSchedule s \ [] \ (\x\set (ksDomSchedule s). dschDomain x \ maxDomain \ 0 < dschLength x) \ ksDomSchedule s = ksDomSchedule (newKernelState undefined) \ ksDomScheduleIdx s < length (ksDomSchedule (newKernelState undefined))" definition - invs' :: "kernel_state \ bool" -where - "invs' \ \s. valid_pspace' s - \ valid_queues s - \ sym_refs (list_refs_of_replies' s) - \ if_live_then_nonz_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 - \ valid_irq_states' s - \ valid_machine_state' s - \ irqs_masked' s - \ valid_queues' s - \ valid_release_queue s - \ valid_release_queue' s - \ valid_pde_mappings' s - \ pspace_domain_valid s - \ ksCurDomain s \ maxDomain - \ valid_dom_schedule' s - \ untyped_ranges_zero' s" + valid_state' :: "kernel_state \ bool" +where + "valid_state' \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s + \ sym_refs (state_refs_of' s) + \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' s + \ valid_idle' s + \ valid_global_refs' s \ valid_arch_state' s + \ valid_irq_node' (irq_node' s) s + \ valid_irq_handlers' s + \ valid_irq_states' s + \ valid_machine_state' s + \ irqs_masked' s + \ sym_heap_sched_pointers s + \ valid_sched_pointers s + \ valid_bitmaps s + \ ct_not_inQ s + \ ct_idle_or_in_cur_domain' s + \ valid_pde_mappings' s + \ pspace_domain_valid s + \ ksCurDomain s \ maxDomain + \ valid_dom_schedule' s + \ untyped_ranges_zero' s" definition "cur_tcb' s \ tcb_at' (ksCurThread s) s" -defs cur_tcb'_asrt_def: - "cur_tcb'_asrt \ \s. cur_tcb' s" - -defs sch_act_sane_asrt_def: - "sch_act_sane_asrt \ \s. sch_act_sane s" - -defs ct_not_ksQ_asrt_def: - "ct_not_ksQ_asrt \ \s. \pd. ksCurThread s \ set (ksReadyQueues s pd)" +definition + invs' :: "kernel_state \ bool" where + "invs' \ valid_state' and cur_tcb'" subsection "Derived concepts" abbreviation - "awaiting_reply' ts \ isBlockedOnReply ts" + "awaiting_reply' ts \ ts = Structures_H.BlockedOnReply" (* x-symbol doesn't have a reverse leadsto.. *) definition @@ -1530,8 +1249,6 @@ definition | NotificationT \ injectKO (makeObject :: Structures_H.notification) | CTET \ injectKO (makeObject :: cte) | TCBT \ injectKO (makeObject :: tcb) - | SchedContextT \ injectKO (makeObject :: sched_context) - | ReplyT \ injectKO (makeObject :: reply) | UserDataT \ injectKO (makeObject :: user_data) | UserDataDeviceT \ injectKO (makeObject :: user_data_device) | KernelDataT \ KOKernelData @@ -1558,7 +1275,7 @@ abbreviation "simple' st \ st = Structures_H.Inactive \ st = Structures_H.Running \ st = Structures_H.Restart \ - idle' st" + idle' st \ awaiting_reply' st" abbreviation "ct_active' \ ct_in_state' active'" @@ -1566,9 +1283,68 @@ abbreviation abbreviation "ct_running' \ ct_in_state' (\st. st = Structures_H.Running)" -defs ct_active'_asrt_def: - "ct_active'_asrt \ ct_active'" +abbreviation(input) + "all_invs_but_sym_refs_ct_not_inQ' + \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s + \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' s + \ valid_idle' s \ valid_global_refs' s \ valid_arch_state' s + \ valid_irq_node' (irq_node' s) s \ valid_irq_handlers' s + \ valid_irq_states' s \ irqs_masked' s \ valid_machine_state' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ cur_tcb' s \ ct_idle_or_in_cur_domain' s \ valid_pde_mappings' s + \ pspace_domain_valid s + \ ksCurDomain s \ maxDomain + \ valid_dom_schedule' s \ untyped_ranges_zero' s" + +abbreviation(input) + "all_invs_but_ct_not_inQ' + \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s + \ sym_refs (state_refs_of' s) + \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' s + \ valid_idle' s \ valid_global_refs' s \ valid_arch_state' s + \ valid_irq_node' (irq_node' s) s \ valid_irq_handlers' s + \ valid_irq_states' s \ irqs_masked' s \ valid_machine_state' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ cur_tcb' s \ ct_idle_or_in_cur_domain' s \ valid_pde_mappings' s + \ pspace_domain_valid s + \ ksCurDomain s \ maxDomain + \ valid_dom_schedule' s \ untyped_ranges_zero' s" + +lemma all_invs_but_sym_refs_not_ct_inQ_check': + "(all_invs_but_sym_refs_ct_not_inQ' and sym_refs \ state_refs_of' and ct_not_inQ) = invs'" + by (simp add: pred_conj_def conj_commute conj_left_commute invs'_def valid_state'_def) + +lemma all_invs_but_not_ct_inQ_check': + "(all_invs_but_ct_not_inQ' and ct_not_inQ) = invs'" + by (simp add: pred_conj_def conj_commute conj_left_commute invs'_def valid_state'_def) + +definition + "all_invs_but_ct_idle_or_in_cur_domain' + \ \s. valid_pspace' s \ sch_act_wf (ksSchedulerAction s) s + \ sym_refs (state_refs_of' s) + \ if_live_then_nonz_cap' s \ if_unsafe_then_cap' s + \ valid_idle' s \ valid_global_refs' s \ valid_arch_state' s + \ valid_irq_node' (irq_node' s) s \ valid_irq_handlers' s + \ valid_irq_states' s \ irqs_masked' s \ valid_machine_state' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s + \ cur_tcb' s \ ct_not_inQ s \ valid_pde_mappings' s + \ pspace_domain_valid s + \ ksCurDomain s \ maxDomain + \ valid_dom_schedule' s \ untyped_ranges_zero' s" + +lemmas invs_no_cicd'_def = all_invs_but_ct_idle_or_in_cur_domain'_def + +lemma all_invs_but_ct_idle_or_in_cur_domain_check': + "(all_invs_but_ct_idle_or_in_cur_domain' and ct_idle_or_in_cur_domain') = invs'" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def pred_conj_def + conj_left_commute conj_commute invs'_def valid_state'_def) + +abbreviation (input) + "invs_no_cicd' \ all_invs_but_ct_idle_or_in_cur_domain'" +lemma invs'_to_invs_no_cicd'_def: + "invs' = (all_invs_but_ct_idle_or_in_cur_domain' and ct_idle_or_in_cur_domain')" + by (fastforce simp: invs'_def all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def ) end locale mdb_next = @@ -1586,7 +1362,7 @@ locale mdb_order = mdb_next + \ \---------------------------------------------------------------------------\ section "Alternate split rules for preserving subgoal order" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ntfn_splits[split]: " P (case ntfn of Structures_H.ntfn.IdleNtfn \ f1 | Structures_H.ntfn.ActiveNtfn x \ f2 x @@ -1612,18 +1388,21 @@ section "Lemmas" schematic_goal wordBits_def': "wordBits = numeral ?n" (* arch-specific consequence *) by (simp add: wordBits_def word_size) -lemmas valid_bound_ntfn'_def = valid_bound_obj'_def -lemmas valid_bound_tcb'_def = valid_bound_obj'_def -lemmas valid_bound_sc'_def = valid_bound_obj'_def -lemmas valid_bound_reply'_def = valid_bound_obj'_def +lemma valid_bound_ntfn'_None[simp]: + "valid_bound_ntfn' None = \" + by (auto simp: valid_bound_ntfn'_def) -lemma valid_bound_obj'_None[simp]: - "valid_bound_obj' P None = \" - by (auto simp: valid_bound_obj'_def) +lemma valid_bound_ntfn'_Some[simp]: + "valid_bound_ntfn' (Some x) = ntfn_at' x" + by (auto simp: valid_bound_ntfn'_def) -lemma valid_bound_obj'_Some[simp]: - "valid_bound_obj' P (Some x) = P x" - by (auto simp: valid_bound_obj'_def) +lemma valid_bound_tcb'_None[simp]: + "valid_bound_tcb' None = \" + by (auto simp: valid_bound_tcb'_def) + +lemma valid_bound_tcb'_Some[simp]: + "valid_bound_tcb' (Some x) = tcb_at' x" + by (auto simp: valid_bound_tcb'_def) lemmas untypedBits_defs = minUntypedSizeBits_def maxUntypedSizeBits_def lemmas objBits_simps = objBits_def objBitsKO_def word_size_def @@ -1658,22 +1437,26 @@ lemma ps_clear_def2: done lemma projectKO_stateI: - "projectKO e s = Some obj \ projectKO e s' = Some obj" + "fst (projectKO e s) = {(obj, s)} \ fst (projectKO e s') = {(obj, s')}" unfolding projectKO_def - by (auto simp: omonad_defs split: option.splits) + by (auto simp: fail_def return_def valid_def split: option.splits) lemma singleton_in_magnitude_check: "(x, s) \ fst (magnitudeCheck a b c s') \ \s'. fst (magnitudeCheck a b c s') = {(x, s')}" - by (fastforce simp: read_magnitudeCheck_def magnitudeCheck_def in_monad - split: option.split_asm) + by (simp add: magnitudeCheck_def when_def in_monad return_def + split: if_split_asm option.split_asm) lemma wordSizeCase_simp [simp]: "wordSizeCase a b = a" by (simp add: wordSizeCase_def wordBits_def word_size) +lemma projectKO_eq: + "(fst (projectKO ko c) = {(obj, c)}) = (projectKO_opt ko = Some obj)" + by (simp add: projectKO_def fail_def return_def split: option.splits) + lemma obj_at'_def': "obj_at' P p s = (\ko obj. ksPSpace s p = Some ko \ is_aligned p (objBitsKO ko) - \ projectKO ko s = Some obj \ P obj - \ ps_clear p (objBitsKO ko) s \ objBitsKO ko < word_bits)" + \ fst (projectKO ko s) = {(obj,s)} \ P obj + \ ps_clear p (objBitsKO ko) s)" apply (simp add: obj_at'_real_def ko_wp_at'_def projectKO_eq True_notin_set_replicate_conv objBits_def) apply fastforce @@ -1681,22 +1464,22 @@ lemma obj_at'_def': lemma obj_at'_def: "obj_at' P p s \ \ko obj. ksPSpace s p = Some ko \ is_aligned p (objBitsKO ko) - \ projectKO ko s = Some obj \ P obj - \ ps_clear p (objBitsKO ko) s \ objBitsKO ko < word_bits" + \ fst (projectKO ko s) = {(obj,s)} \ P obj + \ ps_clear p (objBitsKO ko) s" by (simp add: obj_at'_def') lemma obj_atE' [elim?]: assumes objat: "obj_at' P ptr s" and rl: "\ko obj. \ ksPSpace s ptr = Some ko; is_aligned ptr (objBitsKO ko); - projectKO ko s = Some obj; P obj; objBitsKO ko < word_bits; + fst (projectKO ko s) = {(obj,s)}; P obj; ps_clear ptr (objBitsKO ko) s \ \ R" shows "R" using objat unfolding obj_at'_def by (auto intro!: rl) lemma obj_atI' [intro?]: "\ ksPSpace s ptr = Some ko; is_aligned ptr (objBitsKO ko); - projectKO ko s = Some obj; P obj; objBitsKO ko < word_bits; + fst (projectKO ko s) = {(obj, s)}; P obj; ps_clear ptr (objBitsKO ko) s \ \ obj_at' P ptr s" unfolding obj_at'_def by (auto) @@ -1709,16 +1492,45 @@ lemma cte_at'_def: lemma tcb_cte_cases_simps[simp]: "tcb_cte_cases 0 = Some (tcbCTable, tcbCTable_update)" - "tcb_cte_cases 0x10 = Some (tcbVTable, tcbVTable_update)" - "tcb_cte_cases 0x20 = Some (tcbIPCBufferFrame, tcbIPCBufferFrame_update)" - "tcb_cte_cases 0x30 = Some (tcbFaultHandler, tcbFaultHandler_update)" - "tcb_cte_cases 0x40 = Some (tcbTimeoutHandler, tcbTimeoutHandler_update)" + "tcb_cte_cases 16 = Some (tcbVTable, tcbVTable_update)" + "tcb_cte_cases 32 = Some (tcbReply, tcbReply_update)" + "tcb_cte_cases 48 = Some (tcbCaller, tcbCaller_update)" + "tcb_cte_cases 64 = Some (tcbIPCBufferFrame, tcbIPCBufferFrame_update)" by (simp add: tcb_cte_cases_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 refs_of'_simps[simp]: + "refs_of' (KOTCB tcb) = tcb_st_refs_of' (tcbState tcb) \ tcb_bound_refs' (tcbBoundNotification tcb)" + "refs_of' (KOCTE cte) = {}" + "refs_of' (KOEndpoint ep) = ep_q_refs_of' ep" + "refs_of' (KONotification ntfn) = ntfn_q_refs_of' (ntfnObj ntfn) \ ntfn_bound_refs' (ntfnBoundTCB ntfn)" + "refs_of' (KOUserData) = {}" + "refs_of' (KOUserDataDevice) = {}" + "refs_of' (KOKernelData) = {}" + "refs_of' (KOArch ako) = {}" + by (auto simp: refs_of'_def) + +lemma tcb_st_refs_of'_simps[simp]: + "tcb_st_refs_of' (Running) = {}" + "tcb_st_refs_of' (Inactive) = {}" + "tcb_st_refs_of' (Restart) = {}" + "tcb_st_refs_of' (BlockedOnReceive x'' a') = {(x'', TCBBlockedRecv)}" + "tcb_st_refs_of' (BlockedOnSend x a b c d) = {(x, TCBBlockedSend)}" + "tcb_st_refs_of' (BlockedOnNotification x') = {(x', TCBSignal)}" + "tcb_st_refs_of' (BlockedOnReply) = {}" + "tcb_st_refs_of' (IdleThreadState) = {}" + by (auto simp: tcb_st_refs_of'_def) + +lemma ep_q_refs_of'_simps[simp]: + "ep_q_refs_of' IdleEP = {}" + "ep_q_refs_of' (RecvEP q) = set q \ {EPRecv}" + "ep_q_refs_of' (SendEP q) = set q \ {EPSend}" + by (auto simp: ep_q_refs_of'_def) + +lemma ntfn_q_refs_of'_simps[simp]: + "ntfn_q_refs_of' IdleNtfn = {}" + "ntfn_q_refs_of' (WaitingNtfn q) = set q \ {NTFNSignal}" + "ntfn_q_refs_of' (ActiveNtfn b) = {}" + by (auto simp: ntfn_q_refs_of'_def) lemma ntfn_bound_refs'_simps[simp]: "ntfn_bound_refs' (Some t) = {(t, NTFNBound)}" @@ -1726,74 +1538,38 @@ lemma ntfn_bound_refs'_simps[simp]: by (auto simp: ntfn_bound_refs'_def) lemma tcb_bound_refs'_simps[simp]: - "tcb_bound_refs' (Some a) b c = {(a, TCBBound)} \ tcb_bound_refs' None b c" - "tcb_bound_refs' b (Some a) c = {(a, TCBSchedContext)} \ tcb_bound_refs' b None c" - "tcb_bound_refs' b c (Some a) = {(a, TCBYieldTo)} \ tcb_bound_refs' b c None" - "tcb_bound_refs' None None None = {}" + "tcb_bound_refs' (Some a) = {(a, TCBBound)}" + "tcb_bound_refs' None = {}" by (auto simp: tcb_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 a b c. (x, ref) \ tcb_bound_refs' a b c \ ref \ {TCBBound, TCBSchedContext, TCBYieldTo}" - apply (rename_tac ep; case_tac ep; simp) - apply (rename_tac ep; case_tac ep; simp) - apply (rename_tac ep; case_tac ep; clarsimp split: if_splits) - apply (clarsimp simp: tcb_bound_refs'_def get_refs_def2) - done - -\\ - 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 = + "(x, TCBBlockedRecv) \ refs_of' ko = + (\tcb. ko = KOTCB tcb \ (\a. tcbState tcb = BlockedOnReceive x a))" + "(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 = + "(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 = + "(x, EPRecv) \ refs_of' ko = (\ep. ko = KOEndpoint ep \ (\q. ep = RecvEP q \ x \ set q))" - "(x, NTFNSignal) \ refs_of' ko = + "(x, EPSend) \ refs_of' ko = + (\ep. ko = KOEndpoint ep \ (\q. ep = SendEP 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 = + "(x, TCBBound) \ refs_of' ko = + (\tcb. ko = KOTCB tcb \ (tcbBoundNotification tcb = Some x))" + "(x, NTFNBound) \ refs_of' ko = (\ntfn. ko = KONotification ntfn \ (ntfnBoundTCB ntfn = Some x))" - "(x, TCBSchedContext) \ refs_of' ko = - (\tcb. ko = KOTCB tcb \ tcbSchedContext tcb = Some x)" - "(x, SCTcb) \ refs_of' ko = - (\sc. ko = KOSchedContext sc \ scTCB sc = Some x)" - "(x, NTFNSchedContext) \ refs_of' ko = - (\ntfn. ko = KONotification ntfn \ ntfnSc ntfn = Some x)" - "(x, SCNtfn) \ refs_of' ko = - (\sc. ko = KOSchedContext sc \ scNtfn sc = Some x)" - "(x, SCReply) \ refs_of' ko = - (\sc. ko = KOSchedContext sc \ scReply sc = Some x)" - "(x, ReplySchedContext) \ refs_of' ko = - (\reply. ko = KOReply reply \ replySC reply = Some x)" - "(x, ReplyTCB) \ refs_of' ko = - (\reply. ko = KOReply reply \ replyTCB reply = Some x)" - "(x, TCBYieldTo) \ refs_of' ko = - (\tcb. ko = KOTCB tcb \ tcbYieldTo tcb = Some x)" - "(x, SCYieldFrom) \ refs_of' ko = - (\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.ntfn.splits)+ lemma ko_wp_at'_weakenE: "\ ko_wp_at' P p s; \ko. P ko \ Q ko \ \ ko_wp_at' Q p s" @@ -1805,7 +1581,7 @@ lemma projectKO_opt_tcbD: 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" + = st_tcb_at' (\ts. \a. ts = BlockedOnReceive x a) 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 @@ -1831,32 +1607,20 @@ lemma ko_at_state_refs_ofD': "ko_at' ko p s \ state_refs_of' s p = refs_of' (injectKO ko)" by (clarsimp dest!: obj_at_state_refs_ofD') -abbreviation distinct_release_queue :: "kernel_state \ bool" where - "distinct_release_queue \ \s. distinct (ksReleaseQueue s)" - definition tcb_ntfn_is_bound' :: "word32 option \ tcb \ bool" where "tcb_ntfn_is_bound' ntfn tcb \ tcbBoundNotification tcb = ntfn" lemma st_tcb_at_state_refs_ofD': - "st_tcb_at' P t s \ - \ts ntfnptr sc_ptr yieldto_ptr. P ts - \ obj_at' ((=) ntfnptr o tcbBoundNotification) t s - \ obj_at' ((=) sc_ptr o tcbSchedContext) t s - \ obj_at' ((=) yieldto_ptr o tcbYieldTo) t s - \ state_refs_of' s t = (tcb_st_refs_of' ts - \ tcb_bound_refs' ntfnptr sc_ptr yieldto_ptr)" + "st_tcb_at' P t s \ \ts ntfnptr. P ts \ obj_at' (tcb_ntfn_is_bound' ntfnptr) t s + \ state_refs_of' s t = (tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr)" by (auto simp: pred_tcb_at'_def tcb_ntfn_is_bound'_def obj_at'_def projectKO_eq project_inject state_refs_of'_def) lemma bound_tcb_at_state_refs_ofD': - "bound_tcb_at' P t s \ - \ts ntfnptr sc_ptr yieldto_ptr. P ntfnptr - \ obj_at' ((=) ntfnptr o tcbBoundNotification) t s - \ obj_at' ((=) sc_ptr o tcbSchedContext) t s - \ obj_at' ((=) yieldto_ptr o tcbYieldTo) t s - \ state_refs_of' s t = (tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr sc_ptr yieldto_ptr)" + "bound_tcb_at' P t s \ \ts ntfnptr. P ntfnptr \ obj_at' (tcb_ntfn_is_bound' ntfnptr) t s + \ state_refs_of' s t = (tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr)" by (auto simp: pred_tcb_at'_def obj_at'_def tcb_ntfn_is_bound'_def projectKO_eq project_inject state_refs_of'_def) @@ -1879,17 +1643,13 @@ lemma sym_refs_ko_atD': lemma sym_refs_st_tcb_atD': "\ st_tcb_at' P t s; sym_refs (state_refs_of' s) \ \ - \ts ntfnptr sc_ptr yieldto_ptr. P ts - \ obj_at' ((=) ntfnptr o tcbBoundNotification) t s - \ state_refs_of' s t = tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr sc_ptr yieldto_ptr - \ (\(x, tp)\tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr sc_ptr yieldto_ptr. - ko_wp_at' (\ko. (t, symreftype tp) \ refs_of' ko) x s)" + \ts ntfnptr. P ts \ obj_at' (tcb_ntfn_is_bound' ntfnptr) t s + \ state_refs_of' s t = tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr + \ (\(x, tp)\tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr. ko_wp_at' (\ko. (t, symreftype tp) \ refs_of' ko) x s)" apply (drule st_tcb_at_state_refs_ofD') apply (erule exE)+ apply (rule_tac x=ts in exI) apply (rule_tac x=ntfnptr in exI) - apply (rule_tac x=sc_ptr in exI) - apply (rule_tac x=yieldto_ptr in exI) apply clarsimp apply (frule obj_at_state_refs_ofD') apply (drule (1)sym_refs_obj_atD') @@ -1898,48 +1658,26 @@ lemma sym_refs_st_tcb_atD': lemma sym_refs_bound_tcb_atD': "\ bound_tcb_at' P t s; sym_refs (state_refs_of' s) \ \ - \ts ntfnptr sc_ptr yieldto_ptr. P ntfnptr - \ obj_at' ((=) ntfnptr o tcbBoundNotification) t s - \ state_refs_of' s t = tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr sc_ptr yieldto_ptr - \ (\(x, tp)\tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr sc_ptr yieldto_ptr. - ko_wp_at' (\ko. (t, symreftype tp) \ refs_of' ko) x s)" + \ts ntfnptr. P ntfnptr \ obj_at' (tcb_ntfn_is_bound' ntfnptr) t s + \ state_refs_of' s t = tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr + \ (\(x, tp)\tcb_st_refs_of' ts \ tcb_bound_refs' ntfnptr. ko_wp_at' (\ko. (t, symreftype tp) \ refs_of' ko) x s)" apply (drule bound_tcb_at_state_refs_ofD') apply (erule exE)+ apply (rule_tac x=ts in exI) apply (rule_tac x=ntfnptr in exI) - apply (rule_tac x=sc_ptr in exI) - apply (rule_tac x=yieldto_ptr in exI) apply clarsimp apply (frule obj_at_state_refs_ofD') apply (drule (1)sym_refs_obj_atD') apply auto done -lemma get_refs_nonempty[simp]: - "(get_refs ref_ty ptr_opt \ {}) = (ptr_opt \ None)" - by (clarsimp simp: get_refs_def split: option.splits) - -lemma get_refs_empty[simp]: - "(get_refs ref_ty ptr_opt = {}) = (ptr_opt = None)" - by (clarsimp simp: get_refs_def split: option.splits) - -abbreviation idle_refs :: "(machine_word \ reftype) set" where - "idle_refs \ {(idle_sc_ptr, TCBSchedContext), (idle_thread_ptr, SCTcb)}" - -\\ - This set subtraction gets simplified into a subset relation at all the places - we might want to use this rule, so we do that ahead of time. -\ -lemma refs_of_live'[simplified]: - "refs_of' ko - idle_refs \ {} \ live' ko" - apply (cases ko; simp) - apply clarsimp - apply (rename_tac notification) - apply (case_tac "ntfnObj notification"; - fastforce simp: live_ntfn'_def) - apply fastforce - apply (fastforce simp: live_sc'_def) - apply (fastforce simp: live_reply'_def) +lemma refs_of_live': + "refs_of' ko \ {} \ live' ko" + apply (cases ko, simp_all) + apply clarsimp + apply (rename_tac notification) + apply (case_tac "ntfnObj notification"; simp) + apply fastforce+ done lemma if_live_then_nonz_capE': @@ -1956,11 +1694,10 @@ lemma if_live_then_nonz_capD': lemma if_live_state_refsE: "\ if_live_then_nonz_cap' s; - state_refs_of' s p - idle_refs \ {} \ \ ex_nonz_cap_to' p s" - apply (erule if_live_then_nonz_capE') - apply (simp add: state_refs_of'_def ko_wp_at'_def refs_of_live' - split: if_split_asm option.splits) - done + state_refs_of' s p \ {} \ \ ex_nonz_cap_to' p s" + by (clarsimp simp: state_refs_of'_def ko_wp_at'_def + split: option.splits if_split_asm + elim!: refs_of_live' if_live_then_nonz_capE') lemmas ex_cte_cap_to'_def = ex_cte_cap_wp_to'_def @@ -1984,10 +1721,6 @@ lemma valid_objsE' [elim]: "\ valid_objs' s; ksPSpace s x = Some obj; valid_obj' obj s \ R \ \ R" unfolding valid_objs'_def by auto -lemma valid_objs_sizeE' [elim]: - "\ valid_objs_size' s; ksPSpace s x = Some obj; valid_obj_size' obj s \ R \ \ R" - unfolding valid_objs_size'_def by auto - lemma pspace_distinctD': "\ ksPSpace s x = Some v; pspace_distinct' s \ \ ps_clear x (objBitsKO v) s" apply (simp add: pspace_distinct'_def) @@ -2002,13 +1735,6 @@ lemma pspace_alignedD': apply simp done -lemma pspace_boundedD': - "\ ksPSpace s x = Some v; pspace_bounded' s \ \ objBitsKO v < word_bits" - apply (simp add: pspace_bounded'_def) - apply (drule bspec, erule domI) - apply simp - done - lemma next_unfold: "mdb_next s c = (case s c of Some cte \ Some (mdbNext (cteMDBNode cte)) | None \ None)" @@ -2035,32 +1761,32 @@ lemma valid_pde_mapping'_simps[simp]: lemmas valid_irq_states'_def = valid_irq_masks'_def lemma valid_pspaceI' [intro]: - "\valid_objs' s; pspace_aligned' s; pspace_distinct' s; pspace_bounded' s; valid_mdb' s; no_0_obj' s; - valid_replies' s\ + "\valid_objs' s; pspace_aligned' s; pspace_distinct' s; valid_mdb' s; no_0_obj' s\ \ valid_pspace' s" unfolding valid_pspace'_def by simp lemma valid_pspaceE' [elim]: "\valid_pspace' s; - \ valid_objs' s; valid_replies' s; pspace_aligned' s; pspace_distinct' s; pspace_bounded' s; - no_0_obj' s; valid_mdb' s\ \ R \ \ R" + \ valid_objs' s; pspace_aligned' s; pspace_distinct' s; no_0_obj' s; + valid_mdb' s\ \ R \ \ R" unfolding valid_pspace'_def by simp -lemma idle'_only_sc_refs: - "valid_idle' s \ state_refs_of' s (ksIdleThread s) = {(idle_sc_ptr, TCBSchedContext)}" +lemma idle'_no_refs: + "valid_idle' s \ state_refs_of' s (ksIdleThread s) = {}" by (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def tcb_ntfn_is_bound'_def projectKO_eq project_inject state_refs_of'_def idle_tcb'_def) lemma idle'_not_queued': "\valid_idle' s; sym_refs (state_refs_of' s); - state_refs_of' s ptr = insert t queue \ {rt}; ksIdleThread s \ queue\ - \ ptr = idle_sc_ptr" - by (frule idle'_only_sc_refs, fastforce simp: valid_idle'_def sym_refs_def) + state_refs_of' s ptr = insert t queue \ {rt}\\ + ksIdleThread s \ queue" + by (frule idle'_no_refs, fastforce simp: valid_idle'_def sym_refs_def) lemma idle'_not_queued: "\valid_idle' s; sym_refs (state_refs_of' s); - state_refs_of' s ptr = queue \ {rt}; ksIdleThread s \ queue\ - \ ptr = idle_sc_ptr" - by (frule idle'_only_sc_refs, fastforce simp: valid_idle'_def sym_refs_def) + state_refs_of' s ptr = queue \ {rt}\ \ + ksIdleThread s \ queue" + by (frule idle'_no_refs, fastforce simp: valid_idle'_def sym_refs_def) + lemma obj_at_conj': "\ obj_at' P p s; obj_at' Q p s \ \ obj_at' (\k. P k \ Q k) p s" @@ -2072,10 +1798,6 @@ lemma pred_tcb_at_conj': apply (erule (1) obj_at_conj') done -lemma pred_tcb_at'_eq_commute: - "pred_tcb_at' proj ((=) v) = pred_tcb_at' proj (\x. x = v)" - by (intro ext) (auto simp: pred_tcb_at'_def obj_at'_def) - lemma obj_at_False' [simp]: "obj_at' (\k. False) t s = False" by (simp add: obj_at'_def) @@ -2088,29 +1810,24 @@ lemma obj_at'_pspaceI: "obj_at' t ref s \ ksPSpace s = ksPSpace s' \ obj_at' t ref s'" by (auto intro!: projectKO_stateI simp: obj_at'_def ps_clear_def) -lemma sc_at'_n_pspaceI: - "sc_at'_n n ref s \ ksPSpace s = ksPSpace s' \ sc_at'_n n ref s'" - by (auto intro!: projectKO_stateI simp: ko_wp_at'_def ps_clear_def) - lemma cte_wp_at'_pspaceI: "\cte_wp_at' P p s; ksPSpace s = ksPSpace s'\ \ cte_wp_at' P p s'" supply if_cong[cong] - apply (clarsimp simp: cte_wp_at'_def getObject_def readObject_def gets_the_def) + apply (clarsimp simp add: cte_wp_at'_def getObject_def) apply (drule equalityD2) - apply (clarsimp simp: in_monad loadObject_cte gets_def asks_def - get_def bind_def split_def oassert_opt_def - split: option.split_asm) - apply (rename_tac b; case_tac b) - apply (simp_all add: in_monad read_typeError_def) + apply (clarsimp simp: in_monad loadObject_cte gets_def + get_def bind_def return_def split_def) + apply (case_tac b) + apply (simp_all add: in_monad typeError_def) prefer 2 - apply (simp add: in_monad omonad_defs read_alignError_def obind_def - read_alignCheck_def read_magnitudeCheck_def return_def + apply (simp add: in_monad return_def alignError_def assert_opt_def + alignCheck_def magnitudeCheck_def when_def bind_def split: if_split_asm option.splits) - apply (clarsimp simp: in_monad omonad_defs read_alignError_def obind_def - read_alignCheck_def read_magnitudeCheck_def return_def + apply (clarsimp simp: in_monad return_def alignError_def fail_def assert_opt_def + alignCheck_def bind_def when_def objBits_cte_conv tcbCTableSlot_def tcbVTableSlot_def - cteSizeBits_def tcbIPCBufferSlot_def tcbFaultHandlerSlot_def - split: if_split_asm option.split_asm + tcbReplySlot_def cteSizeBits_def + split: if_split_asm dest!: singleton_in_magnitude_check) done @@ -2129,7 +1846,7 @@ lemma valid_cap'_pspaceI: by (cases cap) (force intro: obj_at'_pspaceI[rotated] cte_wp_at'_pspaceI valid_untyped'_pspaceI - typ_at'_pspaceI[rotated] sc_at'_n_pspaceI[rotated] + typ_at'_pspaceI[rotated] simp: page_table_at'_def page_directory_at'_def split: arch_capability.split zombie_type.split option.splits)+ @@ -2152,17 +1869,12 @@ lemma valid_obj'_pspaceI: 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_arch_obj'_pspaceI valid_bound_obj'_def - valid_sched_context'_def valid_reply'_def + valid_tcb_state'_def valid_arch_obj'_pspaceI valid_bound_tcb'_def + valid_bound_ntfn'_def split: Structures_H.endpoint.splits Structures_H.notification.splits Structures_H.thread_state.splits ntfn.splits option.splits intro: obj_at'_pspaceI valid_cap'_pspaceI) -lemma valid_obj_size'_pspaceI: - "valid_obj_size' obj s \ ksPSpace s = ksPSpace s' \ valid_obj_size' obj s'" - unfolding valid_obj_size'_def - by (cases obj; simp) - lemma pred_tcb_at'_pspaceI: "pred_tcb_at' proj P t s \ ksPSpace s = ksPSpace s' \ pred_tcb_at' proj P t s'" unfolding pred_tcb_at'_def by (fast intro: obj_at'_pspaceI) @@ -2171,33 +1883,23 @@ lemma valid_mdb'_pspaceI: "valid_mdb' s \ ksPSpace s = ksPSpace s' \ valid_mdb' s'" unfolding valid_mdb'_def by simp -lemma valid_replies'_pspaceI: - "valid_replies' s \ ksPSpace s = ksPSpace s' \ valid_replies' s'" - unfolding valid_replies'_def - apply clarsimp - apply (drule_tac x=rptr in spec) - apply (auto simp: opt_map_def intro: pred_tcb_at'_pspaceI) - done - lemma state_refs_of'_pspaceI: "P (state_refs_of' s) \ ksPSpace s = ksPSpace s' \ P (state_refs_of' s')" - unfolding state_refs_of'_def ps_clear_def - by (erule rsubst[where P=P], rule ext) (simp split: option.splits) + unfolding state_refs_of'_def ps_clear_def by (simp cong: option.case_cong) lemma valid_pspace': "valid_pspace' s \ ksPSpace s = ksPSpace s' \ valid_pspace' s'" - by (auto simp add: valid_pspace'_def valid_objs'_def pspace_aligned'_def + by (auto simp add: valid_pspace'_def valid_objs'_def pspace_aligned'_def pspace_distinct'_def ps_clear_def no_0_obj'_def ko_wp_at'_def - typ_at'_def pspace_bounded'_def - intro: valid_obj'_pspaceI valid_mdb'_pspaceI valid_replies'_pspaceI) + typ_at'_def + intro: valid_obj'_pspaceI valid_mdb'_pspaceI) lemma valid_idle'_pspace_itI[elim]: "\ valid_idle' s; ksPSpace s = ksPSpace s'; ksIdleThread s = ksIdleThread s' \ \ valid_idle' s'" apply (clarsimp simp: valid_idle'_def ex_nonz_cap_to'_def) - apply (rule conjI) - apply (erule obj_at'_pspaceI, assumption) - using obj_at'_pspaceI by blast + apply (erule obj_at'_pspaceI, assumption) + done lemma obj_at'_weaken: assumes x: "obj_at' P t s" @@ -2356,83 +2058,43 @@ lemma ps_clear_lookupAround2: apply (drule word_le_minus_one_leq, fastforce) done -lemma magnitudeCheck_wp: - "\\s. (case next of - Some next' \ next' - ptr \ 1 << bits - | None \ True) - \ P s\ - magnitudeCheck ptr next bits - \\_. P\" - unfolding magnitudeCheck_def read_magnitudeCheck_def - apply (simp add: gets_the_def exec_gets assert_opt_def valid_def - return_def split_def fail_def - split: option.split) - done - - -lemma alignCheck_wp: - "\\s. is_aligned ptr bits \ P s\ - alignCheck ptr bits - \\_. P\" - unfolding alignCheck_def read_alignCheck_def - apply (wpsimp simp: read_alignError_def is_aligned_mask omonad_defs) - done - -lemma lookupAround2_no_after_ps_clear: - "snd (lookupAround2 p (ksPSpace s)) = None \ ps_clear p bits s" - apply (fastforce simp: ps_clear_def lookupAround2_None2 dom_def set_eq_iff word_le_less_eq) - done - -lemma lookupAround2_after_ps_clear: - "\snd (lookupAround2 p (ksPSpace s)) = Some after; - 2 ^ bits \ after - p; - 1 < (2 :: machine_word) ^ bits; - is_aligned p bits\ \ - ps_clear p bits s" - apply (rule ps_clearI; clarsimp simp: lookupAround2_char2) - apply (rename_tac x obj_after) - apply (drule_tac x=x in spec) - apply (frule word_l_diffs, simp) - apply (prop_tac "x < after") - apply (frule word_leq_minus_one_le[rotated]) - apply (metis add.commute arith_simps(49) plus_minus_not_NULL_ab word_le_less_eq - word_not_simps(1)) - apply (frule_tac a=x in order.strict_trans2; fastforce simp: add.commute) - apply clarsimp - done - -lemma read_magnitude_check_simp[simp]: - assumes "is_aligned ptr bits" - "(1 :: machine_word) < 2 ^ bits" - "ksPSpace s ptr = Some y" - shows "read_magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) bits s = Some () - = ps_clear ptr bits s" - using assms - apply (clarsimp simp: read_magnitudeCheck_def) +lemma in_magnitude_check: + "\ is_aligned x n; (1 :: word32) < 2 ^ n; ksPSpace s x = Some y \ \ + ((v, s') \ fst (magnitudeCheck x (snd (lookupAround2 x (ksPSpace s))) n s)) + = (s' = s \ ps_clear x n s)" apply (rule iffI) - apply (clarsimp simp: lookupAround2_no_after_ps_clear lookupAround2_after_ps_clear omonad_defs - split: option.splits if_split_asm) - apply (fastforce elim!: ps_clear_lookupAround2 is_aligned_no_overflow split: option.splits) + apply (clarsimp simp: magnitudeCheck_def in_monad lookupAround2_None2 + lookupAround2_char2 + split: option.split_asm) + apply (erule(1) ps_clearI) + apply simp + apply (erule(1) ps_clearI) + apply (simp add: linorder_not_less) + apply (drule word_leq_le_minus_one[where x="2 ^ n"]) + apply (clarsimp simp: power_overflow) + apply (drule word_l_diffs) + apply simp + apply (simp add: field_simps) + apply clarsimp + apply (erule is_aligned_get_word_bits) + apply (erule(1) ps_clear_lookupAround2) + apply simp + apply (simp add: is_aligned_no_overflow) + apply (clarsimp simp add: magnitudeCheck_def in_monad + split: option.split_asm) + apply simp + apply (simp add: power_overflow) done -lemma in_magnitude_check: - assumes "is_aligned ptr bits" - "(1 :: machine_word) < 2 ^ bits" - "ksPSpace s ptr = Some y" - shows "((v, s') \ fst (magnitudeCheck ptr (snd (lookupAround2 ptr (ksPSpace s))) bits s)) - = (s' = s \ ps_clear ptr bits s)" - using assms - by (clarsimp simp: magnitudeCheck_def in_monad) - -lemma read_magnitude_check3[simp]: +lemma in_magnitude_check3: "\ \z. x < z \ z \ y \ ksPSpace s z = None; is_aligned x n; (1 :: word32) < 2 ^ n; ksPSpace s x = Some v; x \ y; y - x < 2 ^ n \ \ - read_magnitudeCheck x (snd (lookupAround2 y (ksPSpace s))) n s - = (if ps_clear x n s then Some () else None)" - apply (clarsimp simp: read_magnitudeCheck_def lookupAround2_char2 - lookupAround2_None2 in_monad - split: option.splits) - apply safe + fst (magnitudeCheck x (snd (lookupAround2 y (ksPSpace s))) n s) + = (if ps_clear x n s then {((), s)} else {})" + apply (rule set_eqI, rule iffI) + apply (clarsimp simp: magnitudeCheck_def lookupAround2_char2 + lookupAround2_None2 in_monad + split: option.split_asm) apply (drule(1) range_convergence1) apply (erule(1) ps_clearI) apply simp @@ -2444,6 +2106,7 @@ lemma read_magnitude_check3[simp]: apply (drule word_l_diffs, simp) apply (simp add: field_simps) apply (simp add: power_overflow) + apply (clarsimp split: if_split_asm) apply (erule(1) ps_clear_lookupAround2) apply simp apply (drule word_le_minus_one_leq[where x="y - x"]) @@ -2452,28 +2115,16 @@ lemma read_magnitude_check3[simp]: apply (simp add: field_simps is_aligned_no_overflow) apply simp apply (simp add: field_simps) - apply (fastforce simp: lookupAround2_None2 lookupAround2_char2 - split: option.split_asm) - done - -lemma in_magnitude_check3: - "\ \z. x < z \ z \ y \ ksPSpace s z = None; is_aligned x n; - (1 :: word32) < 2 ^ n; ksPSpace s x = Some v; x \ y; y - x < 2 ^ n \ \ - fst (magnitudeCheck x (snd (lookupAround2 y (ksPSpace s))) n s) - = (if ps_clear x n s then {((), s)} else {})" - apply (clarsimp simp: magnitudeCheck_def gets_the_def - exec_gets in_monad return_def assert_opt_def fail_def - split: option.split_asm) + apply (simp add: magnitudeCheck_def return_def + iffD2[OF linorder_not_less] when_def + split: option.split_asm) done -lemma read_alignCheck_simp[simp]: - "read_alignCheck x n s = Some v = is_aligned x n" - by (simp add: read_alignCheck_def is_aligned_mask[symmetric] - read_alignError_def omonad_defs) - lemma in_alignCheck[simp]: "((v, s') \ fst (alignCheck x n s)) = (s' = s \ is_aligned x n)" - by (simp add: alignCheck_def in_monad) + by (simp add: alignCheck_def in_monad is_aligned_mask[symmetric] + alignError_def conj_comms + cong: conj_cong) lemma tcb_space_clear: "\ tcb_cte_cases (y - x) = Some (getF, setF); @@ -2516,70 +2167,73 @@ lemma cte_wp_at_cases': \ tcb_cte_cases n = Some (getF, setF) \ P (getF tcb) \ ps_clear (p - n) tcbBlockSizeBits s))" (is "?LHS = ?RHS") apply (rule iffI) - apply (clarsimp simp: cte_wp_at'_def gets_the_def readObject_def - getObject_def bind_def simpler_gets_def omonad_defs + apply (clarsimp simp: cte_wp_at'_def split_def + getObject_def bind_def simpler_gets_def assert_opt_def return_def fail_def - split: option.splits dest!: prod_injects + split: option.splits del: disjCI) - apply (clarsimp simp: loadObject_cte read_typeError_def split_def + apply (clarsimp simp: loadObject_cte typeError_def alignError_def fail_def return_def objBits_simps' - is_aligned_mask[symmetric] + is_aligned_mask[symmetric] alignCheck_def tcbVTableSlot_def field_simps tcbCTableSlot_def + tcbReplySlot_def tcbCallerSlot_def tcbIPCBufferSlot_def - tcbFaultHandlerSlot_def tcbTimeoutHandlerSlot_def - lookupAround2_char1 omonad_defs + lookupAround2_char1 cte_level_bits_def Ball_def unless_def when_def bind_def split: kernel_object.splits if_split_asm option.splits del: disjCI) - apply ((rule disjI2)?, fastforce simp: field_simps elim: rsubst[where P="\x. ksPSpace s x = v" for s v])+ - apply (simp add: cte_wp_at'_def getObject_def split_def gets_the_def - bind_def simpler_gets_def return_def readObject_def - assert_opt_def fail_def objBits_simps' omonad_defs obind_def + apply (subst(asm) in_magnitude_check3, simp+, + simp split: if_split_asm, (rule disjI2)?, intro exI, rule conjI, + erule rsubst[where P="\x. ksPSpace s x = v" for s v], + fastforce simp add: field_simps, simp)+ + apply (subst(asm) in_magnitude_check3, simp+) + apply (simp split: if_split_asm) + apply (simp add: cte_wp_at'_def getObject_def split_def + bind_def simpler_gets_def return_def + assert_opt_def fail_def objBits_simps' split: option.splits) apply (elim disjE conjE exE) apply (erule(1) ps_clear_lookupAround2) apply simp apply (simp add: field_simps) apply (erule is_aligned_no_wrap') - apply (simp add: cte_level_bits_def word_bits_conv) - apply (simp add: cte_level_bits_def) + apply (simp add: cte_level_bits_def word_bits_conv) + apply (simp add: cte_level_bits_def) apply (simp add: loadObject_cte unless_def alignCheck_def is_aligned_mask[symmetric] objBits_simps' - cte_level_bits_def magnitudeCheck_def obind_def - read_magnitudeCheck_def read_alignCheck_def - omonad_defs return_def fail_def) + cte_level_bits_def magnitudeCheck_def + return_def fail_def) apply (clarsimp simp: bind_def return_def when_def fail_def split: option.splits) apply simp apply (erule(1) ps_clear_lookupAround2) - apply (subgoal_tac "p - n \ (p - n) + n", simp) - apply (erule is_aligned_no_wrap') - apply (simp add: word_bits_conv) - apply (simp add: tcb_cte_cases_def split: if_split_asm) - apply (subgoal_tac "(p - n) + n \ (p - n) + 511") - apply (simp add: field_simps) - apply (rule word_plus_mono_right) - apply (simp add: tcb_cte_cases_def split: if_split_asm) + prefer 3 + apply (simp add: loadObject_cte unless_def alignCheck_def + is_aligned_mask[symmetric] objBits_simps' + cte_level_bits_def magnitudeCheck_def + return_def fail_def tcbCTableSlot_def tcbVTableSlot_def + tcbIPCBufferSlot_def tcbReplySlot_def tcbCallerSlot_def + split: option.split_asm) + apply (clarsimp simp: bind_def tcb_cte_cases_def split: if_split_asm) + apply (clarsimp simp: bind_def tcb_cte_cases_def iffD2[OF linorder_not_less] + return_def + split: if_split_asm) + apply (subgoal_tac "p - n \ (p - n) + n", simp) apply (erule is_aligned_no_wrap') - apply simp - apply (simp add: loadObject_cte unless_def alignCheck_def - is_aligned_mask[symmetric] objBits_simps' - cte_level_bits_def magnitudeCheck_def - return_def fail_def tcbCTableSlot_def tcbVTableSlot_def - tcbFaultHandlerSlot_def tcbTimeoutHandlerSlot_def - tcbIPCBufferSlot_def omonad_defs obind_def - read_magnitudeCheck_def read_alignCheck_def - split: option.split_asm) - apply (clarsimp simp: bind_def tcb_cte_cases_def split: if_split_asm) - apply (clarsimp simp: bind_def tcb_cte_cases_def iffD2[OF linorder_not_less] - return_def - split: if_split_asm) + apply (simp add: word_bits_conv) + apply (simp add: tcb_cte_cases_def split: if_split_asm) + apply (subgoal_tac "(p - n) + n \ (p - n) + 511") + apply (simp add: field_simps) + apply (rule word_plus_mono_right) + apply (simp add: tcb_cte_cases_def split: if_split_asm) + apply (erule is_aligned_no_wrap') + apply simp done lemma tcb_at_cte_at': "tcb_at' t s \ cte_at' t s" - apply (clarsimp simp add: cte_wp_at_cases' obj_at'_def projectKO_def oassert_opt_def + apply (clarsimp simp add: cte_wp_at_cases' obj_at'_def projectKO_def del: disjCI) apply (case_tac ko) apply (simp_all add: projectKO_opt_tcb fail_def) @@ -2624,30 +2278,14 @@ lemma obj_at_ko_at': "obj_at' P p s \ \ko. ko_at' ko p s \ P ko" by (auto simp add: obj_at'_def) -lemma ko_at_obj_at': - "\ko_at' ko ptr s; P ko\ \ - obj_at' P ptr s" - by (clarsimp simp: obj_at'_def) - -lemma obj_at_ko_at'_eq: - "(\ko. ko_at' ko p s \ P ko) = obj_at' P p s" - apply (intro iffI; clarsimp simp: obj_at_ko_at') - unfolding obj_at'_def - by blast - -lemma ko_at'_replies_of': - "ko_at' reply ptr s \ replies_of' s ptr = Some reply" - apply (clarsimp simp: obj_at'_def projectKO_eq opt_map_def) - done - lemma obj_at_aligned': - fixes P :: "'a :: pspace_storable \ bool" + fixes P :: "('a :: pspace_storable) \ bool" assumes oat: "obj_at' P p s" and oab: "\(v :: 'a) (v' :: 'a). objBits v = objBits v'" shows "is_aligned p (objBits (obj :: 'a))" using oat apply (clarsimp simp add: obj_at'_def) - apply (clarsimp simp add: projectKO_def fail_def return_def oassert_opt_def + apply (clarsimp simp add: projectKO_def fail_def return_def project_inject objBits_def[symmetric] split: option.splits) apply (erule subst[OF oab]) @@ -2661,65 +2299,76 @@ lemma locateSlot_conv: x \ stateAssert (\s. case (gsCNodes s A) of None \ False | Some n \ n = bits \ B < 2 ^ n) []; locateSlotBasic A B od)" "locateSlotCap c B = (do - x \ stateAssert (\s. - ( - (isCNodeCap c - \ (isZombie c \ capZombieType c \ ZombieTCB)) - \ (case gsCNodes s (capUntypedPtr c) of - None \ False + x \ stateAssert (\s. ((isCNodeCap c \ (isZombie c \ capZombieType c \ ZombieTCB)) + \ (case gsCNodes s (capUntypedPtr c) of None \ False | Some n \ (isCNodeCap c \ n = capCNodeBits c - \ isZombie c \ n = zombieCTEBits (capZombieType c)) \ B < 2 ^ n) - ) - \ isThreadCap c - \ (isZombie c \ capZombieType c = ZombieTCB)) []; + \ isZombie c \ n = zombieCTEBits (capZombieType c)) \ B < 2 ^ n)) + \ isThreadCap c \ (isZombie c \ capZombieType c = ZombieTCB)) []; locateSlotBasic (capUntypedPtr c) B od)" apply (simp_all add: locateSlotCap_def locateSlotTCB_def fun_eq_iff) apply (simp add: locateSlotBasic_def objBits_simps cte_level_bits_def objBits_defs) apply (simp add: locateSlotCNode_def stateAssert_def) - apply (cases c; simp) - by (auto simp: locateSlotCNode_def isZombie_def isThreadCap_def - isCNodeCap_def capUntypedPtr_def stateAssert_def - bind_assoc exec_get locateSlotTCB_def assert_def - objBits_simps' - split: zombie_type.split option.split) - -context -begin - -private method typ_at_proof = - unfold obj_at'_real_def typ_at'_def ko_wp_at'_def, - (rule ext)+, - (rule iffI; clarsimp, case_tac ko; clarsimp simp: projectKO_opts_defs) + apply (cases c, simp_all add: locateSlotCNode_def isZombie_def isThreadCap_def + isCNodeCap_def capUntypedPtr_def stateAssert_def + bind_assoc exec_get locateSlotTCB_def + objBits_simps' + split: zombie_type.split + cong: option.case_cong) + done lemma typ_at_tcb': "typ_at' TCBT = tcb_at'" - by typ_at_proof + apply (rule ext)+ + apply (simp add: obj_at'_real_def typ_at'_def) + apply (simp add: ko_wp_at'_def) + apply (rule iffI) + apply clarsimp + apply (case_tac ko) + apply (auto simp: projectKO_opt_tcb)[9] + apply (case_tac ko) + apply (auto simp: projectKO_opt_tcb) + done -lemma typ_at_ep: (* FIXME: rename to ' *) +lemma typ_at_ep: "typ_at' EndpointT = ep_at'" - by typ_at_proof + apply (rule ext)+ + apply (simp add: obj_at'_real_def typ_at'_def) + apply (simp add: ko_wp_at'_def) + apply (rule iffI) + apply clarsimp + apply (case_tac ko) + apply (auto simp: projectKO_opt_ep)[9] + apply (case_tac ko) + apply (auto simp: projectKO_opt_ep) + done -lemma typ_at_ntfn: (* FIXME: rename to ' *) +lemma typ_at_ntfn: "typ_at' NotificationT = ntfn_at'" - by typ_at_proof + apply (rule ext)+ + apply (simp add: obj_at'_real_def typ_at'_def) + apply (simp add: ko_wp_at'_def) + apply (rule iffI) + apply clarsimp + apply (case_tac ko) + apply (auto simp: projectKO_opt_ntfn)[8] + apply clarsimp + apply (case_tac ko) + apply (auto simp: projectKO_opt_ntfn) + done -lemma typ_at_cte: (* FIXME: rename to ' *) +lemma typ_at_cte: "typ_at' CTET = real_cte_at'" - by typ_at_proof - -lemma typ_at_reply': - "typ_at' ReplyT = reply_at'" - by typ_at_proof - -lemma typ_at_sc': - "typ_at' SchedContextT = sc_at'" - by typ_at_proof - -lemmas typ_ats' = typ_at_sc' typ_at_reply' typ_at_cte typ_at_ntfn typ_at_ep typ_at_tcb' - -end - - + apply (rule ext)+ + apply (simp add: obj_at'_real_def typ_at'_def) + apply (simp add: ko_wp_at'_def) + apply (rule iffI) + apply clarsimp + apply (case_tac ko) + apply (auto simp: projectKO_opt_cte)[8] + apply clarsimp + apply (case_tac ko) + apply (auto simp: projectKO_opt_cte) + done lemma cte_at_typ': "cte_at' c = (\s. typ_at' CTET c s \ (\n. typ_at' TCBT (c - n) s \ n \ dom tcb_cte_cases))" @@ -2730,213 +2379,58 @@ proof - have Q: "\P f. (\x. (\y. x = f y) \ P x) = (\y. P (f y))" by fastforce show ?thesis - by (fastforce simp: cte_wp_at_cases' obj_at'_real_def typ_at'_def word_bits_def + by (fastforce simp: cte_wp_at_cases' obj_at'_real_def typ_at'_def ko_wp_at'_def objBits_simps' P Q conj_comms cte_level_bits_def) qed -lemma typ_at_lift_tcb'_strong: - "f \\s. P (typ_at' TCBT p s)\ \ f \\s. P (tcb_at' p s)\" +lemma typ_at_lift_tcb': + "\typ_at' TCBT p\ f \\_. typ_at' TCBT p\ \ \tcb_at' p\ f \\_. tcb_at' p\" by (simp add: typ_at_tcb') -lemma typ_at_lift_ep'_strong: - "f \\s. P (typ_at' EndpointT p s)\ \ f \\s. P (ep_at' p s)\" +lemma typ_at_lift_ep': + "\typ_at' EndpointT p\ f \\_. typ_at' EndpointT p\ \ \ep_at' p\ f \\_. ep_at' p\" by (simp add: typ_at_ep) -lemma typ_at_lift_ntfn'_strong: - "f \\s. P (typ_at' NotificationT p s)\ \ f \\s. P (ntfn_at' p s)\" +lemma typ_at_lift_ntfn': + "\typ_at' NotificationT p\ f \\_. typ_at' NotificationT p\ \ \ntfn_at' p\ f \\_. ntfn_at' p\" by (simp add: typ_at_ntfn) -lemma typ_at_lift_cte'_strong: - "f \\s. P (typ_at' CTET p s)\ \ f \\s. P (real_cte_at' p s)\" +lemma typ_at_lift_cte': + "\typ_at' CTET p\ f \\_. typ_at' CTET p\ \ \real_cte_at' p\ f \\_. real_cte_at' p\" by (simp add: typ_at_cte) -lemma typ_at_lift_sc'_strong: - "f \\s. P (typ_at' SchedContextT p s)\ \ f \\s. P (sc_at' p s)\" - by (simp add: typ_ats') - -lemma typ_at_lift_reply'_strong: - "f \\s. P (typ_at' ReplyT p s)\ \ f \\s. P (reply_at' p s)\" - by (simp add: typ_ats') - lemma typ_at_lift_cte_at': - assumes x: "\P T p. f \\s. P (typ_at' T p s)\" - shows "f \\s. P (cte_at' c s)\" + assumes x: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" + shows "\cte_at' c\ f \\rv. cte_at' c\" apply (simp only: cte_at_typ') - apply (rule P_bool_lift[where P=P]) - apply (wpsimp wp: hoare_vcg_disj_lift hoare_vcg_ex_lift hoare_vcg_all_lift x)+ + apply (wp hoare_vcg_disj_lift hoare_vcg_ex_lift x) done -lemma typ_at_lift_page_directory_at'_strong: - assumes x: "\P p. f \\s. P (typ_at' (ArchT PDET) p s)\" - shows "f \\s. P (page_directory_at' p s)\" +lemma typ_at_lift_page_directory_at': + assumes x: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" + shows "\page_directory_at' p\ f \\rv. page_directory_at' p\" unfolding page_directory_at'_def All_less_Ball - using x - apply - - apply (rule P_bool_lift[where P=P]) - apply (wpsimp wp: hoare_vcg_const_Ball_lift hoare_vcg_bex_lift hoare_vcg_imp_lift - | fastforce)+ - done + by (wp hoare_vcg_const_Ball_lift x) -lemma typ_at_lift_page_table_at'_strong: - assumes x: "\P p. f \\s. P (typ_at' (ArchT PTET) p s)\" - shows "f \\s. P (page_table_at' p s)\" +lemma typ_at_lift_page_table_at': + assumes x: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" + shows "\page_table_at' p\ f \\rv. page_table_at' p\" unfolding page_table_at'_def All_less_Ball - using x - apply - - apply (rule P_bool_lift[where P=P]) - apply (wpsimp wp: hoare_vcg_const_Ball_lift hoare_vcg_bex_lift hoare_vcg_imp_lift - | fastforce)+ - 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 - -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_page_directory_at'_strong - typ_at_lift_valid_tcb_state'_strong - typ_at_lift_page_table_at'_strong + by (wp hoare_vcg_const_Ball_lift x) lemma ko_wp_typ_at': "ko_wp_at' P p s \ \T. typ_at' T p s" by (clarsimp simp: typ_at'_def ko_wp_at'_def) lemma koType_obj_range': - "koTypeOf k = koTypeOf k' \ koTypeOf k = SchedContextT \ objBitsKO k = objBitsKO k' \ obj_range' p k = obj_range' p k'" + "koTypeOf k = koTypeOf k' \ obj_range' p k = obj_range' p k'" apply (rule ccontr) apply (simp add: obj_range'_def objBitsKO_def archObjSize_def split: kernel_object.splits arch_kernel_object.splits) done -lemma typ_at_lift_valid_irq_node': - assumes P: "\P T p. \\s. P (typ_at' T p s)\ f \\rv s. P (typ_at' T p s)\" - shows "\valid_irq_node' p\ f \\_. valid_irq_node' p\" - apply (simp add: valid_irq_node'_def) - apply (wp hoare_vcg_all_lift P typ_at_lifts_strong) - done - -lemma valid_pde_lift': - assumes x: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" - shows "\\s. valid_pde' pde s\ f \\rv s. valid_pde' pde s\" - by (cases pde) (simp add: valid_mapping'_def|wp x typ_at_lifts_strong[where P=id])+ - -lemma valid_pte_lift': - assumes x: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" - shows "\\s. valid_pte' pte s\ f \\rv s. valid_pte' pte s\" - by (cases pte) (simp add: valid_mapping'_def|wp x typ_at_lifts_strong[where P=id])+ - -lemma valid_asid_pool_lift': - assumes x: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" - shows "\\s. valid_asid_pool' ap s\ f \\rv s. valid_asid_pool' ap s\" - by (cases ap) (simp|wp x typ_at_lifts_strong[where P=id] hoare_vcg_const_Ball_lift)+ - -lemma valid_dom_schedule'_lift: - assumes dsi: "\Q. \\s. Q (ksDomScheduleIdx s)\ f \\rv s. Q (ksDomScheduleIdx s)\" - assumes ds: "\Q. \\s. Q (ksDomSchedule s)\ f \\rv s. Q (ksDomSchedule s)\" - shows "\\s. valid_dom_schedule' s\ f \\rv. valid_dom_schedule'\" - unfolding valid_dom_schedule'_def - 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) - -lemma valid_bound_sc_lift: - "(\T p. f \typ_at' T p\) \ f \valid_bound_sc' tcb\" - 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\" - 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\" - 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\" - 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 - -lemma valid_sc_lift': - "(\T p. f \typ_at' T p\) \ 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) - -context begin -\\ - We're using @{command ML_goal} here because there are two useful formulations - of typ_at lifting lemmas and we do not want to write all of the possibilities - out by hand. If we use typ_at_lift_tcb' as an example, then the first is - @{term "\\s. P (typ_at' TCBT p s)\ f \\_ s. P (typ_at' TCBT p s)\ - \ \\s. P (tcb_at' p s)\ f \\_ s. P (tcb_at' p s)\"} and the second is - @{term "(\P. \\s. P (typ_at' TCBT p s)\ f \\_ s. P (typ_at' TCBT p s)\) - \ \\s. P (tcb_at' p s)\ f \\_ s. P (tcb_at' p s)\"}. - The first form is stronger, and therefore preferred for backward reasoning - using rule. However, since the P in the premise is free in the first form, - forward unification using the OF attribute produces flex-flex pairs which - causes problems. The second form avoids the unification issue by demanding - that there is a P that is free in the lemma supplied to the OF attribute. - However, it can only be applied if @{term f} preserves both - @{term "typ_at' TCBT p s"} and @{term "\ typ_at' TCBT p s"}. - The following @{command ML_goal} generates lemmas of the second form based on - the previously proven stronger lemmas of the first form. -\ -ML \ -local - val strong_thms = @{thms typ_at_lifts_strong[no_vars]}; - fun abstract_P term = Logic.all (Free ("P", @{typ "bool \ bool"})) term - fun abstract thm = - let - val prems = List.map abstract_P (Thm.prems_of thm); - fun imp [] = Thm.concl_of thm - | imp (p :: pms) = @{const Pure.imp} $ p $ imp pms - in - imp prems - end -in - val typ_at_lifts_internal_goals = List.map abstract strong_thms -end -\ - -private ML_goal typ_at_lifts_internal: - \typ_at_lifts_internal_goals\ - by (auto simp: typ_at_lifts_strong) - -lemmas typ_at_lifts = typ_at_lifts_internal - typ_at_lift_cte_at' - valid_pde_lift' - valid_pte_lift' - valid_asid_pool_lift' - valid_bound_tcb_lift - valid_bound_reply_lift - valid_bound_sc_lift - valid_bound_ntfn_lift - valid_ntfn_lift' - valid_sc_lift' -end - lemma typ_at_lift_valid_untyped': assumes P: "\T p. \\s. \typ_at' T p s\ f \\rv s. \typ_at' T p s\" - assumes sz: "\p n. \\s. sc_at'_n n p s\ f \\rv s. sc_at'_n n p s\" shows "\\s. valid_untyped' d p n idx s\ f \\rv s. valid_untyped' d p n idx s\" apply (clarsimp simp: valid_untyped'_def split del:if_split) apply (rule hoare_vcg_all_lift) @@ -2953,112 +2447,81 @@ lemma typ_at_lift_valid_untyped': apply (clarsimp simp: typ_at'_def ko_wp_at'_def simp del:atLeastAtMost_iff) apply (elim disjE) apply (clarsimp simp:psubset_eq simp del:atLeastAtMost_iff) - apply (frule_tac p=ptr' in koType_obj_range', clarsimp) - apply (fastforce simp: ko_wp_at'_def dest!: use_valid [OF _ sz]) + apply (drule_tac p=ptr' in koType_obj_range') + apply (erule impE) + apply simp apply simp - apply (frule_tac p = ptr' in koType_obj_range', clarsimp) - apply (fastforce simp: ko_wp_at'_def dest!: use_valid [OF _ sz]) - apply simp + apply (drule_tac p = ptr' in koType_obj_range') + apply (clarsimp split:if_splits) done +lemma typ_at_lift_asid_at': + "(\T p. \typ_at' T p\ f \\_. typ_at' T p\) \ \asid_pool_at' p\ f \\_. asid_pool_at' p\" + by assumption + lemma typ_at_lift_valid_cap': assumes P: "\P T p. \\s. P (typ_at' T p s)\ f \\rv s. P (typ_at' T p s)\" - assumes sz: "\p n. \\s. sc_at'_n n p s\ f \\rv s. sc_at'_n n p s\" shows "\\s. valid_cap' cap s\ f \\rv s. valid_cap' cap s\" including no_pre apply (simp add: valid_cap'_def) apply wp apply (case_tac cap; - wpsimp wp: valid_cap'_def P typ_at_lifts_strong - hoare_vcg_prop typ_at_lift_cte_at' - hoare_vcg_conj_lift [OF typ_at_lift_cte_at'] - hoare_vcg_conj_lift) + simp add: valid_cap'_def P [where P=id, simplified] typ_at_lift_tcb' + hoare_vcg_prop typ_at_lift_ep' + typ_at_lift_ntfn' typ_at_lift_cte_at' + hoare_vcg_conj_lift [OF typ_at_lift_cte_at']) apply (rename_tac zombie_type nat) apply (case_tac zombie_type; simp) - apply (wp typ_at_lifts_strong[where P=id, simplified] P - hoare_vcg_all_lift)+ + apply (wp typ_at_lift_tcb' P hoare_vcg_all_lift typ_at_lift_cte')+ apply (rename_tac arch_capability) apply (case_tac arch_capability, simp_all add: P [where P=id, simplified] page_table_at'_def hoare_vcg_prop page_directory_at'_def All_less_Ball split del: if_split) - apply (wp hoare_vcg_const_Ball_lift P typ_at_lift_valid_untyped' sz - hoare_vcg_all_lift typ_at_lifts_strong)+ + apply (wp hoare_vcg_const_Ball_lift P typ_at_lift_valid_untyped' + hoare_vcg_all_lift typ_at_lift_cte')+ done -lemma typ_at'_valid_obj'_lift: - assumes P: "\P T p. \\s. P (typ_at' T p s)\ f \\rv s. P (typ_at' T p s)\" - assumes sz: "\n p. \\s. sc_at'_n n p s\ f \\rv s. sc_at'_n n p s\" - notes [wp] = hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_const_Ball_lift - typ_at_lifts[OF P] typ_at_lift_valid_cap'[OF P] - shows "\\s. valid_obj' obj s\ f \\rv s. valid_obj' obj s\" - 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; - wpsimp wp: sz) - apply (wpsimp simp: valid_cte'_def sz) - apply (rename_tac arch_kernel_object) - apply (case_tac arch_kernel_object; wpsimp wp: sz) - apply wpsimp - apply (wpsimp simp: valid_reply'_def) - done -lemma typ_at'_valid_sched_context'_lift: +lemma typ_at_lift_valid_irq_node': assumes P: "\P T p. \\s. P (typ_at' T p s)\ f \\rv s. P (typ_at' T p s)\" - assumes sz: "\n p. \\s. sc_at'_n n p s\ f \\rv s. sc_at'_n n p s\" - notes [wp] = hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_const_Ball_lift - typ_at_lifts[OF P] typ_at_lift_valid_cap'[OF P] - shows "\\s. valid_sched_context' ko s\ f \\rv s. valid_sched_context' ko s\" - by (wpsimp simp: valid_sched_context'_def) - -lemmas typ_at_sc_at'_n_lifts = - typ_at_lift_valid_untyped' typ_at_lift_valid_cap' typ_at'_valid_obj'_lift - typ_at'_valid_obj'_lift[where obj="KOEndpoint ko" for ko, simplified valid_obj'_def kernel_object.case] - typ_at'_valid_obj'_lift[where obj="KONotification ko" for ko, simplified valid_obj'_def kernel_object.case] - typ_at'_valid_obj'_lift[where obj="KOTCB ko" for ko, simplified valid_obj'_def kernel_object.case] - typ_at'_valid_obj'_lift[where obj="KOCTE ko" for ko, simplified valid_obj'_def kernel_object.case] - typ_at'_valid_obj'_lift[where obj="KOArch ko" for ko, simplified valid_obj'_def kernel_object.case] - typ_at'_valid_obj'_lift[where obj="KOReply ko" for ko, simplified valid_obj'_def kernel_object.case] - typ_at'_valid_sched_context'_lift - -lemmas typ_at_lifts_all = typ_at_lifts typ_at_sc_at'_n_lifts - -end - -locale typ_at_props' = - fixes f :: "'a kernel" - assumes typ': "f \\s. P (typ_at' T p' s)\" -begin - -lemmas typ_at_lifts'[wp] = typ_at_lifts[REPEAT [OF typ']] - -end + shows "\valid_irq_node' p\ f \\_. valid_irq_node' p\" + apply (simp add: valid_irq_node'_def) + apply (wp hoare_vcg_all_lift P typ_at_lift_cte') + done -locale typ_at_all_props' = typ_at_props' + - assumes scs: "f \\s. Q (sc_at'_n n p s)\" -begin +lemma valid_pde_lift': + assumes x: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" + shows "\\s. valid_pde' pde s\ f \\rv s. valid_pde' pde s\" + by (cases pde) (simp add: valid_mapping'_def|wp x typ_at_lift_page_table_at')+ -lemmas typ_at_sc_at'_n_lifts'[wp] = typ_at_sc_at'_n_lifts[OF typ' scs] -lemmas typ_at_lifts_all' = typ_at_lifts' typ_at_sc_at'_n_lifts' +lemma valid_pte_lift': + assumes x: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" + shows "\\s. valid_pte' pte s\ f \\rv s. valid_pte' pte s\" + by (cases pte) (simp add: valid_mapping'_def|wp x typ_at_lift_page_directory_at')+ -context begin -(* We want to enforce that typ_at_lifts_all' only contains lemmas that have no - assumptions. The following thm statements should fail if this is not true. *) -private lemmas check_valid_internal = iffD1[OF refl, where P="valid p g q" for p g q] -thm typ_at_lifts_all'[atomized, THEN check_valid_internal] -end +lemma valid_asid_pool_lift': + assumes x: "\T p. \typ_at' T p\ f \\rv. typ_at' T p\" + shows "\\s. valid_asid_pool' ap s\ f \\rv s. valid_asid_pool' ap s\" + by (cases ap) (simp|wp x typ_at_lift_page_directory_at' hoare_vcg_const_Ball_lift)+ -end +lemma valid_bound_tcb_lift: + "(\T p. \typ_at' T p\ f \\_. typ_at' T p\) \ + \valid_bound_tcb' tcb\ f \\_. valid_bound_tcb' tcb\" + by (auto simp: valid_bound_tcb'_def valid_def typ_at_tcb'[symmetric] split: option.splits) -(* we expect typ_at' and sc_at'_n lemmas to be [wp], so this should be easy: *) -method typ_at_props' = unfold_locales; wp? +lemmas typ_at_lifts = typ_at_lift_tcb' typ_at_lift_ep' + typ_at_lift_ntfn' typ_at_lift_cte' + typ_at_lift_cte_at' + typ_at_lift_page_table_at' + typ_at_lift_page_directory_at' + typ_at_lift_asid_at' + typ_at_lift_valid_untyped' + typ_at_lift_valid_cap' + valid_pde_lift' + valid_pte_lift' + valid_asid_pool_lift' + valid_bound_tcb_lift lemma mdb_next_unfold: "s \ c \ c' = (\z. s c = Some z \ c' = mdbNext (cteMDBNode z))" @@ -3211,7 +2674,8 @@ lemma valid_mdb_ctesE [elim]: \ valid_dlist m; no_0 m; mdb_chain_0 m; valid_badges m; caps_contained' m; mdb_chunked m; untyped_mdb' m; untyped_inc' m; valid_nullcaps m; ut_revocable' m; - class_links m; distinct_zombies m; irq_control m \ + class_links m; distinct_zombies m; irq_control m; + reply_masters_rvk_fb m \ \ P\ \ P" unfolding valid_mdb_ctes_def by auto @@ -3219,10 +2683,12 @@ lemma valid_mdb_ctesI [intro]: "\valid_dlist m; no_0 m; mdb_chain_0 m; valid_badges m; caps_contained' m; mdb_chunked m; untyped_mdb' m; untyped_inc' m; valid_nullcaps m; ut_revocable' m; - class_links m; distinct_zombies m; irq_control m \ + class_links m; distinct_zombies m; irq_control m; + reply_masters_rvk_fb m \ \ valid_mdb_ctes m" unfolding valid_mdb_ctes_def by auto +end locale PSpace_update_eq = fixes f :: "kernel_state \ kernel_state" assumes pspace: "ksPSpace (f s) = ksPSpace s" @@ -3262,18 +2728,6 @@ lemma valid_objs_update [iff]: apply (fastforce intro: valid_obj'_pspaceI simp: pspace) done -lemma valid_objs_size_update [iff]: - "valid_objs_size' (f s) = valid_objs_size' s" - apply (simp add: valid_objs_size'_def pspace) - apply (fastforce intro: valid_obj_size'_pspaceI simp: pspace) - done - -lemma valid_replies'_update [iff]: - "valid_replies' (f s) = valid_replies' s" - apply (simp add: valid_replies'_def pspace) - apply (auto simp: pspace pred_tcb_at'_def) - done - lemma pspace_aligned_update [iff]: "pspace_aligned' (f s) = pspace_aligned' s" by (simp add: pspace pspace_aligned'_def) @@ -3282,14 +2736,6 @@ lemma pspace_distinct_update [iff]: "pspace_distinct' (f s) = pspace_distinct' s" by (simp add: pspace pspace_distinct'_def ps_clear_def) -lemma pspace_bounded_update [iff]: - "pspace_bounded' (f s) = pspace_bounded' s" - by (simp add: pspace pspace_bounded'_def) - -lemma pspace_no_overlap'_update [iff]: - "pspace_no_overlap' p sz (f s) = pspace_no_overlap' p sz s" - by (simp add: pspace pspace_no_overlap'_def ps_clear_def) - lemma pred_tcb_at_update [iff]: "pred_tcb_at' proj P p (f s) = pred_tcb_at' proj P p s" by (simp add: pred_tcb_at'_def) @@ -3438,26 +2884,6 @@ interpretation ready_queue_bitmap2_update: P_Arch_Idle_Int_Cur_update_eq "ksReadyQueuesL2Bitmap_update f" by unfold_locales auto -interpretation reprogramTime_update: - P_Arch_Idle_Int_Cur_update_eq "ksReprogramTimer_update f" - by unfold_locales auto - -interpretation ksReleaseQueue_update: - P_Arch_Idle_Int_Cur_update_eq "ksReleaseQueue_update f" - by unfold_locales auto - -interpretation ksConsumedTime_update: - P_Arch_Idle_Int_Cur_update_eq "ksConsumedTime_update f" - by unfold_locales auto - -interpretation ksCurTime_update: - P_Arch_Idle_Int_Cur_update_eq "ksCurTime_update f" - by unfold_locales auto - -interpretation ksCurSc_update: - P_Arch_Idle_Int_Cur_update_eq "ksCurSc_update f" - by unfold_locales auto - interpretation cur_thread_update': P_Arch_Idle_Int_update_eq "ksCurThread_update f" by unfold_locales auto @@ -3515,11 +2941,6 @@ lemma ko_wp_at_norm: "ko_wp_at' P p s \ \ko. P ko \ ko_wp_at' ((=) ko) p s" by (auto simp add: ko_wp_at'_def) -lemma ko_at_ko_wp_atD': - "\ko_at' ko p s; ko_wp_at' P p s\ \ P (injectKO ko)" - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKO_eq project_inject) - done - lemma valid_mdb_machine_state [iff]: "valid_mdb' (ksMachineState_update f s) = valid_mdb' s" by (simp add: valid_mdb'_def) @@ -3532,10 +2953,6 @@ lemma pred_tcb_at' [elim!]: "pred_tcb_at' proj P t s \ tcb_at' t s" by (auto simp add: pred_tcb_at'_def obj_at'_def) -lemma pred_tcb_at'_True[simp]: - "pred_tcb_at' proj \ p s = tcb_at' p s" - by (clarsimp simp: pred_tcb_at'_def obj_at'_def) - lemma valid_pspace_mdb' [elim!]: "valid_pspace' s \ valid_mdb' s" by (simp add: valid_pspace'_def) @@ -3553,8 +2970,7 @@ lemma ex_cte_cap_to'_pres: apply assumption apply simp done - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma page_directory_pde_atI': "\ page_directory_at' p s; x < 2 ^ pageBits \ \ pde_at' (p + (x << 2)) s" by (simp add: page_directory_at'_def pageBits_def) @@ -3639,14 +3055,6 @@ lemma valid_bitmaps_arch[simp]: "valid_bitmaps (ksArchState_update f s) = valid_bitmaps s" by (simp add: valid_bitmaps_def bitmapQ_defs) -lemma valid_release_queue_arch [simp]: - "valid_release_queue (ksArchState_update f s) = valid_release_queue s" - by (simp add: valid_release_queue_def) - -lemma valid_release_queue'_arch [simp]: - "valid_release_queue' (ksArchState_update f s) = valid_release_queue' s" - by (simp add: valid_release_queue'_def) - lemma if_unsafe_then_cap_arch' [simp]: "if_unsafe_then_cap' (ksArchState_update f s) = if_unsafe_then_cap' s" by (simp add: if_unsafe_then_cap'_def ex_cte_cap_to'_def) @@ -3700,14 +3108,6 @@ lemma valid_pspace_valid_objs'[elim!]: "valid_pspace' s \ valid_objs' s" by (simp add: valid_pspace'_def) -lemma valid_pspace_valid_replies'[elim!]: - "valid_pspace' s \ valid_replies' s" - by (simp add: valid_pspace'_def) - -lemma valid_pspace_valid_objs_size'[elim!]: - "valid_pspace' s \ valid_objs_size' s" - by (simp add: valid_pspace'_def valid_objs'_valid_objs_size') - declare badgeBits_def [simp] lemma simple_sane_strg: @@ -3729,14 +3129,12 @@ lemma vms_sch_act_update'[iff]: "valid_machine_state' (ksSchedulerAction_update f s) = valid_machine_state' s" by (simp add: valid_machine_state'_def ) - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma objBitsT_simps: "objBitsT EndpointT = epSizeBits" "objBitsT NotificationT = ntfnSizeBits" "objBitsT CTET = cteSizeBits" "objBitsT TCBT = tcbBlockSizeBits" - "objBitsT ReplyT = replySizeBits" "objBitsT UserDataT = pageBits" "objBitsT UserDataDeviceT = pageBits" "objBitsT KernelDataT = pageBits" @@ -3791,29 +3189,6 @@ lemma not_pred_tcb_at'_strengthen: "pred_tcb_at' f (Not \ P) p s \ \ pred_tcb_at' f P p s" by (clarsimp simp: pred_tcb_at'_def obj_at'_def) -lemma obj_at'_imp: - fixes P Q :: "'a :: pspace_storable \ bool" - shows - "(obj_at' (\rv. P rv \ Q rv) p s) = - (obj_at' (\_ :: 'a. True) p s \ (obj_at' P p s \ obj_at' Q p s))" - apply (rule iffI; clarsimp simp: obj_at'_def) - done - -lemma pred_tcb_at'_imp: - "pred_tcb_at' field (\rv. P rv \ Q rv) p s = - (tcb_at' p s \ (pred_tcb_at' field P p s \ pred_tcb_at' field Q p s))" - apply (rule iffI; clarsimp simp: obj_at'_def pred_tcb_at'_def) - done - -lemma valid_queues_no_bitmap_def': - "valid_queues_no_bitmap = - (\s. \d p. (\t\set (ksReadyQueues s (d, p)). obj_at' (inQ d p) t s) \ - (d > maxDomain \ p > maxPriority \ ksReadyQueues s (d,p) = []))" - apply (rule ext, rule iffI) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_and pred_tcb_at'_def o_def - elim!: obj_at'_weakenE)+ - done - lemma valid_refs'_cteCaps: "valid_refs' S (ctes_of s) = (\c \ ran (cteCaps_of s). S \ capRange c = {})" by (fastforce simp: valid_refs'_def cteCaps_of_def elim!: ranE) @@ -3832,41 +3207,41 @@ lemma cte_at_valid_cap_sizes_0: apply simp done +lemma invs_valid_stateI' [elim!]: + "invs' s \ valid_state' s" + by (simp add: invs'_def) + +lemma tcb_at_invs' [elim!]: + "invs' s \ tcb_at' (ksCurThread s) s" + by (simp add: invs'_def cur_tcb'_def) + lemma invs_valid_objs' [elim!]: "invs' s \ valid_objs' s" - by (simp add: invs'_def valid_pspace'_def) - -lemma invs_valid_objs_size' [elim!]: - "invs' s \ valid_objs_size' s" - by (fastforce simp: invs'_def) + by (simp add: invs'_def valid_state'_def valid_pspace'_def) lemma invs_pspace_aligned' [elim!]: "invs' s \ pspace_aligned' s" - by (simp add: invs'_def valid_pspace'_def) + by (simp add: invs'_def valid_state'_def valid_pspace'_def) lemma invs_pspace_distinct' [elim!]: "invs' s \ pspace_distinct' s" - by (simp add: invs'_def valid_pspace'_def) - -lemma invs_pspace_bounded' [elim!]: - "invs' s \ pspace_bounded' s" - by (simp add: invs'_def valid_pspace'_def) + by (simp add: invs'_def valid_state'_def valid_pspace'_def) lemma invs_valid_pspace' [elim!]: "invs' s \ valid_pspace' s" - by (simp add: invs'_def) + by (simp add: invs'_def valid_state'_def) lemma invs_arch_state' [elim!]: "invs' s \ valid_arch_state' s" + by (simp add: invs'_def valid_state'_def) + +lemma invs_cur' [elim!]: + "invs' s \ cur_tcb' s" by (simp add: invs'_def) lemma invs_mdb' [elim!]: "invs' s \ valid_mdb' s" - by (simp add: invs'_def valid_pspace'_def) - -lemma invs_valid_replies'[elim!]: - "invs' s \ valid_replies' s" - by (simp add: invs'_def valid_pspace'_def) + by (simp add: invs'_def valid_state'_def valid_pspace'_def) lemma valid_mdb_no_loops [elim!]: "valid_mdb_ctes m \ no_loops m" @@ -3875,16 +3250,24 @@ lemma valid_mdb_no_loops [elim!]: lemma invs_no_loops [elim!]: "invs' s \ no_loops (ctes_of s)" apply (rule valid_mdb_no_loops) - apply (simp add: invs'_def valid_pspace'_def valid_mdb'_def) + apply (simp add: invs'_def valid_state'_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) + by (simp add: invs'_def valid_state'_def) lemma invs_unsafe_then_cap' [elim!]: "invs' s \ if_unsafe_then_cap' s" - by (simp add: invs'_def) + by (simp add: invs'_def valid_state'_def) + +lemma invs_sym' [elim!]: + "invs' s \ sym_refs (state_refs_of' s)" + by (simp add: invs'_def valid_state'_def) + +lemma invs_sch_act_wf' [elim!]: + "invs' s \ sch_act_wf (ksSchedulerAction s) s" + by (simp add: invs'_def valid_state'_def) lemma invs_valid_bitmaps[elim!]: "invs' s \ valid_bitmaps s" @@ -3898,25 +3281,17 @@ lemma invs_valid_sched_pointers[elim!]: "invs' s \ valid_sched_pointers s" by (simp add: invs'_def valid_state'_def) -lemma invs_queues'[elim!]: - "invs' s \ valid_queues' s" - by (simp add: invs'_def) - -lemma invs_valid_release_queue [elim!]: - "invs' s \ valid_release_queue s" - by (simp add: invs'_def) - -lemma invs_valid_release_queue' [elim!]: - "invs' s \ valid_release_queue' s" - by (simp add: invs'_def) - -lemma invs_sym_list_refs_of_replies'[elim!]: - "invs' s \ sym_refs (list_refs_of_replies' s)" - by (simp add: invs'_def) +lemma invs_valid_idle'[elim!]: + "invs' s \ valid_idle' s" + by (fastforce simp: invs'_def valid_state'_def) lemma invs_valid_global'[elim!]: "invs' s \ valid_global_refs' s" - by (fastforce simp: invs'_def) + by (fastforce simp: invs'_def valid_state'_def) + +lemma invs'_invs_no_cicd: + "invs' s \ all_invs_but_ct_idle_or_in_cur_domain' s" + by (simp add: invs'_to_invs_no_cicd'_def) lemma invs'_bitmapQ_no_L1_orphans: "invs' s \ bitmapQ_no_L1_orphans s" @@ -3924,7 +3299,12 @@ lemma invs'_bitmapQ_no_L1_orphans: lemma invs_ksCurDomain_maxDomain' [elim!]: "invs' s \ ksCurDomain s \ maxDomain" - by (simp add: invs'_def) + by (simp add: invs'_def valid_state'_def) + +lemma simple_st_tcb_at_state_refs_ofD': + "st_tcb_at' simple' t s \ bound_tcb_at' (\x. tcb_bound_refs' x = state_refs_of' s t) t s" + by (fastforce simp: pred_tcb_at'_def obj_at'_def state_refs_of'_def + projectKO_eq project_inject) lemma cur_tcb_arch' [iff]: "cur_tcb' (ksArchState_update f s) = cur_tcb' s" @@ -3936,24 +3316,26 @@ lemma cur_tcb'_machine_state [simp]: lemma invs_no_0_obj'[elim!]: "invs' s \ no_0_obj' s" - by (simp add: invs'_def valid_pspace'_def) + by (simp add: invs'_def valid_state'_def valid_pspace'_def) lemma invs'_gsCNodes_update[simp]: "invs' (gsCNodes_update f s') = invs' s'" - apply (clarsimp simp: invs'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs - valid_queues'_def valid_release_queue_def valid_release_queue'_def valid_irq_node'_def - valid_irq_handlers'_def irq_issued'_def irqs_masked'_def valid_machine_state'_def - valid_dom_schedule'_def - cur_tcb'_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_bitmaps_def bitmapQ_defs + valid_irq_node'_def valid_irq_handlers'_def irq_issued'_def irqs_masked'_def + valid_machine_state'_def cur_tcb'_def) + apply (cases "ksSchedulerAction s'"; + simp add: ct_in_state'_def tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def + ct_not_inQ_def) done lemma invs'_gsUserPages_update[simp]: "invs' (gsUserPages_update f s') = invs' s'" - apply (clarsimp simp: invs'_def valid_queues_def valid_queues_no_bitmap_def - bitmapQ_defs valid_queues'_def valid_release_queue_def valid_release_queue'_def - valid_irq_node'_def valid_irq_handlers'_def irq_issued'_def irqs_masked'_def - valid_machine_state'_def cur_tcb'_def valid_dom_schedule'_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_bitmaps_def bitmapQ_defs + valid_irq_node'_def valid_irq_handlers'_def irq_issued'_def irqs_masked'_def + valid_machine_state'_def cur_tcb'_def) + apply (cases "ksSchedulerAction s'"; + simp add: ct_in_state'_def tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def + ct_not_inQ_def) done lemma pred_tcb'_neq_contra: @@ -3962,31 +3344,11 @@ lemma pred_tcb'_neq_contra: lemma invs'_ksDomSchedule: "invs' s \ KernelStateData_H.ksDomSchedule s = KernelStateData_H.ksDomSchedule (newKernelState undefined)" -unfolding invs'_def valid_dom_schedule'_def by clarsimp +unfolding invs'_def valid_state'_def by clarsimp lemma invs'_ksDomScheduleIdx: "invs' s \ KernelStateData_H.ksDomScheduleIdx s < length (KernelStateData_H.ksDomSchedule (newKernelState undefined))" -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' - invs_pspace_distinct' - invs_pspace_bounded' - invs_arch_state' - invs_valid_global' - invs_mdb' - invs_valid_objs' - invs_valid_objs_size' - invs_valid_pspace' - invs_queues - invs_queues' - invs_valid_release_queue - invs_valid_release_queue' - invs_sym_list_refs_of_replies' - invs_valid_replies' +unfolding invs'_def valid_state'_def by clarsimp lemma valid_bitmap_valid_bitmapQ_exceptE: "\ valid_bitmapQ_except d p s; bitmapQ d p s \ \ tcbQueueEmpty (ksReadyQueues s (d,p)); @@ -4055,87 +3417,14 @@ private lemma ko_at_defn_ko_wp_at': by (clarsimp simp: ko_at'_defn_def obj_at'_real_def ko_wp_at'_def project_inject) -(* FIXME: normalise_obj_at' sometimes doesn't normalise obj_at' unless you use it twice. - See VER-1364 for more details. *) -private method normalise_obj_at'_step = +method normalise_obj_at' = (clarsimp?, elim obj_at_ko_at'[folded ko_at'_defn_def, elim_format], clarsimp simp: ko_at_defn_rewr ko_at_defn_pred_tcb_at' ko_at_defn_ko_wp_at', ((drule(1) ko_at_defn_uniqueD)+)?, clarsimp simp: ko_at'_defn_def) -method normalise_obj_at' = - normalise_obj_at'_step, normalise_obj_at'_step? - end -lemma valid_replies'D: - "valid_replies' s \ is_reply_linked rptr s - \ \tptr. replyTCBs_of s rptr = Some tptr - \ st_tcb_at' ((=) (BlockedOnReply (Some rptr))) tptr s" - apply (clarsimp simp: valid_replies'_def) - apply (drule_tac x=rptr in spec) - apply fastforce - done - -lemma valid_replies'_no_tcb: - "\replyTCBs_of s rptr = None; valid_replies' s\ - \ \ is_reply_linked rptr s" - by (force simp: valid_replies'_def opt_map_def) - -lemma valid_replies'_other_state: - "\replyTCBs_of s rptr = Some tptr; - st_tcb_at' P tptr s; \ P (BlockedOnReply (Some rptr)); - valid_replies' s\ - \ \ is_reply_linked rptr s" - apply (clarsimp simp: valid_replies'_def) - apply (drule_tac x=rptr in spec) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def)+ - done - -lemma valid_replies'_sc_asrtD: - "valid_replies'_sc_asrt rptr s \ replySCs_of s rptr \ None - \ (\tptr. replyTCBs_of s rptr = Some tptr - \ st_tcb_at' ((=) (BlockedOnReply (Some rptr))) tptr s)" - by (clarsimp simp: valid_replies'_sc_asrt_def) - -lemma valid_replies'_sc_asrt_replySC_None: - "\valid_replies'_sc_asrt rptr s; replyTCBs_of s rptr = Some tptr; - st_tcb_at' P tptr s; \ P (BlockedOnReply (Some rptr))\ - \ replySCs_of s rptr = None" - by (force simp: valid_replies'_sc_asrt_def pred_tcb_at'_def obj_at'_def) - -lemma valid_replies'_no_tcb_not_linked: - "\replyTCBs_of s replyPtr = None; - valid_replies' s; valid_replies'_sc_asrt replyPtr s\ - \ \ is_reply_linked replyPtr s \ replySCs_of s replyPtr = None" - apply (clarsimp simp: valid_replies'_def valid_replies'_sc_asrt_def) - apply (drule_tac x=replyPtr in spec) - apply clarsimp - done - -lemma valid_replies'_sc_asrt_lift: - assumes x: "\P. f \\s. P (replySCs_of s)\" - assumes y: "\P. f \\s. P (replyTCBs_of s)\" - assumes z: "\rptr t. f \st_tcb_at' ((=) (BlockedOnReply rptr)) t\" - shows "f \valid_replies'_sc_asrt replyPtr\" - unfolding valid_replies'_sc_asrt_def - by (wpsimp wp: hoare_vcg_imp_lift' x y z hoare_vcg_ex_lift) - -lemma valid_replies'_lift: - assumes rNext: "\P. f \\s. P (replyNexts_of s)\" - and rPrev: "\P. f \\s. P (replyPrevs_of s)\" - and rTCB: "\P. f \\s. P (replyTCBs_of s)\" - and st: "\rptr p. f \st_tcb_at' ((=) (BlockedOnReply rptr)) p\" - shows "\valid_replies'\ f \\_. valid_replies'\" - unfolding valid_replies'_def - by (wpsimp wp: hoare_vcg_imp_lift' rNext rPrev rTCB st hoare_vcg_all_lift hoare_vcg_ex_lift) - -lemma cteCaps_of_ctes_of_lift: - "(\P. f \\s. P (ctes_of s)\) \ f \\s. P (cteCaps_of s)\" - unfolding cteCaps_of_def . - -lemmas ctes_of_cteCaps_of_lift = cteCaps_of_ctes_of_lift - add_upd_simps "invs' (gsUntypedZeroRanges_update f s)" (obj_at'_real_def) declare upd_simps[simp] @@ -4186,96 +3475,4 @@ lemma obj_range'_disjoint: apply (metis add_mask_fold distinct_obj_range'_not_subset obj_range'_def) done -(* sym_heap *) - -lemma sym_refs_replyNext_replyPrev_sym: - "sym_refs (list_refs_of_replies' s') \ - replyNexts_of s' rp = Some rp' \ replyPrevs_of s' rp' = Some rp" - supply opt_mapE[elim!] - apply (rule iffI; clarsimp simp: projectKO_opts_defs split: kernel_object.split_asm) - apply (drule_tac tp=ReplyNext and y=rp' and x=rp in sym_refsD[rotated]) - apply (clarsimp simp: map_set_def opt_map_red list_refs_of_reply'_def projectKO_opt_reply) - apply (clarsimp simp: opt_map_red map_set_def get_refs_def2 list_refs_of_reply'_def - split: option.split_asm) - apply (drule_tac tp=ReplyPrev and y=rp and x=rp' in sym_refsD[rotated]) - apply (clarsimp simp: map_set_def opt_map_red list_refs_of_reply'_def projectKO_opt_reply) - by (clarsimp simp: opt_map_red map_set_def get_refs_def2 list_refs_of_reply'_def - split: option.split_asm) - -lemma reply_sym_heap_Next_Prev: - "sym_refs (list_refs_of_replies' s') \ sym_heap (replyNexts_of s') (replyPrevs_of s')" - using sym_refs_replyNext_replyPrev_sym by (clarsimp simp: sym_heap_def) - -lemmas reply_sym_heap_Prev_Next - = sym_heap_symmetric[THEN iffD1, OF reply_sym_heap_Next_Prev] - -lemmas sym_refs_replyNext_None - = sym_heap_None[OF reply_sym_heap_Next_Prev] - -lemmas sym_refs_replyPrev_None - = sym_heap_None[OF reply_sym_heap_Prev_Next] - -lemmas sym_refs_reply_heap_path_doubly_linked_Prevs_rev - = sym_heap_path_reverse[OF reply_sym_heap_Next_Prev] - -lemmas sym_refs_reply_heap_path_doubly_linked_Nexts_rev - = sym_heap_path_reverse[OF reply_sym_heap_Prev_Next] - -lemmas sym_refs_replyNext_heap_ls_Cons - = sym_heap_ls_rev_Cons[OF reply_sym_heap_Next_Prev] - -lemmas sym_refs_replyPrev_heap_ls_Cons - = sym_heap_ls_rev_Cons[OF reply_sym_heap_Prev_Next] - -lemmas sym_refs_replyNext_heap_ls - = sym_heap_ls_rev[OF reply_sym_heap_Next_Prev] - -lemmas sym_refs_replyPrev_heap_ls - = sym_heap_ls_rev[OF reply_sym_heap_Prev_Next] - -(* end: sym_heap *) - -lemma no_replySC_valid_replies'_sc_asrt: - "replySCs_of s r = None \ valid_replies'_sc_asrt r s" - unfolding valid_replies'_sc_asrt_def - by (simp) - -(** sc_with_reply' **) - -definition sc_with_reply' where - "sc_with_reply' rp s' = - the_pred_option - (\sc_ptr. \xs. heap_ls (replyPrevs_of s') (scReplies_of s' sc_ptr) xs - \ rp \ set xs)" - -lemma sc_with_reply'_SomeD: - "sc_with_reply' rp s' = Some scp \ - \xs. heap_ls (replyPrevs_of s') (scReplies_of s' scp) xs - \ rp \ set xs" - by (clarsimp simp: sc_with_reply'_def dest!: the_pred_option_SomeD) - -lemma sc_with_reply'_NoneD: - "sc_with_reply' rp s' = None \ - \!scp. \xs. heap_ls (replyPrevs_of s') (scReplies_of s' scp) xs - \ rp \ set xs" - by (clarsimp simp: sc_with_reply'_def the_pred_option_def split: if_split_asm) - -definition "updateTimeStamp_independent (P :: kernel_state \ bool) - \ \f g s. P s \ P (s\ksCurTime := f (ksCurTime s), ksConsumedTime := g (ksConsumedTime s)\)" - -lemma updateTimeStamp_independentI[intro!, simp]: - "\\s f g. P (s\ksCurTime := f (ksCurTime s), ksConsumedTime := g (ksConsumedTime s)\) = P s\ - \ updateTimeStamp_independent P" - by (simp add: updateTimeStamp_independent_def) - -definition "domain_time_independent_H (P :: kernel_state \ bool) - \ \f s. P s \ - P (s\ksDomainTime := f (ksDomainTime s)\)" - -lemma domain_time_independent_HI[intro!, simp]: - "\\s f. P (s\ksDomainTime := f (ksDomainTime s)\) - = P s\ - \ domain_time_independent_H P" - by (simp add: domain_time_independent_H_def) - end diff --git a/proof/refine/ARM/Invocations_R.thy b/proof/refine/ARM/Invocations_R.thy index 60ffad1ed0..5f49d06d96 100644 --- a/proof/refine/ARM/Invocations_R.thy +++ b/proof/refine/ARM/Invocations_R.thy @@ -8,7 +8,7 @@ theory Invocations_R imports Invariants_H begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma invocationType_eq[simp]: "invocationType = invocation_type" diff --git a/proof/refine/ARM/IpcCancel_R.thy b/proof/refine/ARM/IpcCancel_R.thy index 96eb259c72..c7fb548db4 100644 --- a/proof/refine/ARM/IpcCancel_R.thy +++ b/proof/refine/ARM/IpcCancel_R.thy @@ -7,18 +7,16 @@ theory IpcCancel_R imports Schedule_R - Reply_R "Lib.SimpStrategy" begin - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch cancelAllIPC - for aligned'[wp]: pspace_aligned' - (wp: crunch_wps mapM_x_wp' simp: unless_def crunch_simps) + for aligned'[wp]: pspace_aligned' + (wp: crunch_wps mapM_x_wp' simp: unless_def) crunch cancelAllIPC - for distinct'[wp]: pspace_distinct' - (wp: crunch_wps mapM_x_wp' simp: unless_def crunch_simps) + for distinct'[wp]: pspace_distinct' + (wp: crunch_wps mapM_x_wp' simp: unless_def) crunch cancelAllSignals for aligned'[wp]: pspace_aligned' @@ -27,16 +25,11 @@ crunch cancelAllSignals for distinct'[wp]: pspace_distinct' (wp: crunch_wps mapM_x_wp') -lemma cancelSignal_st_tcb_at'_cases: - "\\s. (t = t' \ Q (P Inactive)) \ (t \ t' \ Q (st_tcb_at' P t s))\ - cancelSignal t' n - \\_ s. Q (st_tcb_at' P t s)\" - unfolding cancelSignal_def replyRemoveTCB_def cleanReply_def - by (wpsimp wp: sts_st_tcb_at'_cases_strong getNotification_wp hoare_vcg_imp_lift') - lemma cancelSignal_simple[wp]: "\\\ cancelSignal t ntfn \\rv. st_tcb_at' simple' t\" - by (wpsimp wp: cancelSignal_st_tcb_at'_cases) + apply (simp add: cancelSignal_def Let_def) + apply (wp setThreadState_st_tcb | simp)+ + done lemma cancelSignal_pred_tcb_at': "\pred_tcb_at' proj P t' and K (t \ t')\ @@ -46,77 +39,81 @@ 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) +crunch emptySlot + for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" + (wp: setCTE_pred_tcb_at') + +lemma set_ep_pred_tcb_at' [wp]: + "\ pred_tcb_at' proj P t \ + setEndpoint ep v + \ \rv. pred_tcb_at' proj P t \" + apply (simp add: setEndpoint_def pred_tcb_at'_def) + apply (rule obj_at_setObject2) + apply simp + apply (simp add: updateObject_default_def in_monad projectKOs) done defs capHasProperty_def: "capHasProperty ptr P \ cte_wp_at' (\c. P (cteCap c)) ptr" end - -lemma blockedCancelIPC_st_tcb_at: - "\\s. (t = t' \ Q (P Inactive)) \ (t \ t' \ Q (st_tcb_at' P t s))\ - blockedCancelIPC st t' rptr - \\_ s. Q (st_tcb_at' P t s)\" - unfolding blockedCancelIPC_def getBlockingObject_def - by (wpsimp wp: sts_st_tcb_at'_cases_strong replyUnlink_st_tcb_at' getEndpoint_wp hoare_vcg_imp_lift') - -lemma cancelIPC_st_tcb_at': - "\\s. if t' = t \ st_tcb_at' (\st. st \ {Running, Restart, IdleThreadState}) t' s - then P (P' Inactive) - else P (st_tcb_at' P' t' s)\ - cancelIPC t - \\rv s. P (st_tcb_at' P' t' s)\" - apply (clarsimp simp: cancelIPC_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ gts_sp']) - apply (wpsimp wp: blockedCancelIPC_st_tcb_at replyRemoveTCB_st_tcb_at'_cases - cancelSignal_st_tcb_at'_cases threadSet_pred_tcb_no_state) - apply (auto simp: pred_tcb_at'_def obj_at'_def) - done - -lemma cancelIPC_simple[wp]: - "\\\ cancelIPC t \\rv. st_tcb_at' simple' t\" - unfolding cancelIPC_def blockedCancelIPC_def - apply (wpsimp wp: setThreadState_st_tcb gts_wp' threadSet_wp - simp: Let_def tcb_obj_at'_pred_tcb'_set_obj'_iff) - apply (clarsimp simp: st_tcb_at'_def o_def obj_at'_def isBlockedOnReply_def) - done - -lemma cancelIPC_st_tcb_at'_different_thread: - "\\s. P (st_tcb_at' st t' s) \ t \ t'\ cancelIPC t \\rv s. P (st_tcb_at' st t' s)\" - by (wpsimp wp: cancelIPC_st_tcb_at') - (* Assume various facts about cteDeleteOne, proved in Finalise_R *) locale delete_one_conc_pre = assumes delete_one_st_tcb_at: "\P. (\st. simple' st \ P st) \ \st_tcb_at' P t\ cteDeleteOne slot \\rv. st_tcb_at' P t\" - assumes delete_one_typ_at[wp]: + assumes delete_one_typ_at: "\P. \\s. P (typ_at' T p s)\ cteDeleteOne slot \\rv s. P (typ_at' T p s)\" - assumes delete_one_sc_at'_n[wp]: - "\P. cteDeleteOne slot \\s. P (sc_at'_n n p s)\" assumes delete_one_aligned: "\pspace_aligned'\ cteDeleteOne slot \\rv. pspace_aligned'\" assumes delete_one_distinct: "\pspace_distinct'\ cteDeleteOne slot \\rv. pspace_distinct'\" assumes delete_one_it: "\P. \\s. P (ksIdleThread s)\ cteDeleteOne cap \\rv s. P (ksIdleThread s)\" + assumes delete_one_sch_act_simple: + "\sch_act_simple\ cteDeleteOne sl \\rv. sch_act_simple\" + assumes delete_one_sch_act_not: + "\t. \sch_act_not t\ cteDeleteOne sl \\rv. sch_act_not t\" + assumes delete_one_reply_st_tcb_at: + "\P t. \\s. st_tcb_at' P t s \ (\t' r. cte_wp_at' (\cte. cteCap cte = ReplyCap t' False r) slot s)\ + cteDeleteOne slot + \\rv. st_tcb_at' P t\" assumes delete_one_ksCurDomain: "\P. \\s. P (ksCurDomain s)\ cteDeleteOne sl \\_ s. P (ksCurDomain s)\" assumes delete_one_tcbDomain_obj_at': "\P. \obj_at' (\tcb. P (tcbDomain tcb)) t'\ cteDeleteOne slot \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" -lemma cancelSignal_st_tcb_at': - "\K (P Inactive)\ - cancelSignal t ntfn - \\_. st_tcb_at' P t\" - unfolding cancelSignal_def Let_def - apply (rule hoare_gen_asm_single) - apply (wpsimp wp: setThreadState_st_tcb_at'_cases) +lemma (in delete_one_conc_pre) cancelIPC_simple[wp]: + "\\\ cancelIPC t \\rv. st_tcb_at' simple' t\" + apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def + cong: Structures_H.thread_state.case_cong list.case_cong) + apply (rule bind_wp [OF _ gts_sp']) + apply (rule hoare_pre) + apply (wpc + | wp sts_st_tcb_at'_cases hoare_vcg_conj_lift + hoare_vcg_const_imp_lift delete_one_st_tcb_at + threadSet_pred_tcb_no_state + hoare_strengthen_post [OF cancelSignal_simple] + | simp add: o_def if_fun_split + | rule hoare_drop_imps + | clarsimp elim!: pred_tcb'_weakenE)+ + apply (auto simp: pred_tcb_at' + elim!: pred_tcb'_weakenE) + done + +lemma (in delete_one_conc_pre) cancelIPC_st_tcb_at': + "\st_tcb_at' P t' and K (t \ t')\ + cancelIPC t + \\rv. st_tcb_at' P t'\" + apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def locateSlot_conv + capHasProperty_def isCap_simps) + apply (wp sts_pred_tcb_neq' hoare_drop_imps delete_one_reply_st_tcb_at + | wpc | clarsimp)+ + apply (wp getCTE_wp | clarsimp)+ + apply (wp hoare_vcg_ex_lift threadSet_cte_wp_at' hoare_vcg_imp_lift + cancelSignal_pred_tcb_at' sts_pred_tcb_neq' getEndpoint_wp gts_wp' + threadSet_pred_tcb_no_state + | wpc | clarsimp)+ + apply (auto simp: cte_wp_at_ctes_of isCap_simps) done context begin interpretation Arch . @@ -124,296 +121,214 @@ 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' - -declare if_weak_cong [cong] -declare delete_remove1 [simp] -declare delete.simps [simp del] - -lemma sch_act_wf_weak_sch_act_wf[elim!]: - "sch_act_wf (ksSchedulerAction s) s \ weak_sch_act_wf (ksSchedulerAction s) s" - by (clarsimp simp: weak_sch_act_wf_def) +crunch cancelSignal + for tcb_at'[wp]: "tcb_at' t" + (wp: crunch_wps simp: crunch_simps) -lemma replyTCB_update_corres: - "corres dc (reply_at rp) (reply_at' rp) - (set_reply_obj_ref reply_tcb_update rp new) - (updateReply rp (replyTCB_update (\_. new)))" - apply (simp add: update_sk_obj_ref_def updateReply_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_reply_corres]) - apply (rule set_reply_corres) - apply (simp add: reply_relation_def) - by (wpsimp simp: obj_at'_def replyPrev_same_def)+ +context delete_one_conc_pre +begin -lemma replyUnlinkTcb_corres: - "corres dc - (valid_tcbs and pspace_aligned and pspace_distinct - and st_tcb_at (\st. \ep pl. st = Structures_A.BlockedOnReceive ep (Some rp) pl - \ st = Structures_A.BlockedOnReply rp) t - and reply_tcb_reply_at ((=) (Some t)) rp) - (valid_tcbs' and valid_release_queue_iff) - (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) - 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 (simp add: reply_unlink_tcb_def replyUnlink_def liftM_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_reply_corres]) - apply (rule corres_assert_gen_asm_l) - apply (rename_tac reply'; prop_tac "replyTCB reply' = Some t") - apply (clarsimp simp: reply_relation_def) - apply simp - apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_assert_gen_asm_l) - apply (rule corres_stateAssert_implied[where P'=\, simplified]) - apply (rule corres_split[OF replyTCB_update_corres]) - apply (rule setThreadState_corres) - apply (clarsimp simp: thread_state_relation_def) - apply wpsimp +lemmas delete_one_typ_ats[wp] = typ_at_lifts [OF delete_one_typ_at] - apply (wpsimp simp: updateReply_def) - apply (fastforce simp: replyUnlink_assertion_def thread_state_relation_def) - 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 projectKOs) - 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 projectKOs) +lemma cancelIPC_tcb_at'[wp]: + "\tcb_at' t\ cancelIPC t' \\_. tcb_at' t\" + apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def) + apply (wp delete_one_typ_ats hoare_drop_imps + | simp add: o_def if_apply_def2 | wpc | assumption)+ done -lemma setNotification_valid_tcb'[wp]: - "setNotification ntfn val \valid_tcb' tcb\" - apply (clarsimp simp: setNotification_def) - apply (rule setObject_valid_tcb') - done +end -lemma setNotification_valid_tcbs'[wp]: - "setNotification ntfn val \valid_tcbs'\" - unfolding valid_tcbs'_def - by (wpsimp wp: set_ntfn'.setObject_wp hoare_vcg_all_lift hoare_vcg_imp_lift' - simp: setNotification_def)+ +declare if_weak_cong [cong] +declare delete_remove1 [simp] +declare delete.simps [simp del] -lemma setEndpoint_valid_tcb'[wp]: - "setEndpoint epPtr val \valid_tcb' tcb\" - apply (clarsimp simp: setEndpoint_def) - apply (rule setObject_valid_tcb') +lemma invs_weak_sch_act_wf[elim!]: + "invs' s \ weak_sch_act_wf (ksSchedulerAction s) s" + apply (drule invs_sch_act_wf') + apply (clarsimp simp: weak_sch_act_wf_def) done -lemma setEndpoint_valid_tcbs'[wp]: - "setEndpoint ePtr val \valid_tcbs'\" - unfolding valid_tcbs'_def - by (wpsimp wp: set_ep'.setObject_wp hoare_vcg_all_lift hoare_vcg_imp_lift' - simp: setEndpoint_def)+ - -lemma replyUnlink_valid_tcbs'[wp]: - "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 ) - done +crunch set_endpoint + for tcb_at[wp]: "tcb_at t" +crunch setEndpoint + for tcb_at'[wp]: "tcb_at' t" 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 valid_release_queue_iff and st_tcb_at' ((=) st') t) - (blocked_cancel_ipc st t reply_opt) - (blockedCancelIPC st' t reply_opt)" (is "\ _ ; _ ; _ \ \ corres _ (?abs_guard and _) _ _ _") - apply add_sym_refs - apply (prop_tac "getBlockingObject st' = return epPtr") - apply (case_tac st; clarsimp simp: getBlockingObject_def epBlocked_def) - apply (simp add: blocked_cancel_ipc_def blockedCancelIPC_def gbep_ret) + "\ st = Structures_A.BlockedOnReceive epPtr p' \ + st = Structures_A.BlockedOnSend epPtr p; thread_state_relation st st' \ \ + corres dc (invs and st_tcb_at ((=) st) t) (invs' and st_tcb_at' ((=) st') t) + (blocked_cancel_ipc st t) + (do ep \ getEndpoint epPtr; + y \ assert (\ (case ep of IdleEP \ True | _ \ False)); + ep' \ + if remove1 t (epQueue ep) = [] then return IdleEP + else + return $ epQueue_update (%_. (remove1 t (epQueue ep))) ep; + y \ setEndpoint epPtr ep'; + setThreadState Structures_H.thread_state.Inactive t + od)" + apply (simp add: blocked_cancel_ipc_def gbep_ret) 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 valid_release_queue_iff and st_tcb_at' ((=) st') t - and valid_ep' ep" - in corres_inst) - \\cross over replyTCB\ - apply (rule_tac Q="\s. bound reply_opt \ obj_at' (\r. replyTCB r = Some t) (the reply_opt) s" in corres_cross_add_guard) - apply clarsimp - apply (drule state_relationD) - 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 (drule_tac x=rp in pspace_relation_absD, simp) - apply (clarsimp simp: obj_relation_cuts_def2 obj_at'_def reply_relation_def projectKOs) - apply (rename_tac ko) - apply (case_tac ko; simp) - apply (rename_tac reply') - apply (frule_tac x=rp in pspace_alignedD', simp) - apply (frule_tac x=rp in pspace_distinctD', simp) - 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 (rule_tac P="invs and st_tcb_at ((=) st) t" and + P'="invs' and st_tcb_at' ((=) st') t" in corres_inst) + apply (case_tac rv) + apply (simp add: ep_relation_def) + apply (simp add: get_ep_queue_def ep_relation_def split del: if_split) apply (rename_tac list) - apply (cases reply_opt; - simp split del: if_split add: bind_assoc cong: if_cong) - \\reply_opt = None\ + apply (case_tac "remove1 t list") + apply simp apply (rule corres_guard_imp) apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) + apply (simp add: ep_relation_def) apply (rule setThreadState_corres) apply simp - apply wpsimp+ - apply (frule (1) Receive_or_Send_ep_at[rotated], fastforce) - apply (intro conjI; - clarsimp simp: st_tcb_at_def obj_at_def is_ep is_tcb - intro!: valid_ep_remove1_RecvEP) - apply clarsimp - apply (frule Receive_or_Send_ep_at'[rotated], simp) - apply (simp add: thread_state_relation_def) - apply (fastforce simp: valid_ep'_def) - \\reply_opt bound\ + apply (simp add: valid_tcb_state_def pred_conj_def) + apply (wp weak_sch_act_wf_lift)+ + apply (clarsimp simp: st_tcb_at_tcb_at) + apply (clarsimp simp: st_tcb_at_def obj_at_def) + apply (erule pspace_valid_objsE) + apply fastforce + apply (auto simp: valid_tcb_state_def valid_tcb_def + valid_obj_def obj_at_def)[1] + apply (clarsimp simp: pred_tcb_at') + apply (clarsimp simp: pred_tcb_at'_def) + apply (drule obj_at_ko_at') + apply clarify + apply (drule ko_at_valid_objs') + apply fastforce + apply (simp add: projectKOs) + apply (auto simp add: valid_obj'_def valid_tcb'_def + valid_tcb_state'_def)[1] + apply clarsimp 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 valid_release_queue_iff - and st_tcb_at' ((=) st') t" - 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 wp: set_ep'.set_wp) - apply clarsimp - apply (frule (1) Reply_or_Receive_reply_at[rotated], fastforce) - apply (frule (1) Receive_or_Send_ep_at[rotated], fastforce) + apply (rule corres_split[OF setEndpoint_corres]) + apply (simp add: ep_relation_def) + apply (rule setThreadState_corres) + apply simp + apply (wp)+ 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 (rule conjI, clarsimp simp: obj_at'_def projectKOs ps_clear_upd objBits_simps) - apply (rule conjI; clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs ps_clear_upd) - apply (intro conjI impI; clarsimp?) - apply (erule valid_objs'_ep_update) - apply (case_tac "remove1 t list" - ; clarsimp simp: valid_ep'_def obj_at'_def projectKOs - ; metis distinct.simps(2) distinct_remove1 list.set_intros(1) list.set_intros(2) - set_remove1) - apply (clarsimp simp: obj_at'_def projectKOs) - apply ((clarsimp simp: obj_at'_def projectKOs valid_ep'_def)+)[2] - apply (erule valid_release_queue_ksPSpace_update) - apply ((clarsimp simp: ko_wp_at'_def objBitsKO_def koTypeOf_def)+)[2] - apply (erule valid_release_queue'_ksPSpace_update) - apply ((clarsimp simp: ko_wp_at'_def objBitsKO_def koTypeOf_def)+)[2] - \\BlockedOnSend\ + apply (clarsimp simp: st_tcb_at_def obj_at_def) + apply (erule pspace_valid_objsE) + apply fastforce + apply (auto simp: valid_tcb_state_def valid_tcb_def + valid_obj_def obj_at_def)[1] + apply (clarsimp simp: pred_tcb_at') + apply (clarsimp simp: pred_tcb_at'_def) + apply (drule obj_at_ko_at') + apply clarify + apply (drule ko_at_valid_objs') + apply fastforce + apply (simp add: projectKOs) + apply (auto simp add: valid_obj'_def valid_tcb'_def + valid_tcb_state'_def)[1] + apply (simp add: get_ep_queue_def ep_relation_def split del: if_split) apply (rename_tac list) + apply (case_tac "remove1 t list") + apply simp + apply (rule corres_guard_imp) + apply (rule corres_split[OF setEndpoint_corres]) + apply (simp add: ep_relation_def) + apply (rule setThreadState_corres) + apply simp + apply (simp add: valid_tcb_state_def pred_conj_def) + apply (wp weak_sch_act_wf_lift)+ + apply (clarsimp simp: st_tcb_at_tcb_at) + apply (clarsimp simp: st_tcb_at_def obj_at_def) + apply (erule pspace_valid_objsE) + apply fastforce + apply (auto simp: valid_tcb_state_def valid_tcb_def + valid_obj_def obj_at_def)[1] + apply (clarsimp simp: pred_tcb_at') + apply (clarsimp simp: pred_tcb_at'_def) + apply (drule obj_at_ko_at') + apply clarify + apply (drule ko_at_valid_objs') + apply fastforce + apply (simp add: projectKOs) + apply (auto simp add: valid_obj'_def valid_tcb'_def + valid_tcb_state'_def)[1] + apply clarsimp apply (rule corres_guard_imp) apply (rule corres_split[OF setEndpoint_corres]) - apply (simp add: ep_relation_def split: list.split) + apply (simp add: ep_relation_def) apply (rule setThreadState_corres) apply simp - apply (simp add: valid_tcb_state_def pred_conj_def) - apply wpsimp+ - apply (frule (1) Receive_or_Send_ep_at[rotated], fastforce) - apply (intro conjI; - clarsimp simp: st_tcb_at_def obj_at_def is_ep is_tcb - intro!: valid_ep_remove1_SendEP) - apply (clarsimp split del: if_split) - apply (frule (1) Receive_or_Send_ep_at'[rotated], blast) - apply (fastforce simp: valid_ep'_def) - apply (wpsimp wp: getEndpoint_wp hoare_vcg_conj_lift get_simple_ko_wp)+ - apply (frule (2) Receive_or_Send_ep_at, clarsimp) - apply (rule conjI, clarsimp) - apply (drule (1) st_tcb_recv_reply_state_refs) - apply (clarsimp simp: sk_obj_at_pred_def obj_at_def) - 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 (wp)+ + apply (clarsimp simp: st_tcb_at_tcb_at) + apply (clarsimp simp: st_tcb_at_def obj_at_def) + apply (erule pspace_valid_objsE) + apply fastforce + apply (auto simp: valid_tcb_state_def valid_tcb_def + valid_obj_def obj_at_def)[1] + apply (clarsimp simp: pred_tcb_at') + apply (clarsimp simp: pred_tcb_at'_def) + apply (drule obj_at_ko_at') + apply clarify + apply (drule ko_at_valid_objs') + apply fastforce + apply (simp add: projectKOs) + apply (auto simp add: valid_obj'_def valid_tcb'_def + valid_tcb_state'_def)[1] + apply (wp getEndpoint_wp)+ + apply (clarsimp simp: st_tcb_at_def obj_at_def) + apply (erule pspace_valid_objsE) + apply fastforce + apply (auto simp: valid_tcb_state_def valid_tcb_def + valid_obj_def obj_at_def)[1] 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 projectKOs ) 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) + apply (clarsimp simp: pred_tcb_at'_def) + apply (drule obj_at_ko_at') + apply clarify + apply (drule ko_at_valid_objs') + apply fastforce + apply (simp add: projectKOs) + apply (auto simp add: valid_obj'_def valid_tcb'_def + valid_tcb_state'_def)[1] + apply (fastforce simp: ko_wp_at'_def obj_at'_def projectKOs dest: sym_refs_st_tcb_atD') done lemma cancelSignal_corres: "corres dc - (invs and valid_ready_qs and st_tcb_at ((=) (Structures_A.BlockedOnNotification ntfn)) t) + (invs and st_tcb_at ((=) (Structures_A.BlockedOnNotification ntfn)) t) (invs' and st_tcb_at' ((=) (BlockedOnNotification ntfn)) t) (cancel_signal t ntfn) (cancelSignal t ntfn)" - apply add_sym_refs - apply add_ready_qs_runnable apply (simp add: cancel_signal_def cancelSignal_def Let_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply clarsimp apply (rule corres_guard_imp) apply (rule corres_split[OF getNotification_corres]) apply (rule_tac F="isWaitingNtfn (ntfnObj ntfnaa)" in corres_gen_asm2) - apply (case_tac "ntfn_obj ntfna"; simp add: ntfn_relation_def isWaitingNtfn_def) - apply (case_tac "ntfna", case_tac "ntfnaa") - apply clarsimp - apply wpfix - apply (rename_tac list bound_tcb sc) - apply (rule_tac R="remove1 t list = []" in corres_cases') - apply (simp del: dc_simp) + apply (case_tac "ntfn_obj ntfna") + apply (simp add: ntfn_relation_def isWaitingNtfn_def) + apply (simp add: isWaitingNtfn_def ntfn_relation_def split del: if_split) + apply (rename_tac list) + 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)+ + apply (simp add: list_case_If del: dc_simp) apply (rule corres_split[OF setNotification_corres]) - apply (simp add: ntfn_relation_def) + apply (clarsimp simp add: ntfn_relation_def neq_Nil_conv) 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) - apply (rule setThreadState_corres) - apply simp - apply (wp abs_typ_at_lifts)+ - apply (wp get_simple_ko_wp getNotification_wp)+ + apply (wp)+ + apply (simp add: isWaitingNtfn_def ntfn_relation_def) + apply (wp getNotification_wp)+ 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 (erule pspace_valid_objsE) + apply fastforce apply (clarsimp simp: valid_obj_def valid_tcb_def valid_tcb_state_def) apply (drule sym, simp add: obj_at_def) - apply clarsimp - apply (erule pspace_valid_objsE[where p=ntfn], fastforce) - apply (fastforce simp: valid_obj_def valid_ntfn_def - split: option.splits Structures_A.ntfn.splits) + apply fastforce apply (clarsimp simp: conj_comms pred_tcb_at' cong: conj_cong) apply (rule conjI) apply (simp add: pred_tcb_at'_def) @@ -424,10 +339,10 @@ lemma cancelSignal_corres: apply (simp add: projectKOs) apply (clarsimp simp: valid_obj'_def valid_tcb'_def valid_tcb_state'_def) apply (drule sym, simp) - apply (intro conjI impI allI; fastforce?) + apply (clarsimp simp: invs_weak_sch_act_wf) apply (drule sym_refs_st_tcb_atD', fastforce) apply (fastforce simp: isWaitingNtfn_def ko_wp_at'_def obj_at'_def projectKOs - ntfn_bound_refs'_def get_refs_def + ntfn_bound_refs'_def split: Structures_H.notification.splits ntfn.splits option.splits) done @@ -435,7 +350,128 @@ lemma cte_map_tcb_2: "cte_map (t, tcb_cnode_index 2) = t + 2*2^cte_level_bits" by (simp add: cte_map_def tcb_cnode_index_def to_bl_1) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) + +lemma cte_wp_at_master_reply_cap_to_ex_rights: + "cte_wp_at (is_master_reply_cap_to t) ptr + = (\s. \rights. cte_wp_at ((=) (cap.ReplyCap t True rights)) ptr s)" + by (rule ext, rule iffI; clarsimp simp: cte_wp_at_def is_master_reply_cap_to_def) + +lemma cte_wp_at_reply_cap_to_ex_rights: + "cte_wp_at (is_reply_cap_to t) ptr + = (\s. \rights. cte_wp_at ((=) (cap.ReplyCap t False rights)) ptr s)" + by (rule ext, rule iffI; clarsimp simp: cte_wp_at_def is_reply_cap_to_def) + +lemma reply_no_descendants_mdbNext_null: + assumes descs: "descendants_of (t, tcb_cnode_index 2) (cdt s) = {}" + and sr: "(s, s') \ state_relation" + and invs: "valid_reply_caps s" "valid_reply_masters s" + "valid_objs s" "valid_mdb s" "valid_mdb' s'" "pspace_aligned' s'" + "pspace_distinct' s'" + and tcb: "st_tcb_at (Not \ halted) t s" + and cte: "ctes_of s' (t + 2*2^cte_level_bits) = Some cte" + shows "mdbNext (cteMDBNode cte) = nullPointer" +proof - + from invs st_tcb_at_reply_cap_valid[OF tcb] + have "cte_wp_at (is_master_reply_cap_to t) (t, tcb_cnode_index 2) s" + by (fastforce simp: cte_wp_at_caps_of_state is_cap_simps is_master_reply_cap_to_def) + + hence "\r. cteCap cte = capability.ReplyCap t True r" + using invs sr + by (fastforce simp: cte_wp_at_master_reply_cap_to_ex_rights + cte_wp_at_ctes_of cte cte_map_def tcb_cnode_index_def + dest: pspace_relation_cte_wp_at state_relation_pspace_relation) + + hence class_link: + "\cte'. ctes_of s' (mdbNext (cteMDBNode cte)) = Some cte' \ + capClass (cteCap cte') = ReplyClass t" + using invs + apply (clarsimp simp: valid_mdb'_def valid_mdb_ctes_def) + apply (drule class_linksD[where m="ctes_of s'", OF cte]) + apply (simp add: mdb_next_unfold cte) + apply assumption + apply simp + done + + from invs tcb descs have "\ptr m g. + cte_wp_at ((=) (cap.ReplyCap t m g)) ptr s \ ptr = (t, tcb_cnode_index 2)" + apply (intro allI impI) + apply (case_tac m) + apply (fastforce simp: invs_def valid_state_def valid_reply_masters_def + cte_wp_at_master_reply_cap_to_ex_rights) + apply (fastforce simp: has_reply_cap_def cte_wp_at_reply_cap_to_ex_rights + dest: reply_master_no_descendants_no_reply elim: st_tcb_at_tcb_at) + done + hence "\ptr m mdb r. + ctes_of s' ptr = Some (CTE (capability.ReplyCap t m r) mdb) \ ptr = t + 2*2^cte_level_bits" + using sr invs + apply (intro allI impI) + apply (drule(2) pspace_relation_cte_wp_atI + [OF state_relation_pspace_relation]) + apply (elim exE, case_tac c, simp_all del: split_paired_All) + apply (elim allE, erule impE, fastforce) + apply (clarsimp simp: cte_map_def tcb_cnode_index_def) + done + hence class_unique: + "\ptr cte'. ctes_of s' ptr = Some cte' \ + capClass (cteCap cte') = ReplyClass t \ + ptr = t + 2*2^cte_level_bits" + apply (intro allI impI) + apply (case_tac cte', rename_tac cap node, case_tac cap, simp_all) + apply (rename_tac arch_capability) + apply (case_tac arch_capability, simp_all) + done + + from invs have no_null: "ctes_of s' nullPointer = None" + by (clarsimp simp: no_0_def nullPointer_def valid_mdb'_def valid_mdb_ctes_def) + + from invs cte have no_loop: "mdbNext (cteMDBNode cte) \ t + 2*2^cte_level_bits" + by (fastforce simp: mdb_next_rel_def mdb_next_def + valid_mdb'_def + dest: valid_mdb_no_loops no_loops_direct_simp) + + from invs cte have + "mdbNext (cteMDBNode cte) \ nullPointer \ + (\cte'. ctes_of s' (mdbNext (cteMDBNode cte)) = Some cte')" + by (fastforce simp: valid_mdb'_def valid_mdb_ctes_def nullPointer_def + elim: valid_dlistEn) + hence + "mdbNext (cteMDBNode cte) \ nullPointer \ + mdbNext (cteMDBNode cte) = t + 2*2^cte_level_bits" + using class_link class_unique + by clarsimp + thus ?thesis + by (simp add: no_loop) +qed + +lemma reply_descendants_mdbNext_nonnull: + assumes descs: "descendants_of (t, tcb_cnode_index 2) (cdt s) \ {}" + and sr: "(s, s') \ state_relation" + and tcb: "st_tcb_at (Not \ halted) t s" + and cte: "ctes_of s' (t + 2*2^cte_level_bits) = Some cte" + shows "mdbNext (cteMDBNode cte) \ nullPointer" +proof - + from tcb have "cte_at (t, tcb_cnode_index 2) s" + by (simp add: st_tcb_at_tcb_at tcb_at_cte_at dom_tcb_cap_cases) + hence "descendants_of' (t + 2*2^cte_level_bits) (ctes_of s') \ {}" + using sr descs + by (fastforce simp: state_relation_def cdt_relation_def cte_map_def tcb_cnode_index_def) + thus ?thesis + using cte unfolding nullPointer_def + by (fastforce simp: descendants_of'_def dest: subtree_next_0) +qed + +lemma reply_descendants_of_mdbNext: + "\ (s, s') \ state_relation; valid_reply_caps s; valid_reply_masters s; + valid_objs s; valid_mdb s; valid_mdb' s'; pspace_aligned' s'; + pspace_distinct' s'; st_tcb_at (Not \ halted) t s; + ctes_of s' (t + 2*2^cte_level_bits) = Some cte \ \ + (descendants_of (t, tcb_cnode_index 2) (cdt s) = {}) = + (mdbNext (cteMDBNode cte) = nullPointer)" + apply (case_tac "descendants_of (t, tcb_cnode_index 2) (cdt s) = {}") + apply (simp add: reply_no_descendants_mdbNext_null) + apply (simp add: reply_descendants_mdbNext_nonnull) + done lemma reply_mdbNext_is_descendantD: assumes sr: "(s, s') \ state_relation" @@ -465,1275 +501,132 @@ end locale delete_one_conc = delete_one_conc_pre + assumes delete_one_invs: - "\p. \invs' and sch_act_simple\ cteDeleteOne p \\rv. invs'\" + "\p. \invs'\ cteDeleteOne p \\rv. invs'\" locale delete_one = delete_one_conc + delete_one_abs + assumes delete_one_corres: - "corres dc - (einvs and simple_sched_action and cte_wp_at can_fast_finalise ptr - and current_time_bounded) - (invs' and cte_at' (cte_map ptr)) + "corres dc (einvs and cte_wp_at can_fast_finalise ptr) + (invs' and cte_at' (cte_map ptr)) (cap_delete_one ptr) (cteDeleteOne (cte_map ptr))" -lemma gbep_ret': - "\ st = BlockedOnReceive epPtr r d \ st = BlockedOnSend epPtr p1 p2 p3 p4 \ - \ getBlockingObject st = return epPtr" - by (auto simp add: getBlockingObject_def epBlocked_def assert_opt_def) - -lemma replySC_None_not_head: - "replySC reply = None \ \ isHead (replyNext reply)" - by (fastforce simp: isHead_def getHeadScPtr_def split: reply_next.split_asm option.split_asm) - -lemma sr_inv_sc_with_reply_None_helper: - "\ isHead (replyNext reply') \ - sr_inv - (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)) and (\s. sc_with_reply rp s = None) and reply_at rp) - (valid_objs' and valid_release_queue_iff 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')) - (do y <- - do y <- - when (\y. replyNext reply' = Some y) - (updateReply (theReplyNextPtr (replyNext reply')) - (replyPrev_update Map.empty)); - when (\y. replyPrev reply' = Some y) - (updateReply (the (replyPrev reply')) - (replyNext_update Map.empty)) - od; - cleanReply rp - od)" - apply (case_tac "replyNext reply'"; simp add: getHeadScPtr_def isHead_def split: reply_next.splits ) - (* replyNext reply' = None *) - apply (case_tac "replyPrev reply'"; simp) - (* replyNext reply' = None & replyPrev reply' = None *) - apply (rule sr_inv_imp) - apply (rule cleanReply_sr_inv[where P=\ and P'=\]) - apply simp - apply simp - (* replyNext reply' = None & replyPrev reply' = Some prv_rp *) - apply (rename_tac prv_rp) - apply (rule sr_inv_bind) - apply (rule sr_inv_imp) - apply (rule cleanReply_sr_inv[where P=\ and P'="valid_objs' and valid_release_queue_iff - and reply_at' rp"]) - apply simp - apply simp - apply (rule updateReply_sr_inv) - apply (fastforce simp: reply_relation_def opt_map_red obj_at'_def projectKOs - dest!: sym_refs_replyNext_replyPrev_sym[where rp'=rp, THEN iffD2]) - apply clarsimp - apply (frule_tac rp=prv_rp in sc_replies_relation_sc_with_reply_None) - apply simp - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply (erule (7) sc_with_reply_replyPrev_None) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red)+ - apply (fastforce simp: projectKO_opt_sc obj_at'_def opt_map_red projectKOs) - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def obj_at'_def) - (* replyNext reply' = Some nxt_rp *) - apply (rename_tac nxt_rp) - apply (case_tac "replyPrev reply'"; simp) - (* replyNext reply' = Some nxt_rp & replyPrev reply' = None *) - apply (rule sr_inv_bind) - apply (rule sr_inv_imp) - apply (rule cleanReply_sr_inv[where P=\ and P'="valid_objs' and valid_release_queue_iff - and reply_at' rp"]) - apply simp - apply simp - apply (rule updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def) - apply (clarsimp simp: projectKO_opt_sc obj_at'_def opt_map_red projectKOs sc_replies_relation_def) - apply (rename_tac nreply') - apply (rule heap_path_heap_upd_not_in, simp) - apply (rename_tac scp replies) - apply (drule_tac x=scp and y=replies in spec2, simp) - apply (prop_tac "rp \ set replies") - apply (drule_tac sc=scp in valid_replies_sc_with_reply_None, simp) - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def is_reply sc_replies_of_scs_def - scs_of_kh_def map_project_def - elim!: opt_mapE) - apply (erule (1) heap_ls_prev_not_in) - apply (fastforce elim!: sym_refs_replyNext_replyPrev_sym[THEN iffD1] simp: opt_map_red) - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def obj_at'_def) - (* replyNext reply' = Some nxt_rp & replyPrev reply' = Some prv_rp *) - apply (rename_tac prv_rp) - apply (rule_tac Q="valid_objs and pspace_aligned and pspace_distinct and valid_replies - and (\s. sym_refs (state_refs_of s)) - and (\s. sc_with_reply rp s = None) - and (\s. sc_with_reply prv_rp s = None) - and (\s. sc_with_reply nxt_rp s = None) - and reply_at rp" - and Q'="valid_objs' and valid_release_queue_iff and reply_at' rp - and pspace_aligned' and pspace_distinct' - and reply_at' prv_rp and reply_at' nxt_rp - and (\s'. sc_with_reply' rp s' = None) - and (\s'. sc_with_reply' prv_rp s' = None) - and (\s'. sc_with_reply' nxt_rp s' = None) - and (\s'. sym_refs (state_refs_of' s')) - and (\s'. replyPrevs_of s' nxt_rp = Some rp) - and (\s'. replyNexts_of s' prv_rp = Some rp)" - in sr_inv_stronger_imp) - apply (rule sr_inv_bind) - apply (rule sr_inv_imp) - apply (rule cleanReply_sr_inv[where P=\ and P'="valid_objs' and valid_release_queue_iff - and reply_at' rp"]) - apply simp - apply simp - apply (rule sr_inv_bind) - apply (rule sr_inv_imp) - apply (rule updateReply_sr_inv_next[simplified]) - apply simp - apply simp - apply (rule sr_inv_imp) - apply (rule updateReply_sr_inv_prev[simplified]) - apply simp+ - apply wpsimp - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def) - apply clarsimp - apply (rule conjI) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: state_relationE sc_with_reply_replyPrev_None sc_with_reply_replyNext_None) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: state_relationE sc_with_reply_replyNext_None) - apply (prop_tac"sc_with_reply prv_rp s = None \ sc_with_reply nxt_rp s = None") - apply (rule conjI) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: state_relationE sc_with_reply_replyPrev_None sc_with_reply_replyNext_None) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: state_relationE sc_with_reply_replyNext_None) - apply (erule state_relationE) - apply (clarsimp simp: sc_replies_relation_sc_with_reply_cross_eq) - apply (rule conjI) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (clarsimp simp: valid_reply'_def valid_bound_obj'_def) - apply (fastforce simp: obj_at'_def projectKOs opt_map_red - elim!: sym_refs_replyNext_replyPrev_sym[THEN iffD1] - sym_refs_replyNext_replyPrev_sym[THEN iffD2]) - done - -lemma no_fail_sc_wtih_reply_None_helper: - "\ isHead (replyNext reply') \ - no_fail - (\s'. (s, s') \ state_relation \ - (valid_objs' and valid_release_queue_iff 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')) - s') - (do y <- - do y <- - when (\y. replyNext reply' = Some y) - (updateReply (theReplyNextPtr (replyNext reply')) - (replyPrev_update Map.empty)); - when (\y. replyPrev reply' = Some y) - (updateReply (the (replyPrev reply')) - (replyNext_update Map.empty)) - od; - cleanReply rp - od)" - apply (case_tac "replyNext reply'"; simp split del: if_split) - apply wpsimp - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (clarsimp simp: obj_at'_def projectKOs valid_reply'_def) - apply (rename_tac nextr; case_tac nextr; simp add: isHead_def) - apply (case_tac "replyPrev reply'"; simp) - apply (wpsimp; - frule (1) reply_ko_at_valid_objs_valid_reply'; - clarsimp simp: obj_at'_def projectKOs valid_reply'_def)+ - 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 valid_release_queue_iff and (\s'. sym_refs (list_refs_of_replies' s'))) - (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 (clarsimp simp: reply_remove_tcb_def replyRemoveTCB_def isReply_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_assert_gen_asm_l) - apply (rule corres_assert_gen_asm2) - apply (rule corres_assert_opt_assume) - apply (case_tac state; simp) - apply (drule sym[of rp], simp) - apply (rule_tac P'="?conc_guard and (\s'. sym_refs (state_refs_of' s')) and reply_at' rp" - and P="?abs_guard" in corres_symb_exec_r) - (* get sc_with_reply *) - apply (rule corres_symb_exec_l) - apply (rename_tac reply' sc_opt) - apply (rule_tac P="?abs_guard and (\s. sc_with_reply rp s = sc_opt) and reply_at rp" - and P'="?conc_guard and (\s. sym_refs (state_refs_of' s)) and ko_at' reply' rp" - in corres_inst) - apply (rule_tac Q="(\s'. sc_with_reply' rp s' = sc_opt) and pspace_aligned' - and pspace_distinct' and pspace_bounded'" - in corres_cross_add_guard) - apply (frule pspace_relation_pspace_bounded'[OF state_relation_pspace_relation]) - apply (fastforce simp: sc_replies_relation_sc_with_reply_cross_eq - dest!: state_relationD pspace_distinct_cross dest: pspace_aligned_cross) - apply (case_tac sc_opt; simp split del: if_split add: bind_assoc) - - (** sc_with_reply rp s = None **) - apply (rule_tac F="replySC reply' = None" in corres_req) - apply (fastforce dest!: sc_with_reply_None_reply_sc_reply_at dest: replySCs_of_cross - simp: obj_at'_def projectKOs opt_map_red) - apply (clarsimp simp: replySC_None_not_head) - subgoal for reply' - apply (simp only: bind_assoc[symmetric]) - apply (rule corres_symb_exec_r_sr) - apply (rule corres_guard_imp) - apply (rule replyUnlinkTcb_corres[simplified dc_def]) - apply (clarsimp dest!: valid_objs_valid_tcbs) - apply (frule (1) st_tcb_reply_state_refs) - apply (clarsimp simp: pred_tcb_at_def obj_at_def is_tcb is_reply reply_tcb_reply_at_def) - apply simp - apply (erule sr_inv_sc_with_reply_None_helper) - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def obj_at'_def) - apply (fastforce elim!: reply_ko_at_valid_objs_valid_reply') - apply (erule no_fail_sc_wtih_reply_None_helper) - done - - (** sc_with_reply \ None : rp is in a reply stack **) - apply (rename_tac scp) - apply (rule_tac F="replyNext reply' \ None" in corres_req) - apply clarsimp - apply (prop_tac "sc_at scp s") - apply (fastforce dest!: sc_with_reply_SomeD1 - simp: sc_replies_sc_at_def obj_at_def is_sc_obj_def - elim: valid_sched_context_size_objsI) - apply (prop_tac "sc_at' scp s'") - apply (fastforce dest!: state_relationD sc_at_cross) - apply (drule sc_with_reply'_SomeD, clarsimp) - apply (case_tac "hd xs = rp") - apply (drule heap_path_head, clarsimp) - apply (drule (3) sym_refs_scReplies) - apply (clarsimp simp: obj_at'_def projectKOs sym_heap_def elim!: opt_mapE) - - apply (frule (1) heap_path_takeWhile_lookup_next) - apply (frule heap_path_head, clarsimp) - apply (prop_tac "takeWhile ((\) rp) xs = hd xs # tl (takeWhile ((\) rp) xs)") - apply (case_tac xs; simp) - apply (simp del: heap_path.simps) - apply (drule_tac p1="hd xs" and ps1="tl (takeWhile ((\) rp) xs)" - in sym_refs_reply_heap_path_doubly_linked_Nexts_rev[where p'=rp, THEN iffD1]) - apply clarsimp - apply (case_tac "rev (tl (takeWhile ((\) rp) xs))"; - clarsimp simp: obj_at'_def projectKOs elim!: opt_mapE) - apply (clarsimp simp: liftM_def bind_assoc split del: if_split) - apply (rename_tac next_reply) - apply (rule_tac Q="\x. ?abs_guard - and (\s. \n. kheap s scp = Some (Structures_A.SchedContext x n)) - and (\s. sc_with_reply rp s = Some scp) - and K (rp \ set (sc_replies x))" - in corres_symb_exec_l) - apply (rename_tac sc) - apply (rule_tac Q="(\s'. scReplies_of s' scp = hd_opt (sc_replies sc)) and sc_at' scp" - in corres_cross_add_guard) - apply (clarsimp; rule conjI) - apply (frule state_relation_sc_replies_relation) - apply (frule sc_replies_relation_scReplies_of[symmetric]) - apply (fastforce dest!: sc_at_cross valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj_def obj_at'_def) - apply (fastforce dest!: sc_at_cross valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj_def state_relation_def obj_at'_def - projectKOs opt_map_def) - apply (clarsimp simp: sc_replies_of_scs_def map_project_def opt_map_def - scs_of_kh_def) - apply (fastforce dest!: state_relation_pspace_relation sc_at_cross - valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj) - apply (rule corres_gen_asm') - apply (rule corres_symb_exec_l) - apply (rename_tac replysc) - apply (rule_tac P="?abs_guard and (\s. sc_with_reply rp s = Some scp) - and obj_at (\ko. \n. ko = Structures_A.SchedContext sc n) scp - and reply_sc_reply_at ((=) replysc) rp" - in corres_inst) - apply (rename_tac replysc) - apply (rule_tac F="replySC reply' = replysc" in corres_req) - apply (fastforce dest!: replySCs_of_cross simp: obj_at'_def projectKOs opt_map_red) - apply (case_tac "hd (sc_replies sc) = rp"; simp split del: if_split) - - (* hd (sc_replies sc) = rp & replysc = Some scp: rp is at the head of the queue *) - (* i.e. replyNext reply' *) - apply (rule corres_guard_imp) - apply (rule corres_assert_gen_asm_l2) - apply (simp add: getHeadScPtr_def isHead_def neq_conv[symmetric] split: reply_next.splits) - apply (rule corres_split[OF setSchedContext_scReply_update_None_corres[simplified dc_def]]) - apply (rule_tac Q =\ and - P'="valid_objs' and valid_release_queue_iff and ko_at' reply' rp" and - Q'="(\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prp = Some rp)" - in corres_inst_add) - apply (rule corres_symb_exec_r_sr) - apply (rule corres_guard_imp) - apply (rule corres_split[OF cleanReply_sc_with_reply_None_corres]) - apply (rule replyUnlinkTcb_corres[simplified dc_def]) - apply wpsimp - apply wpsimp - apply simp - apply simp - apply (clarsimp cong: conj_cong) - apply (case_tac "replyPrev reply'"; simp) - apply (rename_tac prev_rp) - apply (rule sr_inv_imp) - apply (rule_tac P =\ and - P'=" (\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prev_rp = Some rp)" - in updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def projectKOs obj_at'_def obj_at_def - elim!: opt_mapE) - apply clarsimp - apply (drule_tac rp=prev_rp in sc_replies_relation_replyNext_update, simp) - apply simp - apply simp - apply clarsimp - apply wpsimp - apply wpsimp - apply (clarsimp dest!: reply_ko_at_valid_objs_valid_reply' simp: valid_reply'_def) - apply simp - apply (wpsimp wp: sc_replies_update_takeWhile_sc_with_reply - sc_replies_update_takeWhile_valid_replies) - apply (wpsimp wp: scReply_update_empty_sc_with_reply') - apply clarsimp - apply (frule_tac reply_ptr=rp and sc_ptr= scp and list="tl (sc_replies sc)" - in sym_refs_reply_sc_reply_at) - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def is_reply) - apply (metis list.sel(1) list.sel(3) list.set_cases) - apply (clarsimp simp: getHeadScPtr_def reply_sc_reply_at_def obj_at_def is_reply - split: reply_next.splits) - apply (frule (1) st_tcb_reply_state_refs) - apply (clarsimp dest!: valid_objs_valid_tcbs - simp: obj_at_def is_reply reply_tcb_reply_at_def) - apply (clarsimp simp: opt_map_red opt_map_def split: option.splits) - apply (rule context_conjI; clarsimp simp: vs_heap_simps obj_at_def) - apply (intro conjI) - apply (metis list.sel(1) list.set_cases) - apply (clarsimp simp: pred_tcb_at_def obj_at_def) - apply clarsimp - apply (rule conjI) - apply (clarsimp dest!: sc_ko_at_valid_objs_valid_sc' - simp: valid_sched_context'_def valid_sched_context_size'_def - objBits_simps) - apply (erule sym_refs_replyNext_replyPrev_sym[THEN iffD2]) - apply (clarsimp simp: opt_map_red obj_at'_def projectKOs) - apply (frule (3) sym_refs_scReplies) - apply (clarsimp simp: hd_opt_def projectKOs opt_map_red sym_heap_def - split: list.split_asm) - apply (clarsimp simp: opt_map_red obj_at'_def projectKOs split: reply_next.splits) - - (* rp is in the middle of the reply stack *) - (* hd (sc_replies sc) \ rp & rp \ set (sc_replies sc) *) - apply (rule corres_guard_imp) - apply (rule_tac Q="valid_objs' and valid_release_queue_iff and ko_at' reply' rp - and (\s'. sym_refs (list_refs_of_replies' s')) and sc_at' scp - and (\s'. sym_refs (state_refs_of' s')) - and (\s'. sc_with_reply' rp s' = Some scp) - and (\s'. scReplies_of s' scp = hd_opt (sc_replies sc)) - and (\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prp = Some rp)" - in corres_assert_gen_asm_l) - apply (simp split del: if_split) - apply (clarsimp simp: getHeadScPtr_def isHead_def neq_conv[symmetric] - split: reply_next.splits) - apply (rename_tac nxt_rp) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split - [OF updateReply_replyPrev_takeWhile_middle_corres]) - apply simp - apply simp - apply (rule_tac P ="?abs_guard and reply_sc_reply_at ((=) None) rp" and - Q ="\s. sc_with_reply rp s = None" and - P'="valid_objs' and valid_release_queue_iff - and ko_at' reply' rp and sc_at' scp" and - Q'="(\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prp = Some rp)" - in corres_inst_add) - apply (rule corres_symb_exec_r_sr) - apply (rule corres_guard_imp) - apply (rule corres_split[OF cleanReply_sc_with_reply_None_corres]) - apply (rule replyUnlinkTcb_corres[simplified dc_def]) - apply wpsimp - apply wpsimp - apply clarsimp - apply (frule (1) st_tcb_reply_state_refs, frule valid_objs_valid_tcbs) - apply (fastforce simp: obj_at_def is_reply reply_tcb_reply_at_def pred_tcb_at_def) - apply simp - apply (clarsimp cong: conj_cong) - apply (case_tac "replyPrev reply'"; simp) - apply (rename_tac prev_rp) - apply (rule sr_inv_imp) - apply (rule_tac P =\ and - P'=" (\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prev_rp = Some rp)" - in updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def projectKOs obj_at'_def obj_at_def - elim!: opt_mapE) - apply clarsimp - apply (drule_tac rp=prev_rp in sc_replies_relation_replyNext_update, simp) - apply simp - apply simp - apply clarsimp - apply wpsimp - apply wpsimp - apply (clarsimp dest!: reply_ko_at_valid_objs_valid_reply' - simp: valid_reply'_def) - apply (wpsimp wp: sc_replies_update_takeWhile_sc_with_reply - sc_replies_update_takeWhile_middle_sym_refs - sc_replies_update_takeWhile_valid_replies) - apply (wpsimp wp: updateReply_valid_objs' updateReply_ko_at'_other) - apply (clarsimp cong: conj_cong) - apply simp - apply (clarsimp simp: valid_reply'_def) - apply (rule context_conjI) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply (clarsimp simp: obj_at_def del: opt_mapE) - apply (frule (1) valid_sched_context_objsI) - apply (clarsimp simp: valid_sched_context_def del: opt_mapE) - apply (frule (4) next_reply_in_sc_replies[OF state_relation_sc_replies_relation]) - apply (fastforce dest!: state_relationD pspace_aligned_cross pspace_distinct_cross) - apply (fastforce dest!: state_relationD pspace_distinct_cross) - apply (fastforce dest!: state_relationD pspace_relation_pspace_bounded') - apply (clarsimp simp: obj_at'_def) - apply (clarsimp simp: vs_heap_simps) - apply clarsimp - apply (rule conjI) - apply (clarsimp simp: list_all_iff dest!: set_takeWhileD) - apply (drule (2) sc_replies_middle_reply_sc_None) - apply (clarsimp simp: vs_heap_simps obj_at_def elim!: opt_mapE) - apply (fastforce simp: obj_at_def is_sc_obj_def elim!: valid_sched_context_size_objsI) - apply (erule reply_sc_reply_at) - apply (clarsimp simp: reply_sc_reply_at_def obj_at_def) - apply (fastforce elim!: sym_refs_replyNext_replyPrev_sym[THEN iffD2] - simp: opt_map_red obj_at'_def projectKOs) - apply (wpsimp simp: get_sk_obj_ref_def wp: get_reply_exs_valid) - apply (fastforce dest!: Reply_or_Receive_reply_at[rotated] simp: obj_at_def is_reply) - apply simp - apply (wpsimp wp: get_sk_obj_ref_wp) - apply (clarsimp simp: obj_at_def reply_sc_reply_at_def) - apply (wpsimp simp: get_sk_obj_ref_def get_simple_ko_def obj_at_def - wp: get_object_wp) - apply (prop_tac "reply_at rp s") - apply (fastforce dest!: st_tcb_at_valid_st2 simp: valid_tcb_state_def) - apply (fastforce simp: obj_at_def is_reply partial_inv_def a_type_def) - apply (wpsimp wp: get_sched_context_exs_valid) - apply (drule sc_with_reply_SomeD) - apply (wpsimp simp: is_sc_obj_def - | clarsimp split: Structures_A.kernel_object.splits)+ - apply (fastforce dest!: sc_with_reply_SomeD1 simp: sc_replies_sc_at_def obj_at_def) - apply (wpsimp wp: get_sched_context_no_fail) - apply (fastforce dest!: sc_with_reply_SomeD elim!: valid_sched_context_size_objsI - simp: obj_at_def is_sc_obj_def) - apply wpsimp - apply wpsimp - apply (fastforce dest!: st_tcb_at_valid_st2 simp: valid_tcb_state_def) - apply wpsimp - apply (wpsimp wp: get_reply_inv' wp_del: getReply_wp) - apply (wpsimp simp: getReply_def) - apply clarsimp - apply wpsimp - apply wpsimp - apply clarsimp - apply (wpsimp wp: gts_wp) - apply wpsimp - 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) - apply (clarsimp, rule conjI) - using fold_list_refs_of_replies' apply metis - apply (clarsimp simp: st_tcb_at'_def obj_at'_def projectKOs) - apply (rename_tac tcb reply) - apply (case_tac "tcbState tcb"; simp) - done - -lemma setSchedContext_pop_head_corres: - "\ replyNext reply' = Some (Head ptr) \ \ - corres dc - ((\s. (sc_replies_of s |> hd_opt) ptr = Some rp) - and valid_objs and pspace_aligned and pspace_distinct) - (ko_at' reply' rp) - (update_sched_context ptr (sc_replies_update tl)) - (do sc' \ getSchedContext ptr; - setSchedContext ptr (scReply_update (\_. replyPrev reply') sc') - od)" - supply opt_mapE[elim!] - apply (rule_tac Q="sc_at' ptr" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD simp: obj_at_def is_sc_obj_def vs_heap_simps - elim!: sc_at_cross valid_objs_valid_sched_context_size) - apply (rule_tac Q="pspace_aligned' and pspace_distinct'" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD elim!: pspace_aligned_cross pspace_distinct_cross) - apply (rule_tac Q="\s'. scReplies_of s' ptr = Some rp" in corres_cross_add_guard) - apply (subst sc_replies_relation_scReplies_of[symmetric, OF state_relation_sc_replies_relation]) - apply simp - apply clarsimp - apply (fastforce simp: opt_map_red dest!: sc_at'_cross[OF state_relation_pspace_relation]) - apply (clarsimp simp: opt_map_red obj_at_simps)+ - apply (rule corres_symb_exec_r) - apply (rule_tac P'="ko_at' sc' ptr and ko_at' reply' rp - and pspace_aligned' and pspace_distinct' and K (scReply sc' = Some rp)" in corres_inst) - apply (rule corres_gen_asm2') - apply (rule_tac Q="sc_obj_at (objBits sc' - minSchedContextBits) ptr" in corres_cross_add_abs_guard) - apply (fastforce dest!: state_relationD ko_at_sc_cross) +lemma (in delete_one) cancelIPC_ReplyCap_corres: + "corres dc (einvs and st_tcb_at awaiting_reply t) + (invs' and st_tcb_at' awaiting_reply' t) + (reply_cancel_ipc t) + (do y \ threadSet (\tcb. tcb \ tcbFault := None \) t; + slot \ getThreadReplySlot t; + callerCap \ liftM (mdbNext \ cteMDBNode) (getCTE slot); + when (callerCap \ nullPointer) (do + y \ stateAssert (capHasProperty callerCap (\cap. isReplyCap cap + \ \ capReplyMaster cap)) + []; + cteDeleteOne callerCap + od) + od)" + proof - + interpret Arch . (*FIXME: arch-split*) + show ?thesis + apply (simp add: reply_cancel_ipc_def getThreadReplySlot_def + locateSlot_conv liftM_def tcbReplySlot_def + del: split_paired_Ex) + apply (rule_tac Q="\_. invs and valid_list and valid_sched and st_tcb_at awaiting_reply t" + and Q'="\_. invs' and st_tcb_at' awaiting_reply' t" + in corres_underlying_split) apply (rule corres_guard_imp) - apply (rule_tac P="(\s. (sc_replies_of s |> hd_opt) ptr = Some rp) - and sc_obj_at (objBits sc' - minSchedContextBits) ptr" - and n1="objBits sc' - minSchedContextBits" - in monadic_rewrite_corres_l[OF update_sched_context_rewrite]) - apply (rule corres_symb_exec_l) - apply (rule corres_guard_imp) - apply (rule_tac P="(\s. kheap s ptr = - Some (kernel_object.SchedContext sc (objBits sc' - minSchedContextBits))) - and K (rp = hd (sc_replies sc))" - and P'="ko_at' sc' ptr and ko_at' reply' rp - and pspace_distinct' and pspace_aligned'" in corres_inst) - apply (rule corres_gen_asm') - apply (rule stronger_corres_guard_imp) - apply (rule_tac sc=sc and sc'=sc' in setSchedContext_update_corres; simp?) - apply (clarsimp simp: sc_relation_def objBits_simps)+ - apply (clarsimp simp: obj_at'_def projectKOs) - apply (prop_tac "heap_ls (replyPrevs_of s') (Some rp) (sc_replies sc)") - apply (drule state_relation_sc_replies_relation) - apply (drule (2) sc_replies_relation_prevs_list, simp) - apply (case_tac "sc_replies sc"; clarsimp simp: opt_map_red) - apply simp - apply simp - apply (wpsimp wp: get_sched_context_exs_valid simp: is_sc_obj_def obj_at_def) - apply (rename_tac ko xs; case_tac ko; clarsimp) - apply simp - apply (wpsimp simp: obj_at_def is_sc_obj_def vs_heap_simps opt_pred_def) - apply (wpsimp wp: get_sched_context_no_fail simp: obj_at_def is_sc_obj) - apply (clarsimp simp: obj_at_def is_sc_obj_def) - apply simp - apply (wpsimp simp: projectKOs obj_at'_def)+ - done - -lemma sched_context_donate_weak_valid_sched_action[wp]: - "\weak_valid_sched_action and bound_sc_tcb_at ((=) None) tcb_ptr\ - sched_context_donate sc_ptr tcb_ptr - \\_. weak_valid_sched_action\" - apply (wpsimp wp: set_tcb_obj_ref_wp update_sched_context_wp test_reschedule_wp - tcb_sched_action_wp get_sc_obj_ref_wp - simp: sched_context_donate_def tcb_release_remove_def) - apply (frule weak_valid_sched_action_no_sc_sched_act_not) - apply (fastforce simp: vs_all_heap_simps tcb_at_kh_simps) - by (auto simp: obj_at_kh_kheap_simps vs_all_heap_simps fun_upd_def pred_map_simps tcb_sched_dequeue_def scheduler_act_not_def - valid_sched_action_def weak_valid_sched_action_def opt_map_simps map_join_simps - cong: conj_cong) - -crunch sched_context_donate - for sc_at[wp]: "sc_at scp" - (simp: crunch_simps wp: crunch_wps) - -crunch rescheduleRequired, setQueue, tcbSchedEnqueue, tcbReleaseRemove, updateReply - for scReplies_of[wp]: "\s. P' (scReplies_of s)" - (simp: crunch_simps wp: crunch_wps) - -crunch updateReply, setSchedContext, updateSchedContext - for tcbSCs_of[wp]: "\s. P' (tcbSCs_of s)" - and list_refs_of_replies'[wp]: "\s. P (list_refs_of_replies' s)" - (simp: crunch_simps opt_map_Some_eta_fold wp: crunch_wps) - -lemma scReplies_of_scTCB_update[simp]: - "\ ko_at' sc scp s\ - \ P (\a. if a = scp then scReply (scTCB_update (\_. Some tp) sc) else scReplies_of s a) - \ P (scReplies_of s)" - by (fastforce simp: obj_at'_def projectKOs opt_map_red elim!: rsubst[where P=P]) - -crunch schedContextDonate - for replies_of': "\s. P (replies_of' s)" (* this interfers with list_refs_of_replies' *) - and scReplies_of[wp]: "\s. P' (scReplies_of s)" - (simp: crunch_simps wp: crunch_wps) - -lemma updateReply_replyNext_update_None: - "\ \ \ - updateReply rp (replyNext_update Map.empty) - \\rv s. (replies_of' s |> replyNext) rp = None \" - by (wpsimp wp: updateReply_wp_all) - -lemma update_sched_context_sc_replies_update_tl: - "\\s. \x. (kheap s |> sc_of ||> sc_replies) scp = Some (x#list)\ - update_sched_context scp (sc_replies_update tl) - \\_. sc_replies_sc_at ((=) list) scp\" - apply (wpsimp wp: update_sched_context_wp) - apply (clarsimp simp: obj_at_def sc_replies_sc_at_def opt_map_red) - done - -lemma setSchedContext_local_sym_refs: - "\\s. ko_at' r' rp s \ ko_at' sc scp s \ replyPrev r' \ Some rp - \ (\p'. p' \ scp \ scReplies_of s p' \ Some rp)\ - setSchedContext scp (scReply_update (\_. replyPrev r') sc) - \\rv s. \p'. scReplies_of s p' \ Some rp\" - apply (wpsimp wp: setObject_sc_wp simp: setSchedContext_def) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red elim!: opt_mapE split: if_split_asm) - apply (drule_tac x=p' in spec) - apply (clarsimp simp: opt_map_red) - done - -lemma replyPop_corres: - "\st = Structures_A.thread_state.BlockedOnReply rp; - st' = Structures_H.thread_state.BlockedOnReply (Some rp)\ \ - corres dc - (valid_objs and pspace_aligned and pspace_distinct - and st_tcb_at ((=) st) t and weak_valid_sched_action - and sc_at scp and reply_at rp and active_scs_valid - and valid_replies and (\s. sym_refs (state_refs_of s)) - and bound_sc_tcb_at ((=) tcbsc) t - and reply_tcb_reply_at ((=) (Some t)) rp - and (\s. sc_with_reply rp s = Some scp) - and (\s. (sc_replies_of s |> hd_opt) scp = Some rp)) - (valid_objs' and valid_release_queue_iff and valid_queues and valid_queues' - and reply_at' rp and sc_at' scp - and (\s'. sym_refs (list_refs_of_replies' s'))) - (do x <- reply_unlink_sc scp rp; - y <- when (tcbsc = None) (sched_context_donate scp t); - reply_unlink_tcb t rp - od) - (replyPop rp t)" - (is "\ _ ; _ \ \ corres _ (?abs_guard and valid_replies and (\s. sym_refs (state_refs_of s)) - and bound_sc_tcb_at ((=) tcbsc) t and reply_tcb_reply_at ((=) (Some t)) rp - and (\s. sc_with_reply rp s = _) and ?sc_replies) - (?conc_guard and (\s'. sym_refs (list_refs_of_replies' s'))) _ _") - supply if_split[split del] opt_mapE[elim!] - 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="\s. tcbSCs_of s t = tcbsc" in corres_cross_add_guard) - apply (fastforce dest!: bound_sc_tcb_at_cross elim!: obj_at'_weakenE) - 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_tac Q="\s. scReplies_of s scp = Some rp" in corres_cross_add_guard) - apply (fastforce simp: opt_map_red obj_at'_def projectKOs - 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 - 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))" - in corres_symb_exec_l) - apply (rename_tac sc) - apply (rule corres_gen_asm') (* sc_replies sc = rp # ls, distinct (rp#ls) *) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: sym_refs_asrt_def) + apply (rule threadset_corresT; simp?) + apply (simp add: tcb_relation_def fault_rel_optionation_def) + apply (simp add: tcb_cap_cases_def) + apply (simp add: tcb_cte_cases_def) + apply (simp add: exst_same_def) + apply (fastforce simp: st_tcb_at_tcb_at) + apply clarsimp + defer + apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state + threadSet_invs_trivial threadSet_pred_tcb_no_state thread_set_not_state_valid_sched + | fastforce simp: tcb_cap_cases_def inQ_def + | wp (once) sch_act_simple_lift)+ + apply (rule corres_underlying_split) 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 - 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')) - and pspace_aligned' and pspace_distinct' and pspace_bounded' and (\s. sym_refs (state_refs_of' s)) - and st_tcb_at' ((=) st') t and (\s. tcbSCs_of s t = tcbsc) and ko_at' r' rp - and (\s. scReplies_of s scp = Some rp) - and K (replyTCB r' = Some t) and K (replyNext r' = Some (Head scp))" - in corres_inst) - apply (rule corres_gen_asm2') (* replyNext r' = Some (Head scp) *) - apply (rule corres_gen_asm2') (* replyTCB r' = Some t *) - apply (erule exE, rename_tac list) - apply (rule_tac F="case list of [] \ replyPrev r' = None | a#_ \ replyPrev r' = Some a" - in corres_req) - apply (clarsimp simp: obj_at_simps) - apply (drule (1) sc_replies_relation_prevs_list'[OF state_relation_sc_replies_relation]) - apply (clarsimp simp: opt_map_red del: opt_mapE) - apply (case_tac list; simp) - apply (simp add: bind_assoc) - 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 - 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')) - and pspace_aligned' and pspace_distinct' and pspace_bounded' - and (\s. sym_refs (state_refs_of' s)) and st_tcb_at' ((=) st') t - and (\s. tcbSCs_of s t = tcbsc) - and (\s. scReplies_of s scp = Some rp) - and ko_at' r' rp and sc_at' scp and K (state = st')" - in corres_inst) - apply (rule corres_gen_asm2') - apply (simp add: bind_assoc isReply_def isHead_def) - apply (subst bind_assoc[symmetric, where m="getSchedContext _"]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setSchedContext_pop_head_corres[where rp=rp]]) - apply simp (* scReplies at scp = replyPrev r', tl (sc_replies sc) *) - 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 - and sc_replies_sc_at ((=) (a#ls)) scp - and ko_at (Structures_A.Reply r) rp - and bound_sc_tcb_at ((=) tcbsc) t" - and P'="?conc_guard and (\s'. sym_refs (list_refs_of_replies' s')) - and st_tcb_at' ((=) st') t and (\s. tcbSCs_of s t = tcbsc) - and ko_at' r' rp and (\s. \p'. scReplies_of s p' \ Some rp) - and (\s. \p'. replyPrevs_of s p' \ Some rp)" - in corres_inst) - apply (rule stronger_corres_guard_imp) - apply (rule updateReply_replyPrev_same_corres) - apply (clarsimp simp: reply_relation_def) - apply clarsimp - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def is_sc_obj) - apply (erule (1) valid_objsE[where x=scp]) - apply (clarsimp simp: valid_obj_def valid_sched_context_def dest!: sym[of _ "sc_replies _"]) - apply (clarsimp simp: obj_at_def) - apply clarsimp - apply (erule valid_objsE'[where x=rp]) - apply (fastforce simp: obj_at'_def projectKOs) - apply (clarsimp simp: valid_obj'_def valid_reply'_def) - 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 - and bound_sc_tcb_at ((=) tcbsc) t - and sc_replies_sc_at (\ls. rp \ set ls) scp - and reply_sc_reply_at ((=) None) rp " - and P'="?conc_guard and st_tcb_at' ((=) st') t - and (\s. (replies_of' s |> replyNext) rp = None) - and (\s. \p'. replyPrevs_of s p' \ Some rp) - and (\s. \p'. scReplies_of s p' \ Some rp) - and (\s. tcbSCs_of s t = tcbsc)" - in corres_inst) - apply (rule_tac Q'="\rv. ?conc_guard and st_tcb_at' ((=) st') t - and (\s. (replies_of' s |> replyNext) rp = None) - and (\s. \p'. replyPrevs_of s p' \ Some rp) - and (\s. \p'. scReplies_of s p' \ Some rp) - and (\s. tcbSCs_of s t = rv)" - in corres_symb_exec_r) - apply (rename_tac tcbsc') - apply (rule stronger_corres_guard_imp) - apply (rule_tac Q'="K (tcbsc' = tcbsc)" in corres_inst_add) - apply (rule corres_gen_asm2') - 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" - and P'="valid_objs' and valid_release_queue_iff - and st_tcb_at' ((=) st') t and reply_at' rp - and (\s. (replies_of' s |> replyNext) rp = None) - and (\s. \p'. replyPrevs_of s p' \ Some rp) - and (\s. \p'. scReplies_of s p' \ Some rp)" - in corres_inst) - apply (rule corres_symb_exec_r_sr_strong) (* replyPrev at rp = None *) - apply (rule corres_guard_imp) - apply (rule replyUnlinkTcb_corres) - apply (clarsimp simp: valid_objs_valid_tcbs elim!: pred_tcb_weakenE) - apply simp - apply (simp add: cleanReply_def) - apply (rule_tac Q'="\_ s. reply_at' rp s \ (replies_of' s |> replyNext) rp = None - \ (\p'. replyPrevs_of s p' \ Some rp) - \ (\p'. scReplies_of s p' \ Some rp)" - in sr_inv_ul_bind[rotated]) - apply (rule updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def) - apply (intro conjI impI allI) - apply (erule sc_replies_relation_replyNext_None; clarsimp) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply clarsimp - apply (wpsimp wp: updateReply_wp_all) - apply (clarsimp simp: obj_at'_def projectKOs objBits_simps ps_clear_upd opt_map_red) - apply (rename_tac s s' reply' sc') - apply (intro conjI allI; clarsimp split: if_split_asm simp: projectKOs) - apply (rename_tac scp' sc'') - apply (drule_tac x=scp' in spec[where P="\x. scReplies_of _ x \ Some rp"]) - apply (clarsimp simp: opt_map_red) - apply (clarsimp simp: sr_inv_def updateReply_def) - apply (clarsimp simp: setReply_def getReply_def getObject_def - setObject_def split_def objBits_simps' - updateObject_default_def in_monad fail_def - in_magnitude_check obj_at_simps return_def - loadObject_default_def ARM_H.fromPPtr_def - split: if_split_asm option.split_asm - dest!: readObject_misc_ko_at') - apply (prop_tac "(ksPSpace s')(rp \ - KOReply (replyNext_update Map.empty reply)) - = ksPSpace s'") - apply (rule ext) - apply (clarsimp simp: opt_map_red split: if_split) - apply (case_tac reply; simp) - apply simp - apply wpsimp - apply wpsimp - apply wpsimp - apply (rule hoare_when_cases, simp) - apply (wpsimp wp: schedContextDonate_valid_objs' - schedContextDonate_replies_of' schedContextDonate_reply_projs) - apply (fastforce split: if_split) - apply (clarsimp simp: pred_tcb_at'_def opt_map_red obj_at_simps pred_tcb_at_def) - apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation, where x=t]) - apply (rename_tac tcb' sc') - apply (clarsimp simp: other_obj_relation_def tcb_relation_def) - apply (wpsimp wp: threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply wpsimp - apply wpsimp - apply wpsimp - apply (wpsimp wp: updateReply_valid_objs' updateReply_replyNext_update_None) - apply wpsimp - apply simp - apply simp - apply wpsimp - apply (elim conjE) - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def) - apply (clarsimp cong: conj_cong imp_cong simp: pred_conj_def) - apply (wpsimp wp: update_sched_context_sc_replies_update_tl) - apply (rule_tac Q'="\_. sc_replies_sc_at ((=) list) scp" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def) - apply (wpsimp wp: update_sched_context_sc_replies_update_tl) - apply (fold updateSchedContext_def) - apply (rule_tac Q'="\_. valid_objs' and valid_release_queue_iff - and valid_queues and valid_queues' - and ko_at' r' rp and sc_at' scp - and (\s. sym_refs (list_refs_of_replies' s)) - and st_tcb_at' ((=) (Structures_H.thread_state.BlockedOnReply (Some rp))) t - and (\s. \p'. scReplies_of s p' \ Some rp) - and (\s. \p'. replyPrevs_of s p' \ Some rp) - and (\s. tcbSCs_of s t = tcbsc)" - in hoare_strengthen_post[rotated]) - apply (clarsimp split: if_split simp: valid_reply'_def opt_map_Some_eta_fold obj_at'_def) - apply (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imp simp: valid_reply'_def) - apply (rule hoare_vcg_conj_lift) - apply (wpsimp wp: updateSchedContext_wp) - apply wpsimp - apply (rule hoare_vcg_conj_lift) - apply (wpsimp wp: setSchedContext_local_sym_refs simp: updateSchedContext_def) - apply wpsimp - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def is_sc_obj opt_map_red) - apply (rule conjI, clarsimp simp: vs_all_heap_simps opt_map_red) - apply (rename_tac n sc0) - apply (clarsimp simp: reply_relation_def) - apply (erule (1) valid_objsE[where x=scp]) - apply (clarsimp simp: valid_obj_def valid_sched_context_def obj_at_def) - apply (case_tac "sc_replies sc0"; simp) - apply (intro conjI impI allI; rename_tac ls; case_tac ls; clarsimp) - apply (clarsimp simp: valid_obj'_def projectKOs opt_map_red opt_map_Some_eta_fold) - apply (intro conjI impI) - apply (fastforce simp: obj_at'_def opt_map_red opt_pred_def projectKOs - valid_sched_context'_def valid_obj'_def valid_reply'_def) - apply (fold fun_upd_def) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red ps_clear_upd objBits_simps - split: if_split) - apply (fastforce dest!: sym_refs_replyNext_replyPrev_sym[where rp'=rp and rp=rp, THEN iffD2] - simp: obj_at_simps opt_map_red) - apply (clarsimp del: opt_mapE) - apply (drule (4) sym_refs_scReplies[simplified sym_heap_def, rule_format, THEN iffD1]) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply (clarsimp del: opt_mapE) - apply (drule (1) reply_sym_heap_Prev_Next[simplified sym_heap_def, rule_format, THEN iffD1]) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply wpsimp - apply (fastforce elim!: pred_tcb'_weakenE) - apply wpsimp - apply wpsimp - apply (wpsimp simp: assert_def reply_relation_def split: if_split) - apply wpsimp - apply (wpsimp simp: reply_relation_def) - apply wpsimp - apply (wpsimp wp: get_simple_ko_wp) - apply wpsimp - apply simp - apply (clarsimp del: opt_mapE) - apply (rule conjI) - apply (clarsimp simp: sym_refs_asrt_def pred_tcb_at'_def obj_at'_def projectKOs) - apply (drule sym_ref_Receive_or_Reply_replyTCB') - apply (fastforce simp: obj_at'_def projectKOs) - apply (rule disjI2, rule sym, simp) - apply clarsimp - apply (drule (4) sym_refs_scReplies[simplified sym_heap_def, rule_format, THEN iffD1]) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply (wpsimp wp: get_sched_context_exs_valid) - apply (clarsimp simp: obj_at_def is_sc_obj) - apply simp - 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 (clarsimp simp: obj_at_simps opt_map_red vs_all_heap_simps) - apply wpsimp - apply (clarsimp simp: obj_at_def is_sc_obj) - done - -lemma get_tcb_obj_ref_exs_valid[wp]: - "\tcb. kheap s tp = Some (Structures_A.TCB tcb) - \ \(=) s\ get_tcb_obj_ref f tp \\\_. (=) s\" - by (clarsimp simp: get_tcb_obj_ref_def thread_get_def gets_the_def get_tcb_def bind_def - gets_def get_def return_def exs_valid_def - split: Structures_A.kernel_object.splits) - -lemma replyRemove_corres: - "\ st = Structures_A.thread_state.BlockedOnReply rp; - st'= BlockedOnReply (Some rp)\ \ - corres dc (valid_objs and pspace_aligned and pspace_distinct and valid_replies - and weak_valid_sched_action and active_scs_valid - and st_tcb_at ((=) st) t and (\s. sym_refs (state_refs_of s))) - (valid_objs' and valid_release_queue_iff and valid_queues and valid_queues' - and (\s'. sym_refs (list_refs_of_replies' s')) and K (rp' = rp)) - (reply_remove t rp) (replyRemove rp' t)" - (is "\ _ ; _ \ \ corres _ ?abs_guard ?conc_guard _ _") - apply (rule corres_gen_asm2', simp only:) - 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 (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_split[OF get_reply_corres]) - apply (rename_tac reply reply') - apply (rule_tac P="?abs_guard and ko_at (Structures_A.Reply reply) rp" - and P'="?conc_guard and (\s. sym_refs (state_refs_of' s)) and st_tcb_at' ((=) st') t - and ko_at' reply' rp" - in corres_inst) - apply (rule corres_guard_imp) - apply (rule corres_assert_gen_asm_l) - apply (prop_tac "reply_tcb reply = replyTCB reply'") - apply (clarsimp simp: reply_relation_def) - apply (clarsimp simp: assert_opt_def isReply_def split del: if_split) - apply (rule_tac P="?abs_guard and ko_at (Structures_A.Reply reply) rp" - and P'="?conc_guard and (\s. sym_refs (state_refs_of' s)) and st_tcb_at' ((=) st') t - and ko_at' reply' rp" - in corres_inst) - apply (rule_tac Q'="\rv'. ?conc_guard and st_tcb_at' ((=) st') t and (\s'. sym_refs (state_refs_of' s')) - and ko_at' reply' rp and K (rv' = st')" - in corres_symb_exec_r) - apply (rename_tac rv') - apply (rule corres_gen_asm2') - apply (simp only:) - apply (rule corres_guard_imp) - apply (rule corres_assert_gen_asm2; simp split del: if_split) - apply (rule corres_symb_exec_l) - apply (rename_tac sc_opt) - apply (rule_tac P="?abs_guard and (\s. sc_with_reply rp s = sc_opt) and ko_at (Structures_A.Reply reply) rp" - and P'="?conc_guard and (\s. sym_refs (state_refs_of' s)) and ko_at' reply' rp" - in corres_inst) - apply (rule_tac Q="(\s'. sc_with_reply' rp s' = sc_opt) and pspace_aligned' - and pspace_distinct' and pspace_bounded'" - in corres_cross_add_guard) - apply (frule pspace_relation_pspace_bounded'[OF state_relation_pspace_relation]) - apply (fastforce simp: sc_replies_relation_sc_with_reply_cross_eq - dest!: state_relationD pspace_distinct_cross dest: pspace_aligned_cross) - apply (case_tac sc_opt; simp split del: if_split add: bind_assoc) - (* sc_with_reply rp s = None *) - apply (rule_tac F="replySC reply' = None" in corres_req) - apply (fastforce dest!: sc_with_reply_None_reply_sc_reply_at replySCs_of_cross - elim!: obj_at_weakenE - simp: is_reply obj_at'_def projectKOs opt_map_red) - apply (clarsimp simp: replySC_None_not_head) - apply (simp only: bind_assoc[symmetric]) - apply (rule corres_symb_exec_r_sr) - apply (rule corres_guard_imp) - apply (rule replyUnlinkTcb_corres[simplified dc_def]) - apply (fastforce dest: valid_objs_valid_tcbs st_tcb_reply_state_refs - simp: obj_at_def is_reply reply_tcb_reply_at_def elim!: pred_tcb_weakenE) - apply simp - apply (rule sr_inv_imp) - apply (erule sr_inv_sc_with_reply_None_helper) - apply (fastforce elim!: obj_at_weakenE simp: is_reply) - apply simp - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def obj_at'_def) - apply (fastforce elim!: reply_ko_at_valid_objs_valid_reply') - apply (wpsimp wp: no_fail_sc_wtih_reply_None_helper, simp) - (* sc_with_reply \ None : rp is in a reply stack *) - apply (rename_tac scp) - apply (rule_tac F="replyNext reply' \ None" in corres_req) - apply clarsimp - apply (prop_tac "sc_at scp s") - apply (fastforce dest!: sc_with_reply_SomeD1 - simp: sc_replies_sc_at_def obj_at_def is_sc_obj_def - elim: valid_sched_context_size_objsI) - apply (prop_tac "sc_at' scp s'") - apply (fastforce dest!: state_relationD sc_at_cross) - apply (drule sc_with_reply'_SomeD, clarsimp) - apply (case_tac "hd xs = rp") - apply (drule heap_path_head, clarsimp) - apply (drule (3) sym_refs_scReplies) - apply (clarsimp simp: obj_at'_def projectKOs sym_heap_def elim!: opt_mapE) - apply (frule (1) heap_path_takeWhile_lookup_next) - apply (frule heap_path_head, clarsimp) - apply (prop_tac "takeWhile ((\) rp) xs = hd xs # tl (takeWhile ((\) rp) xs)") - apply (case_tac xs; simp) - apply (simp del: heap_path.simps) - apply (drule_tac p1="hd xs" and ps1="tl (takeWhile ((\) rp) xs)" - in sym_refs_reply_heap_path_doubly_linked_Nexts_rev[where p'=rp, THEN iffD1]) - apply clarsimp - apply (case_tac "rev (tl (takeWhile ((\) rp) xs))"; - clarsimp simp: obj_at'_def projectKOs elim!: opt_mapE) - apply (clarsimp simp: liftM_def bind_assoc split del: if_split) - apply (rename_tac next_reply) - apply (rule_tac Q="\sc. ?abs_guard - and (\s. \n. kheap s scp = Some (Structures_A.SchedContext sc n)) - and (\s. sc_with_reply rp s = Some scp) - and ko_at (Structures_A.Reply reply) rp - and K (rp \ set (sc_replies sc))" - in corres_symb_exec_l) - apply (rename_tac sc) - apply (rule_tac Q="\s. scReplies_of s scp = hd_opt (sc_replies sc) \ sc_at' scp s" - in corres_cross_add_guard) - apply (clarsimp; rule conjI) - apply (frule state_relation_sc_replies_relation) - apply (frule sc_replies_relation_scReplies_of[symmetric]) - apply (fastforce dest!: sc_at_cross valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj_def obj_at'_def) - apply (fastforce dest!: sc_at_cross valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj_def state_relation_def obj_at'_def - projectKOs opt_map_def) - apply (clarsimp simp: sc_replies_of_scs_def map_project_def opt_map_def - scs_of_kh_def) - apply (fastforce dest!: state_relation_pspace_relation sc_at_cross - valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj) - apply (rule corres_gen_asm') - apply (rule corres_symb_exec_l) - apply (rename_tac tcbsc) - apply (rule_tac P="?abs_guard and (\s. sc_with_reply rp s = Some scp) - and obj_at (\ko. \n. ko = Structures_A.SchedContext sc n) scp - and bound_sc_tcb_at ((=) tcbsc) t - and ko_at (Structures_A.Reply reply) rp - and reply_sc_reply_at - (\ko. (hd (sc_replies sc) = rp \ Some scp = ko) - \ (hd (sc_replies sc) \ rp \ None = ko)) rp" - in corres_inst) - apply (rule_tac F="(hd (sc_replies sc) = rp \ replySC reply' = Some scp) - \ (hd (sc_replies sc) \ rp \ replySC reply' = None)" - in corres_req, clarsimp) - apply (drule (1) replySCs_of_cross) - apply (clarsimp simp: obj_at'_def opt_map_red projectKOs getHeadScPtr_def - split: reply_next.splits) - apply (case_tac "hd (sc_replies sc) = rp"; simp add: bind_assoc split del: if_split) - - (* hd (sc_replies sc) = rp & replysc = Some scp: rp is at the head of the queue *) - apply (simp add: isHead_def) - apply (rule corres_guard_imp) - (* replyPop *) - apply (rule replyPop_corres[simplified dc_def]; simp) - apply (clarsimp simp: obj_at_def is_sc_obj is_reply opt_map_red - reply_tcb_reply_at_def vs_all_heap_simps) - apply (drule (1) valid_sched_context_size_objsI, simp) - apply (drule sc_with_reply_SomeD) - apply (metis list.sel(1) list.set_cases) - apply (clarsimp simp: obj_at'_def projectKOs) - - (* rp is in the middle of the reply stack *) - (* hd (sc_replies sc) \ rp & rp \ set (sc_replies sc) *) - apply (simp add: reply_unlink_sc_def bind_assoc liftM_def split del: if_split) - apply (rule_tac Q="\rv. ?abs_guard and (\s. sc_with_reply rp s = Some scp) - and obj_at (\ko. \n. ko = kernel_object.SchedContext sc n) scp - and bound_sc_tcb_at ((=) tcbsc) t - and ko_at (Structures_A.Reply reply) rp - and reply_sc_reply_at ((=) None) rp and K (rv = sc)" - in corres_symb_exec_l) - apply (rule corres_gen_asm', simp split del: if_split) - apply (rule_tac Q="\rv. ?abs_guard and (\s. sc_with_reply rp s = Some scp) - and obj_at (\ko. \n. ko = kernel_object.SchedContext sc n) scp - and bound_sc_tcb_at ((=) tcbsc) t - and ko_at (Structures_A.Reply reply) rp - and reply_sc_reply_at ((=) None) rp and K (rv = reply)" - in corres_symb_exec_l) - apply (rule corres_gen_asm') - apply (simp split del: if_split add: bind_assoc) - apply (rule corres_guard_imp) - apply (rule_tac Q="?conc_guard and ko_at' reply' rp and sc_at' scp - and (\s'. sym_refs (state_refs_of' s')) - and (\s'. sc_with_reply' rp s' = Some scp) - and (\s'. scReplies_of s' scp = hd_opt (sc_replies sc)) - and (\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prp = Some rp)" - in corres_assert_gen_asm_l) - apply (clarsimp simp: getHeadScPtr_def isHead_def neq_conv[symmetric] - split: reply_next.splits) - apply (rename_tac nxt_rp) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split - [OF updateReply_replyPrev_takeWhile_middle_corres]) - apply simp - apply simp - apply (rule_tac P ="?abs_guard and reply_sc_reply_at ((=) None) rp - and ko_at (Structures_A.Reply reply) rp - and bound_sc_tcb_at ((=) tcbsc) t" and - Q ="\s. sc_with_reply rp s = None" and - P'="valid_objs' and valid_release_queue_iff - and ko_at' reply' rp and sc_at' scp" and - Q'="(\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prp = Some rp)" - in corres_inst_add) - apply (rule corres_symb_exec_r_sr) - apply (rule corres_symb_exec_r_sr) - apply (rule corres_guard_imp) - apply (rule replyUnlinkTcb_corres[simplified dc_def]) - apply (fastforce dest: valid_objs_valid_tcbs st_tcb_reply_state_refs - simp: obj_at_def is_reply reply_tcb_reply_at_def elim!: pred_tcb_weakenE) - apply simp - apply (rule sr_inv_imp) - apply (rule cleanReply_sr_inv) - apply simp - apply simp - apply wpsimp - apply wpsimp - apply (clarsimp dest!: state_relationD simp: reply_sc_reply_at_def) - apply (fastforce intro!: reply_at_cross elim!: obj_at_weakenE simp: is_reply) - apply (clarsimp cong: conj_cong) - apply (case_tac "replyPrev reply'"; simp) - apply (rename_tac prev_rp) - apply (rule sr_inv_imp) - apply (rule_tac P =\ and - P'=" (\s'. \prp. replyPrev reply' = Some prp - \ replyNexts_of s' prev_rp = Some rp)" - in updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def projectKOs obj_at'_def obj_at_def - elim!: opt_mapE) - apply clarsimp - apply (drule_tac rp=prev_rp in sc_replies_relation_replyNext_update, simp) - apply simp - apply simp - apply clarsimp - apply wpsimp - apply wpsimp - apply (clarsimp dest!: reply_ko_at_valid_objs_valid_reply' - simp: valid_reply'_def) - apply (wpsimp wp: sc_replies_update_takeWhile_sc_with_reply - sc_replies_update_takeWhile_middle_sym_refs - sc_replies_update_takeWhile_valid_replies) - apply (wpsimp wp: updateReply_valid_objs' updateReply_ko_at'_other) - apply (clarsimp cong: conj_cong) - apply simp - apply (clarsimp simp: valid_reply'_def) - apply (rule context_conjI) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply (clarsimp simp: obj_at_def del: opt_mapE) - apply (frule (1) valid_sched_context_objsI) - apply (clarsimp simp: valid_sched_context_def del: opt_mapE) - apply (frule (4) next_reply_in_sc_replies[OF state_relation_sc_replies_relation]) - apply (fastforce dest!: state_relationD pspace_aligned_cross pspace_distinct_cross) - apply (fastforce dest!: state_relationD pspace_distinct_cross) - apply (fastforce dest!: state_relationD pspace_relation_pspace_bounded') - apply (clarsimp simp: obj_at'_def) - apply (clarsimp simp: vs_heap_simps) - apply clarsimp - apply (rule conjI) - apply (clarsimp simp: list_all_iff dest!: set_takeWhileD) - apply (clarsimp simp: reply_relation_def) - apply (fastforce elim!: sym_refs_replyNext_replyPrev_sym[THEN iffD2] - simp: opt_map_red obj_at'_def projectKOs) - apply (wpsimp simp: get_sk_obj_ref_def wp: get_reply_exs_valid) - apply (fastforce dest!: Reply_or_Receive_reply_at[rotated] - simp: obj_at_def is_reply) - apply simp - apply (wpsimp wp: get_simple_ko_wp) - apply (clarsimp simp: obj_at_def reply_sc_reply_at_def) - apply (wpsimp simp: get_sk_obj_ref_def get_simple_ko_def obj_at_def - wp: get_object_wp) - apply (fastforce simp: obj_at_def is_reply partial_inv_def a_type_def) - apply (wpsimp wp: get_sched_context_exs_valid) - apply (drule sc_with_reply_SomeD) - apply clarsimp+ - apply (wpsimp simp: obj_at_def) - apply (wpsimp wp: get_sched_context_no_fail) - apply (fastforce elim!: valid_sched_context_size_objsI simp: obj_at_def is_sc_obj_def) - apply (wpsimp simp: pred_tcb_at_def obj_at_def) - apply (wpsimp wp: gbsc_bound_tcb simp: obj_at_def) - apply (clarsimp simp: obj_at_def reply_sc_reply_at_def is_reply) - apply (case_tac "sc_replies sc"; simp) - apply (intro conjI impI) - apply (fastforce dest!: sym_refs_reply_sc_reply_at - simp: sc_replies_sc_at_def obj_at_def reply_sc_reply_at_def) - apply (fastforce dest!: sc_replies_middle_reply_sc_None - simp: vs_heap_simps obj_at_def is_sc_obj is_reply reply_sc_reply_at_def - elim!: valid_sched_context_size_objsI opt_mapE) - apply (wpsimp simp: get_tcb_obj_ref_def thread_get_def st_tcb_def2) - apply (wpsimp wp: get_sched_context_exs_valid) - apply (fastforce dest!: sc_with_reply_SomeD1 simp: sc_replies_sc_at_def obj_at_def) - apply simp - apply wpsimp - apply (fastforce dest!: sc_with_reply_SomeD1 simp: sc_replies_sc_at_def obj_at_def) - apply (wpsimp wp: get_sched_context_no_fail) - apply (fastforce dest!: sc_with_reply_SomeD1 simp: sc_replies_sc_at_def is_sc_obj obj_at_def - elim!: obj_at_weakenE valid_sched_context_size_objsI) - apply wpsimp - apply wpsimp - apply wpsimp - apply simp - apply (fastforce dest!: st_tcb_at_valid_st2 simp: valid_tcb_state_def) - apply clarsimp - apply (wpsimp simp: op_equal) - apply wpsimp - apply wpsimp - apply (fastforce dest: valid_objs_valid_tcbs st_tcb_reply_state_refs - simp: obj_at_def is_reply reply_tcb_reply_at_def) - apply clarsimp - 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 (rule get_cap_corres [where cslot_ptr="(t, tcb_cnode_index 2)", + simplified cte_map_tcb_2 cte_index_repair_sym]) + apply (clarsimp dest!: st_tcb_at_tcb_at + tcb_at_cte_at [where ref="tcb_cnode_index 2"]) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + defer + apply (rule hoare_vcg_conj_lift [OF get_cap_inv get_cap_cte_wp_at, simplified]) + apply (rule hoare_vcg_conj_lift [OF getCTE_inv getCTE_cte_wp_at, simplified]) + apply (rename_tac cte) + apply (rule corres_symb_exec_l [OF _ _ gets_sp]) + apply (rule_tac F="\r. cap = cap.ReplyCap t True r \ + cteCap cte = capability.ReplyCap t True (AllowGrant \ r)" in corres_req) + apply (fastforce simp: cte_wp_at_caps_of_state is_cap_simps + dest!: st_tcb_at_reply_cap_valid) + apply (rule_tac F="(descs = {}) = (mdbNext (cteMDBNode cte) = nullPointer)" + in corres_req) + apply (fastforce simp: st_tcb_at_tcb_at cte_wp_at_ctes_of st_tcb_def2 cte_index_repair + dest: reply_descendants_of_mdbNext) + apply (elim exE) + apply (case_tac "descs = {}", simp add: when_def) + apply (rule_tac F="\sl. descs = {sl}" in corres_req) + apply (fastforce intro: st_tcb_at_tcb_at dest: reply_master_one_descendant) + apply (erule exE, frule singleton_eqD) + apply (rule_tac F="mdbNext (cteMDBNode cte) = cte_map sl" in corres_req) + apply (clarsimp dest!: st_tcb_at_tcb_at) + apply (fastforce simp: cte_wp_at_ctes_of cte_level_bits_def + elim!: reply_mdbNext_is_descendantD) + apply (simp add: when_def getSlotCap_def capHasProperty_def + del: split_paired_Ex) + apply (rule corres_guard_imp) + apply (rule_tac P'="\s. \r'. cte_wp_at ((=) (cap.ReplyCap t False r')) sl s" + in corres_stateAssert_implied [OF delete_one_corres]) + apply (fastforce dest: pspace_relation_cte_wp_at + state_relation_pspace_relation + simp: cte_wp_at_ctes_of isCap_simps) + apply (fastforce simp: invs_def valid_state_def valid_mdb_def reply_mdb_def + reply_masters_mdb_def cte_wp_at_caps_of_state + can_fast_finalise_def) + apply (fastforce simp: valid_mdb'_def valid_mdb_ctes_def + cte_wp_at_ctes_of nullPointer_def + elim: valid_dlistEn dest: invs_mdb') + apply (simp add: exs_valid_def gets_def get_def return_def bind_def + del: split_paired_Ex split_paired_All) + apply (wp) done +qed -lemma cancel_ipc_corres: - "corres dc (invs and valid_ready_qs and tcb_at t) invs' +lemma (in delete_one) cancel_ipc_corres: + "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) (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]) - apply clarsimp apply (rule corres_guard_imp) apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_split) - apply (rule threadset_corres; simp?) - 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 - 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) - apply (rename_tac epPtr reply pl) - apply (rule_tac st = "Structures_A.thread_state.BlockedOnReceive epPtr reply pl" - in blocked_cancelIPC_corres[simplified]) - apply simp - apply (clarsimp simp: thread_state_relation_def) - apply simp+ - apply (clarsimp simp: invs_implies) - apply (clarsimp simp: invs'_implies) - apply (rule corres_guard_imp) - apply (rename_tac epPtr data) - apply (rule_tac st = "Structures_A.thread_state.BlockedOnSend epPtr data" - 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 (clarsimp simp: invs'_implies) + apply (rule_tac P="einvs 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)[1] apply (rule corres_guard_imp) - apply (rule replyRemoveTCB_corres) + apply (rule blocked_cancelIPC_corres) + apply fastforce + apply fastforce apply simp - apply (clarsimp simp: thread_state_relation_def) - apply (clarsimp simp: invs_implies) - apply (clarsimp simp: invs'_implies) + apply simp + apply (clarsimp simp add: isTS_defs list_case_If) 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 (wpsimp wp: threadSet_pred_tcb_no_state threadSet_invs_trivial)+ - apply (wp gts_sp[where P="\", simplified])+ + apply (rule blocked_cancelIPC_corres) + apply fastforce + apply fastforce + apply simp + apply simp + apply (rule corres_guard_imp) + apply (rule cancelIPC_ReplyCap_corres) + apply (clarsimp elim!: st_tcb_weakenE) + apply (clarsimp elim!: pred_tcb'_weakenE) + apply (rule corres_guard_imp [OF cancelSignal_corres], simp+) + apply (wp gts_sp[where P="\",simplified])+ apply (rule hoare_strengthen_post) apply (rule gts_sp'[where P="\"]) apply (clarsimp elim!: pred_tcb'_weakenE) - apply simp - apply (clarsimp simp: inQ_def obj_at'_def projectKOs valid_release_queue'_def - dest!: invs_valid_release_queue') + apply fastforce + apply simp done lemma setNotification_utr[wp]: @@ -1743,6 +636,10 @@ lemma setNotification_utr[wp]: apply (simp add: o_def) done +crunch setEndpoint + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: setObject_ksPSpace_only updateObject_default_inv) + lemma setEndpoint_utr[wp]: "\untyped_ranges_zero'\ setEndpoint p ep \\rv. untyped_ranges_zero'\" apply (simp add: cteCaps_of_def) @@ -1753,10 +650,14 @@ lemma setEndpoint_utr[wp]: declare cart_singleton_empty [simp] declare cart_singleton_empty2[simp] +crunch setNotification + for ksQ[wp]: "\s. P (ksReadyQueues s p)" + (wp: setObject_queues_unchanged_tcb updateObject_default_inv) + 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*) +context begin interpretation Arch . (*FIXME: arch-split*) crunch setNotification for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers @@ -1764,73 +665,81 @@ crunch setNotification (wp: valid_bitmaps_lift) lemma cancelSignal_invs': - "\invs' and st_tcb_at' (\st. st = BlockedOnNotification ntfn) t\ - cancelSignal t ntfn - \\_. invs'\" + "\invs' and st_tcb_at' (\st. st = BlockedOnNotification ntfn) t and sch_act_not t\ + cancelSignal t ntfn \\rv. invs'\" proof - - have NIQ: "\s. \ valid_queues s; - \d p. \t\set (ksReadyQueues s (d, p)). st_tcb_at' runnable' t s; - st_tcb_at' (Not \ runnable') t s \ - \ \d p. t \ set (ksReadyQueues s (d,p))" - apply (clarsimp simp add: pred_tcb_at'_def Invariants_H.valid_queues_def - valid_queues_no_bitmap_def) - apply (drule spec | drule(1) bspec | clarsimp simp: obj_at'_def inQ_def)+ - done have NTFNSN: "\ntfn ntfn'. \\s. sch_act_not (ksCurThread s) s \ setNotification ntfn ntfn' \\_ s. sch_act_not (ksCurThread s) s\" apply (rule hoare_weaken_pre) - apply (wps) + apply (wps setNotification_ksCurThread) apply (wp, simp) done show ?thesis - apply (simp add: cancelSignal_def invs'_def Let_def valid_dom_schedule'_def) - apply (rule bind_wp[OF _ stateAssert_sp]) + apply (simp add: cancelSignal_def invs'_def valid_state'_def Let_def) apply (wp valid_irq_node_lift sts_sch_act' irqs_masked_lift - hoare_vcg_all_lift [OF set_ntfn'.ksReadyQueues] - setThreadState_ct_not_inQ NTFNSN set_ntfn'.get_wp - hoare_vcg_all_lift set_ntfn'.ksReadyQueues hoare_vcg_imp_lift' + hoare_vcg_all_lift + setThreadState_ct_not_inQ NTFNSN + hoare_vcg_all_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 (frule (1) NIQ) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (case_tac "ntfnObj ko", simp_all add: isWaitingNtfn_def) + prefer 2 + apply assumption + apply (rule hoare_strengthen_post) + apply (rule get_ntfn_sp') + apply (rename_tac rv s) + apply (clarsimp simp: pred_tcb_at') apply (rule conjI) apply (clarsimp simp: valid_ntfn'_def) - apply normalise_obj_at' + apply (case_tac "ntfnObj rv", simp_all add: isWaitingNtfn_def) apply (frule ko_at_valid_objs') apply (simp add: valid_pspace_valid_objs') apply (clarsimp simp: projectKO_opt_ntfn split: kernel_object.splits) - apply (simp add: valid_obj'_def valid_ntfn'_def) - apply (rule conjI, clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (rule conjI, erule_tac rfs'="list_refs_of_replies' s" in delta_sym_refs) - subgoal - by (auto simp: symreftype_inverse' list_refs_of_replies'_def - get_refs_def2 opt_map_def - split: option.splits) - subgoal - by (auto simp: symreftype_inverse' list_refs_of_replies'_def - get_refs_def2 opt_map_def - split: option.splits) - apply (frule obj_at_valid_objs', clarsimp) - apply (clarsimp simp: projectKOs 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: projectKOs valid_obj'_def valid_ntfn'_def) - apply (rule conjI, clarsimp split: option.splits) + apply (simp add: 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 (rule conjI) + apply (rule conjI, erule delta_sym_refs) + apply (clarsimp simp: ntfn_bound_refs'_def split: if_split_asm) apply (clarsimp split: if_split_asm) - apply (fastforce simp: list_refs_of_replies'_def opt_map_def o_def split: option.splits) - apply (fastforce simp: get_refs_def elim!: if_live_state_refsE split: option.splits) - done + subgoal + by (fastforce simp: symreftype_inverse' ntfn_bound_refs'_def + tcb_bound_refs'_def ntfn_q_refs_of'_def obj_at'_def projectKOs + split: ntfn.splits option.splits) + subgoal + by (fastforce simp: symreftype_inverse' ntfn_bound_refs'_def + tcb_bound_refs'_def) + subgoal + by (fastforce simp: symreftype_inverse' ntfn_bound_refs'_def + tcb_bound_refs'_def ntfn_q_refs_of'_def remove1_empty + split: ntfn.splits) + apply (rule conjI, clarsimp elim!: if_live_state_refsE) + apply (fastforce simp: sym_refs_def dest!: idle'_no_refs) + apply (case_tac "ntfnObj rv", simp_all) + apply (frule obj_at_valid_objs', clarsimp) + apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def) + apply (rule conjI, clarsimp split: option.splits) + apply (frule st_tcb_at_state_refs_ofD') + apply (frule ko_at_state_refs_ofD') + apply (rule conjI) + apply (erule delta_sym_refs) + apply (fastforce simp: ntfn_bound_refs'_def split: if_split_asm) + apply (clarsimp split: if_split_asm) + apply (fastforce simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def + set_eq_subset) + apply (fastforce simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def + set_eq_subset) + apply (clarsimp simp: valid_pspace'_def) + apply (rule conjI, clarsimp elim!: if_live_state_refsE) + apply (rule conjI) + apply (case_tac "ntfnBoundTCB rv") + apply (clarsimp elim!: if_live_state_refsE)+ + apply (rule conjI, clarsimp split: option.splits) + apply (clarsimp dest!: idle'_no_refs) + done qed +lemmas setEndpoint_valid_arch[wp] + = valid_arch_state_lift' [OF setEndpoint_typ_at' set_ep_arch'] + lemma ep_redux_simps3: "ep_q_refs_of' (case xs of [] \ IdleEP | y # ys \ RecvEP (y # ys)) = (set xs \ {EPRecv})" @@ -1840,154 +749,189 @@ lemma ep_redux_simps3: lemma setEndpoint_pde_mappings'[wp]: "\valid_pde_mappings'\ setEndpoint ptr val \\rv. valid_pde_mappings'\" - by (wp valid_pde_mappings_lift') + apply (wp valid_pde_mappings_lift') + apply (simp add: setEndpoint_def) + apply (rule obj_at_setObject2) + apply (clarsimp dest!: updateObject_default_result)+ + done -end +declare setEndpoint_ksMachine [wp] +declare setEndpoint_valid_irq_states' [wp] -crunch cancelIPC +lemma setEndpoint_vms[wp]: + "\valid_machine_state'\ setEndpoint epptr ep' \\_. valid_machine_state'\" + by (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) + (wp hoare_vcg_all_lift hoare_vcg_disj_lift) + +crunch setEndpoint + for ksQ[wp]: "\s. P (ksReadyQueues s p)" + (wp: setObject_queues_unchanged_tcb updateObject_default_inv) + +crunch setEndpoint + for sch_act_not[wp]: "sch_act_not t" + +crunch setEndpoint for ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksInterruptState[wp]: "\s. P (ksInterruptState s)" - and ksMachineState[wp]: "\s. P (ksMachineState s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and sch_act_simple[wp]: "sch_act_simple" - and valid_pde_mappings'[wp]: "valid_pde_mappings'" - and ifunsafe'[wp]: "if_unsafe_then_cap'" - and global_refs'[wp]: "valid_global_refs'" - 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: crunch_wps simp: crunch_simps) + (wp: setObject_ep_cur_domain) -crunch blockedCancelIPC - for valid_queues[wp]: valid_queues - and replyNexts_replyPrevs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s)" - (wp: crunch_wps) +lemma setEndpoint_ksDomSchedule[wp]: + "\\s. P (ksDomSchedule s)\ setEndpoint ptr ep \\_ s. P (ksDomSchedule s)\" + apply (simp add: setEndpoint_def setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done -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" - apply (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) - done - -lemma blockedCancelIPC_valid_pspace'[wp]: - "\valid_pspace' and st_tcb_at' ((=) st) tptr\ - blockedCancelIPC st tptr rptrOpt - \\_. valid_pspace'\" - supply opt_mapE[elim!] - 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 (rule ccontr, normalise_obj_at') - apply (match premises in epQueue: "_ (valid_ep' ep s)" for ep s \ - \rule meta_mp[rotated, where P="valid_ep' ep s"]\) - apply (drule(1) ep_ko_at_valid_objs_valid_ep') - apply (case_tac "remove1 tptr (epQueue ko)"; clarsimp) - apply (clarsimp simp: valid_ep'_def) - apply (fastforce dest: nonempty_epQueue_remove1_valid_ep'[rotated]) - apply (case_tac "rptrOpt"; clarsimp simp: pred_tcb_at'_eq_commute) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (rename_tac rptr reply KOreply) - apply (drule_tac rptr=rptr in valid_replies'D[simplified pred_tcb_at'_eq_commute]) - apply (clarsimp simp: opt_pred_def) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def projectKOs) - 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]: - "blockedCancelIPC st tptr epptr \if_live_then_nonz_cap'\" - unfolding blockedCancelIPC_def getBlockingObject_def - apply (wpsimp wp: getEndpoint_wp haskell_assert_wp) - 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)" - and valid_queues'[wp]: valid_queues' - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - and untyped_ranges_zero'[wp]: "untyped_ranges_zero'" - (wp: crunch_wps) +lemma setEndpoint_ct_idle_or_in_cur_domain'[wp]: + "\ ct_idle_or_in_cur_domain' \ setEndpoint ptr ep \ \_. ct_idle_or_in_cur_domain' \" + apply (rule ct_idle_or_in_cur_domain'_lift) + apply (wp hoare_vcg_disj_lift hoare_vcg_imp_lift setObject_ep_ct + | rule obj_at_setObject2 + | clarsimp simp: updateObject_default_def in_monad setEndpoint_def)+ + done -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 decompose_list_refs_of_replies' valid_dom_schedule'_def - apply (wpsimp wp: valid_irq_node_lift typ_at_lifts - valid_irq_handlers_lift' valid_irq_states_lift' irqs_masked_lift - simp: cteCaps_of_def pred_tcb_at'_def) - done - -lemma threadSet_fault_invs': - "threadSet (tcbFault_update upd) t \invs'\" - apply (wpsimp wp: threadSet_invs_trivial) - apply (clarsimp simp: inQ_def) - apply (rule conjI) - apply clarsimp - apply (frule invs_valid_release_queue') - apply (clarsimp simp: valid_release_queue'_def obj_at'_def) +lemma setEndpoint_ct_not_inQ[wp]: + "\ct_not_inQ\ setEndpoint eeptr ep' \\_. ct_not_inQ\" + apply (rule ct_not_inQ_lift [OF setEndpoint_nosch]) + apply (simp add: setEndpoint_def) + apply (rule hoare_weaken_pre) + apply (wps setObject_ep_ct) + apply (wp obj_at_setObject2) + apply (clarsimp simp: updateObject_default_def in_monad)+ + done + +lemma setEndpoint_ksDomScheduleIdx[wp]: + "setEndpoint ptr ep \\s. P (ksDomScheduleIdx s)\" + apply (simp add: setEndpoint_def setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +end + +crunch setEndpoint + 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 simp: updateObject_default_def) + +lemma (in delete_one_conc) cancelIPC_invs[wp]: + shows "\tcb_at' t and invs'\ cancelIPC t \\rv. invs'\" +proof - + have P: "\xs v f. (case xs of [] \ return v | y # ys \ return (f (y # ys))) + = return (case xs of [] \ v | y # ys \ f xs)" + by (clarsimp split: list.split) + have EPSCHN: "\eeptr ep'. \\s. sch_act_not (ksCurThread s) s\ + setEndpoint eeptr ep' + \\_ s. sch_act_not (ksCurThread s) s\" + apply (rule hoare_weaken_pre) + apply (wps setEndpoint_ct') + apply (wp, simp) + done + have Q: + "\epptr. \st_tcb_at' (\st. \a. (st = BlockedOnReceive epptr a) + \ (\a b c d. st = BlockedOnSend epptr a b c d)) t + and invs'\ + do ep \ getEndpoint epptr; + y \ assert (\ (case ep of IdleEP \ True | _ \ False)); + ep' \ case remove1 t (epQueue ep) + of [] \ return Structures_H.endpoint.IdleEP + | x # xs \ return (epQueue_update (%_. x # xs) ep); + y \ setEndpoint epptr ep'; + setThreadState Inactive t + od \\rv. invs'\" + apply (simp add: invs'_def valid_state'_def) + apply (subst P) + apply (wp valid_irq_node_lift valid_global_refs_lift' valid_arch_state_lift' + irqs_masked_lift sts_sch_act' + hoare_vcg_all_lift [OF setEndpoint_ksQ] + setThreadState_ct_not_inQ EPSCHN + hoare_vcg_all_lift + | simp add: valid_tcb_state'_def split del: if_split + | wpc)+ + prefer 2 + apply assumption + apply (rule hoare_strengthen_post [OF get_ep_sp']) + apply (clarsimp simp: pred_tcb_at' fun_upd_def[symmetric] conj_comms + split del: if_split cong: if_cong) + apply (rule conjI, clarsimp simp: valid_pspace'_def) + apply (rule conjI, clarsimp simp: valid_pspace'_def) + apply (rule conjI, clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) + apply (frule obj_at_valid_objs', clarsimp) + apply (clarsimp simp: projectKOs valid_obj'_def) + apply (rule conjI) + apply (clarsimp simp: obj_at'_def valid_ep'_def projectKOs + dest!: pred_tcb_at') + apply (clarsimp, rule conjI) + apply (auto simp: pred_tcb_at'_def obj_at'_def)[1] + apply (rule conjI) + apply (clarsimp split: Structures_H.endpoint.split_asm list.split + simp: valid_ep'_def) + apply (rename_tac list x xs) + apply (frule distinct_remove1[where x=t]) + apply (cut_tac xs=list in set_remove1_subset[where x=t]) + apply auto[1] + apply (rename_tac list x xs) + apply (frule distinct_remove1[where x=t]) + apply (cut_tac xs=list in set_remove1_subset[where x=t]) + apply auto[1] + apply (frule(1) sym_refs_ko_atD') + apply (rule conjI) + apply (clarsimp elim!: if_live_state_refsE split: Structures_H.endpoint.split_asm) + apply (drule st_tcb_at_state_refs_ofD') + apply (clarsimp simp: ep_redux_simps3 valid_ep'_def + split: Structures_H.endpoint.split_asm + cong: list.case_cong) + apply (frule_tac x=t in distinct_remove1) + apply (frule_tac x=t in set_remove1_eq) + by (auto elim!: delta_sym_refs + simp: symreftype_inverse' tcb_st_refs_of'_def tcb_bound_refs'_def + split: thread_state.splits if_split_asm) + have R: + "\invs' and tcb_at' t\ + do y \ threadSet (\tcb. tcb \ tcbFault := None \) t; + slot \ getThreadReplySlot t; + callerCap \ liftM (mdbNext \ cteMDBNode) (getCTE slot); + when (callerCap \ nullPointer) (do + y \ stateAssert (capHasProperty callerCap (\cap. isReplyCap cap + \ \ capReplyMaster cap)) + []; + cteDeleteOne callerCap + od) + od + \\rv. invs'\" + unfolding getThreadReplySlot_def + by (wp valid_irq_node_lift delete_one_invs hoare_drop_imps + threadSet_invs_trivial irqs_masked_lift + | simp add: o_def if_apply_def2 + | fastforce simp: inQ_def)+ + show ?thesis + apply (simp add: cancelIPC_def crunch_simps + cong: if_cong list.case_cong) + apply (rule bind_wp [OF _ gts_sp']) + apply (case_tac state, + simp_all add: isTS_defs) + apply (safe intro!: hoare_weaken_pre[OF Q] + hoare_weaken_pre[OF R] + hoare_weaken_pre[OF return_wp] + hoare_weaken_pre[OF cancelSignal_invs'] + elim!: pred_tcb'_weakenE) + apply (auto simp: pred_tcb_at'_def obj_at'_def + dest: invs_sch_act_wf') done +qed -lemma cancelIPC_invs'[wp]: - "cancelIPC t \invs'\" - unfolding cancelIPC_def Let_def - apply (wpsimp wp: blockedCancelIPC_invs' replyRemoveTCB_invs' cancelSignal_invs' - hoare_vcg_all_lift hoare_vcg_imp_lift' threadSet_fault_invs' gts_wp' - simp: pred_tcb_at'_def) - apply normalise_obj_at' - apply (rename_tac tcb) - apply (case_tac "tcbState tcb"; clarsimp) +lemma (in delete_one_conc_pre) cancelIPC_sch_act_simple[wp]: + "\sch_act_simple\ + cancelIPC t + \\rv. sch_act_simple\" + apply (simp add: cancelIPC_def cancelSignal_def Let_def + cong: if_cong Structures_H.thread_state.case_cong) + apply (wp hoare_drop_imps delete_one_sch_act_simple + | simp add: getThreadReplySlot_def | wpcw + | rule sch_act_simple_lift + | (rule_tac Q'="\rv. sch_act_simple" in hoare_post_imp, simp))+ done lemma cancelSignal_st_tcb_at: - assumes [simp]: "P Inactive" shows + assumes x[simp]: "P Inactive" shows "\st_tcb_at' P t\ cancelSignal t' ntfn \\rv. st_tcb_at' P t\" @@ -1997,12 +941,19 @@ lemma cancelSignal_st_tcb_at: apply clarsimp+ done -lemma cancelIPC_st_tcb_at: - assumes [simp]: "\st. simple' st \ P st" shows - "cancelIPC t' \st_tcb_at' P t\" - unfolding cancelIPC_def - apply (wpsimp wp: blockedCancelIPC_st_tcb_at replyRemoveTCB_st_tcb_at'_cases - cancelSignal_st_tcb_at threadSet_pred_tcb_no_state gts_wp') +lemma (in delete_one_conc_pre) cancelIPC_st_tcb_at: + assumes x[simp]: "\st. simple' st \ P st" shows + "\st_tcb_at' P t\ + cancelIPC t' + \\rv. st_tcb_at' P t\" + apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def + cong: if_cong Structures_H.thread_state.case_cong) + apply (rule bind_wp [OF _ gts_sp']) + apply (case_tac rv, simp_all add: isTS_defs list_case_If) + apply (wp sts_st_tcb_at'_cases delete_one_st_tcb_at + threadSet_pred_tcb_no_state + cancelSignal_st_tcb_at hoare_drop_imps + | clarsimp simp: o_def if_fun_split)+ done lemma weak_sch_act_wf_lift_linear: @@ -2015,6 +966,12 @@ lemma weak_sch_act_wf_lift_linear: apply simp_all done +lemma sts_sch_act_not[wp]: + "\sch_act_not t\ setThreadState st t' \\rv. sch_act_not t\" + apply (simp add: setThreadState_def rescheduleRequired_def) + apply (wp hoare_drop_imps | simp | wpcw)+ + done + crunch cancelSignal, setBoundNotification for sch_act_not[wp]: "sch_act_not t" (wp: crunch_wps) @@ -2025,17 +982,71 @@ lemma cancelSignal_tcb_at_runnable': unfolding cancelSignal_def by (wpsimp wp: sts_pred_tcb_neq' hoare_drop_imp) -lemma setThreadState_st_tcb_at'_test_unaffected: - "\\s. st_tcb_at' test t s \ test st\ - setThreadState st t' - \\_. st_tcb_at' test t\" - apply (wpsimp wp: sts_st_tcb') - done +lemma cancelAllIPC_tcb_at_runnable': + "\st_tcb_at' runnable' t\ cancelAllIPC epptr \\_. st_tcb_at' runnable' t\" + unfolding cancelAllIPC_def + by (wpsimp wp: mapM_x_wp' sts_st_tcb' hoare_drop_imp) + +lemma cancelAllSignals_tcb_at_runnable': + "\st_tcb_at' runnable' t\ cancelAllSignals ntfnptr \\_. st_tcb_at' runnable' t\" + unfolding cancelAllSignals_def + by (wpsimp wp: mapM_x_wp' sts_st_tcb' hoare_drop_imp) crunch unbindNotification, bindNotification, unbindMaybeNotification for st_tcb_at'[wp]: "st_tcb_at' P p" (wp: threadSet_pred_tcb_no_state ignore: threadSet) +lemma (in delete_one_conc_pre) finaliseCap_tcb_at_runnable': + "\st_tcb_at' runnable' t\ finaliseCap cap final True \\_. st_tcb_at' runnable' t\" + apply (clarsimp simp add: finaliseCap_def Let_def) + apply (rule conjI | clarsimp | wp cancelAllIPC_tcb_at_runnable' getObject_ntfn_inv + cancelAllSignals_tcb_at_runnable' + | wpc)+ + done + +crunch isFinalCapability + for pred_tcb_at'[wp]: "pred_tcb_at' proj st t" + (simp: crunch_simps) + +lemma (in delete_one_conc_pre) cteDeleteOne_tcb_at_runnable': + "\st_tcb_at' runnable' t\ cteDeleteOne callerCap \\_. st_tcb_at' runnable' t\" + apply (simp add: cteDeleteOne_def unless_def) + apply (wp finaliseCap_tcb_at_runnable' | clarsimp | wp (once) hoare_drop_imps)+ + done + +crunch getThreadReplySlot, getEndpoint + for pred_tcb_at'[wp]: "pred_tcb_at' proj st t" + +lemma (in delete_one_conc_pre) cancelIPC_tcb_at_runnable': + "\st_tcb_at' runnable' t'\ cancelIPC t \\_. st_tcb_at' runnable' t'\" + (is "\?PRE\ _ \_\") + apply (clarsimp simp: cancelIPC_def Let_def) + apply (case_tac "t'=t") + apply (rule_tac Q'="\st. st_tcb_at' runnable' t and K (runnable' st)" + in bind_wp) + apply(case_tac rv; simp) + apply (wpsimp wp: sts_pred_tcb_neq')+ + apply (rule_tac Q'="\rv. ?PRE" in hoare_post_imp, fastforce) + apply (wp cteDeleteOne_tcb_at_runnable' + threadSet_pred_tcb_no_state + cancelSignal_tcb_at_runnable' + sts_pred_tcb_neq' hoare_drop_imps + | wpc | simp add: o_def if_fun_split)+ + done + +crunch cancelSignal + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" + (wp: crunch_wps) + +lemma (in delete_one_conc_pre) cancelIPC_ksCurDomain[wp]: + "\\s. P (ksCurDomain s)\ cancelIPC t \\_ s. P (ksCurDomain s)\" +apply (simp add: cancelIPC_def Let_def) +apply (wp hoare_vcg_conj_lift delete_one_ksCurDomain + | wpc + | rule hoare_drop_imps + | simp add: getThreadReplySlot_def o_def if_fun_split)+ +done + (* FIXME move *) lemma setBoundNotification_not_ntfn: "(\tcb ntfn. P (tcb\tcbBoundNotification := ntfn\) \ P tcb) @@ -2047,41 +1058,32 @@ lemma setBoundNotification_not_ntfn: | simp)+ done -lemma cancelSignal_tcb_obj_at': - "(\tcb st qd. P (tcb\tcbState := st, tcbQueued := qd\) \ P tcb) - \ cancelSignal t word \obj_at' P t'\" - apply (simp add: cancelSignal_def) - apply (wpsimp wp: setThreadState_not_st getNotification_wp) +lemma setBoundNotification_tcb_in_cur_domain'[wp]: + "\tcb_in_cur_domain' t'\ 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 -crunch replyRemoveTCB, cancelSignal, getBlockingObject, blockedCancelIPC - for obj_at'_only_st_qd_ft: "\s. P (obj_at' (Q :: tcb \ bool) t s)" - (simp: crunch_simps pred_tcb_at'_def wp: crunch_wps) -(* FIXME: Proved outside of `crunch` because without the `[where P=P]` constraint, the - postcondition unifies with the precondition in a wonderfully exponential way. VER-1337 *) -lemma cancelIPC_obj_at'_only_st_qd_ft: - "\\s. P (obj_at' Q t' s) \ - (\upd tcb. Q (tcbState_update upd tcb) = Q tcb) \ - (\upd tcb. Q (tcbQueued_update upd tcb) = Q tcb) \ - (\upd tcb. Q (tcbFault_update upd tcb) = Q tcb)\ - cancelIPC t - \\_ s. P (obj_at' Q t' s)\" - unfolding cancelIPC_def Let_def - apply (wpsimp wp: scheduleTCB_obj_at'_only_st_qd_ft[where P=P] - threadSet_obj_at'_only_st_qd_ft[where P=P] - setThreadState_obj_at'_only_st_qd_ft[where P=P] - replyUnlink_obj_at'_only_st_qd_ft[where P=P] - getBlockingObject_obj_at'_only_st_qd_ft[where P=P] - replyRemoveTCB_obj_at'_only_st_qd_ft[where P=P] - blockedCancelIPC_obj_at'_only_st_qd_ft[where P=P] - cancelSignal_obj_at'_only_st_qd_ft[where P=P] - hoare_drop_imp) - done - -lemma cancelIPC_tcbDomain_obj_at': +lemma setThreadState_tcbDomain_obj_at'[wp]: + "setThreadState ts t \obj_at' (\tcb. P (tcbDomain tcb)) t'\" + unfolding setThreadState_def + by wpsimp + +crunch cancelSignal + for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t'" + (wp: crunch_wps) + +lemma (in delete_one_conc_pre) cancelIPC_tcbDomain_obj_at': "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ cancelIPC t \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" - apply (wpsimp wp: cancelIPC_obj_at'_only_st_qd_ft) + apply (simp add: cancelIPC_def Let_def) + apply (wp hoare_vcg_conj_lift + delete_one_tcbDomain_obj_at' + | wpc + | rule hoare_drop_imps + | simp add: getThreadReplySlot_def o_def if_fun_split)+ done lemma (in delete_one_conc_pre) cancelIPC_tcb_in_cur_domain': @@ -2092,21 +1094,59 @@ lemma (in delete_one_conc_pre) cancelIPC_tcb_in_cur_domain': apply (wp cancelIPC_tcbDomain_obj_at' | simp)+ done +lemma (in delete_one_conc_pre) cancelIPC_sch_act_not: + "\sch_act_not t'\ cancelIPC t \\_. sch_act_not t'\" + apply (simp add: cancelIPC_def Let_def) + apply (wp hoare_vcg_conj_lift + delete_one_sch_act_not + | wpc + | simp add: getThreadReplySlot_def o_def if_apply_def2 + split del: if_split + | rule hoare_drop_imps)+ + done + +lemma (in delete_one_conc_pre) cancelIPC_weak_sch_act_wf: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ + cancelIPC t + \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (rule weak_sch_act_wf_lift_linear) + apply (wp cancelIPC_sch_act_not cancelIPC_tcb_in_cur_domain' cancelIPC_tcb_at_runnable')+ + done + 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)+ +lemma rescheduleRequired_weak_sch_act_wf: + "\\\ rescheduleRequired \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: rescheduleRequired_def setSchedulerAction_def) + apply (wp hoare_TrueI | simp add: weak_sch_act_wf_def)+ done +lemma sts_weak_sch_act_wf[wp]: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s + \ (ksSchedulerAction s = SwitchToThread t \ runnable' st)\ + setThreadState st t + \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" + including classic_wp_pre + apply (simp add: setThreadState_def) + apply (wp rescheduleRequired_weak_sch_act_wf) + apply (rule_tac Q'="\_ s. weak_sch_act_wf (ksSchedulerAction s) s" in hoare_post_imp, simp) + apply (simp add: weak_sch_act_wf_def) + apply (wp hoare_vcg_all_lift) + apply (wps threadSet_nosch) + apply (wp hoare_vcg_const_imp_lift threadSet_pred_tcb_at_state threadSet_tcbDomain_triv | simp)+ + done + +lemma sbn_nosch[wp]: + "\\s. P (ksSchedulerAction s)\ setBoundNotification ntfn t \\rv s. P (ksSchedulerAction s)\" + by (simp add: setBoundNotification_def, wp threadSet_nosch) + + 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) + by (wp weak_sch_act_wf_lift sbn_st_tcb') + lemma set_ep_weak_sch_act_wf[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ @@ -2123,14 +1163,25 @@ lemma setObject_ntfn_sa_unchanged[wp]: apply (wp | simp add: updateObject_default_def)+ done +lemma setObject_oa_unchanged[wp]: + "\\s. obj_at' (\tcb::tcb. P tcb) t s\ + setObject ptr (ntfn::Structures_H.notification) + \\rv s. obj_at' P t s\" + apply (rule obj_at_setObject2) + apply (clarsimp simp add: updateObject_type + updateObject_default_def + in_monad) + done + lemma setNotification_weak_sch_act_wf[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ setNotification ntfnptr ntfn \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" apply (wp hoare_vcg_all_lift hoare_convert_imp hoare_vcg_conj_lift - | simp add: weak_sch_act_wf_def st_tcb_at'_def tcb_in_cur_domain'_def)+ - apply (wps ) - apply (wp | simp add: o_def)+ + | simp add: setNotification_def weak_sch_act_wf_def st_tcb_at'_def tcb_in_cur_domain'_def)+ + apply (rule hoare_pre) + apply (wps setObject_ntfn_cur_domain) + apply (wp setObject_ntfn_obj_at'_tcb | simp add: o_def)+ done lemmas ipccancel_weak_sch_act_wfs @@ -2142,7 +1193,9 @@ lemma updateObject_ep_inv: lemma asUser_tcbQueued_inv[wp]: "\obj_at' (\tcb. P (tcbQueued tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbQueued tcb)) t'\" - by (wpsimp wp: getObject_tcb_wp simp: obj_at'_def asUser_def tcb_in_cur_domain'_def threadGet_getObject) + apply (simp add: asUser_def tcb_in_cur_domain'_def threadGet_def) + apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | wpc | simp | clarsimp simp: obj_at'_def)+ + done context begin interpretation Arch . @@ -2177,58 +1230,41 @@ lemma as_user_ready_qs_distinct[wp]: apply (wpsimp wp: set_object_wp) by (clarsimp simp: ready_qs_distinct_def) -crunch ThreadDecls_H.suspend - (* FIXME RT: VER-1016 *) - for tcb_at'_better[wp]: "\s. P (tcb_at' t s)" - (rule: sch_act_simple_lift - wp: crunch_wps - simp: crunch_simps if_fun_split st_tcb_at'_def) - lemma (in delete_one) 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_add_assertion) - prefer 2 - apply (clarsimp simp: sym_refs_asrt_def) + (IpcCancel_A.suspend t) (ThreadDecls_H.suspend t)" + apply (rule corres_cross_over_guard[where P'=P' and Q="tcb_at' t and P'" for P']) + apply (fastforce dest!: tcb_at_cross state_relation_pspace_relation) + apply (simp add: IpcCancel_A.suspend_def Thread_H.suspend_def) 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') - apply (simp only: when_def) - apply (rule corres_split[OF corres_if]) - apply (case_tac state; clarsimp?) - apply (clarsimp simp: update_restart_pc_def updateRestartPC_def) + apply (rule corres_split[OF getThreadState_corres]) + apply (rule corres_split_nor) + apply (rule corres_if) + apply (case_tac state; simp) + apply (simp add: update_restart_pc_def updateRestartPC_def) apply (rule asUser_corres') apply (simp add: ARM.nextInstructionRegister_def ARM.faultRegister_def - ARM_H.nextInstructionRegister_def ARM_H.faultRegister_def - ARM_H.Register_def) + ARM_H.nextInstructionRegister_def ARM_H.faultRegister_def) + apply (simp add: ARM_H.Register_def) + apply (subst unit_dc_is_eq) apply (rule corres_underlying_trivial) apply (wpsimp simp: ARM.setRegister_def ARM.getRegister_def) - 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']) - apply (rule corres_split[OF tcbReleaseRemove_corres], simp) - apply (rule schedContextCancelYieldTo_corres) - apply wpsimp+ - apply (wpsimp simp: update_restart_pc_def updateRestartPC_def) - apply (rule hoare_post_imp[where Q'="\rv s. invs s \ tcb_at t s"], fastforce) - apply wp - apply wpsimp - apply (rule hoare_post_imp[where Q'="\rv s. invs' s \ tcb_at' t s"]) - apply (fastforce simp: invs'_def dest!: valid_queues_inQ_queues) - apply wp - apply (clarsimp simp: updateRestartPC_def) - apply wpsimp - apply wpsimp - apply (wpsimp wp: gts_wp) - apply (wpsimp wp: gts_wp') - apply (rule hoare_post_imp[where Q'="\rv s. invs s \ tcb_at t s"], fastforce) - apply wpsimp - apply (rule hoare_post_imp[where Q'="\rv s. invs' s \ tcb_at' t s"], fastforce) - apply (wpsimp wp: hoare_drop_imps)+ + apply (rule corres_return_trivial) + apply (rule corres_split_nor[OF setThreadState_corres]) + apply wpsimp + apply (rule tcbSchedDequeue_corres, simp) + apply wp + apply (wpsimp wp: sts_valid_objs') + apply (wpsimp simp: update_restart_pc_def updateRestartPC_def valid_tcb_state'_def)+ + apply (rule hoare_post_imp[where Q'="\rv s. einvs s \ tcb_at t s"]) + apply (simp add: invs_implies invs_strgs valid_queues_in_correct_ready_q + valid_queues_ready_qs_distinct valid_sched_def) + apply wp + apply (rule hoare_post_imp[where Q'="\_ s. invs' s \ tcb_at' t s"]) + apply (fastforce simp: invs'_def valid_tcb_state'_def) + apply (wpsimp simp: update_restart_pc_def updateRestartPC_def)+ + apply fastforce+ done lemma (in delete_one) prepareThreadDelete_corres: @@ -2236,59 +1272,29 @@ lemma (in delete_one) prepareThreadDelete_corres: (prepare_thread_delete t) (ArchRetypeDecls_H.ARM_H.prepareThreadDelete t)" by (simp add: ArchVSpace_A.ARM_A.prepare_thread_delete_def ArchRetype_H.ARM_H.prepareThreadDelete_def) -lemma rescheduleRequired_oa_queued: - "\ (\s. P (obj_at' (\tcb. Q (tcbQueued tcb) (tcbDomain tcb) (tcbPriority tcb)) t' s)) and sch_act_simple\ - rescheduleRequired - \\_ s. P (obj_at' (\tcb. Q (tcbQueued tcb) (tcbDomain tcb) (tcbPriority tcb)) t' s)\" - (is "\?OAQ t' p and sch_act_simple\ _ \_\") - apply (simp add: rescheduleRequired_def sch_act_simple_def) - apply (rule_tac Q'="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ ?OAQ t' p s" in bind_wp) - including classic_wp_pre - apply (wp | clarsimp)+ - apply (case_tac x) - apply (wp | clarsimp)+ - done - - -(* FIXME: rename uses of setThreadState_oa_queued; the "_queued" suffix doesn't make sense - any more. VER-1332 *) -lemmas setThreadState_oa_queued = setThreadState_oa - -lemma setBoundNotification_oa_queued: - "\\s. P' (obj_at' (\tcb. P (tcbQueued tcb) (tcbDomain tcb) (tcbPriority tcb)) t' s) \ - setBoundNotification ntfn t - \\_ s. P' (obj_at' (\tcb. P (tcbQueued tcb) (tcbDomain tcb) (tcbPriority tcb)) t' s) \" - (is "\\s. P' (?Q P s)\ _ \\_ s. P' (?Q P s)\") - proof (rule P_bool_lift [where P=P']) - show pos: - "\R. \ ?Q R \ setBoundNotification ntfn t \\_. ?Q R \" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_obj_at'_strongish) - apply (clarsimp) - done - show "\\s. \ ?Q P s\ setBoundNotification ntfn t \\_ s. \ ?Q P s\" - by (simp add: not_obj_at' comp_def, wp hoare_convert_imp pos) - qed +lemma no_refs_simple_strg': + "st_tcb_at' simple' t s' \ P {} \ st_tcb_at' (\st. P (tcb_st_refs_of' st)) t s'" + by (fastforce elim!: pred_tcb'_weakenE)+ -lemma tcbSchedDequeue_t_notksQ: - "\\s. t \ set (ksReadyQueues s (d, p)) \ - obj_at' (\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t s\ - tcbSchedDequeue t - \\_ s. t \ set (ksReadyQueues s (d, p))\" - apply (rule_tac P'="(\s. t \ set (ksReadyQueues s (d, p))) - or obj_at'(\tcb. tcbQueued tcb \ tcbDomain tcb = d \ tcbPriority tcb = p) t" - in hoare_pre_imp, clarsimp) - apply (rule hoare_pre_disj) - apply (wp tcbSchedDequeue_notksQ)[1] - apply (simp add: tcbSchedDequeue_def removeFromBitmap_conceal_def[symmetric]) - apply wp - apply (rule hoare_pre_post, assumption) - apply (clarsimp simp: bitmap_fun_defs removeFromBitmap_conceal_def, wp, clarsimp) - apply (wp threadGet_wp)+ - apply (auto simp: obj_at'_real_def ko_wp_at'_def) +crunch cancelSignal + for it[wp]: "\s. P (ksIdleThread s)" + (wp: crunch_wps simp: crunch_simps) + +lemma (in delete_one_conc_pre) cancelIPC_it[wp]: + "\\s. P (ksIdleThread s)\ + cancelIPC t + \\_ s. P (ksIdleThread s)\" + apply (simp add: cancelIPC_def Let_def getThreadReplySlot_def) + apply (wp hoare_drop_imps delete_one_it | wpc | simp add:if_apply_def2 Fun.comp_def)+ done +crunch threadGet + for ksQ: "\s. P (ksReadyQueues s p)" + +crunch tcbSchedDequeue + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' + (wp: crunch_wps) + lemma asUser_sch_act_simple[wp]: "\sch_act_simple\ asUser s t \\_. sch_act_simple\" unfolding sch_act_simple_def @@ -2296,27 +1302,40 @@ lemma asUser_sch_act_simple[wp]: done lemma (in delete_one_conc) suspend_invs'[wp]: - "\invs' and tcb_at' t\ - ThreadDecls_H.suspend t - \\rv. invs'\" (is "valid ?pre _ _") - apply (simp add: suspend_def updateRestartPC_def getThreadState_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule_tac Q'="\_. ?pre and st_tcb_at' simple' t" - in bind_wp_fwd) - apply (wpsimp wp: cancelIPC_simple) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp_fwd_skip) - apply clarsimp - apply (wpsimp simp: updateRestartPC_def) - apply (rule_tac Q'="\_. ?pre and st_tcb_at' ((=) Inactive) t" - in bind_wp_fwd) - apply (wpsimp wp: sts_invs_minor' sts_st_tcb_at'_cases) - apply (fastforce elim: pred_tcb'_weakenE) - apply (wpsimp wp: tcbReleaseRemove_invs' schedContextCancelYieldTo_invs') + "\invs' and sch_act_simple and tcb_at' t and (\s. t \ ksIdleThread s)\ + ThreadDecls_H.suspend t \\rv. invs'\" + apply (simp add: suspend_def) + apply (wpsimp wp: sts_invs_minor' gts_wp' simp: updateRestartPC_def + | strengthen no_refs_simple_strg')+ + apply (rule_tac Q'="\_. invs' and sch_act_simple and st_tcb_at' simple' t + and (\s. t \ ksIdleThread s)" + in hoare_post_imp) + apply clarsimp + apply wpsimp + apply (fastforce elim: pred_tcb'_weakenE) + done + +lemma (in delete_one_conc_pre) suspend_tcb'[wp]: + "\tcb_at' t'\ ThreadDecls_H.suspend t \\rv. tcb_at' t'\" + apply (simp add: suspend_def unless_def) + apply wp + apply (wpsimp simp: updateRestartPC_def) + apply (wp hoare_drop_imps |clarsimp|rule conjI)+ + done + +lemma (in delete_one_conc_pre) suspend_sch_act_simple[wp]: + "\sch_act_simple\ + ThreadDecls_H.suspend t \\rv. sch_act_simple\" + apply (simp add: suspend_def when_def updateRestartPC_def) + apply (wp cancelIPC_sch_act_simple | simp add: unless_def + | rule sch_act_simple_lift)+ + apply (simp add: updateRestartPC_def) + apply (rule asUser_nosch) + apply wpsimp+ done lemma (in delete_one_conc) suspend_objs': - "\invs' and tcb_at' t\ + "\invs' and sch_act_simple and tcb_at' t and (\s. t \ ksIdleThread s)\ suspend t \\rv. valid_objs'\" apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post) apply (wp suspend_invs') @@ -2332,7 +1351,7 @@ lemma (in delete_one_conc_pre) suspend_st_tcb_at': apply (wp sts_st_tcb_at'_cases threadSet_pred_tcb_no_state cancelIPC_st_tcb_at hoare_drop_imps asUser_pred_tcb_at' x | simp)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply clarsimp done lemmas (in delete_one_conc_pre) suspend_makes_simple' = @@ -2345,6 +1364,9 @@ lemma suspend_makes_inactive: apply (wp threadSet_pred_tcb_no_state setThreadState_st_tcb | simp)+ done +declare threadSet_sch_act_sane [wp] +declare setThreadState_sch_act_sane [wp] + lemma tcbSchedEnqueue_sch_act_not_ct[wp]: "\\s. sch_act_not (ksCurThread s) s\ tcbSchedEnqueue t \\_ s. sch_act_not (ksCurThread s) s\" by (rule hoare_weaken_pre, wps, wp, simp) @@ -2356,521 +1378,154 @@ lemma sts_sch_act_not_ct[wp]: text \Cancelling all IPC in an endpoint or notification object\ -global_interpretation refillUnblockCheck: typ_at_all_props' "refillUnblockCheck scp" - by typ_at_props' +lemma ep_cancel_corres_helper: + "corres dc ((\s. \t \ set list. tcb_at t s) and valid_etcbs and valid_queues + and pspace_aligned and pspace_distinct) + (valid_objs' and sym_heap_sched_pointers and valid_sched_pointers) + (mapM_x (\t. do + y \ set_thread_state t Structures_A.Restart; + tcb_sched_action tcb_sched_enqueue t + od) list) + (mapM_x (\t. do + y \ setThreadState Structures_H.thread_state.Restart t; + tcbSchedEnqueue t + od) list)" + 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 S="{t. (fst t = snd t) \ fst t \ set list}" + in corres_mapM_x) + apply clarsimp + apply (rule corres_guard_imp) + apply (subst bind_return_unit, rule corres_split[OF _ tcbSchedEnqueue_corres]) + apply simp + apply (rule corres_guard_imp [OF setThreadState_corres]) + apply simp + apply (simp add: valid_tcb_state_def) + apply simp + apply simp + apply (wpsimp wp: sts_st_tcb_at') + apply (wpsimp wp: sts_valid_objs' | strengthen valid_objs'_valid_tcbs')+ + apply fastforce + apply (wpsimp wp: hoare_vcg_const_Ball_lift set_thread_state_runnable_valid_queues + sts_st_tcb_at' sts_valid_objs' + simp: valid_tcb_state'_def)+ + done -global_interpretation ifCondRefillUnblockCheck: typ_at_all_props' "ifCondRefillUnblockCheck scp act ast" - by typ_at_props' +crunch set_simple_ko + for ready_qs_distinct[wp]: ready_qs_distinct + and in_correct_ready_q[wp]: in_correct_ready_q + (rule: ready_qs_distinct_lift wp: crunch_wps) -lemma updateSchedContext_valid_tcbs'[wp]: - "updateSchedContext scp f \ valid_tcbs' \" - unfolding updateSchedContext_def setSchedContext_def getSchedContext_def - apply (wpsimp wp: setObject_valid_tcbs'[where P=\]) - apply (clarsimp simp: projectKOs updateObject_default_def in_monad) - apply (wpsimp wp: getObject_inv) - by simp - -lemma valid_refills'_tcbQueued_update[simp]: - "scp \ t \ - valid_refills' scp - (s\ksPSpace := (ksPSpace s)(t \ KOTCB (tcbQueued_update (\_. True) tcb))\) - = valid_refills' scp s" - by (clarsimp simp: valid_refills'_def opt_pred_def) - -lemma threadSet_valid_refills'[wp]: - "threadSet f tp \ valid_refills' scp \" - apply (wpsimp wp: threadSet_wp) - by (clarsimp simp: valid_refills'_def projectKOs obj_at'_def opt_pred_def - dest!: opt_predD split: kernel_object.splits option.splits - elim!: opt_mapE) - -crunch setThreadState - for valid_refills'[wp]: "valid_refills' scp" - -crunch ifCondRefillUnblockCheck - for valid_objs'[wp]: valid_objs' - and valid_tcbs'[wp]: valid_tcbs' - (wp: hoare_vcg_if_lift2 crunch_wps simp: crunch_simps) - -lemma restart_thread_if_no_fault_corres: - "corres dc (valid_sched_action and tcb_at t and pspace_aligned and pspace_distinct - and valid_tcbs and active_scs_valid and current_time_bounded) - (valid_queues and valid_queues' and valid_release_queue_iff and valid_objs') - (restart_thread_if_no_fault t) - (restartThreadIfNoFault t)" - (is "corres _ _ ?conc_guard _ _") - apply (rule corres_cross_over_guard[where Q="?conc_guard and tcb_at' t"]) - apply (fastforce intro: tcb_at_cross) - apply (clarsimp simp: restart_thread_if_no_fault_def restartThreadIfNoFault_def) - apply (rule corres_guard_imp) - apply (rule corres_split - [OF threadGet_corres[where r=fault_rel_optionation] _ thread_get_wp threadGet_wp]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_if) - apply (clarsimp simp: fault_rel_optionation_def) - apply (rule corres_split[OF setThreadState_corres]) - apply (clarsimp simp: fault_rel_optionation_def) - 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 (rule_tac Q'="\scopt s. case_option True (\p. sc_at p s) scopt \ - tcb_at t s \ valid_sched_action s \ - pspace_aligned s \ pspace_distinct s \ valid_tcbs s \ - active_scs_valid s \ current_time_bounded s" - in hoare_strengthen_post[rotated]) - 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. tcb_at t s \ valid_sched_action s \ - pspace_aligned s \ pspace_distinct s \ valid_tcbs s \ - active_scs_valid s \ current_time_bounded s" - in hoare_strengthen_post[rotated]) - apply (fastforce split: option.split simp: valid_tcbs_def valid_tcb_def valid_bound_obj_def) - apply (wpsimp wp: sts_typ_ats set_thread_state_valid_sched_action) - apply (rule hoare_strengthen_post[where Q'="\_ s. tcb_at' t s \ valid_objs' s - \ valid_release_queue_iff s - \ valid_queues s \ valid_queues' s", rotated]) - apply (clarsimp simp: obj_at_simps) - apply (wpsimp wp: sts_st_tcb_at'_cases hoare_drop_imp) - apply (rule setThreadState_corres) - apply clarsimp - apply (clarsimp simp: obj_at_def is_tcb_def invs_def valid_state_def) - apply (clarsimp split: Structures_A.kernel_object.splits) - apply (clarsimp simp: obj_at'_def projectKOs valid_tcb_state'_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" - and cur_tcb'[wp]: cur_tcb' - (simp: crunch_simps wp: whileLoop_wp) - -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)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma cancelAllIPC_loop_body_weak_sch_act_wf: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ tcb_at' t s \ st_tcb_at' (not runnable') t s\ - cancelAllIPC_loop_body t - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - 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: sts_st_tcb_at'_cases hoare_drop_imps) - apply (clarsimp simp: weak_sch_act_wf_def pred_neg_def st_tcb_at'_def obj_at'_def) - done - -crunch cancelAllIPC_loop_body - for valid_queues'[wp]: valid_queues' - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - and valid_objs'[wp]: valid_objs' - and tcb_at'[wp]: "\s. tcb_at' threadPtr 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)" - (simp: valid_tcb_state'_def crunch_simps wp: whileLoop_wp ignore: updateSchedContext) - -global_interpretation cancelAllIPC_loop_body: typ_at_all_props' "cancelAllIPC_loop_body t" - by typ_at_props' - -lemma cancelAllIPC_loop_body_valid_queues: - "\\s. valid_queues s \ valid_tcbs' s\ - cancelAllIPC_loop_body t - \\_. valid_queues\" - apply (clarsimp simp: cancelAllIPC_loop_body_def restartThreadIfNoFault_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (clarsimp simp: weak_sch_act_wf_def pred_neg_def st_tcb_at'_def obj_at'_def) - apply (wpsimp wp: sts_valid_queues sts_st_tcb_at'_cases hoare_drop_imps) - done - -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_tcbs 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_queues and valid_queues' and valid_objs' and valid_release_queue_iff)) - (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_tcbs s - \ pspace_aligned s \ pspace_distinct s - \ st_tcb_at ((=) st) t s \ current_time_bounded s" - and P'="\s. valid_queues s \ valid_queues' s \ valid_objs' s - \ valid_release_queue_iff 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 (clarsimp 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 (fastforce simp: vs_all_heap_simps pred_tcb_at_def obj_at_def - reply_unlink_ts_pred_def) - apply clarsimp - 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 - , fastforce simp: obj_at_def)) - 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 wp: cancelAllIPC_loop_body_weak_sch_act_wf cancelAllIPC_loop_body_valid_queues) - apply fastforce+ - done - -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) - 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)" +lemma ep_cancel_corres: + "corres dc (invs and valid_sched and ep_at ep) (invs' and ep_at' ep) + (cancel_all_ipc ep) (cancelAllIPC ep)" 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_tcbs 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_queues and valid_queues' and valid_objs' and valid_release_queue_iff - and ep_at' ep_ptr)) - (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) - 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 simp - apply fastforce - 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_weak_sch_act_wf - cancelAllIPC_loop_body_valid_queues - 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' - simp: reply_unlink_ts_pred_def)+ - apply (clarsimp simp: valid_ep'_def) + "\list. + corres dc (\s. (\t \ set list. tcb_at t s) \ valid_pspace s \ ep_at ep s + \ valid_etcbs s \ weak_valid_sched_action s \ valid_queues s) + (\s. (\t \ set list. tcb_at' t s) \ valid_pspace' s + \ ep_at' ep s \ weak_sch_act_wf (ksSchedulerAction s) s + \ valid_objs' s \ sym_heap_sched_pointers s \ valid_sched_pointers s) + (do x \ set_endpoint ep Structures_A.IdleEP; + x \ mapM_x (\t. do + y \ set_thread_state t Structures_A.Restart; + tcb_sched_action tcb_sched_enqueue t + od) list; + reschedule_required + od) + (do x \ setEndpoint ep IdleEP; + x \ mapM_x (\t. do + y \ setThreadState Structures_H.thread_state.Restart t; + tcbSchedEnqueue t + od) list; + rescheduleRequired + od)" + apply (rule corres_underlying_split) + apply (rule corres_guard_imp [OF setEndpoint_corres]) + apply (simp add: ep_relation_def)+ + apply (rule corres_split[OF _ rescheduleRequired_corres]) + apply (rule ep_cancel_corres_helper) + apply (rule mapM_x_wp') + apply (wp weak_sch_act_wf_lift_linear set_thread_state_runnable_weak_valid_sched_action | simp)+ + apply (rule_tac Q'="\_ s. \x\set list. tcb_at' x s \ valid_objs' s \ pspace_aligned' s \ pspace_distinct' s" + in hoare_post_add) + apply (rule mapM_x_wp') + apply ((wpsimp wp: hoare_vcg_const_Ball_lift mapM_x_wp' sts_st_tcb' sts_valid_objs' + simp: valid_tcb_state'_def + | strengthen valid_objs'_valid_tcbs')+)[3] + apply fastforce + apply (wp hoare_vcg_const_Ball_lift set_ep_valid_objs' + | (clarsimp simp: valid_ep'_def) + | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def valid_ep'_def + | strengthen valid_objs'_valid_tcbs'))+ 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_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) + apply (simp add: cancel_all_ipc_def cancelAllIPC_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+) + apply (case_tac epa, simp_all add: ep_relation_def + get_ep_queue_def) + apply (rule corres_guard_imp [OF P] + | clarsimp simp: valid_obj_def valid_ep_def + valid_obj'_def valid_ep'_def + invs_valid_pspace projectKOs + valid_sched_def valid_sched_action_def + | erule obj_at_valid_objsE + | drule ko_at_valid_objs' + | rule conjI | clarsimp simp: invs'_def valid_state'_def)+ done qed -lemma ntfn_cancel_corres_helper: - "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 (\s. weak_sch_act_wf (ksSchedulerAction s) s) - and Invariants_H.valid_queues - and valid_queues' - and valid_objs' - and valid_release_queue_iff) - (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_tcbs - and valid_sched_action and tcb_at tp" - in hoare_strengthen_post[rotated]) - apply (fastforce simp: pred_tcb_at_def is_tcb is_sc_obj obj_at_def opt_map_red - valid_tcbs_def valid_tcb_def valid_bound_obj_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_queues and valid_queues' and valid_release_queue_iff - and valid_objs' and tcb_at' tp" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_objs'_valid_tcbs' obj_at'_def) - apply (wp setThreadState_st_tcb) - apply force - apply (clarsimp simp: valid_tcb_state'_def) - apply (wpsimp wp: set_thread_state_pred_map_tcb_sts_of) - apply (wpsimp wp: typ_at_lifts) - 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 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 typ_at_lifts sts_st_tcb') - apply (auto simp: valid_tcb_state'_def) - done - -lemma refill_unblock_check_weak_valid_sched_action[wp]: - "\weak_valid_sched_action and active_scs_valid\ - refill_unblock_check sc_ptr - \\rv. weak_valid_sched_action\" - apply (clarsimp simp: weak_valid_sched_action_def) - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift'') +(* FIXME move *) +lemma set_ntfn_tcb_obj_at' [wp]: + "\obj_at' (P::tcb \ bool) t\ + setNotification ntfn v + \\_. obj_at' P t\" + apply (clarsimp simp: setNotification_def, wp) done -crunch if_cond_refill_unblock_check - for weak_valid_sched_action[wp]: weak_valid_sched_action - (simp: crunch_simps) - lemma cancelAllSignals_corres: - "corres dc (invs and valid_sched and ntfn_at ntfn and current_time_bounded) - (invs' and ntfn_at' ntfn) + "corres dc (invs and valid_sched and ntfn_at ntfn) (invs' and ntfn_at' ntfn) (cancel_all_signals ntfn) (cancelAllSignals ntfn)" - 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_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. weak_sch_act_wf (ksSchedulerAction s) 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' setThreadState_not_st - simp: valid_tcb_state'_def) - apply (wpsimp wp: hoare_vcg_const_Ball_lift)+ - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - 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 projectKOs sym_refs_asrt_def sch_act_wf_asrt_def - | drule ko_at_valid_objs')+ + 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 (rule corres_guard_imp [OF getNotification_corres]) + apply simp+ + apply (case_tac "ntfn_obj ntfna", simp_all add: ntfn_relation_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF setNotification_corres]) + apply (simp add: ntfn_relation_def) + apply (rule corres_split[OF _ rescheduleRequired_corres]) + apply (rule ep_cancel_corres_helper) + apply (wp mapM_x_wp'[where 'b="det_ext state"] + weak_sch_act_wf_lift_linear + set_thread_state_runnable_weak_valid_sched_action + | simp)+ + apply (rename_tac list) + apply (rule_tac Q'="\_ s. (\x\set list. tcb_at' x s) \ valid_objs' s + \ sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_objs' s + \ pspace_aligned' s \ pspace_distinct' 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' sts_valid_objs' + simp: valid_tcb_state'_def + | strengthen valid_objs'_valid_tcbs')+ + apply (wp hoare_vcg_const_Ball_lift set_ntfn_aligned' set_ntfn_valid_objs' + weak_sch_act_wf_lift_linear + | simp)+ + apply (clarsimp simp: invs'_def valid_state'_def invs_valid_pspace valid_obj_def valid_ntfn_def + invs_weak_sch_act_wf valid_ntfn'_def valid_pspace'_def + valid_sched_def valid_sched_action_def valid_obj'_def projectKOs + | erule obj_at_valid_objsE | drule ko_at_valid_objs' | fastforce)+ done lemma ep'_Idle_case_helper: @@ -2900,149 +1555,83 @@ proof - \\_ s. ksSchedulerAction s \ ResumeCurrentThread\" by (rule hoare_strengthen_post [OF rescheduleRequired_notresume], simp) show ?thesis - apply (simp add: setThreadState_def scheduleTCB_def) - apply (wpsimp wp: hoare_vcg_imp_lift [OF nrct] isSchedulable_wp hoare_vcg_if_lift2) + apply (simp add: setThreadState_def) + apply (wpsimp wp: hoare_vcg_imp_lift [OF nrct]) apply (rule_tac Q'="\_. ?PRE" in hoare_post_imp) - apply clarsimp - apply (rule hoare_convert_imp [OF threadSet.ksSchedulerAction threadSet.ct]) + apply (clarsimp) + apply (rule hoare_convert_imp [OF threadSet_nosch threadSet_ct]) apply assumption done qed -lemma replyUnlink_valid_irq_node'[wp]: - "replyUnlink r t \\ s. valid_irq_node' (irq_node' s) s\" - unfolding replyUnlink_def - by (wpsimp wp: valid_irq_node_lift gts_wp') - -lemma replyUnlink_ksQ[wp]: - "\\s. P (ksReadyQueues s p) t\ - replyUnlink r t - \\_ s. P (ksReadyQueues s p) t\" - unfolding replyUnlink_def - by (wpsimp wp: gts_wp' sts_ksQ) - -lemma weak_sch_act_wf_D1: - "weak_sch_act_wf sa s \ (\t. sa = SwitchToThread t \ st_tcb_at' runnable' t s)" - by (simp add: weak_sch_act_wf_def) - -lemma updateSchedContext_valid_pspace'[wp]: - "\valid_pspace' and - (\s. \sc. (valid_sched_context' sc s \ valid_sched_context' (f sc) s) - \ (valid_sched_context_size' sc \ valid_sched_context_size' (f sc)))\ - updateSchedContext scp f - \\_. valid_pspace'\" - unfolding updateSchedContext_def - apply wpsimp - by (fastforce simp: obj_at'_def projectKOs valid_obj'_def) - -lemma refillPopHead_valid_pspace'[wp]: - "\valid_pspace' and (\s. ((\n. 1 < n) |< (scs_of' s ||> scRefillCount)) scp)\ - refillPopHead scp - \\_. valid_pspace'\" - unfolding refillPopHead_def updateSchedContext_def - apply (wpsimp wp: whileLoop_valid_inv) - by (fastforce simp: obj_at'_def projectKOs valid_obj'_def refillNextIndex_def MIN_REFILLS_def - valid_sched_context'_def valid_sched_context_size'_def scBits_simps objBits_simps - dest!: opt_predD - elim!: opt_mapE) - -lemma refillUnblockCheck_ko_wp_at_not_live[wp]: - "refillUnblockCheck scp \\s. P (ko_wp_at' (Not \ live') p' s)\" - unfolding refillUnblockCheck_def refillHeadOverlappingLoop_def mergeRefills_def - apply (wpsimp wp: whileLoop_valid_inv updateSchedContext_wp hoare_drop_imps - simp: updateRefillHd_def refillPopHead_def) - apply (clarsimp simp: ko_wp_at'_def obj_at'_def projectKOs runReaderT_def - opt_map_red refillNextIndex_def - split del: if_split - elim!: rsubst[where P=P]) - apply (frule refillHeadOverlapping_implies_count_greater_than_one) - apply (fastforce simp: obj_at'_def projectKOs) - apply (rule iffI; clarsimp simp: opt_map_red split: if_splits) - apply (fastforce simp: objBits_simps' live_sc'_def)+ - apply (clarsimp simp: ps_clear_upd)+ - apply (wpsimp wp: updateSchedContext_wp simp: updateRefillHd_def) - apply (wpsimp wp: hoare_drop_imps refillReady_wp isRoundRobin_wp simp: setReprogramTimer_def)+ - apply (clarsimp simp: ko_wp_at'_def obj_at'_def projectKOs opt_map_red - split del: if_split - elim!: rsubst[where P=P]) - apply (intro iffI; clarsimp simp: opt_map_red) - apply (fold fun_upd_def) - apply (fastforce simp: objBits_simps') - apply (clarsimp simp: opt_map_red ps_clear_upd split: if_splits) - done - -lemma refillUnblockCheck_refs_of'[wp]: - "refillUnblockCheck sc_ptr \\s. P (state_refs_of' s)\" - unfolding refillUnblockCheck_def refillHeadOverlappingLoop_def mergeRefills_def - apply (wpsimp simp: updateRefillHd_def refillPopHead_def - wp: hoare_drop_imp whileLoop_valid_inv isRoundRobin_wp updateSchedContext_wp) - apply (clarsimp simp: runReaderT_def elim!: rsubst[where P=P]) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red refillNextIndex_def) - apply (fastforce simp: state_refs_of'_def get_refs_def2 ps_clear_upd objBits_simps option.case_eq_if - split: if_splits) - apply (wpsimp wp: updateSchedContext_wp refillReady_wp isRoundRobin_wp - simp: updateRefillHd_def setReprogramTimer_def)+ - apply (fold fun_upd_def) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red - intro!: ext elim!: rsubst[where P=P]) - apply (fastforce simp: state_refs_of'_def get_refs_def2 ps_clear_upd objBits_simps option.case_eq_if - split: if_splits) - done - -crunch ifCondRefillUnblockCheck - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' t" - and 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)" - (wp: crunch_wps simp: crunch_simps valid_pspace'_def ignore: threadSet) +lemma tcbSchedEnqueue_valid_pspace'[wp]: + "tcbSchedEnqueue tcbPtr \valid_pspace'\" + unfolding valid_pspace'_def + by wpsimp lemma cancel_all_invs'_helper: - "\invs' and (\s. sch_act_wf (ksSchedulerAction s) s) - and (\s. (\x \ set q. - tcb_at' x s \ ex_nonz_cap_to' x s \ sch_act_not 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 + "\all_invs_but_sym_refs_ct_not_inQ' and (\s. \x \ set q. tcb_at' x s) + and (\s. sym_refs (\x. if x \ set q then {r \ state_refs_of' s x. snd r = TCBBound} + else state_refs_of' s x) + \ (\x \ set q. ex_nonz_cap_to' x s))\ + mapM_x (\t. do + y \ setThreadState Structures_H.thread_state.Restart t; + tcbSchedEnqueue t + od) q + \\rv. all_invs_but_ct_not_inQ'\" apply (rule mapM_x_inv_wp2) apply clarsimp - apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift - hoare_vcg_const_Ball_lift sts_st_tcb' setThreadState_not_st - possibleSwitchTo_sch_act_not_other) - apply (strengthen weak_sch_act_wf_D1) - apply (wpsimp wp: valid_irq_node_lift hoare_vcg_const_Ball_lift - sts_valid_queues sts_st_tcb' setThreadState_not_st 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 (rule conjI) - apply (fastforce simp: global'_no_ex_cap pred_tcb_at'_def obj_at'_def) + apply (rule hoare_pre) + apply (wp valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift + hoare_vcg_const_Ball_lift untyped_ranges_zero_lift sts_st_tcb' sts_valid_objs' + | simp add: cteCaps_of_def o_def)+ + apply (unfold fun_upd_apply Invariants_H.tcb_st_refs_of'_simps) apply clarsimp - apply (apply_conjunct \intro impI\, - (frule (1) valid_replies'_other_state; clarsimp))+ - apply (fastforce simp: global'_no_ex_cap) + apply (intro conjI) + apply (clarsimp simp: valid_tcb_state'_def global'_no_ex_cap + elim!: rsubst[where P=sym_refs] + dest!: set_mono_suffix + intro!: ext + | (drule (1) bspec, clarsimp simp: valid_pspace'_def valid_tcb'_def))+ + done + +lemma ep_q_refs_max: + "\ ko_at' r p s; sym_refs (state_refs_of' s); r \ IdleEP \ + \ (state_refs_of' s p \ (set (epQueue r) \ {EPSend, EPRecv})) + \ (\x\set (epQueue r). \ntfnptr. state_refs_of' s x \ + {(p, TCBBlockedSend), (p, TCBBlockedRecv), (ntfnptr, TCBBound)})" + 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' tcb_bound_refs'_def + | rule conjI | drule(1) bspec | drule st_tcb_at_state_refs_ofD' + | case_tac ntfnptr)+ + done + +crunch setEndpoint + for ct'[wp]: "\s. P (ksCurThread s)" + (wp: setObject_ep_ct) + +crunch setNotification + for ct'[wp]: "\s. P (ksCurThread s)" + (wp: setObject_ntfn_ct) + +lemma tcbSchedEnqueue_cur_tcb'[wp]: + "\cur_tcb'\ tcbSchedEnqueue t \\_. cur_tcb'\" + by (simp add: tcbSchedEnqueue_def unless_def) + (wp threadSet_cur setQueue_cur | simp)+ + +lemma rescheduleRequired_invs'[wp]: + "\invs'\ rescheduleRequired \\rv. invs'\" + apply (simp add: rescheduleRequired_def) + apply (wp ssa_invs' | simp | wpc)+ done +lemma invs_rct_ct_activatable': + "\ invs' s; ksSchedulerAction s = ResumeCurrentThread \ + \ st_tcb_at' activatable' (ksCurThread s) s" + by (simp add: invs'_def valid_state'_def ct_in_state'_def) + lemma not_in_epQueue: assumes ko_at: "ko_at' r ep_ptr s" and srefs: "sym_refs (state_refs_of' s)" and @@ -3074,11 +1663,11 @@ lemma not_in_epQueue: 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 (clarsimp) 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 (clarsimp) done with st_act show False @@ -3113,11 +1702,9 @@ lemma not_in_ntfnQueue: 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') - apply (metis (full_types, opaque_lifting) sym_refs_simp symreftype.simps(3)) + | 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' dest!: st_tcb_at_state_refs_ofD') done with ko_at have "st_tcb_at' (Not \ simple') t s" @@ -3125,7 +1712,7 @@ lemma not_in_ntfnQueue: 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 (clarsimp) done with st_act show False @@ -3141,414 +1728,341 @@ lemma ct_not_in_ntfnQueue: using assms unfolding ct_in_state'_def by (rule not_in_ntfnQueue) +crunch rescheduleRequired + for valid_pspace'[wp]: "valid_pspace'" +crunch rescheduleRequired + for valid_global_refs'[wp]: "valid_global_refs'" +crunch rescheduleRequired + for valid_machine_state'[wp]: "valid_machine_state'" + lemma sch_act_wf_weak[elim!]: "sch_act_wf sa s \ weak_sch_act_wf sa s" by (case_tac sa, (simp add: weak_sch_act_wf_def)+) +lemma rescheduleRequired_all_invs_but_ct_not_inQ: + "\all_invs_but_ct_not_inQ'\ rescheduleRequired \\_. invs'\" + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp rescheduleRequired_ct_not_inQ + valid_irq_node_lift valid_irq_handlers_lift'' + irqs_masked_lift cur_tcb_lift + untyped_ranges_zero_lift + | simp add: cteCaps_of_def o_def)+ + apply (auto simp: sch_act_wf_weak) + 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_arch_state_lift' - valid_irq_node_lift ssa_invs' sts_sch_act' getEndpoint_wp - irqs_masked_lift) - apply (clarsimp simp: invs'_def valid_ep'_def) - apply (wpsimp wp: hoare_vcg_const_Ball_lift) - apply (wpsimp wp: getEndpoint_wp) - apply (clarsimp simp: invs'_def valid_ep'_def) + "\invs'\ cancelAllIPC ep_ptr \\rv. invs'\" + apply (simp add: cancelAllIPC_def ep'_Idle_case_helper cong del: if_cong) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (wp rescheduleRequired_all_invs_but_ct_not_inQ + cancel_all_invs'_helper hoare_vcg_const_Ball_lift + valid_global_refs_lift' valid_arch_state_lift' + valid_irq_node_lift ssa_invs' sts_sch_act' + irqs_masked_lift + | simp only: sch_act_wf.simps forM_x_def | simp)+ + prefer 2 + apply assumption + apply (rule hoare_strengthen_post [OF get_ep_sp']) + apply (rename_tac rv s) + apply (clarsimp simp: invs'_def valid_state'_def valid_ep'_def) apply (frule obj_at_valid_objs', fastforce) apply (clarsimp simp: projectKOs valid_obj'_def) apply (rule conjI) - apply (metis fold_list_refs_of_replies') - apply (clarsimp simp: sym_refs_asrt_def sch_act_wf_asrt_def) - apply (rule conjI) + apply (case_tac rv, simp_all add: valid_ep'_def)[1] + apply (rule conjI[rotated]) apply (drule(1) sym_refs_ko_atD') - apply (clarsimp simp: valid_ep'_def st_tcb_at_refs_of_rev' split: endpoint.splits) - apply (intro conjI) - apply ((drule(1) bspec | drule st_tcb_at_state_refs_ofD' - | clarsimp elim!: if_live_state_refsE split: if_splits)+)[1] - apply (fastforce simp: runnable'_def st_tcb_at'_def obj_at'_def) - apply (fastforce elim!: pred_tcb'_weakenE) - apply (intro conjI) - apply ((drule(1) bspec | drule st_tcb_at_state_refs_ofD' - | clarsimp elim!: if_live_state_refsE split: if_splits)+)[1] - apply (fastforce simp: runnable'_def st_tcb_at'_def obj_at'_def) - apply (fastforce elim!: pred_tcb'_weakenE) - apply (clarsimp simp: valid_ep'_def split: endpoint.splits) - 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 projectKOs) - apply (fastforce intro: if_live_state_refsE) - done - -lemma cancelAllSignals_invs'_helper: - "\invs' and (\s. sch_act_wf (ksSchedulerAction s) s) - 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 - \\rv. 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 projectKOs)+ + apply (case_tac rv, simp_all add: st_tcb_at_refs_of_rev')[1] + apply (clarsimp elim!: if_live_state_refsE + | drule(1) bspec | drule st_tcb_at_state_refs_ofD')+ + apply (drule(2) ep_q_refs_max) + apply (erule delta_sym_refs) + apply (clarsimp dest!: symreftype_inverse' split: if_split_asm | drule(1) bspec subsetD)+ done lemma cancelAllSignals_invs'[wp]: - "cancelAllSignals ntfnPtr \invs'\" + "\invs'\ cancelAllSignals ntfn \\rv. 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 live'_def obj_at'_def projectKOs 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)+ - done - -lemma setQueue_valid_ep'[wp]: - "setQueue domain prio q \valid_ep' ep\" - apply (clarsimp simp: setQueue_def) - apply wpsimp - apply (clarsimp simp: valid_ep'_def split: endpoint.splits) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (rule bind_wp [OF _ get_ntfn_sp']) + apply (case_tac "ntfnObj ntfna", simp_all) + apply (wp, simp) + apply (wp, simp) + apply (rule hoare_pre) + apply (wp rescheduleRequired_all_invs_but_ct_not_inQ + cancel_all_invs'_helper hoare_vcg_const_Ball_lift + valid_irq_node_lift ssa_invs' irqs_masked_lift + | simp only: sch_act_wf.simps)+ + apply (clarsimp simp: invs'_def valid_state'_def valid_ntfn'_def) + apply (frule obj_at_valid_objs', clarsimp) + apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def) + apply (drule(1) sym_refs_ko_atD') + apply (rule conjI, clarsimp elim!: if_live_state_refsE) + apply (rule conjI[rotated]) + apply (clarsimp elim!: if_live_state_refsE) + apply (drule_tac x="(x, NTFNSignal)" in bspec) + apply (clarsimp simp: st_tcb_at_refs_of_rev')+ + apply (drule st_tcb_at_state_refs_ofD') + apply clarsimp + apply (erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (clarsimp split: if_split_asm) + apply (fastforce simp: symreftype_inverse' ntfn_bound_refs'_def) + apply (drule_tac x="(x, NTFNSignal)" in bspec) + apply (clarsimp simp: st_tcb_at_refs_of_rev')+ + apply (drule st_tcb_at_state_refs_ofD') + apply (fastforce simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def) done -lemma tcbSchedEnqueue_valid_ep'[wp]: - "tcbSchedEnqueue thread \valid_ep' ep\" - apply (clarsimp simp: tcbSchedEnqueue_def unless_def when_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply clarsimp - apply (rule bind_wp_fwd_skip, wpsimp wp: hoare_if)+ - apply (wpsimp wp: threadSet_wp) - apply (fastforce simp: valid_ep'_def obj_at'_def projectKOs objBitsKO_def split: endpoint.splits) - done +crunch tcbSchedEnqueue + for valid_objs'[wp]: valid_objs' + (simp: unless_def valid_tcb'_def tcb_cte_cases_def) lemma cancelAllIPC_valid_objs'[wp]: - "\valid_objs'\ cancelAllIPC ep \\rv. valid_objs'\" - apply (simp add: cancelAllIPC_def ep'_Idle_case_helper cong del: if_cong) - apply (repeat_unless \rule bind_wp[OF _ get_ep_sp']\ - \rule bind_wp_fwd_skip, wpsimp\) - apply (rule hoare_if; (solves \wpsimp\)?) - apply (rule_tac Q'="\_ s. valid_objs' s \ valid_ep' epa s" in bind_wp_fwd) - apply (wpsimp wp: set_ep_valid_objs') - apply (frule (1) ep_ko_at_valid_objs_valid_ep') - apply (fastforce simp: valid_ep'_def obj_at'_def projectKOs objBitsKO_def split: endpoint.splits) - apply (rule bind_wp) - apply wpsimp - apply (rule_tac Q'="\_ s. valid_objs' s \ valid_ep' ep s" in hoare_strengthen_post; clarsimp) - apply (rule mapM_x_wp') - by wpsimp + "\valid_objs' and pspace_aligned' and pspace_distinct'\ cancelAllIPC ep \\rv. valid_objs'\" + apply (simp add: cancelAllIPC_def ep'_Idle_case_helper cong del: if_cong) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (rule bind_wp [OF _ get_ep_sp']) + apply (rule hoare_pre) + apply (wp set_ep_valid_objs' setSchedulerAction_valid_objs') + apply (rule_tac Q'="\_ s. valid_objs' s \ pspace_aligned' s \ pspace_distinct' s + \ (\x\set (epQueue ep). tcb_at' x s)" + in hoare_post_imp) + apply simp + apply (simp add: Ball_def) + apply (wp mapM_x_wp' sts_valid_objs' + hoare_vcg_all_lift hoare_vcg_const_imp_lift)+ + apply simp + apply (simp add: valid_tcb_state'_def) + apply (wp set_ep_valid_objs' hoare_vcg_all_lift hoare_vcg_const_imp_lift) + apply (clarsimp) + apply (frule(1) ko_at_valid_objs') + apply (simp add: projectKOs) + apply (clarsimp simp: valid_obj'_def valid_ep'_def) + apply (case_tac epa, simp_all) + done lemma cancelAllSignals_valid_objs'[wp]: "\valid_objs' and pspace_aligned' and pspace_distinct'\ cancelAllSignals ntfn \\rv. valid_objs'\" apply (simp add: cancelAllSignals_def) - apply (repeat_unless \rule bind_wp[OF _ get_ntfn_sp']\ - \rule bind_wp_fwd_skip, wpsimp\) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (rule bind_wp [OF _ get_ntfn_sp']) apply (case_tac "ntfnObj ntfna", simp_all) apply (wp, simp) apply (wp, simp) apply (rename_tac list) apply (rule_tac Q'="\rv s. valid_objs' s \ (\x\set list. tcb_at' x s)" in hoare_post_imp) - apply simp - apply (wpsimp wp: setSchedulerAction_valid_objs' mapM_x_wp' sts_valid_objs' - hoare_vcg_ball_lift typ_at_lifts) - apply (auto simp: projectKOs valid_obj'_def valid_ntfn'_def - dest: ko_at_valid_objs') + apply (simp add: valid_ntfn'_def) + apply (simp add: Ball_def) + apply (wp setSchedulerAction_valid_objs' mapM_x_wp' + sts_valid_objs' hoare_vcg_all_lift hoare_vcg_const_imp_lift + | simp)+ + apply (simp add: valid_tcb_state'_def) + apply (wp set_ntfn_valid_objs' hoare_vcg_all_lift hoare_vcg_const_imp_lift) + apply clarsimp + apply (frule(1) ko_at_valid_objs') + apply (simp add: projectKOs) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) done lemma cancelAllIPC_st_tcb_at: - "\st_tcb_at' P t and K (P Inactive \ P Restart)\ - cancelAllIPC 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 projectKOs) - apply (wpsimp wp: gts_wp') - apply (fastforce simp: obj_at_ko_at'_eq[where P=\, simplified]) - apply wpsimp - by clarsimp + assumes x[simp]: "P Restart" shows + "\st_tcb_at' P t\ cancelAllIPC epptr \\rv. st_tcb_at' P t\" + unfolding cancelAllIPC_def + by (wp ep'_cases_weak_wp mapM_x_wp' sts_st_tcb_at'_cases | clarsimp)+ lemmas cancelAllIPC_makes_simple[wp] = cancelAllIPC_st_tcb_at [where P=simple', simplified] lemma cancelAllSignals_st_tcb_at: - "\st_tcb_at' P t and K (P Restart)\ - cancelAllSignals epptr - \\_. st_tcb_at' P t\" + assumes x[simp]: "P Restart" shows + "\st_tcb_at' P t\ cancelAllSignals epptr \\rv. 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) - done + by (wp ntfn'_cases_weak_wp mapM_x_wp' sts_st_tcb_at'_cases | clarsimp)+ lemmas cancelAllSignals_makes_simple[wp] = cancelAllSignals_st_tcb_at [where P=simple', simplified] +lemma threadSet_not_tcb[wp]: + "\ko_wp_at' (\x. P x \ (projectKO_opt x = (None :: tcb option))) p\ + threadSet f t + \\rv. ko_wp_at' (\x. P x \ (projectKO_opt x = (None :: tcb option))) p\" + by (clarsimp simp: threadSet_def valid_def getObject_def + setObject_def in_monad loadObject_default_def + ko_wp_at'_def projectKOs split_def in_magnitude_check + objBits_simps' updateObject_default_def + ps_clear_upd projectKO_opt_tcb) + +lemma setThreadState_not_tcb[wp]: + "\ko_wp_at' (\x. P x \ (projectKO_opt x = (None :: tcb option))) p\ + setThreadState st t + \\rv. ko_wp_at' (\x. P x \ (projectKO_opt x = (None :: tcb option))) p\" + by (wpsimp wp: isRunnable_inv threadGet_wp hoare_drop_imps + simp: setThreadState_def setQueue_def + rescheduleRequired_def tcbSchedEnqueue_def tcbQueuePrepend_def + unless_def bitmap_fun_defs)+ + +lemma tcbSchedEnqueue_unlive: + "\ko_wp_at' (\x. \ live' x \ (projectKO_opt x = (None :: tcb option))) p + and tcb_at' t\ + tcbSchedEnqueue t + \\_. ko_wp_at' (\x. \ live' x \ (projectKO_opt x = (None :: tcb option))) p\" + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def) + apply (wp | simp add: setQueue_def bitmap_fun_defs)+ + done + +lemma cancelAll_unlive_helper: + "\\s. (\x\set xs. tcb_at' x s) \ + ko_wp_at' (\x. \ live' x \ (projectKO_opt x = (None :: tcb option))) p s\ + mapM_x (\t. do + y \ setThreadState Structures_H.thread_state.Restart t; + tcbSchedEnqueue t + od) xs + \\rv. ko_wp_at' (Not \ live') p\" + apply (rule hoare_strengthen_post) + apply (rule mapM_x_wp') + apply (rule hoare_pre) + apply (wp tcbSchedEnqueue_unlive hoare_vcg_const_Ball_lift) + apply clarsimp + apply (clarsimp elim!: ko_wp_at'_weakenE) + done + +context begin interpretation Arch . (*FIXME: arch-split*) +lemma setObject_ko_wp_at': + fixes v :: "'a :: pspace_storable" + assumes x: "\v :: 'a. updateObject v = updateObject_default v" + assumes n: "\v :: 'a. objBits v = n" + assumes v: "(1 :: word32) < 2 ^ n" + shows + "\\s. P (injectKO v)\ setObject p v \\rv. ko_wp_at' P p\" + by (clarsimp simp: setObject_def valid_def in_monad + ko_wp_at'_def x split_def n + updateObject_default_def + objBits_def[symmetric] ps_clear_upd + in_magnitude_check v projectKOs) + lemma threadSet_unlive_other: "\ko_wp_at' (Not \ live') p and K (p \ t)\ threadSet f t \\rv. ko_wp_at' (Not \ live') p\" by (clarsimp simp: threadSet_def valid_def getObject_def setObject_def in_monad loadObject_default_def - ko_wp_at'_def projectKOs split_def in_magnitude_check - objBits_simps' updateObject_default_def + ko_wp_at'_def split_def in_magnitude_check + objBits_simps' updateObject_default_def projectKOs ps_clear_upd ARM_H.fromPPtr_def) -lemma rescheduleRequired_unlive[wp]: - "\\s. ko_wp_at' (Not \ live') p s \ sch_act_not p s\ - rescheduleRequired - \\_. ko_wp_at' (Not \ live') p\" - unfolding rescheduleRequired_def - apply (wpsimp wp: setObject_ko_wp_at getObject_tcb_wp isSchedulable_wp - simp: objBits_simps' bitmap_fun_defs tcbSchedEnqueue_def unless_def - threadSet_def setQueue_def threadGet_getObject)+ - by (fastforce simp: o_def dest!: obj_at_ko_at'[where P=\]) - lemma tcbSchedEnqueue_unlive_other: "\ko_wp_at' (Not \ live') p and K (p \ t)\ tcbSchedEnqueue t \\_. ko_wp_at' (Not \ live') p\" - apply (simp add: tcbSchedEnqueue_def) - apply (wpsimp wp: threadGet_wp threadSet_unlive_other) - apply (fastforce simp: obj_at'_def projectKOs ko_wp_at'_def) - done - -crunch scheduleTCB - for unlive[wp]: "ko_wp_at' (Not \ live') p" - (wp: crunch_wps isSchedulable_inv simp: crunch_simps) - -lemma setThreadState_unlive_other: - "\ko_wp_at' (Not \ live') p and sch_act_not p and K (p \ t)\ - setThreadState st t - \\rv. ko_wp_at' (Not \ live') p\" - unfolding setThreadState_def - apply (wpsimp wp: threadSet_wp) - apply (fastforce simp: ko_wp_at'_def obj_at'_def) + apply (simp add: tcbSchedEnqueue_def tcbQueuePrepend_def setQueue_def) + apply (wpsimp wp: threadGet_wp threadSet_unlive_other simp: 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) + apply (clarsimp simp: tcbQueueEmpty_def) + apply (frule (1) tcbQueueHead_ksReadyQueues) + apply (drule_tac x=p in spec) + apply (fastforce dest!: inQ_implies_tcbQueueds_of + simp: tcbQueueEmpty_def ko_wp_at'_def opt_pred_def opt_map_def projectKOs + split: option.splits) done -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma possibleSwitchTo_unlive_other: - "\ko_wp_at' (Not \ live') p and sch_act_not p and K (p \ t)\ - possibleSwitchTo t +lemma rescheduleRequired_unlive[wp]: + "\\s. ko_wp_at' (Not \ live') p s \ ksSchedulerAction s \ SwitchToThread p\ + rescheduleRequired \\_. ko_wp_at' (Not \ live') p\" - apply (simp add: possibleSwitchTo_def inReleaseQueue_def) - apply (wpsimp wp: tcbSchedEnqueue_unlive_other threadGet_wp rescheduleRequired_unlive)+ - apply (auto simp: obj_at'_def ko_wp_at'_def) - done - -lemma setThreadState_Inactive_unlive: - "\ko_wp_at' (Not \ live') p and sch_act_not p\ - 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 projectKOs is_aligned_def ps_clear_def objBitsKO_def) + supply comp_apply[simp del] + unfolding rescheduleRequired_def + apply (wpsimp wp: tcbSchedEnqueue_unlive_other) done -lemma replyUnlink_unlive: - "\ko_wp_at' (Not \ live') p and sch_act_not p\ - replyUnlink replyPtr tcbPtr - \\_. ko_wp_at' (Not o live') p\" - apply (clarsimp simp: replyUnlink_def updateReply_def) - apply (wpsimp wp: setThreadState_Inactive_unlive set_reply'.set_wp gts_wp') - apply (fastforce simp: ko_wp_at'_def obj_at'_def projectKOs is_aligned_def ps_clear_def - objBitsKO_def live'_def live_reply'_def) - done +lemmas setEndpoint_ko_wp_at' + = setObject_ko_wp_at'[where 'a=endpoint, folded setEndpoint_def, simplified] lemma cancelAllIPC_unlive: "\valid_objs' and (\s. sch_act_wf (ksSchedulerAction s) s)\ - cancelAllIPC ep - \\rv. ko_wp_at' (Not \ live') ep\" - unfolding cancelAllIPC_def cancelAllIPC_loop_body_def restartThreadIfNoFault_def - apply (simp add: ep'_Idle_case_helper) - apply (repeat_unless \rule bind_wp[OF _ get_ep_sp']\ - \rule bind_wp_fwd_skip, wpsimp\) - apply (rename_tac endpoint) - apply (rule hoare_if) - apply (wpsimp simp: ko_wp_at'_def live'_def obj_at'_def projectKOs) - - apply (rule_tac Q'="\_ s. valid_objs' s - \ sch_act_wf (ksSchedulerAction s) s - \ ko_wp_at' (Not \ live') ep s - \ ep_at' ep s - \ valid_ep' endpoint s" - in bind_wp_fwd) - apply (wpsimp wp: set_ep_valid_objs' set_ep'.sch_act_wf) - apply (wpsimp wp: set_ep'.set_wp) - apply (clarsimp simp del: fun_upd_apply) - apply (frule (1) ep_ko_at_valid_objs_valid_ep') - apply (clarsimp simp: valid_ep'_def ko_wp_at'_def obj_at'_def projectKOs objBitsKO_def - ps_clear_def) - apply (fastforce simp: valid_ep'_def obj_at'_def projectKOs objBitsKO_def split: endpoint.splits) - - apply clarsimp - apply (rule_tac P'="\s. valid_objs' s - \ sch_act_not ep s - \ ko_wp_at' (Not \ live') ep s - \ ep_at' ep s - \ valid_ep' endpoint s" - in hoare_weaken_pre[rotated]) - apply (clarsimp simp: st_tcb_at'_def obj_at'_def projectKOs) - apply (rule bind_wp) - apply (wpsimp wp: rescheduleRequired_unlive) - apply (rule hoare_strengthen_post) - apply (rule mapM_x_wp') - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp_fwd_skip, wpsimp wp: replyUnlink_valid_objs' replyUnlink_unlive) - apply (wpsimp wp: possibleSwitchTo_unlive_other setThreadState_unlive_other hoare_drop_imps - possibleSwitchTo_sch_act_not_other) - apply (clarsimp simp: valid_tcb_state'_def obj_at'_def projectKOs) - apply (fastforce simp: valid_ep'_def obj_at'_def projectKOs split: endpoint.splits) - apply clarsimp - done - -lemma cancelAllSignals_unlive_helper: - "\\s. (\x\set xs. tcb_at' x s) \ ko_wp_at' (Not \ live') p s - \ sch_act_not p s \ p \ set xs\ - 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 - \sch_act_not p s\" - apply (rule hoare_strengthen_post) - apply (rule mapM_x_wp') - apply (rule hoare_pre) - apply (wpsimp wp: hoare_vcg_const_Ball_lift setThreadState_unlive_other - possibleSwitchTo_unlive_other possibleSwitchTo_sch_act_not_other) - apply clarsimp - apply clarsimp + cancelAllIPC ep \\rv. ko_wp_at' (Not \ live') ep\" + apply (simp add: cancelAllIPC_def ep'_Idle_case_helper) + apply (rule bind_wp[OF _ stateAssert_sp]) + apply (rule bind_wp [OF _ get_ep_sp']) + apply (rule hoare_pre) + apply (wp cancelAll_unlive_helper setEndpoint_ko_wp_at' + hoare_vcg_const_Ball_lift rescheduleRequired_unlive + mapM_x_wp' + | simp add: objBits_simps')+ + apply (clarsimp simp: projectKO_opt_tcb) + apply (frule(1) obj_at_valid_objs') + apply (intro conjI impI) + apply (clarsimp simp: valid_obj'_def valid_ep'_def projectKOs + obj_at'_def pred_tcb_at'_def ko_wp_at'_def + split: endpoint.split_asm)+ done lemma cancelAllSignals_unlive: "\\s. valid_objs' s \ sch_act_wf (ksSchedulerAction s) s - \ obj_at' (\ko. ntfnBoundTCB ko = None) ntfnptr s - \ obj_at' (\ko. ntfnSc ko = None) ntfnptr s\ - cancelAllSignals ntfnptr - \\rv. ko_wp_at' (Not \ live') ntfnptr\" + \ obj_at' (\ko. ntfnBoundTCB ko = None) ntfnptr s\ + 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 (rule bind_wp[OF _ stateAssert_sp]) + apply (rule bind_wp [OF _ get_ntfn_sp']) + apply (case_tac "ntfnObj ntfn", simp_all add: setNotification_def) apply wp - apply (fastforce simp: obj_at'_real_def projectKOs live_ntfn'_def ko_wp_at'_def) + apply (fastforce simp: obj_at'_real_def projectKOs + dest: obj_at_conj' + elim: ko_wp_at'_weakenE) apply wp - apply (fastforce simp: obj_at'_real_def projectKOs live_ntfn'_def ko_wp_at'_def) + apply (fastforce simp: obj_at'_real_def projectKOs + dest: obj_at_conj' + elim: ko_wp_at'_weakenE) apply (wp rescheduleRequired_unlive) - apply (rule cancelAllSignals_unlive_helper[THEN hoare_strengthen_post]) - apply fastforce - apply (wpsimp wp: hoare_vcg_const_Ball_lift set_ntfn'.ko_wp_at - simp: objBits_simps') - apply (clarsimp, frule (1) ko_at_valid_objs'_pre, - clarsimp simp: valid_obj'_def valid_ntfn'_def) - apply (intro conjI[rotated]; clarsimp) - apply (fastforce simp: obj_at'_def projectKOs) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (clarsimp simp: live_ntfn'_def ko_wp_at'_def obj_at'_def) + apply (wp cancelAll_unlive_helper) + apply ((wp mapM_x_wp' setObject_ko_wp_at' hoare_vcg_const_Ball_lift)+, + simp_all add: objBits_simps', simp_all) + apply (fold setNotification_def, wp) + apply (intro conjI[rotated]) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) + apply (clarsimp simp: projectKOs projectKO_opt_tcb) + apply (fastforce simp: ko_wp_at'_def valid_obj'_def valid_ntfn'_def + obj_at'_def projectKOs)+ done +crunch tcbSchedEnqueue + for ep_at'[wp]: "ep_at' epptr" + (simp: unless_def) + 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 tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' p" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps) - lemma cancelBadgedSends_filterM_helper': notes if_cong[cong del] shows "\ys. - \\s. invs' s \ sch_act_wf (ksSchedulerAction s) s + \\s. all_invs_but_sym_refs_ct_not_inQ' 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) + \ {r \ state_refs_of' s y. snd r = TCBBound}) \ distinct (xs @ ys)\ filterM (\t. do st \ getThreadState t; - if blockingIPCBadge st = badge - then - do restartThreadIfNoFault t; + if blockingIPCBadge st = badge then + do y \ setThreadState Structures_H.thread_state.Restart t; + y \ tcbSchedEnqueue t; return False od else return True od) xs - \\rv s. invs' s \ sch_act_wf (ksSchedulerAction s) s + \\rv s. all_invs_but_sym_refs_ct_not_inQ' 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) + \ {r \ state_refs_of' s y. snd r = TCBBound}) \ 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 @@ -3556,102 +2070,66 @@ lemma cancelBadgedSends_filterM_helper': apply (clarsimp simp: filterM_append bind_assoc simp del: set_append distinct_append) apply (drule spec, erule bind_wp_fwd) apply (rule bind_wp [OF _ gts_inv']) - apply (simp add: opt_map_Some_eta_fold split del: if_split) apply (rule hoare_pre) - apply (wpsimp wp: valid_irq_node_lift hoare_vcg_const_Ball_lift - valid_irq_handlers_lift'' irqs_masked_lift sts_st_tcb' - hoare_vcg_all_lift sts_sch_act' - threadGet_inv[THEN hoare_drop_imp] hoare_vcg_imp_lift' - simp: cteCaps_of_def o_def) - apply (clarsimp simp: opt_map_Some_eta_fold) + apply (wp valid_irq_node_lift hoare_vcg_const_Ball_lift sts_sch_act' + sch_act_wf_lift valid_irq_handlers_lift'' cur_tcb_lift irqs_masked_lift + sts_st_tcb' untyped_ranges_zero_lift + | clarsimp simp: cteCaps_of_def o_def)+ 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 (clarsimp simp: valid_pspace'_def cong: conj_cong) 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' projectKOs - 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'')+ + apply (fastforce simp: valid_tcb'_def dest!: st_tcb_ex_cap'') + apply (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) + apply (erule delta_sym_refs) + by (fastforce elim!: obj_atE' + simp: state_refs_of'_def tcb_bound_refs'_def subsetD symreftype_inverse' projectKOs + split: if_split_asm)+ lemmas cancelBadgedSends_filterM_helper = spec [where x=Nil, OF cancelBadgedSends_filterM_helper', simplified] -lemma cancelBadgedSends_invs'[wp]: +lemma cancelBadgedSends_invs[wp]: notes if_cong[cong del] shows - "cancelBadgedSends epptr badge \invs'\" + "\invs'\ cancelBadgedSends epptr badge \\rv. invs'\" apply (simp add: cancelBadgedSends_def) - apply (intro bind_wp[OF _ stateAssert_sp]) + apply (rule 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) + [OF rescheduleRequired_all_invs_but_ct_not_inQ]) + apply (simp add: list_case_return cong: list.case_cong) apply (rule hoare_pre, wp valid_irq_node_lift irqs_masked_lift) + apply simp 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 (clarsimp simp: ep_redux_simps3 fun_upd_def[symmetric]) + apply (clarsimp simp add: valid_ep'_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] + apply (clarsimp simp: invs'_def valid_state'_def + 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 projectKOs) apply (frule if_live_then_nonz_capD', simp add: obj_at'_real_def) apply (clarsimp simp: projectKOs) - 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 (clarsimp simp add: fun_upd_idem + st_tcb_at_refs_of_rev') 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) + apply (fastforce simp: set_eq_subset tcb_bound_refs'_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 projectKOs - 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 projectKOs) - apply (clarsimp simp: sym_refs_def) - apply (fastforce simp: ko_wp_at'_def obj_at'_def projectKOs state_refs_of'_def) - done +crunch tcb_sched_action + for state_refs_of[wp]: "\s. P (state_refs_of s)" + (ignore_del: tcb_sched_action) lemma setEndpoint_valid_tcbs'[wp]: "setEndpoint ePtr val \valid_tcbs'\" @@ -3662,145 +2140,87 @@ lemma setEndpoint_valid_tcbs'[wp]: done lemma cancelBadgedSends_corres: - "corres dc (invs and valid_sched and ep_at epptr and current_time_bounded) - (invs' and ep_at' epptr) + "corres dc (invs and valid_sched and ep_at epptr) (invs' and ep_at' epptr) (cancel_badged_sends epptr bdg) (cancelBadgedSends epptr bdg)" - apply add_sym_refs - apply add_sch_act_wf - 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 (simp add: cancel_badged_sends_def cancelBadgedSends_def) + 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)) - and (\s. sch_act_wf (ksSchedulerAction s) s)"]) + apply (rule corres_split[OF getEndpoint_corres _ get_simple_ko_sp get_ep_sp', + where Q="invs and valid_sched" and Q'=invs']) apply simp_all - apply (case_tac ep; simp add: ep_relation_def) - apply (rename_tac queue) + apply (case_tac ep, simp_all add: ep_relation_def) apply (simp add: filterM_mapM list_case_return cong: list.case_cong) 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_tcbs 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 \ weak_sch_act_wf (ksSchedulerAction s) s \ valid_queues s - \ valid_queues' s \ valid_tcbs' s \ valid_release_queue_iff 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 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+ - apply (wpsimp wp: gts_wp) - apply (wpsimp wp: gts_wp') - apply (clarsimp simp: st_tcb_def2 st_tcb_at_refs_of_rev valid_sched_def - dest!: state_refs_of_elemD) - 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 - setThreadState_valid_queues' threadGet_wp gts_wp' - simp: obj_at_ko_at'_eq[where P=\, simplified]) - apply (fastforce simp: valid_tcb_state'_def obj_at'_def projectKOs 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 (simp add: ep_relation_def) + apply (rule corres_split_eqr[OF _ _ _ hoare_post_add + [where Q'="\_. valid_objs' and pspace_aligned' + and pspace_distinct'"]]) + apply (rule_tac S="(=)" + and Q="\xs s. (\x \ set xs. (epptr, TCBBlockedSend) \ state_refs_of s x) \ + distinct xs \ valid_etcbs s \ + in_correct_ready_q s \ ready_qs_distinct s \ + pspace_aligned s \ pspace_distinct s" + and Q'="\_ s. valid_objs' s \ sym_heap_sched_pointers s \ valid_sched_pointers s + \ pspace_aligned' s \ pspace_distinct' s" + in corres_mapM_list_all2[where r'="(=)"], + simp_all add: list_all2_refl)[1] + apply (clarsimp simp: liftM_def[symmetric] o_def) + 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 (clarsimp simp: o_def dc_def[symmetric] liftM_def) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) + apply (rule corres_trivial) + apply simp + apply wp+ + apply simp + apply (wp sts_st_tcb_at' gts_st_tcb_at sts_valid_objs' + | strengthen valid_objs'_valid_tcbs')+ + apply (clarsimp simp: valid_tcb_state_def tcb_at_def st_tcb_def2 + st_tcb_at_refs_of_rev + dest!: state_refs_of_elemD elim!: tcb_at_is_etcb_at[rotated]) + apply (simp add: valid_tcb_state'_def) + apply (wp hoare_vcg_const_Ball_lift gts_wp | clarsimp)+ + apply (wp hoare_vcg_imp_lift sts_st_tcb' sts_valid_objs' + | clarsimp simp: valid_tcb_state'_def)+ + apply (rule corres_split[OF _ rescheduleRequired_corres]) + apply (rule setEndpoint_corres) + apply (simp split: list.split add: ep_relation_def) apply (wp weak_sch_act_wf_lift_linear)+ - apply (rule_tac Q'="\_ s. valid_tcbs 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 - apply (rule_tac P'="(\s. \t\set queue. tcb_at' t s \ st_tcb_at' (not runnable') t s) - and (\s. valid_tcbs' s \ weak_sch_act_wf (ksSchedulerAction s) s - \ valid_queues s \ valid_queues' s \ valid_release_queue_iff 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 projectKOs st_tcb_at'_def - pred_neg_def weak_sch_act_wf_def) - apply simp - apply simp - apply (wpsimp wp: 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 projectKOs - dest: invs_valid_objs') - apply (intro conjI impI ballI - ; (fastforce simp: valid_ep'_def obj_at'_def projectKOs)?) - apply (frule (2) in_send_ep_queue_TCBBlockedSend') - apply fastforce - apply (fastforce simp: st_tcb_at_refs_of_rev' st_tcb_at'_def obj_at'_def pred_neg_def) - done - -crunch schedContextCancelYieldTo, tcbReleaseRemove - for tcbQueued[wp]: "obj_at' (\obj. \ tcbQueued obj) t" - (wp: crunch_wps simp: crunch_simps setReleaseQueue_def setReprogramTimer_def getReleaseQueue_def) + apply (wpsimp wp: mapM_wp' set_thread_state_runnable_weak_valid_sched_action + simp: valid_tcb_state'_def) + apply ((wpsimp wp: hoare_vcg_imp_lift mapM_wp' sts_valid_objs' simp: valid_tcb_state'_def + | strengthen valid_objs'_valid_tcbs')+)[1] + apply (wpsimp wp: set_ep_valid_objs')+ + apply (clarsimp simp: conj_comms) + apply (frule sym_refs_ko_atD, clarsimp+) + apply (rule obj_at_valid_objsE, assumption+, clarsimp+) + apply (clarsimp simp: valid_obj_def valid_ep_def valid_sched_def valid_sched_action_def) + apply (rule conjI, fastforce) + apply (rule conjI, fastforce) + apply (rule conjI, fastforce) + apply (rule conjI, erule obj_at_weakenE, clarsimp simp: is_ep) + apply (rule conjI, fastforce) + apply (clarsimp simp: st_tcb_at_refs_of_rev) + apply (drule(1) bspec, drule st_tcb_at_state_refs_ofD, clarsimp) + apply (simp add: set_eq_subset) + apply (clarsimp simp: obj_at'_weakenE[OF _ TrueI]) + apply (fastforce simp: valid_ep'_def) + done + +crunch updateRestartPC + for tcb_at'[wp]: "tcb_at' t" + (simp: crunch_simps) 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 projectKOs) - apply (rule hoare_TrueI) - apply wpsimp+ - done + unfolding suspend_def + by (wpsimp simp: comp_def wp: tcbSchedDequeue_not_tcbQueued) crunch prepareThreadDelete for unqueued: "obj_at' (Not \ tcbQueued) t" diff --git a/proof/refine/ARM/Ipc_R.thy b/proof/refine/ARM/Ipc_R.thy index ba0494f88c..e47d7cf621 100644 --- a/proof/refine/ARM/Ipc_R.thy +++ b/proof/refine/ARM/Ipc_R.thy @@ -5,10 +5,10 @@ *) theory Ipc_R -imports Finalise_R Reply_R +imports Finalise_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemmas lookup_slot_wrapper_defs'[simp] = lookupSourceSlot_def lookupTargetSlot_def lookupPivotSlot_def @@ -250,17 +250,15 @@ lemma corres_set_extra_badge: add.commute add.left_commute) done -end - crunch setExtraBadge - 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_pspace'[wp]: valid_pspace' - and cte_wp_at'[wp]: "cte_wp_at' P p" - and ipc_buffer'[wp]: "valid_ipc_buffer_ptr' buffer" - -global_interpretation setExtraBadge: typ_at_all_props' "setExtraBadge buffer badge n" - by typ_at_props' + for typ_at': "\s. P (typ_at' T p s)" +lemmas setExtraBadge_typ_ats' [wp] = typ_at_lifts [OF setExtraBadge_typ_at'] +crunch setExtraBadge + for valid_pspace'[wp]: valid_pspace' +crunch setExtraBadge + for cte_wp_at'[wp]: "cte_wp_at' P p" +crunch setExtraBadge + for ipc_buffer'[wp]: "valid_ipc_buffer_ptr' buffer" crunch getExtraCPtr for inv'[wp]: P (wp: dmo_inv' loadWord_inv) @@ -363,8 +361,6 @@ lemma maskedAsFull_null_cap[simp]: "(capability.NullCap = maskedAsFull x y) = (x = capability.NullCap)" by (case_tac x, auto simp:maskedAsFull_def isCap_simps ) -context begin interpretation Arch . (*FIXME: arch_split*) - lemma maskCapRights_eq_null: "(RetypeDecls_H.maskCapRights r xa = capability.NullCap) = (xa = capability.NullCap)" @@ -381,6 +377,7 @@ lemma cte_refs'_maskedAsFull[simp]: apply (clarsimp simp:maskedAsFull_def isCap_simps)+ done + lemma transferCapsToSlots_corres: "\ list_all2 (\(cap, slot) (cap', slot'). cap_relation cap cap' \ slot' = cte_map slot) caps caps'; @@ -423,7 +420,7 @@ next apply (rule corres_const_on_failure) apply (simp add: dc_def[symmetric] split del: if_split) apply (rule corres_guard_imp) - apply (rule corres_if3) + apply (rule corres_if2) apply (case_tac "fst x", auto simp add: isCap_simps)[1] apply (rule corres_split[OF corres_set_extra_badge]) apply (clarsimp simp: is_cap_simps) @@ -734,12 +731,6 @@ lemma transferCapsToSlots_no_0_obj' [wp]: "\no_0_obj'\ transferCapsToSlots ep buffer n caps slots mi \\rv. no_0_obj'\" by (wp transferCapsToSlots_pres1) -crunch transferCapsToSlots - 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" - and valid_replies' [wp]: valid_replies' - and pspace_bounded'[wp]: pspace_bounded' - lemma transferCapsToSlots_vp[wp]: "\\s. valid_pspace' s \ distinct slots \ length slots \ 1 @@ -748,16 +739,17 @@ lemma transferCapsToSlots_vp[wp]: \ transferCaps_srcs caps s\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_pspace'\" - apply (simp add: valid_pspace'_def | wp)+ + apply (rule hoare_pre) + apply (simp add: valid_pspace'_def | wp)+ apply (fastforce simp: cte_wp_at_ctes_of dest: ctes_of_valid') done crunch setExtraBadge, doIPCTransfer for sch_act [wp]: "\s. P (ksSchedulerAction s)" (wp: crunch_wps mapME_wp' simp: zipWithM_x_mapM) - crunch setExtraBadge - for ksCurThread[wp]: "\s. P (ksCurThread s)" + for pred_tcb_at' [wp]: "\s. pred_tcb_at' proj P p s" + and ksCurThread[wp]: "\s. P (ksCurThread s)" and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and obj_at' [wp]: "\s. P' (obj_at' P p s)" and queues [wp]: "\s. P (ksReadyQueues s)" @@ -791,8 +783,7 @@ lemma tcts_iflive[wp]: by (wp transferCapsToSlots_pres2 | simp)+ crunch setExtraBadge - for valid_idle'[wp]: valid_idle' - and if_unsafe'[wp]: if_unsafe_then_cap' + for if_unsafe'[wp]: if_unsafe_then_cap' lemma tcts_ifunsafe[wp]: "\\s. if_unsafe_then_cap' s \ distinct slots \ @@ -801,6 +792,15 @@ lemma tcts_ifunsafe[wp]: \\rv. if_unsafe_then_cap'\" by (wp transferCapsToSlots_pres2 | simp)+ +crunch ensureNoChildren + for it[wp]: "\s. P (ksIdleThread s)" + +crunch deriveCap + for idle'[wp]: "valid_idle'" + +crunch setExtraBadge + for valid_idle'[wp]: valid_idle' + lemma tcts_idle'[wp]: "\\s. valid_idle' s\ transferCapsToSlots ep buffer n caps slots mi \\rv. valid_idle'\" @@ -982,12 +982,20 @@ lemma tcts_zero_ranges[wp]: apply auto[1] done -crunch setExtraBadge, transferCapsToSlots +crunch setExtraBadge for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and replies_of'[wp]: "\s. P (replies_of' s)" +crunch transferCapsToSlots + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' +crunch transferCapsToSlots + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" +crunch setExtraBadge + for ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" +crunch setExtraBadge + for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" +crunch transferCapsToSlots + for ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" +crunch transferCapsToSlots + for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" crunch transferCapsToSlots for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers @@ -997,14 +1005,14 @@ crunch transferCapsToSlots lemma transferCapsToSlots_invs[wp]: "\\s. invs' s \ distinct slots - \ (\x \ set slots. cte_wp_at' (\cte. cteCap cte = NullCap) x s) - \ (\x \ set slots. ex_cte_cap_to' x s) - \ (\x \ set slots. real_cte_at' x s) - \ length slots \ 1 - \ transferCaps_srcs caps s\ - transferCapsToSlots ep buffer n caps slots mi - \\_. invs'\" - apply (simp add: invs'_def valid_dom_schedule'_def) + \ (\x \ set slots. cte_wp_at' (\cte. cteCap cte = NullCap) x s) + \ (\x \ set slots. ex_cte_cap_to' x s) + \ (\x \ set slots. real_cte_at' x s) + \ length slots \ 1 + \ transferCaps_srcs caps s\ + transferCapsToSlots ep buffer n caps slots mi + \\rv. invs'\" + apply (simp add: invs'_def valid_state'_def) apply (wp valid_irq_node_lift) apply fastforce done @@ -1031,8 +1039,8 @@ lemma transferCaps_corres: and case_option \ in_user_frame recv_buf and (\s. valid_message_info info) and transfer_caps_srcs caps) - (tcb_at' receiver and valid_objs' and valid_replies' and - pspace_aligned' and pspace_distinct' and pspace_bounded' and no_0_obj' and valid_mdb' + (tcb_at' receiver and valid_objs' and + pspace_aligned' and pspace_distinct' and no_0_obj' and valid_mdb' and (\s. case ep of Some x \ ep_at' x s | _ \ True) and case_option \ valid_ipc_buffer_ptr' recv_buf and transferCaps_srcs caps' @@ -1073,16 +1081,10 @@ lemma transferCaps_corres: apply (fastforce simp:valid_cap'_def) done -end - crunch transferCaps for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" -global_interpretation transferCaps: typ_at_all_props' "transferCaps info caps endpoint receiver receiveBuffer" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas transferCaps_typ_ats[wp] = typ_at_lifts [OF transferCaps_typ_at'] lemma isIRQControlCap_mask [simp]: "isIRQControlCap (maskCapRights R c) = isIRQControlCap c" @@ -1095,12 +1097,16 @@ lemma isIRQControlCap_mask [simp]: done lemma isPageCap_maskCapRights[simp]: - "isArchCap isPageCap (RetypeDecls_H.maskCapRights R c) = isArchCap isPageCap c" +" isArchCap isPageCap (RetypeDecls_H.maskCapRights R c) = isArchCap isPageCap c" apply (case_tac c; simp add: isCap_simps isArchCap_def maskCapRights_def) apply (rename_tac arch_capability) apply (case_tac arch_capability; simp add: isCap_simps ARM_H.maskCapRights_def) done +lemma capReplyMaster_mask[simp]: + "isReplyCap c \ capReplyMaster (maskCapRights R c) = capReplyMaster c" + by (clarsimp simp: isCap_simps maskCapRights_def) + lemma is_derived_mask' [simp]: "is_derived' m p (maskCapRights R c) = is_derived' m p c" apply (rule ext) @@ -1149,17 +1155,12 @@ lemma get_mrs_inv'[wp]: | wp dmo_inv' loadWord_inv mapM_wp' asUser_inv det_mapM[where S=UNIV] | wpc)+ -end - -crunch copyMRs - 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 copyMRs: typ_at_all_props' "copyMRs s sb r rb n" - by typ_at_props' +lemma copyMRs_typ_at': + "\\s. P (typ_at' T p s)\ copyMRs s sb r rb n \\rv s. P (typ_at' T p s)\" + by (simp add: copyMRs_def | wp mapM_wp [where S=UNIV, simplified] | wpc)+ -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas copyMRs_typ_at_lifts[wp] = typ_at_lifts [OF copyMRs_typ_at'] lemma copy_mrs_invs'[wp]: "\ invs' and tcb_at' s and tcb_at' r \ copyMRs s sb r rb n \\rv. invs' \" @@ -1184,12 +1185,29 @@ crunch transferCaps for distinct'[wp]: pspace_distinct' (wp: crunch_wps simp: zipWithM_x_mapM) +crunch setMRs + for aligned'[wp]: pspace_aligned' + (wp: crunch_wps simp: crunch_simps) +crunch setMRs + for distinct'[wp]: pspace_distinct' + (wp: crunch_wps simp: crunch_simps) crunch copyMRs - for aligned'[wp]: pspace_aligned' + for aligned'[wp]: pspace_aligned' (wp: crunch_wps simp: crunch_simps wp: crunch_wps) crunch copyMRs for distinct'[wp]: pspace_distinct' (wp: crunch_wps simp: crunch_simps wp: crunch_wps) +crunch setMessageInfo + for aligned'[wp]: pspace_aligned' + (wp: crunch_wps simp: crunch_simps) +crunch setMessageInfo + for distinct'[wp]: pspace_distinct' + (wp: crunch_wps simp: crunch_simps) + +crunch storeWordUser + for valid_objs'[wp]: valid_objs' +crunch storeWordUser + for valid_pspace'[wp]: valid_pspace' lemma set_mrs_valid_objs' [wp]: "\valid_objs'\ setMRs t a msgs \\rv. valid_objs'\" @@ -1371,9 +1389,6 @@ lemma lookupExtraCaps_corres: crunch copyMRs for ctes_of[wp]: "\s. P (ctes_of s)" - and reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" - and valid_replies' [wp]: valid_replies' - and pspace_bounded'[wp]: pspace_bounded' (wp: threadSet_ctes_of crunch_wps) lemma copyMRs_valid_mdb[wp]: @@ -1387,8 +1402,8 @@ lemma doNormalTransfer_corres: and (\s. case ep of Some x \ ep_at x s | _ \ True) and case_option \ in_user_frame send_buf and case_option \ in_user_frame recv_buf) - (tcb_at' sender and tcb_at' receiver and valid_objs' and valid_replies' - and pspace_aligned' and pspace_distinct' and pspace_bounded' and cur_tcb' + (tcb_at' sender and tcb_at' receiver and valid_objs' + and pspace_aligned' and pspace_distinct' and cur_tcb' and valid_mdb' and no_0_obj' and (\s. case ep of Some x \ ep_at' x s | _ \ True) and case_option \ valid_ipc_buffer_ptr' send_buf @@ -1443,15 +1458,10 @@ lemmas corres_ipc_info_helper = corres_split_maprE [where f = message_info_map, OF _ corres_liftE_lift [OF getMessageInfo_corres]] -end - crunch doNormalTransfer 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 doNormalTransfer: typ_at_all_props' "doNormalTransfer s sb e b g r rb" - by typ_at_props' +lemmas doNormal_lifts[wp] = typ_at_lifts [OF doNormalTransfer_typ_at'] lemma doNormal_invs'[wp]: "\tcb_at' sender and tcb_at' receiver and invs'\ @@ -1496,8 +1506,6 @@ lemma msgFromLookupFailure_map[simp]: = msg_from_lookup_failure lf" by (cases lf, simp_all add: lookup_failure_map_def msgFromLookupFailure_def) -context begin interpretation Arch . (*FIXME: arch_split*) - lemma asUser_getRestartPC_corres: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t getRestartPC) (asUser t getRestartPC)" @@ -1546,65 +1554,35 @@ lemma makeFaultMessage_corres: apply (rule corres_split_eqr[OF asUser_mapM_getRegister_corres]) apply (rule corres_trivial, simp) apply (wp | simp)+ - apply (clarsimp simp: threadGet_getObject) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getObject_TCB_corres]) - apply (rename_tac tcb tcb') - apply (rule_tac P="\s. (bound (tcb_sched_context tcb) \ sc_at (the (tcb_sched_context tcb)) s) - \ pspace_aligned s \ pspace_distinct s" - in corres_inst) - apply (case_tac "tcb_sched_context tcb" - ; case_tac "tcbSchedContext tcb'" - ; clarsimp simp: tcb_relation_def) - apply (rule corres_underlying_split) - apply (rule_tac Q="sc_at' (the (tcbSchedContext tcb'))" and P'=\ in corres_cross_add_guard) - apply (fastforce dest!: state_relationD intro!: sc_at_cross simp: obj_at'_def)[1] - apply (rule corres_guard_imp) - apply (rule schedContextUpdateConsumed_corres) - apply (wpsimp simp: sched_context_update_consumed_def setTimeArg_def)+ - apply (fastforce dest!: valid_tcb_objs simp: valid_tcb_def valid_bound_obj_def obj_at_def) - apply clarsimp - apply (corresKsimp corres: makeArchFaultMessage_corres) + apply (rule makeArchFaultMessage_corres) done -crunch makeFaultMessage - for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - -end - -global_interpretation makeFaultMessage: typ_at_all_props' "makeFaultMessage x t" - by typ_at_props' +lemma makeFaultMessage_inv[wp]: + "\P\ makeFaultMessage ft t \\rv. P\" + apply (cases ft, simp_all add: makeFaultMessage_def) + apply (wp asUser_inv mapM_wp' det_mapM[where S=UNIV] + det_getRestartPC getRestartPC_inv + | clarsimp simp: getRegister_def makeArchFaultMessage_def + split: arch_fault.split)+ + done lemmas threadget_fault_corres = threadGet_corres [where r = fault_rel_optionation and f = tcb_fault and f' = tcbFault, simplified tcb_relation_def, simplified] -context begin interpretation Arch . (*FIXME: arch_split*) - -crunch make_fault_msg - for in_user_Frame[wp]: "in_user_frame buffer" - -lemma makeFaultMessage_valid_ipc_buffer_ptr'[wp]: - "makeFaultMessage x thread \valid_ipc_buffer_ptr' p\" - unfolding valid_ipc_buffer_ptr'_def2 - apply (wpsimp wp: hoare_vcg_all_lift) - done - lemma doFaultTransfer_corres: "corres dc - (valid_objs and pspace_distinct and pspace_aligned - and obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender - and tcb_at receiver and case_option \ in_user_frame recv_buf) + (obj_at (\ko. \tcb ft. ko = TCB tcb \ tcb_fault tcb = Some ft) sender + and tcb_at receiver and case_option \ in_user_frame recv_buf + and pspace_aligned and pspace_distinct) (tcb_at' sender and tcb_at' receiver and case_option \ valid_ipc_buffer_ptr' recv_buf) (do_fault_transfer badge sender receiver recv_buf) (doFaultTransfer badge sender receiver recv_buf)" apply (clarsimp simp: do_fault_transfer_def doFaultTransfer_def split_def ARM_H.badgeRegister_def badge_register_def) - apply (rule_tac Q="\fault. valid_objs and pspace_distinct and pspace_aligned and - K (\f. fault = Some f) and + apply (rule_tac Q="\fault. K (\f. fault = Some f) and tcb_at sender and tcb_at receiver and case_option \ in_user_frame recv_buf and pspace_aligned and pspace_distinct" @@ -1642,18 +1620,51 @@ lemma doFaultTransfer_corres: apply (wp | simp)+ done -crunch makeFaultMessage - for iflive[wp]: if_live_then_nonz_cap' - and idle'[wp]: valid_idle' - -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'\" - apply (wpsimp simp: doFaultTransfer_def split_def split: option.split) + "\invs' and tcb_at' receiver\ + doFaultTransfer badge sender receiver recv_buf + \\rv. invs'\" + by (simp add: doFaultTransfer_def split_def | wp + | clarsimp split: option.split)+ + +lemma lookupIPCBuffer_valid_ipc_buffer [wp]: + "\valid_objs'\ VSpace_H.lookupIPCBuffer b s \case_option \ valid_ipc_buffer_ptr'\" + unfolding lookupIPCBuffer_def ARM_H.lookupIPCBuffer_def + apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def + locateSlot_conv threadGet_def comp_def) + apply (wp getCTE_wp getObject_tcb_wp | wpc)+ + apply (clarsimp simp del: imp_disjL) + apply (drule obj_at_ko_at') + apply (clarsimp simp del: imp_disjL) + apply (rule_tac x = ko in exI) + apply (frule ko_at_cte_ipcbuffer) + apply (clarsimp simp: cte_wp_at_ctes_of simp del: imp_disjL) + apply (clarsimp simp: valid_ipc_buffer_ptr'_def) + apply (frule (1) ko_at_valid_objs') + apply (clarsimp simp: projectKO_opts_defs split: kernel_object.split_asm) + apply (clarsimp simp add: valid_obj'_def valid_tcb'_def + isCap_simps cte_level_bits_def field_simps) + apply (drule bspec [OF _ ranI [where a = "0x40"]]) + apply simp + apply (clarsimp simp add: valid_cap'_def) + apply (rule conjI) + apply (rule aligned_add_aligned) + apply (clarsimp simp add: capAligned_def) + apply assumption + apply (erule is_aligned_andI1) + apply (case_tac xd, simp_all add: msg_align_bits)[1] + apply (clarsimp simp: capAligned_def) + apply (drule_tac x = + "(tcbIPCBuffer ko && mask (pageBitsForSize xd)) >> pageBits" in spec) + apply (subst(asm) mult.commute mult.left_commute, subst(asm) shiftl_t2n[symmetric]) + apply (simp add: shiftr_shiftl1) + apply (subst (asm) mask_out_add_aligned) + apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) + apply (erule mp) + apply (rule shiftr_less_t2n) + apply (clarsimp simp: pbfs_atleast_pageBits) + apply (rule and_mask_less') + apply (simp add: word_bits_conv) done lemma doIPCTransfer_corres: @@ -1685,7 +1696,7 @@ lemma doIPCTransfer_corres: defer apply (rule corres_guard_imp) apply (subst case_option_If)+ - apply (rule corres_if3) + apply (rule corres_if2) apply (simp add: fault_rel_optionation_def) apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) apply (simp add: dc_def[symmetric]) @@ -1698,32 +1709,51 @@ lemma doIPCTransfer_corres: apply (wp|simp add: obj_at_def is_tcb valid_pspace'_def)+ done + crunch doIPCTransfer for ifunsafe[wp]: "if_unsafe_then_cap'" - and iflive[wp]: "if_live_then_nonz_cap'" - and sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - and vq[wp]: "valid_queues" - and vq'[wp]: "valid_queues'" - and state_refs_of[wp]: "\s. P (state_refs_of' s)" - and ct[wp]: "cur_tcb'" - and idle'[wp]: "valid_idle'" - 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 irq_node'[wp]: "\s. P (irq_node' s)" - and valid_arch_state'[wp]: "valid_arch_state'" - and vrq[wp]: valid_release_queue - (wp: crunch_wps - simp: zipWithM_x_mapM ball_conj_distrib) + (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots + simp: zipWithM_x_mapM ball_conj_distrib ) +crunch doIPCTransfer + for iflive[wp]: "if_live_then_nonz_cap'" + (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' ignore: transferCapsToSlots + simp: zipWithM_x_mapM ball_conj_distrib ) +lemma valid_pspace_valid_objs'[elim!]: + "valid_pspace' s \ valid_objs' s" + by (simp add: valid_pspace'_def) +crunch doIPCTransfer + for vp[wp]: "valid_pspace'" + (wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' wp: transferCapsToSlots_vp simp:ball_conj_distrib ) +crunch doIPCTransfer + for sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" + (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) +crunch doIPCTransfer + for state_refs_of[wp]: "\s. P (state_refs_of' s)" + (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) +crunch doIPCTransfer + for ct[wp]: "cur_tcb'" + (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) +crunch doIPCTransfer + for idle'[wp]: "valid_idle'" + (wp: crunch_wps get_rs_cte_at' ignore: transferCapsToSlots simp: zipWithM_x_mapM) -end +crunch doIPCTransfer + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps simp: zipWithM_x_mapM) +lemmas dit'_typ_ats[wp] = typ_at_lifts [OF doIPCTransfer_typ_at'] -global_interpretation doIPCTransfer: typ_at_all_props' "doIPCTransfer s e b g r" - by typ_at_props' +crunch doIPCTransfer + for irq_node'[wp]: "\s. P (irq_node' s)" + (wp: crunch_wps simp: crunch_simps) -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas dit_irq_node'[wp] + = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] -lemmas dit_irq_node'[wp] = valid_irq_node_lift [OF doIPCTransfer_irq_node' doIPCTransfer_typ_at'] +crunch doIPCTransfer + for valid_arch_state'[wp]: "valid_arch_state'" + (wp: crunch_wps simp: crunch_simps) +(* Levity: added (20090126 19:32:26) *) declare asUser_global_refs' [wp] lemma lec_valid_cap' [wp]: @@ -1733,22 +1763,42 @@ lemma lec_valid_cap' [wp]: apply (rule lookupExtraCaps_srcs) apply wp apply (clarsimp simp: cte_wp_at_ctes_of) - apply (fastforce) + apply (fastforce elim: ctes_of_valid') apply simp done -declare asUser_irq_handlers'[wp] - crunch doIPCTransfer for objs'[wp]: "valid_objs'" - and global_refs'[wp]: "valid_global_refs'" - and irq_handlers'[wp]: "valid_irq_handlers'" - and irq_states'[wp]: "valid_irq_states'" - and pde_mappings'[wp]: "valid_pde_mappings'" - and irqs_masked'[wp]: "irqs_masked'" - (wp: crunch_wps hoare_vcg_const_Ball_lift - simp: zipWithM_x_mapM ball_conj_distrib - rule: irqs_masked_lift) + ( wp: crunch_wps hoare_vcg_const_Ball_lift + transferCapsToSlots_valid_objs + simp: zipWithM_x_mapM ball_conj_distrib ) + +crunch doIPCTransfer + for global_refs'[wp]: "valid_global_refs'" + (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_global_refsT + transferCapsToSlots_valid_globals + simp: zipWithM_x_mapM ball_conj_distrib) + +declare asUser_irq_handlers' [wp] + +crunch doIPCTransfer + for irq_handlers'[wp]: "valid_irq_handlers'" + (wp: crunch_wps hoare_vcg_const_Ball_lift threadSet_irq_handlers' + transferCapsToSlots_irq_handlers + simp: zipWithM_x_mapM ball_conj_distrib ) + +crunch doIPCTransfer + for irq_states'[wp]: "valid_irq_states'" + (wp: crunch_wps no_irq no_irq_mapM no_irq_storeWord no_irq_loadWord + no_irq_case_option simp: crunch_simps zipWithM_x_mapM) + +crunch doIPCTransfer + for pde_mappings'[wp]: "valid_pde_mappings'" + (wp: crunch_wps simp: crunch_simps) + +crunch doIPCTransfer + for irqs_masked'[wp]: "irqs_masked'" + (wp: crunch_wps simp: crunch_simps rule: irqs_masked_lift) lemma doIPCTransfer_invs[wp]: "\invs' and tcb_at' s and tcb_at' r\ @@ -1758,6 +1808,11 @@ lemma doIPCTransfer_invs[wp]: apply (wpsimp wp: hoare_drop_imp) done +crunch doIPCTransfer + for nosch[wp]: "\s. P (ksSchedulerAction s)" + (wp: hoare_drop_imps hoare_vcg_split_case_option mapM_wp' + simp: split_def zipWithM_x_mapM) + lemma handle_fault_reply_registers_corres: "corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ (do t' \ arch_get_sanitise_register_info t; @@ -1788,46 +1843,71 @@ lemma handle_fault_reply_registers_corres: lemma handleFaultReply_corres: "ft' = fault_map ft \ - corres (=) (tcb_at t) (tcb_at' t) - (handle_fault_reply ft t label msg) - (handleFaultReply ft' t label msg)" - apply (cases ft; simp add: handleFaultReply_def handle_arch_fault_reply_def - handleArchFaultReply_def syscallMessage_def exceptionMessage_def - split: arch_fault.split) - by (rule handle_fault_reply_registers_corres)+ + corres (=) (tcb_at t and pspace_aligned and pspace_distinct) \ + (handle_fault_reply ft t label msg) + (handleFaultReply ft' t label msg)" + apply (cases ft) + apply(simp_all add: handleFaultReply_def + handle_arch_fault_reply_def handleArchFaultReply_def + syscallMessage_def exceptionMessage_def + split: arch_fault.split) + by (rule handle_fault_reply_registers_corres)+ crunch handleFaultReply for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - and ct'[wp]: "\s. P (ksCurThread s)" - and nosch[wp]: "\s. P (ksSchedulerAction s)" -end +lemmas hfr_typ_ats[wp] = typ_at_lifts [OF handleFaultReply_typ_at'] -global_interpretation handleFaultReply: typ_at_all_props' "handleFaultReply x t l m" - by typ_at_props' +crunch handleFaultReply + for ct'[wp]: "\s. P (ksCurThread s)" lemma doIPCTransfer_sch_act_simple [wp]: "\sch_act_simple\ doIPCTransfer sender endpoint badge grant receiver \\_. sch_act_simple\" by (simp add: sch_act_simple_def, wp) +lemma possibleSwitchTo_invs'[wp]: + "\invs' and st_tcb_at' runnable' t + and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ + possibleSwitchTo t \\_. invs'\" + apply (simp add: possibleSwitchTo_def curDomain_def) + apply (wp tcbSchedEnqueue_invs' ssa_invs') + apply (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt]) + apply (wpsimp wp: ssa_invs' threadGet_wp)+ + apply (clarsimp dest!: obj_at_ko_at' simp: tcb_in_cur_domain'_def obj_at'_def) + done + crunch isFinalCapability - for cur' [wp]: "\s. P (cur_tcb' s)" + for cur'[wp]: "\s. P (cur_tcb' s)" (simp: crunch_simps unless_when - wp: crunch_wps getObject_inv) + wp: crunch_wps getObject_inv loadObject_default_inv) + +crunch deleteCallerCap + for ct'[wp]: "\s. P (ksCurThread s)" + (simp: crunch_simps unless_when + wp: crunch_wps getObject_inv loadObject_default_inv) + +lemma getThreadCallerSlot_inv: + "\P\ getThreadCallerSlot t \\_. P\" + by (simp add: getThreadCallerSlot_def, wp) + +crunch unbindNotification + for tcb_at'[wp]: "tcb_at' x" lemma finaliseCapTrue_standin_tcb_at' [wp]: "\tcb_at' x\ finaliseCapTrue_standin cap v2 \\_. tcb_at' x\" - by (rule finaliseCapTrue_standin_tcbDomain_obj_at') - -crunch finaliseCapTrue_standin - for ct'[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps simp: crunch_simps) + apply (simp add: finaliseCapTrue_standin_def Let_def) + apply (safe) + apply (wp getObject_ntfn_inv + | wpc + | simp)+ + done lemma finaliseCapTrue_standin_cur': "\\s. cur_tcb' s\ finaliseCapTrue_standin cap v2 \\_ s'. cur_tcb' s'\" - unfolding cur_tcb'_def - by (wp_pre, wps, wp, assumption) + apply (simp add: cur_tcb'_def) + apply (rule hoare_lift_Pf2 [OF _ finaliseCapTrue_standin_ct']) + apply (wp) + done lemma cteDeleteOne_cur' [wp]: "\\s. cur_tcb' s\ cteDeleteOne slot \\_ s'. cur_tcb' s'\" @@ -1843,12 +1923,89 @@ lemma handleFaultReply_cur' [wp]: apply (wp) done -lemma replyRemove_valid_objs'[wp]: - "replyRemove replyPtr tcbPtr \valid_objs'\" - unfolding replyRemove_def - by (wpsimp wp: updateReply_valid_objs' replyUnlink_valid_objs' - hoare_vcg_if_lift hoare_drop_imps - simp: valid_reply'_def split_del: if_split) +lemma capClass_Reply: + "capClass cap = ReplyClass tcb \ isReplyCap cap \ capTCBPtr cap = tcb" + apply (cases cap, simp_all add: isCap_simps) + apply (rename_tac arch_capability) + apply (case_tac arch_capability, simp_all) + done + +lemma reply_cap_end_mdb_chain: + "\ cte_wp_at (is_reply_cap_to t) slot s; invs s; + invs' s'; + (s, s') \ state_relation; ctes_of s' (cte_map slot) = Some cte \ + \ (mdbPrev (cteMDBNode cte) \ nullPointer + \ mdbNext (cteMDBNode cte) = nullPointer) + \ cte_wp_at' (\cte. isReplyCap (cteCap cte) \ capReplyMaster (cteCap cte)) + (mdbPrev (cteMDBNode cte)) s'" + apply (clarsimp simp only: cte_wp_at_reply_cap_to_ex_rights) + apply (frule(1) pspace_relation_ctes_ofI[OF state_relation_pspace_relation], + clarsimp+) + apply (subgoal_tac "\slot' rights'. caps_of_state s slot' = Some (cap.ReplyCap t True rights') + \ descendants_of slot' (cdt s) = {slot}") + apply (elim state_relationE exE) + apply (clarsimp simp: cdt_relation_def + simp del: split_paired_All) + apply (drule spec, drule(1) mp[OF _ caps_of_state_cte_at]) + apply (frule(1) pspace_relation_cte_wp_at[OF _ caps_of_state_cteD], + clarsimp+) + apply (clarsimp simp: descendants_of'_def cte_wp_at_ctes_of) + apply (frule_tac f="\S. cte_map slot \ S" in arg_cong, simp(no_asm_use)) + apply (frule invs_mdb'[unfolded valid_mdb'_def]) + apply (rule context_conjI) + apply (clarsimp simp: nullPointer_def valid_mdb_ctes_def) + apply (erule(4) subtree_prev_0) + apply (rule conjI) + apply (rule ccontr) + apply (frule valid_mdb_no_loops, simp add: no_loops_def) + apply (drule_tac x="cte_map slot" in spec) + apply (erule notE, rule r_into_trancl, rule ccontr) + apply (clarsimp simp: mdb_next_unfold valid_mdb_ctes_def nullPointer_def) + apply (rule valid_dlistEn, assumption+) + apply (subgoal_tac "ctes_of s' \ cte_map slot \ mdbNext (cteMDBNode cte)") + apply (frule(3) class_linksD) + apply (clarsimp simp: isCap_simps dest!: capClass_Reply[OF sym]) + apply (drule_tac f="\S. mdbNext (cteMDBNode cte) \ S" in arg_cong) + apply (simp, erule notE, rule subtree.trans_parent, assumption+) + apply (case_tac ctea, case_tac cte') + apply (clarsimp simp add: parentOf_def isMDBParentOf_CTE) + apply (simp add: sameRegionAs_def2 isCap_simps) + apply (erule subtree.cases) + apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) + apply (clarsimp simp: parentOf_def isMDBParentOf_CTE) + apply (simp add: mdb_next_unfold) + apply (erule subtree.cases) + apply (clarsimp simp: valid_mdb_ctes_def) + apply (erule_tac cte=ctea in valid_dlistEn, assumption) + apply (simp add: mdb_next_unfold) + apply (clarsimp simp: mdb_next_unfold isCap_simps) + apply (drule_tac f="\S. c' \ S" in arg_cong) + apply (clarsimp simp: no_loops_direct_simp valid_mdb_no_loops) + apply (frule invs_mdb) + apply (drule invs_valid_reply_caps) + apply (clarsimp simp: valid_mdb_def reply_mdb_def + valid_reply_caps_def reply_caps_mdb_def + cte_wp_at_caps_of_state + simp del: split_paired_All) + + apply (erule_tac x=slot in allE, erule_tac x=t in allE, erule impE, fast) + apply (elim exEI) + apply clarsimp + apply (subgoal_tac "P" for P, rule sym, rule equalityI, assumption) + apply clarsimp + apply (erule(4) unique_reply_capsD) + apply (simp add: descendants_of_def) + apply (rule r_into_trancl) + apply (simp add: cdt_parent_rel_def is_cdt_parent_def) + done + +crunch cteDeleteOne + for valid_objs'[wp]: "valid_objs'" + (simp: crunch_simps unless_def + wp: crunch_wps getObject_inv loadObject_default_inv) + +crunch handleFaultReply + for nosch[wp]: "\s. P (ksSchedulerAction s)" lemma emptySlot_weak_sch_act[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ @@ -1872,340 +2029,333 @@ lemma cancelAllSignals_weak_sch_act_wf[wp]: apply (wp rescheduleRequired_weak_sch_act_wf hoare_drop_imp | wpc | simp)+ done -lemma setSchedContext_weak_sch_act_wf: - "setSchedContext p sc \ \s. weak_sch_act_wf (ksSchedulerAction s) s \" - apply (wp weak_sch_act_wf_lift) - done - -lemma setReply_weak_sch_act_wf: - "setReply p r \ \s. weak_sch_act_wf (ksSchedulerAction s) s \" - apply (wp weak_sch_act_wf_lift) - done - -crunch replyUnlink - for nosch[wp]: "\s. P (ksSchedulerAction s)" - (simp: crunch_simps wp: crunch_wps) - -crunch unbindMaybeNotification, schedContextMaybeUnbindNtfn, isFinalCapability, - cleanReply - for sch_act_not[wp]: "sch_act_not t" - (wp: crunch_wps simp: crunch_simps) - -crunch replyRemove, replyRemoveTCB +crunch finaliseCapTrue_standin for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (simp: crunch_simps wp: crunch_wps) - -lemma cancelSignal_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ sch_act_not threadPtr s\ - cancelSignal threadPtr ntfnPtr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - unfolding cancelSignal_def Let_def - by (wpsimp wp: gts_wp' | wp (once) hoare_drop_imp)+ + (ignore: setThreadState + simp: crunch_simps + wp: crunch_wps getObject_inv loadObject_default_inv) -lemma cancelIPC_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ sch_act_not tptr s\ - cancelIPC tptr - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - unfolding cancelIPC_def blockedCancelIPC_def Let_def getBlockingObject_def - apply (wpsimp wp: gts_wp' threadSet_weak_sch_act_wf hoare_vcg_all_lift - | wp (once) hoare_drop_imps)+ - done - -lemma replyClear_weak_sch_act_wf[wp]: +lemma cteDeleteOne_weak_sch_act[wp]: "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ - replyClear rptr tptr + cteDeleteOne sl \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - unfolding replyClear_def - apply (wpsimp wp: gts_wp' simp: pred_tcb_at'_eq_commute) - apply (auto simp: pred_tcb_at'_def obj_at'_def weak_sch_act_wf_def) + apply (simp add: cteDeleteOne_def unless_def) + apply (wp hoare_drop_imps finaliseCapTrue_standin_cur' isFinalCapability_cur' + | simp add: split_def)+ done +crunch emptySlot + for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" + crunch handleFaultReply for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" crunch handleFaultReply for tcb_in_cur_domain'[wp]: "tcb_in_cur_domain' t" -context begin interpretation Arch . (*FIXME: arch_split*) - -crunch handleFaultReply - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - and valid_queues[wp]: "Invariants_H.valid_queues" - and valid_queues'[wp]: "valid_queues'" - 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') +(wp: sbn_sch_act') -lemma possibleSwitchTo_valid_queues[wp]: - "\Invariants_H.valid_queues and valid_objs' and - (\s. sch_act_wf (ksSchedulerAction s) s) and st_tcb_at' runnable' t\ - possibleSwitchTo t - \\rv. Invariants_H.valid_queues\" - by (wpsimp wp: hoare_drop_imps hoare_vcg_if_lift2 - simp: inReleaseQueue_def possibleSwitchTo_def curDomain_def bitmap_fun_defs) - -lemma cancelAllIPC_valid_queues': - "cancelAllIPC t \ valid_queues' \" - apply (clarsimp simp: cancelAllIPC_def) - apply (wpsimp wp: mapM_x_wp' get_ep_inv' getEndpoint_wp) - done +crunch handleFaultReply + for valid_objs'[wp]: valid_objs' -lemma cancelAllSignals_valid_queues': - "cancelAllSignals t \ valid_queues' \" - apply (clarsimp simp: cancelAllSignals_def) - apply (wpsimp wp: mapM_x_wp' getNotification_wp) - done +lemma cte_wp_at_is_reply_cap_toI: + "cte_wp_at ((=) (cap.ReplyCap t False rights)) ptr s + \ cte_wp_at (is_reply_cap_to t) ptr s" + by (fastforce simp: cte_wp_at_reply_cap_to_ex_rights) -crunch cteDeleteOne - for valid_queues'[wp]: valid_queues' - (simp: crunch_simps inQ_def - wp: crunch_wps sts_st_tcb' getObject_inv threadSet_valid_queues') +crunch handle_fault_reply + for pspace_alignedp[wp]: pspace_aligned + and pspace_distinct[wp]: pspace_distinct -crunch handleFaultReply - for valid_objs'[wp]: valid_objs' +crunch cteDeleteOne, doIPCTransfer, handleFaultReply + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and pspace_aligned'[wp]: pspace_aligned' + and pspace_distinct'[wp]: pspace_distinct' + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) -lemma bind_sc_reply_weak_valid_sched_action[wp]: - "bind_sc_reply a b \weak_valid_sched_action\" - unfolding bind_sc_reply_def by wpsimp - -lemma bind_sc_reply_invs[wp]: - "\ \s. invs s - \ reply_at reply_ptr s - \ sc_at sc_ptr s - \ ex_nonz_cap_to reply_ptr s - \ ex_nonz_cap_to sc_ptr s - \ reply_sc_reply_at (\sc_ptr'. sc_ptr' = None) reply_ptr s - \ reply_ptr \ fst ` replies_blocked s - \ reply_ptr \ fst ` replies_with_sc s \ - bind_sc_reply sc_ptr reply_ptr - \ \rv. invs \" - unfolding bind_sc_reply_def - supply if_weak_cong[cong del] if_split[split del] - apply (rule bind_wp[OF _ gscrpls_sp]) - apply (rename_tac sc_replies') - apply (case_tac sc_replies'; simp) - apply (wpsimp wp: sched_context_donate_invs) - apply (wpsimp simp: invs_def valid_state_def valid_pspace_def - wp: valid_irq_node_typ set_reply_sc_valid_replies_already_BlockedOnReply - valid_ioports_lift) - apply (wpsimp wp: set_sc_replies_valid_replies update_sched_context_valid_idle) +lemma doReplyTransfer_corres: + "corres dc + (einvs and tcb_at receiver and tcb_at sender + and cte_wp_at ((=) (cap.ReplyCap receiver False rights)) slot) + (invs' and tcb_at' sender and tcb_at' receiver + and valid_pspace' and cte_at' (cte_map slot)) + (do_reply_transfer sender receiver slot grant) + (doReplyTransfer sender receiver (cte_map slot) grant)" + apply (simp add: do_reply_transfer_def doReplyTransfer_def cong: option.case_cong) + apply (rule corres_underlying_split [OF _ _ gts_sp gts_sp']) + apply (rule corres_guard_imp) + apply (rule getThreadState_corres, (clarsimp simp add: st_tcb_at_tcb_at invs_distinct invs_psp_aligned)+) + apply (rule_tac F = "awaiting_reply state" in corres_req) + apply (clarsimp simp add: st_tcb_at_def obj_at_def is_tcb) + apply (fastforce simp: invs_def valid_state_def intro: has_reply_cap_cte_wpD + dest: has_reply_cap_cte_wpD + dest!: valid_reply_caps_awaiting_reply cte_wp_at_is_reply_cap_toI) + apply (case_tac state, simp_all add: bind_assoc) + apply (simp add: isReply_def liftM_def) + apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) + apply (rule no_fail_pre, wp) apply clarsimp - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def - reply_sc_reply_at_def obj_at_def state_refs_of_def get_refs_def2 - sc_replies_sc_at_def pred_tcb_at_def is_tcb is_reply is_sc_obj_def - split: if_splits - elim!: delta_sym_refs) - apply safe - apply fastforce - apply fastforce - apply (clarsimp simp: valid_idle_def) - apply (rule replies_with_sc_upd_replies_new_valid_replies) - apply fastforce - apply (clarsimp simp: image_def) - apply (rule_tac x="(reply_ptr, b)" in bexI; fastforce) - apply (clarsimp simp: image_def) - apply (fastforce simp: invs_def valid_state_def valid_pspace_def - reply_sc_reply_at_def obj_at_def state_refs_of_def get_refs_def2 - sc_replies_sc_at_def pred_tcb_at_def is_tcb is_reply is_sc_obj_def - split: if_splits - elim!: delta_sym_refs) - apply (clarsimp simp: idle_sc_no_ex_cap) - apply wpsimp - apply (wpsimp simp: invs_def valid_state_def valid_pspace_def - wp: valid_irq_node_typ set_reply_sc_valid_replies_already_BlockedOnReply - valid_ioports_lift valid_sc_typ_list_all_reply) - apply (wpsimp wp: set_sc_replies_valid_replies update_sched_context_valid_idle) - apply (wpsimp simp: get_simple_ko_def get_object_def - wp: valid_sc_typ_list_all_reply valid_ioports_lift) - apply (subgoal_tac "list_all (\r. reply_at r s) (a # list) \ reply_ptr \ set (a # list) \ distinct (a # list)") - apply (clarsimp simp: invs_def valid_pspace_def valid_state_def) - apply (intro conjI) - apply (rule replies_with_sc_upd_replies_valid_replies_add_one, simp) - apply (clarsimp simp:replies_blocked_def image_def, fastforce) - apply simp - apply (clarsimp simp:sc_replies_sc_at_def obj_at_def) - apply (erule delta_sym_refs) - apply (clarsimp split: if_splits - elim!: delta_sym_refs) - apply (clarsimp simp: reply_sc_reply_at_def obj_at_def state_refs_of_def get_refs_def2 - pred_tcb_at_def is_tcb is_reply is_sc_obj sc_at_pred_n_def - split: if_splits - elim!: delta_sym_refs) - apply (safe; clarsimp?) - apply (rename_tac rp1 tl s tptr scp sc r1 r2 n1) - apply (subgoal_tac "(rp1,scp) \ replies_with_sc s \ (rp1,sc_ptr) \ replies_with_sc s") - apply (clarsimp dest!: valid_replies_2_inj_onD ) - apply (intro conjI) - apply (subgoal_tac "valid_reply r1 s") - apply (clarsimp simp: valid_reply_def refs_of_def obj_at_def is_sc_obj_def - split: option.splits) - apply (rename_tac ko n2) - apply (case_tac ko; clarsimp simp: get_refs_def) - apply (erule disjE, clarsimp split: option.splits)+ - apply (clarsimp simp: replies_with_sc_def sc_replies_sc_at_def obj_at_def split: option.splits) - apply (erule valid_objs_valid_reply, assumption) - apply(clarsimp simp: replies_with_sc_def sc_replies_sc_at_def obj_at_def) - apply (metis cons_set_intro) - apply (fastforce simp: idle_sc_no_ex_cap tcb_at_def is_tcb_def - dest: pred_tcb_at_tcb_at get_tcb_SomeD) - apply (clarsimp simp del: distinct.simps list.pred_inject insert_iff) - apply (frule sc_replies_sc_at_subset_fst_replies_with_sc) - apply (frule invs_valid_objs) - apply (intro conjI) - apply (erule replies_blocked_list_all_reply_at) - apply (meson dual_order.trans invs_valid_replies valid_replies_defs(1)) - apply fastforce - apply (erule (1) valid_objs_sc_replies_distinct) - done - -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 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 (\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 - else state_refs_of s p)) - and valid_idle) - (valid_release_queue_iff and valid_objs' and valid_queues and valid_queues' - and valid_replies'_sc_asrt reply_ptr) - (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]) - apply (clarsimp simp: valid_idle'_asrt_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 (rename_tac mdbnode) + apply (rule_tac P="Q" and Q="Q" and P'="Q'" and Q'="(\s. Q' s \ R' s)" for Q Q' R' + in stronger_corres_guard_imp[rotated]) + apply assumption + apply (rule conjI, assumption) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (drule cte_wp_at_is_reply_cap_toI) + apply (erule(4) reply_cap_end_mdb_chain) + apply (rule corres_assert_assume[rotated], simp) + apply (simp add: getSlotCap_def) + apply (rule corres_symb_exec_r[OF _ getCTE_sp getCTE_inv, rotated]) + apply (rule no_fail_pre, wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (rule corres_assert_assume[rotated]) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (rule corres_guard_imp) + apply (rule corres_split[OF threadget_fault_corres]) + apply (case_tac rv, simp_all add: fault_rel_optionation_def bind_assoc)[1] + apply (rule corres_split[OF doIPCTransfer_corres]) + apply (rule corres_split[OF cap_delete_one_corres]) + apply (rule corres_split[OF setThreadState_corres]) apply simp - apply (rule corres_when2, clarsimp) - apply (rule corres_split [OF bindScReply_corres schedContextDonate_corres]) - apply (wpsimp wp: sc_at_typ_at) - apply wpsimp - 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 possibleSwitchTo_corres) + apply (wp set_thread_state_runnable_valid_sched + set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' sts_st_tcb' + sts_valid_objs' delete_one_tcbDomain_obj_at' + | simp add: valid_tcb_state'_def + | strengthen valid_queues_in_correct_ready_q valid_sched_valid_queues + valid_queues_ready_qs_distinct)+ + apply (strengthen cte_wp_at_reply_cap_can_fast_finalise) + apply (wp hoare_vcg_conj_lift) + apply (rule hoare_strengthen_post [OF do_ipc_transfer_non_null_cte_wp_at]) + prefer 2 + apply (erule cte_wp_at_weakenE) + apply (fastforce) + apply (clarsimp simp:is_cap_simps) + apply (wp weak_valid_sched_action_lift)+ + apply (rule_tac Q'="\_ s. valid_objs' s \ cur_tcb' s \ tcb_at' receiver s + \ sch_act_wf (ksSchedulerAction s) s + \ sym_heap_sched_pointers s \ valid_sched_pointers s + \ pspace_aligned' s \ pspace_distinct' s" + in hoare_post_imp, simp add: sch_act_wf_weak) + apply (wp tcb_in_cur_domain'_lift) + defer + apply (simp) + apply (wp)+ + apply (clarsimp simp: invs_psp_aligned invs_distinct) + apply (rule conjI, erule invs_valid_objs) + apply (rule conjI, clarsimp)+ + apply (rule conjI) + apply (erule cte_wp_at_weakenE) + apply (clarsimp) + apply (rule conjI, rule refl) + apply (fastforce) + apply (clarsimp simp: invs_def valid_sched_def valid_sched_action_def) + apply (simp) + apply (auto simp: invs'_def valid_state'_def)[1] + + apply (rule corres_guard_imp) + apply (rule corres_split[OF cap_delete_one_corres]) + apply (rule corres_split_mapr[OF getMessageInfo_corres]) + apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) + apply (rule corres_split_eqr[OF getMRs_corres]) + apply (simp(no_asm) del: dc_simp) + apply (rule corres_split_eqr[OF handleFaultReply_corres]) + apply simp + apply (rule corres_split) + apply (rule threadset_corresT; + clarsimp simp add: tcb_relation_def fault_rel_optionation_def + tcb_cap_cases_def tcb_cte_cases_def exst_same_def) + apply (rule_tac Q="valid_sched and cur_tcb and tcb_at receiver and pspace_aligned and pspace_distinct" + and Q'="tcb_at' receiver and cur_tcb' + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' + and sym_heap_sched_pointers and valid_sched_pointers + and pspace_aligned' and pspace_distinct'" + in corres_guard_imp) + apply (case_tac rvb, simp_all)[1] + apply (rule corres_guard_imp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (fold dc_def, rule possibleSwitchTo_corres) + apply simp + apply (wp hoare_weak_lift_imp hoare_weak_lift_imp_conj set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' + sts_st_tcb' sts_valid_objs' + | force simp: valid_sched_def valid_sched_action_def valid_tcb_state'_def)+ + apply (rule corres_guard_imp) + apply (rule setThreadState_corres) + apply clarsimp+ + apply (wp threadSet_cur weak_sch_act_wf_lift_linear threadSet_pred_tcb_no_state + thread_set_not_state_valid_sched + threadSet_tcbDomain_triv threadSet_valid_objs' + threadSet_sched_pointers threadSet_valid_sched_pointers + | simp add: valid_tcb_state'_def)+ + apply (rule_tac Q'="\_. valid_sched and cur_tcb and tcb_at sender and tcb_at receiver and + valid_objs and pspace_aligned and pspace_distinct" + in hoare_strengthen_post [rotated], clarsimp) + apply (wp) + apply (rule hoare_chain [OF cap_delete_one_invs]) + apply (assumption) + apply (rule conjI, clarsimp) + apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def) + apply (rule_tac Q'="\_. tcb_at' sender and tcb_at' receiver and invs'" + in hoare_strengthen_post [rotated]) + apply (solves\auto simp: invs'_def valid_state'_def\) + apply wp apply clarsimp - apply (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 _ tcb_at'_cross_rel[where t=callee]], 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 (rule conjI) + apply (erule cte_wp_at_weakenE) + apply (clarsimp simp add: can_fast_finalise_def) + apply (erule(1) emptyable_cte_wp_atD) + apply (rule allI, rule impI) + apply (clarsimp simp add: is_master_reply_cap_def) + apply (clarsimp) done -crunch handle_fault_reply - for pspace_aligned[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - -lemma setReleaseQueue_corres: - "corres dc \ (\s. g (ksReleaseQueue s) = qs) - (modify (release_queue_update g)) - (setReleaseQueue qs)" - unfolding setReleaseQueue_def - apply (rule corres_modify) - by (auto simp: state_relation_def release_queue_relation_def cdt_relation_def) - -lemma threadSet_valid_release_queue_inv: - "\obj. tcbInReleaseQueue (f obj) = tcbInReleaseQueue obj \ - threadSet f t \valid_release_queue\" - by (wpsimp wp: threadSet_valid_release_queue) - -lemma threadSet_valid_release_queue'_inv: - "\obj. tcbInReleaseQueue (f obj) = tcbInReleaseQueue obj \ - threadSet f t \valid_release_queue'\" - apply (wpsimp wp: threadSet_valid_release_queue') - by (auto simp: valid_release_queue'_def obj_at'_def) - -crunch handleFaultReply, doIPCTransfer - for valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - (wp: crunch_wps threadSet_valid_release_queue_inv threadSet_valid_release_queue'_inv - ignore: threadSet - simp: crunch_simps) - -lemma refillReady_sp: - "\P\ - refillReady scp - \\rv s. P s \ (\ko. ko_at' ko scp s \ rv = (rTime (refillHd ko) \ ksCurTime s + kernelWCETTicks))\" - apply (wpsimp wp: refillReady_wp) - by fastforce - -lemma refillSufficient_sp: - "\P\ - refillSufficient scp k - \\rv s. P s \ (\ko. ko_at' ko scp s \ rv = (sufficientRefills k (scRefills ko) (scRefillHead ko)))\" - unfolding refillSufficient_def getRefills_def - apply wpsimp - by (clarsimp simp: sufficientRefills_def obj_at'_def) - -lemma isValidTimeoutHandler_sp: - "\P\ - isValidTimeoutHandler x - \\rv s. P s \ (\ko. ko_at' ko x s \ rv = (is_EndpointCap (cteCap (tcbTimeoutHandler ko))))\" - unfolding isValidTimeoutHandler_def - apply (wpsimp wp: getTCB_wp) - by (auto simp: is_EndpointCap_def) +(* when we cannot talk about reply cap rights explicitly (for instance, when a schematic ?rights + would be generated too early *) +lemma doReplyTransfer_corres': + "corres dc + (einvs and tcb_at receiver and tcb_at sender + and cte_wp_at (is_reply_cap_to receiver) slot) + (invs' and tcb_at' sender and tcb_at' receiver + and valid_pspace' and cte_at' (cte_map slot)) + (do_reply_transfer sender receiver slot grant) + (doReplyTransfer sender receiver (cte_map slot) grant)" + using doReplyTransfer_corres[of receiver sender _ slot] + by (fastforce simp add: cte_wp_at_reply_cap_to_ex_rights corres_underlying_def) + +lemma valid_pspace'_splits[elim!]: + "valid_pspace' s \ valid_objs' s" + "valid_pspace' s \ pspace_aligned' s" + "valid_pspace' s \ pspace_distinct' s" + "valid_pspace' s \ valid_mdb' s" + "valid_pspace' s \ no_0_obj' s" + by (simp add: valid_pspace'_def)+ + +lemma sts_valid_pspace_hangers: + "\valid_pspace' and tcb_at' t and + valid_tcb_state' st\ setThreadState st t \\rv. valid_objs'\" + "\valid_pspace' and tcb_at' t and + valid_tcb_state' st\ setThreadState st t \\rv. pspace_distinct'\" + "\valid_pspace' and tcb_at' t and + valid_tcb_state' st\ setThreadState st t \\rv. pspace_aligned'\" + "\valid_pspace' and tcb_at' t and + valid_tcb_state' st\ setThreadState st t \\rv. valid_mdb'\" + "\valid_pspace' and tcb_at' t and + valid_tcb_state' st\ setThreadState st t \\rv. no_0_obj'\" + by (safe intro!: hoare_strengthen_post [OF sts'_valid_pspace'_inv]) declare no_fail_getSlotCap [wp] +lemma setupCallerCap_corres: + "corres dc + (st_tcb_at (Not \ halted) sender and tcb_at receiver and + st_tcb_at (Not \ awaiting_reply) sender and valid_reply_caps and + valid_objs and pspace_distinct and pspace_aligned and valid_mdb + and valid_list and + valid_reply_masters and cte_wp_at (\c. c = cap.NullCap) (receiver, tcb_cnode_index 3)) + (tcb_at' sender and tcb_at' receiver and valid_pspace' + and (\s. weak_sch_act_wf (ksSchedulerAction s) s)) + (setup_caller_cap sender receiver grant) + (setupCallerCap sender receiver grant)" + supply if_split[split del] + apply (simp add: setup_caller_cap_def setupCallerCap_def + getThreadReplySlot_def locateSlot_conv + getThreadCallerSlot_def) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split_nor) + apply (rule setThreadState_corres) + apply (simp split: option.split) + apply (rule corres_symb_exec_r) + apply (rule_tac F="\r. cteCap masterCTE = capability.ReplyCap sender True r + \ mdbNext (cteMDBNode masterCTE) = nullPointer" + in corres_gen_asm2, clarsimp simp add: isCap_simps) + apply (rule corres_symb_exec_r) + apply (rule_tac F="rv = capability.NullCap" + in corres_gen_asm2, simp) + apply (rule cteInsert_corres) + apply (simp split: if_splits) + apply (simp add: cte_map_def tcbReplySlot_def + tcb_cnode_index_def cte_level_bits_def) + apply (simp add: cte_map_def tcbCallerSlot_def + tcb_cnode_index_def cte_level_bits_def) + apply (rule_tac Q'="\rv. cte_at' (receiver + 2 ^ cte_level_bits * tcbCallerSlot)" + in hoare_post_add) + + apply (wp, (wp getSlotCap_wp)+) + apply blast + apply (rule no_fail_pre, wp) + apply (clarsimp simp: cte_wp_at'_def cte_at'_def) + apply (rule_tac Q'="\rv. cte_at' (sender + 2 ^ cte_level_bits * tcbReplySlot)" + in hoare_post_add) + apply (wp, (wp getCTE_wp')+) + apply blast + apply (rule no_fail_pre, wp) + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (wp sts_valid_pspace_hangers + | simp add: cte_wp_at_ctes_of)+ + apply (clarsimp simp: valid_tcb_state_def st_tcb_at_reply_cap_valid + st_tcb_at_tcb_at st_tcb_at_caller_cap_null + split: option.split) + apply (clarsimp simp: valid_tcb_state'_def valid_cap'_def capAligned_reply_tcbI) + apply (frule(1) st_tcb_at_reply_cap_valid, simp, clarsimp) + apply (clarsimp simp: cte_wp_at_ctes_of cte_wp_at_caps_of_state) + apply (drule pspace_relation_cte_wp_at[rotated, OF caps_of_state_cteD], + erule valid_pspace'_splits, clarsimp+)+ + apply (clarsimp simp: cte_wp_at_ctes_of cte_map_def tcbReplySlot_def + tcbCallerSlot_def tcb_cnode_index_def + is_cap_simps) + apply (auto intro: reply_no_descendants_mdbNext_null[OF not_waiting_reply_slot_no_descendants] + simp: cte_index_repair) + done + +crunch getThreadCallerSlot + for tcb_at'[wp]: "tcb_at' t" + +lemma getThreadReplySlot_tcb_at'[wp]: + "\tcb_at' t\ getThreadReplySlot tcb \\_. tcb_at' t\" + by (simp add: getThreadReplySlot_def, wp) + +lemma setupCallerCap_tcb_at'[wp]: + "\tcb_at' t\ setupCallerCap sender receiver grant \\_. tcb_at' t\" + by (simp add: setupCallerCap_def, wp hoare_drop_imp) + +crunch setupCallerCap + for ct'[wp]: "\s. P (ksCurThread s)" + (wp: crunch_wps) + lemma cteInsert_sch_act_wf[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ cteInsert newCap srcSlot destSlot \\_ s. sch_act_wf (ksSchedulerAction s) s\" by (wp sch_act_wf_lift tcb_in_cur_domain'_lift) +lemma setupCallerCap_sch_act [wp]: + "\\s. sch_act_not t s \ sch_act_wf (ksSchedulerAction s) s\ + setupCallerCap t r g \\_ s. sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: setupCallerCap_def getSlotCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv) + apply (wp getCTE_wp' sts_sch_act' hoare_drop_imps hoare_vcg_all_lift) + apply clarsimp + done + +lemma possibleSwitchTo_weak_sch_act_wf[wp]: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ + possibleSwitchTo t \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: possibleSwitchTo_def setSchedulerAction_def threadGet_def curDomain_def + bitmap_fun_defs) + apply (wp rescheduleRequired_weak_sch_act_wf + weak_sch_act_wf_lift_linear[where f="tcbSchedEnqueue t"] + getObject_tcb_wp hoare_weak_lift_imp + | wpc)+ + apply (clarsimp simp: obj_at'_def projectKOs weak_sch_act_wf_def ps_clear_def tcb_in_cur_domain'_def) + done + +lemmas transferCapsToSlots_pred_tcb_at' = + transferCapsToSlots_pres1 [OF cteInsert_pred_tcb_at'] + crunch doIPCTransfer, possibleSwitchTo for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" (wp: mapM_wp' crunch_wps simp: zipWithM_x_mapM) @@ -2216,7 +2366,7 @@ lemma setSchedulerAction_ct_in_domain: \\_. ct_idle_or_in_cur_domain'\" by (simp add:setSchedulerAction_def | wp)+ -crunch doIPCTransfer, possibleSwitchTo +crunch setupCallerCap, doIPCTransfer, possibleSwitchTo for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" @@ -2226,1190 +2376,235 @@ crunch doIPCTransfer for tcbDomain_obj_at'[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" (wp: crunch_wps constOnFailure_wp simp: crunch_simps) -lemma tcbEPFindIndex_corres: - "corres (=) (tcb_at t and (\s. \t \ set list. tcb_at t s) and K (n < length list)) - (tcb_at' t and (\s. \t \ set list. tcb_at' t s)) - (tcb_ep_find_index t list n) (tcbEPFindIndex t list n)" - apply (rule corres_gen_asm') - apply (induct n) - apply (subst tcb_ep_find_index.simps) - apply (subst tcbEPFindIndex.simps) - apply (rule corres_split_eqr) - apply (rule threadGet_corres, simp add: tcb_relation_def) - apply (rule corres_split_eqr) - apply (rule threadGet_corres, simp add: tcb_relation_def) - apply (rule corres_if, simp) - apply (rule corres_trivial, simp) - apply (rule corres_trivial, simp) - apply wpsimp - apply wpsimp - apply wpsimp - apply wpsimp - apply (subst tcb_ep_find_index.simps) - apply (subst tcbEPFindIndex.simps) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr) - apply (rule threadGet_corres, simp add: tcb_relation_def) - apply (rule corres_split_eqr) - apply (rule threadGet_corres, simp add: tcb_relation_def) - apply (rule corres_if, simp) - apply (rule corres_if, simp) - apply (rule corres_trivial, simp) - apply simp - apply (rule corres_trivial, simp) - apply (wp thread_get_wp) - apply (wp threadGet_wp) - apply (wp thread_get_wp) - apply (wpsimp wp: threadGet_wp) - apply (fastforce simp: projectKO_eq projectKO_tcb obj_at'_def)+ - done - -(* The condition `reply_ptr \ fst ` replies_with_sc s` is provable in the presence of - sym_refs, but sym_refs may not hold at a call of reply_push. If we had sym_refs - for replies <-> scs only, then that would be enough and should be true at any call of - reply_push. *) -lemma reply_push_valid_objs: - "\valid_objs and valid_replies and - reply_tcb_reply_at (\tptr. tptr = None) reply_ptr and - (\s. reply_ptr \ fst ` replies_with_sc s)\ - reply_push caller callee reply_ptr can_donate - \\_. valid_objs\" - supply if_split [split del] - unfolding reply_push_def get_tcb_obj_ref_def - apply simp - apply (rule bind_wp[OF _ thread_get_sp]) - apply (rule bind_wp[OF _ thread_get_sp]) - apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift' hoare_vcg_disj_lift - get_tcb_obj_ref_wp) - apply (subgoal_tac "tcb_at caller s \ reply_at reply_ptr s", clarsimp) - apply (subgoal_tac "sc_at y s", clarsimp) - apply (subst sc_at_ppred_exm) - apply (clarsimp simp: obj_at_def valid_obj_def valid_tcb_def) - apply (clarsimp simp: replies_with_sc_def image_def obj_at_def is_sc_obj) - apply (frule obj_at_ko_at[where p = caller], clarsimp) - apply (drule (1) valid_objs_ko_at) - apply (clarsimp simp: obj_at_def valid_obj_def valid_tcb_def) - apply (clarsimp simp: obj_at_def is_tcb sk_obj_at_pred_def is_reply) - done - -lemma tcbEPAppend_corres: - "corres (=) (\s. tcb_at t s \ (\t \ set qs. tcb_at t s)) - (\s. tcb_at' t s \ (\t \ set qs. tcb_at' t s)) - (tcb_ep_append t qs) (tcbEPAppend t qs)" - apply (clarsimp simp: tcb_ep_append_def tcbEPAppend_def null_def split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_if; clarsimp?) - apply (rule_tac corres_split[OF tcbEPFindIndex_corres]) - apply wpsimp+ - done - -lemma tcbEPFindIndex_inv[wp]: - "tcbEPFindIndex t list n \P\" - apply (rule hoare_weaken_pre) - apply (induct n) - apply (subst tcbEPFindIndex.simps, wpsimp) - apply (subst tcbEPFindIndex.simps, wpsimp, assumption) - apply wpsimp+ - done - -crunch tcbEPAppend - for ep_at'[wp]: "ep_at' epptr" - -crunch bindScReply - for typ_at'[wp]: "\s. P (typ_at' T p s)" - (simp: crunch_simps) - -crunch replyPush - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - and pspace_bounded'[wp]: pspace_bounded' - 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 valid_release_queue'[wp]: "valid_release_queue'" - and ct_not_inQ[wp]: "ct_not_inQ" - and ct_idle_or_in_cur_domain'[wp]: "ct_idle_or_in_cur_domain'" - and valid_pde_mappings'[wp]: "valid_pde_mappings'" - 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" - and cte_wp_at'[wp]: "cte_wp_at' P p" - and ctes_of[wp]: "\s. P (ctes_of s)" - and vrq[wp]: valid_release_queue - and valid_queues'[wp]: valid_queues' - (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) - -lemma replyPush_valid_objs'[wp]: - "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' - hoare_vcg_if_lift2 threadGet_wp hoare_vcg_imp_lift') - apply (clarsimp simp: obj_at'_def projectKOs) - apply (intro conjI impI; (fastforce simp: obj_at'_def projectKOs valid_tcb_state'_def)?) - by (insert reply_ko_at_valid_objs_valid_reply'; - fastforce simp: valid_reply'_def obj_at'_def projectKOs valid_bound_obj'_def)+ - -lemma replyPush_valid_replies'[wp]: - "\valid_replies' and pspace_distinct' and pspace_aligned' and pspace_bounded' - and st_tcb_at' (Not \ is_replyState) callerPtr\ - 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 projectKOs) - done - -lemma replyPush_valid_queues[wp]: - "\valid_queues and valid_objs'\ - replyPush callerPtr calleePtr replyPtr canDonate - \\_. valid_queues\" - supply if_split [split del] - unfolding replyPush_def updateReply_def bind_assoc - apply (intro bind_wp[OF _ stateAssert_sp] | simp)+ - apply (rule bind_wp[OF _ threadGet_sp']) - apply (rule bind_wp[OF _ threadGet_sp']) - apply (rule bind_wp[OF _ get_reply_sp']) - apply (wpsimp wp: schedContextDonate_valid_queues - threadGet_wp hoare_vcg_if_lift2 hoare_vcg_imp_lift') - apply (clarsimp simp: ko_at_obj_at'[where P=\]) - apply (clarsimp simp: valid_reply'_def dest!: reply_ko_at_valid_objs_valid_reply') - done - -crunch reply_unlink_tcb - for sc_replies_sc_at[wp]: "\s. Q (sc_replies_sc_at P scp s)" - (wp: crunch_wps simp: crunch_simps ignore: refill_unblock_check) - -crunch if_cond_refill_unblock_check - for valid_sched_action[wp]: valid_sched_action - (wp: crunch_wps simp: crunch_simps) - -crunch doIPCTransfer - 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 possibleSwitchTo + for tcb_at'[wp]: "tcb_at' t" + and valid_pspace'[wp]: valid_pspace' + (wp: crunch_wps) lemma sendIPC_corres: -(* call is only true if called in handleSyscall SysCall, which is always blocking. *) +(* 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 current_time_bounded - 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)" + "corres dc (einvs and st_tcb_at active t and ep_at ep and ex_nonz_cap_to t) + (invs' and sch_act_not t and tcb_at' t and ep_at' ep) + (send_ipc bl call bg cg cgr t ep) (sendIPC bl call bg cg cgr t ep)" +proof - + show ?thesis apply (insert assms) - apply add_sym_refs - apply add_valid_idle' - apply add_cur_tcb' - apply (clarsimp simp: send_ipc_def sendIPC_def Let_def split del: if_split) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: sym_refs_asrt_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_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_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 cur_tcb' 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 (unfold send_ipc_def sendIPC_def Let_def) + apply (case_tac bl) + apply clarsimp + apply (rule corres_guard_imp) + apply (rule corres_split[OF getEndpoint_corres, + where + R="\rv. einvs and st_tcb_at active t and ep_at ep and + valid_ep rv and obj_at (\ob. ob = Endpoint rv) ep + and ex_nonz_cap_to t" + and + R'="\rv'. invs' and tcb_at' t and sch_act_not t + and ep_at' ep and valid_ep' rv'"]) + apply (case_tac rv) + apply (simp add: ep_relation_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setEndpoint_corres) + apply (simp add: ep_relation_def) + apply wp+ + apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) + apply clarsimp + \ \concludes IdleEP if bl branch\ + apply (simp add: ep_relation_def) apply (rule corres_guard_imp) - apply (rule corres_split [OF setThreadState_corres setEndpoint_corres]) + apply (rule corres_split[OF setThreadState_corres]) apply simp + apply (rule setEndpoint_corres) apply (simp add: ep_relation_def) apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def - invs_def valid_state_def valid_pspace_def) - apply (clarsimp simp: invs'_def valid_pspace'_def) - \ \concludes IdleEP\ + apply (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_distinct) + apply clarsimp + \ \concludes SendEP if bl branch\ apply (simp add: ep_relation_def) - apply (case_tac bl; simp add: ep_relation_def) + apply (rename_tac list) + apply (rule_tac F="list \ []" in corres_req) + apply (simp add: valid_ep_def) + apply (case_tac list) + apply simp + apply (clarsimp split del: if_split) apply (rule corres_guard_imp) - apply (rule corres_split [OF 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 (clarsimp simp: st_tcb_at_tcb_at valid_tcb_state_def invs_def valid_state_def valid_pspace_def valid_ep_def) - apply (clarsimp simp: invs'_def valid_pspace'_def valid_ep'_def) - \ \concludes SendEP\ + apply (rule corres_split[OF setEndpoint_corres]) + apply (simp add: ep_relation_def split: list.split) + apply (simp add: isReceive_def split del:if_split) + apply (rule corres_split[OF getThreadState_corres]) + apply (rule_tac + F="\data. recv_state = Structures_A.BlockedOnReceive ep data" + in corres_gen_asm) + apply (clarsimp simp: case_bool_If case_option_If if3_fold + simp del: dc_simp split del: if_split cong: if_cong) + apply (rule corres_split[OF doIPCTransfer_corres]) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule corres_split[OF possibleSwitchTo_corres]) + apply (fold when_def)[1] + apply (rule_tac P="call" and P'="call" + in corres_symmetric_bool_cases, blast) + apply (simp add: when_def dc_def[symmetric] split del: if_split) + apply (rule corres_if2, simp) + apply (rule setupCallerCap_corres) + apply (rule setThreadState_corres, simp) + apply (rule corres_trivial) + apply (simp add: when_def dc_def[symmetric] split del: if_split) + apply (simp split del: if_split add: if_apply_def2) + apply (wp hoare_drop_imps)[1] + apply (simp split del: if_split add: if_apply_def2) + apply (wp hoare_drop_imps)[1] + apply (wp | simp)+ + apply (wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases) + apply (wp sts_weak_sch_act_wf sts_valid_objs' + sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases)[1] + apply (simp add: valid_tcb_state_def pred_conj_def) + apply (strengthen reply_cap_doesnt_exist_strg disjI2_strg + valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct + valid_sched_valid_queues)+ + apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift + | clarsimp simp: is_cap_simps)+)[1] + apply (simp add: pred_conj_def) + apply (strengthen sch_act_wf_weak) + apply (simp add: valid_tcb_state'_def) + apply (wp weak_sch_act_wf_lift_linear tcb_in_cur_domain'_lift hoare_drop_imps)[1] + apply (wp gts_st_tcb_at)+ + apply (simp add: pred_conj_def cong: conj_cong) + apply (wp hoare_TrueI) + apply (simp) + apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb')+ + apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def ep_redux_simps + ep_redux_simps' st_tcb_at_tcb_at valid_ep_def + cong: list.case_cong) + apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) + apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid + st_tcb_def2 valid_sched_def valid_sched_action_def) + apply (force simp: st_tcb_def2 dest!: st_tcb_at_caller_cap_null[simplified,rotated]) + subgoal by (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split) + apply wp+ + apply (clarsimp simp: ep_at_def2)+ + apply (rule corres_guard_imp) + apply (rule corres_split[OF getEndpoint_corres, + where + R="\rv. einvs and st_tcb_at active t and ep_at ep and + valid_ep rv and obj_at (\k. k = Endpoint rv) ep" + and + R'="\rv'. invs' and tcb_at' t and sch_act_not t + and ep_at' ep and valid_ep' rv'"]) + apply (rename_tac rv rv') + apply (case_tac rv) + apply (simp add: ep_relation_def) + \ \concludes IdleEP branch if not bl and no ft\ + apply (simp add: ep_relation_def) + \ \concludes SendEP branch if not bl and no ft\ apply (simp add: ep_relation_def) apply (rename_tac list) - apply (rule_tac F="list \ []" in corres_req, simp add: valid_ep_def) - apply (case_tac list, simp) + apply (rule_tac F="list \ []" in corres_req) + apply (simp add: valid_ep_def) + apply (case_tac list) + apply simp + apply (rule_tac F="a \ t" in corres_req) + apply (clarsimp simp: invs_def valid_state_def + valid_pspace_def) + apply (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) + apply (clarsimp simp: st_tcb_at_def obj_at_def tcb_bound_refs_def2) + apply fastforce apply (clarsimp split del: if_split) - \ \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_tcbs - and active_scs_valid - 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 (fastforce simp: valid_tcbs_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_tcbs - and active_scs_valid - 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 valid_release_queue_iff - and valid_queues and valid_queues'" - 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 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 valid_release_queue_iff and - valid_queues and valid_queues' and tcb_at' t'" - 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 - (\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 (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_release_queue and - valid_release_queue' and - valid_queues and valid_objs' and - valid_queues' and - (\s. reply_opt \ None \ - reply_at' (the reply_opt) s \ - replySCs_of s (the reply_opt) = None) and cur_tcb'" - 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 - scheduler_act_not t and valid_sched_action - 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_release_queue and - valid_release_queue' and valid_queues and valid_objs' and - valid_queues' and (\s. reply_opt \ None \ reply_at' (the reply_opt) s \ - replySCs_of s (the reply_opt) = None) and cur_tcb'" - 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 cur_tcb' and - ep_at' ep and valid_release_queue and valid_release_queue' and - valid_queues and valid_objs' and valid_mdb' and valid_queues' and - cur_tcb') 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 (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 (rule corres_split[OF setEndpoint_corres]) + apply (simp add: ep_relation_def split: list.split) + apply (rule corres_split[OF getThreadState_corres]) + apply (rule_tac + F="\data. recv_state = Structures_A.BlockedOnReceive ep data" + in corres_gen_asm) + apply (clarsimp simp: isReceive_def case_bool_If + split del: if_split cong: if_cong) + apply (rule corres_split[OF doIPCTransfer_corres]) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule possibleSwitchTo_corres) + apply (simp add: if_apply_def2) + apply ((wp sts_cur_tcb set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at_cases | + simp add: if_apply_def2 split del: if_split)+)[1] + apply (wp sts_weak_sch_act_wf sts_valid_objs' + sts_cur_tcb' setThreadState_tcb' sts_st_tcb_at'_cases) + apply (simp add: valid_tcb_state_def pred_conj_def) + apply ((wp hoare_drop_imps do_ipc_transfer_tcb_caps weak_valid_sched_action_lift + | clarsimp simp: is_cap_simps + | strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct + valid_sched_valid_queues )+)[1] + apply (simp add: valid_tcb_state'_def pred_conj_def) + apply (strengthen sch_act_wf_weak) + apply (wp weak_sch_act_wf_lift_linear hoare_drop_imps) + apply (wp gts_st_tcb_at)+ + apply (simp add: pred_conj_def cong: conj_cong) + apply (wp hoare_TrueI) + apply simp + apply (wp weak_sch_act_wf_lift_linear set_ep_valid_objs' setEndpoint_valid_mdb') + apply (clarsimp simp add: invs_def valid_state_def + valid_pspace_def ep_redux_simps ep_redux_simps' + st_tcb_at_tcb_at + cong: list.case_cong) apply (clarsimp simp: valid_ep_def) - apply (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 (drule(1) sym_refs_obj_atD[where P="\ob. ob = e" for e]) + apply (clarsimp simp: st_tcb_at_refs_of_rev st_tcb_at_reply_cap_valid + st_tcb_at_caller_cap_null) + apply (fastforce simp: st_tcb_def2 valid_sched_def valid_sched_action_def) + subgoal by (auto simp: valid_ep'_def + split: list.split; + clarsimp simp: invs'_def valid_state'_def) + apply wp+ + apply (clarsimp simp: ep_at_def2)+ done +qed -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)" - -global_interpretation maybeReturnSc: typ_at_all_props' "maybeReturnSc ntfnPtr tcbPtr" - by typ_at_props' +crunch setMessageInfo + for typ_at'[wp]: "\s. P (typ_at' T p s)" -global_interpretation setMessageInfo: typ_at_all_props' "setMessageInfo t info" - by typ_at_props' +lemmas setMessageInfo_typ_ats[wp] = typ_at_lifts [OF setMessageInfo_typ_at'] -context begin interpretation Arch . (*FIXME: arch_split*) +(* Annotation added by Simon Winwood (Thu Jul 1 20:54:41 2010) using taint-mode *) +declare tl_drop_1[simp] crunch cancel_ipc for cur[wp]: "cur_tcb" - and ntfn_at[wp]: "ntfn_at t" - (wp: crunch_wps simp: crunch_simps ignore: set_object) + (wp: crunch_wps simp: crunch_simps) + +crunch asUser + for valid_objs'[wp]: "valid_objs'" lemma valid_sched_weak_strg: "valid_sched s \ weak_valid_sched_action s" by (simp add: valid_sched_def valid_sched_action_def) -lemma runnable_tsr: - "thread_state_relation ts ts' \ runnable' ts' = runnable ts" - by (case_tac ts, auto) - -lemma idle_tsr: - "thread_state_relation ts ts' \ idle' ts' = idle ts" - by (case_tac ts, auto) - -crunch cancelIPC - for cur[wp]: cur_tcb' - (wp: crunch_wps gts_wp' simp: crunch_simps) - -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 - -lemma getTCBSc_corres: - "corres (\x y. \n. sc_relation x n y) - (\s. bound_sc_tcb_at (\sc. \y. sc = Some y \ sc_at y s) t s) - (\s. bound_sc_tcb_at' (\sc. \y. sc = Some y \ sc_at' y s) t s) - (get_tcb_sc t) (getTCBSc t)" - unfolding get_tcb_sc_def getTCBSc_def - apply (rule corres_guard_imp) - apply (rule corres_split_eqr) - apply (clarsimp simp: get_tcb_obj_ref_def) - apply (rule threadGet_corres, simp add: tcb_relation_def) - apply clarsimp - apply (rule corres_assert_opt_assume_l) - apply (rule corres_assert_assume_r) - apply (rule get_sc_corres) - apply (clarsimp simp: get_tcb_obj_ref_def) - apply (wp thread_get_wp) - apply (wp threadGet_wp) - apply clarsimp - apply (fastforce simp: pred_tcb_at_def obj_at_def is_tcb_def) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - done - -lemma getScTime_corres: - "corres (=) (valid_objs and pspace_aligned and pspace_distinct - and active_scs_valid and active_sc_tcb_at t) - valid_objs' - (get_sc_time t) (getScTime t)" - apply (simp only: get_sc_time_def getScTime_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[OF getTCBSc_corres]) - apply clarsimp - apply (rule_tac s'=s' in conjunct2[OF refill_hd_relation2, symmetric]) - apply simp+ - apply (wpsimp wp: thread_get_wp simp: get_tcb_sc_def get_tcb_obj_ref_def) - apply (wpsimp wp: threadGet_wp simp: getTCBSc_def) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps is_sc_obj_def) - apply (erule_tac x=ref' in valid_objsE; simp add: valid_obj_def) - apply (drule_tac scp=ref' in active_scs_validE[rotated]) - apply (clarsimp simp: is_sc_active_def is_sc_active_kh_simp[symmetric]) - apply (fastforce simp: vs_all_heap_simps pred_map_def cfg_valid_refills_def rr_valid_refills_def - sp_valid_refills_def sc_refill_cfgs_of_scs_def map_project_def) - apply (clarsimp simp: active_sc_tcb_at_def2) - apply (clarsimp simp: pred_tcb_at_def obj_at_def) - apply (prop_tac "sc_at scp s") - apply (fastforce simp: valid_obj_def valid_tcb_def) - apply (frule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - apply clarsimp - apply (rename_tac ko; case_tac ko; simp add: other_obj_relation_def) - apply (frule (2) tcb_at_cross[OF state_relation_pspace_relation]) - apply (fastforce simp: obj_at_def is_tcb) - apply (drule (2) sc_at_cross[OF state_relation_pspace_relation]) - apply (fastforce simp: obj_at_def) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def projectKOs tcb_relation_def valid_obj'_def - dest!: sym[of "Some _"]) - done - -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) - valid_objs' - (tcb_release_enqueue t) (tcbReleaseEnqueue t)" - apply (clarsimp simp: tcb_release_enqueue_def tcbReleaseEnqueue_def setReleaseQueue_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split_eqr) - apply (rule getScTime_corres) - apply (rule corres_split_eqr) - apply (rule release_queue_corres) - apply (rule corres_split_eqr) - apply (rule_tac r'="(=)" and S="(=)" in corres_mapM_list_all2; clarsimp) - apply (clarsimp simp: list.rel_eq) - apply wpfix - apply (rule_tac P="\s. valid_objs s \ pspace_aligned s \ pspace_distinct s - \ active_scs_valid s - \ (\x \ set (y#xs). active_sc_tcb_at x s)" - in corres_guard1_imp) - apply (rule getScTime_corres, simp) - apply wpsimp - apply (wpsimp simp: getScTime_def getTCBSc_def wp: hoare_drop_imps) - apply (clarsimp simp: list.rel_eq) - apply (rule corres_split) - apply (rule corres_when, simp) - apply (rule reprogram_timer_corres) - apply (rule corres_add_noop_lhs2) - apply (rule corres_split) - apply (rule corres_modify) - apply (clarsimp simp: state_relation_def release_queue_relation_def swp_def) - apply (rule threadSet_corres_noop; clarsimp simp: tcb_relation_def) - apply wp - apply wp - apply (rule hoare_strengthen_post[OF hoare_TrueI], simp) - apply (rule_tac Q="\_. P and P" for P in hoare_triv) - apply wpsimp - apply wpsimp - apply (wpsimp wp: mapM_wp_lift threadGet_wp - simp: getScTime_def getTCBSc_def obj_at'_def) - apply wp - apply wpsimp - apply wpsimp - apply (wpsimp wp: threadGet_wp simp: getScTime_def getTCBSc_def) - apply (clarsimp simp: valid_release_q_def) - apply (clarsimp simp: obj_at'_def) - done - -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 \ active_scs_valid s \ is_active_sc ptr s - \ sc_tcb_sc_at (\sc. \t. sc = Some t \ not_queued t s) ptr s) - (valid_queues and valid_objs') - (SchedContext_A.postpone ptr) (postpone ptr)" - apply (rule stronger_corres_guard_imp) - apply (clarsimp simp: SchedContext_A.postpone_def postpone_def get_sc_obj_ref_def) - 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_split) - apply (clarsimp simp: sc_relation_def) - apply (rule_tac P="tcb_at (the (sc_tcb rv))" in corres_guard1_imp) - apply (rule tcbSchedDequeue_corres) - apply clarsimp - apply (rule corres_split) - apply (clarsimp simp: sc_relation_def) - apply (rule tcbReleaseEnqueue_corres) - apply (rule reprogram_timer_corres) - apply wp - apply wp - apply (wp tcb_sched_dequeue_not_queued_inv) - apply (subgoal_tac "scTCB rv' = sc_tcb rv") - apply clarsimp - apply assumption - apply (clarsimp simp: sc_relation_def) - apply wpsimp - apply wp - apply wp - 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 (fastforce simp: valid_obj_def valid_sched_context_def obj_at_def - is_obj_defs get_refs_def refs_of_rev) - apply clarsimp - apply (rule context_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_tcb_sc_at_def obj_at_def) - apply (rename_tac sc' sc n tp) - apply (prop_tac "scTCB sc' = Some tp") - apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - apply (clarsimp simp: projectKOs obj_at'_def sc_relation_def split: if_split_asm) - apply simp - apply (rule tcb_at_cross; (simp add: state_relation_pspace_relation)?) - apply (fastforce simp: valid_obj_def valid_sched_context_def) - done - -lemma schedContextResume_corres: - "corres dc (valid_objs and pspace_aligned and pspace_distinct and valid_ready_qs and valid_release_q - and active_scs_valid and sc_tcb_sc_at (\sc. sc \ None) ptr - and (\s. sym_refs (state_refs_of s))) - (valid_objs' and valid_queues and valid_release_queue_iff) - (sched_context_resume ptr) (schedContextResume ptr)" - apply (simp only: sched_context_resume_def schedContextResume_def) - 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 isSchedulable_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 refillSufficient_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 is_schedulable_wp) - apply (wp isSchedulable_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_def 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: vs_all_heap_simps) - apply (intro conjI impI) - apply (fastforce simp: valid_refills_def vs_all_heap_simps rr_valid_refills_def - opt_map_red opt_pred_def MIN_REFILLS_def - dest!: active_scs_validE split: if_split_asm) - apply (fastforce simp: valid_refills_def vs_all_heap_simps rr_valid_refills_def - dest!: active_scs_validE) - 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 (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 projectKOs isSchedulable_bool_def projection_rewrites - other_obj_relation_def tcb_relation_def) - apply (drule sym[where s="Some ptr"]) - apply (clarsimp simp: projection_rewrites isScActive_def 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) - done - -lemma getScTime_wp: - "\\s. \tcb. ko_at' tcb tptr s \ (tcbSchedContext tcb \ None) \ - (\sc. ko_at' sc (the (tcbSchedContext tcb)) s \ - P (rTime (refillHd sc)) s)\ - getScTime tptr \P\" - apply (wpsimp simp: getScTime_def getTCBSc_def wp: threadGet_wp) - by (clarsimp simp: tcb_at'_ex_eq_all) - -lemma updateRefillHd_valid_objs': - "\valid_objs' and active_sc_at' scPtr\ updateRefillHd scPtr f \\_. valid_objs'\" - apply (clarsimp simp: updateRefillHd_def updateSchedContext_def) - apply wpsimp - apply (frule (1) sc_ko_at_valid_objs_valid_sc') - 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 projectKO_sc) - done - -lemma getCTE_cap_to_refs[wp]: - "\\\ getCTE p \\rv s. \r\zobj_refs' (cteCap rv). ex_nonz_cap_to' r s\" - apply (rule hoare_strengthen_post [OF getCTE_sp]) - apply (clarsimp simp: ex_nonz_cap_to'_def) - apply (fastforce elim: cte_wp_at_weakenE') - done - -lemma lookupCap_cap_to_refs[wp]: - "\\\ lookupCap t cref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" - apply (simp add: lookupCap_def lookupCapAndSlot_def split_def - getSlotCap_def) - apply (wp | simp)+ - done - -lemma arch_stt_objs' [wp]: - "\valid_objs'\ Arch.switchToThread t \\rv. valid_objs'\" - apply (simp add: ARM_H.switchToThread_def) - apply wp - done - -lemma cteInsert_ct'[wp]: - "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" - by (wp sch_act_wf_lift valid_queues_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 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 valid_objs' and valid_queues and valid_queues' and valid_release_queue_iff) - (maybe_donate_sc tcb_ptr ntfn_ptr) - (maybeDonateSc tcb_ptr ntfn_ptr)" - 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 - apply (rule corres_stateAssert_assume) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[OF threadGet_corres, where r'="(=)"]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_when, simp) - apply (rule corres_split[OF getNotification_corres]) - apply (rule corres_option_split) - apply (clarsimp simp: ntfn_relation_def) - apply (rule corres_return_trivial) - apply (simp add: get_tcb_obj_ref_def liftM_def maybeM_def) - apply (rule corres_split[OF get_sc_corres]) - apply (rule corres_when) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_split[OF schedContextDonate_corres]) - apply (rule schedContextResume_corres, simp) - apply clarsimp - apply wpsimp - apply (rule_tac Q'="\_. valid_objs and valid_ready_qs and - pspace_aligned and pspace_distinct and (\s. sym_refs (state_refs_of s)) and - active_scs_valid and valid_release_q and - sc_not_in_release_q xa and sc_tcb_sc_at ((=) (Some tcb_ptr)) xa" - in hoare_strengthen_post[rotated]) - apply (fastforce simp: sc_at_pred_n_def obj_at_def) - apply (wpsimp wp: sched_context_donate_sym_refs - sched_context_donate_sc_not_in_release_q - sched_context_donate_sc_tcb_sc_at) - apply (wpsimp wp: schedContextDonate_valid_objs') - apply (wpsimp wp: get_simple_ko_wp getNotification_wp)+ - apply (wpsimp wp: thread_get_wp' threadGet_wp)+ - apply (clarsimp simp: tcb_at_kh_simps pred_map_eq_normalise invs_def valid_state_def valid_pspace_def - split: option.splits cong: conj_cong) - apply (rename_tac sc_ptr) - 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 (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 - apply (drule heap_refs_retractD[OF sym_refs_retract_tcb_scps, rotated], simp) - apply (clarsimp simp: vs_all_heap_simps obj_at_def) - apply (clarsimp simp: vs_all_heap_simps obj_at_def) - 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 (rename_tac sc_ptr) - 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) - done - -lemma setReleaseQueue_valid_release_queue[wp]: - "\\s. \t. t \ set Q \ obj_at' (tcbInReleaseQueue) t s\ - setReleaseQueue Q - \\_. valid_release_queue\" - apply (clarsimp simp: valid_release_queue_def) - by (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - -lemma setReleaseQueue_valid_queues[wp]: - "setReleaseQueue Q \valid_queues\" - by (wpsimp simp: valid_queues_def) - -lemma getScTime_tcb_at'[wp]: - "\\\ getScTime tptr \\_. tcb_at' tptr\" - by (wpsimp wp: getScTime_wp) - -lemma tcbReleaseEnqueue_vrq[wp]: - "tcbReleaseEnqueue tcbPtr \valid_release_queue\" - unfolding tcbReleaseEnqueue_def - apply wpsimp - apply (wpsimp wp: threadSet_enqueue_vrq) - apply ((wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift)+)[4] - apply (rule_tac Q'="\r. tcb_at' tcbPtr and (\s. \x. x \ set qs \ obj_at' tcbInReleaseQueue x s) - and K (length qs = length r)" - in hoare_strengthen_post[rotated]) - apply (fastforce dest: in_set_zip1) - apply (wpsimp wp: mapM_wp_inv) - apply wpsimp - apply (wpsimp wp_del: getScTime_inv, wpsimp) - apply (clarsimp simp: valid_release_queue_def) - done - -lemma tcbReleaseEnqueue_vrq'[wp]: - "tcbReleaseEnqueue tcbPtr \valid_release_queue'\" - unfolding tcbReleaseEnqueue_def - apply wpsimp - apply (wpsimp wp: threadSet_enqueue_vrq') - apply ((wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift)+)[4] - apply (rule_tac Q'="\r. tcb_at' tcbPtr and (\s. \x. obj_at' tcbInReleaseQueue x s \ x \ set qs) - and K (length qs = length r)" - in hoare_strengthen_post[rotated]) - apply clarsimp - apply (drule_tac x=x in spec, clarsimp) - apply (subst (asm) fst_image_set_zip[symmetric], assumption) - apply (fastforce simp: image_def) - apply (wpsimp wp: mapM_wp_inv) - apply wpsimp - apply (wpsimp wp_del: getScTime_inv, wpsimp) - apply (clarsimp simp: valid_release_queue'_def) - done - -lemma tcbReleaseEnqueue_valid_queues[wp]: - "tcbReleaseEnqueue tcbPtr \valid_queues\" - unfolding tcbReleaseEnqueue_def - apply (wpsimp wp: threadSet_valid_queues) - apply (clarsimp cong: conj_cong simp: inQ_def) - by (wpsimp wp: mapM_wp_inv)+ - -lemma tcbReleaseEnqueue_valid_queues'[wp]: - "tcbReleaseEnqueue tcbPtr \valid_queues'\" - unfolding tcbReleaseEnqueue_def - apply (wpsimp wp: threadSet_valid_queues') - apply (clarsimp cong: conj_cong simp: inQ_def) - by (wpsimp wp: mapM_wp_inv)+ - -lemma postpone_vrq[wp]: - "\valid_release_queue and valid_objs' and obj_at' (\a. \y. scTCB a = Some y) scPtr\ - postpone scPtr - \\_. valid_release_queue\" - unfolding postpone_def - by (wpsimp wp: getNotification_wp threadGet_wp) - -lemma postpone_vrq'[wp]: - "\valid_release_queue' and valid_objs' and obj_at' (\a. \y. scTCB a = Some y) scPtr\ - postpone scPtr - \\_. valid_release_queue'\" - unfolding postpone_def - by (wpsimp wp: getNotification_wp threadGet_wp) - -lemma postpone_vq[wp]: - "\valid_queues and valid_objs'\ - postpone scPtr - \\_. valid_queues\" - unfolding postpone_def - apply (wpsimp wp: getNotification_wp threadGet_wp tcbSchedDequeue_valid_queues) - apply (subst obj_at'_conj[symmetric]) - apply (erule (1) valid_objs_valid_tcbE') - by (clarsimp simp: valid_tcb'_def) - -crunch postpone - for valid_queues'[wp]: valid_queues' - -crunch setReleaseQueue, tcbReleaseEnqueue, postpone, schedContextResume - for valid_objs'[wp]: valid_objs' - (wp: crunch_wps) - -lemma schedContextResume_vrq[wp]: - "\valid_release_queue and valid_objs' and obj_at' (\a. \y. scTCB a = Some y) scPtr\ - schedContextResume scPtr - \\_. valid_release_queue\" - unfolding schedContextResume_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imp refillReady_wp) - -lemma schedContextResume_vrq'[wp]: - "\valid_release_queue' and valid_objs'\ schedContextResume scPtr \\_. valid_release_queue'\" - unfolding schedContextResume_def - apply (wpsimp | wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imp refillReady_wp)+ - by (clarsimp simp: obj_at'_def) - -lemma schedContextResume_vq[wp]: - "\valid_queues and valid_objs'\ schedContextResume scPtr \\_. valid_queues\" - unfolding schedContextResume_def - by (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imp) - -crunch schedContextResume - for valid_queues'[wp]: valid_queues' - (wp: crunch_wps) - -lemma updateSchedContext_sc_obj_at': - "\if scPtr = scPtr' then (\s. \ko. ko_at' ko scPtr' s \ P (f ko)) else obj_at' P scPtr'\ - updateSchedContext scPtr f - \\rv. obj_at' P scPtr'\" - supply if_split [split del] - apply (simp add: updateSchedContext_def) - apply (wpsimp wp: set_sc'.obj_at') - apply (clarsimp split: if_splits simp: obj_at'_real_def ko_wp_at'_def) - done - -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 maybeDonateSc_valid_release_queue[wp]: - "\valid_objs' and valid_release_queue\ - maybeDonateSc tcbPtr ntfnPtr - \\_. valid_release_queue\" - unfolding maybeDonateSc_def - apply wpsimp - apply (rule_tac Q'="\_. valid_release_queue and valid_objs' - and obj_at' (\a. \y. scTCB a = Some y) x2" - in hoare_strengthen_post[rotated], clarsimp) - apply (wpsimp wp: getNotification_wp threadGet_wp schedContextDonate_valid_objs')+ - by (clarsimp simp: obj_at'_def) - -lemma maybeDonateSc_valid_objs'[wp]: - "\valid_objs'\ - maybeDonateSc tptr nptr - \\_. valid_objs'\" - unfolding maybeDonateSc_def - apply (wpsimp wp: getNotification_wp threadGet_wp schedContextDonate_valid_objs') - by (clarsimp simp: obj_at'_def) - -lemma maybeDonateSc_vrq'[wp]: - "\valid_objs' and valid_release_queue'\ - maybeDonateSc tptr nptr - \\_. valid_release_queue'\" - unfolding maybeDonateSc_def - apply (wpsimp wp: getNotification_wp threadGet_wp schedContextDonate_valid_objs') - by (clarsimp simp: obj_at'_def) - -lemma maybeDonateSc_valid_queues[wp]: - "\valid_queues and valid_objs'\ - maybeDonateSc tptr nptr - \\_. valid_queues\" - unfolding maybeDonateSc_def - apply (wpsimp wp: getNotification_wp threadGet_wp schedContextDonate_valid_queues - schedContextDonate_valid_objs') - by (clarsimp simp: obj_at'_def) - -lemma maybeDonateSc_valid_queues'[wp]: - "\valid_queues'\ - maybeDonateSc tptr nptr - \\_. valid_queues'\" - unfolding maybeDonateSc_def - apply (wpsimp wp: getNotification_wp threadGet_wp schedContextDonate_valid_queues') - by (clarsimp simp: obj_at'_def) - -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) - -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' is_BlockedOnNotification 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 projectKOs) - 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 - projectKO_tcb 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 projectKO_tcb) - apply (clarsimp split: option.splits) - apply (drule (1) ntfn_ko_at_valid_objs_valid_ntfn') - apply (clarsimp simp: valid_ntfn'_def) - done - -lemma cancelSignal_valid_idle': - "\\s. valid_idle' s \ threadPtr \ ksIdleThread s\ - cancelSignal threadPtr ntfnPtr - \\_. valid_idle'\" - apply (clarsimp simp: cancelSignal_def) - apply (wpsimp wp: getNotification_wp) - done - -lemma cancelIPC_valid_idle'[wp]: - "\\s. valid_idle' s \ tptr \ ksIdleThread s\ - cancelIPC tptr - \\_. valid_idle'\" - apply (clarsimp simp: cancelIPC_def) - apply (rule bind_wp_fwd_skip, solves \wpsimp wp: threadSet_idle'\)+ - apply (wpsimp wp: blockedCancelIPC_valid_idle' replyRemoveTCB_valid_idle' cancelSignal_valid_idle') - done +crunch as_user + for weak_valid_sched_action[wp]: weak_valid_sched_action + (wp: weak_valid_sched_action_lift) lemma sendSignal_corres: - "corres dc (einvs and ntfn_at ep and current_time_bounded) (invs' and ntfn_at' ep) + "corres dc (einvs and ntfn_at ep) (invs' and ntfn_at' ep) (send_signal ep bg) (sendSignal ep bg)" apply (simp add: send_signal_def sendSignal_def Let_def) - 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 (clarsimp simp: sym_refs_asrt_def) - apply add_sym_refs - apply (case_tac "ntfn_obj ntfn"; simp) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getNotification_corres, + where + R = "\rv. einvs and ntfn_at ep and valid_ntfn rv and + ko_at (Structures_A.Notification rv) ep" and + R' = "\rv'. invs' and ntfn_at' ep and + valid_ntfn' rv' and ko_at' rv' ep"]) + defer + apply (wp get_simple_ko_ko_at get_ntfn_ko')+ + apply (simp add: invs_valid_objs)+ + apply (case_tac "ntfn_obj ntfn") \ \IdleNtfn\ apply (clarsimp simp add: ntfn_relation_def) - apply (case_tac "ntfnBoundTCB nTFN"; simp) + apply (case_tac "ntfnBoundTCB nTFN") + apply clarsimp apply (rule corres_guard_imp[OF setNotification_corres]) apply (clarsimp simp add: ntfn_relation_def)+ apply (rule corres_guard_imp) @@ -3421,216 +2616,172 @@ lemma sendSignal_corres: Structures_H.thread_state.splits) apply (rule corres_split[OF cancel_ipc_corres]) apply (rule corres_split[OF setThreadState_corres]) - apply clarsimp + apply (clarsimp simp: thread_state_relation_def) apply (simp add: badgeRegister_def badge_register_def) apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split[OF maybeDonateSc_corres]) - apply (rule corres_split[OF isSchedulable_corres]) - apply (rule corres_split[OF corres_when], simp) - 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 (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 (clarsimp, drule (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' a and valid_objs'" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: obj_at'_def split: option.split) - apply wpsimp - apply (wpsimp wp: is_schedulable_wp) - apply (wpsimp wp: isSchedulable_wp) - 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 | 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 (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 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) - apply clarsimp - apply (prop_tac "tcb_st_refs_of ts = {}") - apply (fastforce simp: tcb_st_refs_of_def) - apply simp - apply (clarsimp simp add: get_refs_def split: option.splits; fastforce?) - apply (fold fun_upd_def, simp) - 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 valid_idle' 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 (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: gts_wp gts_wp')+ - 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 projectKO_tcb) - apply (clarsimp simp: receiveBlocked_equiv is_BlockedOnReceive_def) + apply (rule possibleSwitchTo_corres) + apply wp + apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' + sts_st_tcb' sts_valid_objs' hoare_disjI2 + cancel_ipc_cte_wp_at_not_reply_state + | strengthen invs_vobjs_strgs invs_psp_aligned_strg valid_sched_weak_strg + valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct + valid_sched_valid_queues + | simp add: valid_tcb_state_def)+ + apply (rule_tac Q'="\rv. invs' and tcb_at' a" in hoare_strengthen_post) + apply wp + apply (fastforce simp: invs'_def valid_state'_def sch_act_wf_weak valid_tcb_state'_def) + apply (rule setNotification_corres) + apply (clarsimp simp add: ntfn_relation_def) + apply (wp gts_wp gts_wp' | clarsimp)+ + apply (auto simp: valid_ntfn_def receive_blocked_def valid_sched_def invs_cur + elim: pred_tcb_weakenE + intro: st_tcb_at_reply_cap_valid + split: Structures_A.thread_state.splits)[1] + apply (clarsimp simp: valid_ntfn'_def invs'_def valid_state'_def valid_pspace'_def sch_act_wf_weak) \ \WaitingNtfn\ - apply (clarsimp simp: ntfn_relation_def Let_def update_waiting_ntfn_def) + apply (clarsimp simp add: ntfn_relation_def Let_def) + apply (simp add: update_waiting_ntfn_def) apply (rename_tac list) + apply (case_tac "tl list = []") + \ \tl list = []\ + apply (rule corres_guard_imp) + apply (rule_tac F="list \ []" in corres_gen_asm) + apply (simp add: list_case_helper split del: if_split) + apply (rule corres_split[OF setNotification_corres]) + apply (simp add: ntfn_relation_def) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (simp add: badgeRegister_def badge_register_def) + apply (rule corres_split[OF asUser_setRegister_corres]) + apply (rule possibleSwitchTo_corres) + apply ((wp | simp)+)[1] + apply (rule_tac Q'="\_. (\s. sch_act_wf (ksSchedulerAction s) s) and + cur_tcb' and + st_tcb_at' runnable' (hd list) and valid_objs' and + sym_heap_sched_pointers and valid_sched_pointers and + pspace_aligned' and pspace_distinct'" + in hoare_post_imp, clarsimp simp: pred_tcb_at' elim!: sch_act_wf_weak) + apply (wp | simp)+ + apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action + | simp)+ + apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb + | simp)+ + apply (wp set_simple_ko_valid_objs set_ntfn_aligned' set_ntfn_valid_objs' + hoare_vcg_disj_lift weak_sch_act_wf_lift_linear + | simp add: valid_tcb_state_def valid_tcb_state'_def)+ + apply (fastforce simp: invs_def valid_state_def valid_ntfn_def + valid_pspace_def ntfn_queued_st_tcb_at valid_sched_def + valid_sched_action_def) + apply (auto simp: valid_ntfn'_def )[1] + apply (clarsimp simp: invs'_def valid_state'_def) + + \ \tl list \ []\ apply (rule corres_guard_imp) apply (rule_tac F="list \ []" in corres_gen_asm) - apply (simp add: list_case_helper split del: if_split) + apply (simp add: list_case_helper) apply (rule corres_split[OF setNotification_corres]) - apply (clarsimp simp: ntfn_relation_def split: list.splits) + apply (simp add: ntfn_relation_def split:list.splits) apply (rule corres_split[OF setThreadState_corres]) - apply clarsimp + apply simp apply (simp add: badgeRegister_def badge_register_def) apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split[OF maybeDonateSc_corres]) - apply (rule corres_split[OF isSchedulable_corres]) - apply (rule corres_split[OF corres_when], simp) - 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 (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]) - apply (clarsimp, drule (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 (clarsimp simp: obj_at'_def split: option.split) - apply wpsimp - apply (wpsimp wp: is_schedulable_wp) - apply (wpsimp wp: isSchedulable_wp) - 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 | 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 (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 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 (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)) - using distinct_tl apply fastforce - using distinct_tl apply fastforce - apply (case_tac list; clarsimp simp: valid_ntfn'_def split: list.splits option.splits) + apply (rule possibleSwitchTo_corres) + apply (wp cur_tcb_lift | simp)+ + apply (wp sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action + | simp)+ + apply (wpsimp wp: sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb) + apply (wp set_ntfn_aligned' set_simple_ko_valid_objs set_ntfn_valid_objs' + hoare_vcg_disj_lift weak_sch_act_wf_lift_linear + | simp add: valid_tcb_state_def valid_tcb_state'_def)+ + apply (fastforce simp: invs_def valid_state_def valid_ntfn_def + valid_pspace_def neq_Nil_conv + ntfn_queued_st_tcb_at valid_sched_def valid_sched_action_def + split: option.splits) + apply (auto simp: valid_ntfn'_def neq_Nil_conv invs'_def valid_state'_def + weak_sch_act_wf_def + split: option.splits)[1] \ \ActiveNtfn\ - apply (clarsimp simp add: ntfn_relation_def Let_def) + apply (clarsimp simp add: ntfn_relation_def) apply (rule corres_guard_imp) apply (rule setNotification_corres) - apply (clarsimp simp: ntfn_relation_def combine_ntfn_badges_def)+ + apply (simp add: ntfn_relation_def combine_ntfn_badges_def + combine_ntfn_msgs_def) + apply (simp add: invs_def valid_state_def valid_ntfn_def) + apply (simp add: invs'_def valid_state'_def valid_ntfn'_def) done -lemma possibleSwitchTo_ksQ': - "\\s. t' \ set (ksReadyQueues s p) \ sch_act_not t' s \ t' \ t\ +lemma valid_Running'[simp]: + "valid_tcb_state' Running = \" + by (rule ext, simp add: valid_tcb_state'_def) + +crunch setMRs + for typ'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps simp: zipWithM_x_mapM) + +lemma possibleSwitchTo_sch_act[wp]: + "\\s. sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ possibleSwitchTo t - \\_ s. t' \ set (ksReadyQueues s p)\" - apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs inReleaseQueue_def) - apply (wp hoare_weak_lift_imp rescheduleRequired_ksQ' tcbSchedEnqueue_ksQ threadGet_wp - | wpc - | simp split del: if_split)+ - apply (auto simp: obj_at'_def) + \\rv s. sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: possibleSwitchTo_def curDomain_def bitmap_fun_defs) + apply (wp hoare_weak_lift_imp threadSet_sch_act setQueue_sch_act threadGet_wp + | simp add: unless_def | wpc)+ + apply (auto simp: obj_at'_def projectKOs tcb_in_cur_domain'_def) done +crunch possibleSwitchTo + for st_refs_of'[wp]: "\s. P (state_refs_of' s)" + (wp: crunch_wps) + +crunch possibleSwitchTo + for cap_to'[wp]: "ex_nonz_cap_to' p" + (wp: crunch_wps) +crunch possibleSwitchTo + for objs'[wp]: valid_objs' + (wp: crunch_wps) +crunch possibleSwitchTo + for ct[wp]: cur_tcb' + (wp: cur_tcb_lift crunch_wps) + lemma possibleSwitchTo_iflive[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' t - and (\s. sch_act_wf (ksSchedulerAction s) s)\ - possibleSwitchTo t - \\rv. if_live_then_nonz_cap'\" - apply (simp add: possibleSwitchTo_def curDomain_def inReleaseQueue_def) - apply wpsimp + "\if_live_then_nonz_cap' and ex_nonz_cap_to' t and (\s. sch_act_wf (ksSchedulerAction s) s) + and pspace_aligned' and pspace_distinct'\ + possibleSwitchTo t + \\_. if_live_then_nonz_cap'\" + apply (simp add: possibleSwitchTo_def curDomain_def) + apply (wp | wpc | simp)+ apply (simp only: imp_conv_disj, wp hoare_vcg_all_lift hoare_vcg_disj_lift) apply (wp threadGet_wp)+ - by (fastforce simp: obj_at'_def projectKOs) + apply (auto simp: obj_at'_def) + done -lemma replyRemoveTCB_irqs_masked'[wp]: - "replyRemoveTCB t \ irqs_masked' \" - unfolding replyRemoveTCB_def - by (wpsimp wp: hoare_drop_imps gts_wp'|rule conjI)+ +crunch possibleSwitchTo + for ifunsafe[wp]: if_unsafe_then_cap' + and idle'[wp]: valid_idle' + and global_refs'[wp]: valid_global_refs' + and arch_state'[wp]: valid_arch_state' + and irq_node'[wp]: "\s. P (irq_node' s)" + and typ_at'[wp]: "\s. P (typ_at' T p s)" + and irq_handlers'[wp]: valid_irq_handlers' + and irq_states'[wp]: valid_irq_states' + and pde_mappigns'[wp]: valid_pde_mappings' + (wp: crunch_wps simp: unless_def tcb_cte_cases_def) -crunch sendSignal, refillUnblockCheck +crunch sendSignal for ct'[wp]: "\s. P (ksCurThread s)" and it'[wp]: "\s. P (ksIdleThread s)" - and irqs_masked'[wp]: "irqs_masked'" (wp: crunch_wps simp: crunch_simps o_def) +context +notes option.case_cong_weak[cong] +begin +crunch sendSignal, setBoundNotification + for irqs_masked'[wp]: "irqs_masked'" + (wp: crunch_wps getObject_inv loadObject_default_inv + simp: crunch_simps unless_def o_def + rule: irqs_masked_lift) +end + lemma ct_in_state_activatable_imp_simple'[simp]: "ct_in_state' activatable' s \ ct_in_state' simple' s" apply (simp add: ct_in_state'_def) @@ -3640,44 +2791,100 @@ lemma ct_in_state_activatable_imp_simple'[simp]: lemma setThreadState_nonqueued_state_update: "\\s. invs' s \ st_tcb_at' simple' t s - \ simple' st - \ (st \ Inactive \ ex_nonz_cap_to' t s)\ - setThreadState st t \\rv. invs'\" - apply (simp add: invs'_def valid_dom_schedule'_def) - apply (rule hoare_pre, wp valid_irq_node_lift - sts_valid_queues) - apply (clarsimp simp: pred_tcb_at' pred_tcb_at'_eq_commute) + \ st \ {Inactive, Running, Restart, IdleThreadState} + \ (st \ Inactive \ ex_nonz_cap_to' t s) + \ (t = ksIdleThread s \ idle' st) + \ (\ runnable' st \ sch_act_simple s)\ + setThreadState st t + \\_. invs'\" + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wp valid_irq_node_lift setThreadState_ct_not_inQ) + apply (clarsimp simp: pred_tcb_at') apply (rule conjI, fastforce simp: valid_tcb_state'_def) - apply (clarsimp simp: list_refs_of_replies'_def o_def pred_tcb_at'_def obj_at'_def) + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (rule conjI) + apply clarsimp + apply (erule delta_sym_refs) + apply (fastforce split: if_split_asm) + apply (fastforce simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm) + apply fastforce done -crunch possibleSwitchTo, asUser, doIPCTransfer +lemma cteDeleteOne_reply_cap_to'[wp]: + "\ex_nonz_cap_to' p and + cte_wp_at' (\c. isReplyCap (cteCap c)) slot\ + cteDeleteOne slot + \\rv. ex_nonz_cap_to' p\" + apply (simp add: cteDeleteOne_def ex_nonz_cap_to'_def unless_def) + apply (rule bind_wp [OF _ getCTE_sp]) + apply (rule hoare_assume_pre) + apply (subgoal_tac "isReplyCap (cteCap cte)") + apply (wp hoare_vcg_ex_lift emptySlot_cte_wp_cap_other isFinalCapability_inv + | clarsimp simp: finaliseCap_def isCap_simps | simp + | wp (once) hoare_drop_imps)+ + apply (fastforce simp: cte_wp_at_ctes_of) + apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) + done + +crunch setupCallerCap, possibleSwitchTo, asUser, doIPCTransfer for vms'[wp]: "valid_machine_state'" (wp: crunch_wps simp: zipWithM_x_mapM_x) -crunch activateIdleThread, isFinalCapability +crunch cancelSignal + for nonz_cap_to'[wp]: "ex_nonz_cap_to' p" + (wp: crunch_wps simp: crunch_simps) + +lemma cancelIPC_nonz_cap_to'[wp]: + "\ex_nonz_cap_to' p\ cancelIPC t \\rv. ex_nonz_cap_to' p\" + apply (simp add: cancelIPC_def getThreadReplySlot_def Let_def + capHasProperty_def) + apply (wp threadSet_cap_to' + | wpc + | simp + | clarsimp elim!: cte_wp_at_weakenE' + | rule hoare_post_imp[where Q'="\rv. ex_nonz_cap_to' p"])+ + done + + +crunch activateIdleThread, getThreadReplySlot, isFinalCapability for nosch[wp]: "\s. P (ksSchedulerAction s)" (ignore: setNextPC simp: Let_def) -crunch asUser, setMRs, doIPCTransfer, possibleSwitchTo +crunch setupCallerCap, asUser, setMRs, doIPCTransfer, possibleSwitchTo for pspace_domain_valid[wp]: "pspace_domain_valid" (wp: crunch_wps simp: zipWithM_x_mapM_x) -crunch doIPCTransfer, possibleSwitchTo +crunch setupCallerCap, doIPCTransfer, possibleSwitchTo for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" (wp: crunch_wps simp: zipWithM_x_mapM) lemma setThreadState_not_rct[wp]: - "setThreadState st t - \\s. ksSchedulerAction s \ ResumeCurrentThread \" - by (wpsimp wp: setThreadState_def) + "\\s. ksSchedulerAction s \ ResumeCurrentThread \ + setThreadState st t + \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" + apply (simp add: setThreadState_def) + apply (wp) + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply (simp) + apply (wp)+ + apply simp + done 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) + apply (wp | wpc)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wp)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ done lemma cancelAllSignals_not_rct[wp]: @@ -3685,327 +2892,170 @@ lemma cancelAllSignals_not_rct[wp]: cancelAllSignals epptr \\_ s. ksSchedulerAction s \ ResumeCurrentThread \" apply (simp add: cancelAllSignals_def) - apply (wpsimp wp: getNotification_wp) + apply (wp | wpc)+ + apply (rule hoare_post_imp [OF _ rescheduleRequired_notresume], simp) + apply simp + apply (rule mapM_x_wp_inv) + apply (wpsimp wp: hoare_vcg_all_lift hoare_drop_imp)+ done crunch finaliseCapTrue_standin for not_rct[wp]: "\s. ksSchedulerAction s \ ResumeCurrentThread" - (simp: crunch_simps wp: crunch_wps) +(simp: Let_def) -crunch cleanReply - for schedulerAction[wp]: "\s. P (ksSchedulerAction s)" - (simp: crunch_simps) +declare setEndpoint_ct' [wp] -lemma replyUnlink_ResumeCurrentThread_imp_notct[wp]: +lemma cancelIPC_ResumeCurrentThread_imp_notct[wp]: "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - replyUnlink a b - \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (clarsimp simp: replyUnlink_def updateReply_def) - apply (wpsimp wp: set_reply'.set_wp gts_wp') - done - -lemma replyRemoveTCB_ResumeCurrentThread_imp_notct[wp]: - "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - replyRemoveTCB tptr + cancelIPC t \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - apply (clarsimp simp: replyRemoveTCB_def) - apply (rule bind_wp_fwd_skip, solves \wpsimp wp: getEndpoint_wp\)+ - apply (rule bind_wp_fwd_skip) - apply (clarsimp simp: when_def) - apply (intro conjI impI) - apply (wpsimp wp: set_sc'.set_wp set_reply'.set_wp hoare_vcg_imp_lift')+ - done - -lemma cancelSignal_ResumeCurrentThread_imp_notct[wp]: - "cancelSignal t ntfn \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" (is "\?PRE t'\ _ \_\") - apply (simp add: cancelSignal_def) - apply wp[1] - apply (wp hoare_convert_imp)+ - apply (rule_tac P="\s. ksSchedulerAction s \ ResumeCurrentThread" - in hoare_weaken_pre) - apply (wpc) - apply (wp | simp)+ +proof - + have aipc: "\t t' ntfn. + \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ + cancelSignal t ntfn + \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" + apply (simp add: cancelSignal_def) + apply (wp)[1] + apply (wp hoare_convert_imp)+ + apply (rule_tac P="\s. ksSchedulerAction s \ ResumeCurrentThread" + in hoare_weaken_pre) + apply (wpc) + apply (wp | simp)+ + apply (wpc, wp+) + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply (wp) + apply simp + done + have cdo: "\t t' slot. + \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ + cteDeleteOne slot + \\_ s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" + apply (simp add: cteDeleteOne_def unless_def split_def) + apply (wp) + apply (wp hoare_convert_imp)[1] + apply (wp) + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply (wp hoare_convert_imp | simp)+ + done + show ?thesis + apply (simp add: cancelIPC_def Let_def) + apply (wp, wpc) + prefer 4 \ \state = Running\ + apply wp + prefer 7 \ \state = Restart\ + apply wp + apply (wp)+ + apply (wp hoare_convert_imp)[1] + apply (wpc, wp+) + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply (wp cdo)+ + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply ((wp aipc hoare_convert_imp)+)[6] + apply (wp) + apply (wp hoare_convert_imp)[1] apply (wpc, wp+) apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) - apply (wpsimp wp: stateAssert_wp)+ - done - -lemma blockedCancelIPC_ResumeCurrentThread_imp_notct[wp]: - "blockedCancelIPC a b c \\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - unfolding blockedCancelIPC_def getBlockingObject_def - apply (wpsimp wp: hoare_vcg_imp_lift' getEndpoint_wp) - done - -crunch cancelIPC - for ResumeCurrentThread_imp_notct[wp]: "\s. ksSchedulerAction s = ResumeCurrentThread - \ ksCurThread s \ t" - -lemma tcbEPFindIndex_wp: - "\\s. (\i j. 0 \ i \ i \ Suc sz \ - (\tcb tcba. ko_at' tcb tptr s \ ko_at' tcba (queue ! j) s \ - (Suc j = i \ tcbPriority tcba \ tcbPriority tcb) \ - (i < j \ j \ sz \ tcbPriority tcba < tcbPriority tcb) \ Q i s))\ - tcbEPFindIndex tptr queue sz \Q\" - apply (induct sz; subst tcbEPFindIndex.simps) - apply (wpsimp wp: threadGet_wp) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb) - apply (wpsimp wp: threadGet_wp | assumption)+ - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb) - done - -crunch tcbEPAppend, tcbEPDequeue - for inv[wp]: P - -lemma tcbEPAppend_rv_wf: - "\\\ tcbEPAppend t q \\rv s. set rv = set (t#q)\" - apply (simp only: tcbEPAppend_def) - apply (wp tcbEPFindIndex_wp) - apply (auto simp: null_def set_append[symmetric]) - done - -lemma tcbEPAppend_rv_wf': - "\P (set (t#q))\ tcbEPAppend t q \\rv. P (set rv)\" - apply (clarsimp simp: valid_def) - apply (frule use_valid[OF _ tcbEPAppend_rv_wf], simp, simp) - apply (frule use_valid[OF _ tcbEPAppend_inv, where P = "P (set (t#q))"], simp+) - done - -lemma tcbEPAppend_rv_wf'': - "\P (ep_q_refs_of' (updateEpQueue ep (t#q))) and K (ep \ IdleEP)\ - tcbEPAppend t q - \\rv. P (ep_q_refs_of' (updateEpQueue ep rv))\" - by (cases ep; wpsimp wp: tcbEPAppend_rv_wf' simp: updateEpQueue_def) - -lemma tcbEPDequeue_rv_wf: - "\\_. t \ set q \ distinct q\ tcbEPDequeue t q \\rv s. set rv = set q - {t}\" - apply (wpsimp simp: tcbEPDequeue_def) - apply (fastforce dest: findIndex_member) - done - -lemma tcbEPDequeue_rv_wf': - "\P (set q - {t}) and K (t \ set q \ distinct q)\ tcbEPDequeue t q \\rv. P (set rv)\" - apply (clarsimp simp: valid_def) - apply (frule use_valid[OF _ tcbEPDequeue_rv_wf], simp, simp) - apply (frule use_valid[OF _ tcbEPDequeue_inv, where P = "P (set q - {t})"], simp+) - done - -lemma tcbEPDequeue_rv_wf'': - "\P (ep_q_refs_of' (updateEpQueue ep q)) and K (t \ set q \ distinct q \ ep \ IdleEP)\ - tcbEPDequeue t q - \\rv. P (ep_q_refs_of' (updateEpQueue ep (t#rv)))\" - by (cases ep; wpsimp wp: tcbEPDequeue_rv_wf' simp: Times_Diff_distrib1 insert_absorb updateEpQueue_def) - -lemma tcbEPAppend_not_null[wp]: - "\\\ tcbEPAppend t q \\rv _. rv \ []\" - by (wpsimp simp: tcbEPAppend_def split_del: if_split) - -lemma tcbEPAppend_distinct[wp]: - "\\s. distinct q \ t \ set q\ tcbEPAppend t q \\q' s. distinct q'\" - apply (simp only: tcbEPAppend_def) - apply (wpsimp wp: tcbEPFindIndex_wp) - apply (auto simp: set_take_disj_set_drop_if_distinct dest: in_set_dropD in_set_takeD) - done - -lemma tcbEPAppend_valid_SendEP: - "\valid_ep' (SendEP (t#q)) and K (t \ set q)\ tcbEPAppend t q \\q'. valid_ep' (SendEP q')\" - apply (simp only: tcbEPAppend_def) - apply (case_tac q; wpsimp wp: tcbEPFindIndex_wp) - apply (fastforce simp: valid_ep'_def set_take_disj_set_drop_if_distinct - dest: in_set_takeD in_set_dropD) - done - -lemma tcbEPAppend_valid_RecvEP: - "\valid_ep' (RecvEP (t#q)) and K (t \ set q)\ tcbEPAppend t q \\q'. valid_ep' (RecvEP q')\" - apply (simp only: tcbEPAppend_def) - apply (case_tac q; wpsimp wp: tcbEPFindIndex_wp) - apply (fastforce simp: valid_ep'_def set_take_disj_set_drop_if_distinct - dest: in_set_takeD in_set_dropD) - 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'))\" - apply (wpsimp simp: tcbEPDequeue_def valid_ep'_def) - apply (fastforce simp: findIndex_def findIndex'_app - dest: in_set_takeD in_set_dropD findIndex_member) - done - -lemma tcbEPDequeue_valid_RecvEP: - "\valid_ep' (RecvEP q) and K (t \ set q)\ tcbEPDequeue t q \\q'. valid_ep' (RecvEP (t#q'))\" - apply (wpsimp simp: tcbEPDequeue_def valid_ep'_def) - apply (fastforce simp: findIndex_def findIndex'_app - dest: in_set_takeD in_set_dropD findIndex_member) - done - -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) - -crunch receiveIPC - for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps transferCapsToSlots_pres1 hoare_vcg_all_lift - simp: crunch_simps zipWithM_x_mapM ignore: constOnFailure) - -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\ - setThreadState Running t - \\rv. invs'\" - apply (wpsimp wp: sts_invs') - apply (simp add: invs'_def valid_dom_schedule'_def pred_tcb_at'_eq_commute) - apply (fastforce dest: global'_no_ex_cap - simp: o_def pred_tcb_at'_def obj_at'_def) - 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\ - 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 (clarsimp dest: global'_no_ex_cap - simp: valid_tcb_state'_def 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_invs'[wp]: - "tcbReleaseEnqueue tcb \invs'\" - apply (clarsimp simp: getScTime_def getTCBSc_def tcbReleaseEnqueue_def - getReleaseQueue_def setReleaseQueue_def setReprogramTimer_def) - apply (clarsimp simp: invs'_def valid_dom_schedule'_def split del: if_split) - apply (wp threadSet_valid_pspace'T threadSet_sch_actT_P[where P=False, simplified] - threadSet_iflive'T threadSet_ifunsafe'T threadSet_idle'T threadSet_not_inQ - valid_irq_node_lift valid_irq_handlers_lift'' threadSet_ct_idle_or_in_cur_domain' - threadSet_cur untyped_ranges_zero_lift threadSet_valid_queues threadSet_valid_queues' - | rule refl threadSet_wp [THEN hoare_vcg_conj_lift] - | clarsimp simp: tcb_cte_cases_def cteCaps_of_def)+ - apply (clarsimp simp: ksReleaseQueue_ksReprogramTimer_update - ksPSpace_ksReprogramTimer_update if_cancel_eq_True) - apply (wpsimp wp: mapM_wp_lift getScTime_wp threadGet_wp)+ - apply (clarsimp simp: invs'_def comp_def obj_at'_def inQ_def cteCaps_of_def) - apply (intro conjI) - apply (clarsimp simp: valid_release_queue_def obj_at'_def projectKOs objBitsKO_def)+ - apply (intro conjI impI; clarsimp) - apply (auto split: if_splits elim: ps_clear_domE)[3] - apply (drule_tac x=a in spec, drule mp) - apply (rule_tac ys=rvs in tup_in_fst_image_set_zipD) - apply (clarsimp simp: image_def) - apply (rule_tac x="(a,b)" in bexI) - apply (auto split: if_splits elim: ps_clear_domE)[3] - apply (drule_tac x=a in spec, drule mp) - apply (rule_tac ys=rvs in tup_in_fst_image_set_zipD) - apply (clarsimp simp: image_def) - apply (rule_tac x="(a,b)" in bexI) - apply (auto split: if_splits elim: ps_clear_domE)[3] - apply (clarsimp simp: valid_release_queue'_def) - apply (erule_tac x=t in allE) - apply (drule mp) - apply (fastforce simp: obj_at'_def projectKO_eq projectKO_tcb objBitsKO_def inQ_def - elim: ps_clear_domE split: if_splits) - apply (clarsimp simp: image_def in_set_conv_decomp zip_append1) - apply (rule_tac x="hd (drop (length ys) rvs)" in exI) - apply (case_tac "drop (length ys) rvs"; fastforce dest: list_all2_lengthD) - done - -crunch postpone, schedContextResume - for invs'[wp]: invs' - (wp: crunch_wps) - -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 projectKOs sym_refs_asrt_def) - apply (rename_tac tcb) - apply (rule_tac x=tcb in exI, clarsimp) - 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 projectKOs) - apply (auto simp: refs_of_rev' ko_wp_at'_def live_sc'_def) + apply (wp) + apply (rule_tac Q'="\_. ?PRE t'" in hoare_post_imp, clarsimp) + apply (wp) + apply simp done +qed -lemma simple'_not_is_BlockedOnReply: - "simple' st \ \ is_BlockedOnReply st" - by (clarsimp simp: is_BlockedOnReply_def) +crunch setMRs + for nosch[wp]: "\s. P (ksSchedulerAction s)" lemma sai_invs'[wp]: "\invs' and ex_nonz_cap_to' ntfnptr\ - sendSignal ntfnptr badge - \\y. invs'\" - (is "valid ?pre _ _") - apply (simp add: sendSignal_def) - apply (rule bind_wp[OF _ stateAssert_sp]) + sendSignal ntfnptr badge \\y. invs'\" + unfolding sendSignal_def + including classic_wp_pre 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) - \ \IdleNtfn\ - apply (case_tac "ntfnBoundTCB nTFN"; clarsimp) - apply (wp setNotification_invs') - apply (clarsimp simp: valid_ntfn'_def) - apply (wp isSchedulable_wp) - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: isSchedulable_bool_def isSchedulable_bool_runnableE) - apply (wpsimp wp: maybeDonateSc_invs' setThreadState_Running_invs' - setNotification_invs' gts_wp' cancelIPC_simple - 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) - \ \ActiveNtfn\ - apply (wpsimp wp: setNotification_invs' simp: valid_ntfn'_def) - \ \WaitingNtfn\ - apply (rename_tac list) - apply (case_tac list; clarsimp) - apply (wp isSchedulable_wp) - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: isSchedulable_bool_def isSchedulable_bool_runnableE) - 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) - 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 projectKOs) - apply (fastforce simp: valid_obj'_def valid_ntfn'_def) - done + apply (case_tac "ntfnObj nTFN", simp_all) + prefer 3 + apply (rename_tac list) + apply (case_tac list, + simp_all split del: if_split + add: setMessageInfo_def)[1] + apply (rule hoare_pre) + apply (wp hoare_convert_imp [OF asUser_nosch] + hoare_convert_imp [OF setMRs_sch_act])+ + apply (clarsimp simp:conj_comms) + apply (simp add: invs'_def valid_state'_def) + apply ((wp valid_irq_node_lift sts_valid_objs' setThreadState_ct_not_inQ + set_ntfn_valid_objs' cur_tcb_lift sts_st_tcb' + hoare_convert_imp [OF setNotification_nosch] + | simp split del: if_split)+)[3] + + apply (intro conjI[rotated]; + (solves \clarsimp simp: invs'_def valid_state'_def valid_pspace'_def\)?) + apply clarsimp + apply (clarsimp simp: invs'_def valid_state'_def split del: if_split) + apply (drule(1) ct_not_in_ntfnQueue, simp+) + apply clarsimp + apply (frule ko_at_valid_objs', clarsimp) + apply (simp add: projectKOs) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def + split: list.splits) + apply (clarsimp simp: invs'_def valid_state'_def) + apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_idle'_def pred_tcb_at'_def idle_tcb'_def + dest!: sym_refs_ko_atD' sym_refs_st_tcb_atD' sym_refs_obj_atD' + split: list.splits) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + apply (frule(1) ko_at_valid_objs') + apply (simp add: projectKOs) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def + split: list.splits option.splits) + apply (clarsimp elim!: if_live_then_nonz_capE' simp:invs'_def valid_state'_def) + apply (drule(1) sym_refs_ko_atD') + apply (clarsimp elim!: ko_wp_at'_weakenE + intro!: refs_of_live') + apply (clarsimp split del: if_split)+ + apply (frule ko_at_valid_objs', clarsimp) + apply (simp add: projectKOs) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) + apply (frule invs_sym') + apply (drule(1) sym_refs_obj_atD') + apply (clarsimp split del: if_split cong: if_cong + simp: st_tcb_at_refs_of_rev' ep_redux_simps' ntfn_bound_refs'_def) + apply (frule st_tcb_at_state_refs_ofD') + apply (erule delta_sym_refs) + apply (fastforce simp: split: if_split_asm) + apply (fastforce simp: tcb_bound_refs'_def set_eq_subset symreftype_inverse' + split: if_split_asm) + apply (clarsimp simp:invs'_def) + apply (frule ko_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def valid_state'_def) + apply (simp add: projectKOs) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def split del: if_split) + apply (clarsimp simp:invs'_def valid_state'_def valid_pspace'_def) + apply (frule(1) ko_at_valid_objs') + apply (simp add: projectKOs) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def + split: list.splits option.splits) + apply (case_tac "ntfnBoundTCB nTFN", simp_all) + apply (wp set_ntfn_minor_invs') + apply (fastforce simp: valid_ntfn'_def invs'_def valid_state'_def + elim!: obj_at'_weakenE + dest!: global'_no_ex_cap) + apply (wp add: hoare_convert_imp [OF asUser_nosch] + hoare_convert_imp [OF setMRs_sch_act] + setThreadState_nonqueued_state_update sts_st_tcb' + del: cancelIPC_simple) + apply (clarsimp | wp cancelIPC_ct')+ + apply (wp set_ntfn_minor_invs' gts_wp' | clarsimp)+ + apply (frule pred_tcb_at') + by (wp set_ntfn_minor_invs' + | rule conjI + | clarsimp elim!: st_tcb_ex_cap'' + | fastforce simp: receiveBlocked_def projectKOs pred_tcb_at'_def obj_at'_def + dest!: invs_rct_ct_activatable' + split: thread_state.splits + | fastforce simp: invs'_def valid_state'_def receiveBlocked_def projectKOs + valid_obj'_def valid_ntfn'_def + split: thread_state.splits + dest!: global'_no_ex_cap st_tcb_ex_cap'' ko_at_valid_objs')+ lemma replyFromKernel_corres: "corres dc (tcb_at t and invs) invs' @@ -4035,1090 +3085,476 @@ lemma rfk_invs': crunch replyFromKernel for nosch[wp]: "\s. P (ksSchedulerAction s)" -lemma set_tcb_obj_ref_ntfns_of[wp]: - "set_tcb_obj_ref f t new \\s. P (ntfns_of s)\" - by (wpsimp simp: set_tcb_obj_ref_def wp: set_object_wp) - (fastforce dest!: get_tcb_SomeD elim!: rsubst[where P=P] simp: opt_map_def - split: option.splits Structures_A.kernel_object.splits)+ - -lemma update_sched_context_ntfns_of[wp]: - "update_sched_context f' scp \\s. P (ntfns_of s)\" - by (wpsimp simp: update_sched_context_def wp: set_object_wp get_object_wp) - (fastforce elim!: rsubst[where P=P] simp: opt_map_def obj_at_def - split: option.splits Structures_A.kernel_object.splits)+ - -crunch maybe_donate_sc - for ntfn_at[wp]: "ntfn_at ntfnp" - and ntfns_of[wp]: "\s. P (ntfns_of s)" - (simp: crunch_simps wp: crunch_wps set_object_wp ignore: set_tcb_obj_ref) - -crunch maybeDonateSc - for ntfn_at'[wp]: "ntfn_at' ntfnp" - and tcb_at'[wp]: "\s. P (tcb_at' tp s)" - (simp: crunch_simps wp: crunch_wps) - lemma completeSignal_corres: - "corres dc - (ntfn_at ntfnptr and tcb_at tcb 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)" + "corres dc (ntfn_at ntfnptr and tcb_at tcb and pspace_aligned and pspace_distinct and valid_objs + \ \and obj_at (\ko. ko = Notification ntfn \ Ipc_A.isActive ntfn) ntfnptr*\ ) + (ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' and obj_at' isActive ntfnptr) + (complete_signal ntfnptr tcb) (completeSignal ntfnptr tcb)" apply (simp add: complete_signal_def completeSignal_def) apply (rule corres_guard_imp) - apply (rule_tac R'="\ntfn. ntfn_at' ntfnptr and tcb_at' tcb and invs' - and valid_ntfn' ntfn and (\_. isActive ntfn)" - in corres_split[OF getNotification_corres]) + apply (rule_tac R'="\ntfn. ntfn_at' ntfnptr and tcb_at' tcb and valid_pspace' + and valid_ntfn' ntfn and (\_. isActive ntfn)" + in corres_split[OF getNotification_corres]) apply (rule corres_gen_asm2) apply (case_tac "ntfn_obj rv") apply (clarsimp simp: ntfn_relation_def isActive_def split: ntfn.splits Structures_H.notification.splits)+ apply (rule corres_guard2_imp) apply (simp add: badgeRegister_def badge_register_def) - apply (rule corres_split[OF asUser_setRegister_corres]) - apply (rule corres_split[OF setNotification_corres]) - 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 valid_queues - and valid_queues' and valid_release_queue_iff" - 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'" - 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 active_scs_valid - and pspace_aligned and pspace_distinct" - and P'="ko_at' sc' scp and ntfn_at' ntfnptr and valid_objs'" - in corres_inst) - apply (rule 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: obj_at_def is_ntfn) - apply (drule active_scs_validE[rotated]) - apply (fastforce simp: vs_all_heap_simps is_sc_obj elim!: opt_mapE) - apply (clarsimp simp: valid_refills_def vs_all_heap_simps rr_valid_refills_def - opt_pred_def - elim!: opt_mapE) - apply (clarsimp elim!: opt_mapE) - apply (erule valid_objs'_valid_refills', clarsimp simp: obj_at'_def) - apply (clarsimp dest!: valid_objs'_valid_refills' - simp: opt_map_red opt_pred_def is_active_sc'_def obj_at'_def projectKOs) - 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 projectKOs pred_tcb_at'_def dest!: sym[of "Some _"]) - apply (erule (1) valid_objsE'[where x=tcb]) - apply (clarsimp simp: obj_at'_def projectKOs 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'" - 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 - apply wpsimp - apply (wpsimp simp: valid_ntfn_def) - apply (clarsimp simp: live'_def 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 (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_pspace'_def invs'_def) - apply (frule (1) ntfn_ko_at_valid_objs_valid_ntfn') - apply (clarsimp simp: obj_at'_def projectKOs) - done - -lemma ntfn_relation_par_inj: - "ntfn_relation ntfn ntfn' \ ntfn_sc ntfn = ntfnSc ntfn'" - by (simp add: ntfn_relation_def) - -lemma thread_set_weak_valid_sched_action2: - "\weak_valid_sched_action and scheduler_act_not tptr\ thread_set f tptr \\rv. weak_valid_sched_action\" - apply (wpsimp wp: thread_set_wp simp: obj_at_kh_kheap_simps vs_all_heap_simps fun_upd_def - weak_valid_sched_action_def) - apply (clarsimp simp: weak_valid_sched_action_def scheduler_act_not_def) - apply (rule_tac x=ref' in exI; clarsimp) - done - -lemma notQueued_cross_rel: - "cross_rel (not_queued t) (notQueued t)" - unfolding cross_rel_def state_relation_def - by (clarsimp simp: notQueued_def ready_queues_relation_def not_queued_def) - -lemma valid_tcb_sched_context_update_empty[elim!]: - "valid_tcb tp tcb s \ valid_tcb tp (tcb_sched_context_update Map.empty tcb) s" - by (auto simp: valid_tcb_def tcb_cap_cases_def) - -lemma valid_tcb'_SchedContext_update_empty[elim!]: - "valid_tcb' tcb s' \ valid_tcb' (tcbSchedContext_update Map.empty tcb) s'" - by (auto simp: valid_tcb'_def valid_cap'_def tcb_cte_cases_def) - -lemma maybeReturnSc_corres: - "corres dc - (ntfn_at ntfnPtr and tcb_at thread and valid_tcbs and pspace_aligned - 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 (\s. sym_refs (state_refs_of s))) - (valid_tcbs' and valid_queues and valid_queues' and valid_release_queue_iff) - (maybe_return_sc ntfnPtr thread) - (maybeReturnSc ntfnPtr thread)" - unfolding maybe_return_sc_def maybeReturnSc_def - apply add_sym_refs - apply (rule corres_stateAssert_assume) - apply (clarsimp simp: liftM_def get_sk_obj_ref_def get_tcb_obj_ref_def - set_tcb_obj_ref_thread_set) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[OF getNotification_corres]) - apply (frule ntfn_relation_par_inj[symmetric], simp) - apply (rule corres_split[OF threadGet_corres[where r="(=)"]]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_when2, simp) - apply (rule corres_assert_opt_assume_l) - apply (rule corres_split[OF threadset_corresT]) - apply (clarsimp simp: tcb_relation_def) - apply (rule ball_tcb_cap_casesI; simp) - apply (clarsimp simp: tcb_cte_cases_def) - apply (rule_tac Q'="\" in corres_symb_exec_r') - apply (rule corres_split) - apply (rule update_sc_no_reply_stack_update_ko_at'_corres - [where f'="scTCB_update (\_. None)"]) - apply ((clarsimp simp: sc_relation_def objBits_def objBitsKO_def)+)[4] - 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: hoare_vcg_imp_lift' thread_set_weak_valid_sched_action2) - apply (wpsimp wp: hoare_drop_imp threadSet_valid_queues_no_state - threadSet_valid_queues' threadSet_valid_release_queue - threadSet_valid_tcbs' - threadSet_valid_release_queue') - apply (wpsimp wp: thread_get_wp threadGet_wp)+ - apply (frule ntfn_relation_par_inj, simp) - 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 (rule cross_rel_srE [OF tcb_at'_cross_rel [where t=thread]]; simp) - apply (rule cross_rel_srE [OF ntfn_at'_cross_rel [where t=ntfnPtr]], simp) - apply (rule cross_rel_srE [OF notQueued_cross_rel [where t=thread]], simp) - apply clarsimp - apply (subgoal_tac "\tcb. ko_at' (tcb :: tcb) thread s'", clarsimp) - apply (rule_tac x=tcb in exI, clarsimp) - apply (clarsimp simp: notQueued_def) - apply (clarsimp simp: valid_release_queue'_def inQ_def) - apply (intro conjI) - apply clarsimp - apply (clarsimp simp: obj_at'_def valid_release_queue'_def) - apply (subgoal_tac "valid_tcb' tcb s'") - apply (clarsimp simp: valid_tcb'_def valid_bound_obj'_def split: option.splits) - apply (clarsimp simp: valid_tcbs'_def obj_at'_real_def ko_wp_at'_def projectKO_tcb) - apply (clarsimp simp: obj_at'_def) - apply (clarsimp simp: sym_refs_asrt_def) + apply (rule corres_split[OF asUser_setRegister_corres setNotification_corres]) + apply (clarsimp simp: ntfn_relation_def) + apply (wp set_simple_ko_valid_objs get_simple_ko_wp getNotification_wp | clarsimp simp: valid_ntfn'_def)+ + apply (clarsimp simp: valid_pspace'_def) + apply (frule_tac P="(\k. k = ntfn)" in obj_at_valid_objs', assumption) + apply (clarsimp simp: projectKOs valid_obj'_def valid_ntfn'_def obj_at'_def) done -lemma tcbEPDequeue_corres: - "qs = qs' \ corres (=) \ \ (tcb_ep_dequeue t qs) (tcbEPDequeue t qs')" - by (clarsimp simp: tcb_ep_dequeue_def tcbEPDequeue_def) lemma doNBRecvFailedTransfer_corres: - "corres dc (pspace_aligned and pspace_distinct and tcb_at thread) \ - (do_nbrecv_failed_transfer thread) (doNBRecvFailedTransfer thread)" - apply (rule corres_cross[where Q' = "tcb_at' thread", OF tcb_at'_cross_rel], simp) - apply (clarsimp simp: do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def) - apply (rule corres_guard_imp) - apply (clarsimp simp: badge_register_def badgeRegister_def) - apply (rule asUser_setRegister_corres) - apply clarsimp+ - done + "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) \ + (do_nbrecv_failed_transfer thread) + (doNBRecvFailedTransfer thread)" + unfolding do_nbrecv_failed_transfer_def doNBRecvFailedTransfer_def + by (corres corres: asUser_setRegister_corres + simp: badgeRegister_def badge_register_def)+ -crunch maybe_return_sc - for tcb_at[wp]: "tcb_at thread" - (wp: crunch_wps simp: crunch_simps) - -lemma maybeReturnSc_valid_objs'[wp]: - "maybeReturnSc ntfnPtr tcbPtr \valid_objs'\" - apply (clarsimp simp: maybeReturnSc_def) - apply (wpsimp wp: threadSet_valid_objs' threadGet_wp getNotification_wp - hoare_vcg_all_lift hoare_vcg_imp_lift') - apply (clarsimp dest!: ntfn_ko_at_valid_objs_valid_ntfn' - simp: obj_at'_def projectKOs) - apply (rename_tac tcb) - apply (rule_tac x=tcb in exI) +lemma receiveIPC_corres: + assumes "is_ep_cap cap" and "cap_relation cap cap'" + shows " + corres dc (einvs and valid_sched and tcb_at thread and valid_cap cap and ex_nonz_cap_to thread + and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3)) + (invs' and tcb_at' thread and valid_cap' cap') + (receive_ipc thread cap isBlocking) (receiveIPC thread cap' isBlocking)" + apply (insert assms) + apply (simp add: receive_ipc_def receiveIPC_def + split del: if_split) + apply (case_tac cap, simp_all add: isEndpointCap_def) + apply (rename_tac word1 word2 right) apply clarsimp - apply (rename_tac sc sc_ptr) - apply (prop_tac "ko_at' sc (the (tcbSchedContext tcb)) s") - apply (clarsimp simp: obj_at'_def projectKOs) - apply (fastforce dest!: sc_ko_at_valid_objs_valid_sc' - simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getEndpoint_corres]) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getBoundNotification_corres]) + apply (rule_tac r'="ntfn_relation" in corres_split) + apply (rule corres_option_split[rotated 2]) + apply (rule getNotification_corres) + apply clarsimp + apply (rule corres_trivial, simp add: ntfn_relation_def default_notification_def + default_ntfn_def) + apply (rule corres_if) + apply (clarsimp simp: ntfn_relation_def Ipc_A.isActive_def Endpoint_H.isActive_def + split: Structures_A.ntfn.splits Structures_H.notification.splits) + apply clarsimp + apply (rule completeSignal_corres) + apply (rule_tac P="einvs and valid_sched and tcb_at thread and + ep_at word1 and valid_ep ep and + obj_at (\k. k = Endpoint ep) word1 + and cte_wp_at (\c. c = cap.NullCap) (thread, tcb_cnode_index 3) + and ex_nonz_cap_to thread" and + P'="invs' and tcb_at' thread and ep_at' word1 and + valid_ep' epa" + in corres_inst) + apply (case_tac ep) + \ \IdleEP\ + apply (simp add: ep_relation_def) + apply (rule corres_guard_imp) + apply (case_tac isBlocking; simp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setEndpoint_corres) + apply (simp add: ep_relation_def) + apply wp+ + apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) + apply simp + apply (clarsimp simp add: invs_def valid_state_def valid_pspace_def + valid_tcb_state_def st_tcb_at_tcb_at) + apply auto[1] + \ \SendEP\ + apply (simp add: ep_relation_def) + apply (rename_tac list) + apply (rule_tac F="list \ []" in corres_req) + apply (clarsimp simp: valid_ep_def) + apply (case_tac list, simp_all split del: if_split)[1] + apply (rule corres_guard_imp) + apply (rule corres_split[OF setEndpoint_corres]) + apply (case_tac lista, simp_all add: ep_relation_def)[1] + apply (rule corres_split[OF getThreadState_corres]) + apply (rule_tac + F="\data. + sender_state = + Structures_A.thread_state.BlockedOnSend word1 data" + in corres_gen_asm) + apply (clarsimp simp: isSend_def case_bool_If + case_option_If if3_fold + split del: if_split cong: if_cong) + apply (rule corres_split[OF doIPCTransfer_corres]) + apply (simp split del: if_split cong: if_cong) + apply (fold dc_def)[1] + apply (rule_tac P="valid_objs and valid_mdb and valid_list + and valid_sched + and cur_tcb + and valid_reply_caps + and pspace_aligned and pspace_distinct + and st_tcb_at (Not \ awaiting_reply) a + and st_tcb_at (Not \ halted) a + and tcb_at thread and valid_reply_masters + and cte_wp_at (\c. c = cap.NullCap) + (thread, tcb_cnode_index 3)" + and P'="tcb_at' a and tcb_at' thread and cur_tcb' + and valid_pspace' + and valid_objs' + and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and sym_heap_sched_pointers and valid_sched_pointers + and pspace_aligned' and pspace_distinct'" + in corres_guard_imp [OF corres_if]) + apply (simp add: fault_rel_optionation_def) + apply (rule corres_if2 [OF _ setupCallerCap_corres setThreadState_corres]) + apply simp + apply simp + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule possibleSwitchTo_corres) + apply (wpsimp wp: sts_st_tcb_at' set_thread_state_runnable_weak_valid_sched_action)+ + apply (wp sts_st_tcb_at'_cases sts_valid_objs' setThreadState_st_tcb + | simp)+ + apply (fastforce simp: st_tcb_at_tcb_at st_tcb_def2 valid_sched_def + valid_sched_action_def) + apply (clarsimp split: if_split_asm) + apply (clarsimp | wp do_ipc_transfer_tcb_caps)+ + apply (rule_tac Q'="\_ s. sch_act_wf (ksSchedulerAction s) s + \ sym_heap_sched_pointers s \ valid_sched_pointers s + \ pspace_aligned' s \ pspace_distinct' s" + in hoare_post_imp) + apply (fastforce elim: sch_act_wf_weak) + apply (wp sts_st_tcb' gts_st_tcb_at | simp)+ + apply (simp cong: list.case_cong) + apply wp + apply simp + apply (wp weak_sch_act_wf_lift_linear setEndpoint_valid_mdb' set_ep_valid_objs') + apply (clarsimp split: list.split) + apply (clarsimp simp add: invs_def valid_state_def st_tcb_at_tcb_at) + apply (clarsimp simp add: valid_ep_def valid_pspace_def) + apply (drule(1) sym_refs_obj_atD[where P="\ko. ko = Endpoint e" for e]) + apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) + apply (auto simp: valid_ep'_def invs'_def valid_state'_def split: list.split)[1] + \ \RecvEP\ + apply (simp add: ep_relation_def) + apply (rule_tac corres_guard_imp) + apply (case_tac isBlocking; simp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setEndpoint_corres) + apply (simp add: ep_relation_def) + apply wp+ + apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, simp) + apply simp + apply (fastforce simp: valid_tcb_state_def) + apply (clarsimp simp add: valid_tcb_state'_def) + apply (wp get_simple_ko_wp[where f=Notification] getNotification_wp gbn_wp gbn_wp' + hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_if_lift + | wpc | simp add: ep_at_def2[symmetric, simplified] | clarsimp)+ + apply (fastforce simp: valid_cap_def invs_psp_aligned invs_valid_objs pred_tcb_at_def + valid_obj_def valid_tcb_def valid_bound_ntfn_def + elim!: obj_at_valid_objsE + split: option.splits) + apply (auto simp: valid_cap'_def invs_valid_pspace' valid_obj'_def valid_tcb'_def + valid_bound_ntfn'_def obj_at'_def projectKOs pred_tcb_at'_def + dest!: invs_valid_objs' obj_at_valid_objs' + split: option.splits) done -lemma maybeReturnSc_valid_tcbs'[wp]: - "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') - apply (fastforce simp: obj_at'_def projectKOs) +lemma receiveSignal_corres: + "\ is_ntfn_cap cap; cap_relation cap cap' \ \ + corres dc (invs and st_tcb_at active thread and valid_cap cap and ex_nonz_cap_to thread) + (invs' and tcb_at' thread and valid_cap' cap') + (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" + apply (simp add: receive_signal_def receiveSignal_def) + apply (case_tac cap, simp_all add: isEndpointCap_def) + apply (rename_tac word1 word2 rights) + apply (rule corres_guard_imp) + apply (rule_tac R="\rv. invs and tcb_at thread and st_tcb_at active thread and + ntfn_at word1 and ex_nonz_cap_to thread and + valid_ntfn rv and + obj_at (\k. k = Notification rv) word1" and + R'="\rv'. invs' and tcb_at' thread and ntfn_at' word1 and + valid_ntfn' rv'" + in corres_split[OF getNotification_corres]) + apply clarsimp + apply (case_tac "ntfn_obj rv") + \ \IdleNtfn\ + apply (simp add: ntfn_relation_def) + apply (rule corres_guard_imp) + apply (case_tac isBlocking; simp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setNotification_corres) + apply (simp add: ntfn_relation_def) + apply wp+ + apply (rule corres_guard_imp, rule doNBRecvFailedTransfer_corres, fastforce+) + \ \WaitingNtfn\ + apply (simp add: ntfn_relation_def) + apply (rule corres_guard_imp) + apply (case_tac isBlocking; simp) + apply (rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule setNotification_corres) + apply (simp add: ntfn_relation_def) + apply wp+ + apply (rule corres_guard_imp) + apply (rule doNBRecvFailedTransfer_corres, fastforce+) + \ \ActiveNtfn\ + apply (simp add: ntfn_relation_def) + apply (rule corres_guard_imp) + apply (simp add: badgeRegister_def badge_register_def) + apply (rule corres_split[OF asUser_setRegister_corres]) + apply (rule setNotification_corres) + apply (simp add: ntfn_relation_def) + apply wp+ + apply (fastforce simp: invs_def valid_state_def valid_pspace_def + elim!: st_tcb_weakenE) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def) + apply wp+ + apply (clarsimp simp add: ntfn_at_def2 valid_cap_def st_tcb_at_tcb_at) + apply (clarsimp simp add: valid_cap'_def) + done + +lemma tg_sp': + "\P\ threadGet f p \\t. obj_at' (\t'. f t' = t) p and P\" + including no_pre + apply (simp add: threadGet_def) + apply wp + apply (rule hoare_strengthen_post) + apply (rule getObject_tcb_sp) + apply clarsimp + apply (erule obj_at'_weakenE) + apply simp done -lemma maybeReturnSc_valid_queues: - "\valid_queues and valid_tcbs'\ - maybeReturnSc ntfnPtr tcbPtr - \\_. valid_queues\" - apply (clarsimp simp: maybeReturnSc_def) - apply (wpsimp wp: hoare_drop_imps) - apply (wpsimp wp: threadSet_valid_queues_new hoare_vcg_if_lift2 - getNotification_wp threadGet_wp)+ - apply (clarsimp simp: obj_at'_def inQ_def) - done +declare lookup_cap_valid' [wp] -crunch maybeReturnSc - for valid_queues'[wp]: valid_queues' - and valid_release_queue[wp]: valid_release_queue - (wp: crunch_wps simp: crunch_simps inQ_def) - -lemma maybeReturnSc_valid_release_queue': - "\valid_release_queue' and valid_tcbs'\ - maybeReturnSc ntfnPtr tcbPtr - \\_. valid_release_queue'\" - (is "valid ?pre _ _") - apply (clarsimp simp: maybeReturnSc_def liftM_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (rule bind_wp[OF _ threadGet_sp]) - apply (rule hoare_when_cases; clarsimp) - apply (rule_tac Q'="\_. ?pre" in bind_wp_fwd) - apply (wpsimp wp: threadSet_valid_release_queue' threadSet_valid_objs') - apply (clarsimp simp: obj_at'_def valid_release_queue'_def) - apply wpsimp +lemma sendFaultIPC_corres: + "valid_fault f \ fr f f' \ + corres (fr \ dc) + (einvs and st_tcb_at active thread and ex_nonz_cap_to thread) + (invs' and sch_act_not thread and tcb_at' thread) + (send_fault_ipc thread f) (sendFaultIPC thread f')" + apply (simp add: send_fault_ipc_def sendFaultIPC_def + liftE_bindE Let_def) + apply (rule corres_guard_imp) + apply (rule corres_split [where r'="\fh fh'. fh = to_bl fh'"]) + apply (rule threadGet_corres) + apply (simp add: tcb_relation_def) + apply simp + apply (rule corres_splitEE) + apply (rule corres_cap_fault) + apply (rule lookup_cap_corres, rule refl) + apply (rule_tac P="einvs and st_tcb_at active thread + and valid_cap handler_cap and ex_nonz_cap_to thread" + and P'="invs' and tcb_at' thread and sch_act_not thread + and valid_cap' handlerCap" + in corres_inst) + apply (case_tac handler_cap, + simp_all add: isCap_defs lookup_failure_map_def + case_bool_If If_rearrage + split del: if_split cong: if_cong)[1] + apply (rule corres_guard_imp) + apply (rule corres_if2 [OF refl]) + apply (simp add: dc_def[symmetric]) + apply (rule corres_split[OF threadset_corres sendIPC_corres], simp_all)[1] + apply (simp add: tcb_relation_def fault_rel_optionation_def exst_same_def)+ + apply (wp thread_set_invs_trivial thread_set_no_change_tcb_state + thread_set_typ_at ep_at_typ_at ex_nonz_cap_to_pres + thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched + | simp add: tcb_cap_cases_def)+ + apply ((wp threadSet_invs_trivial threadSet_tcb' + | simp add: tcb_cte_cases_def + | wp (once) sch_act_sane_lift)+)[1] + apply (rule corres_trivial, simp add: lookup_failure_map_def) + apply (clarsimp simp: st_tcb_at_tcb_at split: if_split) + apply (fastforce simp: valid_cap_def) + apply (clarsimp simp: valid_cap'_def inQ_def) + apply auto[1] + apply (clarsimp simp: lookup_failure_map_def) + apply wp+ + apply (fastforce elim: st_tcb_at_tcb_at) + apply fastforce done -lemma maybe_return_sc_weak_valid_sched_action: - "\weak_valid_sched_action and scheduler_act_not tcb_ptr and tcb_at tcb_ptr\ - maybe_return_sc ntfn_ptr tcb_ptr - \\_. weak_valid_sched_action\" - apply (clarsimp simp: maybe_return_sc_def) - apply (wpsimp wp: set_object_wp thread_get_wp get_simple_ko_wp - simp: set_tcb_obj_ref_def get_tcb_obj_ref_def get_sk_obj_ref_def) - apply (clarsimp simp: obj_at_def is_tcb_def) - apply (rename_tac tcb, case_tac tcb; clarsimp) - apply (fastforce simp: weak_valid_sched_action_def scheduler_act_not_def vs_all_heap_simps) +lemma gets_the_noop_corres: + assumes P: "\s. P s \ f s \ None" + shows "corres dc P P' (gets_the f) (return x)" + apply (clarsimp simp: corres_underlying_def gets_the_def + return_def gets_def bind_def get_def) + apply (clarsimp simp: assert_opt_def return_def dest!: P) done -lemma maybeReturnSc_invs'_and_valid_idle': - "\invs' and valid_idle' and (\s. tptr \ ksIdleThread s)\ - maybeReturnSc nptr tptr - \\_. invs' and valid_idle'\" - apply (wpsimp wp: setSchedContext_invs' simp: maybeReturnSc_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' - threadSet_valid_queues threadSet_valid_queues' threadSet_valid_release_queue - threadSet_valid_release_queue' threadGet_wp getNotification_wp - hoare_vcg_imp_lift' hoare_vcg_all_lift valid_dom_schedule'_lift - | clarsimp simp: tcb_cte_cases_def cteCaps_of_def)+ - apply (clarsimp simp: obj_at'_def projectKOs) - apply (rename_tac ntfn tcb) - 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 (fastforce simp: valid_release_queue'_def obj_at'_def projectKOs) - apply (fastforce simp: valid_release_queue'_def obj_at'_def projectKOs) - apply (clarsimp simp: untyped_ranges_zero_inv_def cteCaps_of_def comp_def) - apply (clarsimp simp: valid_idle'_def obj_at'_def projectKOs sym_refs_asrt_def) - apply (drule_tac ko="tcb" and p=tptr in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def projectKOs) - apply (clarsimp simp: ko_wp_at'_def refs_of_rev') - apply (fastforce elim: if_live_then_nonz_capE' simp: ko_wp_at'_def live_sc'_def) - apply (fastforce simp: valid_pspace'_def valid_obj'_def valid_sched_context'_def) - apply (fastforce simp: valid_obj'_def valid_sched_context_size'_def objBits_def objBitsKO_def) - apply (clarsimp simp: valid_idle'_def obj_at'_def projectKOs sym_refs_asrt_def) - apply (drule_tac ko="tcb" and p=tptr in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def projectKOs) - apply (clarsimp simp: ko_wp_at'_def refs_of_rev') +lemma handleDoubleFault_corres: + "corres dc (tcb_at thread and pspace_aligned and pspace_distinct) + \ + (handle_double_fault thread f ft) + (handleDoubleFault thread f' ft')" + apply (rule corres_cross_over_guard[where Q="tcb_at' thread"]) + apply (fastforce intro!: tcb_at_cross) + apply (simp add: handle_double_fault_def handleDoubleFault_def) + apply (rule corres_guard_imp) + apply (subst bind_return [symmetric], + rule corres_split[OF setThreadState_corres]) + apply simp + apply (rule corres_noop2) + apply (simp add: exs_valid_def return_def) + apply (rule hoare_eq_P) + apply wp + apply (rule asUser_inv) + apply (rule getRestartPC_inv) + apply (wp no_fail_getRestartPC)+ + apply (wp|simp)+ done -lemma - shows - maybeReturnSc_invs': - "\invs' and valid_idle' and (\s. tptr \ ksIdleThread s)\ - maybeReturnSc nptr tptr - \\_. invs'\" - and maybeReturnSc_valid_idle': - "\invs' and valid_idle' and (\s. tptr \ ksIdleThread s)\ - maybeReturnSc nptr tptr - \\_. valid_idle'\" - by (fastforce intro: hoare_strengthen_post[OF maybeReturnSc_invs'_and_valid_idle'])+ +crunch sendFaultIPC + for tcb'[wp]: "tcb_at' t" (wp: crunch_wps) -crunch doIPCTransfer - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - and no_0_obj'[wp]: no_0_obj' - and vrq[wp]: valid_release_queue - and vrq'[wp]: valid_release_queue' - (wp: crunch_wps simp: zipWithM_x_mapM_x) +crunch receiveIPC + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) -definition receiveIPC_preamble where - "receiveIPC_preamble replyCap thread \ - case replyCap of NullCap \ return Nothing - | ReplyCap r _ \ - (do tptrOpt <- liftM replyTCB (getReply (r)); - when (tptrOpt \ Nothing \ tptrOpt \ Some thread) $ cancelIPC (the tptrOpt); - return (Just r) - od) - | _ \ haskell_fail []" - -crunch maybe_return_sc - for ep_at[wp]: "ep_at epptr" - (wp: crunch_wps simp: crunch_simps) +lemmas receiveIPC_typ_ats[wp] = typ_at_lifts [OF receiveIPC_typ_at'] -lemma thread_set_cap_to_fault_helper: - "(a, b, c) \ ran tcb_cap_cases \ a (tcb_fault_update h tcb) = a tcb" - by (clarsimp simp: tcb_cap_cases_def, fastforce) +crunch receiveSignal + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) -crunch cancel_ipc - for ep_at[wp]: "ep_at epptr" - and reply_at[wp]: "reply_at rptr" - and ex_nonz_cap_to[wp]: "ex_nonz_cap_to t" - (simp: crunch_simps thread_set_cap_to_fault_helper - wp: crunch_wps thread_set_cap_to) +lemmas receiveAIPC_typ_ats[wp] = typ_at_lifts [OF receiveSignal_typ_at'] -crunch doIPCTransfer - for replySCs_of[wp]: "\s. P (replySCs_of s)" - and replyTCBs_of[wp]: "\s. P (replyTCBs_of s)" - (wp: crunch_wps simp: zipWithM_x_mapM_x) +declare cart_singleton_empty[simp] -crunch receive_ipc_preamble - for ep_at[wp]: "ep_at epptr" - and valid_list[wp]: valid_list - and tcb_at[wp]: "tcb_at t" - 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" - -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'\" - unfolding receiveIPC_preamble_def - by (case_tac replyCap; wpsimp) - -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' - (receive_ipc_preamble reply_cap thread) - (receiveIPC_preamble replyCap thread)" - supply if_split [split del] - apply (insert assms) - apply (clarsimp simp: receive_ipc_preamble_def receiveIPC_preamble_def) - apply (case_tac reply_cap; simp add: is_reply_cap_def) - apply (rule stronger_corres_guard_imp) - apply (clarsimp simp: liftM_def) - apply (rule corres_split[OF get_reply_corres]) - apply (rule corres_split[OF _ corres_return_eq_same[OF refl], where r'=dc]) - apply (rule corres_when2) - apply (clarsimp simp: reply_relation_def) - apply (rename_tac r, case_tac "replyTCB r"; simp) - apply (rename_tac r r') - apply (subgoal_tac "replyTCB r' = reply_tcb r", simp) - apply (rule cancel_ipc_corres) - apply (clarsimp simp: reply_relation_def) - apply wpsimp - apply wpsimp - apply (wpsimp wp: get_simple_ko_wp) - apply (wpsimp wp: getReply_wp) - apply (clarsimp simp: valid_cap_def) - apply (frule (1) valid_objs_ko_at[OF invs_valid_objs]) - apply (clarsimp simp: valid_obj_def valid_reply_def) - apply (clarsimp simp: valid_cap_def) - apply (erule cross_relF[OF _ reply_at'_cross_rel]) - apply fastforce - done +declare cart_singleton_empty2[simp] -lemma ri_preamble_vbreply: - "receive_ipc_preamble_rv reply_cap replyOpt s \ valid_bound_reply replyOpt s" - by (case_tac replyOpt; clarsimp elim!: reply_at_ppred_reply_at) - -lemma ri_preamble_not_in_sc: - "\sym_refs (state_refs_of s); - valid_replies s; - receive_ipc_preamble_rv reply_cap replyOpt s\ - \ valid_bound_obj (\a b. a \ fst ` replies_with_sc b) replyOpt s" - apply (case_tac replyOpt; simp) - apply (erule (1) no_tcb_not_in_replies_with_sc, simp) - done +crunch setupCallerCap + for aligned'[wp]: "pspace_aligned'" + (wp: crunch_wps) +crunch setupCallerCap + for distinct'[wp]: "pspace_distinct'" + (wp: crunch_wps) +crunch setupCallerCap + for cur_tcb[wp]: "cur_tcb'" + (wp: crunch_wps) -lemma receiveIPC_corres_helper: - "(do replyOpt <- - case replyCap of capability.NullCap \ return Nothing - | capability.ReplyCap r v18 \ return (Just r) - | _ \ haskell_fail []; - y <- - when (\y. replyOpt = Some y) - (do tptrOpt <- liftM replyTCB (getReply (the replyOpt)); - when ((\y. tptrOpt = Some y) \ tptrOpt \ Some thread) - (cancelIPC (the tptrOpt)) - od); - f replyOpt - od) = (do replyOpt <- - case replyCap of capability.NullCap \ return Nothing - | capability.ReplyCap r _ \ - (do tptrOpt <- liftM replyTCB (getReply (r)); - when (tptrOpt \ Nothing \ tptrOpt \ Some thread) $ cancelIPC (the tptrOpt); - return (Just r) - od) - | _ \ haskell_fail []; - f replyOpt - 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 +lemma setupCallerCap_state_refs_of[wp]: + "\\s. P ((state_refs_of' s) (sender := {r \ state_refs_of' s sender. snd r = TCBBound}))\ + setupCallerCap sender rcvr grant + \\rv s. P (state_refs_of' s)\" + apply (simp add: setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def) + apply (wp hoare_drop_imps) + apply (simp add: fun_upd_def cong: if_cong) done -lemma 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 setupCallerCap + for sch_act_wf: "\s. sch_act_wf (ksSchedulerAction s) s" + (wp: crunch_wps ssa_sch_act sts_sch_act rule: sch_act_wf_lift) -lemma receiveIPC_preamble_valid_idle': - "\\s. valid_idle' s \ thread \ ksIdleThread s \ sym_refs (state_refs_of' s)\ - receiveIPC_preamble replyCap thread - \\_. valid_idle'\" - 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 valid_idle'_def idle_tcb'_def) +lemma is_derived_ReplyCap' [simp]: + "\m p g. is_derived' m p (capability.ReplyCap t False g) = + (\c. \ g. c = capability.ReplyCap t True g)" + apply (subst fun_eq_iff) + apply clarsimp + apply (case_tac x, simp_all add: is_derived'_def isCap_simps + badge_derived'_def + vsCapRef_def) done -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) - -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)" - 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) _ _ _") - apply add_sch_act_wf - apply add_valid_idle' - apply add_cur_tcb' - supply if_split [split del] - apply (insert assms) - apply (rule corres_cross_add_abs_guard[where Q="K (thread \ idle_thread_ptr)"]) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - 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_assume[rotated]) - 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 valid_idle' and (\s. sch_act_wf (ksSchedulerAction s) s) - and cur_tcb' 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 fastforce - \ \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_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 cur_tcb' - and valid_queues - and valid_queues' - and valid_release_queue - and valid_release_queue' - and valid_objs' - and valid_bound_obj' valid_replies'_sc_asrt replyOpt - and cur_tcb' - 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) - 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 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 (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 - 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 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 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 - 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) - 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) - apply (rule_tac Q'="\ya. (\s. tcb_at' sender s \ - tcb_at' thread s \ - cur_tcb' s \ - valid_queues s \ - valid_queues' s \ - valid_release_queue s \ - valid_release_queue' s \ - valid_objs' s \ - valid_bound_obj' valid_replies'_sc_asrt replyOpt - s \ - cur_tcb' s \ - sch_act_wf (ksSchedulerAction s) s)" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: sch_act_wf_weak obj_at'_def projectKOs 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) - apply (clarsimp simp: pred_conj_def cong: conj_cong) - apply (wpsimp wp: valid_replies'_sc_asrt_lift valid_bound_obj'_lift) - 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 (clarsimp split: list.split) - apply (frule (2) ri_preamble_not_in_sc) - apply (frule_tac y=sender in valid_sched_scheduler_act_not_better) - apply (fastforce simp: st_tcb_at_refs_of_rev elim: st_tcb_weakenE) - apply (prop_tac "ex_nonz_cap_to epptr s") - apply (fastforce simp: live_def obj_at_def is_ep elim!: if_live_then_nonz_capD2) - apply (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 simp: invs_def valid_pspace_def valid_state_def valid_ep_def) - apply (fastforce elim: ri_preamble_vbreply reply_at_ppred_reply_at) - apply (clarsimp simp: invs'_def valid_pspace'_def valid_ep'_def) - 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' maybeReturnSc_valid_idle' valid_case_option_post_wp) - apply simp - 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 (\s. thread \ idle_thread s) - and valid_sched and ?tat and ?tex - 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 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 valid_idle' - and (\s. sch_act_wf (ksSchedulerAction s) s) and - (\_. thread \ idle_thread_ptr) and valid_bound_reply' replyOpt - and cur_tcb'" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: invs'_def valid_pspace'_def split: if_split)[1] - apply (subgoal_tac "thread \ ksIdleThread s \ (\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 fastforce - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - apply (intro conjI; clarsimp) - apply (clarsimp simp: valid_idle'_def) - 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 receiveIPC_preamble_valid_idle') - apply clarsimp - apply (clarsimp simp: valid_cap_def valid_idle_def invs_def valid_state_def valid_sched_def) - apply (clarsimp simp: valid_cap'_def valid_idle'_def) - apply (simp add: sym_refs_asrt_def) - done +lemma unique_master_reply_cap': + "\c t. isReplyCap c \ capReplyMaster c \ capTCBPtr c = t \ + (\g . c = capability.ReplyCap t True g)" + by (fastforce simp: isCap_simps conj_comms) -lemma 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) - (valid_tcbs' and valid_queues and valid_queues' and valid_release_queue_iff) - (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 isSchedulable_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: isSchedulable_wp)+ +lemma getSlotCap_cte_wp_at: + "\\\ getSlotCap sl \\rv. cte_wp_at' (\c. cteCap c = rv) sl\" + apply (simp add: getSlotCap_def) + apply (wp getCTE_wp) + apply (clarsimp simp: cte_wp_at_ctes_of) done -lemma as_user_refs_of[wp]: - "as_user thread f \\s. obj_at (\ko. P (refs_of ko)) ptr s\" - apply (clarsimp simp: as_user_def) - apply (wpsimp wp: set_object_wp) - apply (clarsimp simp: obj_at_def) - apply (erule rsubst[where P=P]) - apply (clarsimp simp: get_tcb_def get_refs_def2 tcb_st_refs_of_def - split: Structures_A.kernel_object.splits) - done +crunch setThreadState + for no_0_obj'[wp]: no_0_obj' -lemma receiveSignal_corres: - "\ is_ntfn_cap cap; cap_relation cap cap' \ \ - corres dc ((invs and weak_valid_sched_action and scheduler_act_not thread and valid_ready_qs - and st_tcb_at active thread and active_scs_valid and valid_release_q - and current_time_bounded and (\s. thread = cur_thread s) and not_queued thread - and not_in_release_q thread and ex_nonz_cap_to thread) and valid_cap cap) - (invs' and tcb_at' thread and ex_nonz_cap_to' thread and valid_cap' cap') - (receive_signal thread cap isBlocking) (receiveSignal thread cap' isBlocking)" - (is "\_;_\ \ corres _ (?pred and _) _ _ _") - apply (simp add: receive_signal_def receiveSignal_def) - apply add_sym_refs - 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 valid_release_queue_iff 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 projectKOs 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 (clarsimp simp: ntfn_relation_def) - apply (rule maybeReturnSc_corres) - apply (wpsimp wp: maybe_return_sc_weak_valid_sched_action) - 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 (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 (clarsimp simp: ntfn_relation_def) - apply (rule maybeReturnSc_corres) - apply (wpsimp wp: maybe_return_sc_weak_valid_sched_action) - 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 (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 valid_ntfn'_def) - apply (corresKsimp corres: doNBRecvFailedTransfer_corres) - 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 (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 - split: option.splits) - 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 projectKOs 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 (frule_tac p=cap_ntfn_ptr in sym_refs_ko_atD[rotated]) - apply (fastforce simp: obj_at_def) +lemma setupCallerCap_vp[wp]: + "\valid_pspace' and tcb_at' sender and tcb_at' rcvr\ + setupCallerCap sender rcvr grant \\rv. valid_pspace'\" + apply (simp add: valid_pspace'_def setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv getSlotCap_def) + apply (wp getCTE_wp) + apply (rule_tac Q'="\_. valid_pspace' and + tcb_at' sender and tcb_at' rcvr" + in hoare_post_imp) + apply (clarsimp simp: valid_cap'_def o_def cte_wp_at_ctes_of isCap_simps + valid_pspace'_def) + apply (frule(1) ctes_of_valid', simp add: valid_cap'_def capAligned_def) apply clarsimp - apply (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 projectKOs live_ntfn'_def ko_wp_at'_def) + apply (wp | simp add: valid_pspace'_def valid_tcb_state'_def)+ done -declare lookup_cap_valid' [wp] - -lemma thread_set_fault_valid_sched_except_blocked_except_released_ipc_qs[wp]: - "thread_set (tcb_fault_update f) t \valid_sched_except_blocked_except_released_ipc_qs\" - by (wpsimp wp: thread_set_fault_valid_sched_pred simp: valid_sched_2_def) +declare haskell_assert_inv[wp del] -lemma sendFaultIPC_corres: - assumes "fr f f'" - assumes "cap_relation cap cap'" - shows - "corres (fr \ (=)) - (invs and valid_list and valid_sched_action and active_scs_valid - and st_tcb_at active thread and scheduler_act_not thread - and current_time_bounded - and (\s. can_donate \ bound_sc_tcb_at (\sc. sc \ None) thread s) - and valid_cap cap and K (valid_fault_handler cap) and K (valid_fault f)) - (invs' and valid_cap' cap') - (send_fault_ipc thread cap f can_donate) - (sendFaultIPC thread cap' f' can_donate)" - using assms - apply (clarsimp simp: send_fault_ipc_def sendFaultIPC_def) - apply (rule corres_gen_asm) - apply (rule corres_gen_asm) - apply (cases cap; simp add: valid_fault_handler_def tcb_relation_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split) - apply (rule threadset_corres; clarsimp simp: tcb_relation_def fault_rel_optionation_def) - apply (rule corres_split) - apply (rule sendIPC_corres, clarsimp) - apply (rule corres_trivial, clarsimp) - 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 - simp: ran_tcb_cap_cases valid_cap_def)+ - apply (frule pred_tcb_at_tcb_at, clarsimp) - apply (erule (1) st_tcb_ex_cap[OF _ invs_iflive]) - apply (case_tac st; clarsimp) - apply (clarsimp, frule pred_tcb_at_tcb_at) - apply (frule cross_relF[OF _ tcb_at'_cross_rel[where t=thread]], fastforce) - apply (fastforce simp: invs'_def valid_tcb_def valid_release_queue_def - valid_release_queue'_def valid_cap'_def obj_at'_def inQ_def) - done - -lemma gets_the_noop_corres: - assumes P: "\s. P s \ f s \ None" - shows "corres dc P P' (gets_the f) (return x)" - apply (clarsimp simp: corres_underlying_def gets_the_def - return_def gets_def bind_def get_def) - apply (clarsimp simp: assert_opt_def return_def dest!: P) - done +lemma setupCallerCap_iflive[wp]: + "\if_live_then_nonz_cap' and ex_nonz_cap_to' sender and pspace_aligned' and pspace_distinct'\ + setupCallerCap sender rcvr grant + \\rv. if_live_then_nonz_cap'\" + unfolding setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv + by (wp getSlotCap_cte_wp_at + | simp add: unique_master_reply_cap' + | strengthen eq_imp_strg + | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ + +lemma setupCallerCap_ifunsafe[wp]: + "\if_unsafe_then_cap' and valid_objs' and + ex_nonz_cap_to' rcvr and tcb_at' rcvr and pspace_aligned' and pspace_distinct'\ + setupCallerCap sender rcvr grant + \\rv. if_unsafe_then_cap'\" + unfolding setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv + apply (wp getSlotCap_cte_wp_at + | simp add: unique_master_reply_cap' | strengthen eq_imp_strg + | wp (once) hoare_drop_imp[where f="getCTE rs" for rs])+ + apply (rule_tac Q'="\rv. valid_objs' and tcb_at' rcvr and ex_nonz_cap_to' rcvr" + in hoare_post_imp) + apply (clarsimp simp: ex_nonz_tcb_cte_caps' tcbCallerSlot_def + objBits_def objBitsKO_def dom_def cte_level_bits_def) + apply (wp sts_valid_objs' | simp)+ + apply (clarsimp simp: valid_tcb_state'_def)+ + done + +lemma setupCallerCap_global_refs'[wp]: + "\valid_global_refs'\ + setupCallerCap sender rcvr grant + \\rv. valid_global_refs'\" + unfolding setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv + by (wp + | simp add: o_def unique_master_reply_cap' + | strengthen eq_imp_strg + | wp (once) getCTE_wp + | wp (once) hoare_vcg_imp_lift' hoare_vcg_ex_lift | clarsimp simp: cte_wp_at_ctes_of)+ + +crunch setupCallerCap + for valid_arch'[wp]: "valid_arch_state'" + (wp: hoare_drop_imps) -end +crunch setupCallerCap + for typ'[wp]: "\s. P (typ_at' T p s)" -crunch sendFaultIPC, receiveIPC, receiveSignal - 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 hoare_vcg_all_lift simp: crunch_simps) - -global_interpretation sendFaultIPC: typ_at_all_props' "sendFaultIPC t cap f d" - by typ_at_props' -global_interpretation receiveIPC: typ_at_all_props' "receiveIPC t cap b r" - by typ_at_props' -global_interpretation receiveSignal: typ_at_all_props' "receiveSignal t cap b" - by typ_at_props' - -lemma setCTE_valid_queues[wp]: - "\Invariants_H.valid_queues\ setCTE ptr val \\rv. Invariants_H.valid_queues\" - by (wp valid_queues_lift setCTE_pred_tcb_at') - -crunch cteInsert - for vq[wp]: "Invariants_H.valid_queues" - (wp: crunch_wps) +crunch setupCallerCap + for irq_node'[wp]: "\s. P (irq_node' s)" + (wp: hoare_drop_imps) -lemma getSlotCap_cte_wp_at: - "\\\ getSlotCap sl \\rv. cte_wp_at' (\c. cteCap c = rv) sl\" - apply (simp add: getSlotCap_def) - apply (wp getCTE_wp) - apply (clarsimp simp: cte_wp_at_ctes_of) - done +lemma setupCallerCap_irq_handlers'[wp]: + "\valid_irq_handlers'\ + setupCallerCap sender rcvr grant + \\rv. valid_irq_handlers'\" + unfolding setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def locateSlot_conv + by (wp hoare_drop_imps | simp)+ lemma cteInsert_cap_to': "\ex_nonz_cap_to' p and cte_wp_at' (\c. cteCap c = NullCap) dest\ @@ -5139,9 +3575,10 @@ lemma cteInsert_cap_to': apply (clarsimp simp: cte_wp_at_ctes_of)+ done -context begin interpretation Arch . (*FIXME: arch_split*) +crunch setExtraBadge + for cap_to'[wp]: "ex_nonz_cap_to' p" -crunch setExtraBadge, doIPCTransfer +crunch doIPCTransfer for cap_to'[wp]: "ex_nonz_cap_to' p" (ignore: transferCapsToSlots wp: crunch_wps transferCapsToSlots_pres2 cteInsert_cap_to' hoare_vcg_const_Ball_lift @@ -5152,985 +3589,579 @@ 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 getThreadCallerSlot + for idle'[wp]: "valid_idle'" +crunch getThreadReplySlot + for idle'[wp]: "valid_idle'" -crunch setExtraBadge, receiveIPC +crunch setupCallerCap + for it[wp]: "\s. P (ksIdleThread s)" + (simp: updateObject_cte_inv wp: crunch_wps) + +lemma setupCallerCap_idle'[wp]: + "\valid_idle' and valid_pspace' and + (\s. st \ ksIdleThread s \ rt \ ksIdleThread s)\ + setupCallerCap st rt gr + \\_. valid_idle'\" + by (simp add: setupCallerCap_def capRange_def | wp hoare_drop_imps)+ + +crunch doIPCTransfer + for idle'[wp]: "valid_idle'" + (wp: crunch_wps simp: crunch_simps ignore: transferCapsToSlots) + +crunch setExtraBadge + for it[wp]: "\s. P (ksIdleThread s)" +crunch receiveIPC for it[wp]: "\s. P (ksIdleThread s)" - and irqs_masked' [wp]: "irqs_masked'" (ignore: transferCapsToSlots - wp: transferCapsToSlots_pres2 crunch_wps hoare_vcg_all_lift + wp: transferCapsToSlots_pres2 crunch_wps hoare_vcg_const_Ball_lift simp: crunch_simps ball_conj_distrib) -crunch copyMRs, doIPCTransfer +crunch setupCallerCap + for irq_states'[wp]: valid_irq_states' + (wp: crunch_wps) + +crunch setupCallerCap + for pde_mappings'[wp]: valid_pde_mappings' + (wp: crunch_wps) + +crunch receiveIPC + for irqs_masked'[wp]: "irqs_masked'" + (wp: crunch_wps rule: irqs_masked_lift) + +crunch getThreadCallerSlot + for ct_not_inQ[wp]: "ct_not_inQ" +crunch getThreadReplySlot + for ct_not_inQ[wp]: "ct_not_inQ" + +lemma setupCallerCap_ct_not_inQ[wp]: + "\ct_not_inQ\ setupCallerCap sender receiver grant \\_. ct_not_inQ\" + apply (simp add: setupCallerCap_def) + apply (wp hoare_drop_imp setThreadState_ct_not_inQ) + done + +crunch copyMRs for ksQ'[wp]: "\s. P (ksReadyQueues s)" - and ct'[wp]: "\s. P (ksCurThread s)" (wp: mapM_wp' hoare_drop_imps simp: crunch_simps) +crunch doIPCTransfer + for ksQ[wp]: "\s. P (ksReadyQueues s)" + (wp: hoare_drop_imps hoare_vcg_split_case_option + mapM_wp' + simp: split_def zipWithM_x_mapM) + +crunch doIPCTransfer + for ct'[wp]: "\s. P (ksCurThread s)" + (wp: hoare_drop_imps hoare_vcg_split_case_option + mapM_wp' + simp: split_def zipWithM_x_mapM) + lemma asUser_ct_not_inQ[wp]: - "\ct_not_inQ\ asUser tptr f \\rv. ct_not_inQ\" + "\ct_not_inQ\ asUser t m \\rv. ct_not_inQ\" apply (simp add: asUser_def split_def) apply (wp hoare_drop_imps threadSet_not_inQ | simp)+ done -crunch copyMRs, doIPCTransfer +crunch copyMRs 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')" +crunch doIPCTransfer + for ct_not_inQ[wp]: "ct_not_inQ" + (ignore: getRestartPC setRegister transferCapsToSlots + wp: hoare_drop_imps hoare_vcg_split_case_option + mapM_wp' + simp: split_def zipWithM_x_mapM) + +lemma ntfn_q_refs_no_bound_refs': "rf : ntfn_q_refs_of' (ntfnObj ob) \ rf ~: ntfn_bound_refs' (ntfnBoundTCB ob')" by (auto simp add: ntfn_q_refs_of'_def ntfn_bound_refs'_def split: Structures_H.ntfn.splits) -lemma completeSignal_invs': - "\invs' and tcb_at' tcb and ex_nonz_cap_to' tcb\ - completeSignal ntfnptr tcb +lemma completeSignal_invs: + "\invs' and tcb_at' tcb\ + completeSignal ntfnptr tcb \\_. invs'\" apply (simp add: completeSignal_def) apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (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 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 projectKOs live_ntfn'_def) - done + apply (rule hoare_pre) + apply (wp set_ntfn_minor_invs' | wpc | simp)+ + apply (rule_tac Q'="\_ s. (state_refs_of' s ntfnptr = ntfn_bound_refs' (ntfnBoundTCB ntfn)) + \ ntfn_at' ntfnptr s + \ valid_ntfn' (ntfnObj_update (\_. Structures_H.ntfn.IdleNtfn) ntfn) s + \ ((\y. ntfnBoundTCB ntfn = Some y) \ ex_nonz_cap_to' ntfnptr s) + \ ntfnptr \ ksIdleThread s" + in hoare_strengthen_post) + apply ((wp hoare_vcg_ex_lift hoare_weak_lift_imp | wpc | simp add: valid_ntfn'_def)+)[1] + apply (clarsimp simp: obj_at'_def state_refs_of'_def typ_at'_def ko_wp_at'_def projectKOs split: option.splits) + apply (blast dest: ntfn_q_refs_no_bound_refs') + apply wp + apply (subgoal_tac "valid_ntfn' ntfn s") + apply (subgoal_tac "ntfnptr \ ksIdleThread s") + apply (fastforce simp: valid_ntfn'_def valid_bound_tcb'_def projectKOs ko_at_state_refs_ofD' + elim: obj_at'_weakenE + if_live_then_nonz_capD'[OF invs_iflive' + obj_at'_real_def[THEN meta_eq_to_obj_eq, + THEN iffD1]]) + apply (fastforce simp: valid_idle'_def pred_tcb_at'_def obj_at'_def projectKOs + dest!: invs_valid_idle') + apply (fastforce dest: invs_valid_objs' ko_at_valid_objs' + simp: valid_obj'_def projectKOs)[1] + done + +lemma setupCallerCap_urz[wp]: + "\untyped_ranges_zero' and valid_pspace' and tcb_at' sender\ + setupCallerCap sender t g \\rv. untyped_ranges_zero'\" + apply (simp add: setupCallerCap_def getSlotCap_def + getThreadCallerSlot_def getThreadReplySlot_def + locateSlot_conv) + apply (wp getCTE_wp') + apply (rule_tac Q'="\_. untyped_ranges_zero' and valid_mdb' and valid_objs'" in hoare_post_imp) + apply (clarsimp simp: cte_wp_at_ctes_of cteCaps_of_def untyped_derived_eq_def + isCap_simps) + apply (wp sts_valid_pspace_hangers) + apply (clarsimp simp: valid_tcb_state'_def) + done + +lemmas threadSet_urz = untyped_ranges_zero_lift[where f="cteCaps_of", OF _ threadSet_cteCaps_of] -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 - simp: maybeReturnSc_def tcb_cte_cases_def cteCaps_of_def) - -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 doIPCTransfer + for urz[wp]: "untyped_ranges_zero'" + (ignore: threadSet wp: threadSet_urz crunch_wps simp: zipWithM_x_mapM) + +crunch receiveIPC + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: crunch_wps transferCapsToSlots_pres1 simp: zipWithM_x_mapM ignore: constOnFailure) + +crunch possibleSwitchTo + for ctes_of[wp]: "\s. P (ctes_of s)" + (wp: crunch_wps ignore: constOnFailure) +lemmas possibleSwitchToTo_cteCaps_of[wp] + = cteCaps_of_ctes_of_lift[OF possibleSwitchTo_ctes_of] + +crunch asUser + for valid_bitmaps[wp]: valid_bitmaps + (rule: valid_bitmaps_lift wp: crunch_wps) + +crunch setupCallerCap, possibleSwitchTo, doIPCTransfer + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and valid_bitmaps[wp]: valid_bitmaps + (rule: sym_heap_sched_pointers_lift wp: crunch_wps simp: crunch_simps) -crunch doNBRecvFailedTransfer - for invs'[wp]: invs' +(* t = ksCurThread s *) +lemma ri_invs' [wp]: + "\invs' and sch_act_not t + and ct_in_state' simple' + and st_tcb_at' simple' t + and ex_nonz_cap_to' t + and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s)\ + receiveIPC t cap isBlocking + \\_. invs'\" (is "\?pre\ _ \_\") + apply (clarsimp simp: receiveIPC_def) + apply (rule bind_wp [OF _ get_ep_sp']) + apply (rule bind_wp [OF _ gbn_sp']) + apply (rule bind_wp) + (* set up precondition for old proof *) + apply (rule_tac P''="ko_at' ep (capEPPtr cap) and ?pre" in hoare_vcg_if_split) + apply (wp completeSignal_invs) + apply (case_tac ep) + \ \endpoint = RecvEP\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wpc, wp valid_irq_node_lift) + apply (simp add: valid_ep'_def) + apply (wp sts_sch_act' hoare_vcg_const_Ball_lift valid_irq_node_lift + setThreadState_ct_not_inQ + asUser_urz + | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ + apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at' o_def) + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (frule obj_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def) + apply (drule(1) sym_refs_ko_atD') + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (clarsimp simp: st_tcb_at_refs_of_rev' valid_ep'_def + valid_obj'_def projectKOs tcb_bound_refs'_def + dest!: isCapDs) + apply (rule conjI, clarsimp) + apply (drule (1) bspec) + apply (clarsimp dest!: st_tcb_at_state_refs_ofD') + apply (clarsimp simp: set_eq_subset) + apply (rule conjI, erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (rename_tac list one two three fur five six seven eight nine ten eleven) + apply (subgoal_tac "set list \ {EPRecv} \ {}") + apply (safe ; solves \auto\) + apply fastforce + apply fastforce + apply (clarsimp split: if_split_asm) + apply (fastforce simp: valid_pspace'_def global'_no_ex_cap idle'_not_queued) + \ \endpoint = IdleEP\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wpc, wp valid_irq_node_lift) + apply (simp add: valid_ep'_def) + apply (wp sts_sch_act' valid_irq_node_lift + setThreadState_ct_not_inQ + asUser_urz + | simp add: doNBRecvFailedTransfer_def cteCaps_of_def)+ + apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def o_def) + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (subgoal_tac "t \ capEPPtr cap") + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule ko_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (clarsimp dest!: isCapDs) + apply (rule conjI, erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (clarsimp simp: tcb_bound_refs'_def + dest: symreftype_inverse' + split: if_split_asm) + apply (fastforce simp: global'_no_ex_cap) + apply (clarsimp simp: obj_at'_def pred_tcb_at'_def projectKOs) + \ \endpoint = SendEP\ + apply (simp add: invs'_def valid_state'_def) + apply (rename_tac list) + apply (case_tac list, simp_all split del: if_split) + apply (rename_tac sender queue) + apply (rule hoare_pre) + apply (wp valid_irq_node_lift hoare_drop_imps setEndpoint_valid_mdb' + set_ep_valid_objs' sts_st_tcb' sts_sch_act' + setThreadState_ct_not_inQ + possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift + setEndpoint_ksQ setEndpoint_ct' + | simp add: valid_tcb_state'_def case_bool_If + case_option_If + split del: if_split cong: if_cong + | wp (once) sch_act_sane_lift hoare_vcg_conj_lift hoare_vcg_all_lift + untyped_ranges_zero_lift)+ + apply (clarsimp split del: if_split simp: pred_tcb_at') + apply (frule obj_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def) + apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) + apply (drule(1) sym_refs_ko_atD') + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def + st_tcb_at_refs_of_rev' conj_ac + split del: if_split + cong: if_cong) + apply (subgoal_tac "sch_act_not sender s") + prefer 2 + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) + apply (drule st_tcb_at_state_refs_ofD') + apply (simp only: conj_ac(1, 2)[where Q="sym_refs R" for R]) + apply (subgoal_tac "distinct (ksIdleThread s # capEPPtr cap # t # sender # queue)") + apply (rule conjI) + apply (clarsimp simp: ep_redux_simps' cong: if_cong) + apply (erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (fastforce simp: tcb_bound_refs'_def + dest: symreftype_inverse' + split: if_split_asm) + apply (clarsimp simp: singleton_tuple_cartesian split: list.split + | rule conjI | drule(1) bspec + | drule st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' + | clarsimp elim!: if_live_state_refsE)+ + apply (case_tac cap, simp_all add: isEndpointCap_def) + apply (clarsimp simp: global'_no_ex_cap) + apply (rule conjI + | clarsimp simp: singleton_tuple_cartesian split: list.split + | clarsimp elim!: if_live_state_refsE + | clarsimp simp: global'_no_ex_cap idle'_not_queued' idle'_no_refs tcb_bound_refs'_def + | drule(1) bspec | drule st_tcb_at_state_refs_ofD' + | clarsimp simp: set_eq_subset dest!: bound_tcb_at_state_refs_ofD' )+ + apply (rule hoare_pre) + apply (wp getNotification_wp | wpc | clarsimp)+ + done (* t = ksCurThread s *) lemma rai_invs'[wp]: - "\invs' and st_tcb_at' active' t + "\invs' and sch_act_not t + and st_tcb_at' simple' t and ex_nonz_cap_to' t and (\s. \r \ zobj_refs' cap. ex_nonz_cap_to' r s) and (\s. \ntfnptr. isNotificationCap cap \ capNtfnPtr cap = ntfnptr - \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) ntfnptr s)\ - receiveSignal t cap isBlocking + \ obj_at' (\ko. ntfnBoundTCB ko = None \ ntfnBoundTCB ko = Some t) + ntfnptr s)\ + receiveSignal t cap isBlocking \\_. invs'\" - apply (simp add: receiveSignal_def doNBRecvFailedTransfer_def valid_idle'_asrt_def) - apply (intro bind_wp [OF _ stateAssert_sp]) + apply (simp add: receiveSignal_def) apply (rule bind_wp [OF _ get_ntfn_sp']) apply (rename_tac ep) - apply (case_tac "ntfnObj ep"; clarsimp) - \ \IdleNtfn\ - apply (wpsimp wp: setNotification_invs' maybeReturnSc_invs' sts_invs_minor' simp: 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 projectKOs - dest: invs_valid_objs' split: option.splits) - \ \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 projectKOs - dest: invs_valid_objs') - \ \WaitingNtfn\ - apply (wpsimp wp: setNotification_invs' maybeReturnSc_invs') - apply (rule_tac Q'="\_ _. ntfnBoundTCB ep = None" in hoare_post_add) - apply (clarsimp simp: valid_ntfn'_def cong: conj_cong) - apply (wpsimp wp: maybeReturnSc_invs' tcbEPAppend_rv_wf' sts_invs_minor' - hoare_vcg_ball_lift hoare_drop_imps)+ - apply (frule invs_valid_objs') - apply (erule valid_objsE') - apply (fastforce simp: obj_at'_def projectKOs) - 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 projectKOs) - apply (rule conjI, clarsimp) - apply (rule conjI, clarsimp) - apply (rule conjI, clarsimp) - apply (rule context_conjI) - apply (drule_tac ko=ep in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def projectKOs) - apply (fastforce simp: tcb_bound_refs'_def refs_of_rev' get_refs_def ko_wp_at'_def - split: option.splits) - apply (intro conjI) - apply (drule_tac ko=ep in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def projectKOs) - apply (fastforce simp: tcb_bound_refs'_def refs_of_rev' get_refs_def ko_wp_at'_def - split: option.splits) - apply (clarsimp simp: valid_idle'_def idle_tcb'_def) - apply (case_tac "tcbState obj"; clarsimp simp: obj_at_simps) - done - -lemma updateReply_reply_at'_wp: - "\\s. P (if p = rptr then True else reply_at' p s)\ - updateReply rptr f - \\rv s. P (reply_at' p s)\" - apply (rule hoare_weaken_pre, rule updateReply_obj_at') - apply (clarsimp simp: obj_at'_real_def split: if_splits) - done - -crunch setThreadState - for tcbSCs_of[wp]: "\s. P (tcbSCs_of s)" - (ignore: threadSet wp: threadSet_tcbSCs_of_inv) - -crunch replyUnlink - for tcbSCs_of[wp]: "\s. P (tcbSCs_of s)" - and scs_of'[wp]: "\s. P (scs_of' s)" - -lemma replyUnlink_misc_heaps[wp]: - "replyUnlink rPtr tPtr \\s. P (tcbSCs_of s) (scTCBs_of s) (scReplies_of s) (replySCs_of s)\" - by (rule hoare_weaken_pre, wps, wp, simp) - -lemma schedContextUpdateConsumed_scReplies_of[wp]: - "schedContextUpdateConsumed scPtr \\s. P (scReplies_of s) \" - unfolding schedContextUpdateConsumed_def - apply (wpsimp simp: setSchedContext_def) - apply (clarsimp simp: opt_map_def if_distrib) - apply (erule subst[where P=P, rotated], rule ext) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def split: option.splits) - done - -lemma schedContextUpdateConsumed_sc_tcbs_of[wp]: - "schedContextUpdateConsumed scPtr \\s. P (scTCBs_of s)\" - unfolding schedContextUpdateConsumed_def - apply (wpsimp simp: setSchedContext_def) - apply (clarsimp simp: opt_map_def if_distrib) - apply (erule subst[where P=P, rotated], rule ext) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def split: option.splits) - done - -crunch schedContextUpdateConsumed - for tcbSCs_of[wp]: "\s. P (tcbSCs_of s)" - -crunch doIPCTransfer - for replySCs_of[wp]: "\s. P (replySCs_of s)" - (wp: crunch_wps simp: crunch_simps) - -lemma schedContextUpdateConsumed_misc_heaps[wp]: - "schedContextUpdateConsumed scPtr - \\s. P (scReplies_of s) (replySCs_of s) (tcbSCs_of s) (scTCBs_of s)\" - by (rule hoare_weaken_pre, wps, wp, simp) - -crunch doIPCTransfer - for scs_replies_of[wp]: "\s. P (scReplies_of s) (replySCs_of s)" - (wp: crunch_wps ignore: setSchedContext simp: zipWithM_x_mapM) - -crunch doIPCTransfer - for scs_tcbs_of[wp]: "\s. P (tcbSCs_of s) (scTCBs_of s)" - (wp: crunch_wps threadSet_tcbSCs_of_inv ignore: threadSet simp: zipWithM_x_mapM) - -crunch setEndpoint - for misc_heaps[wp]: "\s. P (scReplies_of s) (replySCs_of s) (tcbSCs_of s) (scTCBs_of s)" - (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\ - replyPush callerPtr calleePtr replyPtr canDonate - \\_ s. sym_refs (list_refs_of_replies' s)\" - supply if_split [split del] - unfolding replyPush_def - apply wpsimp - apply (wpsimp wp: bindsym_heap_scReplies_list_refs_of_replies' - hoare_vcg_if_lift2 hoare_vcg_imp_lift' hoare_vcg_all_lift) - apply (rule_tac Q'="(\_ s. sym_refs (list_refs_of_replies' s) \ - (\rptr scp. (scReplies_of s) scp = Some rptr - \ replySCs_of s rptr = Some scp) \ - \ 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 (frule valid_replies'_no_tcb_not_linked; clarsimp) - 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 (clarsimp simp: sym_heap_def pred_map_eq) - done - -lemma replyPush_if_live_then_nonz_cap': - "\ if_live_then_nonz_cap' and valid_objs' and valid_idle' 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)\ - replyPush callerPtr calleePtr replyPtr canDonate - \\_. if_live_then_nonz_cap'\" - supply if_split [split del] - apply (clarsimp simp: replyPush_def bind_assoc) - apply (intro bind_wp[OF _ stateAssert_inv]) - 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 - (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 projectKO_sc pred_map_def pred_map_eq_def - live_sc'_def - elim!: opt_mapE) - 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 projectKOs) - apply (clarsimp simp: valid_idle'_def) - done - -lemma bindScReply_valid_idle': - "\valid_idle' and K (scPtr \ idle_sc_ptr)\ - bindScReply scPtr replyPtr - \\_. valid_idle'\" - unfolding bindScReply_def - by (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift set_reply'.obj_at') - -lemma replyPush_valid_idle': - "\valid_idle' - and valid_pspace' - and (\s. callerPtr \ ksIdleThread s) - and sym_heap_tcbSCs\ - replyPush callerPtr calleePtr replyPtr canDonate - \\_. valid_idle'\" - apply (simp only: replyPush_def) - supply if_split [split del] - apply wpsimp - apply (wpsimp wp: schedContextDonate_valid_idle' bindScReply_valid_idle')+ - apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') - apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift') - apply (wpsimp wp: threadGet_wp)+ - apply (clarsimp simp: tcb_at'_ex_eq_all valid_pspace'_def) - apply (subgoal_tac "\kob. valid_reply' kob s \ valid_reply' (replyTCB_update (\_. Some callerPtr) kob) s") - apply (subgoal_tac "calleePtr \ idle_thread_ptr", simp) - apply (subgoal_tac "y \ idle_sc_ptr", simp) - apply (erule (3) not_idle_scTCB) - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') - apply (clarsimp simp: valid_tcb'_def) - apply (frule (2) not_idle_tcbSC[where p=callerPtr]) - apply (clarsimp simp: valid_idle'_def) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - apply (clarsimp simp: valid_idle'_def idle_tcb'_def obj_at'_real_def ko_wp_at'_def) - apply (clarsimp simp: valid_reply'_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) - apply (rule hoare_lift_Pf[where f="ctes_of"]) - apply wp+ - done - -lemma replyPush_sch_act_wf: - "\\s. sch_act_wf (ksSchedulerAction s) s \ sch_act_not callerPtr s\ - replyPush callerPtr calleePtr replyPtr canDonate - \\_ s. sch_act_wf (ksSchedulerAction s) s\" - unfolding replyPush_def - by (wpsimp wp: sts_sch_act' hoare_vcg_all_lift hoare_vcg_if_lift hoare_drop_imps) - -lemma replyPush_invs': - "\invs' and valid_idle' and sym_heap_tcbSCs and sym_heap_scReplies and - st_tcb_at' (Not \ is_replyState) callerPtr 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)\ - replyPush callerPtr calleePtr replyPtr canDonate - \\_. invs'\" - unfolding invs'_def valid_pspace'_def - apply (wpsimp wp: replyPush_sch_act_wf 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 - -lemma setEndpoint_invs': - "\invs' and valid_ep' ep and ex_nonz_cap_to' eptr\ setEndpoint eptr ep \\_. invs'\" - by (wpsimp simp: invs'_def valid_dom_schedule'_def comp_def) - -crunch maybeReturnSc, cancelIPC - for sch_act_not[wp]: "sch_act_not t" - and sch_act_simple[wp]: "sch_act_simple" - (wp: crunch_wps hoare_drop_imps simp: crunch_simps) - -crunch maybeReturnSc, doIPCTransfer - for replyTCB_obj_at'[wp]: "\s. P (obj_at' (\reply. P' (replyTCB reply)) t s)" - and reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" - (wp: crunch_wps constOnFailure_wp simp: crunch_simps) - -lemma replyUnlink_replyTCBs_of_None[wp]: - "\\s. r \ rptr \ replyTCBs_of s rptr = None\ - replyUnlink r t - \\_ s. replyTCBs_of s rptr = None\" - apply (wpsimp wp: updateReply_wp_all gts_wp' simp: replyUnlink_def) - done - -lemma cancelIPC_replyTCBs_of_None: - "\\s. reply_at' rptr s \ (replyTCBs_of s rptr \ None \ replyTCBs_of s rptr = Some t)\ - cancelIPC t - \\rv s. replyTCBs_of s rptr = None\" - unfolding cancelIPC_def blockedCancelIPC_def getBlockingObject_def - apply (clarsimp simp: sym_refs_asrt_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ gts_sp']) - apply (case_tac state; clarsimp) - \ \BlockedOnReceive\ - apply (wpsimp wp: getEndpoint_wp - hoare_vcg_all_lift hoare_vcg_imp_lift') - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (drule_tac ko="ko :: reply" for ko in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def projectKOs) - apply (clarsimp simp: tcb_st_refs_of'_def tcb_bound_refs'_def - refs_of_rev' get_refs_def ko_wp_at'_def opt_map_def - split: option.splits if_splits) - \ \BlockedOnReply\ - apply (wp gts_wp' updateReply_obj_at'_inv - hoare_vcg_all_lift hoare_vcg_const_imp_lift hoare_vcg_imp_lift' - | rule threadSet_pred_tcb_no_state - | simp add: replyRemoveTCB_def cleanReply_def if_fun_split)+ - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (drule_tac p=rptr and ko="ko :: reply" for ko in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def projectKOs) - apply (clarsimp simp: tcb_st_refs_of'_def tcb_bound_refs'_def - refs_of_rev' get_refs_def ko_wp_at'_def opt_map_def - split: option.splits) - \ \Other thread states\ - apply (all \wpsimp simp: cancelSignal_def sym_refs_asrt_def wp: hoare_drop_imps\) - apply (all \clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs\) - apply (all \drule_tac p=rptr and ko="ko :: reply" for ko in sym_refs_ko_atD'[rotated]\) - apply (fastforce simp: tcb_bound_refs'_def tcb_st_refs_of'_def refs_of_rev' - get_refs_def ko_wp_at'_def obj_at'_def projectKOs - split: option.splits - elim!: opt_mapE)+ - done - -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 projectKOs - 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) - -lemma maybeReturnSc_sym_heap_tcbSCs[wp]: - "\sym_heap_tcbSCs and valid_objs'\ - maybeReturnSc y t - \\_. sym_heap_tcbSCs\" - supply opt_mapE [rule del] - unfolding maybeReturnSc_def - apply (simp add: liftM_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (wpsimp wp: setSchedContext_scTCBs_of threadSet_tcbSCs_of | wps)+ - apply (wpsimp wp: threadGet_wp) - apply (clarsimp simp: tcb_at'_ex_eq_all) - apply (drule sym, simp) - apply (subgoal_tac "(tcbSCs_of s) t = Some (the (tcbSchedContext tcb))") - apply (clarsimp simp: sym_heap_def) - apply (subst (asm) sym_heap_symmetric[simplified sym_heap_def], simp) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def opt_map_def projectKOs) - done - -lemma maybeReturnSc_sym_heap_scReplies[wp]: - "maybeReturnSc y t \sym_heap_scReplies\" - unfolding maybeReturnSc_def - apply (simp add: liftM_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (wpsimp wp: setSchedContext_scReplies_of | wps)+ - apply (wpsimp wp: threadGet_wp) - apply (clarsimp simp: tcb_at'_ex_eq_all) - apply (drule sym, simp) - apply (erule back_subst) - apply (rule arg_cong2[where f=sym_heap, OF _ refl], rule ext) - apply (clarsimp simp: pred_map_eq_def pred_map_def obj_at'_real_def ko_wp_at'_def opt_map_def - projectKOs) - done - -crunch cleanReply - for scTCBs_of[wp]: "\s. P (scTCBs_of s)" - and tcbSCs_of[wp]: "\s. P (tcbSCs_of s)" - -lemma replyRemoveTCB_scTCBs_of[wp]: - "replyRemoveTCB tptr \\s. P (scTCBs_of s)\" - unfolding replyRemoveTCB_def - apply (wpsimp wp: setSchedContext_scTCBs_of gts_wp') - apply (erule back_subst[where P=P], rule ext, clarsimp) - by (clarsimp simp: opt_map_def obj_at'_real_def ko_wp_at'_def) - -lemma replyRemoveTCB_tcbSCs_of[wp]: - "replyRemoveTCB tptr \\s. P (tcbSCs_of s)\" - unfolding replyRemoveTCB_def - by (wpsimp wp: setSchedContext_scTCBs_of gts_wp') - -lemma replyRemoveTCB_sym_heap_tcbSCs[wp]: - "replyRemoveTCB tptr \sym_heap_tcbSCs\" - by (rule hoare_weaken_pre, wps, wpsimp, simp) - -crunch cancelIPC - for sym_heap_tcbSCs[wp]: sym_heap_tcbSCs - (wp: crunch_wps threadSet_tcbSCs_of_inv ignore: setSchedContext threadSet) - -lemma cleanReply_sym_heap_scReplies : - "\\s. sym_heap (scReplies_of s) (\a. if a = rptr then None else replySCs_of s a)\ - cleanReply rptr - \\_. sym_heap_scReplies\" - unfolding cleanReply_def - apply (clarsimp simp: bind_assoc updateReply_def) - apply (wpsimp wp: hoare_drop_imp | wps)+ - done - -lemma replyRemoveTCB_sym_heap_scReplies [wp]: - "\sym_heap_scReplies and (\s. sym_refs (list_refs_of_replies' s))\ - replyRemoveTCB t - \\_. sym_heap_scReplies\" - supply if_split [split del] - unfolding replyRemoveTCB_def - apply (clarsimp simp: bind_assoc updateReply_def) - apply wpsimp - apply (wpsimp wp: cleanReply_sym_heap_scReplies) - apply wp - apply wps - apply wpsimp - apply (rule_tac Q'="\_ s. (replySCs_of s) (the (replyPrev reply)) = None \ - sym_heap (scReplies_of s) (\a. if a = rptr then None else replySCs_of s a)" - in hoare_strengthen_post[rotated], clarsimp) - apply wpsimp - apply (rule_tac Q'="\_ s. (replyPrev reply \ None \ - reply_at' (the (replyPrev reply)) s \ - (replySCs_of s) (the (replyPrev reply)) = None) \ - sym_heap (scReplies_of s) (\a. if a = rptr then None else replySCs_of s a)" - in hoare_strengthen_post[rotated]) - apply (clarsimp split: if_splits simp: obj_at'_def) - apply (wp hoare_vcg_if_lift2 hoare_vcg_imp_lift' hoare_vcg_all_lift) - apply wps - apply (wpsimp wp: setSchedContext_scReplies_of) - apply wpsimp - apply wp - apply wps - apply wpsimp - apply wpsimp - apply wpsimp - apply (rule_tac Q'="\replya s. sym_heap_scReplies s \ sym_refs (list_refs_of_replies' s)" - in hoare_strengthen_post[rotated]) - apply (rename_tac rv s) - apply (clarsimp split: if_splits) - apply (intro conjI; intro allI impI) - apply clarsimp - apply (intro conjI; intro allI impI) - apply (clarsimp simp: isHead_to_head) - apply (intro conjI; intro allI impI) - apply clarsimp - apply (rename_tac replyPtr scPtr sc) - apply (subgoal_tac "replyPrevs_of s rv = Some replyPtr") - apply (rule replyNexts_Some_replySCs_None) - apply (simp add: sym_refs_replyNext_replyPrev_sym[symmetric]) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs opt_map_def) - apply (intro conjI; intro allI impI) - apply clarsimp - apply (drule ko_at'_inj, assumption, simp) - apply (clarsimp simp: isHead_to_head) - apply (rename_tac rPtr) - apply (subgoal_tac "replyPrevs_of s rv = Some rPtr") - apply (insert replyNexts_Some_replySCs_None) - apply (simp add: sym_refs_replyNext_replyPrev_sym[symmetric]) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs opt_map_def) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs opt_map_def) - apply clarsimp - apply (rename_tac replyPtr reply rPtr reply') - apply (subgoal_tac "replyPrevs_of s rv = Some replyPtr") - apply (rule replyNexts_Some_replySCs_None) - apply (simp add: sym_refs_replyNext_replyPrev_sym[symmetric]) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs opt_map_def) - apply (clarsimp simp: isHead_to_head) - apply (erule sym_heap_remove_only) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs opt_map_def pred_map_eq) - apply (clarsimp simp: isHead_to_head) - apply (erule rsubst2[where P=sym_heap, OF _ refl]) - apply (rule ext, clarsimp split: if_split) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs opt_map_def) - apply (intro conjI, intro allI impI) - apply clarsimp - apply (rename_tac replyPtr) - apply (subgoal_tac "replyPrevs_of s rv = Some replyPtr") - apply (rule replyNexts_Some_replySCs_None) - apply (simp add: sym_refs_replyNext_replyPrev_sym[symmetric]) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs opt_map_def) - apply (erule rsubst2[where P=sym_heap, OF _ refl]) - apply (rule ext, clarsimp split: if_split) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs opt_map_def) - apply (wpsimp wp: hoare_drop_imp)+ + apply (case_tac "ntfnObj ep") + \ \ep = IdleNtfn\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp valid_irq_node_lift sts_sch_act' typ_at_lifts + setThreadState_ct_not_inQ + asUser_urz + | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def | wpc)+ + apply (clarsimp simp: pred_tcb_at' valid_tcb_state'_def) + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (subgoal_tac "capNtfnPtr cap \ t") + apply (frule valid_pspace_valid_objs') + apply (frule (1) ko_at_valid_objs') + apply (clarsimp simp: projectKOs) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def) + apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) + apply (drule simple_st_tcb_at_state_refs_ofD' + ko_at_state_refs_ofD' bound_tcb_at_state_refs_ofD')+ + apply (clarsimp dest!: isCapDs) + apply (rule conjI, erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' + split: if_split_asm) + apply (fastforce dest!: global'_no_ex_cap) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) + \ \ep = ActiveNtfn\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp valid_irq_node_lift sts_valid_objs' typ_at_lifts hoare_weak_lift_imp + asUser_urz + | simp add: valid_ntfn'_def)+ + apply (clarsimp simp: pred_tcb_at' valid_pspace'_def) + apply (frule (1) ko_at_valid_objs') + apply (clarsimp simp: projectKOs) + apply (clarsimp simp: valid_obj'_def valid_ntfn'_def isCap_simps) + apply (drule simple_st_tcb_at_state_refs_ofD' + ko_at_state_refs_ofD')+ + apply (erule delta_sym_refs) + apply (clarsimp split: if_split_asm simp: global'_no_ex_cap)+ + \ \ep = WaitingNtfn\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' + setThreadState_ct_not_inQ typ_at_lifts + asUser_urz + | simp add: valid_ntfn'_def doNBRecvFailedTransfer_def | wpc)+ + apply (clarsimp simp: valid_tcb_state'_def) + apply (frule_tac t=t in not_in_ntfnQueue) + apply (simp) + apply (simp) + apply (erule pred_tcb'_weakenE, clarsimp) + apply (frule ko_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def) + apply (simp add: projectKOs) + apply (clarsimp simp: valid_obj'_def) + apply (clarsimp simp: valid_ntfn'_def pred_tcb_at') + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (rule conjI, clarsimp simp: obj_at'_def split: option.split) + apply (drule(1) sym_refs_ko_atD') + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (clarsimp simp: st_tcb_at_refs_of_rev' + dest!: isCapDs) + apply (rule conjI, erule delta_sym_refs) + apply (clarsimp split: if_split_asm) + apply (rename_tac list one two three four five six seven eight nine) + apply (subgoal_tac "set list \ {NTFNSignal} \ {}") + apply safe[1] + apply (auto simp: symreftype_inverse' ntfn_bound_refs'_def tcb_bound_refs'_def)[5] + apply (fastforce simp: tcb_bound_refs'_def + split: if_split_asm) + apply (fastforce dest!: global'_no_ex_cap) done -crunch blockedCancelIPC, cancelSignal - for sym_heap_scReplies[wp]: sym_heap_scReplies - (wp: crunch_wps ignore: setSchedContext setReply updateReply) - -lemma cancelIPC_sym_heap_scReplies [wp]: - "\sym_heap_scReplies and (\s. sym_refs (list_refs_of_replies' s))\ - cancelIPC t - \\_. sym_heap_scReplies\" - unfolding cancelIPC_def - by (wpsimp wp: gts_wp', simp add: comp_def) - -lemma replyTCB_is_not_ksIdleThread: - "\ko_at' reply replyPtr s; the (replyTCB reply) = ksIdleThread s; replyTCB reply = Some tcb; - valid_idle' s; sym_refs (state_refs_of' s)\ - \ False" - apply (frule sym_ref_replyTCB_Receive_or_Reply) - apply blast - apply fastforce - apply (clarsimp simp: st_tcb_at'_def obj_at_simps valid_idle'_def idle_tcb'_def) +lemma getCTE_cap_to_refs[wp]: + "\\\ getCTE p \\rv s. \r\zobj_refs' (cteCap rv). ex_nonz_cap_to' r s\" + apply (rule hoare_strengthen_post [OF getCTE_sp]) + apply (clarsimp simp: ex_nonz_cap_to'_def) + apply (fastforce elim: cte_wp_at_weakenE') done -lemma refillUnblockCheck_sym_heap_tcbSCs[wp]: - "\sym_heap_tcbSCs and valid_objs'\ - refillUnblockCheck scp - \\_. sym_heap_tcbSCs\" - supply opt_mapE [rule del] - unfolding refillUnblockCheck_def refillHeadOverlappingLoop_def mergeRefills_def updateRefillHd_def - apply (wpsimp wp: whileLoop_valid_inv updateSchedContext_wp wp_del: use_corresK - simp: refillPopHead_def) - apply (clarsimp simp: sym_heap_def obj_at'_def projectKOs ps_clear_upd opt_map_red projectKO_opt_tcb) - apply (wpsimp wp: updateSchedContext_wp getCurTime_wp refillReady_wp isRoundRobin_wp - simp: setReprogramTimer_def)+ - apply (clarsimp simp: sym_heap_def obj_at'_def projectKOs ps_clear_upd projectKO_opt_tcb) - apply (rule conjI) - apply (clarsimp simp: opt_map_red) - apply (rule iffI; clarsimp?) - apply (clarsimp simp: opt_map_def split: option.split_asm if_split_asm) - apply (prop_tac "tcb_at' p s") - apply (fastforce simp: valid_obj'_def valid_sched_context'_def) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_def) - apply (drule_tac x=p and y=p' in spec2) - apply (drule sym[of "_ = _"]) - apply (clarsimp simp: opt_map_def projectKOs split: option.splits) +lemma lookupCap_cap_to_refs[wp]: + "\\\ lookupCap t cref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\,-" + apply (simp add: lookupCap_def lookupCapAndSlot_def split_def + getSlotCap_def) + apply (wp | simp)+ done -lemma refillUnblockCheck_sym_heap_scReplies[wp]: - "\sym_heap_scReplies and valid_objs'\ - refillUnblockCheck scp - \\_. sym_heap_scReplies\" - supply opt_mapE [rule del] - unfolding refillUnblockCheck_def refillHeadOverlappingLoop_def mergeRefills_def updateRefillHd_def - apply (wpsimp wp: whileLoop_valid_inv updateSchedContext_wp wp_del: use_corresK - simp: refillPopHead_def) - apply (clarsimp simp: sym_heap_def obj_at'_def projectKOs ps_clear_upd opt_map_red projectKO_opt_reply) - apply (drule_tac x=scp and y=p' in spec2) - apply (clarsimp simp: opt_map_red) - apply (wpsimp wp: updateSchedContext_wp getCurTime_wp refillReady_wp isRoundRobin_wp - simp: setReprogramTimer_def)+ - apply (clarsimp simp: sym_heap_def obj_at'_def projectKOs ps_clear_upd projectKO_opt_reply) - apply (rule conjI; clarsimp) - apply (drule_tac x=scp and y=p' in spec2) - apply (clarsimp simp: opt_map_def projectKO_opt_reply) - apply (drule_tac x=p and y=p' in spec2) - apply (clarsimp simp: opt_map_def projectKO_opt_reply) +lemma arch_stt_objs' [wp]: + "\valid_objs'\ Arch.switchToThread t \\rv. valid_objs'\" + apply (simp add: ARM_H.switchToThread_def) + apply wp done -crunch ifCondRefillUnblockCheck - for sym_heap_tcbSCs[wp]: sym_heap_tcbSCs - and sym_heap_scReplies[wp]: sym_heap_scReplies - and valid_idle'[wp]: valid_idle' - (simp: crunch_simps) +declare zipWithM_x_mapM [simp] -(* 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 - split: if_split) - apply (intro bind_wp[OF _ stateAssert_sp]) - 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 \ valid_idle' 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)" - in bind_wp) - apply (rule_tac P'1="\s. \rptr. replyOpt = Some rptr \ \ is_reply_linked rptr s" - 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 - getNotification_wp gbn_wp' hoare_vcg_all_lift hoare_vcg_const_imp_lift - simp: 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 projectKOs) - 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' - hoare_vcg_all_lift hoare_vcg_const_imp_lift - simp: if_fun_split - | wp (once) hoare_false_imp)+ - apply (fastforce simp: valid_obj'_def valid_ep'_def pred_tcb_at'_def obj_at'_def projectKOs) - \ \SendEP\ - 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 valid_idle' - and (\s. sch_act_wf (ksSchedulerAction s) s) and tcb_at' t - and st_tcb_at' (Not \ is_replyState) sender - and (\s. sender \ ksIdleThread s) - 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 valid_idle' and (\s. sch_act_wf (ksSchedulerAction s) s) - and tcb_at' t and st_tcb_at' (Not \ is_replyState) x21 - and (\s. x21 \ ksIdleThread 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' - maybeReturnSc_valid_idle' 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 "sender \ ksIdleThread s - \ 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 (frule (1) st_tcb_idle', clarsimp simp: isBlockedOnSend_equiv is_BlockedOnSend_def) - 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) - \ \Resolve common precondition\ - apply (simp (no_asm_use) cong: conj_cong - | wpsimp wp: cancelIPC_st_tcb_at'_different_thread cancelIPC_notin_epQueue - 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) - apply (clarsimp simp: comp_def invs'_def valid_pspace'_def if_distribR - 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 projectKOs) - apply (drule_tac ko="ko :: endpoint" for ko in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def projectKOs) - 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 projectKOs) - apply (drule_tac ko="ko :: reply" for ko in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def projectKOs) - 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 projectKOs - 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 - apply (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 projectKOs valid_cap'_def - intro!: replyTCB_is_not_ksIdleThread - split: if_split) - done +lemma cteInsert_invs_bits[wp]: + "\\s. sch_act_wf (ksSchedulerAction s) s\ + cteInsert a b c + \\rv s. sch_act_wf (ksSchedulerAction s) s\" + "\cur_tcb'\ cteInsert a b c \\rv. cur_tcb'\" + "\\s. P (state_refs_of' s)\ + cteInsert a b c + \\rv s. P (state_refs_of' s)\" +apply (wp sch_act_wf_lift valid_queues_lift + cur_tcb_lift tcb_in_cur_domain'_lift)+ +done -lemma bindScReply_st_tcb_at'[wp]: - "\\s. P (st_tcb_at' P' t s)\ - bindScReply scPtr replyPtr - \\_ s. P (st_tcb_at' P' t s)\" - apply (clarsimp simp: bindScReply_def) - by (wpsimp wp: crunch_wps) - -lemma replyPush_st_tcb_at'_not_caller: - "\\s. P (st_tcb_at' P' t s) \ t \ callerPtr\ - replyPush callerPtr calleePtr replyPtr canDonate - \\_ s. P (st_tcb_at' P' t s)\" - apply (clarsimp simp: replyPush_def) - 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)\ - replyUnlink replyPtr tcbPtr - \\_. invs'\" - unfolding invs'_def valid_dom_schedule'_def - by wpsimp - -lemma asUser_pred_tcb_at'[wp]: - "asUser tptr f \\s. P (pred_tcb_at' proj test t s)\" - unfolding asUser_def - by (wpsimp wp: mapM_wp' threadSet_pred_tcb_no_state crunch_wps - simp: tcb_to_itcb'_def) - -lemma setCTE_pred_tcb_at': - "setCTE ptr val \\s. P (pred_tcb_at' proj test t s)\ " - apply (simp add: setCTE_def pred_tcb_at'_def) - apply (rule setObject_cte_obj_at_tcb'; simp add: tcb_to_itcb'_def) +lemma possibleSwitchTo_sch_act_not: + "\sch_act_not t' and K (t \ t')\ possibleSwitchTo t \\rv. sch_act_not t'\" + apply (simp add: possibleSwitchTo_def setSchedulerAction_def curDomain_def) + apply (wp hoare_drop_imps | wpc | simp)+ done -crunch 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 \ valid_idle' 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\ - 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; - 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' - replyPush_valid_idle' sts_invs_minor' schedContextDonate_valid_idle' - replyPush_st_tcb_at'_not_caller sts_st_tcb' 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') - apply (frule_tac t=d in pred_tcb_at') - apply (frule_tac P'="Not \ is_replyState" in pred_tcb'_weakenE) - 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 (clarsimp simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def) - done +crunch possibleSwitchTo + for vms'[wp]: valid_machine_state' +crunch possibleSwitchTo + for pspace_domain_valid[wp]: pspace_domain_valid +crunch possibleSwitchTo + for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' -lemma replyUnlink_obj_at_tcb_none: - "\K (rptr' = rptr)\ - replyUnlink rptr tptr - \\_. obj_at' (\reply. replyTCB reply = None) rptr'\" - apply (simp add: replyUnlink_def) - apply (wpsimp wp: updateReply_wp_all gts_wp') - by (auto simp: obj_at'_def projectKOs objBitsKO_def) +crunch possibleSwitchTo + for ct'[wp]: "\s. P (ksCurThread s)" +crunch possibleSwitchTo + for it[wp]: "\s. P (ksIdleThread s)" +crunch possibleSwitchTo + for irqs_masked'[wp]: "irqs_masked'" +crunch possibleSwitchTo + for urz[wp]: "untyped_ranges_zero'" + (simp: crunch_simps unless_def wp: crunch_wps) crunch possibleSwitchTo for pspace_aligned'[wp]: pspace_aligned' and pspace_distinct'[wp]: pspace_distinct' lemma si_invs'[wp]: - "\invs' and st_tcb_at' active' t - and (\s. cd \ bound_sc_tcb_at' (\a. a \ None) t s) + "\invs' and st_tcb_at' simple' t + and sch_act_not t and ex_nonz_cap_to' ep and ex_nonz_cap_to' t\ - sendIPC bl call ba cg cgr cd t ep - \\rv. invs'\" + sendIPC bl call ba cg cgr t ep + \\rv. invs'\" supply if_split[split del] - apply (simp add: sendIPC_def valid_idle'_asrt_def) - apply (intro bind_wp[OF _ stateAssert_sp]) + apply (simp add: sendIPC_def split del: if_split) apply (rule bind_wp [OF _ get_ep_sp']) - apply (rename_tac ep') - apply (case_tac ep') - \ \ep' = RecvEP\ + apply (case_tac epa) + \ \epa = RecvEP\ + apply simp 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 \ valid_idle' 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 projectKO_eq projectKO_tcb - 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 \ valid_idle' 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 projectKO_eq projectKO_tcb - 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 projectKO_eq projectKO_ep 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 - projectKO_eq projectKO_tcb isReceive_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 - projectKO_eq projectKO_tcb 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 projectKO_eq projectKO_tcb) - apply (drule_tac p=a and ko="obja" in sym_refs_ko_atD'[rotated]) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb) - apply (clarsimp simp: isReceive_def refs_of_rev' ko_wp_at'_def live_reply'_def - split: thread_state.splits) + apply (case_tac list) + apply simp + apply (simp split del: if_split add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (rule_tac P="a\t" in hoare_gen_asm) + apply (wp valid_irq_node_lift + sts_valid_objs' set_ep_valid_objs' setEndpoint_valid_mdb' sts_st_tcb' sts_sch_act' + possibleSwitchTo_sch_act_not setThreadState_ct_not_inQ + possibleSwitchTo_ct_not_inQ hoare_vcg_all_lift + hoare_convert_imp [OF doIPCTransfer_sch_act doIPCTransfer_ct'] + hoare_convert_imp [OF setEndpoint_nosch setEndpoint_ct'] + hoare_drop_imp [where f="threadGet tcbFault t"] + | rule_tac f="getThreadState a" in hoare_drop_imp + | wp (once) hoare_drop_imp[where Q'="\_ _. call"] + hoare_drop_imp[where Q'="\_ _. \ call"] + hoare_drop_imp[where Q'="\_ _. cg"] + | simp add: valid_tcb_state'_def case_bool_If + case_option_If + cong: if_cong + split del: if_split + | wp (once) sch_act_sane_lift tcb_in_cur_domain'_lift hoare_vcg_const_imp_lift)+ + apply (clarsimp simp: pred_tcb_at' cong: conj_cong imp_cong + split del: if_split) + apply (frule obj_at_valid_objs', clarsimp) + apply (frule(1) sym_refs_ko_atD') + apply (clarsimp simp: projectKOs valid_obj'_def valid_ep'_def + st_tcb_at_refs_of_rev' pred_tcb_at' + conj_comms fun_upd_def[symmetric] + split del: if_split) + apply (frule pred_tcb_at') + apply (drule simple_st_tcb_at_state_refs_ofD' st_tcb_at_state_refs_ofD')+ + apply (clarsimp simp: valid_pspace'_splits) + apply (subst fun_upd_idem[where x=t]) + apply (clarsimp split: if_split) + apply (rule conjI, clarsimp simp: obj_at'_def projectKOs) + apply (drule bound_tcb_at_state_refs_ofD') + apply (fastforce simp: tcb_bound_refs'_def) + apply (subgoal_tac "ex_nonz_cap_to' a s") + prefer 2 + apply (clarsimp elim!: if_live_state_refsE) + apply clarsimp + apply (rule conjI) + apply (drule bound_tcb_at_state_refs_ofD') + apply (fastforce simp: tcb_bound_refs'_def set_eq_subset) + apply (clarsimp simp: conj_ac) + apply (rule conjI, clarsimp simp: idle'_no_refs) + apply (rule conjI, clarsimp simp: global'_no_ex_cap) + apply (rule conjI) apply (rule impI) - apply (drule (1) valid_replies'_other_state; clarsimp simp: isReceive_def) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKO_eq projectKO_tcb) - 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 projectKO_eq projectKO_tcb) - apply (clarsimp simp: ko_wp_at'_def obj_at'_def projectKO_eq projectKO_tcb - refs_of_rev' live_sc'_def valid_idle'_def idle_tcb'_def) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def isReceive_def is_BlockedOnReply_def) - \ \epa = IdleEP\ + apply (frule(1) ct_not_in_epQueue, clarsimp, clarsimp) + apply (clarsimp) + apply (simp add: ep_redux_simps') + apply (rule conjI, clarsimp split: if_split) + apply (rule conjI, fastforce simp: tcb_bound_refs'_def set_eq_subset) + apply (clarsimp, erule delta_sym_refs; + solves\auto simp: symreftype_inverse' tcb_bound_refs'_def split: if_split_asm\) + apply (solves\clarsimp split: list.splits\) + \ \epa = IdleEP\ apply (cases bl) - apply (wpsimp wp: sts_sch_act' sts_valid_queues 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 - projectKO_eq projectKO_tcb idle_tcb'_def comp_def) - apply wpsimp - \ \ep' = SendEP\ + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wp valid_irq_node_lift) + apply (simp add: valid_ep'_def) + apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ) + apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (subgoal_tac "ep \ t") + apply (drule simple_st_tcb_at_state_refs_ofD' ko_at_state_refs_ofD' + bound_tcb_at_state_refs_ofD')+ + apply (rule conjI, erule delta_sym_refs) + apply (auto simp: tcb_bound_refs'_def symreftype_inverse' + split: if_split_asm)[2] + apply (fastforce simp: global'_no_ex_cap) + apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) + apply simp + apply wp + apply simp + \ \epa = SendEP\ apply (cases bl) - apply (wpsimp wp: tcbEPAppend_valid_SendEP sts_sch_act' sts_valid_queues setThreadState_ct_not_inQ - 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 projectKO_eq projectKO_ep) - apply (drule_tac ko="SendEP xa" in sym_refs_ko_atD'[rotated]) - apply (fastforce simp: obj_at'_def projectKO_eq projectKO_ep) - 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 projectKO_eq projectKO_tcb) - apply (fastforce simp: ko_wp_at'_def refs_of_rev') - apply wpsimp + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre, wp valid_irq_node_lift) + apply (simp add: valid_ep'_def) + apply (wp hoare_vcg_const_Ball_lift valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ) + apply (clarsimp simp: valid_tcb_state'_def pred_tcb_at') + apply (rule conjI, clarsimp elim!: obj_at'_weakenE) + apply (frule obj_at_valid_objs', clarsimp) + apply (frule(1) sym_refs_ko_atD') + apply (frule pred_tcb_at') + apply (drule simple_st_tcb_at_state_refs_ofD') + apply (drule bound_tcb_at_state_refs_ofD') + apply (clarsimp simp: valid_obj'_def valid_ep'_def + projectKOs st_tcb_at_refs_of_rev') + apply (rule conjI, clarsimp) + apply (drule (1) bspec) + apply (clarsimp dest!: st_tcb_at_state_refs_ofD' bound_tcb_at_state_refs_ofD' + simp: tcb_bound_refs'_def) + apply (clarsimp simp: set_eq_subset) + apply (rule conjI, erule delta_sym_refs) + subgoal by (fastforce simp: obj_at'_def projectKOs symreftype_inverse' + split: if_split_asm) + apply (fastforce simp: tcb_bound_refs'_def symreftype_inverse' + split: if_split_asm) + apply (fastforce simp: global'_no_ex_cap idle'_not_queued) + apply (simp | wp)+ done lemma sfi_invs_plus': - "\invs' and valid_idle' and st_tcb_at' active' t + "\invs' and st_tcb_at' simple' t and sch_act_not 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)\ - sendFaultIPC t cap f canDonate - \\_. invs'\, - \\_. invs' and valid_idle' and st_tcb_at' active' t - and sch_act_not 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_wp_at' (\cte. cteCap cte = cap) (t + n) s)\" + and ex_nonz_cap_to' t\ + sendFaultIPC t f + \\_. invs'\, \\_. invs' and st_tcb_at' simple' t and sch_act_not t and (\s. ksIdleThread s \ t)\" apply (simp add: sendFaultIPC_def) apply (wp threadSet_invs_trivial threadSet_pred_tcb_no_state - threadSet_cap_to' threadSet_idle' + threadSet_cap_to' | wpc | simp)+ - apply (intro conjI impI allI; (fastforce simp: inQ_def)?) - apply (clarsimp simp: invs'_def valid_release_queue'_def obj_at'_def) - apply (fastforce simp: ex_nonz_cap_to'_def cte_wp_at'_def) + apply (rule_tac Q'="\rv s. invs' s \ sch_act_not t s + \ st_tcb_at' simple' t s + \ ex_nonz_cap_to' t s + \ t \ ksIdleThread s + \ (\r\zobj_refs' rv. ex_nonz_cap_to' r s)" + in hoare_strengthen_postE_R) + apply wp + apply (clarsimp simp: inQ_def pred_tcb_at') + apply (wp | simp)+ + apply (clarsimp simp: eq_commute) + apply (subst(asm) global'_no_ex_cap, auto) done crunch send_fault_ipc @@ -6139,130 +4170,75 @@ crunch send_fault_ipc (simp: crunch_simps wp: crunch_wps) lemma handleFault_corres: - assumes "fr f f'" - shows "corres dc (invs and valid_list and valid_sched_action and active_scs_valid - and scheduler_act_not t and st_tcb_at active t and current_time_bounded - and ex_nonz_cap_to t and K (valid_fault f)) - (invs' and sch_act_not t and st_tcb_at' active' t and ex_nonz_cap_to' t) - (handle_fault t f) (handleFault t f')" - apply add_valid_idle' - using assms + "fr f f' \ + corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread + and (%_. valid_fault f)) + (invs' and sch_act_not thread + and st_tcb_at' simple' thread and ex_nonz_cap_to' thread) + (handle_fault thread f) (handleFault thread f')" apply (simp add: handle_fault_def handleFault_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (rule corres_gen_asm) apply (rule corres_guard_imp) - apply (rule corres_split) - apply (rule getObject_TCB_corres) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split_eqr) - apply (simp only: get_tcb_obj_ref_def) - apply (rule threadGet_corres, clarsimp simp: tcb_relation_def) - apply (rule corres_split_eqr) - apply (rule corres_split_catch[OF sendFaultIPC_corres]) - apply (fastforce simp: tcb_relation_def)+ - apply (clarsimp simp: handle_no_fault_def handleNoFaultHandler_def unless_def when_def) - apply (rule setThreadState_corres, simp) - apply (rule_tac Q'="\_ s. invs s \ tcb_at t s" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply wp - apply (rule hoare_strengthen_post[OF catch_wp[OF _ sfi_invs_plus']]) - apply wpsimp - apply (clarsimp simp: invs'_def valid_pspace'_def) - apply (wp gbn_inv get_tcb_obj_ref_wp) - apply (wp hoare_vcg_imp_lift' threadGet_wp) - apply wp - apply (wp getObject_tcb_wp) - apply (clarsimp simp: pred_tcb_at_def obj_at_def is_tcb_def get_tcb_def cong: conj_cong) - apply (intro conjI) - apply (fastforce dest: invs_valid_objs simp: valid_obj_def valid_tcb_def tcb_cap_cases_def) - apply (fastforce dest: invs_valid_objs simp: valid_obj_def valid_tcb_def tcb_cap_cases_def) - apply (rule_tac x=3 in exI) - apply (fastforce simp: caps_of_state_tcb_index_trans get_tcb_def tcb_cnode_map_def) - apply (clarsimp simp: valid_tcb_def ran_tcb_cap_cases) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (drule_tac p=t and k="ko :: tcb" for ko in ko_at_valid_objs'[rotated, OF invs_valid_objs']) - apply (fastforce simp: obj_at'_def projectKOs)+ - apply (rule conjI) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def tcb_cte_cases_def) - apply (rule_tac x="0x30" in bexI) - apply (auto elim: cte_wp_at_tcbI' simp: objBitsKO_def return_def tcb_cte_cases_def) + apply (subst return_bind [symmetric], + rule corres_split[where P="tcb_at thread", + OF gets_the_noop_corres [where x="()"]]) + apply (simp add: tcb_at_def) + apply (rule corres_split_catch) + apply (rule_tac F="valid_fault f" in corres_gen_asm) + apply (rule sendFaultIPC_corres, assumption) + apply simp + apply (rule handleDoubleFault_corres) + apply wp+ + apply (clarsimp simp: st_tcb_at_tcb_at st_tcb_def2 invs_def + valid_state_def valid_idle_def) + apply auto done -lemma handleTimeout_corres: - assumes "fr f f'" - shows "corres dc (invs and valid_list and valid_sched_action and active_scs_valid - and scheduler_act_not t and st_tcb_at active t and current_time_bounded - and cte_wp_at is_ep_cap (t,tcb_cnode_index 4) and K (valid_fault f)) - invs' - (handle_timeout t f) (handleTimeout t f')" - (is "corres _ ?G ?G' _ _") - apply add_valid_idle' - using assms - apply (clarsimp simp: handle_timeout_def handleTimeout_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (rule corres_gen_asm) - apply (rule_tac Q="?G" and Q'="?G' and obj_at' (isEndpointCap \ cteCap \ tcbTimeoutHandler) t" - in stronger_corres_guard_imp) - apply (rule corres_symb_exec_r) - apply (rule corres_assert_assume_r) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getObject_TCB_corres]) - apply (rule corres_assert_assume_l) - apply (rule corres_split) - apply (rule corres_split_catch[OF sendFaultIPC_corres]) - apply fastforce - apply (fastforce simp: tcb_relation_def) - apply (rule corres_trivial, clarsimp) - apply wp+ - apply (rule corres_trivial, clarsimp) - apply (wp getTCB_wp)+ - apply (fastforce simp: pred_tcb_at_def cte_wp_at_def obj_at_def is_tcb_def get_cap_def gets_the_def - get_object_def get_tcb_def valid_obj_def valid_tcb_def bind_def - return_def tcb_cap_cases_def tcb_cnode_map_def simpler_gets_def - dest: invs_valid_objs) - apply assumption - apply (wpsimp wp: getTCB_wp simp: isValidTimeoutHandler_def) - apply (fastforce simp: isCap_simps pred_tcb_at'_def obj_at'_def projectKOs - valid_obj'_def valid_tcb'_def tcb_cte_cases_def - dest: invs_valid_objs') - apply (wpsimp wp: hoare_drop_imps simp: isValidTimeoutHandler_def)+ - apply (frule cross_relF[OF _ tcb_at'_cross_rel[where t=t]], fastforce) - apply (clarsimp simp: pred_tcb_at_def pred_tcb_at'_def obj_at_def obj_at'_def - is_tcb_def projectKOs state_relation_def pspace_relation_def) - apply (erule_tac x=t in ballE) - apply (auto simp: other_obj_relation_def tcb_relation_def cap_relation_def - cte_wp_at_caps_of_state caps_of_state_def tcb_cnode_map_def - get_object_def get_tcb_def get_cap_def simpler_gets_def - return_def bind_def is_cap_simps isCap_simps gets_the_def) +lemma sts_invs_minor'': + "\st_tcb_at' (\st'. tcb_st_refs_of' st' = tcb_st_refs_of' st + \ (st \ Inactive \ \ idle' st \ + st' \ Inactive \ \ idle' st')) t + and (\s. t = ksIdleThread s \ idle' st) + and (\s. \ runnable' st \ sch_act_not t s) + and invs'\ + setThreadState st t + \\rv. invs'\" + apply (simp add: invs'_def valid_state'_def) + apply (rule hoare_pre) + apply (wp valid_irq_node_lift sts_sch_act' setThreadState_ct_not_inQ) + apply clarsimp + apply (rule conjI) + apply fastforce + apply (rule conjI) + apply (clarsimp simp: pred_tcb_at'_def) + apply (drule obj_at_valid_objs') + apply (clarsimp simp: valid_pspace'_def) + apply (clarsimp simp: valid_obj'_def valid_tcb'_def projectKOs) + subgoal by (cases st, auto simp: valid_tcb_state'_def + split: Structures_H.thread_state.splits)[1] + apply (rule conjI) + apply (clarsimp dest!: st_tcb_at_state_refs_ofD' + elim!: rsubst[where P=sym_refs] + intro!: ext) + apply (fastforce elim!: st_tcb_ex_cap'') done lemma hf_invs' [wp]: - "\invs' - and st_tcb_at' active' t - and ex_nonz_cap_to' t\ - handleFault t f - \\r. invs'\" - apply (simp add: handleFault_def handleNoFaultHandler_def sendFaultIPC_def valid_idle'_asrt_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (wpsimp wp: sts_invs_minor' threadSet_invs_trivialT threadSet_pred_tcb_no_state getTCB_wp - threadGet_wp threadSet_cap_to' hoare_vcg_all_lift hoare_vcg_imp_lift' threadSet_idle' - | fastforce simp: tcb_cte_cases_def)+ - apply (clarsimp simp: invs'_def inQ_def) - apply (subgoal_tac "st_tcb_at' (\st'. tcb_st_refs_of' st' = {}) t s") - apply (rule_tac x=ko in exI) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (intro conjI impI allI; clarsimp?) - apply (clarsimp simp: valid_release_queue'_def obj_at'_def) - apply (clarsimp simp: ex_nonz_cap_to'_def return_def fail_def oassert_opt_def - projectKO_def projectKO_tcb - split: option.splits) - apply (rule_tac x="t+0x30" in exI) - apply (fastforce elim: cte_wp_at_tcbI' simp: objBitsKO_def) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def valid_idle'_def idle_tcb'_def) + "\invs' and sch_act_not t + and st_tcb_at' simple' t + and ex_nonz_cap_to' t and (\s. t \ ksIdleThread s)\ + handleFault t f \\r. invs'\" + apply (simp add: handleFault_def) + apply wp + apply (simp add: handleDoubleFault_def) + apply (wp sts_invs_minor'' dmo_invs')+ + apply (rule hoare_strengthen_postE, rule sfi_invs_plus', + simp_all) + apply (strengthen no_refs_simple_strg') + apply clarsimp done +declare zipWithM_x_mapM [simp del] + lemma gts_st_tcb': "\\\ getThreadState t \\r. st_tcb_at' (\st. st = r) t\" apply (rule hoare_strengthen_post) @@ -6270,356 +4246,69 @@ lemma gts_st_tcb': apply simp done -crunch replyRemove - for ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - (simp: crunch_simps) +declare setEndpoint_ct' [wp] + +lemma setupCallerCap_pred_tcb_unchanged: + "\pred_tcb_at' proj P t and K (t \ t')\ + setupCallerCap t' t'' g + \\rv. pred_tcb_at' proj P t\" + apply (simp add: setupCallerCap_def getThreadCallerSlot_def + getThreadReplySlot_def) + apply (wp sts_pred_tcb_neq' hoare_drop_imps) + apply clarsimp + done + +lemma si_blk_makes_simple': + "\st_tcb_at' simple' t and K (t \ t')\ + sendIPC True call bdg x x' t' ep + \\rv. st_tcb_at' simple' t\" + apply (simp add: sendIPC_def) + apply (rule bind_wp [OF _ get_ep_inv']) + apply (case_tac rv, simp_all) + apply (rename_tac list) + apply (case_tac list, simp_all add: case_bool_If case_option_If + split del: if_split cong: if_cong) + apply (rule hoare_pre) + apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged + hoare_drop_imps) + apply (clarsimp simp: pred_tcb_at' del: disjCI) + apply (wp sts_st_tcb_at'_cases) + apply clarsimp + apply (wp sts_st_tcb_at'_cases) + apply clarsimp + done -crunch getSanitiseRegisterInfo - for inv[wp]: P +lemma si_blk_makes_runnable': + "\st_tcb_at' runnable' t and K (t \ t')\ + sendIPC True call bdg x x' t' ep + \\rv. st_tcb_at' runnable' t\" + apply (simp add: sendIPC_def) + apply (rule bind_wp [OF _ get_ep_inv']) + apply (case_tac rv, simp_all) + apply (rename_tac list) + apply (case_tac list, simp_all add: case_bool_If case_option_If + split del: if_split cong: if_cong) + apply (rule hoare_pre) + apply (wp sts_st_tcb_at'_cases setupCallerCap_pred_tcb_unchanged + hoare_vcg_const_imp_lift hoare_drop_imps + | simp)+ + apply (clarsimp del: disjCI simp: pred_tcb_at' elim!: pred_tcb'_weakenE) + apply (wp sts_st_tcb_at'_cases) + apply clarsimp + apply (wp sts_st_tcb_at'_cases) + apply clarsimp + done -lemma handleFaultReply_invs[wp]: - "\invs' and tcb_at' t\ handleFaultReply x t label msg \\rv. invs'\" - unfolding handleFaultReply_def - by (cases x; wpsimp simp: handleArchFaultReply_def split: arch_fault.split) +crunch possibleSwitchTo, completeSignal + for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" -lemma doReplyTransfer_corres: - "corres dc - (einvs and reply_at reply and tcb_at sender and current_time_bounded) - invs' - (do_reply_transfer sender reply grant) - (doReplyTransfer sender reply grant)" - apply add_cur_tcb' - supply if_split [split del] subst_all[simp del] - apply (simp add: do_reply_transfer_def doReplyTransfer_def cong: option.case_cong) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split [OF getReply_TCB_corres]) - apply (simp add: maybeM_def) - apply (rule corres_option_split [OF refl corres_return_trivial]) - apply (rename_tac recv_opt receiverOpt recvr) - apply (rule_tac Q="\s. einvs s \ tcb_at sender s \ tcb_at recvr s \ current_time_bounded s \ - reply_tcb_reply_at (\xa. xa = Some recvr) reply s" and - Q'="invs' and cur_tcb'" - in corres_split [OF _ _ gts_sp gts_sp' ]) - apply (rule getThreadState_corres, simp, rename_tac ts ts') - apply (case_tac ts; simp add: isReply_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_assert_assume_l) - apply (rule corres_split [OF replyRemove_corres], (rule refl)+) - 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 corres_split [OF threadget_fault_corres]) - apply (rule corres_split) - apply (rule_tac P="tcb_at sender and tcb_at recvr and valid_objs and pspace_aligned and - valid_list and pspace_distinct and valid_mdb and cur_tcb - and current_time_bounded" and - P'="tcb_at' sender and tcb_at' recvr and valid_pspace' and cur_tcb' and - valid_release_queue and valid_release_queue'" - in corres_guard_imp) - apply (simp add: fault_rel_optionation_def) - apply (rule corres_option_split; simp) - apply (rule corres_split [OF doIPCTransfer_corres setThreadState_corres]) - apply (clarsimp simp: thread_state_relation_def) - prefer 3 - apply (rule corres_split_mapr[OF getMessageInfo_corres]) - apply (rule corres_split_eqr[OF lookupIPCBuffer_corres']) - apply (rule corres_split_eqr[OF getMRs_corres], simp) - apply (simp (no_asm) del: dc_simp) - apply (rule corres_split_eqr[OF handleFaultReply_corres], simp) - apply (rule corres_split [OF threadset_corresT setThreadState_corres]) - apply (clarsimp simp: tcb_relation_def fault_rel_optionation_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def) - apply (clarsimp simp: thread_state_relation_def split: if_split) - (* solving hoare_triples *) - apply (clarsimp simp: valid_tcb_state_def) - apply (rule_tac Q="\_. valid_objs and pspace_aligned and - pspace_distinct and tcb_at recvr - and current_time_bounded" in - hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_objs_valid_tcbs) - apply (wpsimp wp: thread_set_fault_valid_objs) - apply (wpsimp wp: threadSet_valid_tcbs' threadSet_valid_release_queue_inv - threadSet_valid_release_queue'_inv) - apply (clarsimp simp: pred_conj_def cong: conj_cong) - apply wpsimp+ - apply (strengthen valid_objs'_valid_tcbs') - apply wpsimp+ - apply (strengthen valid_objs_valid_tcbs) - apply wpsimp+ - apply (strengthen valid_objs'_valid_tcbs') - apply wpsimp - apply (clarsimp split: option.splits) - apply (clarsimp split: option.splits simp: valid_pspace'_def) - apply (clarsimp simp: isRunnable_def get_tcb_obj_ref_def) - (* solve remaining corres goals *) - apply (rule corres_split [OF getThreadState_corres]) - apply (rule corres_split [OF threadGet_corres[where r="(=)"]]) - apply (simp add: tcb_relation_def) - apply (rename_tac scopt scopt') - apply (rule corres_when) - apply (case_tac state; simp add: thread_state_relation_def) - apply (rule corres_assert_opt_assume_l) - apply (rule_tac Q="valid_sched_action and tcb_at recvr - and sc_tcb_sc_at (\a. a \ None) (the scopt) and - active_sc_at (the scopt) and valid_refills (the scopt) and - valid_release_q and active_scs_valid and - (\s. sc_tcb_sc_at (\sc. \t. sc = Some t \ not_queued t s) (the scopt) s) and - invs and valid_list and scheduler_act_not recvr - and current_time_bounded and st_tcb_at active recvr" - and Q'="invs' and tcb_at' recvr and sc_at' (the scopt) and cur_tcb'" - and P'="invs' and sc_at' (the scopt') and tcb_at' recvr and cur_tcb'" - and P="valid_sched_action and tcb_at recvr and current_time_bounded and - sc_tcb_sc_at (\a. a \ None) (the scopt) and - active_sc_at (the scopt) and valid_refills (the scopt) and - valid_release_q and active_scs_valid and - (\s. sc_tcb_sc_at (\sc. \t. sc = Some t \ not_queued t s) (the scopt) s) and - invs and valid_list and scheduler_act_not recvr and st_tcb_at active recvr" - in stronger_corres_guard_imp) - - (* this next section by somewhat complicated symbolic executions *) - apply (rule corres_symb_exec_l [OF _ _ get_sched_context_sp], rename_tac sc) - apply (rule corres_symb_exec_l [OF _ _ gets_sp], rename_tac ct) - apply (rule corres_symb_exec_r [OF _ refillReady_sp], rename_tac ready) - apply (rule corres_symb_exec_r [OF _ refillSufficient_sp], rename_tac suff) - apply (rule_tac Q="\_. ready = sc_refill_ready ct sc \ suff = sc_refill_sufficient 0 sc" in corres_cross_add_guard[rotated]) - apply (rule_tac corres_gen_asm2) - apply (rule stronger_corres_guard_imp) - apply (rule corres_if, simp) - apply (rule possibleSwitchTo_corres; (solves simp)?) - apply (rule corres_symb_exec_r[OF _ get_sc_sp'], rename_tac sc') - apply (rule_tac Q="\_. sc_badge sc = scBadge sc'" in corres_cross_add_guard[rotated]) - apply (rule_tac corres_gen_asm2) - apply (rule_tac Q="\s. active_scs_valid s \ - is_active_sc (the scopt') s \ current_time_bounded s \ - sc_tcb_sc_at (\sc. \t. sc = Some t \ not_queued t s) (the scopt) s \ - invs s \ valid_release_q s \ tcb_at recvr s \ - valid_list s \ valid_sched_action s \ - scheduler_act_not recvr s \ st_tcb_at active recvr s" - in corres_guard_imp) - apply (rule corres_symb_exec_l [OF _ _ gets_the_get_tcb_sp], rename_tac tcb) - apply (rule_tac Q'="\s. invs' s \ (\ko. ko_at' ko recvr s \ - capability.is_EndpointCap (cteCap (tcbTimeoutHandler ko)) = - is_ep_cap (tcb_timeout_handler tcb)) \ tcb_at' recvr s \ cur_tcb' s" - and P'="\s. invs' s \ tcb_at' recvr s \ cur_tcb' s" - in stronger_corres_guard_imp) - apply (rule corres_symb_exec_r [OF _ isValidTimeoutHandler_sp], rename_tac isHV) - apply (rule corres_symb_exec_r, rename_tac isT) - apply (rule_tac F="isHV = is_ep_cap (tcb_timeout_handler tcb) \ - isT = (case fault of None \ False | Some a \ is_timeout_fault a)" - in corres_gen_asm2) - apply (rule corres_if2[OF _ handleTimeout_corres, rotated]) - apply (clarsimp) - apply (simp, rule postpone_corres) - apply simp - apply wpsimp - apply (clarsimp simp: fault_rel_optionation_def if_distribR) - apply (clarsimp simp: invs'_def valid_pspace'_def) - apply (auto simp: is_timeout_fault_def fault_map_def split: ExceptionTypes_A.fault.splits)[1] - - (* solve final hoare triple goals *) - apply wpsimp - apply wpsimp - apply (wpsimp wp: hoare_drop_imp simp: isValidTimeoutHandler_def) - apply (wpsimp simp: isValidTimeoutHandler_def) - apply (clarsimp split: if_split simp: valid_fault_def invs_def valid_state_def valid_pspace_def) - apply (clarsimp simp: tcb_cnode_map_def obj_at_def TCB_cte_wp_at_obj_at) - 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 projectKOs tcb_relation_def) - apply (case_tac "cteCap (tcbTimeoutHandler ko)"; - case_tac "tcb_timeout_handler tcb"; simp) - apply (wpsimp simp: tcb_at_def) - apply (wpsimp simp: tcb_at_def) - apply (assumption) - apply clarsimp - apply (subgoal_tac "invs' s \ tcb_at' recvr s \ cur_tcb' s - \ obj_at' (\sc'. sc_badge sc = scBadge sc') (the scopt') s") - apply (clarsimp simp: obj_at'_def) - apply (assumption) - apply (clarsimp simp: obj_at'_def) - apply wpsimp - apply wpsimp - - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def active_sc_at_equiv - split: if_split) - 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 projectKOs 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 (prop_tac "sc_relation sc n ko") - 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 projectKOs ) - apply (frule (1) sc_ko_at_valid_objs_valid_sc', clarsimp) - apply (subgoal_tac "0 < scRefillMax ko") - apply (subgoal_tac "sc_valid_refills sc") - apply (prop_tac "koa=ko", erule (1) ko_at'_inj, simp only:) - apply (subgoal_tac "sc_valid_refills' ko") - apply (simp add: sc_refill_ready_relation sc_refill_sufficient_relation state_relation_def active_sc_at_equiv) - apply (metis valid_sched_context'_def sc_valid_refills_scRefillCount) - apply (subst (asm) active_sc_at_equiv) - apply (frule (1) active_scs_validE) - apply (clarsimp simp: valid_refills_def2 obj_at_def) - apply (clarsimp simp: obj_at_def vs_all_heap_simps active_sc_def - sc_relation_def) - apply wpsimp - apply (wpsimp simp: refillSufficient_def getRefills_def obj_at'_def) - apply (wpsimp wp: refillReady_wp) - apply (simp add: refillReady_def, rule no_ofail_gets_the) - apply wpsimp - apply wpsimp - apply (clarsimp simp: obj_at_def sc_at_pred_n_def get_sched_context_exs_valid) - apply (rule get_sched_context_exs_valid) - apply (clarsimp simp: sc_at_pred_n_def obj_at_def) - apply ((wpsimp simp: obj_at_def is_sc_obj_def - | clarsimp split: Structures_A.kernel_object.splits)+)[1] - apply simp - apply clarsimp - apply (wpsimp wp: thread_get_wp') - apply (wpsimp wp: threadGet_wp) - apply (wpsimp wp: gts_wp) - apply (wpsimp wp: gts_wp') - apply (rule_tac Q'="\_. tcb_at recvr and valid_sched_action and invs and valid_list - and valid_release_q and scheduler_act_not recvr - and active_scs_valid and current_time_bounded - and active_if_bound_sc_tcb_at recvr - and not_queued recvr" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: obj_at_def is_tcb) - apply (subgoal_tac "pred_map (\a. a = Some y) (tcb_scps_of s) recvr") - apply (subgoal_tac "pred_map (\a. a = Some recvr) (sc_tcbs_of s) y") - apply (intro conjI) - apply (clarsimp simp: vs_all_heap_simps sc_at_kh_simps) - apply (clarsimp simp: vs_all_heap_simps) - apply (erule active_scs_validE[rotated], clarsimp simp: vs_all_heap_simps) - apply (clarsimp simp: vs_all_heap_simps sc_at_kh_simps) - apply (clarsimp simp: vs_all_heap_simps pred_tcb_at_def obj_at_def runnable_eq) - apply (simp add: sc_at_kh_simps pred_map_eq_normalise heap_refs_inv_def2) - apply (erule heap_refs_retractD[rotated], clarsimp) - apply (clarsimp simp: vs_all_heap_simps) - apply (wpsimp wp: set_thread_state_valid_sched_action set_thread_state_valid_release_q - sts_invs_minor2) - apply (rule_tac Q'="\_ s. - st_tcb_at inactive recvr s \ - invs s \ valid_list s \ scheduler_act_not recvr s \ - ex_nonz_cap_to recvr s \ current_time_bounded s \ - recvr \ idle_thread s \ - fault_tcb_at ((=) None) recvr s \ - valid_release_q s \ - active_scs_valid s \ - heap_refs_inv (sc_tcbs_of s) (tcb_scps_of s) \ - (pred_map_eq None (tcb_scps_of s) recvr \ active_sc_tcb_at recvr s) \ - not_queued recvr s \ not_in_release_q recvr s" - in hoare_strengthen_post[rotated]) - apply (clarsimp split: if_split simp: pred_tcb_at_def obj_at_def) - apply (wpsimp wp: thread_set_no_change_tcb_state thread_set_cap_to - thread_set_no_change_tcb_state - thread_set_pred_tcb_at_sets_true simp: ran_tcb_cap_cases) - apply simp - apply (wpsimp wp: hoare_drop_imp) - apply wpsimp - apply wpsimp - apply wpsimp - apply (rule_tac Q'="\_. tcb_at' recvr and invs' and cur_tcb'" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: tcb_at'_ex_eq_all invs'_def valid_pspace'_def) - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb', clarsimp simp: valid_tcb'_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) and cur_tcb'" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - 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) and cur_tcb'" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (fastforce dest: global'_no_ex_cap simp: invs'_def split: if_split) - apply (wpsimp wp: threadSet_fault_invs' threadSet_pred_tcb_no_state threadSet_cur) - apply wpsimp+ - apply (wpsimp wp: thread_get_wp') - apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\_. tcb_at sender and tcb_at recvr and invs and valid_list and - valid_sched and scheduler_act_not recvr and not_in_release_q recvr and - active_if_bound_sc_tcb_at recvr and st_tcb_at inactive recvr and - ex_nonz_cap_to recvr and not_queued recvr and current_time_bounded" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_sched_def invs_def valid_state_def valid_pspace_def - pred_tcb_at_def obj_at_def - 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 cur_tcb' 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 (clarsimp simp: op_equal invs'_def obj_at'_def) - apply wpsimp - apply (wpsimp wp: get_tcb_obj_ref_wp) - apply (wpsimp wp: threadGet_wp) - apply (rule_tac Q'="\_. tcb_at sender and tcb_at recvr and invs and valid_list and - valid_sched and scheduler_act_not recvr and not_in_release_q recvr and - active_if_bound_sc_tcb_at recvr and st_tcb_at inactive recvr and - ex_nonz_cap_to recvr and not_queued recvr and current_time_bounded" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_sched_def invs_def valid_state_def valid_pspace_def - dest!: idle_no_ex_cap) - apply (erule disjE; - clarsimp simp: vs_all_heap_simps obj_at_def is_sc_obj opt_map_red opt_pred_def) - apply (rule conjI) - apply (erule (1) valid_sched_context_size_objsI) - apply (clarsimp split: if_split) - apply (drule sym_refs_inv_tcb_scps, rename_tac scp sc n t tcb') - 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 and cur_tcb'" - in hoare_strengthen_post[rotated]) - 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 - valid_sched_action_weak_valid_sched_action - cong: conj_cong) - apply (rename_tac recvr ts_reply s s') - apply (subgoal_tac "ts_reply = reply", simp) - apply (rule conjI, fastforce) - apply (rule context_conjI) - apply (clarsimp simp: tcb_at_kh_simps pred_map_def) - apply (subgoal_tac "\ pred_map runnable (tcb_sts_of s) recvr") - apply (intro conjI) - apply (rule weak_valid_sched_action_contrap; simp add: valid_sched_action_def) - apply (rule valid_release_q_not_in_release_q_not_runnable; clarsimp simp: tcb_at_kh_simps pred_map_def) - apply (erule (1) released_ipc_queuesE1) - apply (erule (1) st_tcb_ex_cap, clarsimp) - apply (erule valid_ready_qs_not_queued_not_runnable, clarsimp) - apply (clarsimp simp: tcb_at_kh_simps pred_map_def) - apply (clarsimp simp: tcb_at_kh_simps pred_map_def) - 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 (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) - apply (clarsimp split: option.split - simp: invs_def valid_state_def valid_pspace_def invs'_def - valid_pspace'_def) - apply (frule cross_relF[OF _ reply_at'_cross_rel[where t=reply]]; clarsimp) - apply (frule (1) reply_ko_at_valid_objs_valid_reply') - apply (clarsimp simp: valid_reply'_def) +lemma sendSignal_st_tcb'_Running: + "\st_tcb_at' (\st. st = Running \ P st) t\ + sendSignal ntfnptr bdg + \\_. st_tcb_at' (\st. st = Running \ P st) t\" + apply (simp add: sendSignal_def) + apply (wp sts_st_tcb_at'_cases cancelIPC_st_tcb_at' gts_wp' getNotification_wp hoare_weak_lift_imp + | wpc | clarsimp simp: pred_tcb_at')+ done end diff --git a/proof/refine/ARM/KHeap_R.thy b/proof/refine/ARM/KHeap_R.thy index ca287174fe..9473f54f06 100644 --- a/proof/refine/ARM/KHeap_R.thy +++ b/proof/refine/ARM/KHeap_R.thy @@ -1,5 +1,4 @@ (* - * Copyright 2022, Proofcraft Pty Ltd * Copyright 2014, General Dynamics C4 Systems * * SPDX-License-Identifier: GPL-2.0-only @@ -7,84 +6,22 @@ theory KHeap_R imports - "AInvs.AInvs" + "AInvs.ArchDetSchedSchedule_AI" Machine_R begin -lemma obj_at_replyTCBs_of: - "obj_at' (\reply. replyTCB reply = tptr_opt) rptr s - \ replyTCBs_of s rptr = tptr_opt" - by (clarsimp simp: obj_at'_def projectKOs opt_map_def) - -abbreviation - "valid_replies'_alt s \ - (\rptr rp. ko_at' rp rptr s \ ((\rp'. replyNext rp = Some (Next rp')) \ replyPrev rp \ None) - \ (\tptr. replyTCB rp = Some tptr - \ st_tcb_at' ((=) (BlockedOnReply (Some rptr))) tptr s))" - -lemma valid_replies'_def2: - "pspace_distinct' s \ pspace_aligned' s \ - valid_replies' s = valid_replies'_alt s" - unfolding valid_replies'_def - apply (rule iffI; clarsimp simp: obj_at'_def projectKOs valid_sz_simps) - apply (drule_tac x=rptr in spec, clarsimp simp: opt_map_def) - apply (clarsimp simp: pspace_alignedD' pspace_distinctD' opt_map_def projectKOs - split: option.splits) - done - -primrec - same_caps' :: "Structures_H.kernel_object \ Structures_H.kernel_object \ bool" -where - "same_caps' val (KOTCB tcb) = (\tcb'. val = KOTCB tcb' \ - (\(getF, t) \ ran tcb_cte_cases. getF tcb' = getF tcb))" -| "same_caps' val (KOCTE cte) = (val = KOCTE cte)" -| "same_caps' val (KOEndpoint ep) = (\ep'. val = KOEndpoint ep')" -| "same_caps' val (KONotification ntfn) = (\ntfn'. val = KONotification ntfn')" -| "same_caps' val (KOKernelData) = (val = KOKernelData)" -| "same_caps' val (KOUserData) = (val = KOUserData)" -| "same_caps' val (KOUserDataDevice) = (val = KOUserDataDevice)" -| "same_caps' val (KOArch ao) = (\ao'. val = KOArch ao')" -| "same_caps' val (KOSchedContext sc) = (\sc'. val = KOSchedContext sc')" -| "same_caps' val (KOReply r) = (\r'. val = KOReply r')" - -lemma same_caps'_more_simps[simp]: - "same_caps' (KOTCB tcb) val = (\tcb'. val = KOTCB tcb' \ - (\(getF, t) \ ran tcb_cte_cases. getF tcb' = getF tcb))" - "same_caps' (KOCTE cte) val = (val = KOCTE cte)" - "same_caps' (KOEndpoint ep) val = (\ep'. val = KOEndpoint ep')" - "same_caps' (KONotification ntfn) val = (\ntfn'. val = KONotification ntfn')" - "same_caps' (KOKernelData) val = (val = KOKernelData)" - "same_caps' (KOUserData) val = (val = KOUserData)" - "same_caps' (KOUserDataDevice) val = (val = KOUserDataDevice)" - "same_caps' (KOArch ao) val = (\ao'. val = KOArch ao')" - "same_caps' (KOSchedContext sc) val = (\sc'. val = KOSchedContext sc')" - "same_caps' (KOReply r) val = (\r'. val = KOReply r')" - by (cases val; fastforce)+ - lemma lookupAround2_known1: "m x = Some y \ fst (lookupAround2 x m) = Some (x, y)" by (fastforce simp: lookupAround2_char1) -abbreviation (input) - set_ko' :: "machine_word \ kernel_object \ kernel_state \ kernel_state" -where - "set_ko' ptr ko s \ s\ksPSpace := (ksPSpace s)(ptr := Some ko)\" - -abbreviation (input) - set_obj' :: "machine_word \ ('a :: pspace_storable) \ kernel_state \ kernel_state" -where - "set_obj' ptr obj s \ set_ko' ptr (injectKO obj) s" - -context begin interpretation Arch . (*FIXME: arch_split*) +lemma koTypeOf_injectKO: + fixes v :: "'a :: pspace_storable" + shows "koTypeOf (injectKO v) = koType TYPE('a)" + apply (cut_tac v1=v in iffD2 [OF project_inject, OF refl]) + apply (simp add: project_koType[symmetric]) + done -lemma ovalid_readObject[wp]: - assumes R: - "\a n ko s obj::'a::pspace_storable. - \ loadObject t t n ko s = Some a; projectKO_opt ko = Some obj \ \ a = obj" - shows "ovalid (obj_at' P t) (readObject t) (\(rv::'a::pspace_storable) _. P rv)" - by (auto simp: obj_at'_def readObject_def split_def omonad_defs obind_def - lookupAround2_known1 projectKOs ovalid_def - dest: R) +context begin interpretation Arch . (*FIXME: arch-split*) lemma setObject_modify_variable_size: fixes v :: "'a :: pspace_storable" shows @@ -118,90 +55,69 @@ lemma setObject_modify: lemma obj_at_getObject: assumes R: - "\a n ko s obj::'a::pspace_storable. - \ loadObject t t n ko s = Some a; projectKO_opt ko = Some obj \ \ a = obj" + "\a b n ko s obj::'a::pspace_storable. + \ (a, b) \ fst (loadObject t t n ko s); projectKO_opt ko = Some obj \ \ a = obj" shows "\obj_at' P t\ getObject t \\(rv::'a::pspace_storable) s. P rv\" - unfolding getObject_def - apply wpsimp - using R use_ovalid[OF ovalid_readObject] by blast + by (auto simp: getObject_def obj_at'_def in_monad valid_def + split_def projectKOs lookupAround2_known1 + dest: R) declare projectKO_inv [wp] +lemma loadObject_default_inv: + "\P\ loadObject_default addr addr' next obj \\rv. P\" + apply (simp add: loadObject_default_def magnitudeCheck_def + alignCheck_def unless_def alignError_def + | wp hoare_vcg_split_case_option + hoare_drop_imps hoare_vcg_all_lift)+ + done + lemma getObject_inv: - "\P\ getObject p \\(rv :: 'a :: pspace_storable). P\" - unfolding getObject_def by wpsimp - -lemma getObject_tcb_inv [wp]: "\P\ getObject l \\(rv :: Structures_H.tcb). P\" - by (rule getObject_inv) - -lemma loadObject_default_Some [simp]: - "\projectKO_opt ko = Some (obj::'a); - is_aligned p (objBits obj); objBits obj < word_bits; - case_option True (\x. 2 ^ (objBits obj) \ x - p) n; q = p\ - \ bound (loadObject_default p q n ko s:: ('a::pre_storable) option)" - by (clarsimp simp: loadObject_default_def split_def projectKO_def obind_def - alignCheck_def alignError_def magnitudeCheck_def projectKOs - read_alignCheck_def read_alignError_def read_magnitudeCheck_def - unless_def gets_the_def is_aligned_mask omonad_defs - split: option.splits) simp - -lemmas loadObject_default_Some'[simp, intro!] = loadObject_default_Some[simplified] -lemmas loadObject_default_Some''[simp, intro!] - = loadObject_default_Some[where p=p and s=s and n="snd (lookupAround2 p (ksPSpace s))" for p s, - simplified] - -lemma no_ofail_loadObject_default [simp]: - "no_ofail (\s. \obj. projectKO_opt ko = Some (obj::'a) \ objBits obj < word_bits \ + assumes x: "\p q n ko. \P\ loadObject p q n ko \\(rv :: 'a :: pspace_storable). P\" + shows "\P\ getObject p \\(rv :: 'a :: pspace_storable). P\" + by (simp add: getObject_def split_def | wp x)+ + +lemma getObject_inv_tcb [wp]: "\P\ getObject l \\(rv :: Structures_H.tcb). P\" + apply (rule getObject_inv) + apply simp + apply (rule loadObject_default_inv) + done +end +(* FIXME: this should go somewhere in spec *) +translations + (type) "'a kernel" <=(type) "kernel_state \ ('a \ kernel_state) set \ bool" + +context begin interpretation Arch . (*FIXME: arch-split*) + +lemma no_fail_loadObject_default [wp]: + "no_fail (\s. \obj. projectKO_opt ko = Some (obj::'a) \ is_aligned p (objBits obj) \ q = p \ case_option True (\x. 2 ^ (objBits obj) \ x - p) n) - (loadObject_default p q n ko :: ('a::pre_storable) kernel_r)" - by (clarsimp simp: no_ofail_def) - -method no_ofail_readObject_method = - clarsimp simp: obj_at'_def readObject_def obind_def omonad_defs split_def projectKO_eq no_ofail_def, - rule ps_clear_lookupAround2, assumption+, simp, - blast intro: is_aligned_no_overflow, - clarsimp simp: objBits_simps' project_inject word_bits_def split: option.splits - -lemma no_ofail_obj_at'_readObject_tcb[simp]: - "no_ofail (obj_at' (P::tcb \ bool) p) (readObject p::tcb kernel_r)" - by no_ofail_readObject_method - -lemma no_ofail_obj_at'_readObject_ep[simp]: - "no_ofail (obj_at' (P::endpoint \ bool) p) (readObject p::endpoint kernel_r)" - by no_ofail_readObject_method - -lemma no_ofail_obj_at'_readObject_ntfn[simp]: - "no_ofail (obj_at' (P::notification \ bool) p) (readObject p::notification kernel_r)" - by no_ofail_readObject_method - -lemma no_ofail_obj_at'_readObject_reply[simp]: - "no_ofail (obj_at' (P::reply \ bool) p) (readObject p::reply kernel_r)" - by no_ofail_readObject_method - -lemma no_ofail_obj_at'_readObject_sc[simp]: - "no_ofail (obj_at' (P::sched_context \ bool) p) (readObject p::sched_context kernel_r)" - by no_ofail_readObject_method - -lemmas no_ofail_tcb_at'_readObject[wp] = no_ofail_obj_at'_readObject_tcb[where P=\] -lemmas no_ofail_ep_at'_readObject[wp] = no_ofail_obj_at'_readObject_ep[where P=\] -lemmas no_ofail_ntfn_at'_readObject[wp] = no_ofail_obj_at'_readObject_ntfn[where P=\] -lemmas no_ofail_reply_at'_readObject[wp] = no_ofail_obj_at'_readObject_reply[where P=\] -lemmas no_ofail_sc_at'_readObject[wp] = no_ofail_obj_at'_readObject_sc[where P=\] - -lemma no_fail_getObject_misc[wp]: - "no_fail (tcb_at' t) (getObject t :: tcb kernel)" - "no_fail (sc_at' t) (getObject t :: sched_context kernel)" - "no_fail (ep_at' t) (getObject t :: endpoint kernel)" - "no_fail (ntfn_at' t) (getObject t :: notification kernel)" - "no_fail (reply_at' t) (getObject t :: reply kernel)" - by (wpsimp simp: getObject_def wp: no_ofail_gets_the)+ + (loadObject_default p q n ko :: ('a::pre_storable) kernel)" + apply (simp add: loadObject_default_def split_def projectKO_def + alignCheck_def alignError_def magnitudeCheck_def + unless_def) + apply (rule no_fail_pre) + apply (wp case_option_wp) + apply (clarsimp simp: is_aligned_mask) + apply (clarsimp split: option.split_asm) + apply (clarsimp simp: is_aligned_mask[symmetric]) + apply simp + done -lemma lookupAround2_same1[simp]: - "(fst (lookupAround2 x s) = Some (x, y)) = (s x = Some y)" - apply (rule iffI) - apply (simp add: lookupAround2_char1) - apply (simp add: lookupAround2_known1) +lemma no_fail_getObject_tcb [wp]: + "no_fail (tcb_at' t) (getObject t :: tcb kernel)" + apply (simp add: getObject_def split_def) + apply (rule no_fail_pre) + apply wp + apply (clarsimp simp add: obj_at'_def projectKOs objBits_simps' + cong: conj_cong) + apply (rule ps_clear_lookupAround2, assumption+) + apply simp + apply (simp add: field_simps) + apply (erule is_aligned_no_wrap') + apply simp + apply (fastforce split: option.split_asm simp: objBits_simps' archObjSize_def) done lemma typ_at_to_obj_at': @@ -211,7 +127,7 @@ lemma typ_at_to_obj_at': lemmas typ_at_to_obj_at_arches = typ_at_to_obj_at'[where 'a=pte, simplified] - typ_at_to_obj_at'[where 'a=pde, simplified] + typ_at_to_obj_at' [where 'a=pde, simplified] typ_at_to_obj_at'[where 'a=asidpool, simplified] typ_at_to_obj_at'[where 'a=user_data, simplified] typ_at_to_obj_at'[where 'a=user_data_device, simplified] @@ -219,126 +135,55 @@ lemmas typ_at_to_obj_at_arches lemmas page_table_at_obj_at' = page_table_at'_def[unfolded typ_at_to_obj_at_arches] -method readObject_obj_at'_method - = clarsimp simp: readObject_def obind_def omonad_defs split_def loadObject_default_def - obj_at'_def objBits_simps' scBits_pos_power2 projectKOs - split: option.splits if_split_asm - -lemma readObject_misc_ko_at'[simp]: - shows - readObject_ko_at'_tcb: "readObject p s = Some (tcb :: tcb) \ ko_at' tcb p s" and - readObject_ko_at'_ep: "readObject p s = Some (ep :: endpoint) \ ko_at' ep p s" and - readObject_ko_at'_ntfn: "readObject p s = Some (ntfn :: notification) \ ko_at' ntfn p s" and - readObject_ko_at'_reply: "readObject p s = Some (reply :: reply) \ ko_at' reply p s" and - readObject_ko_at'_sc: "readObject p s = Some (sc :: sched_context) \ ko_at' sc p s" - by readObject_obj_at'_method+ - -lemma readObject_misc_obj_at'[simplified, simp]: - shows - readObject_tcb_at': "bound (readObject p s :: tcb option) \ tcb_at' p s" and - readObject_ep_at': "bound (readObject p s :: endpoint option) \ ep_at' p s" and - readObject_ntfn_at': "bound (readObject p s :: notification option) \ ntfn_at' p s" and - readObject_reply_at': "bound (readObject p s :: reply option) \ reply_at' p s" and - readObject_sc_at': "bound (readObject p s :: sched_context option) \ sc_at' p s" - by readObject_obj_at'_method+ - -lemma getObject_tcb_at': - "\ \ \ getObject t \\r::tcb. tcb_at' t\" - unfolding getObject_def by wpsimp - -lemma koType_objBitsKO: - "\koTypeOf k' = koTypeOf k; koTypeOf k = SchedContextT \ objBitsKO k' = objBitsKO k\ - \ objBitsKO k' = objBitsKO k" - by (auto simp: objBitsKO_def archObjSize_def - split: Structures_H.kernel_object.splits - ARM_H.arch_kernel_object.splits) - -lemma get_object_def2: - "get_object p = do - kh \ gets kheap; - assert (kh p \ None); - return $ the $ kh p - od" - apply (rule ext) - apply (rule monad_state_eqI) - apply ((clarsimp simp: get_object_def gets_the_def gets_def assert_opt_def in_monad - split: option.splits)+)[2] - by (clarsimp simp: snd_bind get_object_def snd_gets_the assert_def exec_gets return_def) - -lemma getObject_def2: - "getObject ptr = do - map \ gets $ psMap \ ksPSpace; - (before, after) \ return (lookupAround2 (fromPPtr ptr) map); - (ptr', val) \ assert_opt before; - gets_the $ loadObject (fromPPtr ptr) ptr' after val - od" - apply (rule ext) - apply (rule monad_state_eqI) - apply (force simp: getObject_def readObject_def gets_the_def exec_gets obind_def split_def - omonad_defs assert_opt_def fail_def return_def in_monad ARM_H.fromPPtr_def - split: option.splits)+ - by (clarsimp simp: snd_bind split_def getObject_def gets_the_def exec_gets assert_opt_def - readObject_def obind_def omonad_defs return_def fail_def - split: option.splits) - -lemma loadObject_default_def2: - "(gets_the $ loadObject_default ptr ptr' next obj) = do - assert (ptr = ptr'); - val \ (case projectKO_opt obj of None \ fail | Some k \ return k); - alignCheck ptr (objBits val); - assert (objBits val < word_bits); - magnitudeCheck ptr next (objBits val); - return val - od" - apply (rule ext) - apply (rule monad_state_eqI) - apply (force simp: loadObject_default_def gets_the_def exec_gets obind_def split_def - omonad_defs assert_opt_def fail_def return_def in_monad ARM_H.fromPPtr_def - read_magnitudeCheck_assert magnitudeCheck_assert projectKOs - split: option.splits if_splits)+ - by (force simp: snd_bind split_def loadObject_default_def gets_the_def exec_gets assert_opt_def - obind_def omonad_defs return_def fail_def projectKO_def assert_def - read_magnitudeCheck_assert magnitudeCheck_assert - read_alignError_def is_aligned_mask alignCheck_def read_alignCheck_def - split: option.splits) - -lemma pspace_relation_tcb_at: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes t: "tcbs_of' s' t \ None" - shows "tcb_at t s" using assms - by (fastforce elim!: pspace_dom_relatedE obj_relation_cutsE opt_mapE - simp: other_obj_relation_def obj_at_def projectKOs is_tcb_def - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm kernel_object.splits) - -lemma pspace_relation_sc_at: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes t: "scs_of' s' scp \ None" - shows "sc_at scp s" using assms - by (fastforce elim!: pspace_dom_relatedE obj_relation_cutsE opt_mapE - simp: other_obj_relation_def is_sc_obj obj_at_def projectKOs - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm) lemma corres_get_tcb [corres]: "corres (tcb_relation \ the) (tcb_at t) (tcb_at' t) (gets (get_tcb t)) (getObject t)" apply (rule corres_no_failI) apply wp - apply (simp add: get_object_def get_tcb_def gets_def gets_the_def getObject_def) - apply (clarsimp simp: in_monad split_def bind_def gets_def get_def return_def - assert_def fail_def obj_at_def is_tcb - dest!: readObject_misc_ko_at') - apply (clarsimp simp: state_relation_def pspace_relation_def obj_at'_def projectKOs) + apply (clarsimp simp add: gets_def get_def return_def bind_def get_tcb_def) + apply (frule in_inv_by_hoareD [OF getObject_inv_tcb]) + apply (clarsimp simp add: obj_at_def is_tcb obj_at'_def projectKO_def + projectKO_opt_tcb split_def + getObject_def loadObject_default_def in_monad) + apply (case_tac koa) + apply (simp_all add: fail_def return_def) + apply (case_tac bb) + apply (simp_all add: fail_def return_def) + apply (clarsimp simp add: state_relation_def pspace_relation_def) apply (drule bspec) + apply clarsimp apply blast - apply (simp add: other_obj_relation_def) + apply (clarsimp simp: tcb_relation_cut_def lookupAround2_known1) + done + +lemma lookupAround2_same1[simp]: + "(fst (lookupAround2 x s) = Some (x, y)) = (s x = Some y)" + apply (rule iffI) + apply (simp add: lookupAround2_char1) + apply (simp add: lookupAround2_known1) done -lemmas tcbSlot_defs = tcbCTableSlot_def tcbVTableSlot_def tcbIPCBufferSlot_def - tcbFaultHandlerSlot_def tcbTimeoutHandlerSlot_def +lemma getObject_tcb_at': + "\ \ \ getObject t \\r::tcb. tcb_at' t\" + by (clarsimp simp: valid_def getObject_def in_monad + loadObject_default_def obj_at'_def projectKOs split_def + in_magnitude_check objBits_simps') text \updateObject_cte lemmas\ +lemma koType_objBitsKO: + "koTypeOf k = koTypeOf k' \ objBitsKO k = objBitsKO k'" + by (auto simp: objBitsKO_def archObjSize_def + split: Structures_H.kernel_object.splits + ARM_H.arch_kernel_object.splits) + +lemma updateObject_objBitsKO: + "(ko', t') \ fst (updateObject (val :: 'a :: pspace_storable) ko p q n t) + \ objBitsKO ko' = objBitsKO ko" + apply (drule updateObject_type) + apply (erule koType_objBitsKO) + done + lemma updateObject_cte_is_tcb_or_cte: fixes cte :: cte and ptr :: word32 shows "\ fst (lookupAround2 p (ksPSpace s)) = Some (q, ko); @@ -354,19 +199,16 @@ lemma updateObject_cte_is_tcb_or_cte: lookupAround2_char1 split: kernel_object.splits) apply (subst(asm) in_magnitude_check3, simp+) - apply (simp add: in_monad tcbSlot_defs + apply (simp add: in_monad tcbCTableSlot_def tcbVTableSlot_def + tcbReplySlot_def tcbCallerSlot_def tcbIPCBufferSlot_def split: if_split_asm) - apply (simp add: in_monad tcbSlot_defs + apply (simp add: in_monad tcbCTableSlot_def tcbVTableSlot_def + tcbReplySlot_def tcbCallerSlot_def tcbIPCBufferSlot_def split: if_split_asm) done declare plus_1_less[simp] -lemma setObject_sc_at'_n[wp]: - "setObject ptr val \\s. P (sc_at'_n n p s)\" - by (fastforce simp : valid_def setObject_def ko_wp_at'_def in_monad split_def updateObject_size - ps_clear_upd lookupAround2_char1 updateObject_type word_bits_def) - lemma updateObject_default_result: "(x, s'') \ fst (updateObject_default e ko p q n s) \ x = injectKO e" by (clarsimp simp add: updateObject_default_def in_monad) @@ -374,6 +216,7 @@ lemma updateObject_default_result: lemma obj_at_setObject1: assumes R: "\(v::'a::pspace_storable) p q n ko s x s''. (x, s'') \ fst (updateObject v ko p q n s) \ x = injectKO v" + assumes Q: "\(v::'a::pspace_storable) (v'::'a). objBits v = objBits v'" shows "\ obj_at' (\x::'a::pspace_storable. True) t \ setObject p (v::'a::pspace_storable) @@ -382,10 +225,13 @@ lemma obj_at_setObject1: apply (rule bind_wp [OF _ hoare_gets_sp]) apply (clarsimp simp: valid_def in_monad obj_at'_def projectKOs lookupAround2_char1 - project_inject) - apply (frule updateObject_size, drule R) + project_inject + dest!: R) + apply (subgoal_tac "objBitsKO (injectKO v) = objBitsKO (injectKO obj)") apply (intro conjI impI, simp_all) apply fastforce+ + apply (fold objBits_def) + apply (rule Q) done lemma obj_at_setObject2: @@ -410,271 +256,56 @@ lemma obj_at_setObject2: apply (clarsimp simp: ps_clear_upd lookupAround2_char1) done -\\ - If the old and new versions of an object are the same size, then showing - `obj_at'` for the updated state is the same as showing the predicate for - the new value; we get to "reuse" the existing PSpace properties. -\ -lemma same_size_obj_at'_set_obj'_iff: - fixes obj :: "'a :: pspace_storable" - assumes "obj_at' (\old_obj :: 'a. objBits old_obj = objBits obj) ptr s" - shows "obj_at' P ptr (set_obj' ptr obj s) = P obj" - apply (rule iffI) - apply (prop_tac "ko_at' obj ptr (set_obj' ptr obj s)") - apply (clarsimp simp: obj_at'_def projectKO_eq project_inject) - apply (clarsimp simp: obj_at'_def) - using assms - apply (fastforce simp: obj_at'_def inj_def projectKO_eq project_inject objBits_def) - done - -lemma tcb_at'_obj_at'_set_obj'[unfolded injectKO_tcb]: - assumes "P (tcb :: tcb)" - and "tcb_at' ptr s" - shows "obj_at' P ptr (set_obj' ptr tcb s)" - using assms - apply (clarsimp simp: objBits_def objBitsKO_def inj_def - same_size_obj_at'_set_obj'_iff[where 'a=tcb, simplified]) - done - -\\ - Keeps a generic @{term obj_at'} (rather than a specific @{term "obj_at' (\_. True)"}) to match - in more simp contexts. -\ -lemma tcb_obj_at'_set_obj'_iff: - fixes tcb :: tcb - and P Q :: "tcb \ bool" - shows "obj_at' P p s \ obj_at' Q p (set_obj' p tcb s) = Q tcb" - apply (rule same_size_obj_at'_set_obj'_iff) - apply (clarsimp simp: objBits_simps obj_at'_def) - done - -lemmas tcb_obj_at'_pred_tcb'_set_obj'_iff = - tcb_obj_at'_set_obj'_iff[where Q="test o proj o tcb_to_itcb'" for test proj, - simplified objBits_simps o_def, simplified, - folded pred_tcb_at'_def] - -lemma same_size_ko_wp_at'_set_ko'_iff: - assumes "ko_wp_at' (\old_ko. objBitsKO old_ko = objBitsKO ko) ptr s" - shows "ko_wp_at' P ptr (set_ko' ptr ko s) = P ko" - apply (rule iffI) - apply (clarsimp simp: ko_wp_at'_def) - using assms - apply (clarsimp simp: ko_wp_at'_def) - apply (erule ps_clear_domE) - apply clarsimp - apply blast - done - -\\ - Moves the @{term ksPSpace_update} to the top. -\ -lemma unfold_set_ko': - "set_ko' ptr ko s = ksPSpace_update (\ps. ps(ptr := Some ko)) s" - by clarsimp - -lemma ko_wp_at'_set_ko'_distinct: - assumes "ptr \ ptr'" - "ko_wp_at' \ ptr' s" - shows "ko_wp_at' P ptr (set_ko' ptr' ko s) = ko_wp_at' P ptr s" - using assms - apply (clarsimp simp: ko_wp_at'_def) - apply (rule iffI; clarsimp) - apply (erule ps_clear_domE) - apply clarsimp - apply blast - apply (erule ps_clear_domE) - apply clarsimp - apply blast - done - -lemma obj_at'_set_obj'_distinct: - assumes "p \ p'" - "obj_at' Q p' s" - shows "obj_at' P p (set_ko' p' ko s) = obj_at' P p s" - using assms apply - - apply (rule iffI; fastforce simp: obj_at'_def projectKO_eq project_inject ps_clear_upd) - done - -lemmas pred_tcb_at'_set_obj'_distinct = - obj_at'_set_obj'_distinct[where P="test o proj o tcb_to_itcb'" for test proj, - simplified o_def, folded pred_tcb_at'_def] - -lemmas pred_tcb_at'_set_obj'_iff = - tcb_obj_at'_set_obj'_iff[where Q="test o proj o tcb_to_itcb'" for test proj, - simplified o_def injectKO_tcb, folded pred_tcb_at'_def] - -lemma non_sc_same_typ_at'_objBits_always_the_same: - assumes "typ_at' t ptr s" - "koTypeOf ko = t" - "t \ SchedContextT" - shows "ko_wp_at' (\old_ko. objBitsKO old_ko = objBitsKO ko) ptr s" - using assms - apply (clarsimp simp: typ_at'_def ko_wp_at'_def) - apply (rule koType_objBitsKO) - apply simp+ - done - -lemmas non_sc_same_typ_at'_ko_wp_at'_set_ko'_iff = - same_size_ko_wp_at'_set_ko'_iff[OF non_sc_same_typ_at'_objBits_always_the_same] - -(* Worth adding other typ_at's? *) -lemma typ_at'_ksPSpace_exI: - "pde_at' ptr s \ \pde. ksPSpace s ptr = Some (KOArch (KOPDE pde))" - "pte_at' ptr s \ \pte. ksPSpace s ptr = Some (KOArch (KOPTE pte))" - apply - - apply (clarsimp simp: typ_at'_def ko_wp_at'_def, - (case_tac ko; clarsimp), - (rename_tac arch, case_tac arch; clarsimp)?)+ - done - -\\ - Used to show a stronger variant of @{thm obj_at_setObject2} - for many concrete types. - - Needs to be a definition so we can easily refer to it within - ML as a constant. -\ -definition distinct_updateObject_types :: - "('a :: pspace_storable) itself \ ('b :: pspace_storable) itself \ bool" -where - "distinct_updateObject_types t t' \ - (\ko' s' (v :: 'a) ko p before after s. - (ko', s') \ fst (updateObject v ko p before after s) - \ koTypeOf ko' \ koType TYPE('b))" +lemma updateObject_ep_eta: + "updateObject (v :: endpoint) = updateObject_default v" + by ((rule ext)+, simp) -lemma setObject_distinct_types_preserves_obj_at'_pre: - fixes v :: "'a :: pspace_storable" - and P :: "'b :: pspace_storable \ bool" - assumes distinct_types[unfolded distinct_updateObject_types_def, rule_format]: - "distinct_updateObject_types TYPE('a) TYPE('b)" - shows "setObject p v \\s. P' (obj_at' P t s)\" - apply (simp add: setObject_def split_def) - apply (rule bind_wp [OF _ hoare_gets_sp]) - apply (clarsimp simp: valid_def in_monad) - apply (frule updateObject_type) - apply (erule_tac P="P'" in rsubst) - apply (drule distinct_types) - apply (clarsimp simp: lookupAround2_char1) - apply (case_tac "obj_at' P t s") - apply (clarsimp simp: obj_at'_def projectKOs) - using project_koType ps_clear_upd - apply fastforce - apply (clarsimp simp: obj_at'_def projectKOs ps_clear_upd) - apply (intro impI conjI iffI; metis project_koType) - done +lemma updateObject_tcb_eta: + "updateObject (v :: tcb) = updateObject_default v" + by ((rule ext)+, simp) -\\ - We're using @{command ML_goal} here because we want to show - `distinct_updateObject_types TYPE('a) TYPE('b)` for around - 50 different combinations of 'a and 'b. Doing that by hand would - be painful, and not as clear for future readers as this comment - plus this ML code. -\ -ML \ -local - val ko_types = [ - @{typ notification}, - @{typ tcb}, - @{typ cte}, - @{typ sched_context}, - @{typ reply}, - @{typ endpoint}, - - (*FIXME: arch_split*) - @{typ asidpool}, - @{typ pte}, - @{typ pde} - ]; - - val skipped_pairs = [ - \\ - This corresponds to the case where we're inserting a CTE into - a TCB, which is the only case where the first two arguments - to `updateObject` should have different types. - - See the comment on @{term updateObject} for more information. - \ - (@{typ cte}, @{typ tcb}) - ]; - - fun skips (ts as (typ, typ')) = - typ = typ' orelse Library.member (op =) skipped_pairs ts; - - fun mk_distinct_goal (typ, typ') = - Const (@{const_name distinct_updateObject_types}, - Term.itselfT typ --> Term.itselfT typ' --> @{typ bool}) - $ Logic.mk_type typ - $ Logic.mk_type typ'; -in - val distinct_updateObject_types_goals = - Library.map_product pair ko_types ko_types - |> Library.filter_out skips - |> List.map mk_distinct_goal -end -\ +lemma updateObject_ntfn_eta: + "updateObject (v :: Structures_H.notification) = updateObject_default v" + by ((rule ext)+, simp) -ML_goal distinct_updateObject_types: \ - distinct_updateObject_types_goals -\ - apply - - \\ - The produced goals match the following pattern: - \ - apply (all \match conclusion in \distinct_updateObject_types _ _\ \ -\) - unfolding distinct_updateObject_types_def - apply safe - apply (clarsimp simp: distinct_updateObject_types_def - setObject_def updateObject_cte updateObject_default_def - typeError_def in_monad - split: if_splits kernel_object.splits)+ - done - -lemmas setObject_distinct_types_preserves_obj_at'[wp] = - distinct_updateObject_types[THEN setObject_distinct_types_preserves_obj_at'_pre] - -(* FIXME RT: these overlap substantially with `setObject_distinct_types_preserves_obj_at'`, - but fixing that requires having names for the relevant subset of lemmas. We can't do that with - attributes, but we might be able to do it with a new command (`lemmas_matching`?) once `match` - is factored. - - This doesn't really matter in this case because you're never going to refer to these lemmas by - name. *) -lemmas set_distinct_types_preserves_obj_at'[wp] = - setObject_distinct_types_preserves_obj_at'[folded setReply_def setNotification_def setCTE_def - setSchedContext_def setEndpoint_def] - -lemmas set_distinct_types_preserves_pred_tcb_at'[wp] = - set_distinct_types_preserves_obj_at'[TRY[where P="test o proj o tcb_to_itcb'" for test proj, - simplified o_def, folded pred_tcb_at'_def, rule_format]] - setObject_distinct_types_preserves_obj_at'[TRY[where P="test o proj o tcb_to_itcb'" for test proj, - simplified o_def, folded pred_tcb_at'_def, - rule_format]] +lemmas updateObject_eta = + updateObject_ep_eta updateObject_tcb_eta updateObject_ntfn_eta -end +lemma objBits_type: + "koTypeOf k = koTypeOf k' \ objBitsKO k = objBitsKO k'" + by (erule koType_objBitsKO) lemma setObject_typ_at_inv: "\typ_at' T p'\ setObject p v \\r. typ_at' T p'\" - by (clarsimp simp: setObject_def split_def valid_def typ_at'_def ko_wp_at'_def in_monad - lookupAround2_char1 ps_clear_upd updateObject_size updateObject_type) + apply (clarsimp simp: setObject_def split_def) + apply (clarsimp simp: valid_def typ_at'_def ko_wp_at'_def in_monad + lookupAround2_char1 ps_clear_upd) + apply (drule updateObject_type) + apply clarsimp + apply (drule objBits_type) + apply (simp add: ps_clear_upd) + done lemma setObject_typ_at_not: "\\s. \ (typ_at' T p' s)\ setObject p v \\r s. \ (typ_at' T p' s)\" apply (clarsimp simp: setObject_def valid_def in_monad split_def) apply (erule notE) - by (clarsimp simp: typ_at'_def ko_wp_at'_def lookupAround2_char1 - updateObject_size updateObject_type - split: if_split_asm - elim!: ps_clear_domE) - fastforce+ + apply (clarsimp simp: typ_at'_def ko_wp_at'_def lookupAround2_char1 + split: if_split_asm) + apply (drule updateObject_type) + apply clarsimp + apply (drule objBits_type) + apply (clarsimp elim!: ps_clear_domE) + apply fastforce + apply (clarsimp elim!: ps_clear_domE) + apply fastforce + done lemma setObject_typ_at'[wp]: "\\s. P (typ_at' T p' s)\ setObject p v \\r s. P (typ_at' T p' s)\" by (blast intro: P_bool_lift setObject_typ_at_inv setObject_typ_at_not) -global_interpretation setObject: typ_at_all_props' "setObject p v" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas setObject_typ_ats [wp] = typ_at_lifts [OF setObject_typ_at'] lemma setObject_cte_wp_at2': assumes x: "\x n tcb s t. \ t \ fst (updateObject v (KOTCB tcb) ptr x n s); Q s; @@ -717,10 +348,49 @@ lemma setObject_cte_wp_at': unfolding pred_conj_def by (rule setObject_cte_wp_at2'[OF x y], assumption+) +lemma setObject_ep_pre: + assumes "\P and ep_at' p\ setObject p (e::endpoint) \Q\" + shows "\P\ setObject p (e::endpoint) \Q\" using assms + apply (clarsimp simp: valid_def setObject_def in_monad + split_def updateObject_default_def + projectKOs in_magnitude_check objBits_simps') + apply (drule spec, drule mp, erule conjI) + apply (simp add: obj_at'_def projectKOs objBits_simps') + apply (simp add: split_paired_Ball) + apply (drule spec, erule mp) + apply (clarsimp simp: in_monad projectKOs in_magnitude_check) + done + +lemma setObject_ntfn_pre: + assumes "\P and ntfn_at' p\ setObject p (e::Structures_H.notification) \Q\" + shows "\P\ setObject p (e::Structures_H.notification) \Q\" using assms + apply (clarsimp simp: valid_def setObject_def in_monad + split_def updateObject_default_def + projectKOs in_magnitude_check objBits_simps') + apply (drule spec, drule mp, erule conjI) + apply (simp add: obj_at'_def projectKOs objBits_simps') + apply (simp add: split_paired_Ball) + apply (drule spec, erule mp) + apply (clarsimp simp: in_monad projectKOs in_magnitude_check) + done + +lemma setObject_tcb_pre: + assumes "\P and tcb_at' p\ setObject p (t::tcb) \Q\" + shows "\P\ setObject p (t::tcb) \Q\" using assms + apply (clarsimp simp: valid_def setObject_def in_monad + split_def updateObject_default_def + projectKOs in_magnitude_check objBits_simps') + apply (drule spec, drule mp, erule conjI) + apply (simp add: obj_at'_def projectKOs objBits_simps') + apply (simp add: split_paired_Ball) + apply (drule spec, erule mp) + apply (clarsimp simp: in_monad projectKOs in_magnitude_check) + done + lemma obj_at_setObject3: fixes Q::"'a::pspace_storable \ bool" fixes P::"'a::pspace_storable \ bool" - assumes R: "\ko s y n. (updateObject v ko p y n s) + assumes R: "\ko s x y n. (updateObject v ko p y n s) = (updateObject_default v ko p y n s)" assumes P: "\(v::'a::pspace_storable). (1 :: word32) < 2 ^ (objBits v)" shows "\(\s. P v)\ setObject p v \\rv. obj_at' P p\" @@ -753,93 +423,57 @@ method setObject_easy_cases = 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 projectKO_opts_defs projectKO_eq + typeError_def opt_map_def opt_pred_def projectKO_opts_defs projectKOs projectKO_eq split: if_split_asm Structures_H.kernel_object.split_asm -lemma setObject_endpoint_replies_of'[wp]: - "setObject c (endpoint::endpoint) \\s. P' (replies_of' s)\" +lemma setObject_endpoint_tcbs_of'[wp]: + "setObject c (endpoint :: endpoint) \\s. P' (tcbs_of' s)\" by setObject_easy_cases -lemma setObject_notification_replies_of'[wp]: - "setObject c (notification::notification) \\s. P' (replies_of' s)\" +lemma setObject_notification_tcbs_of'[wp]: + "setObject c (notification :: notification) \\s. P' (tcbs_of' s)\" by setObject_easy_cases -lemma setObject_tcb_replies_of'[wp]: - "setObject c (tcb::tcb) \\s. P' (replies_of' s)\" +lemma setObject_cte_tcbSchedNexts_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedNexts_of s)\" by setObject_easy_cases -lemma setObject_sched_context_replies_of'[wp]: - "setObject c (sched_context::sched_context) \\s. P' (replies_of' s)\" +lemma setObject_cte_tcbSchedPrevs_of[wp]: + "setObject c (cte :: cte) \\s. P' (tcbSchedPrevs_of s)\" by setObject_easy_cases -lemma setObject_cte_replies_of'[wp]: - "setObject c (cte::cte) \\s. P' (replies_of' s)\" - by setObject_easy_cases - -\\ - 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 @{term - "\s. replies_of' s c \ None \ P' ((replies_of' s)(c \ reply))" - } -\ -lemma setObject_reply_replies_of'[wp]: - "\\s. P' ((replies_of' s)(c \ reply))\ - setObject c (reply::reply) - \\_ s. P' (replies_of' s)\" +lemma setObject_cte_tcbQueued[wp]: + "setObject c (cte :: cte) \\s. P' (tcbQueued |< tcbs_of' s)\" + supply inQ_def[simp] by setObject_easy_cases -\\ - 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 @{term - "\s. scs_of' s c \ None \ P' ((scs_of' s)(c \ sched_context))" - } -\ -lemma setObject_sched_context_scs_of'[wp]: - "\\s. P' ((scs_of' s)(c \ sched_context))\ - setObject c (sched_context::sched_context) - \\_ s. P' (scs_of' s)\" +lemma setObject_cte_inQ[wp]: + "setObject c (cte :: cte) \\s. P' (inQ d p |< tcbs_of' s)\" + supply inQ_def[simp] by setObject_easy_cases -lemma setObject_scs_of'[wp]: - "setObject c (cte::cte) \\s. P' (scs_of' s)\" - "setObject c (reply::reply) \\s. P' (scs_of' s)\" - "setObject c (tcb::tcb) \\s. P' (scs_of' s)\" - "setObject c (notification::notification) \\s. P' (scs_of' s)\" - "setObject c (endpoint::endpoint) \\s. P' (scs_of' s)\" - by setObject_easy_cases+ - -lemmas setReply_replies_of' = setObject_reply_replies_of'[folded setReply_def] - -crunch setNotification, setEndpoint, setSchedContext, setCTE - for replies_of'[wp]: "\s. P (replies_of' s)" - -lemmas setSchedContext_scs_of_of' = - setObject_sched_context_scs_of'[folded setSchedContext_def] - -crunch setNotification, setEndpoint, setCTE, setReply - for scs_of'[wp]: "\s. P (scs_of' s)" - lemma getObject_obj_at': assumes x: "\q n ko. loadObject p q n ko = - (loadObject_default p q n ko :: ('a :: pspace_storable) kernel_r)" + (loadObject_default p q n ko :: ('a :: pspace_storable) kernel)" + assumes P: "\(v::'a::pspace_storable). (1 :: word32) < 2 ^ (objBits v)" shows "\ \ \ getObject p \\r::'a::pspace_storable. obj_at' ((=) r) p\" - by (clarsimp simp: valid_def getObject_def in_monad omonad_defs readObject_def + by (clarsimp simp: valid_def getObject_def in_monad loadObject_default_def obj_at'_def projectKOs split_def in_magnitude_check lookupAround2_char1 - x project_inject objBits_def[symmetric] - split: option.split_asm if_split_asm) + x P project_inject objBits_def[symmetric]) lemma getObject_valid_obj: assumes x: "\p q n ko. loadObject p q n ko = - (loadObject_default p q n ko :: ('a :: pspace_storable) kernel_r)" + (loadObject_default p q n ko :: ('a :: pspace_storable) kernel)" + assumes P: "\(v::'a::pspace_storable). (1 :: word32) < 2 ^ (objBits v)" shows "\ valid_objs' \ getObject p \\rv::'a::pspace_storable. valid_obj' (injectKO rv) \" apply (rule hoare_chain) apply (rule hoare_vcg_conj_lift) - apply (rule getObject_obj_at' [OF x]) + apply (rule getObject_obj_at' [OF x P]) apply (rule getObject_inv) + apply (subst x) + apply (rule loadObject_default_inv) apply (clarsimp, assumption) apply clarsimp apply (drule(1) obj_at_valid_objs') @@ -853,13 +487,18 @@ lemma typeError_inv [wp]: by (simp add: typeError_def|wp)+ lemma getObject_cte_inv [wp]: "\P\ (getObject addr :: cte kernel) \\rv. P\" - by (wpsimp simp: getObject_def) + apply (simp add: getObject_def loadObject_cte split_def) + apply (clarsimp simp: valid_def in_monad) + apply (clarsimp simp: typeError_def in_monad magnitudeCheck_def + split: kernel_object.split_asm if_split_asm option.split_asm) + done lemma getObject_ko_at: assumes x: "\q n ko. loadObject p q n ko = - (loadObject_default p q n ko :: ('a :: pspace_storable) kernel_r)" + (loadObject_default p q n ko :: ('a :: pspace_storable) kernel)" + assumes P: "\(v::'a::pspace_storable). (1 :: word32) < 2 ^ (objBits v)" shows "\ \ \ getObject p \\r::'a::pspace_storable. ko_at' r p\" - by (subst eq_commute, rule getObject_obj_at' [OF x]) + by (subst eq_commute, rule getObject_obj_at' [OF x P]) lemma getObject_ko_at_tcb [wp]: "\\\ getObject p \\rv::tcb. ko_at' rv p\" @@ -878,77 +517,126 @@ lemma setObject_nosch: apply (wp x | simp)+ done -context -begin +lemma getObject_ep_inv: "\P\ (getObject addr :: endpoint kernel) \\rv. P\" + apply (rule getObject_inv) + apply (simp add: loadObject_default_inv) + done -private method getObject_valid_obj = - rule hoare_chain, - rule getObject_valid_obj; clarsimp simp: objBits_simps' valid_obj'_def scBits_pos_power2 +lemma getObject_ntfn_inv: + "\P\ (getObject addr :: Structures_H.notification kernel) \\rv. P\" + apply (rule getObject_inv) + apply (simp add: loadObject_default_inv) + done -lemma get_ep'_valid_ep[wp]: - "\ valid_objs' \ getEndpoint ep \ valid_ep' \" - unfolding getEndpoint_def by getObject_valid_obj +lemma get_ep_inv'[wp]: "\P\ getEndpoint ep \\rv. P\" + by (simp add: getEndpoint_def getObject_ep_inv) -lemma get_ntfn'_valid_ntfn[wp]: - "\ valid_objs' \ getNotification ep \ valid_ntfn' \" - unfolding getNotification_def by getObject_valid_obj +lemma get_ntfn_inv'[wp]: "\P\ getNotification ntfn \\rv. P\" + by (simp add: getNotification_def getObject_ntfn_inv) -lemma get_sc_valid_sc'[wp]: - "\ valid_objs' \ getSchedContext sc \ valid_sched_context' \" - unfolding getSchedContext_def by getObject_valid_obj +lemma get_ep'_valid_ep[wp]: + "\ invs' and ep_at' ep \ getEndpoint ep \ valid_ep' \" + apply (simp add: getEndpoint_def) + apply (rule hoare_chain) + apply (rule getObject_valid_obj) + apply simp + apply (simp add: objBits_simps') + apply clarsimp + apply (simp add: valid_obj'_def) + done -lemma get_reply_valid_reply'[wp]: - "\ valid_objs'\ getReply sc \ valid_reply' \" - unfolding getReply_def by getObject_valid_obj +lemma get_ntfn'_valid_ntfn[wp]: + "\ invs' and ntfn_at' ep \ getNotification ep \ valid_ntfn' \" + apply (simp add: getNotification_def) + apply (rule hoare_chain) + apply (rule getObject_valid_obj) + apply simp + apply (simp add: objBits_simps') + apply clarsimp + apply (simp add: valid_obj'_def) + done -end +lemma setObject_distinct[wp]: + shows "\pspace_distinct'\ setObject p val \\rv. pspace_distinct'\" + apply (clarsimp simp: setObject_def split_def valid_def in_monad + projectKOs pspace_distinct'_def ps_clear_upd + objBits_def[symmetric] lookupAround2_char1 + split: if_split_asm + dest!: updateObject_objBitsKO) + apply (fastforce dest: bspec[OF _ domI]) + apply (fastforce dest: bspec[OF _ domI]) + done -lemma get_ep_ko': - "\\\ getEndpoint ep \\rv. ko_at' rv ep\" - unfolding getEndpoint_def - by (rule getObject_ko_at; simp add: objBits_simps') +lemma setObject_aligned[wp]: + shows "\pspace_aligned'\ setObject p val \\rv. pspace_aligned'\" + apply (clarsimp simp: setObject_def split_def valid_def in_monad + projectKOs pspace_aligned'_def ps_clear_upd + objBits_def[symmetric] lookupAround2_char1 + split: if_split_asm + dest!: updateObject_objBitsKO) + apply (fastforce dest: bspec[OF _ domI]) + apply (fastforce dest: bspec[OF _ domI]) + done -lemma get_ntfn_ko': - "\\\ getNotification ntfn \\rv. ko_at' rv ntfn\" - unfolding getNotification_def - by (rule getObject_ko_at; simp add: objBits_simps') +lemma set_ep_aligned' [wp]: + "\pspace_aligned'\ setEndpoint ep v \\rv. pspace_aligned'\" + unfolding setEndpoint_def by wp -lemma get_sc_ko': - "\\\ getSchedContext sc_ptr \\sc. ko_at' sc sc_ptr\" - unfolding getSchedContext_def - by (rule getObject_ko_at; simp add: objBits_simps' scBits_pos_power2) +lemma set_ep_distinct' [wp]: + "\pspace_distinct'\ setEndpoint ep v \\rv. pspace_distinct'\" + unfolding setEndpoint_def by wp -lemma get_reply_ko': - "\\\ getReply reply_ptr \\reply. ko_at' reply reply_ptr\" - unfolding getReply_def - by (rule getObject_ko_at; simp add: objBits_simps') -context -begin +lemma setEndpoint_cte_wp_at': + "\cte_wp_at' P p\ setEndpoint ptr v \\rv. cte_wp_at' P p\" + unfolding setEndpoint_def + apply (rule setObject_cte_wp_at'[where Q="\", simplified]) + apply (clarsimp simp add: updateObject_default_def in_monad + projectKOs + intro!: set_eqI)+ + done -private method unfold_setObject_inmonad = - (clarsimp simp: setObject_def split_def valid_def in_monad projectKOs updateObject_size - objBits_def[symmetric] lookupAround2_char1 ps_clear_upd - split: if_split_asm), - (fastforce dest: bspec[OF _ domI])+ +lemma setEndpoint_pred_tcb_at'[wp]: + "\pred_tcb_at' proj P t\ setEndpoint ptr val \\rv. pred_tcb_at' proj P t\" + apply (simp add: pred_tcb_at'_def setEndpoint_def) + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_default_def in_monad) + done -lemma setObject_distinct[wp]: - "setObject p val \pspace_distinct'\" - unfolding pspace_distinct'_def by (unfold_setObject_inmonad) +lemma get_ntfn_ko': + "\\\ getNotification ep \\rv. ko_at' rv ep\" + apply (simp add: getNotification_def) + apply (rule getObject_ko_at) + apply simp + apply (simp add: objBits_simps') + done -lemma setObject_aligned[wp]: - "setObject p val \pspace_aligned'\" - unfolding pspace_aligned'_def by (unfold_setObject_inmonad) +lemma set_ntfn_aligned'[wp]: + "\pspace_aligned'\ setNotification p ntfn \\rv. pspace_aligned'\" + unfolding setNotification_def by wp -lemma setObject_bounded[wp]: - "setObject p val \pspace_bounded'\" - unfolding pspace_bounded'_def by (unfold_setObject_inmonad) +lemma set_ntfn_distinct'[wp]: + "\pspace_distinct'\ setNotification p ntfn \\rv. pspace_distinct'\" + unfolding setNotification_def by wp -end +lemma setNotification_cte_wp_at': + "\cte_wp_at' P p\ setNotification ptr v \\rv. cte_wp_at' P p\" + unfolding setNotification_def + apply (rule setObject_cte_wp_at'[where Q="\", simplified]) + apply (clarsimp simp add: updateObject_default_def in_monad + projectKOs + intro!: set_eqI)+ + done -end +lemma setObject_ntfn_tcb': + "\tcb_at' t\ setObject p (e::Structures_H.notification) \\_. tcb_at' t\" + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_default_def in_monad) + done -context begin interpretation Arch . (*FIXME: arch_split*) +lemma set_ntfn_tcb' [wp]: + "\ tcb_at' t \ setNotification ntfn v \ \rv. tcb_at' t \" + by (simp add: setNotification_def setObject_ntfn_tcb') lemma pspace_dom_update: "\ ps ptr = Some x; a_type x = a_type v \ \ pspace_dom (ps(ptr \ v)) = pspace_dom ps" @@ -960,6 +648,7 @@ lemma pspace_dom_update: lemmas ps_clear_def3 = ps_clear_def2 [OF order_less_imp_le [OF aligned_less_plus_1]] + declare diff_neg_mask[simp del] lemma cte_wp_at_ctes_of: @@ -994,29 +683,6 @@ lemma cte_wp_at_ctes_of: word_bw_assocs field_simps) done -(* FIXME rt merge: move to Word_lib *) -lemma max_word_minus_1[simp]: "0xFFFFFFFF + 2^x = (2^x - 1::32 word)" - by simp - -lemma ctes_of'_after_update: - "ko_wp_at' (same_caps' val) p s \ ctes_of (s\ksPSpace := (ksPSpace s)(p \ val)\) x = ctes_of s x" - apply (clarsimp simp only: ko_wp_at'_def map_to_ctes_def Let_def) - apply (rule if_cong) - apply (cases val; fastforce split: if_splits) - apply (cases val; fastforce split: if_splits) - apply (rule if_cong) - apply (cases val; clarsimp; fastforce) - apply (cases val; clarsimp simp: tcb_cte_cases_def) - apply simp - done - -lemma ex_cap_to'_after_update: - "\ ex_nonz_cap_to' p s; ko_wp_at' (same_caps' val) p' s \ - \ ex_nonz_cap_to' p (s\ksPSpace := (ksPSpace s)(p' \ val)\)" - unfolding ex_nonz_cap_to'_def cte_wp_at_ctes_of - using ctes_of'_after_update - by fastforce - lemma tcb_cte_cases_small: "\ tcb_cte_cases v = Some (getF, setF) \ \ v < 2 ^ tcbBlockSizeBits" @@ -1171,25 +837,34 @@ lemma real_cte_at': objBits_simps' cte_level_bits_def del: disjCI) -lemma no_fail_getMiscObject [wp]: +lemma no_fail_getEndpoint [wp]: "no_fail (ep_at' ptr) (getEndpoint ptr)" - "no_fail (ntfn_at' ptr) (getNotification ptr)" - "no_fail (reply_at' ptr) (getReply ptr)" - "no_fail (sc_at' ptr) (getSchedContext ptr)" - by (wpsimp simp: getEndpoint_def getNotification_def getReply_def getSchedContext_def)+ + apply (simp add: getEndpoint_def getObject_def + split_def) + apply (rule no_fail_pre) + apply wp + apply (clarsimp simp add: obj_at'_def projectKOs objBits_simps' + lookupAround2_known1) + apply (erule(1) ps_clear_lookupAround2) + apply simp + apply (simp add: field_simps) + apply (erule is_aligned_no_wrap') + apply (simp add: word_bits_conv) + apply (clarsimp split: option.split_asm simp: objBits_simps' archObjSize_def) + done lemma getEndpoint_corres [corres]: "corres ep_relation (ep_at ptr) (ep_at' ptr) (get_endpoint ptr) (getEndpoint ptr)" apply (rule corres_no_failI) apply wp - apply (simp add: get_simple_ko_def getEndpoint_def get_object_def gets_the_def + apply (simp add: get_simple_ko_def getEndpoint_def get_object_def getObject_def bind_assoc ep_at_def2) - apply (clarsimp simp: in_monad split_def bind_def gets_def get_def return_def - dest!: readObject_misc_ko_at') + apply (clarsimp simp: in_monad split_def bind_def gets_def get_def return_def) apply (clarsimp simp: assert_def fail_def obj_at_def return_def is_ep partial_inv_def) - apply (rename_tac ep' ep) - apply (clarsimp simp: state_relation_def pspace_relation_def obj_at'_def projectKOs) + apply (clarsimp simp: loadObject_default_def in_monad projectKOs + in_magnitude_check objBits_simps') + apply (clarsimp simp add: state_relation_def pspace_relation_def) apply (drule bspec) apply blast apply (simp add: other_obj_relation_def) @@ -1223,16 +898,14 @@ lemma setObject_ksDomSchedule_inv: apply (wp updateObject_default_inv | simp)+ done -lemma read_magnitudeCheck_Some: - "(case y of None \ True | Some z \ 2 ^ n \ z - x) - \ read_magnitudeCheck x y n s = Some ()" - by (fastforce simp: read_magnitudeCheck_def split: option.splits if_split_asm; simp) +lemma projectKO_def2: + "projectKO ko = assert_opt (projectKO_opt ko)" + by (simp add: projectKO_def assert_opt_def) -lemmas read_magnitudeCheck_Some'[simp, intro!] = read_magnitudeCheck_Some[THEN iffD1] lemma no_fail_magnitudeCheck[wp]: "no_fail (\s. case y of None \ True | Some z \ 2 ^ n \ z - x) (magnitudeCheck x y n)" - apply (clarsimp simp: magnitudeCheck_def gets_the_def) + apply (clarsimp simp add: magnitudeCheck_def split: option.splits) apply (rule no_fail_pre, wp) apply simp done @@ -1242,11 +915,11 @@ lemma no_fail_setObject_other [wp]: assumes x: "updateObject ob = updateObject_default ob" shows "no_fail (obj_at' (\k::'a. objBits k = objBits ob) ptr) (setObject ptr ob)" - apply (simp add: setObject_def x split_def updateObject_default_def alignError_def - projectKO_def alignCheck_def read_alignCheck_def read_alignError_def) + apply (simp add: setObject_def x split_def updateObject_default_def + projectKO_def2 alignCheck_def alignError_def) apply (rule no_fail_pre) - apply wp - apply (clarsimp simp: is_aligned_mask[symmetric] obj_at'_def omonad_defs + apply (wp ) + apply (clarsimp simp: is_aligned_mask[symmetric] obj_at'_def objBits_def[symmetric] projectKOs project_inject lookupAround2_known1) apply (erule(1) ps_clear_lookupAround2) @@ -1256,14 +929,13 @@ lemma no_fail_setObject_other [wp]: apply (erule is_aligned_no_wrap') apply simp apply simp - apply (fastforce simp: oassert_opt_def project_inject split: option.splits) + apply fastforce done lemma obj_relation_cut_same_type: "\ (y, P) \ obj_relation_cuts ko x; P ko z; (y', P') \ obj_relation_cuts ko' x'; P' ko' z \ \ (a_type ko = a_type ko') \ (\n n'. a_type ko = ACapTable n \ a_type ko' = ACapTable n') - \ (\n n'. a_type ko = ASchedContext n \ a_type ko' = ASchedContext n') \ (\sz sz'. a_type ko = AArch (AUserData sz) \ a_type ko' = AArch (AUserData sz')) \ (\sz sz'. a_type ko = AArch (ADeviceData sz) \ a_type ko' = AArch (ADeviceData sz'))" apply (rule ccontr) @@ -1275,47 +947,16 @@ lemma obj_relation_cut_same_type: ARM_A.arch_kernel_obj.split_asm) done -lemma replyNexts_of_non_reply_update: - "\s'. \typ_at' (koTypeOf ko) ptr s'; - koTypeOf ko \ ReplyT \ - \ replyNexts_of (s'\ksPSpace := (ksPSpace s')(ptr \ ko)\) = replyNexts_of s'" - by (fastforce simp: typ_at'_def ko_wp_at'_def opt_map_def projectKO_opts_defs - split: kernel_object.splits) - -definition replyNext_same :: "'a :: pspace_storable \ 'a \ bool" where - "replyNext_same obj1 obj2 \ - (case (injectKO obj1, injectKO obj2) of - (KOReply r1, KOReply r2) \ replyNext r1 = replyNext r2 - | _ \ True)" - -lemma replyNexts_of_replyNext_same_update: - "\s'. \typ_at' ReplyT ptr s'; ksPSpace s' ptr = Some ko; - koTypeOf (injectKO (ob':: 'a :: pspace_storable)) = ReplyT; - projectKO_opt ko = Some ab; replyNext_same (ob':: 'a) ab\ - \ replyNexts_of (s'\ksPSpace := (ksPSpace s')(ptr \ injectKO ob')\) = replyNexts_of s'" - apply (cases "injectKO ob'"; clarsimp simp: typ_at'_def ko_wp_at'_def) - by (cases ko; fastforce simp add: replyNext_same_def project_inject projectKO_opts_defs opt_map_def) - -lemma replyPrevs_of_non_reply_update: - "\s'. \typ_at' (koTypeOf ko) ptr s'; - koTypeOf ko \ ReplyT \ - \ replyPrevs_of (s'\ksPSpace := (ksPSpace s')(ptr \ ko)\) = replyPrevs_of s'" - by (fastforce simp: typ_at'_def ko_wp_at'_def opt_map_def projectKO_opts_defs - split: kernel_object.splits) - -definition replyPrev_same :: "'a :: pspace_storable \ 'a \ bool" where - "replyPrev_same obj1 obj2 \ - (case (injectKO obj1, injectKO obj2) of - (KOReply r1, KOReply r2) \ replyPrev r1 = replyPrev r2 - | _ \ True)" +definition exst_same :: "Structures_H.tcb \ Structures_H.tcb \ bool" +where + "exst_same tcb tcb' \ tcbPriority tcb = tcbPriority tcb' + \ tcbTimeSlice tcb = tcbTimeSlice tcb' + \ tcbDomain tcb = tcbDomain tcb'" -lemma replyPrevs_of_replyPrev_same_update: - "\s'. \typ_at' ReplyT ptr s'; ksPSpace s' ptr = Some ko; - koTypeOf (injectKO (ob':: 'a :: pspace_storable)) = ReplyT; - projectKO_opt ko = Some ab; replyPrev_same (ob':: 'a) ab\ - \ replyPrevs_of (s'\ksPSpace := (ksPSpace s')(ptr \ injectKO ob')\) = replyPrevs_of s'" - apply (cases "injectKO ob'"; clarsimp simp: typ_at'_def ko_wp_at'_def) - by (cases ko; fastforce simp add: replyPrev_same_def project_inject projectKO_opts_defs opt_map_def) +fun exst_same' :: "Structures_H.kernel_object \ Structures_H.kernel_object \ bool" +where + "exst_same' (KOTCB tcb) (KOTCB tcb') = exst_same tcb tcb'" | + "exst_same' _ _ = True" lemma tcbs_of'_non_tcb_update: "\typ_at' (koTypeOf ko) ptr s'; koTypeOf ko \ TCBT\ @@ -1334,6 +975,7 @@ lemma setObject_other_corres: \ 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 e: "\ko. P ko \ exst_same' (injectKO ko) (injectKO ob')" assumes P: "\(v::'a::pspace_storable). (1 :: word32) < 2 ^ (objBits v)" 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) @@ -1348,8 +990,8 @@ lemma setObject_other_corres: 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 in_magnitude_check[OF _ P] - updateObject_default_def) + 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 @@ -1383,24 +1025,28 @@ lemma setObject_other_corres: (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 (prop_tac "typ_at' (koTypeOf (injectKO ob')) ptr b") - apply (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_obj_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 (drule replyPrevs_of_non_reply_update[simplified]) - apply (clarsimp simp: other_obj_relation_def; cases ob; cases "injectKO ob'"; - simp split: arch_kernel_obj.split_asm) - apply (clarsimp simp add: opt_map_def) - done + | clarsimp simp: is_other_obj_relation_type is_other_obj_relation_type_def a_type_def)+)[1] + apply (extract_conjunct \match conclusion in "ekheap_relation _ _" \ -\) + apply (simp only: ekheap_relation_def) + apply (rule ballI, drule(1) bspec) + apply (drule domD) + apply (insert e) + apply atomize + apply (clarsimp simp: obj_at'_def) + apply (erule_tac x=obj in allE) + apply (clarsimp simp: projectKO_eq project_inject) + apply (case_tac ob; + simp_all add: a_type_def other_obj_relation_def etcb_relation_def + is_other_obj_relation_type t exst_same_def) + apply (clarsimp simp: is_other_obj_relation_type t exst_same_def + split: Structures_A.kernel_object.splits Structures_H.kernel_object.splits + arch_kernel_obj.splits)+ + \ \ready_queues_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) lemmas obj_at_simps = obj_at_def obj_at'_def projectKOs map_to_ctes_upd_other is_other_obj_relation_type_def @@ -1425,421 +1071,90 @@ lemma setNotification_corres [corres]: apply (corresKsimp wp: get_object_ret get_object_wp)+ by (fastforce simp: is_ntfn obj_at_simps objBits_defs partial_inv_def) -lemma reply_at'_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes t: "reply_at' ptr s'" - shows "reply_at ptr s" using assms - apply (clarsimp simp: obj_at'_def projectKOs) - 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 pte_relation_def pde_relation_def - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm) - -lemma set_reply_corres: (* for reply update that doesn't touch the reply stack *) - "reply_relation ae ae' \ - corres dc \ - (obj_at' (\ko. replyPrev_same ae' ko) ptr) - (set_reply ptr ae) (setReply ptr ae')" - proof - - have x: "updateObject ae' = updateObject_default ae'" by clarsimp - have z: "\s. reply_at' ptr s - \ map_to_ctes ((ksPSpace s) (ptr \ injectKO ae')) = map_to_ctes (ksPSpace s)" - by (clarsimp simp: obj_at_simps) - have b: "\ko. (\_ :: reply. True) ko \ objBits ko = objBits ae'" - by (clarsimp simp: obj_at_simps) - assume r: "reply_relation ae ae'" - show ?thesis - apply (simp add: set_simple_ko_def setReply_def is_reply_def[symmetric]) - supply image_cong_simp [cong del] - apply (insert r) - apply (rule corres_no_failI) - apply (rule no_fail_pre) - apply wp - apply (rule x) - apply (clarsimp simp: obj_at'_weakenE[OF _ b]) - 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 obj_at'_def is_reply - updateObject_default_def in_magnitude_check[OF _]) - apply (prop_tac "reply_at ptr a") - apply (clarsimp simp: obj_at'_def projectKOs dest!: state_relation_pspace_relation reply_at'_cross[where ptr=ptr]) - apply (clarsimp simp: obj_at_def is_reply) - apply (rename_tac reply) - apply (prop_tac "obj_at (same_caps (kernel_object.Reply ae)) ptr a") - apply (clarsimp simp: obj_at_def is_reply) - apply (clarsimp simp: state_relation_def - z[simplified obj_at'_def is_reply projectKO_eq projectKO_opts_defs, simplified]) - 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 (rule conjI[rotated]) - 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 (fold fun_upd_def) - apply (simp only: pspace_relation_def simp_thms - pspace_dom_update[where x="kernel_object.Reply _" - and v="kernel_object.Reply _", - simplified a_type_def, simplified]) - apply (simp only: dom_fun_upd2 simp_thms) - apply (elim conjE) - apply (frule bspec, erule domI) - apply (rule conjI) - apply (rule ballI, drule(1) bspec) - apply (drule domD) - apply (clarsimp simp: project_inject split: if_split_asm kernel_object.split_asm) - apply (rename_tac bb aa ba) - apply (drule_tac x="(aa, ba)" in bspec, simp) - apply clarsimp - apply (frule_tac ko'="kernel_object.Reply reply" and x'=ptr in obj_relation_cut_same_type) - apply simp+ - apply clarsimp - (* 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) - by (subst replyPrevs_of_replyPrev_same_update[simplified, where ob'=ae', simplified]; - simp add: typ_at'_def ko_wp_at'_def obj_at'_def project_inject opt_map_def) - qed - -lemma setReply_not_queued_corres: (* for reply updates on replies not in fst ` replies_with_sc *) - "reply_relation r1 r2 \ - corres dc (\s. ptr \ fst ` replies_with_sc s) (reply_at' ptr) - (set_reply ptr r1) (setReply ptr r2)" -proof - - have x: "updateObject r2 = updateObject_default r2" by clarsimp - have z: "\s. reply_at' ptr s - \ map_to_ctes ((ksPSpace s) (ptr \ injectKO r2)) = map_to_ctes (ksPSpace s)" - by (clarsimp simp: obj_at_simps) - have b: "\ko. (\_ :: reply. True) ko \ objBits ko = objBits r2" - by (clarsimp simp: obj_at_simps) - assume r: "reply_relation r1 r2" - show ?thesis - apply (simp add: set_simple_ko_def setReply_def is_reply_def[symmetric]) - supply image_cong_simp [cong del] - apply (insert r) - apply (rule corres_no_failI) - apply (rule no_fail_pre) - apply wp - apply (rule x) - apply (clarsimp simp: obj_at'_weakenE[OF _ b]) - 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 obj_at'_def is_reply - updateObject_default_def in_magnitude_check[OF _]) - apply (prop_tac "reply_at ptr a") - apply (clarsimp simp: obj_at'_def projectKOs dest!: state_relation_pspace_relation reply_at'_cross[where ptr=ptr]) - apply (clarsimp simp: obj_at_def is_reply) - apply (rename_tac reply) - apply (prop_tac "obj_at (same_caps (kernel_object.Reply _)) ptr a") - apply (clarsimp simp: obj_at_def is_reply) - apply (clarsimp simp: state_relation_def - z[simplified obj_at'_def is_reply projectKO_eq projectKO_opts_defs, simplified]) - 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 (rule conjI[rotated]) - 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 (fold fun_upd_def) - apply (simp only: pspace_relation_def simp_thms - pspace_dom_update[where x="kernel_object.Reply _" - and v="kernel_object.Reply _", - simplified a_type_def, simplified]) - apply (simp only: dom_fun_upd2 simp_thms) - apply (elim conjE) - apply (frule bspec, erule domI) - apply (rule conjI) - apply (rule ballI, drule(1) bspec) - apply (drule domD) - apply (clarsimp simp: project_inject split: if_split_asm kernel_object.split_asm) - apply (rename_tac bb aa ba) - apply (drule_tac x="(aa, ba)" in bspec, simp) - apply clarsimp - apply (frule_tac ko'="kernel_object.Reply reply" and x'=ptr in obj_relation_cut_same_type) - apply simp+ - apply clarsimp - (* 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 (subgoal_tac "((scs_of' b)(ptr := sc_of' (KOReply r2)) |> scReply) p = scReplies_of b p") - apply simp - apply (subgoal_tac "heap_ls (replyPrevs_of b) (scReplies_of b p) (sc_replies z)") - apply (erule heap_path_heap_upd_not_in) - apply (clarsimp simp: sc_at_pred_n_def obj_at_def replies_with_sc_def image_def) - apply (drule_tac x=p in spec) - apply (fastforce elim!: opt_mapE) - apply (simp add: typ_at'_def ko_wp_at'_def obj_at'_def project_inject opt_map_def) - apply (simp add: typ_at'_def ko_wp_at'_def obj_at'_def project_inject opt_map_def) - done -qed - -lemma sc_at'_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes t: "sc_at' ptr s'" - shows "sc_at ptr s" using assms - apply (clarsimp simp: obj_at'_def projectKOs) - 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 pte_relation_def pde_relation_def - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm) - -lemma sc_obj_at'_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes t: "obj_at' (\sc::sched_context. scSize sc = n) ptr s'" - shows "sc_obj_at n ptr s" using assms - 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 projectKOs - other_obj_relation_def pte_relation_def pde_relation_def sc_relation_def - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm) - -lemma setSchedContext_corres: - assumes R': "sc_relation sc n sc'" - assumes s: "n = scSize sc'" - shows "corres dc \ - (obj_at' (\k::sched_context. objBits k = objBits sc') ptr - and (\s'. heap_ls (replyPrevs_of s') (scReply sc') (sc_replies sc))) - (set_object ptr (kernel_object.SchedContext sc n)) - (setSchedContext ptr sc')" - proof - - have z: "\s. sc_at' ptr s - \ map_to_ctes ((ksPSpace s) (ptr \ injectKO sc')) = map_to_ctes (ksPSpace s)" - by (clarsimp simp: obj_at_simps) - show ?thesis - apply (insert R' s) - apply (clarsimp simp: setSchedContext_def) - apply (rule corres_no_failI) - apply (rule no_fail_pre) - apply wp - apply clarsimp - apply clarsimp - apply clarsimp - apply (rename_tac s s' rv; prop_tac "sc_obj_at n ptr s") - apply (fastforce intro!: sc_obj_at'_cross dest: state_relation_pspace_relation - simp: obj_at'_def objBits_simps) - apply (clarsimp simp: obj_at_def is_sc_obj_def obj_at'_def projectKO_eq projectKO_opts_defs) - apply (unfold update_sched_context_def 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_def2 - projectKOs obj_at_def a_type_def - updateObject_default_def in_magnitude_check[OF _] - split: Structures_A.kernel_object.splits) - apply (prop_tac "obj_at (same_caps (kernel_object.SchedContext sc n)) ptr s") - apply (clarsimp simp: obj_at_def) - apply (clarsimp simp: state_relation_def - z[simplified obj_at'_def is_sc_obj_def projectKO_eq projectKO_opts_defs, simplified]) - apply (clarsimp simp: caps_of_state_after_update cte_wp_at_after_update - swp_def fun_upd_def obj_at_def) - apply (subst conj_assoc[symmetric]) - apply (rule conjI[rotated]) - apply (clarsimp simp: 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 (fold fun_upd_def) - apply (simp only: pspace_relation_def simp_thms - pspace_dom_update[where x="kernel_object.SchedContext _ _" - and v="kernel_object.SchedContext _ _", - simplified a_type_def, simplified]) - apply (simp only: dom_fun_upd2 simp_thms) - apply (elim conjE) - apply (frule bspec, erule domI) - apply (rule conjI) - apply (rule ballI, drule(1) bspec) - apply (drule domD) - apply (clarsimp simp: project_inject split: if_split_asm kernel_object.split_asm) - apply (rename_tac sc0 x bb aa ba) - apply (drule_tac x="(aa, ba)" in bspec, simp) - apply clarsimp - apply (frule_tac ko'="kernel_object.SchedContext sc0 n" and x'=ptr - in obj_relation_cut_same_type) - apply simp+ - apply (clarsimp simp: a_type_def split: Structures_A.kernel_object.split_asm if_split_asm) - (* sc_replies_relation *) - 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) - by (auto simp: typ_at'_def ko_wp_at'_def opt_map_def projectKO_opts_defs - split: if_splits) -qed - -lemma setSchedContext_update_corres: - assumes R': "sc_relation sc n sc' \ sc_relation (f sc) n (f' (sc'::sched_context))" - assumes s: "objBits sc' = objBits (f' sc')" - shows "corres dc - (\s. kheap s ptr = Some (kernel_object.SchedContext sc n)) - (ko_at' sc' ptr and (\s'. heap_ls (replyPrevs_of s') (scReply (f' sc')) (sc_replies (f sc)))) - (set_object ptr (kernel_object.SchedContext (f sc) n)) - (setSchedContext ptr (f' sc'))" - apply (insert R' s) - apply (rule_tac F="sc_relation sc n sc'" in corres_req) - apply (drule state_relation_pspace_relation) - apply (drule (1) pspace_relation_absD) - apply (clarsimp simp: obj_at'_def projectKOs split: if_split_asm) - apply (rule corres_guard_imp) - apply (rule setSchedContext_corres) - apply fastforce - apply (clarsimp simp: obj_at'_def sc_relation_def objBits_simps) - apply fastforce - apply (clarsimp simp: obj_at'_def sc_relation_def) - done - -lemma setSchedContext_no_stack_update_corres: - "\sc_relation sc n sc' \ sc_relation (f sc) n (f' sc'); - sc_replies sc = sc_replies (f sc); objBits sc' = objBits (f' sc'); - scReply sc' = scReply (f' sc')\ - \ corres dc - (\s. kheap s ptr = Some (kernel_object.SchedContext sc n)) - (ko_at' sc' ptr) - (set_object ptr (kernel_object.SchedContext (f sc) n)) - (setSchedContext ptr (f' sc'))" - apply (rule_tac F="sc_relation sc n sc'" in corres_req) - apply (drule state_relation_pspace_relation) - apply (drule (1) pspace_relation_absD) - apply (clarsimp simp: obj_at'_def projectKOs split: if_split_asm) - apply (rule stronger_corres_guard_imp) - apply (rule setSchedContext_update_corres[where sc=sc and sc'=sc']) - apply simp+ - apply (clarsimp dest!: state_relation_sc_replies_relation - simp: obj_at'_def projectKOs) - apply (drule (2) sc_replies_relation_prevs_list) - by fastforce - -lemma setSchedContext_update_sched_context_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); objBits sc' = objBits (f' sc'); - scReply sc' = scReply (f' sc')\ - \ corres dc - (\s. sc_at ptr s) - (ko_at' sc' ptr) - (update_sched_context ptr f) - (setSchedContext ptr (f' sc'))" - apply (clarsimp simp: update_sched_context_def) - apply (rule corres_symb_exec_l[rotated 2, OF get_object_sp]) - apply (find_goal \match conclusion in "\P\ f \\Q\" for P f Q \ -\) - apply (fastforce intro: get_object_exs_valid - simp: obj_at_def) - apply wpsimp - apply (clarsimp simp: obj_at_def) - apply (rename_tac obj) - apply (case_tac obj; - clarsimp, (solves \clarsimp simp: obj_at_def is_sc_obj_def corres_underlying_def\)?) - apply (rule corres_guard_imp) - apply (rule_tac f=f and f'="f'" in setSchedContext_no_stack_update_corres) - apply simp+ - apply (clarsimp simp: obj_at_def) - apply (clarsimp simp: obj_at_simps) - done - -lemma getNotification_corres: - "corres ntfn_relation (ntfn_at ptr) (ntfn_at' ptr) - (get_notification ptr) (getNotification ptr)" - apply (rule corres_no_failI) +lemma no_fail_getNotification [wp]: + "no_fail (ntfn_at' ptr) (getNotification ptr)" + apply (simp add: getNotification_def getObject_def + split_def) + apply (rule no_fail_pre) 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 projectKOs) - apply (drule bspec) - apply blast - apply (simp add: other_obj_relation_def) + apply (clarsimp simp add: obj_at'_def projectKOs objBits_simps' + lookupAround2_known1) + apply (erule(1) ps_clear_lookupAround2) + apply simp + apply (simp add: field_simps) + apply (erule is_aligned_no_wrap') + apply (simp add: word_bits_conv) + apply (clarsimp split: option.split_asm simp: objBits_simps' archObjSize_def) done -lemma get_reply_corres: - "corres reply_relation (reply_at ptr) (reply_at' ptr) - (get_reply ptr) (getReply ptr)" +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 getReply_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_reply partial_inv_def) - apply (clarsimp simp add: state_relation_def pspace_relation_def obj_at'_def projectKOs) + apply (simp add: get_simple_ko_def getNotification_def get_object_def + getObject_def bind_assoc) + apply (clarsimp simp: in_monad split_def bind_def gets_def get_def return_def) + apply (clarsimp simp: assert_def fail_def obj_at_def return_def is_ntfn partial_inv_def) + apply (clarsimp simp: loadObject_default_def in_monad projectKOs + in_magnitude_check objBits_simps') + apply (clarsimp simp add: state_relation_def pspace_relation_def) apply (drule bspec) apply blast apply (simp add: other_obj_relation_def) done -lemma getReply_TCB_corres: - "corres (=) (reply_at ptr) (reply_at' ptr) - (get_reply_tcb ptr) (liftM replyTCB (getReply ptr))" - apply clarsimp - apply (rule get_reply_corres[THEN corres_rel_imp]) - 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 projectKOs) - done - -lemma get_sc_corres_size: - "corres (\sc sc'. sc_relation sc n sc') - (sc_obj_at n 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) - apply (clarsimp simp: assert_def fail_def obj_at_def return_def is_sc_obj - split: Structures_A.kernel_object.splits - dest!: readObject_misc_ko_at') - 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 objBits_simps projectKOs) - done - lemma setObject_ko_wp_at: fixes v :: "'a :: pspace_storable" - assumes R: "\ko s y n. (updateObject v ko p y n s) + assumes R: "\ko s x y n. (updateObject v ko p y n s) = (updateObject_default v ko p y n s)" + assumes n: "\v' :: 'a. objBits v' = n" + assumes m: "(1 :: word32) < 2 ^ n" shows "\\s. obj_at' (\x :: 'a. True) p s \ P (ko_wp_at' (if p = p' then K (P' (injectKO v)) else P')p' s)\ setObject p v \\rv s. P (ko_wp_at' P' p' s)\" apply (clarsimp simp: setObject_def valid_def in_monad - ko_wp_at'_def split_def in_magnitude_check + ko_wp_at'_def split_def R updateObject_default_def projectKOs obj_at'_real_def split del: if_split) - apply (clarsimp simp: project_inject objBits_def[symmetric] + apply (clarsimp simp: project_inject objBits_def[symmetric] n + in_magnitude_check [OF _ m] elim!: rsubst[where P=P] split del: if_split) apply (rule iffI) - apply (clarsimp simp: ps_clear_upd objBits_def[symmetric] + apply (clarsimp simp: n ps_clear_upd objBits_def[symmetric] split: if_split_asm) - apply (clarsimp simp: project_inject objBits_def[symmetric] + apply (clarsimp simp: n project_inject objBits_def[symmetric] ps_clear_upd split: if_split_asm) done +lemma typ_at'_valid_obj'_lift: + assumes P: "\P T p. \\s. P (typ_at' T p s)\ f \\rv s. P (typ_at' T p s)\" + notes [wp] = hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_const_Ball_lift typ_at_lifts [OF P] + shows "\\s. valid_obj' obj s\ f \\rv s. valid_obj' obj s\" + 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 valid_bound_tcb'_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 + valid_bound_ntfn'_def; + wpsimp wp: hoare_case_option_wp hoare_case_option_wp2; + (clarsimp split: option.splits)?) + apply (wpsimp simp: valid_cte'_def) + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object; wpsimp) + done + +lemmas setObject_valid_obj = typ_at'_valid_obj'_lift [OF setObject_typ_at'] + lemma setObject_valid_objs': assumes x: "\x n ko s ko' s'. \ (ko', s') \ fst (updateObject val ko ptr x n s); P s; @@ -1850,7 +1165,7 @@ lemma setObject_valid_objs': apply (subgoal_tac "\ko. valid_obj' ko s \ valid_obj' ko b") defer apply clarsimp - apply (erule (1) use_valid [OF _ setObject.typ_at_sc_at'_n_lifts'(3)]) + apply (erule(1) use_valid [OF _ setObject_valid_obj]) apply (clarsimp simp: setObject_def split_def in_monad lookupAround2_char1) apply (simp add: valid_objs'_def) @@ -1864,8 +1179,10 @@ lemma setObject_valid_objs': lemma setObject_iflive': fixes v :: "'a :: pspace_storable" - assumes R: "\ko s y n. (updateObject v ko ptr y n s) + assumes R: "\ko s x y n. (updateObject v ko ptr y n s) = (updateObject_default v ko ptr y n s)" + assumes n: "\x :: 'a. objBits x = n" + assumes m: "(1 :: word32) < 2 ^ n" 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)" @@ -1877,7 +1194,7 @@ lemma setObject_iflive': 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 setObject_ko_wp_at [OF R n m]) apply (rule hoare_vcg_ex_lift) apply (rule setObject_cte_wp_at'[where Q = P, OF x y]) apply assumption+ @@ -1937,45 +1254,30 @@ lemma setObject_it[wp]: definition idle_tcb_ps :: "('a :: pspace_storable) \ bool" where "idle_tcb_ps val \ (\tcb. projectKO_opt (injectKO val) = Some tcb \ idle_tcb' tcb)" -\\ - `idle_sc_ps val` asserts that `val` is a pspace_storable value - which corresponds to an idle SchedContext. -\ -definition idle_sc_ps :: "('a :: pspace_storable) \ bool" where - "idle_sc_ps val \ (\sc. sc_of' (injectKO val) = Some sc \ idle_sc' sc)" - 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 R: "\ko s x y n. (updateObject v ko ptr y n s) + = (updateObject_default v ko ptr y n s)" + assumes n: "\x :: 'a. objBits x = n" + assumes m: "(1 :: word32) < 2 ^ n" 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 + \\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 + \ idle_tcb_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 (rule setObject_ko_wp_at [OF R n m]) 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) + apply (clarsimp simp add: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def idle_tcb_ps_def) + apply (clarsimp simp add: project_inject) + apply (drule_tac x=obja in spec, simp) done lemma setObject_no_0_obj' [wp]: @@ -1991,39 +1293,11 @@ lemma valid_updateCapDataI: apply (cases c) apply (simp_all add: isCap_defs valid_cap'_def capUntypedPtr_def isCap_simps capAligned_def word_size word_bits_def word_bw_assocs) - done - -lemma no_ofail_threadRead[simp]: - "no_ofail (obj_at' (P::tcb \ bool) p) (threadRead f p)" - unfolding threadRead_def oliftM_def no_ofail_def - apply clarsimp - apply (clarsimp simp: threadRead_def obind_def oliftM_def oreturn_def - split: option.split dest!: no_ofailD[OF no_ofail_obj_at'_readObject_tcb]) done -lemmas no_ofail_threadRead_tcb_at'[wp] = no_ofail_threadRead[where P=\] - -lemma threadRead_tcb_at'': - "bound (threadRead f t s) \ tcb_at' t s" - by (clarsimp simp: threadRead_def oliftM_def elim!: obj_at'_weakenE) - -lemmas threadRead_tcb_at' = threadRead_tcb_at''[simplified] - -lemma ovalid_threadRead: - "\\s. tcb_at' t s \ (\tcb. ko_at' tcb t s \ P (f tcb) s)\ - threadRead f t - \P\" - by (clarsimp simp: threadRead_def oliftM_def obind_def obj_at'_def ovalid_def - dest!: readObject_misc_ko_at' split: option.split_asm) - -lemma ovalid_threadRead_sp: - "\P\ threadRead f ptr \\rv s. \tcb :: tcb. ko_at' tcb ptr s \ f tcb = rv \ P s\" - by (clarsimp simp: threadRead_def oliftM_def obind_def obj_at'_def ovalid_def - dest!: readObject_misc_ko_at' split: option.split_asm) - lemma no_fail_threadGet [wp]: "no_fail (tcb_at' t) (threadGet f t)" - by (wpsimp simp: threadGet_def wp: no_ofail_gets_the) + by (simp add: threadGet_def, wp) lemma no_fail_getThreadState [wp]: "no_fail (tcb_at' t) (getThreadState t)" @@ -2064,6 +1338,97 @@ lemma no_fail_dmo' [wp]: apply (simp add: no_fail_def) done +lemma setEndpoint_nosch[wp]: + "\\s. P (ksSchedulerAction s)\ + setEndpoint val ptr + \\rv s. P (ksSchedulerAction s)\" + apply (simp add: setEndpoint_def) + apply (rule setObject_nosch) + apply (simp add: updateObject_default_def) + apply wp + apply simp + done + +lemma setNotification_nosch[wp]: + "\\s. P (ksSchedulerAction s)\ + setNotification val ptr + \\rv s. P (ksSchedulerAction s)\" + apply (simp add: setNotification_def) + apply (rule setObject_nosch) + apply (simp add: updateObject_default_def) + apply wp + apply simp + done + +lemma set_ep_valid_objs': + "\valid_objs' and valid_ep' ep\ + setEndpoint epptr ep + \\r s. valid_objs' s\" + apply (simp add: setEndpoint_def) + apply (rule setObject_valid_objs') + apply (clarsimp simp: updateObject_default_def in_monad + projectKOs valid_obj'_def) + done + +lemma set_ep_ctes_of[wp]: + "\\s. P (ctes_of s)\ setEndpoint p val \\rv s. P (ctes_of s)\" + apply (simp add: setEndpoint_def) + apply (rule setObject_ctes_of[where Q="\", simplified]) + apply (clarsimp simp: updateObject_default_def in_monad + projectKOs) + apply (clarsimp simp: updateObject_default_def bind_def + projectKOs) + done + +lemma set_ep_valid_mdb' [wp]: + "\valid_mdb'\ + setObject epptr (ep::endpoint) + \\_. valid_mdb'\" + apply (simp add: valid_mdb'_def) + apply (rule set_ep_ctes_of[simplified setEndpoint_def]) + done + +lemma setEndpoint_valid_mdb': + "\valid_mdb'\ setEndpoint p v \\rv. valid_mdb'\" + unfolding setEndpoint_def + by (rule set_ep_valid_mdb') + +lemma set_ep_valid_pspace'[wp]: + "\valid_pspace' and valid_ep' ep\ + setEndpoint epptr ep + \\r. valid_pspace'\" + apply (simp add: valid_pspace'_def) + apply (wp set_ep_aligned' [simplified] set_ep_valid_objs') + apply (wp hoare_vcg_conj_lift) + apply (simp add: setEndpoint_def) + apply (wp setEndpoint_valid_mdb')+ + apply auto + done + +lemma set_ep_valid_bitmapQ[wp]: + "\Invariants_H.valid_bitmapQ\ setEndpoint epptr ep \\rv. Invariants_H.valid_bitmapQ\" + apply (unfold setEndpoint_def) + apply (rule setObject_ep_pre) + apply (simp add: bitmapQ_defs setObject_def split_def) + apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ + done + +lemma set_ep_bitmapQ_no_L1_orphans[wp]: + "\ bitmapQ_no_L1_orphans \ setEndpoint epptr ep \\rv. bitmapQ_no_L1_orphans \" + apply (unfold setEndpoint_def) + apply (rule setObject_ep_pre) + apply (simp add: bitmapQ_defs setObject_def split_def) + apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ + done + +lemma set_ep_bitmapQ_no_L2_orphans[wp]: + "\ bitmapQ_no_L2_orphans \ setEndpoint epptr ep \\rv. bitmapQ_no_L2_orphans \" + apply (unfold setEndpoint_def) + apply (rule setObject_ep_pre) + apply (simp add: bitmapQ_defs setObject_def split_def) + apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_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\" @@ -2076,7 +1441,7 @@ lemma ct_in_state_thread_state_lift': 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 tcb_cd: "\P 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 @@ -2108,7 +1473,7 @@ lemma ct_idle_or_in_cur_domain'_lift: 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\ + assumes e: "\d a 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' \" @@ -2126,24 +1491,48 @@ lemma ct_idle_or_in_cur_domain'_lift: 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 - apply simp +lemma setObject_ep_obj_at'_tcb[wp]: + "\obj_at' (P :: tcb \ bool) t \ setObject ptr (e::endpoint) \\_. obj_at' (P :: tcb \ bool) t\" + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_default_def in_monad) + done + +lemma setObject_ep_cur_domain[wp]: + "\\s. P (ksCurDomain s)\ setObject ptr (e::endpoint) \\_ s. P (ksCurDomain s)\" + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setEndpoint_tcb_in_cur_domain'[wp]: + "\tcb_in_cur_domain' t\ setEndpoint epptr ep \\_. tcb_in_cur_domain' t\" + apply (clarsimp simp: setEndpoint_def) + apply (rule tcb_in_cur_domain'_lift; wp) + done + +lemma setEndpoint_obj_at'_tcb[wp]: + "\obj_at' (P :: tcb \ bool) t \ setEndpoint ptr (e::endpoint) \\_. obj_at' (P :: tcb \ bool) t\" + by (clarsimp simp: setEndpoint_def, wp) + +lemma set_ep_sch_act_wf[wp]: + "\\s. sch_act_wf (ksSchedulerAction s) s\ + setEndpoint epptr ep + \\rv s. sch_act_wf (ksSchedulerAction s) s\" + apply (wp sch_act_wf_lift) + apply (simp add: setEndpoint_def split_def setObject_def + | wp updateObject_default_inv)+ done lemma setObject_state_refs_of': assumes x: "updateObject val = updateObject_default val" + assumes y: "(1 :: word32) < 2 ^ objBits val" shows "\\s. P ((state_refs_of' s) (ptr := refs_of' (injectKO val)))\ setObject ptr val \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: setObject_def valid_def in_monad split_def - updateObject_default_def x - projectKOs in_magnitude_check[OF _] + updateObject_default_def x in_magnitude_check + projectKOs y elim!: rsubst[where P=P] intro!: ext split del: if_split cong: option.case_cong if_cong) apply (clarsimp simp: state_refs_of'_def objBits_def[symmetric] @@ -2160,14 +1549,183 @@ lemma setObject_state_refs_of_eq: setObject ptr val \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: setObject_def valid_def in_monad split_def - lookupAround2_char1 + updateObject_default_def in_magnitude_check + projectKOs lookupAround2_char1 elim!: rsubst[where P=P] intro!: ext split del: if_split cong: option.case_cong if_cong) - apply (frule x) - apply (simp add: state_refs_of'_def ps_clear_upd updateObject_size - cong: option.case_cong if_cong)+ + apply (frule x, drule updateObject_objBitsKO) + apply (simp add: state_refs_of'_def ps_clear_upd + cong: option.case_cong if_cong) + done + +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)\" + unfolding setEndpoint_def + by (wp setObject_state_refs_of', + simp_all add: objBits_simps' fun_upd_def[symmetric]) + +lemma set_ntfn_ctes_of[wp]: + "\\s. P (ctes_of s)\ setNotification p val \\rv s. P (ctes_of s)\" + apply (simp add: setNotification_def) + apply (rule setObject_ctes_of[where Q="\", simplified]) + apply (clarsimp simp: updateObject_default_def in_monad + projectKOs) + apply (clarsimp simp: updateObject_default_def bind_def + projectKOs) + done + +lemma set_ntfn_valid_mdb' [wp]: + "\valid_mdb'\ + setObject epptr (ntfn::Structures_H.notification) + \\_. valid_mdb'\" + apply (simp add: valid_mdb'_def) + apply (rule set_ntfn_ctes_of[simplified setNotification_def]) + done + +lemma set_ntfn_valid_objs': + "\valid_objs' and valid_ntfn' ntfn\ + setNotification p ntfn + \\r s. valid_objs' s\" + apply (simp add: setNotification_def) + apply (rule setObject_valid_objs') + apply (clarsimp simp: updateObject_default_def in_monad + valid_obj'_def) + done + +lemma set_ntfn_valid_pspace'[wp]: + "\valid_pspace' and valid_ntfn' ntfn\ + setNotification p ntfn + \\r. valid_pspace'\" + apply (simp add: valid_pspace'_def) + apply (wp set_ntfn_aligned' [simplified] set_ntfn_valid_objs') + apply (simp add: setNotification_def,wp) + apply auto + done + +lemma set_ntfn_valid_bitmapQ[wp]: + "\Invariants_H.valid_bitmapQ\ setNotification p ntfn \\rv. Invariants_H.valid_bitmapQ\" + apply (unfold setNotification_def) + apply (rule setObject_ntfn_pre) + apply (simp add: bitmapQ_defs setObject_def split_def) + apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp)+ + done + +lemma set_ntfn_bitmapQ_no_L1_orphans[wp]: + "\ bitmapQ_no_L1_orphans \ setNotification p ntfn \\rv. bitmapQ_no_L1_orphans \" + apply (unfold setNotification_def) + apply (rule setObject_ntfn_pre) + apply (simp add: bitmapQ_defs setObject_def split_def) + apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp)+ + done + +lemma set_ntfn_bitmapQ_no_L2_orphans[wp]: + "\ bitmapQ_no_L2_orphans \ setNotification p ntfn \\rv. bitmapQ_no_L2_orphans \" + apply (unfold setNotification_def) + apply (rule setObject_ntfn_pre) + apply (simp add: bitmapQ_defs setObject_def split_def) + apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp)+ + done + +lemma set_ntfn_state_refs_of'[wp]: + "\\s. P ((state_refs_of' s) (epptr := ntfn_q_refs_of' (ntfnObj ntfn) + \ ntfn_bound_refs' (ntfnBoundTCB ntfn)))\ + setNotification epptr ntfn + \\rv s. P (state_refs_of' s)\" + unfolding setNotification_def + by (wp setObject_state_refs_of', + simp_all add: objBits_simps' fun_upd_def) + +lemma setNotification_pred_tcb_at'[wp]: + "\pred_tcb_at' proj P t\ setNotification ptr val \\rv. pred_tcb_at' proj P t\" + apply (simp add: pred_tcb_at'_def setNotification_def) + apply (rule obj_at_setObject2) + apply simp + apply (clarsimp simp: updateObject_default_def in_monad) + done + +lemma setObject_ntfn_cur_domain[wp]: + "\ \s. P (ksCurDomain s) \ setObject ptr (ntfn::Structures_H.notification) \ \_s . P (ksCurDomain s) \" + apply (clarsimp simp: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setObject_ntfn_obj_at'_tcb[wp]: + "\obj_at' (P :: tcb \ bool) t \ setObject ptr (ntfn::Structures_H.notification) \\_. obj_at' (P :: tcb \ bool) t\" + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_default_def in_monad) done +lemma setNotification_ksCurDomain[wp]: + "\ \s. P (ksCurDomain s) \ setNotification ptr (ntfn::Structures_H.notification) \ \_s . P (ksCurDomain s) \" + apply (simp add: setNotification_def) + apply wp + done + +lemma setNotification_tcb_in_cur_domain'[wp]: + "\tcb_in_cur_domain' t\ setNotification epptr ep \\_. tcb_in_cur_domain' t\" + apply (clarsimp simp: setNotification_def) + apply (rule tcb_in_cur_domain'_lift; wp) + done + +lemma set_ntfn_sch_act_wf[wp]: + "\\s. sch_act_wf (ksSchedulerAction s) s\ + setNotification ntfnptr ntfn + \\rv s. sch_act_wf (ksSchedulerAction s) s\" + apply (wp sch_act_wf_lift | clarsimp simp: setNotification_def)+ + apply (simp add: setNotification_def split_def setObject_def + | wp updateObject_default_inv)+ + done + +lemmas cur_tcb_lift = + hoare_lift_Pf [where f = ksCurThread and P = tcb_at', folded cur_tcb'_def] + +lemma set_ntfn_cur_tcb'[wp]: + "\cur_tcb'\ setNotification ptr ntfn \\rv. cur_tcb'\" + apply (wp cur_tcb_lift) + apply (simp add: setNotification_def setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setEndpoint_typ_at'[wp]: + "\\s. P (typ_at' T p s)\ setEndpoint ptr val \\rv s. P (typ_at' T p s)\" + unfolding setEndpoint_def + by (rule setObject_typ_at') + +lemmas setEndpoint_typ_ats[wp] = typ_at_lifts [OF setEndpoint_typ_at'] + +lemma get_ep_sp': + "\P\ getEndpoint r \\t. P and ko_at' t r\" + by (clarsimp simp: getEndpoint_def getObject_def loadObject_default_def + projectKOs in_monad valid_def obj_at'_def objBits_simps' + in_magnitude_check split_def) + +lemma setEndpoint_cur_tcb'[wp]: + "\cur_tcb'\ setEndpoint p v \\rv. cur_tcb'\" + apply (wp cur_tcb_lift) + apply (simp add: setEndpoint_def setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + 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 + apply (wp setObject_iflive'[where P="\"]) + apply simp + apply (simp add: objBits_simps') + apply simp + apply (clarsimp simp: updateObject_default_def in_monad projectKOs) + apply (clarsimp simp: updateObject_default_def in_monad + projectKOs bind_def) + apply clarsimp + done + +declare setEndpoint_cte_wp_at'[wp] + lemma ex_nonz_cap_to_pres': assumes y: "\P p. \cte_wp_at' P p\ f \\rv. cte_wp_at' P p\" shows "\ex_nonz_cap_to' p\ f \\rv. ex_nonz_cap_to' p\" @@ -2176,6 +1734,52 @@ lemma ex_nonz_cap_to_pres': y hoare_vcg_all_lift) done +lemma setEndpoint_cap_to'[wp]: + "\ex_nonz_cap_to' p\ setEndpoint p' v \\rv. ex_nonz_cap_to' p\" + by (wp ex_nonz_cap_to_pres') + +lemma setEndpoint_ifunsafe'[wp]: + "\if_unsafe_then_cap'\ setEndpoint p v \\rv. if_unsafe_then_cap'\" + unfolding setEndpoint_def + apply (rule setObject_ifunsafe'[where P="\", simplified]) + apply (clarsimp simp: updateObject_default_def in_monad projectKOs + intro!: equals0I)+ + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setEndpoint_idle'[wp]: + "\\s. valid_idle' s\ + setEndpoint p v + \\_. valid_idle'\" + unfolding setEndpoint_def + apply (wp setObject_idle') + apply (simp add: objBits_simps' updateObject_default_inv)+ + apply (clarsimp simp: projectKOs idle_tcb_ps_def) + done + +crunch setEndpoint + for it[wp]: "\s. P (ksIdleThread s)" + (simp: updateObject_default_inv) + +lemma setObject_ksPSpace_only: + "\ \p q n ko. \P\ updateObject val p q n ko \\rv. P \; + \f s. P (ksPSpace_update f s) = P s \ + \ \P\ setObject ptr val \\rv. P\" + apply (simp add: setObject_def split_def) + apply (wp | simp | assumption)+ + done + +lemma setObject_ksMachine: + "\ \p q n ko. \\s. P (ksMachineState s)\ updateObject val p q n ko \\rv s. P (ksMachineState s)\ \ + \ \\s. P (ksMachineState s)\ setObject ptr val \\rv s. P (ksMachineState s)\" + by (simp add: setObject_ksPSpace_only) + +lemma setObject_ksInterrupt: + "\ \p q n ko. \\s. P (ksInterruptState s)\ updateObject val p q n ko \\rv s. P (ksInterruptState s)\ \ + \ \\s. P (ksInterruptState s)\ setObject ptr val \\rv s. P (ksInterruptState s)\" + by (simp add: setObject_ksPSpace_only) + lemma valid_irq_handlers_lift': assumes x: "\P. \\s. P (cteCaps_of s)\ f \\rv s. P (cteCaps_of s)\" assumes y: "\P. \\s. P (ksInterruptState s)\ f \\rv s. P (ksInterruptState s)\" @@ -2186,6 +1790,19 @@ lemma valid_irq_handlers_lift': lemmas valid_irq_handlers_lift'' = valid_irq_handlers_lift' [unfolded cteCaps_of_def] +crunch setEndpoint + for ksInterruptState[wp]: "\s. P (ksInterruptState s)" + (wp: setObject_ksInterrupt updateObject_default_inv) + +lemmas setEndpoint_irq_handlers[wp] + = valid_irq_handlers_lift'' [OF set_ep_ctes_of setEndpoint_ksInterruptState] + +declare set_ep_arch' [wp] + +lemma set_ep_maxObj [wp]: + "\\s. P (gsMaxObjectSize s)\ setEndpoint ptr val \\rv s. P (gsMaxObjectSize s)\" + by (simp add: setEndpoint_def | wp setObject_ksPSpace_only updateObject_default_inv)+ + lemma valid_global_refs_lift': assumes ctes: "\P. \\s. P (ctes_of s)\ f \\_ s. P (ctes_of s)\" assumes arch: "\P. \\s. P (ksArchState s)\ f \\_ s. P (ksArchState s)\" @@ -2213,6 +1830,107 @@ lemma valid_arch_state_lift': apply (wp typs hoare_vcg_const_Ball_lift arch typ_at_lifts)+ done +lemma setObject_ep_ct: + "\\s. P (ksCurThread s)\ setObject p (e::endpoint) \\_ s. P (ksCurThread s)\" + apply (simp add: setObject_def updateObject_ep_eta split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setObject_ntfn_ct: + "\\s. P (ksCurThread s)\ setObject p (e::Structures_H.notification) + \\_ s. P (ksCurThread s)\" + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma get_ntfn_sp': + "\P\ getNotification r \\t. P and ko_at' t r\" + by (clarsimp simp: getNotification_def getObject_def loadObject_default_def + projectKOs in_monad valid_def obj_at'_def objBits_simps' + in_magnitude_check split_def) + +lemma set_ntfn_pred_tcb_at' [wp]: + "\ pred_tcb_at' proj P t \ + setNotification ep v + \ \rv. pred_tcb_at' proj P t \" + apply (simp add: setNotification_def pred_tcb_at'_def) + apply (rule obj_at_setObject2) + apply (clarsimp simp add: updateObject_default_def in_monad) + done + +lemma set_ntfn_iflive'[wp]: + "\\s. if_live_then_nonz_cap' s + \ (live' (KONotification v) \ ex_nonz_cap_to' p s)\ + setNotification p v + \\rv. if_live_then_nonz_cap'\" + apply (simp add: setNotification_def) + apply (wp setObject_iflive'[where P="\"]) + apply simp + apply (simp add: objBits_simps) + apply (simp add: objBits_simps') + apply (clarsimp simp: updateObject_default_def in_monad projectKOs) + apply (clarsimp simp: updateObject_default_def + projectKOs bind_def) + apply clarsimp + done + +declare setNotification_cte_wp_at'[wp] + +lemma set_ntfn_cap_to'[wp]: + "\ex_nonz_cap_to' p\ setNotification p' v \\rv. ex_nonz_cap_to' p\" + by (wp ex_nonz_cap_to_pres') + +lemma setNotification_ifunsafe'[wp]: + "\if_unsafe_then_cap'\ setNotification p v \\rv. if_unsafe_then_cap'\" + unfolding setNotification_def + apply (rule setObject_ifunsafe'[where P="\", simplified]) + apply (clarsimp simp: updateObject_default_def in_monad projectKOs + intro!: equals0I)+ + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setNotification_idle'[wp]: + "\\s. valid_idle' s\ setNotification p v \\rv. valid_idle'\" + unfolding setNotification_def + apply (wp setObject_idle') + apply (simp add: objBits_simps' updateObject_default_inv)+ + apply (clarsimp simp: projectKOs idle_tcb_ps_def) + done + +crunch setNotification + for it[wp]: "\s. P (ksIdleThread s)" + (wp: updateObject_default_inv) + +lemma set_ntfn_arch' [wp]: + "\\s. P (ksArchState s)\ setNotification ntfn p \\_ s. P (ksArchState s)\" + apply (simp add: setNotification_def setObject_def split_def) + apply (wp updateObject_default_inv|simp)+ + done + +lemma set_ntfn_ksInterrupt[wp]: + "\\s. P (ksInterruptState s)\ setNotification ptr val \\rv s. P (ksInterruptState s)\" + by (simp add: setNotification_def | wp setObject_ksInterrupt updateObject_default_inv)+ + +lemma set_ntfn_ksMachine[wp]: + "\\s. P (ksMachineState s)\ setNotification ptr val \\rv s. P (ksMachineState s)\" + by (simp add: setNotification_def | wp setObject_ksMachine updateObject_default_inv)+ + +lemma set_ntfn_maxObj [wp]: + "\\s. P (gsMaxObjectSize s)\ setNotification ptr val \\rv s. P (gsMaxObjectSize s)\" + by (simp add: setNotification_def | wp setObject_ksPSpace_only updateObject_default_inv)+ + +lemma set_ntfn_global_refs' [wp]: + "\valid_global_refs'\ setNotification ptr val \\_. valid_global_refs'\" + by (rule valid_global_refs_lift'; wp) + +crunch setNotification + for typ_at'[wp]: "\s. P (typ_at' T p s)" + +lemma set_ntfn_valid_arch' [wp]: + "\valid_arch_state'\ setNotification ptr val \\_. valid_arch_state'\" + by (rule valid_arch_state_lift'; wp) + lemmas valid_irq_node_lift = hoare_use_eq_irq_node' [OF _ typ_at_lift_valid_irq_node'] @@ -2229,791 +1947,9 @@ lemma valid_irq_states_lift': apply wp done -lemma irqs_masked_lift: - assumes "\P. \\s. P (intStateIRQTable (ksInterruptState s))\ f - \\rv s. P (intStateIRQTable (ksInterruptState s))\" - shows "\irqs_masked'\ f \\_. irqs_masked'\" - apply (simp add: irqs_masked'_def) - apply (wp assms) - done +lemmas set_ntfn_irq_handlers'[wp] = valid_irq_handlers_lift'' [OF set_ntfn_ctes_of set_ntfn_ksInterrupt] -lemma setObject_pspace_domain_valid[wp]: - "setObject ptr val \pspace_domain_valid\" - by (clarsimp simp: setObject_def split_def pspace_domain_valid_def valid_def - 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) - -lemma forall_ko_at'_equiv_projection: - "(\s. \ko::'a::pspace_storable. ko_at' ko p s \ P ko s) = - (\s. obj_at' (\_::'a::pspace_storable. True) p s \ P (the ((ksPSpace s |> projectKO_opt) p)) s)" - by (fastforce simp: obj_at'_def projectKOs opt_map_red) - -end - -locale pspace_only' = - fixes f :: "'a kernel" - assumes pspace: "(rv, s') \ fst (f s) \ \g. s' = ksPSpace_update g s" -begin - -lemma it[wp]: "\P. f \\s. P (ksIdleThread 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)\" - and l1Bitmap[wp]: "\P. f \\s. P (ksReadyQueuesL1Bitmap s)\" - and l2Bitmap[wp]: "\P. f \\s. P (ksReadyQueuesL2Bitmap s)\" - and gsUserPages[wp]: "\P. f \\s. P (gsUserPages s)\" - and gsCNodes[wp]: "\P. f \\s. P (gsCNodes s)\" - and gsUntypedZeroRanges[wp]: "\P. f \\s. P (gsUntypedZeroRanges s)\" - and gsMaxObjectSize[wp]: "\P. f \\s. P (gsMaxObjectSize s)\" - and ksDomScheduleIdx[wp]: "\P. f \\s. P (ksDomScheduleIdx s)\" - and ksDomainTime[wp]: "\P. f \\s. P (ksDomainTime s)\" - and ksReadyQueues[wp]: "\P. f \\s. P (ksReadyQueues s)\" - and ksReleaseQueue[wp]: "\P. f \\s. P (ksReleaseQueue s)\" - and ksConsumedTime[wp]: "\P. f \\s. P (ksConsumedTime s)\" - and ksCurTime[wp]: "\P. f \\s. P (ksCurTime s)\" - and ksCurSc[wp]: "\P. f \\s. P (ksCurSc s)\" - and ksReprogramTimer[wp]: "\P. f \\s. P (ksReprogramTimer s)\" - and ksSchedulerAction[wp]: "\P. f \\s. P (ksSchedulerAction s)\" - and ksInterruptState[wp]: "\P. f \\s. P (ksInterruptState s)\" - and ksWorkUnitsCompleted[wp]: "\P. f \\s. P (ksWorkUnitsCompleted s)\" - and ksArchState[wp]: "\P. f \\s. P (ksArchState s)\" - and ksMachineState[wp]: "\P. f \\s. P (ksMachineState s)\" - unfolding valid_def using pspace - by (all \fastforce\) - -lemma sch_act_simple[wp]: - "f \\s. P (sch_act_simple s)\" - apply (wpsimp wp: ksSchedulerAction simp: sch_act_simple_def) - done - -end - -locale simple_ko' = - fixes f :: "obj_ref \ 'a::pspace_storable \ unit kernel" - and g :: "obj_ref \ 'a kernel" - assumes f_def: "f p v = setObject p v" - assumes g_def: "g p = getObject p" - assumes default_update: "updateObject (v::'a) = updateObject_default (v::'a)" - assumes default_load: "(loadObject ptr ptr' next obj :: 'a kernel_r) = - loadObject_default ptr ptr' next obj" - assumes not_cte: "projectKO_opt (KOCTE cte) = (None::'a option)" -begin - -lemma updateObject_cte[simp]: - "fst (updateObject (v::'a) (KOCTE cte) p x n s) = {}" - by (clarsimp simp: default_update updateObject_default_def in_monad projectKOs not_cte bind_def) - -lemma pspace_aligned'[wp]: "f p v \pspace_aligned'\" - and pspace_distinct'[wp]: "f p v \pspace_distinct'\" - and pspace_bounded'[wp]: "f p v \pspace_bounded'\" - and no_0_obj'[wp]: "f p v \no_0_obj'\" - unfolding f_def by (all \wpsimp simp: default_update updateObject_default_def in_monad\) - -lemma valid_objs': - "\valid_objs' and valid_obj' (injectKO v) \ f p v \\_. valid_objs'\" - unfolding f_def - by (rule setObject_valid_objs') - (clarsimp simp: default_update updateObject_default_def in_monad projectKOs)+ - -lemma typ_at'[wp]: - "f p v \\s. P (typ_at' T p' s)\" - unfolding f_def - by (rule setObject_typ_at') - -lemma sc_at'_n[wp]: "f p v \\s. P (sc_at'_n n p' s)\" - unfolding f_def - by (clarsimp simp: valid_def setObject_def in_monad split_def ko_wp_at'_def ps_clear_upd - updateObject_size lookupAround2_char1 updateObject_type) - -sublocale typ_at_all_props' "f p v" for p v by typ_at_props' - -sublocale pspace_only' "f p v" for p v - unfolding f_def - by unfold_locales - (fastforce simp: setObject_def updateObject_default_def magnitudeCheck_def default_update - in_monad split_def projectKOs - split: option.splits) - -lemma set_ep_valid_bitmapQ[wp]: - "f p v \ valid_bitmapQ \" - unfolding bitmapQ_defs by (wpsimp wp: hoare_vcg_all_lift | wps)+ - -lemma bitmapQ_no_L1_orphans[wp]: - "f p v \ bitmapQ_no_L1_orphans \" - unfolding bitmapQ_defs by (wpsimp wp: hoare_vcg_all_lift | wps)+ - -lemma bitmapQ_no_L2_orphans[wp]: - "f p v \ bitmapQ_no_L2_orphans \" - unfolding bitmapQ_defs by (wpsimp wp: hoare_vcg_all_lift | wps)+ - -lemma state_refs_of': - "\\s. P ((state_refs_of' s) (ptr := refs_of' (injectKO val)))\ - f ptr val - \\_ s. P (state_refs_of' s)\" - unfolding f_def - by (auto intro: setObject_state_refs_of' simp: default_update) - -lemma valid_arch_state'[wp]: - "f p v \ valid_arch_state' \" - by (rule valid_arch_state_lift'; wp) - -lemmas valid_irq_node'[wp] = valid_irq_node_lift[OF ksInterruptState typ_at'] -lemmas irq_states' [wp] = valid_irq_states_lift' [OF ksInterruptState ksMachineState] -lemmas irqs_masked'[wp] = irqs_masked_lift[OF ksInterruptState] - -lemma valid_machine_state'[wp]: - "f p v \valid_machine_state'\" - unfolding valid_machine_state'_def pointerInDeviceData_def pointerInUserData_def - by (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - -lemma pspace_domain_valid[wp]: - "f ptr val \pspace_domain_valid\" - unfolding f_def by (wpsimp simp: default_update updateObject_default_def in_monad projectKOs) - -lemmas x = ct_not_inQ_lift[OF ksSchedulerAction] - -lemma setObject_wp: - "\\s. P (set_obj' ptr obj s)\ - setObject ptr (obj :: 'a :: pspace_storable) - \\_. P\" - apply (wpsimp simp: setObject_def default_update updateObject_default_def fun_upd_def - ARM_H.fromPPtr_def) (* FIXME: arch split *) - (* FIXME: this is a simp rule, why isn't it available? *) - done - -lemmas set_wp = setObject_wp[folded f_def] -lemma setObject_pre: - fixes obj :: 'a - assumes "\P and obj_at' (\old_obj :: 'a. objBits old_obj = objBits obj) p\ - setObject p obj - \Q\" - shows "\P\ setObject p obj \Q\" - supply simps = in_magnitude_check[OF _, unfolded objBits_def] valid_def - setObject_def in_monad split_def default_update updateObject_default_def - projectKO_eq project_inject objBits_def - ARM_H.fromPPtr_def (* FIXME: arch split *) - using assms - apply (clarsimp simp: simps) - apply (rename_tac s ko) - apply (drule_tac x=s in spec) - apply (clarsimp simp: obj_at'_def projectKO_eq split_paired_Ball project_inject) - apply (erule impE) - apply fastforce - apply (drule spec, erule mp) - apply (fastforce simp: simps) - done - -\\ - Keeps the redundant @{term "obj_at \"} precondition because this matches common abbreviations - like @{term "tcb_at'"}. - - Lets the postcondition pointer depend on the state for things like @{term "ksCurThread"}. -\ -lemma setObject_obj_at'_strongest: - fixes obj :: 'a - shows "\\s. obj_at' (\_:: 'a. True) ptr s - \ obj_at' (\old_obj :: 'a. objBits old_obj = objBits obj) ptr s - \ (let s' = set_obj' ptr obj s in - Q ((ptr = ptr' s' \ P s' obj) - \ (ptr \ ptr' s' \ obj_at' (P s') (ptr' s') s)))\ - setObject ptr obj - \\rv s. Q (obj_at' (P s) (ptr' s) s)\" - apply (rule setObject_pre) - apply (wpsimp wp: setObject_wp - simp: Let_def) - apply (elim impE) - apply (clarsimp simp: obj_at'_def) - apply (erule rsubst[where P=Q]) - apply (case_tac "ptr = ptr' (set_obj' ptr obj s)"; simp) - apply (clarsimp simp: same_size_obj_at'_set_obj'_iff - obj_at'_ignoring_obj[where P="P f obj" for f]) - apply (clarsimp simp: obj_at'_def projectKO_eq project_inject ps_clear_upd) - done - -lemmas obj_at'_strongest = setObject_obj_at'_strongest[folded f_def] - -lemma setObject_obj_at': - fixes v :: 'a - shows "\\s. obj_at' (\_:: 'a. True) p s \ P (if p = p' then P' v else obj_at' P' p' s)\ - setObject p v - \\rv s. P (obj_at' P' p' s)\" - by (wpsimp wp: setObject_obj_at'_strongest split: if_splits) - -lemmas obj_at' = setObject_obj_at'[folded f_def] - -lemma getObject_wp: - "\\s. \ko :: 'a. ko_at' ko p s \ P ko s\ - getObject p - \P\" - apply (wpsimp simp: getObject_def default_load ARM_H.fromPPtr_def loadObject_default_def - projectKO_def readObject_def omonad_defs split_def) - apply (rename_tac ko) - apply (prop_tac "ko_at' ko p s") - apply (clarsimp simp: obj_at'_def project_inject projectKO_eq objBits_def[symmetric] - read_magnitudeCheck_def - lookupAround2_no_after_ps_clear - lookupAround2_after_ps_clear[OF _ _] - split: if_split_asm option.split_asm) - apply fastforce - done - -lemma getObject_wp': - "\\s. obj_at' (\_::'a. True) p s \ P (the ((ksPSpace s |> projectKO_opt) p)) s\ - getObject p - \P::'a \ _ \ _\" - apply (wpsimp wp: getObject_wp) - by (metis forall_ko_at'_equiv_projection) - -lemmas get_wp = getObject_wp[folded g_def] -lemmas get_wp' = getObject_wp'[folded g_def] - -lemma loadObject_default_inv: - "\P\ gets_the $ loadObject_default addr addr' next obj \\rv. P\" - by wpsimp - -lemma getObject_inv: - "\P\ getObject p \\(rv :: 'a). P\" - by (wpsimp simp: default_load getObject_def split_def wp: loadObject_default_inv) - -lemmas get_inv = getObject_inv[folded g_def] - -lemma getObject_sp: - "\P\ getObject r \\rv::'a. P and ko_at' rv r\" - apply (clarsimp simp: getObject_def loadObject_default_def default_load - projectKOs in_monad valid_def obj_at'_def project_inject - split_def ARM_H.fromPPtr_def readObject_def omonad_defs - split: if_split_asm option.split_asm) - by (clarsimp simp: objBits_def) - -lemmas getObject_sp' = getObject_sp[folded g_def] - -lemma setObject_preserves_some_obj_at': - "\\s. obj_at' (\_ :: 'a. True) p s \ P (obj_at' (\_ :: 'a. True) p' s)\ - setObject p (ko :: 'a) - \\_ s. P (obj_at' (\_ :: 'a. True) p' s)\" - apply (wpsimp wp: setObject_obj_at'_strongest) - apply (case_tac "p = p'"; clarsimp) - done - -lemmas set_preserves_some_obj_at' = setObject_preserves_some_obj_at'[folded f_def] - -lemma getObject_wp_rv_only: - "\\s. obj_at' (\_:: 'a. True) p s \ obj_at' (\ko :: 'a. P ko) p s\ getObject p \\rv _. P rv\" - apply (wpsimp wp: getObject_wp) - apply (clarsimp simp: obj_at'_def) - done - -lemmas get_wp_rv_only = getObject_wp_rv_only[folded g_def] - -\\ Stronger than getObject_inv. \ -lemma getObject_wp_state_only: - "\\s. obj_at' (\_ :: 'a. True) p s \ P s\ getObject p \\_ :: 'a. P\" - apply (wpsimp wp: getObject_wp) - apply (clarsimp simp: obj_at'_def) - done - -lemmas get_wp_state_only = getObject_wp_state_only[folded g_def] - -lemma setObject_no_update: - assumes [simp]: "\ko :: 'a. Q (upd ko) = Q ko" - shows - "\\s. P (obj_at' Q p' s) \ ko_at' ko p s\ - setObject p (upd ko) - \\_ s. P (obj_at' Q p' s)\" - apply (wpsimp wp: setObject_obj_at'_strongest) - apply (case_tac "p = p'"; clarsimp simp: obj_at'_def) - done - -lemmas set_no_update = setObject_no_update[folded f_def] - -lemmas getObject_ko_at' = getObject_ko_at[OF default_load] - -lemmas get_ko_at' = getObject_ko_at'[folded g_def] - -lemmas ko_wp_at = setObject_ko_wp_at[where 'a='a, folded f_def, - simplified default_update, simplified] - -lemma setObject_valid_reply': - "setObject p (ko :: 'a) \valid_reply' reply'\" - unfolding valid_reply'_def valid_bound_obj'_def - apply (wpsimp split: option.splits - wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - apply fastforce - done - -lemmas set_valid_reply' = setObject_valid_reply'[folded f_def] - -lemma setObject_ko_at': - "\\s. obj_at' (\_ :: 'a. True) p s \ - (p = p' \ P (ko = ko')) \ - (p \ p' \ P (ko_at' ko' p' s))\ - setObject p (ko :: 'a) - \\_ s. P (ko_at' (ko' :: 'a) p' s)\" - apply (wpsimp wp: obj_at'_strongest[unfolded f_def]) - apply (case_tac "p = p'"; clarsimp simp: obj_at'_def) - done - -lemmas set_ko_at' = setObject_ko_at'[folded f_def] - -end - -locale simple_non_tcb_ko' = simple_ko' "f:: obj_ref \ 'a::pspace_storable \ unit kernel" - "g:: obj_ref \ 'a kernel" for f g + - assumes not_tcb: "projectKO_opt (KOTCB sc) = (None :: 'a option)" -begin - -lemma updateObject_tcb[simp]: - "fst (updateObject (v::'a) (KOTCB tcb) p x n s) = {}" - by (clarsimp simp: default_update updateObject_default_def in_monad projectKOs not_tcb bind_def) - -lemma not_inject_tcb[simp]: - "injectKO (v::'a) \ KOTCB tcb" - by (simp flip: project_inject add: projectKOs not_tcb) - -lemma typeOf_not_tcb[simp]: - "koTypeOf (injectKO (v::'a)) \ TCBT" - by (cases "injectKO v"; simp) - -lemma cte_wp_at'[wp]: "f p v \\s. P (cte_wp_at' Q p' s)\" - unfolding f_def by (rule setObject_cte_wp_at2'[where Q="\", simplified]; simp) - -lemma ctes_of[wp]: "f p v \\s. P (ctes_of s)\" - unfolding f_def by (rule setObject_ctes_of[where Q="\", simplified]; simp) - -lemma valid_mdb'[wp]: "f p v \valid_mdb'\" - unfolding valid_mdb'_def by wp - -lemma obj_at_tcb'[wp]: - "f p v \\s. P (obj_at' (Q :: tcb \ bool) p' s)\" - unfolding f_def obj_at'_real_def - apply (wp setObject_ko_wp_at; simp add: default_update) - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) - apply (case_tac ko; simp add: projectKOs not_tcb) - done - -lemma valid_queues[wp]: - "f p v \ valid_queues \" - unfolding valid_queues_def valid_queues_no_bitmap_def - by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_ball_lift |wps)+ - -lemma valid_inQ_queues[wp]: - "f p v \ valid_inQ_queues \" - unfolding valid_inQ_queues_def - by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_ball_lift | wps)+ - -lemma set_non_tcb_valid_queues'[wp]: - "f p v \valid_queues'\" - unfolding valid_queues'_def - by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift) - -lemma set_non_tcb_valid_release_queue[wp]: - "f p v \valid_release_queue\" - unfolding valid_release_queue_def - by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift | wps)+ - -lemma set_non_tcb_valid_release_queue'[wp]: - "f p v \valid_release_queue'\" - unfolding valid_release_queue'_def - by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift | wps)+ - -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 ifunsafe'[wp]: - "f p v \if_unsafe_then_cap'\" - unfolding f_def - apply (rule setObject_ifunsafe'[where P="\", simplified]) - apply (clarsimp simp: default_update updateObject_default_def in_monad projectKOs not_tcb - not_cte - intro!: equals0I)+ - apply (simp add: setObject_def split_def default_update) - apply (wp updateObject_default_inv | simp)+ - done - -lemmas irq_handlers[wp] = valid_irq_handlers_lift'' [OF ctes_of ksInterruptState] -lemmas irq_handlers'[wp] = valid_irq_handlers_lift'' [OF ctes_of ksInterruptState] - -lemma valid_global_refs'[wp]: - "f p v \valid_global_refs'\" - by (rule valid_global_refs_lift'; wp) - -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) - -lemma untyped_ranges_zero'[wp]: - "f p ko \untyped_ranges_zero'\" - unfolding cteCaps_of_def o_def - apply (wpsimp wp: untyped_ranges_zero_lift) - done - -end - -locale simple_non_reply_ko' = simple_ko' "f:: obj_ref \ 'a::pspace_storable \ unit kernel" - "g:: obj_ref \ 'a kernel" for f g + - assumes not_reply: "projectKO_opt (KOReply reply) = (None :: 'a option)" -begin - -lemma updateObject_reply[simp]: - "fst (updateObject (v::'a) (KOReply c) p x n s) = {}" - by (clarsimp simp: default_update updateObject_default_def in_monad projectKOs not_reply bind_def) - -lemma not_inject_reply[simp]: - "injectKO (v::'a) \ KOReply sc" - by (simp flip: project_inject add: projectKOs not_reply) - -lemma typeOf_not_reply[simp]: - "koTypeOf (injectKO (v::'a)) \ ReplyT" - by (cases "injectKO v"; simp) - -end - -locale simple_non_tcb_non_reply_ko' = - simple_non_reply_ko' "f:: obj_ref \ 'a::pspace_storable \ unit kernel" - "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_replies' requires us to not be touching either of a Reply or a TCB -\ - -lemma valid_replies'[wp]: - "\valid_replies' and pspace_distinct' and pspace_aligned'\ - f p v - \\_. valid_replies'\" - (is "\?pre valid_replies'\ _ \?post\") - apply (rule_tac Q'="\_. ?pre valid_replies'_alt" in hoare_post_imp; - clarsimp simp: valid_replies'_def2) - unfolding obj_at'_real_def - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift ko_wp_at hoare_vcg_ex_lift) - by (fastforce simp: valid_replies'_def2 obj_at'_def ko_wp_at'_def projectKOs) - -lemma valid_pspace': - "\valid_pspace' and valid_obj' (injectKO v) \ f p v \\_. valid_pspace'\" - unfolding valid_pspace'_def by (wpsimp wp: valid_objs') - -end - -locale simple_non_sc_ko' = simple_ko' "f:: obj_ref \ 'a::pspace_storable \ unit kernel" - "g:: obj_ref \ 'a kernel" for f g + - assumes not_sc: "projectKO_opt (KOSchedContext sc) = (None :: 'a option)" -begin - -lemma updateObject_sc[simp]: - "fst (updateObject (v::'a) (KOSchedContext c) p x n s) = {}" - by (clarsimp simp: default_update updateObject_default_def in_monad projectKOs not_sc bind_def) - -lemma not_inject_sc[simp]: - "injectKO (v::'a) \ KOSchedContext sc" - by (simp flip: project_inject add: projectKOs not_sc) - -lemma typeOf_not_sc[simp]: - "koTypeOf (injectKO (v::'a)) \ SchedContextT" - by (cases "injectKO v"; simp) - -end - -locale simple_non_tcb_non_sc_ko' = - simple_non_sc_ko' "f:: obj_ref \ 'a::pspace_storable \ unit kernel" - "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) - apply (clarsimp simp: projectKOs) - 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" - "g:: obj_ref \ 'a kernel" + - simple_non_tcb_non_reply_ko' "f:: obj_ref \ 'a::pspace_storable \ unit kernel" - "g:: obj_ref \ 'a kernel" for f g - -(* FIXME: should these be in Arch + sublocale instead? *) -interpretation set_ep': simple_non_tcb_non_sc_non_reply_ko' setEndpoint getEndpoint - by unfold_locales (simp_all add: setEndpoint_def getEndpoint_def projectKO_opts_defs - objBits_simps') - -interpretation set_ntfn': simple_non_tcb_non_sc_non_reply_ko' setNotification getNotification - by unfold_locales (simp_all add: setNotification_def getNotification_def projectKO_opts_defs - objBits_simps') - -interpretation set_reply': simple_non_tcb_non_sc_ko' setReply getReply - by unfold_locales (simp_all add: setReply_def getReply_def projectKO_opts_defs objBits_simps') - -interpretation set_sc': simple_non_tcb_non_reply_ko' setSchedContext getSchedContext - by unfold_locales (simp_all add: setSchedContext_def getSchedContext_def projectKO_opts_defs - objBits_simps' scBits_pos_power2) - -interpretation set_tcb': simple_non_sc_ko' "\p v. setObject p (v::tcb)" - "\p. getObject p :: tcb kernel" - by unfold_locales (simp_all add: projectKO_opts_defs objBits_simps') - -lemma threadSet_pspace_only': - "pspace_only' (threadSet f p)" - unfolding threadSet_def - apply unfold_locales - apply (clarsimp simp: in_monad) - apply (drule_tac P="(=) s" in use_valid[OF _ getObject_tcb_inv], rule refl) - apply (fastforce dest: set_tcb'.pspace) - done - -interpretation threadSet: pspace_only' "threadSet f p" - by (simp add: threadSet_pspace_only') - -interpretation setBoundNotification: pspace_only' "setBoundNotification ntfnPtr tptr" - by (simp add: setBoundNotification_def threadSet_pspace_only') - - -context begin interpretation Arch . (*FIXME: arch_split*) - -lemmas setNotification_cap_to'[wp] - = ex_cte_cap_to'_pres [OF set_ntfn'.cte_wp_at' set_ntfn'.ksInterruptState] - -lemmas setEndpoint_cap_to'[wp] - = ex_cte_cap_to'_pres [OF set_ep'.cte_wp_at' set_ep'.ksInterruptState] - -lemmas setEndpoint_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_ep'.ctes_of] -lemmas setNotification_cteCaps_of[wp] = ctes_of_cteCaps_of_lift [OF set_ntfn'.ctes_of] - -(* aliases for compatibility with master *) - -lemmas setObject_ep_pre = set_ep'.setObject_pre -lemmas setObject_ntfn_pre = set_ntfn'.setObject_pre -lemmas setObject_tcb_pre = set_tcb'.setObject_pre -lemmas setObject_reply_pre = set_reply'.setObject_pre -lemmas setObject_sched_context_pre = set_sc'.setObject_pre - -lemmas getEndpoint_wp = set_ep'.get_wp -lemmas getNotification_wp = set_ntfn'.get_wp -lemmas getTCB_wp = set_tcb'.get_wp -lemmas getReply_wp[wp] = set_reply'.get_wp -lemmas getSchedContext_wp[wp] = set_sc'.get_wp - -lemmas getEndpoint_wp' = set_ep'.get_wp' -lemmas getNotification_wp' = set_ntfn'.get_wp' -lemmas getTCB_wp' = set_tcb'.get_wp' -lemmas getReply_wp' = set_reply'.get_wp' -lemmas getSchedContext_wp' = set_sc'.get_wp' - -lemmas getObject_ep_inv = set_ep'.getObject_inv -lemmas getObject_ntfn_inv = set_ntfn'.getObject_inv -lemmas getObject_reply_inv = set_reply'.getObject_inv -lemmas getObject_sc_inv = set_sc'.getObject_inv -(* FIXME RT: the one below is deferred because it requires to - move the simple_ko' locale at the beginning of this theory - which turns out to be quite a lot more work *) -(*lemmas getObject_tcb_inv = set_tcb'.getObject_inv*) - -lemmas get_ep_inv'[wp] = set_ep'.get_inv -lemmas get_ntfn_inv'[wp] = set_ntfn'.get_inv -lemmas get_tcb_inv' = set_tcb'.get_inv -lemmas get_reply_inv' = set_reply'.get_inv -lemmas get_sc_inv' = set_sc'.get_inv - -lemmas get_ep_sp' = set_ep'.getObject_sp' -lemmas get_ntfn_sp' = set_ntfn'.getObject_sp' -lemmas get_tcb_sp' = set_tcb'.getObject_sp' -lemmas get_reply_sp' = set_reply'.getObject_sp' -lemmas get_sc_sp' = set_sc'.getObject_sp' - -lemmas setObject_tcb_wp = set_tcb'.setObject_wp -lemmas setObject_sc_wp = set_sc'.setObject_wp -lemmas setObject_tcb_obj_at'_strongest = set_tcb'.setObject_obj_at'_strongest - -lemmas set_ep_valid_objs'[wp] = - set_ep'.valid_objs'[simplified valid_obj'_def pred_conj_def, simplified] -lemmas set_ep_valid_pspace'[wp] = - set_ep'.valid_pspace'[simplified valid_obj'_def pred_conj_def, simplified] - -lemmas set_ntfn_valid_objs'[wp] = - set_ntfn'.valid_objs'[simplified valid_obj'_def pred_conj_def, simplified] -lemmas set_ntfn_valid_pspace'[wp] = - set_ntfn'.valid_pspace'[simplified valid_obj'_def pred_conj_def, simplified] - -lemmas set_reply_valid_objs'[wp] = - set_reply'.valid_objs'[simplified valid_obj'_def pred_conj_def, simplified] - -lemmas set_sc_valid_objs'[wp] = - set_sc'.valid_objs'[simplified valid_obj'_def pred_conj_def, simplified] -lemmas set_sc_valid_pspace'[wp] = - set_sc'.valid_pspace'[simplified valid_obj'_def pred_conj_def, simplified] - -lemma set_ep_state_refs_of'[wp]: - "\\s. P ((state_refs_of' s) (p := ep_q_refs_of' ep))\ - setEndpoint p ep - \\rv s. P (state_refs_of' s)\" - by (wp set_ep'.state_refs_of') (simp flip: fun_upd_def) - -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 - \\rv s. P (state_refs_of' s)\" - by (wp set_ntfn'.state_refs_of') (simp flip: fun_upd_def) - -lemma setSchedContext_state_refs_of'[wp]: - "\\s. P ((state_refs_of' s)(p := get_refs SCNtfn (scNtfn sc) \ - get_refs SCTcb (scTCB sc) \ - get_refs SCYieldFrom (scYieldFrom sc) \ - get_refs SCReply (scReply sc)))\ - setSchedContext p sc - \\rv s. P (state_refs_of' s)\" - by (wp set_sc'.state_refs_of') (simp flip: fun_upd_def) - -lemma setReply_state_refs_of'[wp]: - "\\s. P ((state_refs_of' s)(p := get_refs ReplySchedContext (replySC reply) \ - get_refs ReplyTCB (replyTCB reply)))\ - setReply p reply - \\rv s. P (state_refs_of' s)\" - by (wp set_reply'.state_refs_of') (simp flip: fun_upd_def) - -lemma setReply_reply_projs[wp]: - "\\s. P ((replyNexts_of s)(rptr := replyNext_of reply)) - ((replyPrevs_of s)(rptr := replyPrev reply)) - ((replyTCBs_of s)(rptr := replyTCB reply)) - ((replySCs_of s)(rptr := replySC reply))\ - setReply rptr reply - \\_ s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)\" - apply (wpsimp simp: setReply_def updateObject_default_def setObject_def split_def) - apply (erule rsubst4[where P=P]) - apply (clarsimp simp: ext opt_map_def list_refs_of_reply'_def map_set_def projectKO_opt_reply - split: option.splits)+ - done - -lemma updateReply_wp_all: - "\\s. \ko. ko_at' ko rptr s \ P (set_obj' rptr (upd ko) s)\ - updateReply rptr upd - \\_. P\" - unfolding updateReply_def - apply (wpsimp wp: set_reply'.set_wp) - done - -lemma setSchedContext_iflive'[wp]: - "\if_live_then_nonz_cap' and (\s. live_sc' sc \ ex_nonz_cap_to' p s)\ - setSchedContext p sc - \\rv. if_live_then_nonz_cap'\" - unfolding setSchedContext_def - by (wpsimp wp: setObject_iflive'[where P="\"] - simp: updateObject_default_def in_monad scBits_pos_power2 - projectKOs objBits_simps' bind_def - |simp)+ - -lemma setReply_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' p\ - setReply p reply - \\rv. if_live_then_nonz_cap'\" - unfolding setReply_def - by (wpsimp wp: setObject_iflive'[where P="\"] - simp: updateObject_default_def in_monad - projectKOs objBits_simps' bind_def - |simp)+ - -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 - projectKOs objBits_simps' bind_def - |simp)+ - -lemma setReply_list_refs_of_replies'[wp]: - "\\s. P ((list_refs_of_replies' s)(p := list_refs_of_reply' reply))\ - setReply p reply - \\rv s. P (list_refs_of_replies' s)\" - apply (wpsimp simp: setReply_def updateObject_default_def setObject_def split_def) - apply (erule arg_cong[where f=P, THEN iffD1, rotated]) - apply (clarsimp simp: opt_map_def sym_refs_def fun_upd_def list_refs_of_reply'_def - map_set_def projectKO_opt_reply) - apply (rule ext) - apply (clarsimp simp: projectKO_opt_reply list_refs_of_reply'_def) - done - -lemma setObject_ksPSpace_only: - "\ \p q n ko. \P\ updateObject val p q n ko \\rv. P \; - \f s. P (ksPSpace_update f s) = P s \ - \ \P\ setObject ptr val \\rv. P\" - apply (simp add: setObject_def split_def) - apply (wp | simp | assumption)+ - done - -lemma setObject_ksMachine: - "\ \p q n ko. \\s. P (ksMachineState s)\ updateObject val p q n ko \\rv s. P (ksMachineState s)\ \ - \ \\s. P (ksMachineState s)\ setObject ptr val \\rv s. P (ksMachineState s)\" - by (simp add: setObject_ksPSpace_only) - -lemma setObject_ksInterrupt: - "\ \p q n ko. \\s. P (ksInterruptState s)\ updateObject val p q n ko \\rv s. P (ksInterruptState s)\ \ - \ \\s. P (ksInterruptState s)\ setObject ptr val \\rv s. P (ksInterruptState s)\" - by (simp add: setObject_ksPSpace_only) - - -lemma set_ntfn_iflive'[wp]: - "\\s. if_live_then_nonz_cap' s - \ (live' (KONotification v) \ ex_nonz_cap_to' p s)\ - setNotification p v - \\rv. if_live_then_nonz_cap'\" - apply (simp add: setNotification_def) - apply (wp setObject_iflive'[where P="\"]) - apply simp - apply (simp add: objBits_simps) - apply (clarsimp simp: updateObject_default_def in_monad projectKOs) - apply (clarsimp simp: updateObject_default_def in_monad - projectKOs bind_def) - apply clarsimp - done +lemmas set_ntfn_irq_states' [wp] = valid_irq_states_lift' [OF set_ntfn_ksInterrupt set_ntfn_ksMachine] lemma valid_pde_mappings'_def2: "valid_pde_mappings' = @@ -3042,45 +1978,81 @@ lemma set_ntfn_valid_pde_mappings'[wp]: apply (clarsimp simp: updateObject_default_def in_monad) done -lemma setObject_tcb_pre': - "\P and tcb_at' p\ setObject p (t::tcb) \Q\ \ \P\ setObject p (t::tcb) \Q\" - apply (rule setObject_tcb_pre) - apply (clarsimp simp: valid_def setObject_def in_monad - split_def updateObject_default_def - projectKOs in_magnitude_check objBits_simps') +lemma set_ntfn_vms'[wp]: + "\valid_machine_state'\ setNotification ptr val \\rv. valid_machine_state'\" + apply (simp add: setNotification_def valid_machine_state'_def pointerInDeviceData_def pointerInUserData_def) + apply (intro hoare_vcg_all_lift hoare_vcg_disj_lift) + by (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv | + simp)+ + +lemma irqs_masked_lift: + assumes "\P. \\s. P (intStateIRQTable (ksInterruptState s))\ f + \\rv s. P (intStateIRQTable (ksInterruptState s))\" + shows "\irqs_masked'\ f \\_. irqs_masked'\" + apply (simp add: irqs_masked'_def) + apply (wp assms) done -lemma setObject_at_pre_default: - assumes pre: "\P and obj_at' (\_::'a. True) p\ setObject p (v::'a::pspace_storable) \Q\" - assumes R: "\ko s y n. updateObject v ko p y n s = updateObject_default v ko p y n s" - shows "\P\ setObject p v \Q\" - using pre - apply (clarsimp simp: valid_def setObject_def in_monad R - split_def updateObject_default_def - projectKOs in_magnitude_check split_paired_Ball) - apply (drule spec, drule mp, erule conjI) - apply (simp add: obj_at'_def projectKOs objBits_def project_inject) - apply metis - apply (simp add: split_paired_Ball) - apply (drule spec, erule mp) - apply (clarsimp simp: in_monad projectKOs in_magnitude_check) +lemma setObject_pspace_domain_valid[wp]: + "\pspace_domain_valid\ + setObject ptr val + \\rv. pspace_domain_valid\" + apply (clarsimp simp: setObject_def split_def pspace_domain_valid_def + valid_def in_monad + split: if_split_asm) + apply (drule updateObject_objBitsKO) + apply (clarsimp simp: lookupAround2_char1) + done + +crunch setNotification, setEndpoint + for pspace_domain_valid[wp]: "pspace_domain_valid" + +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 setNotification_ct_not_inQ[wp]: + "\ct_not_inQ\ setNotification ptr rval \\_. ct_not_inQ\" + apply (rule ct_not_inQ_lift [OF setNotification_nosch]) + apply (simp add: setNotification_def ct_not_inQ_def) + apply (rule hoare_weaken_pre) + apply (wps setObject_ntfn_ct) + apply (rule obj_at_setObject2) + apply (clarsimp simp add: updateObject_default_def in_monad)+ + done + +lemma setNotification_ksCurThread[wp]: + "\\s. P (ksCurThread s)\ setNotification a b \\rv s. P (ksCurThread s)\" + apply (simp add: setNotification_def setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ done -lemma setObject_pspace_no_overlap': - assumes R: "\ko s y n. updateObject v ko p y n s = updateObject_default v ko p y n s" - shows "setObject p (v::'a::pspace_storable) \pspace_no_overlap' w s\" - apply (clarsimp simp: setObject_def split_def valid_def in_monad R objBits_def - updateObject_default_def in_monad projectKOs in_magnitude_check) - apply (fastforce simp: pspace_no_overlap'_def project_inject) +lemma setNotification_ksDomSchedule[wp]: + "\\s. P (ksDomSchedule s)\ setNotification a b \\rv s. P (ksDomSchedule s)\" + apply (simp add: setNotification_def setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ done -lemma setObject_tcb_pspace_no_overlap': - "setObject t (tcb::tcb) \pspace_no_overlap' w s\" - apply (rule setObject_pspace_no_overlap') - apply (clarsimp simp: setObject_def) +lemma setNotification_ksDomScheduleId[wp]: + "\\s. P (ksDomScheduleIdx s)\ setNotification a b \\rv s. P (ksDomScheduleIdx s)\" + apply (simp add: setNotification_def setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ done -end +lemma setNotification_ct_idle_or_in_cur_domain'[wp]: + "\ ct_idle_or_in_cur_domain' \ setNotification ptr ntfn \ \_. 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 + +crunch setNotification + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: setObject_ksPSpace_only updateObject_default_inv) lemma sym_heap_sched_pointers_lift: assumes prevs: "\P. f \\s. P (tcbSchedPrevs_of s)\" @@ -3098,14 +2070,35 @@ crunch setNotification (simp: updateObject_default_def) lemma set_ntfn_minor_invs': - "\invs' - and valid_ntfn' val - and (\s. live' (KONotification val) \ ex_nonz_cap_to' ptr s)\ - setNotification ptr val + "\invs' and obj_at' (\ntfn. ntfn_q_refs_of' (ntfnObj ntfn) = ntfn_q_refs_of' (ntfnObj val) + \ ntfn_bound_refs' (ntfnBoundTCB ntfn) = ntfn_bound_refs' (ntfnBoundTCB val)) + ptr + and valid_ntfn' val + and (\s. live' (KONotification val) \ ex_nonz_cap_to' ptr s) + and (\s. ptr \ ksIdleThread s) \ + setNotification ptr val \\rv. invs'\" - apply (clarsimp simp add: invs'_def cteCaps_of_def valid_dom_schedule'_def) + apply (clarsimp simp: invs'_def valid_state'_def cteCaps_of_def) apply (wpsimp wp: irqs_masked_lift valid_irq_node_lift untyped_ranges_zero_lift + sym_heap_sched_pointers_lift valid_bitmaps_lift simp: o_def) + apply (clarsimp elim!: rsubst[where P=sym_refs] + intro!: ext + dest!: obj_at_state_refs_ofD')+ + done + +lemma getEndpoint_wp: + "\\s. \ep. ko_at' ep e s \ P ep s\ getEndpoint e \P\" + apply (rule hoare_strengthen_post) + apply (rule get_ep_sp') + apply simp + done + +lemma getNotification_wp: + "\\s. \ntfn. ko_at' ntfn e s \ P ntfn s\ getNotification e \P\" + apply (rule hoare_strengthen_post) + apply (rule get_ntfn_sp') + apply simp done lemma ep_redux_simps': @@ -3116,11 +2109,9 @@ lemma ep_redux_simps': "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)+ + simp: valid_ep_def valid_ntfn_def + intro!: ext)+ -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 projectKOs) (* There are two wp rules for preserving valid_ioc over set_object. First, the more involved rule for CNodes and TCBs *) @@ -3133,18 +2124,11 @@ lemma idle_is_global [intro!]: "ksIdleThread s \ global_refs' s" by (simp add: global_refs'_def) -lemma idle_sc_is_global [intro!]: - "idle_sc_ptr \ global_refs' s" - by (simp add: global_refs'_def) - lemma valid_globals_cte_wpD': - "\ valid_global_refs' s; cte_wp_at' P p s; ptr \ global_refs' s \ - \ \cte. P cte \ ptr \ capRange (cteCap cte)" + "\ valid_global_refs' s; cte_wp_at' P p s \ + \ \cte. P cte \ ksIdleThread s \ capRange (cteCap cte)" by (fastforce simp: valid_global_refs'_def valid_refs'_def cte_wp_at_ctes_of) -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] - lemma dmo_aligned'[wp]: "\pspace_aligned'\ doMachineOp f \\_. pspace_aligned'\" apply (simp add: doMachineOp_def split_def) @@ -3178,2043 +2162,76 @@ lemma dmo_inv': crunch doMachineOp for cte_wp_at'2[wp]: "\s. P (cte_wp_at' P' p 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)" -global_interpretation doMachineOp: typ_at_all_props' "doMachineOp mop" - by typ_at_props' +crunch doMachineOp + for typ_at'[wp]: "\s. P (typ_at' T p s)" + +lemmas doMachineOp_typ_ats[wp] = typ_at_lifts [OF doMachineOp_typ_at'] lemma doMachineOp_invs_bits[wp]: - "\valid_pspace'\ doMachineOp m \\rv. valid_pspace'\" - "\\s. sch_act_wf (ksSchedulerAction s) s\ - doMachineOp m \\rv s. sch_act_wf (ksSchedulerAction s) s\" - "\Invariants_H.valid_queues\ doMachineOp m \\rv. Invariants_H.valid_queues\" - "\valid_queues'\ doMachineOp m \\rv. valid_queues'\" - "\\s. P (state_refs_of' s)\ - doMachineOp m - \\rv s. P (state_refs_of' s)\" - "\if_live_then_nonz_cap'\ doMachineOp m \\rv. if_live_then_nonz_cap'\" - "\cur_tcb'\ doMachineOp m \\rv. cur_tcb'\" - "\if_unsafe_then_cap'\ doMachineOp m \\rv. if_unsafe_then_cap'\" - "\sch_act_simple\ doMachineOp mop \\rv. sch_act_simple\" - by (simp add: doMachineOp_def split_def sch_act_simple_def - | wp cur_tcb_lift sch_act_wf_lift tcb_in_cur_domain'_lift - | fastforce elim: state_refs_of'_pspaceI)+ + "doMachineOp m \valid_pspace'\" + "doMachineOp m \\s. sch_act_wf (ksSchedulerAction s) s\" + "doMachineOp m \valid_bitmaps\" + "doMachineOp m \valid_sched_pointers\" + "doMachineOp m \\s. P (state_refs_of' s)\" + "doMachineOp m \if_live_then_nonz_cap'\" + "doMachineOp m \cur_tcb'\" + "doMachineOp m \if_unsafe_then_cap'\" + by (simp add: doMachineOp_def split_def + | wp + | fastforce elim: state_refs_of'_pspaceI)+ +crunch doMachineOp + for cte_wp_at'[wp]: "\s. P (cte_wp_at' P' p s)" crunch doMachineOp for obj_at'[wp]: "\s. P (obj_at' P' p s)" - and it[wp]: "\s. P (ksIdleThread s)" - and idle'[wp]: "valid_idle'" - and pde_mappings'[wp]: "valid_pde_mappings'" - and ko_wp_at'[wp]: "\s. P (ko_wp_at' T p s)" - -context begin interpretation Arch . (*FIXME: arch_split*) - -lemmas bit_simps' = pteBits_def asidHighBits_def asid_low_bits_def - asid_high_bits_def minSchedContextBits_def - replySizeBits_def pageBits_def pdeBits_def ptBits_def pdBits_def - -lemmas is_aligned_add_step_le' = is_aligned_add_step_le[simplified mask_2pm1 add_diff_eq] - -lemma objBitsKO_Data: - "objBitsKO (if dev then KOUserDataDevice else KOUserData) = pageBits" - by (simp add: objBits_def objBitsKO_def word_size_def) - -lemma of_bl_shift_cte_level_bits: - "(of_bl z :: machine_word) << cte_level_bits \ mask (cte_level_bits + length z)" - by word_bitwise - (simp add: test_bit_of_bl word_size cte_level_bits_def rev_bl_order_simps) - -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[simplified word_shift_by_n]) - 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: bit_simps' min_sched_context_bits_def) - apply (rule_tac x=replySizeBits in exI) - apply (simp add: replySizeBits_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=pdeBits in exI) - apply (simp add: bit_simps is_aligned_shift mask_def pdeBits_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 (simp add: pbfs_less_wb'[unfolded word_bits_def, simplified]) - apply fastforce - done - -lemma obj_relation_cuts_range_mask_range: - "\ (p', P) \ obj_relation_cuts ko p; P ko ko'; is_aligned p (obj_bits ko) \ - \ p' \ mask_range p (obj_bits ko)" - apply (drule (1) obj_relation_cuts_range_limit, clarsimp) - apply (rule conjI) - apply (rule word_plus_mono_right2; assumption?) - apply (simp add: is_aligned_no_overflow_mask) - apply (erule word_plus_mono_right) - apply (simp add: is_aligned_no_overflow_mask) - done - -lemma obj_relation_cuts_obj_bits: - "\ (p', P) \ obj_relation_cuts ko p; P ko ko' \ \ objBitsKO ko' \ obj_bits ko" - apply (erule (1) obj_relation_cutsE; - clarsimp simp: objBits_simps objBits_defs cte_level_bits_def sc_const_eq[symmetric] - pbfs_atleast_pageBits[simplified bit_simps] archObjSize_def pteBits_def - pdeBits_def sc_relation_def) - apply (cases ko; simp add: other_obj_relation_def objBits_defs - split: kernel_object.splits) - apply (rename_tac ako, case_tac ako; clarsimp) - apply (rename_tac ako', case_tac ako'; clarsimp simp: archObjSize_def) - done - -lemma typ_at'_same_type: - assumes "typ_at' T p s" "koTypeOf k = koTypeOf ko" "objBitsKO k = objBitsKO ko" "ksPSpace s p' = Some ko" - shows "typ_at' T p (s\ksPSpace :=(ksPSpace s)(p' \ k)\)" - using assms - by (clarsimp simp: typ_at'_def ko_wp_at'_def ps_clear_upd) - -lemma cte_at'_same_type: - "\cte_wp_at' \ t s; koTypeOf k = koTypeOf ko;objBitsKO k = objBitsKO ko; - ksPSpace s p = Some ko\ - \ cte_wp_at' \ t (s\ksPSpace := (ksPSpace s)(p \ k)\)" - apply (simp add: cte_at_typ' typ_at'_same_type) - apply (elim exE disjE) - apply (rule disjI1, clarsimp simp: typ_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 projectKOs 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 projectKOs objBits_simps - split: endpoint.splits capability.splits) - apply fastforce+ - apply (clarsimp split: zombie_type.splits simp: projectKOs 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: ko_wp_at'_def valid_cap'_def obj_at'_def projectKOs objBits_simps - page_directory_at'_def page_table_at'_def - ARM_H.arch_capability.distinct ARM_H.arch_capability.inject - split: ARM_H.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)\)" - 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 projectKOs objBits_simps - split: endpoint.splits capability.splits) - apply fastforce+ - apply (clarsimp split: zombie_type.splits simp: projectKOs 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: ko_wp_at'_def valid_cap'_def obj_at'_def projectKOs objBits_simps - page_directory_at'_def page_table_at'_def - split: ARM_H.arch_capability.splits option.splits if_split_asm - | rule_tac ko="KOReply obj" in typ_at'_same_type[where p'=rptr])+ - apply (clarsimp simp: valid_untyped'_def ko_wp_at'_def obj_range'_def split: if_split_asm) - apply (drule_tac x=rptr in spec, fastforce simp: objBits_simps)+ - apply (drule_tac x=addr in spec, fastforce) - apply fastforce - done - -lemma valid_tcb_state'_ep_update: - "\ valid_objs' s; valid_ep' ep s; ep_at' epPtr s; ksPSpace s x = Some (KOTCB obj) \ - \ valid_tcb_state' (tcbState obj) (s\ksPSpace := (ksPSpace s)(epPtr \ KOEndpoint ep)\)" - apply (rule valid_objsE', simp, simp) - by (fastforce simp: typ_at'_same_type ps_clear_upd objBits_simps valid_obj'_def projectKOs - valid_tcb_state'_def valid_bound_obj'_def valid_tcb'_def obj_at'_def - split: option.splits thread_state.splits) - -lemma valid_tcb_state'_reply_update: - "\ valid_objs' s; valid_reply' reply s; reply_at' rptr s; ksPSpace s x = Some (KOTCB obj) \ - \ valid_tcb_state' (tcbState obj) (s\ksPSpace := (ksPSpace s)(rptr \ KOReply reply)\)" - apply (rule valid_objsE', simp, simp) - by (fastforce simp: typ_at'_same_type ps_clear_upd objBits_simps valid_obj'_def projectKOs - valid_bound_obj'_def valid_tcb'_def valid_tcb_state'_def obj_at'_def - split: option.splits thread_state.splits) - -lemma valid_tcb'_ep_update: - "\ valid_objs' s; valid_ep' ep s; ep_at' epPtr s; ksPSpace s x = Some (KOTCB obj) \ - \ valid_tcb' obj (s\ksPSpace := (ksPSpace s)(epPtr \ KOEndpoint ep)\)" - apply (rule valid_objsE', simp, simp) - by (fastforce simp: typ_at'_same_type ps_clear_upd objBits_simps valid_obj'_def projectKOs - valid_bound_obj'_def valid_tcb'_def obj_at'_def valid_tcb_state'_ep_update - valid_cap'_ep_update - split: option.splits thread_state.splits) - -lemma valid_arch_obj'_ep_update: - "\ valid_objs' s; valid_ep' ep s; ep_at' epPtr s; ksPSpace s x = Some (KOArch obj) \ - \ valid_arch_obj' obj (s\ksPSpace := (ksPSpace s)(epPtr \ KOEndpoint ep)\)" - apply (rule valid_objsE', simp, simp) - apply (cases obj; clarsimp simp: valid_arch_obj'_def valid_obj'_def obj_at'_def projectKOs - split: arch_kernel_object.splits) - apply (rename_tac asid ep', case_tac asid, simp) - apply (rename_tac pte ep', case_tac pte; simp add: valid_mapping'_def) - apply (rename_tac pde ep', case_tac pde; simp add: valid_mapping'_def) - done - -lemma valid_arch_obj'_reply_update: - "\ valid_objs' s; valid_reply' reply s; reply_at' rptr s; ksPSpace s x = Some (KOArch obj) \ - \ valid_arch_obj' obj (s\ksPSpace := (ksPSpace s)(rptr \ KOReply reply)\)" - supply ps_clear_upd[simp] - apply (rule valid_objsE', simp, simp) - apply (cases obj; clarsimp simp: valid_arch_obj'_def valid_obj'_def obj_at'_def projectKOs - split: arch_kernel_object.splits) - apply (rename_tac asid reply', case_tac asid, simp) - apply (rename_tac pte reply', case_tac pte; simp add: valid_mapping'_def) - apply (rename_tac pde reply', case_tac pde; simp add: valid_mapping'_def) - done -end +crunch doMachineOp + for it[wp]: "\s. P (ksIdleThread s)" +crunch doMachineOp + for idle'[wp]: "valid_idle'" + (wp: crunch_wps simp: crunch_simps valid_idle'_pspace_itI) +crunch doMachineOp + for pde_mappings'[wp]: "valid_pde_mappings'" -lemma valid_obj'_ep_update: - "\ valid_objs' s; valid_ep' ep s; ep_at' epPtr s; ksPSpace s x = Some obj\ - \ valid_obj' obj (s\ksPSpace := (ksPSpace s)(epPtr \ KOEndpoint ep)\)" - apply (rule valid_objsE', simp, simp) - by (cases obj; - clarsimp simp: typ_at'_same_type valid_obj'_def obj_at'_def ps_clear_upd - valid_ntfn'_def valid_bound_obj'_def valid_reply'_def valid_cte'_def - valid_sched_context'_def objBits_simps projectKOs valid_cap'_ep_update - valid_arch_obj'_ep_update valid_ep'_ep_update valid_tcb'_ep_update - split: endpoint.splits ntfn.splits option.splits) - fastforce+ - -lemma valid_obj'_reply_update: - "\ valid_objs' s; valid_reply' reply s; reply_at' rptr s; ksPSpace s x = Some obj \ - \ valid_obj' obj (s\ksPSpace := (ksPSpace s)(rptr \ KOReply reply)\)" - apply (rule valid_objsE', simp, simp) - apply (cases obj; clarsimp simp: valid_obj'_def) - apply (fastforce simp: valid_ep'_def obj_at'_def projectKOs split: endpoint.split) - apply (fastforce simp: valid_bound_obj'_def valid_ntfn'_def obj_at'_def projectKOs - split: ntfn.splits option.split) - apply (fastforce simp: valid_bound_obj'_def valid_tcb'_def valid_tcb_state'_reply_update - valid_cap'_reply_update obj_at'_def projectKOs tcb_cte_cases_def - split: option.split) - apply (fastforce simp: valid_cap'_reply_update obj_at'_def valid_cte'_def projectKOs) - apply (fastforce simp: valid_arch_obj'_reply_update obj_at'_def projectKOs) - apply (fastforce simp: valid_sched_context'_def valid_bound_obj'_def objBitsKO_def - obj_at'_def projectKOs ps_clear_upd - split: option.split) - apply (fastforce simp: valid_reply'_def valid_bound_obj'_def obj_at'_def projectKOs objBitsKO_def - split: option.split) - done - -lemma valid_objs'_ep_update: - "\ valid_objs' s; valid_ep' ep s; ep_at' epPtr s \ - \ valid_objs' (s\ksPSpace := (ksPSpace s)(epPtr \ KOEndpoint ep)\)" - apply (clarsimp simp: valid_objs'_def obj_at'_def projectKOs) - apply (erule ranE) - apply (clarsimp simp: ps_clear_upd split: if_split_asm) - apply (fastforce simp: valid_obj'_def valid_ep'_def obj_at'_def ps_clear_upd - objBits_simps projectKOs - split: endpoint.splits) - apply (fastforce intro!: valid_obj'_ep_update simp: valid_objs'_def obj_at'_def projectKOs) - done - -lemma valid_objs'_reply_update: - "\ valid_objs' s; valid_reply' reply s; reply_at' rptr s \ - \ valid_objs' (s\ksPSpace := (ksPSpace s)(rptr \ KOReply reply)\)" - apply (clarsimp simp: valid_objs'_def obj_at'_def projectKOs) - apply (erule ranE) - apply (clarsimp split: if_split_asm) - apply (fastforce simp: valid_bound_obj'_def valid_obj'_def valid_reply'_def - obj_at'_def projectKOs objBitsKO_def - split: option.splits) - apply (fastforce intro!: valid_obj'_reply_update simp: valid_objs'_def obj_at'_def projectKOs) - done - -lemma valid_release_queue_ksPSpace_update: - "\valid_release_queue s; - ko_wp_at' (\ko'. koTypeOf ko' = koTypeOf ko \ objBitsKO ko' = objBitsKO ko) ptr s; - koTypeOf ko \ TCBT\ \ - valid_release_queue (s\ksPSpace := (ksPSpace s)(ptr \ ko)\)" - by (fastforce simp: valid_release_queue_def ko_wp_at'_def obj_at'_def projectKOs ps_clear_upd) - -lemma valid_release_queue'_ksPSpace_update: - "\valid_release_queue' s; - ko_wp_at' (\ko'. koTypeOf ko' = koTypeOf ko \ objBitsKO ko' = objBitsKO ko) ptr s; - koTypeOf ko \ TCBT\ \ - valid_release_queue' (s\ksPSpace := (ksPSpace s)(ptr \ ko)\)" - by (fastforce simp: valid_release_queue'_def ko_wp_at'_def obj_at'_def projectKOs ps_clear_upd) - -lemma sym_ref_Receive_or_Reply_replyTCB': - "\ sym_refs (state_refs_of' s); ko_at' tcb tp s; - tcbState tcb = BlockedOnReceive ep pl (Some rp) - \ tcbState tcb = BlockedOnReply (Some rp) \ \ - \reply. ksPSpace s rp = Some (KOReply reply) \ replyTCB reply = Some tp" - apply (drule (1) sym_refs_obj_atD'[rotated, where p=tp]) - apply (clarsimp simp: state_refs_of'_def projectKOs obj_at'_def) - 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 - split: endpoint.split_asm ntfn.split_asm thread_state.split_asm if_split_asm)+ - done - -lemma sym_ref_replyTCB_Receive_or_Reply: - "\ ko_at' reply rp s; sym_refs (state_refs_of' s); replyTCB reply = Some tp \ - \ st_tcb_at' (\st. (\ep pl. st = BlockedOnReceive ep pl (Some rp)) - \ st = BlockedOnReply (Some rp)) tp s" - apply (drule (1) sym_refs_obj_atD'[rotated, where p=rp]) - apply (clarsimp simp: state_refs_of'_def projectKOs 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 - 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 projectKOs 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 projectKOs 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 projectKOs)+ - done - -(* cross lemmas *) - -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma pspace_aligned_cross: - "\ pspace_aligned s; pspace_relation (kheap s) (ksPSpace s') \ \ pspace_aligned' s'" - apply (clarsimp simp: pspace_aligned'_def pspace_aligned_def pspace_relation_def) - apply (rename_tac p' ko') - apply (prop_tac "p' \ pspace_dom (kheap s)", fastforce) - apply (thin_tac "pspace_dom k = p" for k p) - apply (clarsimp simp: pspace_dom_def) - apply (drule bspec, fastforce)+ - apply clarsimp - apply (rename_tac ko' a a' P ko) - apply (erule (1) obj_relation_cutsE; clarsimp simp: objBits_simps) - - \\CNode\ - apply (clarsimp simp: cte_map_def) - apply (simp only: cteSizeBits_def cte_level_bits_def) - apply (rule is_aligned_add) - apply (erule is_aligned_weaken, simp) - apply (rule is_aligned_weaken) - apply (rule is_aligned_mult_triv2, simp) - - \\SchedContext, Reply\ - apply ((clarsimp simp: minSchedContextBits_def min_sched_context_bits_def replySizeBits_def - sc_relation_def - elim!: is_aligned_weaken)+)[2] - - \\PageTable\ - apply (clarsimp simp: archObjSize_def pteBits_def) - apply (rule is_aligned_add) - apply (erule is_aligned_weaken) - apply simp - apply (rule is_aligned_shift) - - \\PageDirectory\ - apply (clarsimp simp: archObjSize_def pdeBits_def) - apply (rule is_aligned_add) - apply (erule is_aligned_weaken, simp) - apply (rule is_aligned_shift) - - \\DataPage\ - apply (rule is_aligned_add) - apply (erule is_aligned_weaken) - apply (clarsimp simp: pageBits_def pageBitsForSize_def) - apply (case_tac sz; simp) - apply (rule is_aligned_mult_triv2) - - \\other_obj_relation\ - apply (simp add: other_obj_relation_def) - by (clarsimp simp: bit_simps' tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def - split: kernel_object.splits Structures_A.kernel_object.splits) - (fastforce simp: archObjSize_def split: arch_kernel_object.splits arch_kernel_obj.splits) - -lemma pspace_relation_pspace_bounded': - "\ pspace_relation (kheap s) (ksPSpace s') \ \ pspace_bounded' s'" - apply (clarsimp simp: pspace_bounded'_def pspace_relation_def) - apply (rename_tac p' ko') - apply (prop_tac "p' \ pspace_dom (kheap s)", fastforce) - apply (thin_tac "pspace_dom k = p" for k p) - apply (clarsimp simp: pspace_dom_def) - apply (drule bspec, fastforce)+ - apply clarsimp - apply (rename_tac ko' a a' P ko) - apply (erule (1) obj_relation_cutsE; - clarsimp simp: objBits_simps' word_bits_def pageBits_def archObjSize_def pteBits_def pdeBits_def) +lemma setEndpoint_ksMachine: + "\\s. P (ksMachineState s)\ setEndpoint ptr val \\rv s. P (ksMachineState s)\" + by (simp add: setEndpoint_def | wp setObject_ksMachine updateObject_default_inv)+ - \\SchedContext\ - apply (clarsimp simp: minSchedContextBits_def min_sched_context_bits_def replySizeBits_def - valid_sched_context_size_def sc_relation_def untyped_max_bits_def - elim!: is_aligned_weaken) +lemmas setEndpoint_valid_irq_states' = + valid_irq_states_lift' [OF setEndpoint_ksInterruptState setEndpoint_ksMachine] - \\other_obj_relation\ - apply (simp add: other_obj_relation_def) - by (clarsimp simp: bit_simps' tcbBlockSizeBits_def epSizeBits_def ntfnSizeBits_def - split: kernel_object.splits Structures_A.kernel_object.splits) - (clarsimp simp: archObjSize_def pteBits_def pdeBits_def pageBits_def - split: arch_kernel_object.splits arch_kernel_obj.splits) - -lemma pspace_distinct_cross: - "\ pspace_distinct s; pspace_aligned s; pspace_relation (kheap s) (ksPSpace s') \ \ - pspace_distinct' s'" - apply (frule (1) pspace_aligned_cross) - apply (clarsimp simp: pspace_distinct'_def) - apply (rename_tac p' ko') - apply (rule pspace_dom_relatedE; assumption?) - apply (rename_tac p ko P) - apply (frule (1) pspace_alignedD') - apply (frule (1) pspace_alignedD) - apply (frule pspace_relation_pspace_bounded') - apply (frule (1) pspace_boundedD') - apply (rule ps_clearI, assumption) - apply (case_tac ko'; - simp add: scBits_pos_power2 objBits_simps objBits_defs bit_simps' - del: minSchedContextBits_def) - apply (clarsimp split: arch_kernel_object.splits simp: bit_simps' archObjSize_def) - apply (rule ccontr, clarsimp) - apply (rename_tac x' ko_x') - apply (frule_tac x=x' in pspace_alignedD', assumption) - apply (rule_tac x=x' in pspace_dom_relatedE; assumption?) - apply (rename_tac x ko_x P') - apply (frule_tac p=x in pspace_alignedD, assumption) - 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 archObjSize_def) - apply (rule_tac n=pteBits in is_aligned_add_step_le'; assumption?) - apply (clarsimp simp: pde_relation_def objBits_simps archObjSize_def) - apply (rule_tac n=pdeBits 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 - add: is_other_obj_relation_type_CapTable - is_other_obj_relation_type_SchedContext - is_other_obj_relation_type_Reply - a_type_def) - 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) - apply (frule_tac x=p and y=x in pspace_distinctD; assumption?) - apply (drule (4) mask_range_subsetD) - apply (erule (2) in_empty_interE) +lemma setEndpoint_ct': + "\\s. P (ksCurThread s)\ setEndpoint a b \\rv s. P (ksCurThread s)\" + apply (simp add: setEndpoint_def setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ done -lemma aligned'_distinct'_ko_at'I: - "\ksPSpace s' x = Some ko; pspace_aligned' s'; pspace_distinct' s'; - (if koTypeOf ko = SchedContextT then pspace_bounded' s' else True); - ko = injectKO (v:: 'a :: pspace_storable)\ - \ ko_at' v x s'" - apply (simp add: obj_at'_def projectKOs project_inject pspace_bounded'_def - pspace_distinct'_def pspace_aligned'_def) +lemma aligned_distinct_obj_atI': + "\ ksPSpace s x = Some ko; pspace_aligned' s; pspace_distinct' s; ko = injectKO v \ + \ ko_at' v x s" + apply (simp add: obj_at'_def projectKOs project_inject pspace_distinct'_def pspace_aligned'_def) apply (drule bspec, erule domI)+ - apply (case_tac "injectKO v"; clarsimp simp: valid_sz_simps dest!: pspace_boundedD') - done - -lemma aligned_distinct_ko_at'I: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes ps: "pspace_aligned s" "pspace_distinct s" - shows "\ksPSpace s' x = Some ko; ko = injectKO (v:: 'a :: pspace_storable)\ - \ ko_at' v x s'" - apply (rule aligned'_distinct'_ko_at'I[OF _ pspace_aligned_cross[OF ps(1) p]]; simp) - using assms by (fastforce dest!: pspace_distinct_cross simp: pspace_relation_pspace_bounded'[OF p])+ - -lemma tcb_at_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes aligned: "pspace_aligned s" - assumes distinct: "pspace_distinct s" - assumes t: "tcb_at t s" - shows "tcb_at' t s'" using assms - apply (clarsimp simp: obj_at_def is_tcb) - 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=tcb] elim: obj_at'_weakenE) - -lemma st_tcb_at_coerce_abstract: - assumes t: "st_tcb_at' P t c" - assumes sr: "(a, c) \ state_relation" - shows "st_tcb_at (\st. \st'. thread_state_relation st st' \ P st') t a" - using assms - apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def - projectKOs) - 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 - split: Structures_A.kernel_object.split_asm if_split_asm - arch_kernel_obj.split_asm)+ - apply fastforce - done - -lemma st_tcb_at_coerce_concrete: - assumes t: "st_tcb_at P t s" - assumes sr: "(s, s') \ state_relation" "pspace_aligned s" "pspace_distinct s" - shows "st_tcb_at' (\st'. \st. thread_state_relation st st' \ P st) t s'" - using assms - apply (clarsimp simp: state_relation_def pred_tcb_at_def obj_at_def projectKOs) - apply (frule (1) pspace_distinct_cross, fastforce simp: state_relation_def) - apply (frule pspace_aligned_cross, fastforce simp: state_relation_def) - apply (prop_tac "tcb_at t s", clarsimp simp: st_tcb_at_def obj_at_def is_tcb) - apply (drule (2) tcb_at_cross[rotated], fastforce simp: state_relation_def) - apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def projectKOs) - 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 - split: Structures_A.kernel_object.split_asm if_split_asm)+ - apply fastforce - done - -lemma st_tcb_at_runnable_cross: - "\ st_tcb_at runnable t s; pspace_aligned s; pspace_distinct s; (s, s') \ state_relation \ - \ st_tcb_at' runnable' t s'" - apply (drule (3) st_tcb_at_coerce_concrete) - by (clarsimp simp: pred_tcb_at'_def obj_at'_def sts_rel_runnable) - -lemma bound_sc_tcb_at_cross: - assumes t: "bound_sc_tcb_at P t s" - assumes sr: "(s, s') \ state_relation" "pspace_aligned s" "pspace_distinct s" - shows "tcb_at' t s' \ P (tcbSCs_of s' t)" - using assms - apply (clarsimp simp: state_relation_def pred_tcb_at_def obj_at_def projectKOs) - apply (frule (1) pspace_distinct_cross, fastforce simp: state_relation_def) - apply (frule pspace_aligned_cross, fastforce simp: state_relation_def) - apply (prop_tac "tcb_at t s", clarsimp simp: obj_at_def is_tcb) - apply (drule (2) tcb_at_cross[rotated], fastforce simp: state_relation_def) - apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def projectKOs 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 - split: Structures_A.kernel_object.split_asm if_split_asm)+ - done - -lemma bound_yt_tcb_at_cross: - assumes t: "bound_yt_tcb_at P t s" - assumes sr: "(s, s') \ state_relation" "pspace_aligned s" "pspace_distinct s" - shows "obj_at' (\tcb'. \tcb. tcb_relation tcb tcb' \ P (tcb_yield_to tcb)) t s'" - using assms - apply (clarsimp simp: state_relation_def pred_tcb_at_def obj_at_def projectKOs) - apply (frule (1) pspace_distinct_cross, fastforce simp: state_relation_def) - apply (frule pspace_aligned_cross, fastforce simp: state_relation_def) - apply (prop_tac "tcb_at t s", clarsimp simp: st_tcb_at_def obj_at_def is_tcb) - apply (drule (2) tcb_at_cross[rotated], fastforce simp: state_relation_def) - apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def projectKOs) - 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 - split: Structures_A.kernel_object.split_asm if_split_asm)+ - apply fastforce - done - -lemma sc_tcb_sc_at_bound_cross: - "\pspace_relation (kheap s) (ksPSpace s'); valid_objs s; pspace_aligned s; pspace_distinct s; - sc_tcb_sc_at ((\) None) scp s\ - \ obj_at' (\sc. \y. scTCB sc = Some y) scp s'" - apply (clarsimp simp: obj_at_def sc_tcb_sc_at_def) - apply (frule (1) pspace_relation_absD) - apply clarsimp - apply (prop_tac "valid_sched_context_size n") - apply (erule (1) valid_sched_context_size_objsI) - apply (clarsimp simp: if_split_asm) - apply (rename_tac z; case_tac z; simp) - apply (drule (3) aligned_distinct_ko_at'I[where 'a=sched_context], simp) - apply (clarsimp simp: obj_at'_def sc_relation_def projectKOs) - by (metis not_None_eq) - -lemma cur_tcb_cross: - "\ cur_tcb s; pspace_aligned s; pspace_distinct s; (s,s') \ state_relation \ \ cur_tcb' s'" - apply (clarsimp simp: cur_tcb'_def cur_tcb_def state_relation_def) - apply (erule (3) tcb_at_cross) - done - -method add_cur_tcb' = - rule_tac Q="\s'. cur_tcb' s'" in corres_cross_add_guard, - fastforce intro!: cur_tcb_cross - -lemma cur_sc_tcb_cross: - "\(s, s') \ state_relation; valid_objs s; pspace_aligned s; pspace_distinct s; - cur_sc_tcb s; schact_is_rct s\ - \ obj_at' (\sc. scTCB sc = Some (ksCurThread s')) (ksCurSc s') s'" - apply (clarsimp simp: obj_at_def sc_tcb_sc_at_def cur_sc_tcb_def - dest!: schact_is_rct state_relationD) - apply (frule (1) pspace_relation_absD) - apply clarsimp - apply (prop_tac "valid_sched_context_size n") - apply (erule (1) valid_sched_context_size_objsI) - apply (clarsimp simp: if_split_asm) - apply (rename_tac z; case_tac z; simp) - apply (drule (3) aligned_distinct_ko_at'I[where 'a=sched_context], simp) - apply (clarsimp simp: obj_at'_def sc_relation_def projectKOs) - done - -lemma reply_at_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes ps: "pspace_aligned s" "pspace_distinct s" - assumes t: "reply_at ptr s" - shows "reply_at' ptr s'" - using assms - apply (clarsimp simp: obj_at_def is_reply) - apply (drule (1) pspace_relation_absD, clarsimp) - apply (case_tac z; simp) - by (fastforce dest!: aligned_distinct_ko_at'I[where 'a=reply] elim: obj_at'_weakenE) - -lemma ep_at_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes ps: "pspace_aligned s" "pspace_distinct s" - assumes t: "ep_at ptr s" - 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 ntfn_at_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes ps: "pspace_aligned s" "pspace_distinct s" - assumes t: "ntfn_at ptr s" - 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) - -lemma sc_at_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes ps: "pspace_aligned s" "pspace_distinct s" - assumes t: "sc_at ptr s" - shows "sc_at' ptr s'" - using assms - apply (clarsimp simp: obj_at_def is_sc_obj) - apply (drule (1) pspace_relation_absD, clarsimp) - apply (case_tac z; simp) - by (fastforce dest!: aligned_distinct_ko_at'I[where 'a=sched_context] elim: obj_at'_weakenE) - -lemma sc_at'_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and sc_at t) (sc_at' t)" - unfolding cross_rel_def state_relation_def - apply clarsimp - by (erule (3) sc_at_cross) - -lemma sc_obj_at_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes ps: "pspace_aligned s" "pspace_distinct s" - assumes t: "sc_obj_at n ptr s" - shows "obj_at' (\sc::sched_context. objBits sc = minSchedContextBits + n) ptr s'" - using assms - apply (clarsimp simp: obj_at_def is_sc_obj) - apply (drule (1) pspace_relation_absD, clarsimp) - apply (case_tac z; simp) - apply (rename_tac sc') - apply (drule (3) aligned_distinct_ko_at'I[where 'a=sched_context], simp) - by (clarsimp simp: scBits_simps objBits_simps sc_relation_def obj_at'_def) - -lemma real_cte_at_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes ps: "pspace_aligned s" "pspace_distinct s" - assumes t: "real_cte_at ptr s" - shows "real_cte_at' (cte_map ptr) s'" - 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 (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) - 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 pde_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_obj_relation_def) - apply ((drule_tac x=0 in spec, clarsimp simp: pte_relation_def pde_relation_def)+)[2] - apply (drule_tac x=p in spec, clarsimp) - 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 pageBits_def split: vmpage_size.split_asm) - apply (all \case_tac ko'; clarsimp simp: other_obj_relation_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 (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 - -end - -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]) - -lemma ct_not_inQ_cross: - "\(s,s') \ state_relation; ct_not_in_q s; valid_queues' s'; cur_tcb s; pspace_aligned s; - pspace_distinct s\ - \ ct_not_inQ s'" - apply (frule (3) cur_tcb_cross) - apply (clarsimp simp: ct_not_inQ_def ct_not_in_q_def) - apply (prop_tac "scheduler_action s = resume_cur_thread") - apply (clarsimp simp: state_relation_def) - apply (metis sched_act_relation.simps Structures_A.scheduler_action.exhaust - scheduler_action.simps) - apply (clarsimp simp: not_queued_def) - apply (rule ccontr) - apply (prop_tac "obj_at' tcbQueued (ksCurThread s') s'") - apply (clarsimp simp: obj_at_simps cur_tcb'_def) - apply (frule curthread_relation) - apply (frule state_relation_ready_queues_relation) - apply (clarsimp simp: valid_queues'_def inQ_def ready_queues_relation_def obj_at_simps) - by (metis Structures_H.kernel_object.case(6)) - -lemma sch_act_wf_cross: - "\(s,s') \ state_relation; valid_sched_action s; cur_tcb s; pspace_aligned s; pspace_distinct s\ - \ sch_act_wf (ksSchedulerAction s') s'" - apply (clarsimp simp: sch_act_wf_def) - apply (cases "ksSchedulerAction s'"; clarsimp) - apply (prop_tac "scheduler_action s = resume_cur_thread") - apply (clarsimp simp: state_relation_def) - apply (metis sched_act_relation.simps Structures_A.scheduler_action.exhaust - scheduler_action.simps) - apply (frule curthread_relation) - apply (frule state_relation_pspace_relation) - apply (frule (2) cur_tcb_cross) - apply fastforce - apply (clarsimp simp: valid_sched_action_def is_activatable_def vs_all_heap_simps - ct_in_state'_def st_tcb_at'_def) - apply (clarsimp simp: pspace_relation_def) - apply (drule_tac x="cur_thread s" in bspec, fastforce) - apply (drule_tac x="(cur_thread s, other_obj_relation)" in bspec, fastforce) - apply (clarsimp simp: other_obj_relation_def) - apply (rename_tac tcb) - apply (case_tac "tcb_state tcb"; clarsimp simp: tcb_relation_def obj_at_simps cur_tcb'_def) - apply (rename_tac target) - apply (clarsimp simp: valid_sched_action_def weak_valid_sched_action_def vs_all_heap_simps) - apply (prop_tac "scheduler_action s = switch_thread target") - apply (clarsimp simp: state_relation_def) - apply (metis sched_act_relation.simps Structures_A.scheduler_action.exhaust - scheduler_action.simps) - apply (prop_tac "tcb_at' target s'") - apply (fastforce intro!: tcb_at_cross - simp: obj_at_def is_tcb_def) - apply (frule state_relation_pspace_relation) - apply (clarsimp simp: pspace_relation_def) - apply (drule_tac x=target in bspec, fastforce) - apply (drule_tac x="(target, other_obj_relation)" 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) - apply (clarsimp simp: tcb_relation_def obj_at_simps switch_in_cur_domain_def - state_relation_def in_cur_domain_def tcb_in_cur_domain'_def - etcb_at'_def vs_all_heap_simps) - done - -lemma ct_idle_or_in_cur_domain'_cross: - "\(s,s') \ state_relation; ct_in_cur_domain s; cur_tcb s; pspace_aligned s; pspace_distinct s\ - \ ct_idle_or_in_cur_domain' s'" - apply (clarsimp simp: ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def ct_in_cur_domain_def) - apply (case_tac "cur_thread s = idle_thread s"; clarsimp) - apply (clarsimp simp: state_relation_def) - apply (frule curthread_relation) - apply (frule (2) cur_tcb_cross) - apply fastforce - apply (prop_tac "scheduler_action s = resume_cur_thread") - apply (clarsimp simp: state_relation_def) - apply (metis sched_act_relation.simps Structures_A.scheduler_action.exhaust - scheduler_action.simps) - apply (clarsimp simp: in_cur_domain_def etcb_at_def vs_all_heap_simps obj_at_simps cur_tcb'_def) - apply (frule state_relation_pspace_relation) - apply (clarsimp simp: pspace_relation_def) - apply (drule_tac x="cur_thread s" in bspec) - apply (clarsimp simp: cur_tcb_def obj_at_def) - apply (drule_tac x="(cur_thread s, other_obj_relation)" in bspec) - apply (clarsimp simp: cur_tcb_def obj_at_def is_tcb_def) - apply (rename_tac tcb) - apply (case_tac tcb; clarsimp) - apply (clarsimp simp: cur_tcb_def obj_at_def is_tcb_def) - apply (rename_tac tcb) - apply (case_tac tcb; clarsimp) - apply (clarsimp simp: other_obj_relation_def tcb_relation_def state_relation_def) - done - -lemma valid_idle'_cross: - "\(s,s') \ state_relation; valid_idle s; pspace_aligned s; pspace_distinct s; valid_objs s\ - \ valid_idle' s'" - apply (clarsimp simp: valid_idle'_def valid_idle_def pred_tcb_at_def obj_at_def) - apply (prop_tac "ksIdleThread s' = idle_thread s") - apply (clarsimp simp: state_relation_def) - apply clarsimp - apply (prop_tac "tcb_at' (ksIdleThread s') s'") - apply (fastforce intro!: tcb_at_cross simp: obj_at_def state_relation_def is_tcb_def) - apply (prop_tac "sc_at' (idle_sc_ptr) s'") - apply (fastforce intro!: sc_at_cross valid_objs_valid_sched_context_size - simp: obj_at_def state_relation_def is_sc_obj_def) - apply (frule state_relation_pspace_relation) - apply (clarsimp simp: pspace_relation_def) - apply (intro conjI) - apply (drule_tac x="idle_thread s" in bspec, fastforce) - apply (drule_tac x="(idle_thread s, other_obj_relation)" in bspec, fastforce) - apply (clarsimp simp: obj_at_simps idle_tcb'_def tcb_relation_def) - apply (drule_tac x="idle_sc_ptr" in bspec, fastforce) - apply (drule_tac x="(idle_sc_ptr, sc_relation_cut)" in bspec) - apply (fastforce intro: valid_objs_valid_sched_context_size) - by (fastforce dest: sc_replies_prevs_walk - simp: heap_walk_Nil_None obj_at_simps sc_relation_def state_relation_def) - -lemma ksReadyQueues_distinct_cross: - "\(s,s') \ state_relation; valid_ready_qs s\ \ \d p. distinct (ksReadyQueues s' (d, p))" - by (clarsimp simp: valid_ready_qs_def state_relation_def ready_queues_relation_def) - -lemma ready_qs_runnable_cross: - "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; valid_ready_qs s\ - \ ready_qs_runnable s'" - unfolding ready_qs_runnable_def - by (fastforce simp: state_relation_def ready_queues_relation_def - in_ready_q_def st_tcb_at_runnable_cross - dest: valid_ready_qs_in_ready_qD) - -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 (case_tac z; simp) - apply (clarsimp simp: opt_map_def reply_relation_def) - done - -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 (case_tac z; simp) - apply (clarsimp simp: opt_map_def reply_relation_def) - done - -lemma valid_replies_sc_cross: - "\(s, s') \ state_relation; valid_replies s; sym_refs (state_refs_of s); - pspace_aligned s; pspace_distinct s; reply_at rptr s\ - \ valid_replies'_sc_asrt rptr s'" - apply (clarsimp simp: valid_replies_defs valid_replies'_sc_asrt_def elim!: opt_mapE) - apply (rename_tac scptr rp ko) - apply (prop_tac "sc_replies_sc_at (\rs. rptr \ set rs) scptr s") - apply (frule_tac sc_ptr=scptr and reply_ptr=rptr in sym_refs_sc_replies_sc_at) - apply (rule ccontr) - apply (drule not_sk_obj_at_pred) - apply (fastforce simp: sk_obj_at_pred_def obj_at_def is_obj_defs) - apply (frule (1) replySCs_of_cross) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_def) - apply (clarsimp simp: sc_at_pred_n_eq_commute sc_at_ppred_def obj_at_def) - apply (drule subsetD, force) - apply (clarsimp simp: pred_tcb_at_eq_commute[symmetric]) - apply (frule (1) st_tcb_reply_state_refs) - apply (drule (3) st_tcb_at_coerce_concrete) - apply (drule replyTCBs_of_cross[where P="\rtcb. rtcb = (Some tptr)" for tptr]) - apply (fastforce simp: sk_obj_at_pred_def2) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - done - -lemma getCurThread_sp: - "\P\ getCurThread \\rv. P and (\s. rv = ksCurThread s)\" - by (wpsimp simp: getCurThread_def) - -lemma getSchedulerAction_sp: - "\P\ getSchedulerAction \\rv. P and (\s. rv = ksSchedulerAction s)\" - by (wpsimp simp: getSchedulerAction_def) - -lemma getReprogramTimer_sp: - "\P\ getReprogramTimer \\rv. P and (\s. rv = ksReprogramTimer s)\" - by (wpsimp simp: getReprogramTimer_def) - -lemma getIdleThread_sp: - "\P\ getIdleThread \\rv. P and (\s. rv = ksIdleThread s)\" - by wpsimp - -lemma getIdleSC_sp: - "\P\ getIdleSC \\rv. P and (\s. rv = ksIdleSC s)\" - by wpsimp - -lemma getReprogramTimer_wp[wp]: - "\\s. P (ksReprogramTimer s) s\ getReprogramTimer \P\" - by (wpsimp simp: getReprogramTimer_def) - -lemma getConsumedTime_wp[wp]: - "\\s. P (ksConsumedTime s) s\ getConsumedTime \P\" - by (wpsimp simp: getConsumedTime_def) - -lemma isRoundRobin_wp: - "\\s. \ko. ko_at' ko sc s \ P (scPeriod ko = 0) s\ isRoundRobin sc \P\" - by (wpsimp simp: isRoundRobin_def) - -lemma getCurSc_wp[wp]: - "\\s. P (ksCurSc s) s\ getCurSc \P\" - unfolding getCurSc_def - by wpsimp - -lemma getCurTime_wp[wp]: - "\\s. P (ksCurTime s) s\ getCurTime \P\" - unfolding getCurTime_def - by wpsimp - -lemma curDomain_wp[wp]: - "\\s. P (ksCurDomain s) s\ curDomain \P\" - unfolding curDomain_def - by wpsimp - -lemma curDomain_sp: - "\P\ curDomain \\rv. P and (\s. rv = ksCurDomain s)\" - by wpsimp - -lemma getReleaseQueue_wp[wp]: - "\\s. P (ksReleaseQueue s) s\ getReleaseQueue \P\" - unfolding getReleaseQueue_def - by wpsimp - -lemma getObject_sc_wp: - "\\s. sc_at' p s \ (\t::sched_context. ko_at' t p s \ Q t s)\ getObject p \Q\" - by (clarsimp simp: getObject_def valid_def in_monad - split_def objBits_simps' loadObject_default_def - projectKOs obj_at'_def in_magnitude_check - dest!: readObject_misc_ko_at') - -lemma getRefillNext_getSchedContext: - "getRefillNext scPtr index = do sc \ getSchedContext scPtr; - return $ if index = scRefillMax sc - 1 then 0 else index + 1 - od" - apply (clarsimp simp: getRefillNext_def readRefillNext_def readSchedContext_def - getSchedContext_def getObject_def[symmetric]) - done - -lemma getRefillNext_wp: - "\\s. \ko. ko_at' ko scPtr s \ P (if index = scRefillMax ko - Suc 0 then 0 else index + 1) s\ - getRefillNext scPtr index - \P\" - apply (simp add: getRefillNext_getSchedContext) - apply (wpsimp wp: getObject_sc_wp) - done - -lemma getRefillSize_def2: - "getRefillSize scPtr = liftM scRefillCount (gets_the (readSchedContext scPtr))" - apply (clarsimp simp: getRefillSize_def readRefillSize_def liftM_def oliftM_def) - done - -lemma getRefillSize_wp: - "\\s. \ko. ko_at' ko scp s \ P (scRefillCount ko) s\ getRefillSize scp \P\" - apply (clarsimp simp: getRefillSize_def2) - apply (wpsimp wp: simp: readSchedContext_def) - done - -lemma refillEmpty_wp: - "\\s. \ko. ko_at' ko scp s \ P (scRefillCount ko = 0) s\ refillEmpty scp \P\" - unfolding refillEmpty_def - by (wpsimp wp:) - -lemma refillFull_wp: - "\\s. \ko. ko_at' ko scp s \ P (scRefillCount ko = scRefillMax ko) s\ refillFull scp \P\" - unfolding refillFull_def - by (wpsimp wp:) - -lemma no_ofail_readCurTime[simp]: - "no_ofail \ readCurTime" - unfolding readCurTime_def by clarsimp - -lemma ovalid_readCurTime[wp]: - "\\s. P (ksCurTime s) s\ readCurTime \\r s. P r s \ r = ksCurTime s\" - by (simp add: readCurTime_def asks_def obind_def ovalid_def) - -lemma ovalid_readRefillReady[rule_format, simp]: - "ovalid (\s. \ko. ko_at' ko scp s \ P (rTime (refillHd ko) \ ksCurTime s + kernelWCETTicks) s) - (readRefillReady scp) P" - unfolding readRefillReady_def readSchedContext_def ovalid_def - by (fastforce simp: obind_def split: option.split_asm - dest: use_ovalid[OF ovalid_readCurTime] - dest!: readObject_misc_ko_at') - - -lemma refillReady_wp: - "\\s. \ko. ko_at' ko scp s \ P (rTime (refillHd ko) \ ksCurTime s + kernelWCETTicks) s\ refillReady scp \P\" - unfolding refillReady_def - by wpsimp (drule use_ovalid[OF ovalid_readRefillReady]) - -lemma scActive_wp: - "\\s. \ko. ko_at' ko scp s \ P (0 < scRefillMax ko) s\ scActive scp \P\" - unfolding scActive_def - by wpsimp - -lemma getRefills_wp: - "\\s. \ko. ko_at' ko scp s \ P (scRefills ko) s\ - getRefills scp - \P\" - unfolding getRefills_def - by wpsimp - -lemma refillSufficient_wp: - "\\s. \ko. ko_at' ko scp s \ P (minBudget \ refillsCapacity k (scRefills ko) (scRefillHead ko)) s\ refillSufficient scp k \P\" - unfolding refillSufficient_def - apply (wpsimp wp: getRefills_wp) - by (clarsimp simp: sufficientRefills_def obj_at'_def) - -(* projection rewrites *) - -lemma pred_map_rewrite: - "pred_map P proj = opt_pred P proj" - by (fastforce simp: pred_map_def2 opt_pred_def) - -abbreviation sc_of2 :: "Structures_A.kernel_object \ Structures_A.sched_context" where - "sc_of2 ko \ case ko of kernel_object.SchedContext sc n \ Some sc | _ \ None" - -abbreviation scs_of2 :: "'z state \ obj_ref \ Structures_A.sched_context" where - "scs_of2 \ (\s. kheap s |> sc_of2)" - -lemma scs_of_rewrite: - "scs_of s = scs_of2 s" - by (fastforce simp: sc_heap_of_state_def opt_map_def - split: option.splits Structures_A.kernel_object.splits) - -abbreviation - "sc_replies_of2 s \ scs_of2 s ||> sc_replies" - -lemma sc_replies_of_rewrite: - "sc_replies_of s = sc_replies_of2 s" - by (fastforce simp: sc_heap_of_state_def sc_replies_of_scs_def opt_map_def map_project_def - split: option.splits Structures_A.kernel_object.splits) - -definition - sc_replies_relation2_2 :: - "(obj_ref \ obj_ref list) \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ bool" where - "sc_replies_relation2_2 sc_repls scRepl replPrevs \ - \p replies. sc_repls p = Some replies \ heap_ls replPrevs (scRepl p) replies" - -abbreviation sc_replies_relation2 :: "det_state \ kernel_state \ bool" where - "sc_replies_relation2 s s' \ - sc_replies_relation2_2 (sc_replies_of2 s) (scReplies_of s') (replyPrevs_of s')" - -lemmas sc_replies_relation2_def = sc_replies_relation2_2_def - -lemma sc_replies_relation_rewrite: - "sc_replies_relation s s' = sc_replies_relation2 s s'" - unfolding sc_replies_relation_def sc_replies_relation2_def sc_replies_of_rewrite - by simp - -definition is_active_sc2 where - "is_active_sc2 p s \ ((\sc. 0 < sc_refill_max sc) |< scs_of2 s) p" - -lemma is_active_sc_rewrite: - "is_active_sc p s = is_active_sc2 p s" - by (fastforce simp: is_active_sc2_def vs_all_heap_simps is_active_sc_def - active_sc_def opt_map_red opt_map_def opt_pred_def - split: option.split_asm Structures_A.kernel_object.splits) - -abbreviation - "valid_refills2 scp s \ - ((\sc. if sc_period sc = 0 then rr_valid_refills (sc_refills sc) (sc_refill_max sc) (sc_budget sc) - else sp_valid_refills (sc_refills sc) (sc_refill_max sc) (sc_period sc) (sc_budget sc)) |< - scs_of2 s) scp" - -lemmas valid_refills2_def = rr_valid_refills_def sp_valid_refills_def - -lemma valid_refills_rewrite: - "valid_refills scp s = valid_refills2 scp s" - by (fastforce simp: opt_map_red vs_all_heap_simps valid_refills_def opt_pred_def - elim!: opt_mapE - split: option.splits Structures_A.kernel_object.splits) - -definition - round_robin2 :: "obj_ref \ 'z state \ bool" -where - "round_robin2 sc_ptr s \ ((\sc. sc_period sc = 0) |< scs_of2 s) sc_ptr" - -lemma round_robin_rewrite: - "round_robin scp s = round_robin2 scp s" - by (clarsimp simp: round_robin_def round_robin2_def vs_all_heap_simps opt_map_def opt_pred_def - elim!: opt_mapE - split: option.splits Structures_A.kernel_object.splits) - -abbreviation - sc_refills_sc_at2 where - "sc_refills_sc_at2 P scp s \ ((\sc. P (sc_refills sc)) |< scs_of2 s) scp" - -lemma sc_refills_sc_at_rewrite: - "sc_refills_sc_at P scp s = sc_refills_sc_at2 P scp s" - by (fastforce simp: sc_refills_sc_at_def obj_at_def is_sc_obj opt_map_red opt_pred_def - elim!: opt_mapE - split: option.splits Structures_A.kernel_object.split_asm) - -lemmas projection_rewrites = pred_map_rewrite scs_of_rewrite is_active_sc_rewrite - sc_heap_of_state_def sc_refills_sc_at_rewrite - active_sc_at'_rewrite valid_refills_rewrite round_robin_rewrite - -lemma is_active_sc'_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes t: "is_active_sc2 ptr s" - shows "is_active_sc' ptr s'" - using assms - supply projection_rewrites[simp] - apply (clarsimp simp: projectKOs is_active_sc2_def is_active_sc'_def opt_pred_def - split: option.split_asm Structures_A.kernel_object.split_asm elim!: opt_mapE) - apply (drule (1) pspace_relation_absD, clarsimp split: if_split_asm) - by (case_tac z; simp add: sc_relation_def opt_map_red) - -lemma set_refills_is_active_sc2[wp]: - "set_refills ptr new \is_active_sc2 ptr'\" - apply (wpsimp simp: is_active_sc2_def wp: set_refills_wp) - by (clarsimp simp: obj_at_def opt_map_def opt_pred_def) - -(* end : projection rewrites *) - -(* updateSchedContext *) - -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma state_relation_sc_update: - assumes - R1: "\s s'. (s, s') \ state_relation \ - P s \ P' s' \ sc_at ptr s \ sc_at' ptr s' \ - (\n. (((\ko. obj_bits ko = min_sched_context_bits + n) |< kheap s) ptr) \ - sc_relation (the ((scs_of2 s ||> f) ptr)) n (the ((scs_of' s' ||> f') ptr)))" - and R2: "\s s'. (s, s') \ state_relation \ - P s \ P' s' \ sc_at ptr s \ sc_at' ptr s' \ - heap_ls (replyPrevs_of s') (scReply (the ((scs_of' s' ||> f') ptr))) - (sc_replies (the ((scs_of2 s ||> f) ptr)))" - and sz: "\sc'::sched_context. objBits sc' = objBits (f' sc')" - shows - "\(s, s') \ state_relation; P s; P' s'; sc_at ptr s; sc_at' ptr s'\ \ - (kheap_update (\hp p. if p = ptr - then - case hp ptr of - Some (kernel_object.SchedContext sc n) - \ Some (kernel_object.SchedContext (f sc) n) - | _ \ hp ptr - else hp p) s, - (ksPSpace_update (\hp' p. if p = ptr - then case hp' ptr of - Some (KOSchedContext sc') - \ Some (KOSchedContext (f' sc')) - | _ \ hp' ptr - else hp' p)) s') \ state_relation" - supply pred_map_rewrite[simp] scs_of_rewrite[simp] opt_map_red[simp] - sc_replies_of_rewrite[simplified, simp] - proof - - have z': "\s. sc_at' ptr s - \ \sc'::sched_context. map_to_ctes ((\hp' p. if p = ptr then case hp' ptr of - Some (KOSchedContext sc') \ Some (KOSchedContext (f' sc')) - | _ \ hp' ptr else hp' p) (ksPSpace s)) = map_to_ctes (ksPSpace s)" - by (clarsimp simp: obj_at_simps fun_upd_def[symmetric]) - have z: "\s sc'::sched_context. ko_at' sc' ptr s - \ map_to_ctes ((ksPSpace s)(ptr \ KOSchedContext (f' sc'))) = map_to_ctes (ksPSpace s)" - by (clarsimp simp: obj_at_simps) - assume H: "(s, s') \ state_relation" "P s" "P' s'" "sc_at ptr s" "sc_at' ptr s'" - show ?thesis - using H sz - apply - - apply (insert R1[rule_format, OF H] - R2[rule_format, OF H]) - apply (clarsimp simp: state_relation_def) - apply (clarsimp simp: obj_at_def is_sc_obj) - apply (prop_tac "obj_at (same_caps (kernel_object.SchedContext _ n)) ptr s") - apply (clarsimp simp: obj_at_def obj_bits_def) - apply (clarsimp simp: obj_at'_def projectKOs fun_upd_def[symmetric] - z[simplified obj_at'_def projectKO_eq projectKO_opts_defs]) - apply (rename_tac n sc sc') - apply (rule conjI) - (* pspace_relation *) - apply (simp only: pspace_relation_def simp_thms - pspace_dom_update[where x="kernel_object.SchedContext _ _" - and v="kernel_object.SchedContext _ _", - simplified a_type_def, simplified]) - apply (simp only: dom_fun_upd2 simp_thms) - apply (elim conjE) - apply (frule bspec, erule domI) - apply (rule ballI, drule(1) bspec) - apply (drule domD) - apply (clarsimp simp: project_inject opt_pred_def - split: if_split_asm kernel_object.split_asm) - apply (drule_tac x=sc' in spec) - apply (rename_tac bb aa ba) - apply (drule_tac x="(aa, ba)" in bspec, simp) - apply (clarsimp simp: objBits_def) - apply (frule_tac ko'="kernel_object.SchedContext sc n" and x'=ptr in obj_relation_cut_same_type) - apply simp+ - apply (erule obj_relation_cutsE) - apply ((simp split: if_split_asm)+)[8] - (* sc_replies_relation *) - apply (frule (2) sc_replies_relation_prevs_list[simplified]) - apply (subst replyPrevs_of_non_reply_update[simplified]; (simp add: typ_at'_def ko_wp_at'_def)?) - apply (simp add: sc_replies_relation_def) - apply (rule conjI) - (* 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 is_sc_obj - split: Structures_A.kernel_object.splits if_split_asm) - apply (rule conjI) - (* cdt_relation *) - apply (clarsimp simp add: cte_wp_at_cases cdt_relation_def) - (* revokable_relation *) - apply (prop_tac "kheap_update - (\hp x. - if x = ptr - then case hp ptr of None \ hp ptr - | Some (kernel_object.SchedContext sc n) \ - Some (kernel_object.SchedContext (f sc) n) - | Some _ \ hp ptr - else hp x) s - = s\ kheap := (kheap s)(ptr \ kernel_object.SchedContext (f sc) n)\" ) - apply (clarsimp simp: fun_upd_def cong: if_cong) - apply (simp only: fun_upd_def) - apply (simp add: caps_of_state_after_update) - done -qed - -(* update wp rules without ko_at' *) -lemma updateSchedContext_wp: - "\ \s. sc_at' sc_ptr s \ - Q (s\ksPSpace := (ksPSpace s)(sc_ptr \ KOSchedContext (f' (the (scs_of' s sc_ptr))))\) \ - updateSchedContext sc_ptr f' - \ \rv. Q \" - by (wpsimp simp: updateSchedContext_def wp: set_sc'.set_wp) - (clarsimp simp: obj_at'_def projectKOs opt_map_red elim!: rsubst[where P=Q]) - -lemma no_fail_setSchedContext[wp]: - "no_fail (sc_at' ptr and (\s'. ((\k::sched_context. objBits k = objBits new) |< scs_of' s') ptr)) - (setSchedContext ptr new)" - unfolding setSchedContext_def by (wpsimp simp: opt_map_def obj_at'_def projectKOs opt_pred_def) - -lemma no_fail_updateSchedContext[wp]: - "no_fail (sc_at' ptr and (\s'. ((\k::sched_context. objBits k = objBits (f k)) |< scs_of' s') ptr)) - (updateSchedContext ptr f)" - by (wpsimp simp: updateSchedContext_def obj_at'_def projectKOs opt_map_def opt_pred_def) - -lemma update_sched_context_rewrite: - "monadic_rewrite False True (sc_obj_at n scp) - (update_sched_context scp f) - (do sc \ get_sched_context scp; - set_object scp (kernel_object.SchedContext (f sc) n) od)" - apply (clarsimp simp: update_sched_context_def get_sched_context_def bind_assoc) - apply (rule monadic_rewrite_bind_tail) - defer - apply (rule get_object_sp) - apply (case_tac obj; clarsimp simp: monadic_rewrite_pre_imp_eq set_object_def) - apply (rule monadic_rewrite_bind_tail) - defer - apply (rule get_object_sp) - apply (clarsimp simp: monadic_rewrite_def obj_at_def is_sc_obj_def) - done - -lemmas sc_inv_state_eq' = getObject_sc_inv[THEN use_valid[rotated], rotated - , where s=s and P="(=) s" for s, OF _ refl] - -lemma sc_inv_state_eq: - "(a :: sched_context, s') \ fst (getSchedContext p s) \ s' = s" - by (fastforce dest: sc_inv_state_eq' simp: getSchedContext_def) - -lemma getObject_idempotent: - "monadic_rewrite False True (sc_at' ptr) - (do rv \ (getObject ptr :: sched_context kernel); - getObject ptr - od) - (getObject ptr :: sched_context kernel)" - apply (clarsimp simp: monadic_rewrite_def) - apply (rule monad_state_eqI) - apply ((clarsimp simp: in_monad getObject_def split_def - loadObject_default_def projectKOs scBits_pos_power2 objBits_simps' - lookupAround2_known1 in_magnitude_check)+)[2] - apply (fastforce dest!: sc_inv_state_eq[simplified getSchedContext_def] - no_fail_getObject_misc[simplified no_fail_def, rule_format] - simp: snd_bind) - done - -lemma getSchedContext_setSchedContext_decompose: - "monadic_rewrite False True - (sc_at' scPtr and K (\sc. objBits (f sc) = objBits sc) and K (\sc. objBits (g sc) = objBits sc)) - (do sc \ getSchedContext scPtr; - setSchedContext scPtr (g (f sc)) - od) - (do sc \ getSchedContext scPtr; - setSchedContext scPtr (f sc); - sc \ getSchedContext scPtr; - setSchedContext scPtr (g sc) - od)" - apply (clarsimp simp: monadic_rewrite_def) - apply (rule monad_state_eqI) - apply (simp add: in_monad getSchedContext_def getObject_def) - apply (frule no_ofailD[OF no_ofail_sc_at'_readObject]) - apply (clarsimp del: readObject_misc_ko_at' simp del: readObject_misc_obj_at') - apply (clarsimp simp: setSchedContext_def setObject_def obj_at'_def projectKOs objBits_simps' - in_monad scBits_pos_power2 updateObject_default_def - in_magnitude_check ps_clear_upd magnitudeCheck_assert split_def - del: readObject_misc_ko_at' - split: option.split_asm) - apply (rename_tac sc sc') - apply (rule_tac x="f sc" in exI) - apply (rule conjI; - fastforce simp: readObject_def obind_def omonad_defs split_def - ps_clear_upd loadObject_default_def lookupAround2_known1 projectKOs - objBits_simps' scBits_pos_power2 lookupAround2_None2 lookupAround2_char2 - split: option.splits if_split_asm dest!: readObject_misc_ko_at') - apply (rename_tac sc p sc') - apply (rule_tac x="f sc" in exI) - apply (rule conjI) - apply (thin_tac "scSize _ = _") - apply (clarsimp simp: readObject_def obind_def omonad_defs fun_upd_def split_def - ps_clear_upd loadObject_default_def lookupAround2_known1 projectKOs - objBits_simps' scBits_pos_power2 lookupAround2_None2 lookupAround2_char2 - split: option.splits if_split_asm) - apply (metis option.simps(3) word_le_less_eq word_le_not_less) - apply (clarsimp simp: split: option.splits) - apply (metis (no_types) array_rules(2) lookupAround2_char2 mcs(1) order.strict_trans2 - word_le_less_eq word_le_not_less) - apply (simp add: in_monad getSchedContext_def getObject_def) - apply (frule no_ofailD[OF no_ofail_sc_at'_readObject]) - apply (clarsimp del: readObject_misc_ko_at' simp del: readObject_misc_obj_at') - apply (clarsimp simp: setSchedContext_def setObject_def projectKOs in_monad ps_clear_upd obj_at'_def - split_def updateObject_default_def magnitudeCheck_assert - dest!: readObject_misc_ko_at') - - apply (frule no_failD[OF no_fail_getMiscObject(4)]) - apply (simp add: snd_bind) - apply (rule iffI; clarsimp simp: snd_bind split_def setSchedContext_def; rename_tac sc s') - apply (frule sc_inv_state_eq, simp) - apply (rule_tac x="(sc, s)" in bexI[rotated], simp) - apply (rule disjI2) - apply (drule use_valid[OF _ get_sc_ko'], simp) - apply (clarsimp simp: obj_at'_def) - apply (prop_tac "obj_at' (\k. objBits k = objBits (g (f sc))) scPtr s") - apply (clarsimp simp: obj_at'_def) - apply (rule_tac x=sc in exI, clarsimp simp: projectKO_opt_sc) - apply (drule_tac ob1="g (f sc)" in no_failD[OF no_fail_setObject_other, rotated]) - apply simp - apply clarsimp - apply (frule sc_inv_state_eq, simp) - apply (rule_tac x="(sc, s)" in bexI[rotated], simp) - apply (drule use_valid[OF _ get_sc_ko'], simp) - apply (erule disjE; clarsimp) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (prop_tac "obj_at' (\k. objBits k = objBits (f sc)) scPtr s") - apply (clarsimp simp: obj_at'_def projectKOs projectKO_opt_sc) - apply (rule_tac x=sc in exI, clarsimp simp: projectKO_opt_sc) - apply (drule_tac ob1="(f sc)" in no_failD[OF no_fail_setObject_other, rotated]) - apply simp+ - - apply (rename_tac s'; erule disjE; clarsimp?) - apply (drule_tac Q2="\s'. s' = (s\ksPSpace := (ksPSpace s)(scPtr \ injectKO (f sc))\)" - in use_valid[OF _ setObject_sc_wp]) - apply simp+ - - apply (prop_tac "sc_at' scPtr (s\ksPSpace := (ksPSpace s)(scPtr \ KOSchedContext (f sc))\)") - apply (clarsimp simp: obj_at'_def objBits_simps' ps_clear_upd projectKOs) - apply (frule_tac s="s\ksPSpace := (ksPSpace s)(scPtr \ KOSchedContext (f sc))\" - in no_failD[OF no_fail_getMiscObject(4)]) - apply clarsimp - - apply (rename_tac s') - apply (drule_tac Q2="\s'. s' = (s\ksPSpace := (ksPSpace s)(scPtr \ injectKO (f sc))\)" - in use_valid[OF _ setObject_sc_wp]) - apply simp+ - - apply (frule sc_inv_state_eq, simp) - apply (drule use_valid[OF _ get_sc_ko'], simp) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (prop_tac "obj_at' (\k. objBits k = objBits (g (f sc))) scPtr - (s\ksPSpace := (ksPSpace s)(scPtr \ KOSchedContext (f sc))\)") - apply (clarsimp simp: obj_at'_def projectKOs) - apply (rule_tac x="f sc" in exI, clarsimp) - apply (drule_tac ob1="g (f sc)" in no_failD[OF no_fail_setObject_other, rotated]) - apply simp+ - done - -lemmas getSchedContext_setSchedContext_decompose_decompose_ext - = getSchedContext_setSchedContext_decompose[where f="f x" and g="g y" for f g x y] -lemmas getSchedContext_setSchedContext_decompose_decompose2 - = getSchedContext_setSchedContext_decompose[where g="\sc. g (h sc)" for g h] -lemmas getSchedContext_setSchedContext_decompose_decompose_ext2 - = getSchedContext_setSchedContext_decompose[where f="f x" and g="g y" for f g x y] - -(* rewrite rules for updateSchedContext *) -lemma updateSchedContext_decompose: - "monadic_rewrite False True - (sc_at' scPtr and K (\sc. objBits (f sc) = objBits sc) and K (\sc. objBits (g sc) = objBits sc)) - (updateSchedContext scPtr (g o f)) - (do updateSchedContext scPtr f; - updateSchedContext scPtr g - od)" - unfolding updateSchedContext_def bind_assoc o_def - using getSchedContext_setSchedContext_decompose by blast - -lemma updateSchedContext_decompose_fold: - "\\f\ set fs. \sc. objBits (f sc) = objBits sc; \sc. objBits (f sc) = objBits sc\ \ - monadic_rewrite False True - (sc_at' scPtr) - (updateSchedContext scPtr (fold (o) fs f)) - (do _ \ updateSchedContext scPtr f; - mapM_x (updateSchedContext scPtr) fs - od)" - apply (induction fs arbitrary: f) - apply (clarsimp simp: mapM_x_Nil) - apply (rule monadic_rewrite_guard_imp) - apply (rule monadic_rewrite_refl, simp) - apply (clarsimp simp: mapM_x_Cons) - apply (drule_tac x="a o f" in meta_spec) - apply (rule monadic_rewrite_guard_imp) - apply (rule monadic_rewrite_trans) - apply simp - apply (subst bind_assoc[symmetric]) - apply (rule monadic_rewrite_guard_imp) - apply (rule monadic_rewrite_bind_head) - apply (rule updateSchedContext_decompose[simplified]) - apply simp - apply simp + apply (clarsimp simp: bit_simps objBits_simps' word_bits_def + split: kernel_object.splits arch_kernel_object.splits) done -lemmas updateSchedContext_decompose_x2 = updateSchedContext_decompose_fold[where fs="[g, h]" for f g h, - simplified mapM_x_Cons mapM_x_Nil fold_Cons fold_Nil id_def, simplified] - -lemmas updateSchedContext_decompose_x3 = updateSchedContext_decompose_fold[where fs="[g, h, k]" for f g h k, - simplified mapM_x_Cons mapM_x_Nil fold_Cons fold_Nil id_def, simplified] - -lemma updateSchedContext_corres_gen: - assumes - R1: "\s s'. (s, s') \ state_relation \ - P s \ P' s' \ sc_at ptr s \ sc_at' ptr s' \ - (\n. (((\ko. obj_bits ko = min_sched_context_bits + n) |< kheap s) ptr)\ - sc_relation (the ((scs_of2 s ||> f) ptr)) n (the ((scs_of' s' ||> f') ptr)))" - and R2: "\s s'. (s, s') \ state_relation \ - P s \ P' s' \ sc_at ptr s \ sc_at' ptr s' \ - heap_ls (replyPrevs_of s') (scReply (the ((scs_of' s' ||> f') ptr))) - (sc_replies (the ((scs_of2 s ||> f) ptr)))" - and sz: "\sc'::sched_context. objBits sc' = objBits (f' sc')" - shows "corres dc - (sc_at ptr and P) - (sc_at' ptr and P') - (update_sched_context ptr f) - (updateSchedContext ptr f')" - unfolding corres_underlying_def using sz - apply clarsimp - apply (rename_tac s s') - apply (drule obj_at_ko_at) - apply (drule obj_at_ko_at') - apply (clarsimp simp: is_sc_obj) - apply (rename_tac sc' n sc) - apply (rule conjI, clarsimp) - apply (erule use_valid[OF _ updateSchedContext_wp]) - apply clarsimp - apply (rule_tac x="((), s\kheap := (kheap s)(ptr \ - kernel_object.SchedContext (f sc) n)\)" in bexI) - apply clarsimp - apply (drule state_relation_sc_update[OF R1 R2 sz, simplified]) - apply ((fastforce simp: obj_at_def is_sc_obj obj_at'_def projectKOs)+)[4] - apply (clarsimp simp: obj_at_def obj_at'_def projectKOs fun_upd_def[symmetric] opt_map_red) - apply (case_tac s; case_tac s'; fastforce) - apply (clarsimp simp: update_sched_context_def obj_at_def in_monad - get_object_def set_object_def a_type_def) - apply (clarsimp intro!: no_failD[OF no_fail_updateSchedContext] - simp: obj_at'_def projectKOs opt_map_def opt_pred_def) +lemma aligned'_distinct'_ko_wp_at'I: + "\ksPSpace s' x = Some ko; P ko; pspace_aligned' s'; pspace_distinct' s'\ + \ ko_wp_at' P x s'" + apply (simp add: ko_wp_at'_def pspace_distinct'_def pspace_aligned'_def) + apply (drule bspec, erule domI)+ + apply (cases ko; force) done -lemmas updateSchedContext_corres = updateSchedContext_corres_gen[where P=\ and P'=\, simplified] - -(* end : updateSchedContext *) +lemma aligned'_distinct'_ko_at'I: + "\ksPSpace s' x = Some ko; pspace_aligned' s'; pspace_distinct' s'; + ko = injectKO (v:: 'a :: pspace_storable)\ + \ ko_at' v x s'" + by (fastforce elim: aligned'_distinct'_ko_wp_at'I simp: obj_at'_real_def project_inject) +lemmas setEndpoint_valid_globals[wp] + = valid_global_refs_lift' [OF set_ep_ctes_of set_ep_arch' + setEndpoint_it setEndpoint_ksInterruptState] end - -(* this let us cross the sc size information from concrete to abstract *) -lemma ko_at_sc_cross: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes t: "ko_at' (sc'::sched_context) ptr s'" - shows "sc_obj_at (objBits sc' - minSchedContextBits) ptr s" using assms - apply (clarsimp simp: obj_at'_def projectKOs) - 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 pte_relation_def pde_relation_def - scBits_simps sc_relation_def objBits_simps - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm) - -lemma update_sc_no_reply_stack_update_ko_at'_corres: - assumes x: "\sc n. sc_relation sc n sc' \ sc_relation (f sc) n (f' sc')" - assumes y: "\sc. sc_replies sc = sc_replies (f sc)" - assumes z: "objBits sc' = objBits (f' sc')" - assumes r: "scReply sc' = scReply (f' sc')" - shows - "corres dc (sc_at ptr) (ko_at' sc' ptr) - (update_sched_context ptr f) - (setSchedContext ptr (f' sc'))" - unfolding update_sched_context_def - apply (rule corres_guard_imp) - apply (rule corres_symb_exec_l'[where Q'="\r s. ko_at r ptr s \ (\n. is_sc_obj n r)", - where P="\s. obj_at \ ptr s"]) - apply (rule corres_guard_imp[where P'=R and Q'=R for R]) - apply (rule_tac F="(\n. is_sc_obj n obj)" in corres_gen_asm) - apply (case_tac obj; simp add: is_sc_obj_def) - apply (rule setSchedContext_no_stack_update_corres[where f'=f']) - apply (clarsimp simp: x obj_at_def intro!: y z r)+ - apply (fastforce simp: exs_valid_def get_object_def in_monad) - apply (wpsimp wp: get_object_wp) - apply (fastforce simp: obj_at_def) - apply simp - done - -lemma update_sc_no_reply_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 (f' sc') = scReply sc' \ \ - corres dc (sc_at ptr and pspace_aligned and pspace_distinct) \ - (update_sched_context ptr f) - (do sc' <- getSchedContext ptr; - setSchedContext ptr (f' sc') - od)" - apply (rule_tac Q="sc_at' ptr" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD sc_at_cross simp: obj_at'_def) - apply (rule corres_symb_exec_r) - apply (rule corres_guard1_imp) - apply (rule update_sc_no_reply_stack_update_ko_at'_corres; simp) - apply clarsimp - apply (wpsimp wp: get_sched_context_exs_valid simp: is_sc_obj_def obj_at_def) - apply (rename_tac ko; case_tac ko; simp) - apply (wpsimp simp: obj_at_def is_sc_obj_def)+ - done - -lemma ko_at'_inj: - "ko_at' ko ptr s \ ko_at' ko' ptr s \ ko' = ko" - by (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - -(* FIXME RT: Move these to AInvs where possible *) -(* FIXME RT: Try to unify with existing notions. - See https://sel4.atlassian.net/browse/VER-1382 *) -definition injective_ref where - "injective_ref ref heap \ (\q p1 p2. (p1, ref) \ heap q \ (p2, ref) \ heap q \ p1 = p2)" - -lemma sym_refs_inj: - "\sym_refs heap; injective_ref (symreftype ref) heap; (x, ref) \ heap y; (x, ref) \ heap y'\ - \ y = y' " - apply (clarsimp simp: sym_refs_def injective_ref_def) - apply fastforce - done - -lemma sym_refs_inj2: - "\sym_refs heap; injective_ref ref heap; (x, ref) \ heap y; (y, symreftype ref) \ heap z\ - \ x = z " - apply (subgoal_tac "(y, symreftype ref) \ heap x") - apply (erule (3) sym_refs_inj[where ref="symreftype ref", simplified]) - apply (fastforce simp: sym_refs_def) - done - -lemma injective_ref_SCTcb[simp]: - "injective_ref SCTcb (state_refs_of' s) " - apply (clarsimp simp: state_refs_of'_def injective_ref_def split: option.splits if_splits) - apply (clarsimp simp: refs_of'_def) - 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 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) - apply (clarsimp simp: get_refs_def split: option.splits) - done - -lemma reply_at'_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and reply_at t) (reply_at' t)" - unfolding cross_rel_def state_relation_def - apply clarsimp - by (erule (3) reply_at_cross) - -lemma sch_act_simple_cross_rel: - "cross_rel simple_sched_action sch_act_simple" - apply (clarsimp simp: cross_rel_def) - by (fastforce simp: simple_sched_action_def sch_act_simple_def - dest: state_relation_sched_act_relation - split: Structures_A.scheduler_action.splits) - -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 (clarsimp simp: obj_at'_def) - -lemma ex1_ex_eq_all: - "\!x. Q x \ (\x. Q x \ P x) = (\x. Q x \ P x)" - by fastforce - -lemmas tcb_at'_ex_eq_all = ex1_ex_eq_all[OF tcb_at'_ex1_ko_at'] - -lemma receiveBlocked_equiv: - "receiveBlocked st = is_BlockedOnReceive st" - unfolding receiveBlocked_def - by (case_tac st; simp) - -lemma threadGet_getObject: - "threadGet f t = do x <- getObject t; - return (f x) - od" - apply (simp add: threadGet_def threadRead_def oliftM_def getObject_def[symmetric]) - done - -lemma obj_at'_typ_at'[elim!]: - "obj_at' (P :: ('a :: pspace_storable) \ bool) p s \ - obj_at' (\ :: ('a :: pspace_storable) \ bool) p s" - by (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - -lemma shows - obj_at'_sc_tcbs_of_equiv: - "obj_at' (\x. scTCB x = Some t) p s = (sc_at' p s \ scTCBs_of s p = Some t)" - and obj_at'_tcb_scs_of_equiv: - "obj_at' (\x. tcbSchedContext x = Some sc) p s = (tcb_at' p s \ tcbSCs_of s p = Some sc)" - and obj_at'_replySCs_of_equiv: - "obj_at' (\a. replyNext a = Some (Head sc)) p s = (reply_at' p s \ replySCs_of s p = Some sc)" - and obj_at'_scReplies_of_equiv: - "obj_at' (\a. scReply a = Some sc) p s = (sc_at' p s \ scReplies_of s p = Some sc)" - by (intro iffI; clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs opt_map_def)+ - -lemma not_idle_scTCB: - "\sym_heap_tcbSCs s; valid_objs' s; valid_idle' s; p \ idle_sc_ptr; sc_at' p s\ \ - obj_at' (\x. scTCB x \ Some idle_thread_ptr) p s" - apply (subgoal_tac "\obj_at' (\x. scTCB x = Some idle_thread_ptr) p s") - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - apply (subst (asm) sym_heap_symmetric) - apply (clarsimp simp: obj_at'_sc_tcbs_of_equiv sym_heap_def) - apply (clarsimp simp: valid_idle'_def obj_at'_real_def ko_wp_at'_def idle_tcb'_def projectKOs - elim!: opt_mapE) - done - -lemma not_idle_tcbSC: - "\sym_heap_tcbSCs s; valid_objs' s; valid_idle' s; p \ idle_thread_ptr; tcb_at' p s\ \ - obj_at' (\x. tcbSchedContext x \ Some idle_sc_ptr) p s" - apply (subgoal_tac "\obj_at' (\x. tcbSchedContext x = Some idle_sc_ptr) p s") - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - apply (clarsimp simp: obj_at'_tcb_scs_of_equiv sym_heap_def) - apply (clarsimp simp: valid_idle'_def obj_at'_real_def ko_wp_at'_def idle_tcb'_def projectKOs - elim!: opt_mapE) - done - -lemma setObject_tcb_tcbs_of': - "\\s. P' ((tcbs_of' s)(c \ tcb))\ - setObject c (tcb::tcb) - \\_ s. P' (tcbs_of' s)\" - by (setObject_easy_cases, clarsimp simp: ARM_H.fromPPtr_def) - -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)\" - unfolding threadSet_def - apply (rule bind_wp[OF _ get_tcb_sp']) - apply (wpsimp wp: setObject_tcb_tcbs_of') - apply (erule subst[where P=P, rotated], rule ext) - apply (clarsimp simp: opt_map_def obj_at'_real_def ko_wp_at'_def projectKO_tcb - split: option.splits) - done - -lemma aligned'_distinct'_obj_at'I: - "\ \y. ksPSpace s p = Some (injectKO (y:: 'a::pspace_storable)); - pspace_aligned' s; pspace_distinct' s; - (if koTypeOf (the (ksPSpace s p)) = SchedContextT then pspace_bounded' s else True)\ - \ obj_at' (\ :: 'a::pspace_storable \ bool) p s" - apply (clarsimp) - apply (frule_tac v=y in aligned'_distinct'_ko_at'I; simp?) - apply (case_tac "injectKO y"; clarsimp simp: valid_sz_simps dest!: pspace_boundedD') - done - -lemma sym_refs_tcbSCs: - "\sym_refs (state_refs_of' s); pspace_aligned' s; pspace_distinct' s; pspace_bounded' s\ - \ sym_heap_tcbSCs s" - apply (clarsimp simp: sym_heap_def) - apply (rule iffI) - apply (drule_tac tp=SCTcb and x=p and y=p' in sym_refsE; - force simp: get_refs_def2 state_refs_of'_def projectKOs opt_map_red refs_of_rev' - dest: pspace_alignedD' pspace_distinctD' pspace_boundedD' elim!: opt_mapE - split: if_split_asm option.split_asm)+ - by (drule_tac tp=TCBSchedContext and x=p' and y=p in sym_refsE; - force simp: get_refs_def2 state_refs_of'_def projectKOs opt_map_red refs_of_rev' - dest: pspace_alignedD' pspace_distinctD' pspace_boundedD' - elim!: opt_mapE split: if_split_asm option.split_asm)+ - -lemma sym_refs_scReplies: - "\sym_refs (state_refs_of' s); pspace_aligned' s; pspace_distinct' s; pspace_bounded' s\ - \ sym_heap_scReplies s" - apply (clarsimp simp: sym_heap_def) - apply (rule iffI) - apply (drule_tac tp=ReplySchedContext and x=p and y=p' in sym_refsE; - force simp: get_refs_def2 state_refs_of'_def projectKOs opt_map_red refs_of_rev' - dest: pspace_alignedD' pspace_distinctD' pspace_boundedD' - elim!: opt_mapE - split: if_split_asm option.split_asm)+ - by (drule_tac tp=SCReply and x=p' and y=p in sym_refsE; - force simp: get_refs_def2 state_refs_of'_def projectKOs opt_map_red refs_of_rev' - dest: pspace_alignedD' pspace_distinctD' pspace_boundedD' - elim!: opt_mapE - split: if_split_asm option.split_asm)+ - -lemma setSchedContext_scTCBs_of: - "\\s. P (\a. if a = scPtr then scTCB sc else scTCBs_of s a)\ - setSchedContext scPtr sc - \\_ s. P (scTCBs_of s)\" - unfolding setSchedContext_def - apply (wpsimp wp: setObject_sc_wp) - apply (erule back_subst[where P=P], rule ext) - by (clarsimp simp: opt_map_def) - -lemma setSchedContext_scReplies_of: - "\\s. P (\a. if a = scPtr then scReply sc else scReplies_of s a)\ - setSchedContext scPtr sc - \\_ s. P (scReplies_of s)\" - unfolding setSchedContext_def - apply (wpsimp wp: setObject_sc_wp) - apply (erule back_subst[where P=P], rule ext) - by (clarsimp simp: opt_map_def) - -lemma getObject_tcb_wp: - "\\s. tcb_at' p s \ (\t::tcb. ko_at' t p s \ Q t s)\ getObject p \Q\" - by (clarsimp simp: getObject_def valid_def in_monad - split_def objBits_simps' loadObject_default_def - projectKOs obj_at'_def in_magnitude_check - dest!: readObject_misc_ko_at') - - -lemma threadSet_tcbSCs_of: - "\\s. P (\a. if a = t then tcbSchedContext (f (the (tcbs_of' s a))) else tcbSCs_of s a)\ - threadSet f t - \\_ s. P (tcbSCs_of s)\" - unfolding threadSet_def - apply (wpsimp wp: setObject_tcb_wp getObject_tcb_wp) - apply (clarsimp simp: tcb_at'_ex_eq_all) - apply (erule back_subst[where P=P], rule ext) - apply (clarsimp simp: opt_map_def obj_at'_real_def ko_wp_at'_def projectKOs) - done - -lemma shows - replyNexts_Some_replySCs_None: - "replyNexts_of s rp \ None \ replySCs_of s rp = None" and - replySCs_Some_replyNexts_None: - "replySCs_of s rp \ None \ replyNexts_of s rp = None" - by (clarsimp simp: opt_map_def projectKOs split: option.splits reply_next.splits)+ - -lemma sym_heap_remove_only: - "\ sym_heap h1 h2; h2 y = Some x \ \ - sym_heap (\a. if a = x then None else h1 a) (\a. if a = y then None else h2 a)" - supply opt_mapE [rule del] - apply (clarsimp simp: sym_heap_def) - apply (subst (asm) sym_heap_symmetric[simplified sym_heap_def], simp) - done - -lemma pred_tcb_at'_equiv: - "pred_tcb_at' p P t s = (tcb_at' t s \ P (p (tcb_to_itcb' (the (tcbs_of' s t)))))" - by (rule iffI; - clarsimp simp: pred_tcb_at'_def pred_map_def obj_at'_real_def ko_wp_at'_def projectKOs - opt_map_def) - -lemma isBlockedOnSend_equiv: - "isBlockedOnSend st = is_BlockedOnSend st" - by (case_tac st; simp add: isBlockedOnSend_def) - -lemma isSend_equiv: - "isSend st = is_BlockedOnSend st" - by (case_tac st; simp add: isSend_def) - -lemma sch_act_wf_not_runnable_sch_act_not: - "\st_tcb_at' P t s; sch_act_wf (ksSchedulerAction s) s; \st. P st \ \ runnable' st\ \ - sch_act_not t s" - by (clarsimp simp: pred_tcb_at'_def obj_at'_def) - -lemma isTimeoutFault_fault_map[simp]: - "isTimeoutFault (fault_map a) = is_timeout_fault a" - by (clarsimp simp: isTimeoutFault_def fault_map_def is_timeout_fault_def - split: ExceptionTypes_A.fault.splits) - -lemma valid_bound_obj_lift: - "f \P (the x)\ \ f \valid_bound_obj P x\" - unfolding valid_bound_obj_def - by (case_tac x; wpsimp) - -lemma valid_bound_obj'_lift: - "f \P (the x)\ \ f \valid_bound_obj' P x\" - unfolding valid_bound_obj'_def - by (case_tac x; wpsimp) - -lemma ep_at'_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and ep_at t) (ep_at' t)" - unfolding cross_rel_def state_relation_def - apply clarsimp - by (erule (3) ep_at_cross) - -lemma sch_act_not_cross_rel: - "cross_rel (scheduler_act_not t) (sch_act_not t)" - unfolding cross_rel_def state_relation_def - apply clarsimp - apply (case_tac "scheduler_action s"; simp) - by (clarsimp simp: scheduler_act_not_def sched_act_relation_def) - -global_interpretation set_simple_ko: typ_at_pres "set_simple_ko C ptr ep" - unfolding typ_at_pres_def by wpsimp - -global_interpretation update_sk_obj_ref: typ_at_pres "update_sk_obj_ref C update ref new" - unfolding typ_at_pres_def by wpsimp - -lemma getReprogramTimer_corres: - "corres (=) \ \ (gets reprogram_timer) getReprogramTimer" - by (clarsimp simp: getReprogramTimer_def state_relation_def) - -lemma setDomainTime_corres: - "dt = dt' \ - corres dc \ \ (modify (domain_time_update (\_. dt))) (setDomainTime dt')" - apply (clarsimp simp: setDomainTime_def, rule corres_modify) - by (clarsimp simp: state_relation_def swp_def) - -lemma setConsumedTime_corres: - "ct = ct' \ - corres dc \ \ (modify (consumed_time_update (\_. ct))) (setConsumedTime ct')" - apply (clarsimp simp: setConsumedTime_def, rule corres_modify) - by (clarsimp simp: state_relation_def swp_def) - -lemma setCurSc_corres: - "sc = sc' \ - corres dc \ \ (modify (cur_sc_update (\_. sc))) (setCurSc sc')" - apply (clarsimp simp: setCurSc_def, rule corres_modify) - by (clarsimp simp: state_relation_def swp_def) - -lemma refillSingle_equiv: - "sc_valid_refills' sc \ - (length (refills_map (scRefillHead sc) (scRefillCount sc) (scRefillMax sc) (scRefills sc)) = Suc 0) - = (scRefillHead sc = refillTailIndex sc)" - apply (clarsimp simp: valid_sched_context'_def refillTailIndex_def refills_map_def) - apply (case_tac "scRefillCount sc = Suc 0"; simp) - apply (auto simp: Let_def) - done - -lemma refillSingle_corres: - "scp = scp' \ - corres (=) (sc_at scp) (obj_at' sc_valid_refills' scp') - (refill_single scp) - (refillSingle scp')" - unfolding refill_single_def refillSingle_def - apply (simp add: refill_size_def get_refills_def) - apply (rule stronger_corres_guard_imp) - apply (rule_tac R'="\sc s. sc_valid_refills' sc" and R="\_ _ . True" in corres_split) - apply (rule get_sc_corres) - apply simp - apply (metis (mono_tags, opaque_lifting) refillSingle_equiv sc_relation_def) - apply wpsimp+ - apply (clarsimp simp: obj_at'_def) - done - -lemma active_sc_at'_cross: - "\(s,s') \ state_relation; pspace_aligned s; pspace_distinct s; is_active_sc sc_ptr s; - sc_at sc_ptr s\ - \ active_sc_at' sc_ptr s'" - apply (frule state_relation_pspace_relation) - apply (frule (3) sc_at_cross) - apply (clarsimp simp: pspace_relation_def obj_at_def is_sc_obj_def) - apply (drule_tac x=sc_ptr in bspec, blast) - apply (clarsimp simp: sc_relation_def vs_all_heap_simps active_sc_at'_def obj_at'_def projectKOs - active_sc_def) - done - -lemma is_active_sc'2_cross: - "\(s,s') \ state_relation; pspace_aligned s; pspace_distinct s; is_active_sc sc_ptr s; - sc_at sc_ptr s\ - \ is_active_sc' sc_ptr s'" - apply (frule state_relation_pspace_relation) - apply (frule (3) sc_at_cross) - apply (clarsimp simp: pspace_relation_def obj_at_def is_sc_obj_def) - apply (drule_tac x=sc_ptr in bspec, blast) - apply (clarsimp simp: sc_relation_def vs_all_heap_simps obj_at'_def projectKOs - active_sc_def opt_map_red StateRelation.is_active_sc'_def opt_pred_def) - done - -lemma release_q_runnable_cross: - "\(s,s') \ state_relation; valid_release_q s; pspace_aligned s; pspace_distinct s\ \ - \p. p \ set (ksReleaseQueue s') \ obj_at' (runnable' \ tcbState) p s'" - apply (frule state_relation_release_queue_relation) - apply (clarsimp simp: valid_release_q_def obj_at'_def release_queue_relation_def) - apply (drule_tac x=p in bspec, blast) - apply (clarsimp simp: vs_all_heap_simps) - apply (frule_tac t=p in st_tcb_at_coerce_concrete[rotated, where P=runnable], simp, simp) - apply (clarsimp simp: pred_tcb_at_def obj_at_def) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def sts_rel_runnable) - done - - -\ \Some methods to add invariants to the concrete guard of a corres proof. Often used for properties - that are asserted to hold in the Haskell definition.\ - -method add_sym_refs = - rule_tac Q="\s'. sym_refs (state_refs_of' s')" in corres_cross_add_guard, - (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 - -method add_ct_not_inQ = - rule_tac Q="\s'. ct_not_inQ s'" in corres_cross_add_guard, - fastforce intro!: ct_not_inQ_cross simp: valid_sched_def - -method add_sch_act_wf = - rule_tac Q="\s'. sch_act_wf (ksSchedulerAction s') s'" in corres_cross_add_guard, - fastforce intro!: sch_act_wf_cross simp: valid_sched_def - -method add_ct_idle_or_in_cur_domain' = - rule_tac Q="\s'. ct_idle_or_in_cur_domain' s'" in corres_cross_add_guard, - fastforce intro!: ct_idle_or_in_cur_domain'_cross simp: valid_sched_def - -method add_valid_idle' = - rule_tac Q="\s'. valid_idle' s'" in corres_cross_add_guard, - fastforce intro!: valid_idle'_cross - -method add_ready_qs_runnable = - rule_tac Q=ready_qs_runnable in corres_cross_add_guard, - (clarsimp simp: pred_conj_def)?, - (frule valid_sched_valid_ready_qs)?, (frule invs_psp_aligned)?, (frule invs_distinct)?, - fastforce dest: ready_qs_runnable_cross - -method add_release_q_runnable = - rule_tac Q="\s'. \p. p \ set (ksReleaseQueue s') \ obj_at' (runnable' \ tcbState) p s'" - in corres_cross_add_guard, - (simp only: pred_conj_def)?, - (frule valid_sched_valid_release_q)?, (frule invs_psp_aligned)?, (frule invs_distinct)?, - fastforce dest: release_q_runnable_cross - -method add_valid_replies for rptr uses simp = - rule_tac Q="\s. valid_replies'_sc_asrt rptr s" in corres_cross_add_guard, - fastforce elim: valid_replies_sc_cross simp: simp - end diff --git a/proof/refine/ARM/KernelInit_R.thy b/proof/refine/ARM/KernelInit_R.thy index 9e5909072e..59d308fa31 100644 --- a/proof/refine/ARM/KernelInit_R.thy +++ b/proof/refine/ARM/KernelInit_R.thy @@ -40,8 +40,6 @@ axiomatization where axiomatization where ckernel_init_domain_list: - "((tc,s),x) \ Init_H - \ length (ksDomSchedule s) > 0 - \ (\(d,time) \ set (ksDomSchedule s). us_to_ticks (time * \s_in_ms) > 0)" + "((tc,s),x) \ Init_H \ length (ksDomSchedule s) > 0 \ (\(d,time) \ set (ksDomSchedule s). time > 0)" end diff --git a/proof/refine/ARM/LevityCatch.thy b/proof/refine/ARM/LevityCatch.thy index 72c64a908d..de9fd7637e 100644 --- a/proof/refine/ARM/LevityCatch.thy +++ b/proof/refine/ARM/LevityCatch.thy @@ -14,33 +14,29 @@ begin (* Try again, clagged from Include *) no_notation bind_drop (infixl ">>" 60) -lemma read_magnitudeCheck_assert: - "read_magnitudeCheck x y n = oassert (case y of None \ True | Some z \ 1 << n \ z - x)" - by (fastforce simp: read_magnitudeCheck_def split: option.split) - lemma magnitudeCheck_assert: "magnitudeCheck x y n = assert (case y of None \ True | Some z \ 1 << n \ z - x)" - by (simp add: magnitudeCheck_def read_magnitudeCheck_assert) - -context begin interpretation Arch . (*FIXME: arch_split*) + apply (simp add: magnitudeCheck_def assert_def when_def + split: option.split) + apply fastforce + done +context begin interpretation Arch . (*FIXME: arch-split*) lemmas makeObject_simps = makeObject_endpoint makeObject_notification makeObject_cte makeObject_tcb makeObject_user_data makeObject_pde makeObject_pte makeObject_asidpool end -lemma projectKO_inv : "\P\ gets_the $ projectKO ko \\rv. P\" - by wpsimp +lemma projectKO_inv : "\P\ projectKO ko \\rv. P\" + by (simp add: projectKO_def fail_def valid_def return_def + split: option.splits) (****** From GeneralLib *******) -lemma read_alignCheck_assert: - "read_alignCheck ptr n = oassert (is_aligned ptr n)" - by (simp add: is_aligned_mask read_alignCheck_def read_alignError_def ounless_def) - lemma alignCheck_assert: "alignCheck ptr n = assert (is_aligned ptr n)" - by (simp add: read_alignCheck_assert alignCheck_def) + by (simp add: is_aligned_mask alignCheck_def assert_def + alignError_def unless_def when_def) lemma magnitudeCheck_inv: "\P\ magnitudeCheck x y n \\rv. P\" apply (clarsimp simp add: magnitudeCheck_def split: option.splits) @@ -59,7 +55,7 @@ lemma updateObject_default_inv: "\P\ updateObject_default obj ko x y n \\rv. P\" unfolding updateObject_default_def by (simp, wp magnitudeCheck_inv alignCheck_inv projectKO_inv, simp) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma to_from_apiType [simp]: "toAPIType (fromAPIType x) = Some x" by (cases x) (auto simp add: fromAPIType_def ARM_H.fromAPIType_def toAPIType_def ARM_H.toAPIType_def) diff --git a/proof/refine/ARM/Machine_R.thy b/proof/refine/ARM/Machine_R.thy index 5fbb392db2..76ffc6375b 100644 --- a/proof/refine/ARM/Machine_R.thy +++ b/proof/refine/ARM/Machine_R.thy @@ -22,32 +22,7 @@ lemma irq_state_independent_HI[intro!, simp]: \ irq_state_independent_H P" by (simp add: irq_state_independent_H_def) -definition "getCurrentTime_independent_H (P :: kernel_state \ bool) - \ \f s. P s \ - P (s\ksMachineState := - ksMachineState s\last_machine_time := - f (last_machine_time (ksMachineState s)) (time_state (ksMachineState s))\\)" - -lemma getCurrentTime_independent_HI[intro!, simp]: - "\\s f. - P (s\ksMachineState - := (ksMachineState s)\last_machine_time := - f (last_machine_time (ksMachineState s)) (time_state (ksMachineState s))\\) - = P s\ - \ getCurrentTime_independent_H P" - by (simp add: getCurrentTime_independent_H_def) - -definition "time_state_independent_H (P :: kernel_state \ bool) - \ \f s. P s \ - P (s\ksMachineState := ksMachineState s\time_state := f (time_state (ksMachineState s))\\)" - -lemma time_state_independent_HI[intro!, simp]: - "\\s f. P (s\ksMachineState := ksMachineState s\time_state := f (time_state (ksMachineState s))\\) - = P s\ - \ time_state_independent_H P" - by (simp add: time_state_independent_H_def) - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma dmo_getirq_inv[wp]: "irq_state_independent_H P \ \P\ doMachineOp (getActiveIRQ in_kernel) \\rv. P\" @@ -79,7 +54,7 @@ lemma dmo_maskInterrupt: lemma dmo_maskInterrupt_True: "\invs'\ doMachineOp (maskInterrupt True irq) \\_. invs'\" apply (wp dmo_maskInterrupt) - apply (clarsimp simp: invs'_def valid_dom_schedule'_def) + apply (clarsimp simp: invs'_def valid_state'_def) apply (simp add: valid_irq_masks'_def valid_machine_state'_def ct_not_inQ_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) done diff --git a/proof/refine/ARM/PageTableDuplicates.thy b/proof/refine/ARM/PageTableDuplicates.thy index 5162dd9fc6..46975c1950 100644 --- a/proof/refine/ARM/PageTableDuplicates.thy +++ b/proof/refine/ARM/PageTableDuplicates.thy @@ -1,5 +1,4 @@ (* - * Copyright 2022, Proofcraft Pty Ltd * Copyright 2014, General Dynamics C4 Systems * * SPDX-License-Identifier: GPL-2.0-only @@ -9,7 +8,7 @@ theory PageTableDuplicates imports Syscall_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma set_ep_valid_duplicate' [wp]: "\\s. vs_valid_duplicates' (ksPSpace s)\ @@ -20,10 +19,9 @@ lemma set_ep_valid_duplicate' [wp]: objBits_def[symmetric] lookupAround2_char1 split: if_split_asm) apply (frule pspace_storable_class.updateObject_type[where v = v,simplified]) - apply (clarsimp simp: updateObject_default_def assert_def bind_def when_def - alignError_def magnitudeCheck_def read_magnitudeCheck_def - assert_opt_def return_def fail_def - split: if_splits option.splits) + apply (clarsimp simp:updateObject_default_def assert_def bind_def + alignCheck_def in_monad when_def alignError_def magnitudeCheck_def + assert_opt_def return_def fail_def split:if_splits option.splits) apply (rule_tac ko = ba in valid_duplicates'_non_pd_pt_I) apply simp+ apply (rule_tac ko = ba in valid_duplicates'_non_pd_pt_I) @@ -39,10 +37,9 @@ lemma set_ntfn_valid_duplicate' [wp]: objBits_def[symmetric] lookupAround2_char1 split: if_split_asm) apply (frule pspace_storable_class.updateObject_type[where v = v,simplified]) - apply (clarsimp simp: updateObject_default_def assert_def bind_def when_def - alignError_def magnitudeCheck_def read_magnitudeCheck_def - assert_opt_def return_def fail_def - split: if_splits option.splits) + apply (clarsimp simp:updateObject_default_def assert_def bind_def + alignCheck_def in_monad when_def alignError_def magnitudeCheck_def + assert_opt_def return_def fail_def split:if_splits option.splits) apply (rule_tac ko = ba in valid_duplicates'_non_pd_pt_I) apply simp+ apply (rule_tac ko = ba in valid_duplicates'_non_pd_pt_I) @@ -65,7 +62,7 @@ lemma setCTE_valid_duplicates'[wp]: apply (erule valid_duplicates'_non_pd_pt_I[rotated 3],simp+)+ done -crunch cteInsert +crunch cteInsert, setupReplyMaster for valid_duplicates'[wp]: "(\s. vs_valid_duplicates' (ksPSpace s))" (wp: crunch_wps simp: crunch_simps) @@ -75,7 +72,7 @@ lemma doMachineOp_ksPSpace_inv[wp]: crunch threadSet, setBoundNotification, setExtraBadge for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (wp: updateObject_default_inv) + (wp: setObject_ksInterrupt updateObject_default_inv) lemma transferCapsToSlots_duplicates'[wp]: "\\s. vs_valid_duplicates' (ksPSpace s)\ @@ -83,39 +80,11 @@ lemma transferCapsToSlots_duplicates'[wp]: \\rv s. vs_valid_duplicates' (ksPSpace s)\" by (rule transferCapsToSlots_pres1; wp) -lemma setObjectSC_valid_duplicates'[wp]: - "setObject a (sc::sched_context) \\s. vs_valid_duplicates' (ksPSpace s)\" - apply (clarsimp simp: setObject_def split_def valid_def in_monad - projectKOs pspace_aligned'_def ps_clear_upd - objBits_def[symmetric] lookupAround2_char1 - split: if_split_asm) - apply (frule pspace_storable_class.updateObject_type[where v = sc,simplified]) - apply (clarsimp simp: updateObject_default_def assert_def bind_def - alignCheck_def in_monad when_def alignError_def magnitudeCheck_def - assert_opt_def return_def fail_def typeError_def - split: if_splits option.splits Structures_H.kernel_object.splits) - apply (erule valid_duplicates'_non_pd_pt_I[rotated 3],simp+)+ - done - -lemma setObjectReply_valid_duplicates'[wp]: - "setObject a (r::reply) \\s. vs_valid_duplicates' (ksPSpace s)\" - apply (clarsimp simp: setObject_def split_def valid_def in_monad - projectKOs pspace_aligned'_def ps_clear_upd - objBits_def[symmetric] lookupAround2_char1 - split: if_split_asm) - apply (frule pspace_storable_class.updateObject_type[where v = r,simplified]) - apply (clarsimp simp: updateObject_default_def assert_def bind_def - alignCheck_def in_monad when_def alignError_def magnitudeCheck_def - assert_opt_def return_def fail_def typeError_def - split: if_splits option.splits Structures_H.kernel_object.splits) - apply (erule valid_duplicates'_non_pd_pt_I[rotated 3],simp+)+ - done - crunch transferCaps, sendFaultIPC, handleFault, replyFromKernel, insertNewCap for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" (ignore: transferCapsToSlots - wp: crunch_wps hoare_vcg_const_Ball_lift hoare_vcg_all_lift get_rs_cte_at' whileM_inv - simp: zipWithM_x_mapM ball_conj_distrib crunch_simps) + wp: crunch_wps hoare_vcg_const_Ball_lift get_rs_cte_at' + simp: zipWithM_x_mapM ball_conj_distrib) lemma koTypeOf_pte: "koTypeOf ko = ArchT PTET \ \pte. ko = KOArch (KOPTE pte)" @@ -138,16 +107,15 @@ lemma mapM_x_storePTE_updates: apply (thin_tac "valid P f Q" for P f Q) apply (simp add: storePTE_def setObject_def) apply (wp | simp add:split_def updateObject_default_def)+ - apply (clarsimp cong: if_cong) + apply clarsimp apply (intro conjI ballI) apply (drule(1) bspec) - apply (clarsimp simp: typ_at'_def ko_wp_at'_def objBits_defs - dest!: koTypeOf_pte - split: kernel_object.split_asm) + apply (clarsimp simp:typ_at'_def ko_wp_at'_def + objBits_simps archObjSize_def dest!:koTypeOf_pte + split: Structures_H.kernel_object.split_asm) apply (simp add:ps_clear_def dom_fun_upd2[unfolded fun_upd_def]) - apply (simp add: lookupAround2_known1) apply (erule rsubst[where P=Q]) - apply (rule ext, clarsimp) + apply fastforce done lemma is_aligned_plus_bound: @@ -377,7 +345,7 @@ lemma mapM_x_storePTE_update_helper: apply (drule pspace_alignedD') apply simp apply (simp add:objBits_simps' archObjSize_def pteBits_def - is_aligned_weaken[where y = 2] pageBits_def pdeBits_def vs_ptr_align_def + is_aligned_weaken[where y = 2] pageBits_def pdeBits_def split:kernel_object.splits arch_kernel_object.splits) apply (simp add:mask_lower_twice) apply (drule mask_out_first_mask_some[where m = ptBits]) @@ -435,15 +403,15 @@ lemma mapM_x_storePDE_updates: apply (thin_tac "valid P f Q" for P f Q) apply (simp add: storePDE_def setObject_def) apply (wp | simp add:split_def updateObject_default_def)+ - apply (clarsimp cong: if_cong) + apply clarsimp apply (intro conjI ballI) apply (drule(1) bspec) apply (clarsimp simp:typ_at'_def ko_wp_at'_def objBits_simps archObjSize_def dest!:koTypeOf_pde split: Structures_H.kernel_object.split_asm arch_kernel_object.split_asm if_split) - apply (simp add:ps_clear_def dom_fun_upd2[unfolded fun_upd_def])+ + apply (simp add:ps_clear_def dom_fun_upd2[unfolded fun_upd_def]) apply (erule rsubst[where P=Q]) - apply (rule ext, clarsimp) + apply fastforce done lemma mapM_x_storePDE_update_helper: @@ -489,7 +457,7 @@ lemma mapM_x_storePDE_update_helper: apply (drule pspace_alignedD') apply simp apply (simp add:objBits_simps' archObjSize_def pteBits_def - is_aligned_weaken[where y = 2] pageBits_def pdeBits_def vs_ptr_align_def + is_aligned_weaken[where y = 2] pageBits_def pdeBits_def split:kernel_object.splits arch_kernel_object.splits) apply (simp add:mask_lower_twice) apply (drule mask_out_first_mask_some[where m = pdBits]) @@ -593,7 +561,9 @@ lemma globalPDEWindow_neg_mask: done lemma copyGlobalMappings_ksPSpace_stable: - notes blah[simp del] = atLeastAtMost_simps + notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + atLeastAtMost_iff assumes ptr_al: "is_aligned ptr pdBits" shows "\\s. ksPSpace s x = ko \ pspace_distinct' s \ pspace_aligned' s \ @@ -608,10 +578,12 @@ lemma copyGlobalMappings_ksPSpace_stable: apply (rule ccontr) apply clarsimp apply (drule(1) pspace_alignedD') - apply (drule is_aligned_weaken[where y = 2]; simp?) - by (clarsimp simp: archObjSize_def pageBits_def pteBits_def pdeBits_def objBits_simps' - minSchedContextBits_def - split: arch_kernel_object.split kernel_object.splits) + apply (drule is_aligned_weaken[where y = 2]) + apply (case_tac y, simp_all add: objBits_simps' pageBits_def) + apply (simp add: archObjSize_def pageBits_def + pteBits_def pdeBits_def + split: arch_kernel_object.splits) + done have ptr_eqD: "\p a b. \p + a = ptr + b;is_aligned p pdBits; a < 2^ pdBits; b < 2^pdBits \ @@ -725,13 +697,12 @@ lemma copyGlobalMappings_ksPSpace_stable: | simp add: storePDE_def setObject_def split_def updateObject_default_def split: option.splits)+ - apply (clarsimp simp: objBits_simps archObjSize_def obj_at'_def scBits_simps - projectKO_def projectKO_opt_pde fail_def return_def oassert_opt_def) - apply (intro conjI impI) - apply (clarsimp simp: obj_at'_def objBits_simps scBits_simps - projectKO_def projectKO_opt_pde fail_def return_def pde.exhaust - split: Structures_H.kernel_object.splits arch_kernel_object.splits) - apply (drule_tac x = xa in bspec) + apply (clarsimp simp:objBits_simps archObjSize_def) + apply (clarsimp simp:obj_at'_def objBits_simps + projectKO_def projectKO_opt_pde fail_def return_def + split: Structures_H.kernel_object.splits + arch_kernel_object.splits) + apply (drule_tac x = xa in bspec) apply simp apply (rule ccontr) apply (simp add: pdeBits_def) @@ -748,11 +719,7 @@ lemma copyGlobalMappings_ksPSpace_stable: apply (drule postfix_listD) apply (clarsimp simp:pdBits_def pdeBits_def le_less_trans) apply (simp add:pdBits_def pageBits_def pdeBits_def) - apply (clarsimp simp: obj_at'_def objBits_simps scBits_simps - projectKO_def projectKO_opt_pde fail_def return_def - split: Structures_H.kernel_object.splits arch_kernel_object.splits) - apply (drule_tac x = xa in bspec) - apply (clarsimp simp:pdBits_def pdeBits_def le_less_trans)+ + apply simp apply wp apply (clarsimp simp:objBits_simps archObjSize_def pdeBits_def) apply (rule hoare_name_pre_state) @@ -772,6 +739,10 @@ lemma copyGlobalMappings_ksPSpace_stable: qed lemma copyGlobalMappings_ksPSpace_same: + notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + atLeastAtMost_iff + shows "\is_aligned ptr pdBits\ \ \\s. ksPSpace s x = ko \ pspace_distinct' s \ pspace_aligned' s \ is_aligned (armKSGlobalPD (ksArchState s)) pdBits \ ptr = armKSGlobalPD (ksArchState s)\ @@ -790,7 +761,7 @@ lemma copyGlobalMappings_ksPSpace_same: updateObject_default_def split: option.splits)+ apply (clarsimp simp:objBits_simps archObjSize_def) - apply (clarsimp simp:obj_at'_def objBits_simps oassert_opt_def + apply (clarsimp simp:obj_at'_def objBits_simps projectKO_def projectKO_opt_pde fail_def return_def split: Structures_H.kernel_object.splits arch_kernel_object.splits) @@ -802,7 +773,9 @@ lemmas copyGlobalMappings_ksPSpaceD = use_valid[OF _ copyGlobalMappings_ksPSpace lemmas copyGlobalMappings_ksPSpace_sameD = use_valid[OF _ copyGlobalMappings_ksPSpace_same] lemma copyGlobalMappings_ksPSpace_concrete: - notes blah[simp del] = atLeastAtMost_simps + notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + atLeastAtMost_iff assumes monad: "(r, s') \ fst (copyGlobalMappings ptr s)" and ps: "pspace_distinct' s" "pspace_aligned' s" and al: "is_aligned (armKSGlobalPD (ksArchState s)) pdBits" @@ -862,7 +835,7 @@ lemma copyGlobalMappings_ksPSpace_concrete: apply (frule_tac d1 = "0x3FFF" and p1="ptr" in is_aligned_add_helper[THEN conjunct2]) apply (simp add: pdeBits_def) apply (frule_tac d1 = "pptrBase >> 20 << 2" and p1 = "ptr" - in is_aligned_add_helper[THEN conjunct2]) + in is_aligned_add_helper[THEN conjunct2]) apply (simp add: pptrBase_def pdeBits_def) apply (simp add: pdeBits_def) apply (cut_tac copyGlobalMappings_ksPSpace_sameD) @@ -875,7 +848,9 @@ qed lemma copyGlobalMappings_valid_duplicates': - notes blah[simp del] = atLeastAtMost_simps + notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + atLeastAtMost_iff shows "\(\s. vs_valid_duplicates' (ksPSpace s)) and pspace_distinct' and pspace_aligned' and (\s. is_aligned (armKSGlobalPD (ksArchState s)) pdBits) @@ -1058,13 +1033,12 @@ lemma valid_duplicates'_update: lemma createObject_valid_duplicates'[wp]: "\(\s. vs_valid_duplicates' (ksPSpace s)) and pspace_aligned' and pspace_distinct' - and pspace_no_overlap' ptr (getObjectSize ty us) and pspace_bounded' + and pspace_no_overlap' ptr (getObjectSize ty us) and (\s. is_aligned (armKSGlobalPD (ksArchState s)) pdBits) and K (is_aligned ptr (getObjectSize ty us)) and K (ty = APIObjectType apiobject_type.CapTableObject \ us < 28)\ RetypeDecls_H.createObject ty ptr us d \\xa s. vs_valid_duplicates' (ksPSpace s)\" - supply if_cong[cong] apply (rule hoare_gen_asm) apply (simp add:createObject_def) apply (rule hoare_pre) @@ -1136,17 +1110,12 @@ lemma createObject_valid_duplicates'[wp]: ,simplified objBits_simps]) apply simp apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def pageBits_def) - apply (frule(3) retype_aligned_distinct'[where n = 4096 and ko = "KOArch (KOPDE makeObject)"]) - apply (simp add:objBits_simps archObjSize_def) - apply (rule range_cover_rel[OF range_cover_full]) - apply simp - apply (simp add:APIType_capBits_def word_bits_def pdeBits_def)+ - apply (frule(3) retype_aligned_distinct'(2)[where n = 4096 and ko = "KOArch (KOPDE makeObject)"]) + apply (frule(2) retype_aligned_distinct'[where n = 4096 and ko = "KOArch (KOPDE makeObject)"]) apply (simp add:objBits_simps archObjSize_def) apply (rule range_cover_rel[OF range_cover_full]) apply simp apply (simp add:APIType_capBits_def word_bits_def pdeBits_def)+ - apply (frule(3) retype_aligned_distinct'(3)[where n = 4096 and ko = "KOArch (KOPDE makeObject)"]) + apply (frule(2) retype_aligned_distinct'(2)[where n = 4096 and ko = "KOArch (KOPDE makeObject)"]) apply (simp add:objBits_simps archObjSize_def) apply (rule range_cover_rel[OF range_cover_full]) apply simp @@ -1164,29 +1133,38 @@ lemma createObject_valid_duplicates'[wp]: apply (rule none_in_new_cap_addrs[where us =12,simplified] ,(simp add: objBits_simps pageBits_def word_bits_conv archObjSize_def pdeBits_def)+)[1] apply (intro conjI impI allI) - apply simp - apply (fastforce elim!: valid_duplicates'_update simp: vs_entry_align_def)+ - apply (clarsimp simp:ARM_H.toAPIType_def word_bits_def - split:ARM_H.object_type.splits) - apply (cut_tac ptr = ptr in new_cap_addrs_fold'[where n = "2^us" - and ko = "(KOCTE makeObject)",simplified]) - apply (rule word_1_le_power) - apply (clarsimp simp: word_bits_def) - apply (drule_tac ptr = ptr and ko = "KOCTE makeObject" in - valid_duplicates'_insert_ko[where us = us,simplified]) - apply (simp add: APIType_capBits_def is_aligned_mask toAPIType_def - split: ARM_H.object_type.splits) - apply (simp add: vs_entry_align_def) - apply (simp add: objBits_simps') - apply (rule none_in_new_cap_addrs - ,(simp add: objBits_simps' pageBits_def APIType_capBits_def - ARM_H.toAPIType_def - word_bits_conv archObjSize_def is_aligned_mask - split: ARM_H.object_type.splits)+)[1] - apply (clarsimp simp: word_bits_def) - apply (fastforce elim!: valid_duplicates'_update - simp: vs_entry_align_def)+ - done + apply simp + apply clarsimp + apply (drule(2) valid_duplicates'_update) prefer 3 + apply fastforce + apply (simp add: vs_entry_align_def) + apply simp + apply clarsimp + apply (drule(2) valid_duplicates'_update) prefer 3 + apply (fastforce simp: vs_entry_align_def)+ + apply clarsimp + apply (drule(2) valid_duplicates'_update) prefer 3 + apply (fastforce simp: vs_entry_align_def)+ + apply (clarsimp simp:ARM_H.toAPIType_def word_bits_def + split:ARM_H.object_type.splits) + apply (cut_tac ptr = ptr in new_cap_addrs_fold'[where n = "2^us" + and ko = "(KOCTE makeObject)",simplified]) + apply (rule word_1_le_power) + apply (clarsimp simp: word_bits_def) + apply (drule_tac ptr = ptr and ko = "KOCTE makeObject" in + valid_duplicates'_insert_ko[where us = us,simplified]) + apply (simp add: APIType_capBits_def is_aligned_mask ARM_H.toAPIType_def + split: ARM_H.object_type.splits) + apply (simp add: vs_entry_align_def) + apply (simp add: objBits_simps') + apply (rule none_in_new_cap_addrs + ,(simp add: objBits_simps' pageBits_def APIType_capBits_def + ARM_H.toAPIType_def + word_bits_conv archObjSize_def is_aligned_mask + split: ARM_H.object_type.splits)+)[1] + apply (clarsimp simp: word_bits_def) + done + crunch createNewObjects for arch_inv[wp]: "\s. P (armKSGlobalPD (ksArchState s))" @@ -1194,13 +1172,11 @@ crunch createNewObjects lemma createNewObjects_valid_duplicates'[wp]: - "\(\s. vs_valid_duplicates' (ksPSpace s)) and pspace_no_overlap' ptr sz and pspace_aligned' - and pspace_distinct' and pspace_bounded' and (\s. is_aligned (armKSGlobalPD (ksArchState s)) pdBits) - and K (range_cover ptr sz (Types_H.getObjectSize ty us) (length dest)) - and K (ptr \ 0) - and K (ty = APIObjectType ArchTypes_H.apiobject_type.CapTableObject \ us < 28) - and K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ sc_size_bounds us)\ - createNewObjects ty src dest ptr us d + "\ (\s. vs_valid_duplicates' (ksPSpace s)) and pspace_no_overlap' ptr sz + and pspace_aligned' and pspace_distinct' and (\s. is_aligned (armKSGlobalPD (ksArchState s)) pdBits) + and K (range_cover ptr sz (Types_H.getObjectSize ty us) (length dest) \ + ptr \ 0 \ (ty = APIObjectType ArchTypes_H.apiobject_type.CapTableObject \ us < 28) ) \ + createNewObjects ty src dest ptr us d \\reply s. vs_valid_duplicates' (ksPSpace s)\" proof (induct rule:rev_induct ) case Nil @@ -1209,24 +1185,24 @@ lemma createNewObjects_valid_duplicates'[wp]: next case (snoc dest dests) show ?case - apply (rule hoare_gen_asm)+ + apply (rule hoare_gen_asm) apply clarsimp apply (frule range_cover.weak) apply (subst createNewObjects_Cons) apply (simp add: word_bits_def) apply wp apply (wp snoc.hyps) - (* first bundling up "pspace_xxx" conjuncts together to apply - createNewObjects_pspace_no_overlap' in an appropriate way *) - apply (subst conj_assoc[symmetric]) - apply (subst conj_assoc[symmetric]) - apply (subst conj_assoc[symmetric]) apply (rule hoare_vcg_conj_lift) apply (rule hoare_post_imp[OF _ createNewObjects_pspace_no_overlap'[where sz = sz]]) apply clarsimp + apply (rule hoare_vcg_conj_lift) + apply (rule hoare_post_imp[OF _ createNewObjects_pspace_no_overlap'[where sz = sz]]) + apply clarsimp + apply (rule hoare_vcg_conj_lift) + apply (rule hoare_post_imp[OF _ createNewObjects_pspace_no_overlap'[where sz = sz]]) apply (rule pspace_no_overlap'_le) - apply fastforce - apply (simp add: range_cover.sz[where 'a=32, folded word_bits_def])+ + apply fastforce + apply (simp add: range_cover.sz[where 'a=32, folded word_bits_def])+ apply wp apply clarsimp apply (frule range_cover.aligned) @@ -1276,64 +1252,68 @@ lemma valid_duplicates_deleteObjects_helper: assumes inc: "\p ko. \m p = Some (KOArch ko);p \ {ptr .. ptr + 2 ^ sz - 1}\ \ 6 \ sz" assumes aligned:"is_aligned ptr sz" - notes blah[simp del] = atLeastAtMost_simps + notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + atLeastAtMost_iff shows "vs_valid_duplicates' (\x. if x \ {ptr .. ptr + 2 ^ sz - 1} then None else m x)" apply (rule valid_duplicates'_diffI,rule vd) - apply (clarsimp simp: vs_valid_duplicates'_def split:option.splits) + apply (clarsimp simp: vs_valid_duplicates'_def split:option.splits) apply (clarsimp simp: vs_valid_duplicates'_def split:option.splits) apply (case_tac "the (m x)",simp_all add:vs_ptr_align_def) - apply fastforce+ + apply fastforce+ apply (rename_tac arch_kernel_object) apply (case_tac arch_kernel_object) - apply fastforce+ - apply (clarsimp split:ARM_H.pte.splits) - apply auto[1] - apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) - apply (simp add:vs_ptr_align_def)+ - apply clarsimp - apply (drule(1) inc) - apply (drule(1) mask_out_first_mask_some) - apply (simp add:mask_lower_twice) - apply (simp add: mask_in_range[OF aligned,symmetric]) - apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) - apply simp - apply (simp add:vs_ptr_align_def) - apply simp + apply fastforce+ + apply (clarsimp split:ARM_H.pte.splits) + apply auto[1] apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) - apply simp - apply (simp add:vs_ptr_align_def) - apply simp - apply (clarsimp split:ARM_H.pde.splits) - apply auto[1] - apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) - apply simp - apply (simp add:vs_ptr_align_def) - apply (drule(1) inc) - apply (drule(1) mask_out_first_mask_some) + apply (simp add:vs_ptr_align_def)+ + apply clarsimp + apply (drule(1) inc) + apply (drule(1) mask_out_first_mask_some) apply (simp add:mask_lower_twice) - apply (simp add: mask_in_range[OF aligned,symmetric]) - apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) - apply simp - apply (simp add:vs_ptr_align_def) + apply (simp add: mask_in_range[OF aligned,symmetric]) + apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) + apply simp + apply (simp add:vs_ptr_align_def) + apply simp + apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) apply simp + apply (simp add:vs_ptr_align_def) + apply simp + apply (clarsimp split:ARM_H.pde.splits) + apply auto[1] apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) apply simp apply (simp add:vs_ptr_align_def) + apply (drule(1) inc) + apply (drule(1) mask_out_first_mask_some) + apply (simp add:mask_lower_twice) + apply (simp add: mask_in_range[OF aligned,symmetric]) + apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) + apply simp + apply (simp add:vs_ptr_align_def) + apply simp + apply (drule_tac p' = y in valid_duplicates'_D[OF vd]) apply simp - apply fastforce+ + apply (simp add:vs_ptr_align_def) + apply simp done lemma deleteObjects_valid_duplicates'[wp]: - notes [simp del] = atLeastAtMost_simps + notes blah[simp del] = atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + atLeastAtMost_iff shows - "\(\s. vs_valid_duplicates' (ksPSpace s)) and K (is_aligned ptr sz)\ - deleteObjects ptr sz - \\_ s. vs_valid_duplicates' (ksPSpace s)\" + "\(\s. vs_valid_duplicates' (ksPSpace s)) and + K (is_aligned ptr sz) + \ deleteObjects ptr sz + \\r s. vs_valid_duplicates' (ksPSpace s)\" apply (rule hoare_gen_asm) - apply (clarsimp simp: deleteObjects_def2) - apply (intro bind_wp[OF _ stateAssert_sp]) - apply (wpsimp wp: hoare_drop_imps) - apply (clarsimp simp: deletionIsSafe_def) + apply (clarsimp simp:deleteObjects_def2) + apply (wp hoare_drop_imps|simp)+ + apply clarsimp + apply (simp add:deletionIsSafe_def) apply (erule valid_duplicates_deleteObjects_helper) apply fastforce apply simp @@ -1349,32 +1329,20 @@ crunch resetUntypedCap crunch updateFreeIndex for valid_duplicates[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" -lemma untypedCap_is_aligned: - "\valid_objs' s; cte_wp_at' (isUntypedCap \ cteCap) slot s; cte_wp_at' ((=) cap \ cteCap) slot s\ - \ is_aligned (capPtr cap) (capBlockSize cap)" - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (frule cte_wp_at_valid_objs_valid_cap'[OF ctes_of_cte_wpD], clarsimp+) - apply (clarsimp simp: valid_cap_simps' capAligned_def isCap_simps) - done - lemma resetUntypedCap_valid_duplicates'[wp]: "\(\s. vs_valid_duplicates' (ksPSpace s)) and valid_objs' and cte_wp_at' (isUntypedCap o cteCap) slot\ - resetUntypedCap slot - \\_ s. vs_valid_duplicates' (ksPSpace s)\" + resetUntypedCap slot + \\r s. vs_valid_duplicates' (ksPSpace s)\" (is "\?P\ ?f \\_. ?Q\") apply (clarsimp simp: resetUntypedCap_def) - apply (rule validE_valid) - apply (rule_tac Q'="\cap. ?P and cte_wp_at' ((=) cap \ cteCap) slot" in bindE_wp_fwd) - apply wpsimp - apply (simp only: unlessE_def) - apply (clarsimp; safe; (solves wpsimp)?) - apply wpsimp - apply (fastforce elim: untypedCap_is_aligned) - apply wpsimp - apply (fastforce elim: untypedCap_is_aligned) - apply (wpsimp wp: mapME_x_inv_wp preemptionPoint_inv) - apply (fastforce elim: untypedCap_is_aligned) + apply (rule hoare_pre) + apply (wp | simp add: unless_def)+ + apply (wp mapME_x_inv_wp preemptionPoint_inv | simp | wp (once) hoare_drop_imps)+ + apply (wp getSlotCap_wp) + apply (clarsimp simp: cte_wp_at_ctes_of split del: if_split) + apply (frule cte_wp_at_valid_objs_valid_cap'[OF ctes_of_cte_wpD], clarsimp+) + apply (clarsimp simp add: isCap_simps valid_cap_simps' capAligned_def) done lemma is_aligned_armKSGlobalPD: @@ -1394,8 +1362,8 @@ lemma invokeUntyped_valid_duplicates[wp]: notes whenE_wps[wp_split del] shows "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and valid_untyped_inv' ui and ct_active'\ - invokeUntyped ui - \\_ s. vs_valid_duplicates' (ksPSpace s) \" + invokeUntyped ui + \\rv s. vs_valid_duplicates' (ksPSpace s) \" apply (simp only: invokeUntyped_def updateCap_def) apply (rule hoare_name_pre_state) apply (cases ui) @@ -1450,7 +1418,8 @@ crunch lemma get_asid_valid_duplicates'[wp]: "\\s. vs_valid_duplicates' (ksPSpace s)\ getObject param_b \\(pool::asidpool) s. vs_valid_duplicates' (ksPSpace s)\" - apply (simp add:getObject_def | wp)+ + apply (simp add:getObject_def split_def| wp)+ + apply (simp add:loadObject_default_def|wp)+ done lemma set_asid_pool_valid_duplicates'[wp]: @@ -1471,8 +1440,8 @@ lemma set_asid_pool_valid_duplicates'[wp]: crunch suspend - for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (wp: crunch_wps gts_wp' simp: crunch_simps unless_def o_def) + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (wp: crunch_wps simp: crunch_simps unless_def o_def) crunch deletingIRQHandler @@ -1508,7 +1477,7 @@ lemma storePDE_no_duplicates': Structures_H.kernel_object.splits ARM_H.pde.splits ARM_H.pte.splits) apply (clarsimp split:option.splits) - apply (drule_tac p = x in valid_duplicates'_D) + apply (drule_tac p = x and p' = y in valid_duplicates'_D) apply simp+ done @@ -1541,7 +1510,7 @@ lemma storePTE_no_duplicates': Structures_H.kernel_object.splits ARM_H.pde.splits ARM_H.pte.splits) apply (clarsimp split:option.splits) - apply (drule_tac p = x in valid_duplicates'_D) + apply (drule_tac p = x and p' = y in valid_duplicates'_D) apply simp+ done @@ -1557,7 +1526,7 @@ lemma checkMappingPPtr_SmallPage: apply (wp unlessE_wp getPTE_wp |wpc|simp add:)+ apply (clarsimp simp:ko_wp_at'_def obj_at'_def) apply (clarsimp simp:projectKO_def projectKO_opt_pte - return_def fail_def vs_entry_align_def oassert_opt_def + return_def fail_def vs_entry_align_def split:kernel_object.splits arch_kernel_object.splits option.splits) done @@ -1569,7 +1538,7 @@ lemma checkMappingPPtr_Section: apply (wp unlessE_wp getPDE_wp |wpc|simp add:)+ apply (clarsimp simp:ko_wp_at'_def obj_at'_def) apply (clarsimp simp:projectKO_def projectKO_opt_pde - return_def fail_def vs_entry_align_def oassert_opt_def + return_def fail_def vs_entry_align_def split:kernel_object.splits arch_kernel_object.splits option.splits) done @@ -1591,14 +1560,14 @@ crunch (wp: crunch_wps simp: crunch_simps unless_def) lemma lookupPTSlot_aligned: - "\\s. valid_objs' s \ vmsz_aligned vptr sz \ sz \ ARMSuperSection\ + "\\s. valid_objs' s \ vmsz_aligned' vptr sz \ sz \ ARMSuperSection\ lookupPTSlot pd vptr \\rv s. is_aligned rv ((pageBitsForSize sz) - 10)\,-" apply (simp add:lookupPTSlot_def) apply (wp|wpc|simp)+ apply (wp getPDE_wp) - apply (clarsimp simp:obj_at'_def vmsz_aligned_def) - apply (clarsimp simp:projectKO_def fail_def oassert_opt_def + apply (clarsimp simp:obj_at'_def vmsz_aligned'_def) + apply (clarsimp simp:projectKO_def fail_def projectKO_opt_pde return_def lookup_pt_slot_no_fail_def split:option.splits Structures_H.kernel_object.splits arch_kernel_object.splits) @@ -1628,7 +1597,7 @@ crunch lemma unmapPage_valid_duplicates'[wp]: notes checkMappingPPtr_inv[wp del] shows "\pspace_aligned' and valid_objs' and (\s. vs_valid_duplicates' (ksPSpace s)) - and K (vmsz_aligned vptr vmpage_size)\ + and K (vmsz_aligned' vptr vmpage_size)\ unmapPage vmpage_size asiv vptr word \\r s. vs_valid_duplicates' (ksPSpace s)\" apply (simp add:unmapPage_def) (* make sure checkMappingPPtr_SmallPage is first tried before checkMappingPPtr_inv *) @@ -1661,10 +1630,10 @@ lemma unmapPage_valid_duplicates'[wp]: apply (clarsimp simp:conj_comms) apply (rule hoare_strengthen_postE_R[where Q'= "\r. pspace_aligned' and (\s. vs_valid_duplicates' (ksPSpace s)) and - K(vmsz_aligned vptr vmpage_size \ is_aligned r pdBits) + K(vmsz_aligned' vptr vmpage_size \ is_aligned r pdBits) and page_directory_at' (lookup_pd_slot r vptr && ~~ mask pdBits)"]) apply (wp findPDForASID_page_directory_at' | simp)+ - apply (clarsimp simp add:pdBits_def pageBits_def vmsz_aligned_def) + apply (clarsimp simp add:pdBits_def pageBits_def vmsz_aligned'_def) apply (drule is_aligned_lookup_pd_slot) apply (erule is_aligned_weaken,simp) apply simp @@ -1708,9 +1677,7 @@ crunch for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" (wp: crunch_wps simp: crunch_simps unless_def) -crunch deleteASIDPool, unbindNotification, prepareThreadDelete, unbindFromSC, - schedContextUnbindAllTCBs, schedContextSetInactive, schedContextUnbindYieldFrom, - schedContextUnbindReply +crunch deleteASIDPool, unbindNotification, prepareThreadDelete for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" (wp: crunch_wps simp: crunch_simps unless_def) @@ -1728,10 +1695,8 @@ lemma finaliseCap_valid_duplicates'[wp]: "\valid_objs' and pspace_aligned' and (\s. vs_valid_duplicates' (ksPSpace s)) and (valid_cap' cap)\ finaliseCap cap call final \\r s. vs_valid_duplicates' (ksPSpace s)\" - apply (cases cap; simp add: isCap_simps finaliseCap_def) - apply (wpsimp wp: crunch_wps hoare_vcg_all_lift - simp: crunch_simps split: option.splits - | rule conjI)+ + apply (case_tac cap,simp_all add:isCap_simps finaliseCap_def) + apply (wp|intro conjI|clarsimp split: option.splits)+ done crunch @@ -1799,15 +1764,15 @@ lemma cteRevoke_valid_duplicates'[wp]: \ sch_act_simple s \" apply (rule cteRevoke_preservation) apply (wp cteDelete_invs' cteDelete_valid_duplicates' cteDelete_sch_act_simple) - apply (fastforce simp: cteDelete_def sch_act_simple_def)+ + apply (simp add:cteDelete_def)+ done lemma mapM_x_storePTE_invalid_whole: "\\s. vs_valid_duplicates' (ksPSpace s) \ - s \' capability.ArchObjectCap (arch_capability.PageTableCap word option) \ - pspace_aligned' s\ - mapM_x (swp storePTE InvalidPTE) [word , word + 2 ^ pteBits .e. word + 2 ^ ptBits - 1] - \\y s. vs_valid_duplicates' (ksPSpace s)\" + s \' capability.ArchObjectCap (arch_capability.PageTableCap word option) \ + pspace_aligned' s\ + mapM_x (swp storePTE InvalidPTE) [word , word + 2 ^ pteBits .e. word + 2 ^ ptBits - 1] + \\_ s. vs_valid_duplicates' (ksPSpace s)\" apply (wp mapM_x_storePTE_update_helper[where word = word and sz = ptBits and ptr = word]) apply (clarsimp simp: valid_cap'_def capAligned_def pageBits_def ptBits_def objBits_simps archObjSize_def pteBits_def) @@ -1826,18 +1791,25 @@ crunch crunch isFinalCapability - for valid_cap'[wp]: "\s. valid_cap' cap s" + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (wp: crunch_wps filterM_preserved simp: crunch_simps unless_def) + +crunch + isFinalCapability + for valid_cap'[wp]: "\s. valid_cap' cap s" (wp: crunch_wps filterM_preserved simp: crunch_simps unless_def) crunch sendSignal - for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (wp: crunch_wps simp: crunch_simps) + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" lemma invokeIRQControl_valid_duplicates'[wp]: "\\s. vs_valid_duplicates' (ksPSpace s) \ performIRQControl a - \\_ s. vs_valid_duplicates' (ksPSpace s)\" - unfolding performIRQControl_def by (wpsimp simp: ARM_H.performIRQControl_def) + \\_ s. vs_valid_duplicates' (ksPSpace s)\" + apply (simp add:performIRQControl_def ) + apply (rule hoare_pre) + apply (wp|wpc | simp add:ARM_H.performIRQControl_def)+ + done crunch InterruptDecls_H.invokeIRQHandler for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" @@ -1856,8 +1828,14 @@ lemma invokeCNode_valid_duplicates'[wp]: apply (rule hoare_pre) apply (wp unless_wp | wpc | simp)+ apply (simp add:invokeCNode_def) + apply (wp getSlotCap_inv hoare_drop_imp + |simp add:locateSlot_conv getThreadCallerSlot_def + |wpc)+ apply (simp add:cteDelete_def invokeCNode_def) - apply (wp getSlotCap_inv hoare_drop_imp | simp add:locateSlot_conv whenE_def split_def | wpc)+ + apply (wp getSlotCap_inv hoare_drop_imp + |simp add:locateSlot_conv getThreadCallerSlot_def + whenE_def split_def + |wpc)+ apply (rule valid_validE) apply (rule hoare_post_imp[OF _ finaliseSlot_valid_duplicates']) apply simp @@ -1945,7 +1923,8 @@ lemma performPageInvocation_valid_duplicates'[wp]: done lemma placeASIDPool_valid_duplicates'[wp]: - notes blah[simp del] = atLeastAtMost_simps + notes blah[simp del] = atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex shows "\\s. vs_valid_duplicates' (ksPSpace s) \ pspace_no_overlap' ptr pageBits s \ is_aligned ptr pageBits \ pspace_aligned' s\ placeNewObject' ptr (KOArch (KOASIDPool makeObject)) 0 @@ -2009,7 +1988,7 @@ lemma performArchInvocation_valid_duplicates': apply fastforce apply (rule hoare_name_pre_state) apply (clarsimp simp: valid_arch_inv'_def isCap_simps valid_pti'_def - cte_wp_at_ctes_of is_arch_update'_def isPageTableCap_def + cte_wp_at_ctes_of is_arch_update'_def isPageTableCap_def split: arch_capability.splits) apply (clarsimp simp: performPageTableInvocation_def) apply (wp storePDE_no_duplicates' | simp)+ @@ -2043,7 +2022,7 @@ lemma performArchInvocation_valid_duplicates': descendants_range'_def2 empty_descendants_range_in') apply (intro conjI; clarsimp) apply (drule(1) cte_cap_in_untyped_range, fastforce simp:cte_wp_at_ctes_of, simp_all)[1] - apply (clarsimp simp: invs'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) + apply (clarsimp simp: invs'_def valid_state'_def if_unsafe_then_cap'_def cte_wp_at_ctes_of) apply clarsimp apply (rename_tac asidpool_invocation) apply (case_tac asidpool_invocation) @@ -2053,56 +2032,59 @@ lemma performArchInvocation_valid_duplicates': crunch restart for valid_duplicates'[wp]: "(\s. vs_valid_duplicates' (ksPSpace s))" - (wp: crunch_wps simp: crunch_simps) + (wp: crunch_wps) crunch setPriority, setMCPriority for valid_duplicates'[wp]: "(\s. vs_valid_duplicates' (ksPSpace s))" (ignore: threadSet - wp: setObject_ksInterrupt updateObject_default_inv crunch_wps + wp: setObject_ksInterrupt updateObject_default_inv simp: crunch_simps) -crunch installTCBCap, installThreadBuffer - for valid_duplicates'[wp]: "(\s. vs_valid_duplicates' (ksPSpace s))" - (wp: crunch_wps checkCap_inv - simp: crunch_simps getThreadVSpaceRoot_def getThreadFaultHandlerSlot_def - getThreadTimeoutHandlerSlot_def - ignore: checkCapAt) - -lemma tc_caps_valid_duplicates': - "\invs' and sch_act_simple and (\s. vs_valid_duplicates' (ksPSpace s)) and - tcb_at' t and ex_nonz_cap_to' t and - case_option \ (valid_cap' o fst) croot and - K (case_option True (isCNodeCap o fst) croot) and - case_option \ (valid_cap' o fst) vroot and - K (case_option True (isValidVTableRoot o fst) vroot) and - case_option \ (valid_cap' o fst) fault_h and - K (case_option True (isValidFaultHandler o fst) fault_h) and - case_option \ (valid_cap' o fst) timeout_h and - K (case_option True (isValidFaultHandler o fst) timeout_h) and - case_option \ (valid_cap') (case_option None (case_option None (Some o fst) o snd) ipcb) and - K (case_option True isArchObjectCap (case_option None (case_option None (Some o fst) o snd) ipcb)) - and K (case_option True (swp is_aligned msg_align_bits o fst) ipcb)\ - invokeTCB (ThreadControlCaps t sl fault_h timeout_h croot vroot ipcb) +lemma tc_valid_duplicates': + "\invs' and sch_act_simple and (\s. vs_valid_duplicates' (ksPSpace s)) and tcb_at' a and ex_nonz_cap_to' a and + case_option \ (valid_cap' o fst) e' and + K (case_option True (isCNodeCap o fst) e') and + case_option \ (valid_cap' o fst) f' and + K (case_option True (isValidVTableRoot o fst) f') and + case_option \ (valid_cap') (case_option None (case_option None (Some o fst) o snd) g) and + K (valid_option_prio d) and + K (valid_option_prio mcp) and + K (case_option True isArchObjectCap (case_option None (case_option None (Some o fst) o snd) g)) + and K (case_option True (swp is_aligned msg_align_bits o fst) g)\ + invokeTCB (tcbinvocation.ThreadControl a sl b' mcp d e' f' g) \\rv s. vs_valid_duplicates' (ksPSpace s)\" - apply (simp add: invokeTCB_def) - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_const_imp_lift - installTCBCap_invs' installTCBCap_sch_act_simple) - apply (fastforce simp: isValidFaultHandler_def isCap_simps isValidVTableRoot_def) - done - -crunch schedContextBindTCB - for valid_duplicates'[wp]: "(\s. vs_valid_duplicates' (ksPSpace s))" - (wp: crunch_wps simp: crunch_simps) - -lemma tc_sched_valid_duplicates': - "\invs' and sch_act_simple and (\s. vs_valid_duplicates' (ksPSpace s)) and - tcb_at' t and ex_nonz_cap_to' t and - case_option \ (valid_cap' o fst) sc_fh and - K (valid_option_prio pri) and - K (valid_option_prio mcp)\ - invokeTCB (ThreadControlSched t sl sc_fh pri mcp sc_opt) - \\rv s. vs_valid_duplicates' (ksPSpace s)\" - by (wpsimp simp: mapTCBPtr_def stateAssertE_def invokeTCB_def wp: hoare_drop_imps) + apply (rule hoare_gen_asm) + apply (simp add: split_def invokeTCB_def getThreadCSpaceRoot getThreadVSpaceRoot + getThreadBufferSlot_def locateSlot_conv + cong: option.case_cong) + apply (simp only: eq_commute[where a="a"]) + apply (rule hoare_walk_assmsE) + apply (clarsimp simp: pred_conj_def option.splits [where P="\x. x s" for s]) + apply ((wp case_option_wp threadSet_invs_trivial hoare_weak_lift_imp + hoare_vcg_all_lift threadSet_cap_to' | clarsimp simp: inQ_def)+)[2] + apply (rule hoare_walk_assmsE) + apply (clarsimp simp: pred_conj_def option.splits [where P="\x. x s" for s]) + apply ((wp case_option_wp threadSet_invs_trivial hoare_weak_lift_imp setMCPriority_invs' + typ_at_lifts[OF setMCPriority_typ_at'] + hoare_vcg_all_lift threadSet_cap_to' | clarsimp simp: inQ_def)+)[2] + apply ((simp only: simp_thms cases_simp cong: conj_cong + | (wp cteDelete_deletes cteDelete_invs' cteDelete_sch_act_simple + threadSet_ipcbuffer_trivial + (* setPriority has no effect on vs_duplicates *) + case_option_wp[where m'="return ()", OF setPriority_valid_duplicates' return_inv,simplified] + checkCap_inv[where P="tcb_at' t" for t] + checkCap_inv[where P="valid_cap' c" for c] + checkCap_inv[where P="\s. P (ksReadyQueues s)" for P] + checkCap_inv[where P="\s. vs_valid_duplicates' (ksPSpace s)"] + checkCap_inv[where P=sch_act_simple] cteDelete_valid_duplicates' hoare_vcg_const_imp_liftE_R + typ_at_lifts[OF setPriority_typ_at'] assertDerived_wp threadSet_cte_wp_at' + hoare_vcg_all_liftE_R hoare_vcg_all_lift hoare_weak_lift_imp)[1] + | wpc + | simp add: inQ_def + | wp hoare_vcg_conj_liftE1 cteDelete_invs' cteDelete_deletes hoare_vcg_const_imp_lift)+) + apply (clarsimp simp: tcb_cte_cases_def cte_level_bits_def objBits_defs + tcbIPCBufferSlot_def) + by (auto dest!: isCapDs isReplyCapD isValidVTableRootD simp: isCap_simps) crunch performTransfer, unbindNotification, bindNotification, setDomain for valid_duplicates'[wp]: "(\s. vs_valid_duplicates' (ksPSpace s))" @@ -2114,65 +2096,74 @@ lemma invokeTCB_valid_duplicates'[wp]: "\invs' and sch_act_simple and ct_in_state' runnable' and tcb_inv_wf' ti and (\s. vs_valid_duplicates' (ksPSpace s))\ invokeTCB ti \\rv s. vs_valid_duplicates' (ksPSpace s)\" - apply (case_tac ti; simp only:) - apply (simp add: invokeTCB_def) - apply wp - apply (clarsimp simp: invs'_def - dest!: global'_no_ex_cap) - apply (simp add: invokeTCB_def) - apply wp - apply (clarsimp simp: invs'_def - dest!: global'_no_ex_cap) - apply (wpsimp wp: tc_caps_valid_duplicates' split: option.splits) - apply (wpsimp wp: tc_sched_valid_duplicates') - apply (simp add:invokeTCB_def | wp mapM_x_wp' | intro impI conjI | wpc)+ + apply (case_tac ti, simp_all only:) + apply (simp add: invokeTCB_def) + apply wp + apply (clarsimp simp: invs'_def valid_state'_def + dest!: global'_no_ex_cap) + apply (simp add: invokeTCB_def) + apply wp + apply (clarsimp simp: invs'_def valid_state'_def + dest!: global'_no_ex_cap) + apply (wp tc_valid_duplicates') + apply (clarsimp split:option.splits) + apply (rename_tac option) + apply (case_tac option, simp_all) + apply (simp add:invokeTCB_def | wp mapM_x_wp' | intro impI conjI | wpc)+ done -crunch invokeSchedContext, invokeSchedControlConfigureFlags - for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (simp: crunch_simps wp: crunch_wps hoare_vcg_all_lift) - lemma performInvocation_valid_duplicates'[wp]: "\\s. vs_valid_duplicates' (ksPSpace s) \ invs' s \ sch_act_simple s \ valid_invocation' i s \ ct_active' s\ - RetypeDecls_H.performInvocation isBlocking isCall canDonate i - \\_ s. vs_valid_duplicates' (ksPSpace s)\" + RetypeDecls_H.performInvocation isBlocking isCall i + \\reply s. vs_valid_duplicates' (ksPSpace s)\" apply (clarsimp simp: performInvocation_def) - apply (simp add: ct_in_state'_def) + apply (simp add:ct_in_state'_def) apply (rule hoare_name_pre_state) apply (rule hoare_pre) - apply wpc - apply (wpsimp wp: performArchInvocation_valid_duplicates' - simp: stateAssertE_def stateAssert_def)+ + apply wpc + apply (wp performArchInvocation_valid_duplicates' |simp)+ apply (cases i) - apply (clarsimp simp: simple_sane_strg sch_act_simple_def ct_in_state'_def - ct_active_runnable'[unfolded ct_in_state'_def] - | wp tcbinv_invs' arch_performInvocation_invs' - | rule conjI - | erule active_ex_cap')+ + apply (clarsimp simp: simple_sane_strg sch_act_simple_def + ct_in_state'_def ct_active_runnable'[unfolded ct_in_state'_def] + | wp tcbinv_invs' arch_performInvocation_invs' + | rule conjI | erule active_ex_cap')+ apply simp done lemma hi_valid_duplicates'[wp]: "\invs' and sch_act_simple and ct_active' and (\s. vs_valid_duplicates' (ksPSpace s))\ - handleInvocation isCall isBlocking canDonate firstPhase cptr + handleInvocation isCall isBlocking \\r s. vs_valid_duplicates' (ksPSpace s) \" apply (simp add: handleInvocation_def split_def - ts_Restart_case_helper' ct_not_inQ_asrt_def) - apply (rule validE_valid) - apply (intro bindE_wp[OF _ stateAssertE_sp]) - apply (wpsimp wp: syscall_valid' setThreadState_nonqueued_state_update rfk_invs' ct_in_state'_set - hoare_drop_imp) - apply (fastforce simp: ct_in_state'_def simple_sane_strg sch_act_simple_def - elim!: pred_tcb'_weakenE st_tcb_ex_cap'' - dest: st_tcb_at_idle_thread') + ts_Restart_case_helper') + apply (wp syscall_valid' setThreadState_nonqueued_state_update + rfk_invs' ct_in_state'_set | simp)+ + apply (fastforce simp add: tcb_at_invs' ct_in_state'_def + simple_sane_strg + sch_act_simple_def + elim!: pred_tcb'_weakenE st_tcb_ex_cap'' + dest: st_tcb_at_idle_thread')+ done -crunch activateIdleThread, schedContextCompleteYieldTo - for valid_duplicates' [wp]: "\s. vs_valid_duplicates' (ksPSpace s)" +crunch + activateIdleThread + for valid_duplicates'[wp]: "(\s. vs_valid_duplicates' (ksPSpace s))" (ignore: setNextPC threadSet simp:crunch_simps) +crunch + tcbSchedAppend + for valid_duplicates'[wp]: "(\s. vs_valid_duplicates' (ksPSpace s))" + (simp:crunch_simps wp:unless_wp) + +lemma timerTick_valid_duplicates'[wp]: + "\\s. vs_valid_duplicates' (ksPSpace s)\ + timerTick \\x s. vs_valid_duplicates' (ksPSpace s)\" + apply (simp add:timerTick_def decDomainTime_def) + apply (wp hoare_drop_imps|wpc|simp)+ + done + lemma handleInterrupt_valid_duplicates'[wp]: "\\s. vs_valid_duplicates' (ksPSpace s)\ handleInterrupt irq \\r s. vs_valid_duplicates' (ksPSpace s)\" @@ -2183,29 +2174,53 @@ lemma handleInterrupt_valid_duplicates'[wp]: |wpc|simp add: handleReservedIRQ_def maskIrqSignal_def)+ done -crunch awaken - for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (wp: crunch_wps) crunch schedule - for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (ignore: setNextPC clearExMonitor threadSet simp: crunch_simps - wp: hoare_drop_imps) + for valid_duplicates'[wp]: "(\s. vs_valid_duplicates' (ksPSpace s))" + (ignore: setNextPC clearExMonitor threadSet simp:crunch_simps wp:findM_inv hoare_drop_imps) lemma activate_sch_valid_duplicates'[wp]: - "\\s. vs_valid_duplicates' (ksPSpace s)\ + "\\s. ct_in_state' activatable' s \ vs_valid_duplicates' (ksPSpace s)\ activateThread \\rv s. vs_valid_duplicates' (ksPSpace s)\" apply (simp add: activateThread_def getCurThread_def cong: if_cong Structures_H.thread_state.case_cong) apply (rule bind_wp [OF _ gets_sp]) - apply (wpsimp wp: threadGet_wp hoare_drop_imps) - by (fastforce simp: obj_at'_def) + apply (rule bind_wp[where Q'="\st s. (runnable' or idle') st \ vs_valid_duplicates' (ksPSpace s)"]) + apply (rule hoare_pre) + apply (wp | wpc | simp add: setThreadState_runnable_simp)+ + apply (clarsimp simp: ct_in_state'_def cur_tcb'_def pred_tcb_at' + elim!: pred_tcb'_weakenE) + done -crunch receiveSignal, receiveIPC, handleYield, "VSpace_H.handleVMFault", handleHypervisorFault, - lookupReply, checkBudgetRestart +crunch + receiveSignal for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (wp: crunch_wps simp: crunch_simps) + +crunch + receiveIPC + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (wp: getNotification_wp gbn_wp' crunch_wps) + +crunch + deleteCallerCap + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (wp: crunch_wps) + +crunch + handleReply + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (wp: crunch_wps) + +crunch + handleYield + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (ignore: threadGet simp:crunch_simps wp:unless_wp) + +crunch + "VSpace_H.handleVMFault", handleHypervisorFault + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (ignore: getFAR getDFSR getIFSR simp:crunch_simps) lemma hs_valid_duplicates'[wp]: "\invs' and ct_active' and sch_act_simple and (\s. vs_valid_duplicates' (ksPSpace s))\ @@ -2217,91 +2232,42 @@ lemma hs_valid_duplicates'[wp]: lemma hc_valid_duplicates'[wp]: "\invs' and ct_active' and sch_act_simple and (\s. vs_valid_duplicates' (ksPSpace s))\ - handleCall - \\_ s. vs_valid_duplicates' (ksPSpace s)\" - apply (clarsimp simp: handleCall_def) - apply (rule validE_valid) - apply (rule bindE_wp[OF _ stateAssertE_sp]) - apply wpsimp - done + handleCall + \\rv s. vs_valid_duplicates' (ksPSpace s)\" + by (simp add: handleCall_def | wp)+ lemma handleRecv_valid_duplicates'[wp]: "\(\s. vs_valid_duplicates' (ksPSpace s))\ - handleRecv isBlocking canDonate \\r s. vs_valid_duplicates' (ksPSpace s)\" - apply (simp add: handleRecv_def cong: if_cong split del: if_split) + handleRecv isBlocking \\r s. vs_valid_duplicates' (ksPSpace s)\" + apply (simp add: handleRecv_def cong: if_cong) apply (rule hoare_pre) apply wp - apply ((wp getNotification_wp | wpc | simp add: whenE_def split del: if_split)+)[1] - apply (rule_tac Q'="\rv s. vs_valid_duplicates' (ksPSpace s)" in hoare_strengthen_postE[rotated]) - apply (clarsimp simp: isCap_simps sch_act_sane_not) - apply assumption - apply (wp)+ - apply (auto elim: st_tcb_ex_cap'' pred_tcb'_weakenE - dest!: st_tcb_at_idle_thread' - simp: ct_in_state'_def sch_act_sane_def) - done + apply ((wp getNotification_wp | wpc | simp add: whenE_def split del: if_split)+)[1] -lemma checkBudget_true: - "\P\ checkBudget \\rv s. rv \ P s\" - unfolding checkBudget_def - apply wpsimp - apply (wpsimp wp: hoare_drop_imp) - apply wpsimp - apply (wpsimp wp: hoare_drop_imp)+ - done + apply (rule_tac Q'="\rv s. vs_valid_duplicates' (ksPSpace s)" -lemma checkBudgetRestart_true: - "\P\ checkBudgetRestart \\rv s. rv \ P s\" - unfolding checkBudgetRestart_def - apply wpsimp - apply (rule_tac Q'="\rv s. rv \ P s" in hoare_strengthen_post[rotated], clarsimp) - apply (wpsimp wp: checkBudget_true)+ - done - -lemma checkBudgetRestart_gen: - "\R\ checkBudgetRestart \\_. Q\ \ - \P and R\ checkBudgetRestart \\rv s. (rv \ P s) \ (\rv \ Q s)\" - apply (wpsimp wp: checkBudgetRestart_true) - apply (wpsimp wp: hoare_drop_imp)+ - done + in hoare_strengthen_postE[rotated]) -lemma setCurTime_invs'[wp]: - "setCurTime v \invs'\" - unfolding setCurTime_def - apply wp - apply (clarsimp simp: invs'_def valid_machine_state'_def - valid_irq_node'_def valid_release_queue_def valid_release_queue'_def) - apply (clarsimp simp: valid_dom_schedule'_def valid_queues'_def valid_queues_def valid_bitmapQ_def - bitmapQ_def valid_queues_no_bitmap_def bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def) + apply (clarsimp simp: isCap_simps sch_act_sane_not) + apply assumption + apply (wp deleteCallerCap_nonz_cap)+ + apply (auto elim: st_tcb_ex_cap'' pred_tcb'_weakenE + dest!: st_tcb_at_idle_thread' + simp: ct_in_state'_def sch_act_sane_def) done -lemma updateTimeStamp_invs'[wp]: - "updateTimeStamp \invs'\" - unfolding updateTimeStamp_def - by (wpsimp wp: dmo_invs'_simple simp: getCurrentTime_def no_irq_def) - -lemma updateTimeStamp_sch_act_simple[wp]: - "updateTimeStamp \sch_act_simple\" - unfolding updateTimeStamp_def sch_act_simple_def setDomainTime_def - by (wpsimp wp: dmo_invs'_simple simp: setCurTime_def) - -crunch updateTimeStamp - for ksPSpace[wp]: "\s. P (ksPSpace s)" - and tcb_at'[wp]: "tcb_at' t" - -crunch getCapReg, refillCapacity - for inv[wp]: P lemma handleEvent_valid_duplicates': "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and sch_act_simple and (\s. e \ Interrupt \ ct_running' s)\ handleEvent e \\rv s. vs_valid_duplicates' (ksPSpace s)\" - supply if_cong[cong] - apply (case_tac e; simp add: handleEvent_def) - apply (rename_tac syscall, case_tac syscall; simp) - apply (wpsimp wp: checkBudgetRestart_gen stateAssertE_inv active_from_running' - hoare_vcg_if_lift2)+ + apply (case_tac e, simp_all add: handleEvent_def) + apply (rename_tac syscall) + apply (case_tac syscall) + apply (wp handleReply_sane + | simp add: active_from_running' simple_sane_strg cong: if_cong + | wpc)+ done (* nothing extra needed on this architecture *) @@ -2314,8 +2280,19 @@ lemma callKernel_valid_duplicates': (\s. e \ Interrupt \ ct_running' s)\ callKernel e \\rv s. vs_valid_duplicates' (ksPSpace s)\" - apply (simp add: callKernel_def mcsPreemptionPoint_def) - apply (wpsimp wp: hoare_drop_imp hoare_vcg_if_lift2 handleEvent_valid_duplicates') + apply (simp add: callKernel_def fastpathKernelAssertions_def) + apply (rule hoare_pre) + apply (wp activate_invs' activate_sch_act schedule_sch + schedule_sch_act_simple he_invs' + | simp add: no_irq_getActiveIRQ + | wp (once) hoare_drop_imps )+ + apply (rule hoare_strengthen_postE) + apply (rule valid_validE) + prefer 2 + apply assumption + apply (wp handleEvent_valid_duplicates') + apply simp + apply simp done end diff --git a/proof/refine/ARM/RAB_FN.thy b/proof/refine/ARM/RAB_FN.thy index eb7eea5bb4..969cb775de 100644 --- a/proof/refine/ARM/RAB_FN.thy +++ b/proof/refine/ARM/RAB_FN.thy @@ -78,7 +78,7 @@ declare resolveAddressBitsFn.simps[simp del] lemma isCNodeCap_capUntypedPtr_capCNodePtr: "isCNodeCap c \ capUntypedPtr c = capCNodePtr c" - by (clarsimp simp: isCap_simps State_H.ARM_H.PPtr_def) + by (clarsimp simp: isCap_simps) lemma resolveAddressBitsFn_eq: "monadic_rewrite F E (\s. (isCNodeCap cap \ (\slot. cte_wp_at' (\cte. cteCap cte = cap) slot s)) diff --git a/proof/refine/ARM/Refine.thy b/proof/refine/ARM/Refine.thy index 89474fd975..f8b1edefcf 100644 --- a/proof/refine/ARM/Refine.thy +++ b/proof/refine/ARM/Refine.thy @@ -16,7 +16,7 @@ imports PageTableDuplicates begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) text \User memory content is the same on both levels\ lemma typ_at_AUserDataI: @@ -86,7 +86,6 @@ lemma typ_at_UserDataI: split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) - apply (case_tac ko; simp) apply (rename_tac vmpage_size n) apply (rule_tac x = vmpage_size in exI) apply (subst conjunct2 [OF is_aligned_add_helper]) @@ -118,7 +117,6 @@ lemma typ_at_DeviceDataI: split: Structures_A.kernel_object.split_asm Structures_H.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) - apply (case_tac ko; simp) apply (rename_tac vmpage_size n) apply (rule_tac x = vmpage_size in exI) apply (subst conjunct2 [OF is_aligned_add_helper]) @@ -130,7 +128,7 @@ lemma typ_at_DeviceDataI: done lemma pointerInUserData_relation: - "\ (s,s') \ state_relation; invs' s'; valid_state s\ + "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInUserData p s' = in_user_frame p s" apply (simp add: pointerInUserData_def in_user_frame_def) apply (rule iffI) @@ -139,7 +137,7 @@ lemma pointerInUserData_relation: apply (drule_tac sz = sz and n = "(p && mask (pageBitsForSize sz)) >> pageBits" in typ_at_AUserDataI [where s = s and s' = s']) - apply fastforce+ + apply (fastforce simp: valid_state'_def)+ apply (rule shiftr_less_t2n') apply (simp add: pbfs_atleast_pageBits mask_twice) apply (case_tac sz, simp_all)[1] @@ -156,7 +154,7 @@ lemma pointerInUserData_relation: done lemma pointerInDeviceData_relation: - "\ (s,s') \ state_relation; invs' s'; valid_state s\ + "\ (s,s') \ state_relation; valid_state' s'; valid_state s\ \ pointerInDeviceData p s' = in_device_frame p s" apply (simp add: pointerInDeviceData_def in_device_frame_def) apply (rule iffI) @@ -165,7 +163,7 @@ lemma pointerInDeviceData_relation: apply (drule_tac sz = sz and n = "(p && mask (pageBitsForSize sz)) >> pageBits" in typ_at_ADeviceDataI [where s = s and s' = s']) - apply (fastforce simp: invs'_def)+ + apply (fastforce simp: valid_state'_def)+ apply (rule shiftr_less_t2n') apply (simp add: pbfs_atleast_pageBits mask_twice) apply (case_tac sz, simp_all)[1] @@ -182,7 +180,7 @@ lemma pointerInDeviceData_relation: done lemma user_mem_relation: - "\(s,s') \ state_relation; invs' s'; valid_state s\ + "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ user_mem' s' = user_mem s" apply (rule ext) apply (clarsimp simp: user_mem_def user_mem'_def pointerInUserData_relation pointerInDeviceData_relation) @@ -190,199 +188,140 @@ lemma user_mem_relation: done lemma device_mem_relation: - "\(s,s') \ state_relation; invs' s'; valid_state s\ + "\(s,s') \ state_relation; valid_state' s'; valid_state s\ \ device_mem' s' = device_mem s" - unfolding device_mem_def device_mem'_def - by (rule ext) (clarsimp simp: pointerInUserData_relation pointerInDeviceData_relation) + apply (rule ext) + apply (clarsimp simp: device_mem_def device_mem'_def pointerInUserData_relation + pointerInDeviceData_relation) + done lemma absKState_correct: - assumes invs: "einvs (s :: det_ext state)" and invs': "invs' s'" - assumes rel: "(s,s') \ state_relation" - shows "absKState s' = abs_state s" +assumes invs: "einvs (s :: det_ext state)" and invs': "invs' s'" +assumes rel: "(s,s') \ state_relation" +shows "absKState s' = abs_state s" using assms apply (intro state.equality, simp_all add: absKState_def abs_state_def) - apply (rule absHeap_correct; clarsimp simp: state_relation_sc_replies_relation) - apply (clarsimp elim!: state_relationE) - apply (rule absCDT_correct; clarsimp) - apply (rule absIsOriginalCap_correct; clarsimp) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (clarsimp simp: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (rule absSchedulerAction_correct, simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (simp add: state_relation_def) - apply (fastforce simp: curry_def state_relation_def ready_queues_relation_def) - apply (simp add: state_relation_def release_queue_relation_def) + apply (rule absHeap_correct, clarsimp+) + apply (clarsimp elim!: state_relationE) + apply (rule absCDT_correct, clarsimp+) + apply (rule absIsOriginalCap_correct, clarsimp+) + apply (simp add: state_relation_def) + apply (simp add: state_relation_def) apply (clarsimp simp: user_mem_relation invs_def invs'_def) apply (simp add: state_relation_def) apply (rule absInterruptIRQNode_correct, simp add: state_relation_def) apply (rule absInterruptStates_correct, simp add: state_relation_def) apply (rule absArchState_correct, simp) - apply (rule absExst_correct; simp) + apply (rule absExst_correct, simp+) done text \The top-level invariance\ -lemma kernel_entry_invs_det_ext: - "\\s. invs s \ schact_is_rct s \ cur_sc_active s \ ct_not_in_release_q s - \ (e \ Interrupt \ ct_running s)\ - kernel_entry e us - \\_ s :: det_state. invs s \ (ct_running s \ ct_idle s)\" - apply (simp add: kernel_entry_def) - apply (wp akernel_invs_det_ext thread_set_invs_trivial thread_set_ct_in_state - hoare_weak_lift_imp hoare_vcg_disj_lift hoare_vcg_imp_lift' - | clarsimp simp add: tcb_cap_cases_def)+ +lemma set_thread_state_sched_act: + "\(\s. runnable state) and (\s. P (scheduler_action s))\ + set_thread_state thread state + \\rs s. P (scheduler_action (s::det_state))\" + apply (simp add: set_thread_state_def) + apply wp + apply (simp add: set_thread_state_ext_def) + apply wp + apply (rule hoare_pre_cont) + apply (rule_tac Q'="\rv. (\s. runnable ts) and (\s. P (scheduler_action s))" + in hoare_strengthen_post) + apply wp + apply force + apply (wp gts_st_tcb_at)+ + apply (rule_tac Q'="\rv. st_tcb_at ((=) state) thread and (\s. runnable state) and (\s. P (scheduler_action s))" in hoare_strengthen_post) + apply (simp add: st_tcb_at_def) + apply (wp obj_set_prop_at)+ + apply (force simp: st_tcb_at_def obj_at_def) + apply wp + apply clarsimp done -lemma kernel_entry_valid_sched: - "\\s. valid_sched s \ invs s \ schact_is_rct s - \ cur_sc_active s \ ct_not_in_release_q s - \ (ct_running s \ ct_idle s) \ (e \ Interrupt \ ct_running s) - \ valid_machine_time s \ current_time_bounded s \ consumed_time_bounded s - \ cur_sc_offset_ready (consumed_time s) s - \ cur_sc_offset_sufficient (consumed_time s) s\ - kernel_entry e us - \\_. valid_sched :: det_state \ _\" - apply (simp add: kernel_entry_def) - apply (wp call_kernel_valid_sched thread_set_invs_trivial thread_set_ct_in_state - hoare_weak_lift_imp hoare_vcg_disj_lift thread_set_not_state_valid_sched - | clarsimp simp add: tcb_cap_cases_def)+ +lemma activate_thread_sched_act: + "\ct_in_state activatable and (\s. P (scheduler_action s))\ + activate_thread + \\rs s. P (scheduler_action (s::det_state))\" + by (simp add: activate_thread_def set_thread_state_def arch_activate_idle_thread_def + | (wp set_thread_state_sched_act gts_wp)+ | wpc)+ + +lemma schedule_sched_act_rct[wp]: + "\\\ Schedule_A.schedule + \\rs (s::det_state). scheduler_action s = resume_cur_thread\" + unfolding Schedule_A.schedule_def + by (wpsimp) + +lemma call_kernel_sched_act_rct[wp]: + "\einvs and (\s. e \ Interrupt \ ct_running s) + and (\s. scheduler_action s = resume_cur_thread)\ + call_kernel e + \\rs (s::det_state). scheduler_action s = resume_cur_thread\" + apply (simp add: call_kernel_def) + apply (wp activate_thread_sched_act | simp)+ + apply (clarsimp simp: active_from_running) done -abbreviation (input) mcs_invs where - "mcs_invs s \ einvs s - \ scheduler_action s = resume_cur_thread - \ cur_sc_active s \ ct_not_in_release_q s - \ valid_machine_time s \ current_time_bounded s \ consumed_time_bounded s - \ (cur_sc_offset_ready (consumed_time s) s - \ cur_sc_offset_sufficient (consumed_time s) s) - \ valid_domain_list s " - lemma kernel_entry_invs: - "\\s. mcs_invs s \ (ct_running s \ ct_idle s) \ (e \ Interrupt \ ct_running s)\ - kernel_entry e us - \\_ s. mcs_invs s \ (ct_running s \ ct_idle s)\" - apply (rule_tac Q'="\_ s. (invs s \ (ct_running s \ ct_idle s)) - \ (cur_sc_offset_ready (consumed_time s) s - \ cur_sc_offset_sufficient (consumed_time s) s) - \ valid_sched s - \ valid_domain_list s - \ valid_list s \ scheduler_action s = resume_cur_thread - \ cur_sc_active s \ ct_not_in_release_q s - \ valid_machine_time s \ current_time_bounded s - \ consumed_time_bounded s" + "\einvs and (\s. e \ Interrupt \ ct_running s) + and (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) + and (\s. scheduler_action s = resume_cur_thread)\ + kernel_entry e us + \\rv. einvs and (\s. ct_running s \ ct_idle s) + and (\s. 0 < domain_time s) and valid_domain_list + and (\s. scheduler_action s = resume_cur_thread)\" + apply (rule_tac Q'="\rv. invs and (\s. ct_running s \ ct_idle s) and valid_sched and + (\s. 0 < domain_time s) and valid_domain_list and + valid_list and (\s. scheduler_action s = resume_cur_thread)" in hoare_post_imp) apply clarsimp - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (wpsimp wp: kernel_entry_invs_det_ext) - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: kernel_entry_def) - apply (wp thread_set_invs_trivial thread_set_not_state_valid_sched hoare_vcg_disj_lift - ct_in_state_thread_state_lift thread_set_no_change_tcb_state - hoare_weak_lift_imp call_kernel_cur_sc_offset_ready_and_sufficient - | clarsimp simp: tcb_cap_cases_def)+ - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (wpsimp wp: kernel_entry_valid_sched) - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: kernel_entry_def) - apply (wpsimp wp: call_kernel_domain_list_inv_det_ext | clarsimp simp: active_from_running)+ - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: kernel_entry_def) - apply wpsimp - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: kernel_entry_def) - apply (wp thread_set_invs_trivial thread_set_not_state_valid_sched hoare_vcg_disj_lift - ct_in_state_thread_state_lift thread_set_no_change_tcb_state hoare_weak_lift_imp - call_kernel_schact_is_rct[unfolded schact_is_rct_def] - | clarsimp simp: tcb_cap_cases_def)+ - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: kernel_entry_def) - apply (wp thread_set_invs_trivial thread_set_not_state_valid_sched hoare_vcg_disj_lift - ct_in_state_thread_state_lift thread_set_no_change_tcb_state hoare_weak_lift_imp - call_kernel_cur_sc_active - | clarsimp simp: tcb_cap_cases_def)+ - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: kernel_entry_def) - apply (wp thread_set_invs_trivial thread_set_not_state_valid_sched hoare_vcg_disj_lift - ct_in_state_thread_state_lift thread_set_no_change_tcb_state - hoare_weak_lift_imp call_kernel_ct_not_in_release_q - | clarsimp simp: tcb_cap_cases_def)+ - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: kernel_entry_def) - apply wpsimp - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: kernel_entry_def) - apply (wpsimp wp: call_kernel_current_time_bounded) - apply (clarsimp simp: kernel_entry_def) - apply (wpsimp wp: call_kernel_consumed_time_bounded) + apply (simp add: kernel_entry_def) + apply (wp akernel_invs_det_ext call_kernel_valid_sched thread_set_invs_trivial + thread_set_ct_running thread_set_not_state_valid_sched + hoare_vcg_disj_lift ct_in_state_thread_state_lift thread_set_no_change_tcb_state + call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext + hoare_weak_lift_imp + | clarsimp simp add: tcb_cap_cases_def active_from_running)+ done definition - "full_invs - \ {((tc, s :: det_ext state), m, e). mcs_invs s - \ (ct_running s \ ct_idle s) - \ (m = KernelMode \ e \ None) - \ (m = UserMode \ ct_running s) - \ (m = IdleMode \ ct_idle s) - \ (e \ None \ e \ Some Interrupt \ ct_running s)}" - -crunch do_user_op, check_active_irq - for valid_list[wp]: valid_list - and valid_sched[wp]: valid_sched - and sched_act[wp]: "\s. P (scheduler_action s)" - and domain_time[wp]: "\s. P (domain_time s)" - and cur_sc_active[wp]: cur_sc_active - and ct_not_in_release_q[wp]: ct_not_in_release_q - and current_time_bounded[wp]: current_time_bounded - and cur_sc_offset_ready[wp]: "\s. cur_sc_offset_ready (consumed_time s) s" - and cur_sc_offset_sufficient[wp]: "\s. cur_sc_offset_sufficient (consumed_time s) s" - and consumed_time_bounded[wp]: consumed_time_bounded - -lemma device_update_valid_machine_time[wp]: - "do_machine_op (device_memory_update ds) \valid_machine_time\" - apply (simp add: do_machine_op_def device_memory_update_def simpler_modify_def select_f_def - gets_def get_def bind_def valid_def return_def) + "full_invs \ {((tc, s :: det_ext state), m, e). einvs s \ + (ct_running s \ ct_idle s) \ + (m = KernelMode \ e \ None) \ + (m = UserMode \ ct_running s) \ + (m = IdleMode \ ct_idle s) \ + (e \ None \ e \ Some Interrupt \ ct_running s) \ + 0 < domain_time s \ valid_domain_list s \ + (scheduler_action s = resume_cur_thread)}" + +lemma do_user_op_valid_list:"\valid_list\ do_user_op f tc \\_. valid_list\" + unfolding do_user_op_def + apply (wp | simp add: split_def)+ done -lemma user_memory_update_valid_machine_time[wp]: - "do_machine_op (user_memory_update ds) \valid_machine_time\" - apply (simp add: do_machine_op_def user_memory_update_def simpler_modify_def select_f_def - gets_def get_def bind_def valid_def return_def) +lemma do_user_op_valid_sched:"\valid_sched\ do_user_op f tc \\_. valid_sched\" + unfolding do_user_op_def + apply (wp | simp add: split_def)+ done -lemma do_user_op_valid_machine_time[wp]: - "do_user_op f tc \valid_machine_time\" - apply (simp add: do_user_op_def) - apply wpsimp - done - -lemma check_active_irq_valid_machine_time[wp]: - "check_active_irq \valid_machine_time\" - apply (clarsimp simp: check_active_irq_def) - apply (wpsimp wp: getActiveIRQ_inv) +lemma do_user_op_sched_act: + "\\s. P (scheduler_action s)\ do_user_op f tc \\_ s. P (scheduler_action s)\" + unfolding do_user_op_def + apply (wp | simp add: split_def)+ done lemma do_user_op_invs2: - "do_user_op f tc - \\s. mcs_invs s \ ct_running s\" - apply (rule_tac Q'="\_ s. (invs s \ ct_running s) \ valid_list s \ valid_sched s - \ scheduler_action s = resume_cur_thread - \ valid_domain_list s - \ cur_sc_active s \ ct_not_in_release_q s - \ valid_machine_time s \ current_time_bounded s - \ consumed_time_bounded s - \ cur_sc_offset_ready (consumed_time s) s - \ cur_sc_offset_sufficient (consumed_time s) s" - in hoare_post_imp, fastforce) - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (wpsimp wp: do_user_op_invs[simplified pred_conj_def]) - apply (wp do_user_op_valid_list do_user_op_valid_sched do_user_op_sched_act do_user_op_domain_time - | fastforce)+ + "\einvs and ct_running and (\s. scheduler_action s = resume_cur_thread) + and (\s. 0 < domain_time s) and valid_domain_list \ + do_user_op f tc + \\_. (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread)) + and (\s. 0 < domain_time s) and valid_domain_list \" + apply (rule_tac Q'="\_. valid_list and valid_sched and + (\s. scheduler_action s = resume_cur_thread) and (invs and ct_running) and + (\s. 0 < domain_time s) and valid_domain_list" + in hoare_strengthen_post) + apply (wp do_user_op_valid_list do_user_op_valid_sched do_user_op_sched_act + do_user_op_invs | simp | force)+ done lemmas ext_init_def = ext_init_det_ext_ext_def ext_init_unit_def @@ -396,68 +335,16 @@ lemmas valid_list_inits[simp] = valid_list_init[simplified] lemma valid_sched_init[simp]: "valid_sched init_A_st" apply (simp add: valid_sched_def init_A_st_def ext_init_def) - apply (insert getCurrentTime_buffer_bound MIN_BUDGET_le_MAX_PERIOD') - apply (clarsimp simp: init_kheap_def obj_at_def idle_thread_ptr_def init_globals_frame_def - init_global_pd_def ct_not_in_q_def valid_sched_action_def is_activatable_def - ct_in_cur_domain_2_def valid_idle_etcb_def etcb_at'_def - valid_ready_qs_def ready_or_release_2_def in_queues_2_def - idle_sc_ptr_def valid_blocked_defs default_domain_def minBound_word - released_ipc_queues_defs active_reply_scs_def active_if_reply_sc_at_def - active_sc_def MIN_REFILLS_def) - by (auto simp: vs_all_heap_simps active_scs_valid_def cfg_valid_refills_def - rr_valid_refills_def MIN_REFILLS_def bounded_release_time_def - default_sched_context_def MAX_PERIOD_def active_sc_def - intro: order_trans[OF mult_left_mono, OF us_to_ticks_helper]) + apply (clarsimp simp: valid_etcbs_def init_kheap_def st_tcb_at_kh_def obj_at_kh_def + obj_at_def is_etcb_at_def idle_thread_ptr_def init_globals_frame_def + init_global_pd_def valid_queues_2_def ct_not_in_q_def not_queued_def + valid_sched_action_def is_activatable_def + ct_in_cur_domain_2_def valid_blocked_2_def valid_idle_etcb_def etcb_at'_def default_etcb_def) + done lemma valid_domain_list_init[simp]: "valid_domain_list init_A_st" - apply (insert domain_time_pos) - apply (simp add: init_A_st_def ext_init_def valid_domain_list_def) - done - -lemma cur_sc_active_init[simp]: - "cur_sc_active init_A_st" - apply (clarsimp simp: init_A_st_def init_kheap_def vs_all_heap_simps active_sc_def MIN_REFILLS_def) - done - -lemma ct_not_in_release_q_init[simp]: - "ct_not_in_release_q init_A_st" - apply (clarsimp simp: init_A_st_def init_kheap_def not_in_release_q_def in_queue_2_def) - done - -lemma valid_machine_time_init[simp]: - "valid_machine_time init_A_st" - apply (clarsimp simp: init_A_st_def valid_machine_time_def init_machine_state_def) - done - -lemma current_time_bounded_init[simp]: - "current_time_bounded init_A_st" - apply (insert getCurrentTime_buffer_no_overflow) - apply (clarsimp simp: current_time_bounded_def init_A_st_def) - done - -lemma consumed_time_bounded_init[simp]: - "consumed_time_bounded init_A_st" - apply (clarsimp simp: init_kheap_def init_A_st_def) - done - -lemma cur_sc_offset_ready_and_sufficient[simp]: - "cur_sc_offset_ready (consumed_time init_A_st) init_A_st - \ cur_sc_offset_sufficient (consumed_time init_A_st) init_A_st" - apply (clarsimp simp: init_A_st_def) - done - -lemma check_active_irq_invs: - "check_active_irq \\s. mcs_invs s \ (ct_running s \ ct_idle s)\" - by (wpsimp simp: check_active_irq_def ct_in_state_def) - -lemma check_active_irq_invs_just_running: - "check_active_irq \\s. mcs_invs s \ ct_running s\" - by (wpsimp simp: check_active_irq_def ct_in_state_def) - -lemma check_active_irq_invs_just_idle: - "check_active_irq \\s. mcs_invs s \ ct_idle s\" - by (wpsimp simp: check_active_irq_def ct_in_state_def) + by (simp add: init_A_st_def ext_init_def valid_domain_list_def) lemma akernel_invariant: "ADT_A uop \ full_invs" @@ -468,55 +355,44 @@ lemma akernel_invariant: apply (simp add: Let_def Init_A_def) apply (simp add: init_A_st_def ext_init_def) apply (clarsimp simp: ADT_A_def global_automaton_def) + apply (rename_tac tc' s' mode' e' tc s mode e) apply (elim disjE) apply ((clarsimp simp: kernel_call_A_def - | drule use_valid[OF _ kernel_entry_invs])+)[2] + | drule use_valid[OF _ kernel_entry_invs])+)[2] apply ((clarsimp simp: do_user_op_A_def monad_to_transition_def check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running] - | drule use_valid[OF _ do_user_op_cur_sc_active])+)[2] + | drule use_valid[OF _ do_user_op_invs2] + | drule use_valid[OF _ check_active_irq_invs_just_running])+)[2] apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] + | drule use_valid[OF _ check_active_irq_invs])+)[1] apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) apply ((clarsimp simp add: do_user_op_A_def check_active_irq_A_def - | drule use_valid[OF _ do_user_op_invs2] - | drule use_valid[OF _ check_active_irq_invs_just_running])+)[1] + | drule use_valid[OF _ do_user_op_invs2] + | drule use_valid[OF _ check_active_irq_invs_just_running])+)[1] apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] + | drule use_valid[OF _ check_active_irq_invs])+)[1] apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs_just_idle])+)[1] + | drule use_valid[OF _ check_active_irq_invs_just_idle])+)[1] apply ((clarsimp simp add: check_active_irq_A_def - | drule use_valid[OF _ check_active_irq_invs])+)[1] + | drule use_valid[OF _ check_active_irq_invs])+)[1] done lemma ckernel_invs: - "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) - and (\s. e \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') - and (\s. is_active_sc' (ksCurSc s) s) and sym_heap_tcbSCs - and (\s. obj_at' (\sc. scTCB sc = Some (ksCurThread s)) (ksCurSc s) s) - and (\s. pred_map (\tcb. \ tcbInReleaseQueue tcb) (tcbs_of' s) (ksCurThread s)) - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - callKernel e - \\_. invs'\" - apply (simp add: callKernel_def mcsPreemptionPoint_def) + "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. e \ Interrupt \ ct_running' s) and + (\s. ksSchedulerAction s = ResumeCurrentThread)\ + callKernel e + \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) + and (invs' and (ct_running' or ct_idle'))\" + apply (simp add: callKernel_def) apply (rule hoare_pre) - apply (wpsimp wp: hoare_drop_imp[where Q'="\_. kernelExitAssertions"] activate_invs') - apply (rule hoare_drop_imp) - apply (wpsimp wp: schedule_invs') - apply (wpsimp wp: stateAssert_wp) - apply (wpsimp wp: isSchedulable_wp hoare_drop_imp) - apply (intro iffI; clarsimp simp: isScActive_def isSchedulable_bool_def) - apply (rule hoare_strengthen_postE[where E'="\_. invs'" and Q=Q and R=Q for Q]) - apply wpsimp - apply (clarsimp simp: active_from_running')+ - apply (clarsimp simp: sym_heap_def pred_map_def) - apply (rule_tac x="ksCurSc s" in exI) - apply (clarsimp simp: obj_at_simps is_active_sc'_def isScActive_def opt_map_red pred_map_def - opt_pred_def) + apply (wp activate_invs' activate_sch_act schedule_sch + schedule_sch_act_simple he_invs' schedule_invs' + hoare_drop_imp[where Q'="\_. kernelExitAssertions"] + | simp add: no_irq_getActiveIRQ)+ done (* abstract and haskell have identical domain list fields *) @@ -539,59 +415,52 @@ lemma corres_cross_over_fastpathKernelAssertions: (fastforce elim: fastpathKernelAssertions_cross)+ defs kernelExitAssertions_def: - "kernelExitAssertions s \ valid_domain_list' s" + "kernelExitAssertions s \ 0 < ksDomainTime s \ valid_domain_list' s" lemma callKernel_domain_time_left: - "\ \ \ callKernel e \\_ s. valid_domain_list' s \" + "\ \ \ callKernel e \\_ s. 0 < ksDomainTime s \ valid_domain_list' s \" unfolding callKernel_def kernelExitAssertions_def by wpsimp -lemma threadSet_is_active_sc'[wp]: - "threadSet f tp \\s. is_active_sc' scp s\" - by (wpsimp simp: is_active_sc'_def) - -lemma threadSet_sym_heap_tcbSCs: - "\x. tcbSchedContext (f x) = tcbSchedContext x \ - threadSet f t \\s. P (tcbSCs_of s) (scTCBs_of s)\" - unfolding threadSet_def - apply (rule bind_wp[OF _ get_tcb_sp']) - apply (wpsimp wp: setObject_tcb_tcbs_of' | wps)+ - apply (prop_tac "((\a. if a = t then Some (f tcb) else tcbs_of' s a) |> - tcbSchedContext) = tcbSCs_of s") - apply (rule ext) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_def) - apply simp - done - lemma kernelEntry_invs': - "\ invs' and (\s. e \ Interrupt \ ct_running' s) - and (ct_running' or ct_idle') - and (\s. vs_valid_duplicates' (ksPSpace s)) - and (\s. is_active_sc' (ksCurSc s) s) and sym_heap_tcbSCs - and (\s. obj_at' (\sc. scTCB sc = Some (ksCurThread s)) (ksCurSc s) s) - and (\s. pred_map (\tcb. \ tcbInReleaseQueue tcb) (tcbs_of' s) (ksCurThread s)) - and (\s. ksSchedulerAction s = ResumeCurrentThread) - and valid_domain_list' \ + "\ invs' and (\s. e \ Interrupt \ ct_running' s) and + (ct_running' or ct_idle') and + (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. 0 < ksDomainTime s) and valid_domain_list' \ kernelEntry e tc - \\_. invs' and (\s. vs_valid_duplicates' (ksPSpace s))\" - apply (rule_tac P'1="\s. obj_at' (\tcb. tcbSchedContext tcb = Some (ksCurSc s)) (ksCurThread s) s" - in hoare_pre_add[THEN iffD2]) - apply (clarsimp simp: obj_at'_tcb_scs_of_equiv obj_at'_sc_tcbs_of_equiv sym_heap_def) - apply (fastforce simp: ct_in_state'_def pred_tcb_at'_def obj_at'_def) + \\rs. (\s. ksSchedulerAction s = ResumeCurrentThread) and + (invs' and (ct_running' or ct_idle')) and + (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. 0 < ksDomainTime s) and valid_domain_list' \" apply (simp add: kernelEntry_def) - apply (wpsimp wp: ckernel_invs callKernel_valid_duplicates' threadSet_invs_trivial - threadSet_ct_in_state' hoare_weak_lift_imp hoare_vcg_disj_lift threadSet_sym_heap_tcbSCs - | wps)+ - apply (rule hoare_vcg_conj_lift) - apply (wpsimp wp: threadSet_wp) - apply (wpsimp wp: threadSet_invs_trivial; simp?) - apply (wpsimp wp: threadSet_ct_running' hoare_weak_lift_imp)+ - apply (fastforce simp: obj_at'_def projectKOs pred_map_def opt_map_red) + apply (wp ckernel_invs callKernel_valid_duplicates' callKernel_domain_time_left + threadSet_invs_trivial threadSet_ct_running' + TcbAcc_R.dmo_invs' hoare_weak_lift_imp + callKernel_domain_time_left + | clarsimp simp: user_memory_update_def no_irq_def tcb_at_invs' + valid_domain_list'_def)+ done lemma absKState_correct': "\einvs s; invs' s'; (s,s') \ state_relation\ \ absKState s' = abs_state s" - by (rule absKState_correct) + apply (intro state.equality, simp_all add: absKState_def abs_state_def) + apply (rule absHeap_correct) + apply (clarsimp simp: valid_state_def valid_pspace_def)+ + apply (clarsimp dest!: state_relationD) + apply (rule absCDT_correct) + apply (clarsimp simp: valid_state_def valid_pspace_def + valid_state'_def valid_pspace'_def)+ + apply (rule absIsOriginalCap_correct, clarsimp+) + apply (simp add: state_relation_def) + apply (simp add: state_relation_def) + apply (clarsimp simp: user_mem_relation invs_def invs'_def) + apply (simp add: state_relation_def) + apply (rule absInterruptIRQNode_correct, simp add: state_relation_def) + apply (rule absInterruptStates_correct, simp add: state_relation_def) + apply (erule absArchState_correct) + apply (rule absExst_correct, simp, assumption+) + done lemma ptable_lift_abs_state[simp]: "ptable_lift t (abs_state s) = ptable_lift t s" @@ -612,12 +481,13 @@ proof - from invs invs' rel have [simp]: "absKState s' = abs_state s" by - (rule absKState_correct', simp_all) from invs have valid: "valid_state s" by auto + from invs' have valid': "valid_state' s'" by auto have "in_user_frame y s \ in_device_frame y s " by (rule ptable_rights_imp_frame[OF valid rights[simplified] trans[simplified]]) thus ?thesis - by (auto simp add: pointerInUserData_relation[OF rel invs' valid] - pointerInDeviceData_relation[OF rel invs' valid]) + by (auto simp add: pointerInUserData_relation[OF rel valid' valid] + pointerInDeviceData_relation[OF rel valid' valid]) qed @@ -626,8 +496,7 @@ lemma device_update_invs': \\_. invs'\" apply (simp add: doMachineOp_def device_memory_update_def simpler_modify_def select_f_def gets_def get_def bind_def valid_def return_def) - by (clarsimp simp: invs'_def valid_irq_states'_def valid_machine_state'_def - valid_dom_schedule'_def) + by (clarsimp simp: invs'_def valid_state'_def valid_irq_states'_def valid_machine_state'_def) lemmas ex_abs_def = ex_abs_underlying_def[where sr=state_relation and P=G,abs_def] for G @@ -637,11 +506,11 @@ crunch doMachineOp lemma doUserOp_invs': "\invs' and ex_abs einvs and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - valid_domain_list'\ + (\s. 0 < ksDomainTime s) and valid_domain_list'\ doUserOp f tc \\_. invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_running' and - valid_domain_list'\" + (\s. 0 < ksDomainTime s) and valid_domain_list'\" apply (simp add: doUserOp_def split_def ex_abs_def) apply (wp device_update_invs' | (wp (once) dmo_invs', wpsimp simp: no_irq_modify device_memory_update_def @@ -663,155 +532,9 @@ lemma doUserOp_valid_duplicates': text \The top-level correspondence\ -lemma kernel_preemption_corres: - "corres (dc \ dc) - (einvs and current_time_bounded and scheduler_act_sane - and (\s. schact_is_rct s \ cur_sc_active s) - and (\s. schact_is_rct s \ ct_in_state activatable s) - and cur_sc_chargeable and ct_not_blocked - and (\s. cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s) and ct_not_queued - and consumed_time_bounded and ct_not_in_release_q) - invs' - (liftE preemption_path) - (liftE (do irq_opt <- doMachineOp (getActiveIRQ True); - _ <- mcsPreemptionPoint irq_opt; - when (\y. irq_opt = Some y) (handleInterrupt (the irq_opt)) - od))" (is "corres _ ?P ?P' _ _") - apply (rule_tac Q="\s. sc_at' (ksCurSc s) s" in corres_cross_add_guard) - apply clarsimp - apply (frule (1) cur_sc_tcb_sc_at_cur_sc[OF invs_valid_objs invs_cur_sc_tcb]) - apply (drule state_relationD, clarsimp) - apply (erule sc_at_cross; fastforce simp: invs_def valid_state_def valid_pspace_def) - apply (rule corres_guard_imp) - apply (simp add: preemption_path_def mcsPreemptionPoint_def bind_assoc) - apply (rule corres_split[OF corres_machine_op]) - apply (rule corres_underlying_trivial) - apply (rule no_fail_getActiveIRQ) - apply (clarsimp simp: dc_def[symmetric]) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule corres_split_eqr[OF isSchedulable_corres]) - apply (rename_tac irq ct sched) - apply (rule corres_split[OF corres_if2]) - apply simp - apply (rule_tac P="?P and (\s. ct = cur_thread s) and (\s. sched = schedulable ct s) - and K sched" - and P'="?P' and (\s. ct = ksCurThread s) - and (\s. sched = isSchedulable_bool ct s)" - in corres_inst) - apply (rule corres_gen_asm') - apply(rule corres_guard_imp) - apply (rule corres_split_eqr[OF checkBudget_corres]) - apply (simp only: K_bind_def) - apply (rule corres_return_trivial) - apply wpsimp - apply wpsimp - apply (clarsimp simp: valid_sched_def runnable_eq_active - schedulable_def2 active_sc_tcb_at_def2 tcb_at_kh_simps[symmetric] - pred_tcb_at_def obj_at_def) - apply (rename_tac scp tcb) - apply (prop_tac "cur_sc_tcb_are_bound s \ scp = cur_sc s") - apply (clarsimp simp: cur_sc_chargeable_def) - apply (drule_tac x=scp in spec, clarsimp simp: vs_all_heap_simps) - apply clarsimp - apply simp - apply (simp add: get_sc_active_def active_sc_def dc_def[symmetric]) - apply (rule corres_split_eqr[OF getCurSc_corres]) - apply (rule corres_split[OF get_sc_corres]) - apply (rename_tac csc sc sc') - apply (rule corres_if2) - apply (clarsimp simp: sc_relation_def) - apply (rule_tac P="?P and (\s. ct = cur_thread s) and (\s. sched = schedulable ct s) - and (\s. \n. ko_at (Structures_A.SchedContext sc n) (cur_sc s) s) - and K (\sched) and K (0 < sc_refill_max sc)" - and P'="?P' and (\s. ct = ksCurThread s) - and (\s. sched = isSchedulable_bool ct s)" - in corres_inst) - apply(rule corres_guard_imp) - apply (rule corres_split_eqr[OF getConsumedTime_corres]) - apply (rule chargeBudget_corres) - apply wpsimp - apply wpsimp - apply (prop_tac "cur_sc_active s") - apply (clarsimp simp: obj_at_def is_sc_active_kh_simp[symmetric] - is_sc_active_def2) - apply (clarsimp simp: active_sc_def) - apply (clarsimp simp: valid_sched_def) - apply clarsimp - apply (rule setConsumedTime_corres) - apply simp - apply wpsimp - apply wpsimp - apply wpsimp - apply wpsimp - apply (rule_tac x=irq in option_corres) - apply (rule_tac P=\ and P'=\ in corres_inst) - apply (simp add: when_def) - apply (rule corres_when, simp) - apply simp - apply (rule handleInterrupt_corres) - apply simp - apply (rule hoare_vcg_if_split) - apply (wpsimp wp: check_budget_valid_sched hoare_vcg_imp_lift') - apply (wpsimp wp: hoare_vcg_if_split) - apply (wpsimp wp: charge_budget_valid_sched hoare_vcg_imp_lift') - apply wpsimp - apply wpsimp - apply wpsimp - apply wpsimp - apply (rule_tac Q'="\_ s. bound irq \ invs' s \ (intStateIRQTable (ksInterruptState s) (the irq) \ - irqstate.IRQInactive)" - in hoare_strengthen_post[rotated]) - apply clarsimp - apply (wpsimp wp: hoare_vcg_imp_lift') - apply clarsimp - apply (wpsimp wp: is_schedulable_wp') - apply (wpsimp wp: isSchedulable_wp cong: conj_cong imp_cong) - apply wpsimp - apply wpsimp - apply (rule_tac Q'="\_ s. invs s \ valid_sched s \ valid_list s \ scheduler_act_sane s \ - consumed_time_bounded s \ ct_not_blocked s \ ct_not_in_release_q s \ - current_time_bounded s \ cur_sc_chargeable s \ - (cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s) \ - (schact_is_rct s \ cur_sc_active s) \ ct_not_queued s \ - (schact_is_rct s \ ct_in_state activatable s)" - in hoare_strengthen_post[rotated]) - apply clarsimp - apply (frule ct_not_blocked_cur_sc_not_blocked, clarsimp) - apply clarsimp - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_objs_valid_tcbs - valid_sched_def cur_tcb_def ct_in_state_kh_simp[symmetric]) - apply (intro conjI; clarsimp simp: schedulable_def2 ct_in_state_def) - apply (clarsimp simp: current_time_bounded_def) - apply (rule context_conjI) - apply (clarsimp simp: cur_sc_tcb_def sc_tcb_sc_at_def obj_at_def is_sc_obj) - apply (erule (1) valid_sched_context_size_objsI) - apply clarsimp - apply (frule (1) cur_sc_chargeable_when_ct_active_sc) - apply (frule (1) active_sc_tcb_at_ct_cur_sc_active[THEN iffD2]) - apply (clarsimp simp: current_time_bounded_def) - apply (rule context_conjI) - apply (clarsimp simp: vs_all_heap_simps obj_at_def) - apply (drule consumed_time_bounded_helper) - apply clarsimp - apply clarsimp - apply wpsimp - apply (rule_tac Q'="\irq s. invs' s \ sc_at' (ksCurSc s) s \ - (\irq'. irq = Some irq' \ - intStateIRQTable (ksInterruptState s ) irq' \ IRQInactive)" - in hoare_post_imp) - apply (clarsimp simp: invs'_def valid_pspace'_def valid_objs'_valid_tcbs') - apply ((wp doMachineOp_getActiveIRQ_IRQ_active | simp)+)[1] - apply clarsimp - apply (clarsimp simp: invs'_def) - done - lemma kernel_corres': "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) - and current_time_bounded and consumed_time_bounded and valid_machine_time - and ct_not_in_release_q and cur_sc_active - and (\s. cur_sc_offset_ready (consumed_time s) s) - and (\s. cur_sc_offset_sufficient (consumed_time s) s) - and (\s. scheduler_action s = resume_cur_thread)) + and (\s. scheduler_action s = resume_cur_thread)) (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and (\s. ksSchedulerAction s = ResumeCurrentThread) and (\s. vs_valid_duplicates' (ksPSpace s))) @@ -819,155 +542,57 @@ lemma kernel_corres': (do _ \ runExceptT $ handleEvent event `~catchError~` (\_. withoutPreemption $ do - irq_opt <- doMachineOp (getActiveIRQ True); - _ \ mcsPreemptionPoint irq_opt; - when (isJust irq_opt) $ handleInterrupt (fromJust irq_opt) + irq <- doMachineOp (getActiveIRQ True); + when (isJust irq) $ handleInterrupt (fromJust irq) od); - _ \ stateAssert rct_imp_activatable'_asrt []; _ \ ThreadDecls_H.schedule; - _ \ stateAssert rct_imp_activatable'_asrt []; activateThread - od)" (is "corres _ ?P ?P' _ _") - unfolding call_kernel_def - apply add_cur_tcb' - apply (rule_tac Q="\s. obj_at' (\sc. scTCB sc = Some (ksCurThread s)) (ksCurSc s) s" in corres_cross_add_guard) - apply (fastforce simp: invs_def valid_state_def valid_pspace_def intro!: cur_sc_tcb_cross) - apply (rule_tac Q="\s'. pred_map (\tcb. \ tcbInReleaseQueue tcb) (tcbs_of' s') (ksCurThread s')" - in corres_cross_add_guard) - apply (clarsimp, frule tcb_at_invs) - apply (fastforce simp: not_in_release_q_def release_queue_relation_def pred_map_def opt_map_red obj_at'_def - invs'_def valid_pspace'_def projectKOs valid_release_queue'_def cur_tcb'_def - dest!: state_relationD) - apply (rule_tac Q="\s'. pred_map (\scPtr. isScActive scPtr s') (tcbSCs_of s') (ksCurThread s')" - in corres_cross_add_guard) - apply clarsimp - apply (frule invs_cur_sc_tcb_symref, clarsimp simp: schact_is_rct) - apply (prop_tac "sc_at (cur_sc s) s") - apply (frule invs_cur_sc_tcb) - apply (clarsimp simp: cur_sc_tcb_def sc_tcb_sc_at_def obj_at_def is_sc_obj) - apply (erule (1) valid_sched_context_size_objsI[OF invs_valid_objs]) - apply (frule (4) active_sc_at'_cross[OF _ invs_psp_aligned invs_distinct]) - apply (clarsimp simp: active_sc_at'_def obj_at'_def projectKOs cur_tcb'_def pred_tcb_at_def - is_sc_obj obj_at_def pred_map_def isScActive_def - dest!: state_relationD) - apply (rule_tac x="cur_sc s" in exI, clarsimp simp: opt_map_red) - apply (frule_tac x="ksCurThread s'" in pspace_relation_absD, simp) - apply (fastforce simp: other_obj_relation_def tcb_relation_def) - apply simp + od)" + unfolding call_kernel_def callKernel_def + apply (simp add: call_kernel_def callKernel_def) apply (rule corres_guard_imp) apply (rule corres_split) apply (rule corres_split_handle[OF handleEvent_corres]) - (* handle *) - apply (rule kernel_preemption_corres) - apply (rule_tac E'="\_ s. einvs s \ scheduler_act_sane s \ cur_sc_chargeable s \ - (schact_is_rct s \ cur_sc_active s) \ ct_not_queued s \ - (schact_is_rct s \ ct_in_state activatable s) \ - (cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s) \ - ct_not_blocked s \ current_time_bounded s \ - ct_not_in_release_q s \ consumed_time_bounded s" - in hoare_strengthen_postE[where Q=Q and R=Q for Q]) - apply (wpsimp wp: handle_event_schact_is_rct_imp_ct_activatable - handle_event_schact_is_rct_imp_cur_sc_active call_kernel_schact_is_rct - handle_event_scheduler_act_sane handle_event_ct_not_queuedE_E - handle_event_cur_sc_chargeable handle_event_cur_sc_more_than_ready - handle_event_valid_sched) apply simp - apply (clarsimp simp: cur_sc_chargeable_def) + apply (rule corres_split[OF corres_machine_op]) + apply (rule corres_underlying_trivial) + apply (rule no_fail_getActiveIRQ) + apply clarsimp + apply (rule_tac x=irq in option_corres) + apply (rule_tac P=\ and P'=\ in corres_inst) + apply (simp add: when_def) + apply (rule corres_when[simplified dc_def], simp) + apply simp + apply (rule handleInterrupt_corres[simplified dc_def]) + apply simp + apply (wpsimp wp: hoare_drop_imps hoare_vcg_all_lift simp: schact_is_rct_def)[1] + apply simp + apply (rule_tac Q'="\irq s. invs' s \ + (\irq'. irq = Some irq' \ + intStateIRQTable (ksInterruptState s ) irq' \ + IRQInactive)" + in hoare_post_imp) + apply simp + apply (wp doMachineOp_getActiveIRQ_IRQ_active handle_event_valid_sched | simp)+ apply (rule_tac Q'="\_. \" and E'="\_. invs'" in hoare_strengthen_postE) apply wpsimp+ - apply (rule_tac P="invs and valid_sched and current_time_bounded - and ct_ready_if_schedulable and scheduler_act_sane - and (\s. schact_is_rct s \ cur_sc_active s) - and (\s. schact_is_rct s \ ct_in_state activatable s) - and (\s. schact_is_rct s \ ct_not_in_release_q s) - and cur_sc_more_than_ready and consumed_time_bounded - and cur_sc_in_release_q_imp_zero_consumed" - and P'=invs' in corres_inst) - apply (rule corres_stateAssert_add_assertion) - apply (simp add: rct_imp_activatable'_asrt_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF schedule_corres]) - apply (rule_tac P="invs and valid_sched and current_time_bounded - and cur_sc_active and schact_is_rct - and ct_in_state activatable - and (\s. cur_sc_offset_ready (consumed_time s) s \ - cur_sc_offset_sufficient (consumed_time s) s)" - and P'="invs' and (\s. ksSchedulerAction s = ResumeCurrentThread)" - in corres_inst) - apply (rule corres_stateAssert_add_assertion) - apply (rule corres_guard_imp) - apply (rule activateThread_corres) - apply simp - apply simp - apply (clarsimp simp: ct_in_state_def ct_in_state'_def) - apply (drule (3) st_tcb_at_coerce_concrete[OF _ _ invs_psp_aligned invs_distinct]) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs state_relation_def) - apply (rename_tac st; case_tac st; clarsimp) - apply (wpsimp wp: schedule_valid_sched - schedule_cur_sc_active schedule_ct_activateable - schedule_cur_sc_offset_ready_and_sufficient) - apply (wpsimp wp: schedule_invs' schedule_sch) - apply clarsimp - apply clarsimp - apply (clarsimp simp: rct_imp_activatable'_asrt_def) - apply (clarsimp simp: ct_in_state_def ct_in_state'_def) - apply (prop_tac "schact_is_rct s") - apply (clarsimp simp: state_relation_def schact_is_rct_def sched_act_relation_def) - apply (case_tac "scheduler_action s"; clarsimp) - apply (drule schact_is_rct, clarsimp) - apply (frule (3) st_tcb_at_coerce_concrete[OF _ _ invs_psp_aligned invs_distinct]) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKOs state_relation_def) - apply (rename_tac st; case_tac st; clarsimp) - apply wpsimp - apply (wpsimp wp: preemption_path_valid_sched - preemption_path_current_time_bounded - preemption_point_scheduler_act_sane - preemption_path_schact_is_rct_imp_ct_not_in_release_q - preemption_path_cur_sc_more_than_ready - preemption_path_consumed_time_bounded - preemption_path_cur_sc_in_release_q_imp_zero_consumed - preemption_path_ct_ready_if_schedulable) - apply ((wpsimp wp: he_invs handle_event_valid_sched handle_event_scheduler_act_sane - handle_event_cur_sc_chargeable handle_event_schact_is_rct_imp_cur_sc_active - handle_event_schact_is_rct_imp_ct_activatable - handle_event_schact_is_rct_imp_ct_not_in_release_q - handle_event_cur_sc_in_release_q_imp_zero_consumed - | strengthen ct_not_blocked_imp_ct_not_blocked_on_receive - ct_not_blocked_imp_ct_not_blocked_on_ntfn)+)[1] - apply (wpsimp wp: he_invs') - apply (wpsimp simp: mcsPreemptionPoint_def wp: isSchedulable_wp) - apply (wpsimp wp: dmo_getirq_inv) - apply (clarsimp simp: isSchedulable_bool_def isScActive_def) - apply (rule_tac Q'="\_. invs'" and E'="\_. invs'" in hoare_strengthen_postE) - apply (wpsimp wp: he_invs') - apply simp - apply clarsimp - apply (clarsimp cong: conj_cong) - apply (intro conjI, clarsimp simp: active_from_running) - apply (rule valid_sched_ct_not_queued; clarsimp?) - apply (erule (2) cur_sc_active_ct_not_in_release_q_imp_ct_running_imp_ct_schedulable, clarsimp) - apply (clarsimp simp: ct_in_state_def pred_tcb_at_def obj_at_def cur_tcb_def is_tcb - dest!: invs_cur) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def - invs_strengthen_cur_sc_tcb_are_bound) - apply (fastforce simp: ct_in_state_def pred_tcb_at_def obj_at_def cur_tcb_def is_tcb - dest!: invs_cur) - apply (clarsimp, rule schact_is_rct_ct_released; simp?) - apply (frule (1) cur_sc_not_idle_sc_ptr') - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def - invs_strengthen_cur_sc_tcb_are_bound) - apply simp + apply (simp add: invs'_def valid_state'_def) + apply (rule corres_split[OF schedule_corres]) + apply (rule activateThread_corres) + apply (wp handle_interrupt_valid_sched[unfolded non_kernel_IRQs_def, simplified] + schedule_invs' hoare_vcg_if_lift2 hoare_drop_imps |simp)+ + apply (rule_tac Q'="\_. valid_sched and invs and valid_list" and + E'="\_. valid_sched and invs and valid_list" + in hoare_strengthen_postE) + apply (wp handle_event_valid_sched hoare_vcg_imp_lift' |simp)+ + apply (clarsimp simp: active_from_running schact_is_rct_def) apply (clarsimp simp: active_from_running') done lemma kernel_corres: - "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) - and current_time_bounded and consumed_time_bounded and valid_machine_time - and ct_not_in_release_q and cur_sc_active - and (\s. cur_sc_offset_ready (consumed_time s) s) - and (\s. cur_sc_offset_sufficient (consumed_time s) s) - and (\s. scheduler_action s = resume_cur_thread) - and valid_domain_list) + "corres dc (einvs and (\s. event \ Interrupt \ ct_running s) and (ct_running or ct_idle) and + (\s. scheduler_action s = resume_cur_thread) and + (\s. 0 < domain_time s \ valid_domain_list s)) (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') and (\s. ksSchedulerAction s = ResumeCurrentThread) and (\s. vs_valid_duplicates' (ksPSpace s))) @@ -979,7 +604,7 @@ lemma kernel_corres: apply (rule corres_add_noop_lhs2) apply (simp only: bind_assoc[symmetric]) apply (rule corres_split[where r'=dc and - R="\_ s. valid_domain_list s" and + R="\_ s. 0 < domain_time s \ valid_domain_list s" and R'="\_. \"]) apply (simp only: bind_assoc) apply (rule kernel_corres') @@ -987,7 +612,7 @@ lemma kernel_corres: apply simp apply (simp add: kernelExitAssertions_def state_relation_def) apply (wp call_kernel_domain_time_inv_det_ext call_kernel_domain_list_inv_det_ext) - apply wpsimp + apply wp apply clarsimp apply clarsimp done @@ -1004,51 +629,43 @@ lemma device_mem_corres: invs_def invs'_def corres_underlying_def device_mem_relation) -crunch thread_set - for domain_time_inv[wp]: "\s. P (domain_time s)" - lemma entry_corres: - "corres (=) - (\s. mcs_invs s \ (ct_running s \ ct_idle s) \ (event \ Interrupt \ ct_running s)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and (ct_running' or ct_idle') - and valid_domain_list' - and (\s. ksSchedulerAction s = ResumeCurrentThread) - and (\s. vs_valid_duplicates' (ksPSpace s))) - (kernel_entry event tc) (kernelEntry event tc)" + "corres (=) (einvs and (\s. event \ Interrupt \ ct_running s) and + (\s. 0 < domain_time s) and valid_domain_list and (ct_running or ct_idle) and + (\s. scheduler_action s = resume_cur_thread)) + (invs' and (\s. event \ Interrupt \ ct_running' s) and + (\s. 0 < ksDomainTime s) and valid_domain_list' and (ct_running' or ct_idle') and + (\s. ksSchedulerAction s = ResumeCurrentThread) and + (\s. vs_valid_duplicates' (ksPSpace s))) + (kernel_entry event tc) (kernelEntry event tc)" apply (simp add: kernel_entry_def kernelEntry_def) - apply add_cur_tcb' apply (rule corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_split) apply simp - apply (rule threadset_corresT) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_set_def atcbContextSet_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def) - apply (rule corres_split [OF kernel_corres]) - apply (rule_tac P=invs and P'=\ in corres_inst) - apply add_cur_tcb' - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def arch_tcb_relation_def - arch_tcb_context_get_def atcbContextGet_def) - apply wp+ - apply clarsimp - apply (clarsimp simp: cur_tcb'_def) - apply (rule hoare_strengthen_post, rule akernel_invs_det_ext, simp add: invs_def cur_tcb_def) - apply wpsimp - apply (wp thread_set_invs_trivial + apply (rule threadset_corresT; simp?) + apply (simp add: tcb_relation_def arch_tcb_relation_def + arch_tcb_context_set_def atcbContextSet_def) + apply (clarsimp simp: tcb_cap_cases_def) + apply (clarsimp simp: tcb_cte_cases_def) + apply (simp add: exst_same_def) + apply (rule corres_split[OF kernel_corres]) + apply (rule corres_split_eqr[OF getCurThread_corres]) + apply (rule threadGet_corres) + apply (simp add: tcb_relation_def arch_tcb_relation_def + arch_tcb_context_get_def atcbContextGet_def) + apply wp+ + apply (rule hoare_strengthen_post, rule akernel_invs_det_ext, fastforce simp: invs_def cur_tcb_def) + apply (rule hoare_strengthen_post, rule ckernel_invs, simp add: invs'_def cur_tcb'_def) + apply (wp thread_set_invs_trivial thread_set_ct_running threadSet_invs_trivial threadSet_ct_running' thread_set_not_state_valid_sched hoare_weak_lift_imp hoare_vcg_disj_lift ct_in_state_thread_state_lift | simp add: tcb_cap_cases_def ct_in_state'_def thread_set_no_change_tcb_state schact_is_rct_def | (wps, wp threadSet_st_tcb_at2) )+ - apply (clarsimp simp: invs_def cur_tcb_def) - apply (clarsimp simp: ct_in_state'_def cur_tcb'_def invs'_def valid_release_queue'_def - projectKOs obj_at'_def) + apply (fastforce simp: invs_def cur_tcb_def) + apply (clarsimp simp: ct_in_state'_def) done lemma corres_gets_machine_state: @@ -1058,7 +675,8 @@ lemma corres_gets_machine_state: lemma do_user_op_corres: "corres (=) (einvs and ct_running) - invs' + (invs' and (%s. ksSchedulerAction s = ResumeCurrentThread) and + ct_running') (do_user_op f tc) (doUserOp f tc)" apply (simp add: do_user_op_def doUserOp_def split_def) apply (rule corres_guard_imp) @@ -1111,22 +729,25 @@ lemma ct_idle_related: done definition - "full_invs' - \ {((tc,s),m,e). invs' s \ vs_valid_duplicates' (ksPSpace s) - \ ex_abs (\s :: det_state. mcs_invs s - \ (ct_running s \ ct_idle s) - \ (e \ None \ e \ Some Interrupt \ ct_running s)) s - \ (m = KernelMode \ e \ None) - \ (m = UserMode \ ct_running' s) - \ (m = IdleMode \ ct_idle' s)}" + "full_invs' \ {((tc,s),m,e). invs' s \ vs_valid_duplicates' (ksPSpace s) \ + ex_abs (einvs::det_ext state \ bool) s \ + ksSchedulerAction s = ResumeCurrentThread \ + (ct_running' s \ ct_idle' s) \ + (m = KernelMode \ e \ None) \ + (m = UserMode \ ct_running' s) \ + (m = IdleMode \ ct_idle' s) \ + (e \ None \ e \ Some Interrupt \ ct_running' s) \ + 0 < ksDomainTime s \ valid_domain_list' s}" lemma checkActiveIRQ_valid_duplicates': - "checkActiveIRQ \\s. vs_valid_duplicates' (ksPSpace s)\" + "\\s. vs_valid_duplicates' (ksPSpace s)\ + checkActiveIRQ + \\_ s. vs_valid_duplicates' (ksPSpace s)\" apply (simp add: checkActiveIRQ_def) apply wp done -lemma checkActiveIRQ_corres': +lemma check_active_irq_corres': "corres (=) \ \ (check_active_irq) (checkActiveIRQ)" apply (simp add: check_active_irq_def checkActiveIRQ_def) apply (rule corres_guard_imp) @@ -1136,43 +757,48 @@ lemma checkActiveIRQ_corres': apply (wp | simp )+ done -lemma checkActiveIRQ_corres: +lemma check_active_irq_corres: "corres (=) (invs and (ct_running or ct_idle) and einvs and (\s. scheduler_action s = resume_cur_thread) - and valid_domain_list) - (invs' and (\s. vs_valid_duplicates' (ksPSpace s))) + and (\s. 0 < domain_time s) and valid_domain_list) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) + and (\s. 0 < ksDomainTime s) and valid_domain_list' and (ct_running' or ct_idle') + and (\s. vs_valid_duplicates' (ksPSpace s))) (check_active_irq) (checkActiveIRQ)" apply (rule corres_guard_imp) - apply (rule checkActiveIRQ_corres', auto) + apply (rule check_active_irq_corres', auto) done lemma checkActiveIRQ_just_running_corres: "corres (=) (invs and ct_running and einvs and (\s. scheduler_action s = resume_cur_thread) - and valid_domain_list) - (invs' and (\s. vs_valid_duplicates' (ksPSpace s))) + and (\s. 0 < domain_time s) and valid_domain_list) + (invs' and ct_running' and (\s. vs_valid_duplicates' (ksPSpace s)) + and (\s. 0 < ksDomainTime s) and valid_domain_list' + and (\s. ksSchedulerAction s = ResumeCurrentThread)) (check_active_irq) (checkActiveIRQ)" apply (rule corres_guard_imp) - apply (rule checkActiveIRQ_corres', auto) + apply (rule check_active_irq_corres', auto) done lemma checkActiveIRQ_just_idle_corres: "corres (=) (invs and ct_idle and einvs and (\s. scheduler_action s = resume_cur_thread) - and valid_domain_list) + and (\s. 0 < domain_time s) and valid_domain_list) (invs' and ct_idle' and (\s. vs_valid_duplicates' (ksPSpace s)) - and valid_domain_list' + and (\s. 0 < ksDomainTime s) and valid_domain_list' and (\s. ksSchedulerAction s = ResumeCurrentThread)) (check_active_irq) (checkActiveIRQ)" apply (rule corres_guard_imp) - apply (rule checkActiveIRQ_corres', auto) + apply (rule check_active_irq_corres', auto) done lemma checkActiveIRQ_invs': "\invs' and ex_abs invs and (ct_running' or ct_idle') and (\s. ksSchedulerAction s = ResumeCurrentThread)\ checkActiveIRQ - \\_. invs' and (ct_running' or ct_idle') and (\s. ksSchedulerAction s = ResumeCurrentThread)\" + \\_. invs' and (ct_running' or ct_idle') + and (\s. ksSchedulerAction s = ResumeCurrentThread)\" apply (simp add: checkActiveIRQ_def ex_abs_def) apply (wp dmo_invs' | simp)+ done @@ -1181,7 +807,8 @@ lemma checkActiveIRQ_invs'_just_running: "\invs' and ex_abs invs and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)\ checkActiveIRQ - \\_. invs' and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)\" + \\_. invs' and ct_running' + and (\s. ksSchedulerAction s = ResumeCurrentThread)\" apply (simp add: checkActiveIRQ_def) apply (wp | simp)+ done @@ -1190,7 +817,8 @@ lemma checkActiveIRQ_invs'_just_idle: "\invs' and ex_abs invs and ct_idle' and (\s. ksSchedulerAction s = ResumeCurrentThread)\ checkActiveIRQ - \\_. invs' and ct_idle' and (\s. ksSchedulerAction s = ResumeCurrentThread)\" + \\_. invs' and ct_idle' + and (\s. ksSchedulerAction s = ResumeCurrentThread)\" apply (simp add: checkActiveIRQ_def) apply (wp | simp)+ done @@ -1200,11 +828,6 @@ lemma sched_act_rct_related: \ scheduler_action a = resume_cur_thread" by (case_tac "scheduler_action a", simp_all add: state_relation_def) -lemma resume_cur_thread_cross: - "\ (a, c) \ state_relation; scheduler_action a = resume_cur_thread\ - \ ksSchedulerAction c = ResumeCurrentThread" - by (case_tac "scheduler_action a", simp_all add: state_relation_def) - lemma domain_time_rel_eq: "(a, c) \ state_relation \ P (ksDomainTime c) = P (domain_time a)" by (clarsimp simp: state_relation_def) @@ -1213,28 +836,6 @@ lemma domain_list_rel_eq: "(a, c) \ state_relation \ P (ksDomSchedule c) = P (domain_list a)" by (clarsimp simp: state_relation_def) -lemma ct_running_cross: - "\(a,c) \ state_relation; ct_running a; pspace_aligned a; pspace_distinct a\ \ ct_running' c" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def) - apply (frule st_tcb_at_coerce_concrete) - apply fastforce+ - apply (clarsimp simp: obj_at_simps state_relation_def) - done - -lemma ct_idle_cross: - "\(a,c) \ state_relation; ct_idle a; pspace_aligned a; pspace_distinct a\ \ ct_idle' c" - apply (clarsimp simp: ct_in_state_def ct_in_state'_def) - apply (frule st_tcb_at_coerce_concrete) - apply fastforce+ - apply (clarsimp simp: obj_at_simps state_relation_def) - done - -lemma ct_running_or_idle_cross: - "\(a,c) \ state_relation; ct_running a \ ct_idle a; pspace_aligned a; pspace_distinct a\ - \ ct_running' c \ ct_idle' c" - apply (fastforce dest: ct_running_cross ct_idle_cross) - done - lemma ckernel_invariant: "ADT_H uop \ full_invs'" unfolding full_invs'_def @@ -1251,65 +852,28 @@ lemma ckernel_invariant: apply (frule akernel_init_invs[THEN bspec]) apply (rule_tac x = s in exI) apply (clarsimp simp: Init_A_def) - - apply (clarsimp simp: Init_A_def init_A_st_def) - apply (insert ckernel_init_invs)[1] apply clarsimp apply (frule ckernel_init_sch_norm) apply (frule ckernel_init_ctr) apply (frule ckernel_init_domain_time) apply (frule ckernel_init_domain_list) - apply (clarsimp simp: ex_abs_def) apply (fastforce simp: Init_H_def valid_domain_list'_def) - apply (clarsimp simp: ADT_A_def ADT_H_def global_automaton_def) apply (erule_tac P="a \ (\x. b x)" for a b in disjE) - apply (clarsimp simp: ex_abs_def kernel_call_H_def) - apply (rename_tac uc' conc_state' uc conc_state abs_state event) - apply (drule use_valid[OF _ valid_corres_combined]) - apply (rule kernel_entry_invs) - apply (rule corres_guard_imp) - apply (rule entry_corres) - apply force - apply force - apply (rule hoare_weaken_pre) - apply (rule kernelEntry_invs') - apply clarsimp - apply (rename_tac s' s; intro conjI) - apply (prop_tac "cur_sc s = ksCurSc s'", fastforce dest!: state_relationD) - apply (prop_tac "sc_at (cur_sc s) s") - apply (rule cur_sc_tcb_sc_at_cur_sc[OF invs_valid_objs invs_cur_sc_tcb]; simp) - apply (prop_tac "sc_at' (ksCurSc s') s'") - apply (rule sc_at_cross[OF state_relation_pspace_relation invs_psp_aligned invs_distinct]; simp) - apply (prop_tac "is_active_sc' (ksCurSc s') s'") - apply (rule is_active_sc'2_cross[OF _ invs_psp_aligned invs_distinct], simp+) - - apply (clarsimp simp: invs'_def valid_pspace'_def, rule sym_refs_tcbSCs; simp?) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def state_refs_of_cross_eq) - apply (fastforce dest!: cur_sc_tcb_cross[simplified schact_is_rct_def] - simp: invs_def valid_state_def valid_pspace_def) - apply (clarsimp simp: invs'_def valid_release_queue'_def) - apply (prop_tac "cur_tcb' s'") - apply (rule cur_tcb_cross[OF invs_cur invs_psp_aligned invs_distinct]; simp?) - apply (clarsimp simp: cur_tcb'_def) - apply (clarsimp simp: pred_map_def obj_at'_def projectKOs opt_map_red not_in_release_q_def - release_queue_relation_def - dest!: state_relationD) - apply clarsimp - apply (rule_tac x=abs_state in exI) - apply (intro conjI; (clarsimp; fail)?) - subgoal by (fastforce intro: ct_running_cross) - apply (rule ct_running_or_idle_cross; simp?; fastforce) - subgoal by (fastforce intro!: resume_cur_thread_cross) + apply (clarsimp simp: kernel_call_H_def) - apply clarsimp - apply (intro conjI impI) - apply metis - apply metis - apply (fastforce dest!: ct_running_or_idle_cross) + apply (drule use_valid[OF _ valid_corres_combined + [OF kernel_entry_invs entry_corres], + OF _ kernelEntry_invs'[THEN hoare_weaken_pre]]) + subgoal by fastforce + apply (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related + sched_act_rct_related) + apply (clarsimp simp: kernel_call_H_def) + subgoal by (fastforce simp: ex_abs_def sch_act_simple_def ct_running_related ct_idle_related + sched_act_rct_related) apply (erule_tac P="a \ b" for a b in disjE) apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) @@ -1319,13 +883,11 @@ lemma ckernel_invariant: apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) apply clarsimp apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (clarsimp simp: ex_abs_def) - apply (rule conjI) - apply metis - apply (fastforce intro: resume_cur_thread_cross ct_running_cross) + apply (fastforce simp: ex_abs_def) apply (clarsimp simp: ex_abs_def, rule_tac x=s in exI, - clarsimp simp: ct_running_related sched_act_rct_related) - apply (fastforce simp: ex_abs_def) + clarsimp simp: ct_running_related sched_act_rct_related) + apply (clarsimp simp: ex_abs_def) + apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related) apply (erule_tac P="a \ b \ c \ (\x. d x)" for a b c d in disjE) apply (clarsimp simp add: do_user_op_H_def monad_to_transition_def) @@ -1335,10 +897,7 @@ lemma ckernel_invariant: apply (rule valid_corres_combined[OF do_user_op_invs2 corres_guard_imp2[OF do_user_op_corres]]) apply clarsimp apply (rule doUserOp_invs'[THEN hoare_weaken_pre]) - apply (clarsimp simp: ex_abs_def) - apply (rule conjI) - apply metis - apply (fastforce intro: resume_cur_thread_cross ct_running_cross) + apply (fastforce simp: ex_abs_def) apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related) apply (fastforce simp: ex_abs_def) @@ -1347,13 +906,9 @@ lemma ckernel_invariant: apply (drule use_valid) apply (rule hoare_vcg_conj_lift) apply (rule checkActiveIRQ_valid_duplicates') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_running corres_guard_imp2[OF checkActiveIRQ_just_running_corres]]) - apply clarsimp + apply (rule valid_corres_combined[OF check_active_irq_invs_just_running checkActiveIRQ_just_running_corres]) apply (rule checkActiveIRQ_invs'_just_running[THEN hoare_weaken_pre]) - apply (clarsimp simp: ex_abs_def) - apply (rule conjI) - apply blast - apply (fastforce intro: resume_cur_thread_cross ct_running_cross) + apply (fastforce simp: ex_abs_def) apply (fastforce simp: ex_abs_def ct_running_related sched_act_rct_related) apply (fastforce simp: ex_abs_def) @@ -1362,32 +917,22 @@ lemma ckernel_invariant: apply (drule use_valid) apply (rule hoare_vcg_conj_lift) apply (rule checkActiveIRQ_valid_duplicates') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle corres_guard_imp2[OF checkActiveIRQ_just_idle_corres]]) - apply clarsimp + apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle checkActiveIRQ_just_idle_corres]) apply (rule checkActiveIRQ_invs'_just_idle[THEN hoare_weaken_pre]) + apply clarsimp apply (fastforce simp: ex_abs_def) - apply (clarsimp simp: ex_abs_def) - apply (rule_tac x=s in exI) - apply clarsimp - apply (intro conjI) - apply (fastforce intro: ct_idle_related) - apply (fastforce intro: resume_cur_thread_cross) + apply (fastforce simp: ex_abs_def ct_idle_related sched_act_rct_related) apply (fastforce simp: ex_abs_def) apply (clarsimp simp: check_active_irq_H_def) apply (drule use_valid) - apply (rule hoare_vcg_conj_lift) + apply (rule hoare_vcg_conj_lift) apply (rule checkActiveIRQ_valid_duplicates') - apply (rule valid_corres_combined[OF check_active_irq_invs_just_idle corres_guard_imp2[OF checkActiveIRQ_just_idle_corres]]) - apply clarsimp - apply (rule checkActiveIRQ_invs'_just_idle[THEN hoare_weaken_pre]) - apply (fastforce simp: ex_abs_def) - apply (clarsimp simp: ex_abs_def) - apply (rule_tac x=s in exI) - apply clarsimp - apply (intro conjI) - apply (fastforce intro: ct_idle_related) - apply (fastforce intro: resume_cur_thread_cross) + apply (rule valid_corres_combined[OF check_active_irq_invs check_active_irq_corres]) + apply (rule checkActiveIRQ_invs'[THEN hoare_weaken_pre]) + apply clarsimp + apply (fastforce simp: ex_abs_def) + apply (fastforce simp: ex_abs_def ct_running_related ct_idle_related sched_act_rct_related) apply (fastforce simp: ex_abs_def) done @@ -1408,28 +953,26 @@ lemma fw_sim_A_H: apply (erule_tac P="a \ (\x. b x)" for a b in disjE) apply (clarsimp simp add: kernel_call_H_def kernel_call_A_def) - apply (rename_tac abs_state uc' conc_state' conc_state event) - apply (rule rev_mp, rule_tac tc=tc and event=event in entry_corres) + apply (rule rev_mp, rule_tac tc=tc and event=x in entry_corres) apply (clarsimp simp: corres_underlying_def) - apply (drule_tac x="(abs_state, conc_state)" in bspec, blast) + apply (drule (1) bspec) + apply (clarsimp simp: sch_act_simple_def) + apply (drule (1) bspec) apply clarsimp - apply (frule (1) ct_running_or_idle_cross; clarsimp) - apply (prop_tac "event \ Interrupt \ ct_running' conc_state", fastforce dest!: ct_running_cross) - apply (prop_tac "valid_domain_list' conc_state \ ksSchedulerAction conc_state = ResumeCurrentThread") - apply (clarsimp simp: state_relation_def) - apply clarsimp - apply (drule_tac x="(uc', conc_state')" in bspec, blast) - apply clarsimp - apply (frule use_valid[OF _ kernel_entry_invs]) - apply force - apply (rename_tac abs_state') - apply (intro conjI impI allI; simp) - apply (rule_tac x=abs_state' in exI) - apply (prop_tac "ct_running abs_state'", rule ct_running_related; simp) + apply (rule conjI) + apply clarsimp + apply (rule_tac x=b in exI) + apply (rule conjI) + apply (rule impI, simp) + apply (frule (2) ct_running_related) apply clarsimp - apply (rule_tac x=abs_state' in exI) + apply (rule_tac x=b in exI) + apply (drule use_valid, rule kernelEntry_invs') + apply (simp add: sch_act_simple_def) apply clarsimp - apply (drule_tac a=abs_state' in ct_running_cross; clarsimp) + apply (frule (1) ct_idle_related) + apply (clarsimp simp: ct_in_state_def st_tcb_at_def obj_at_def) + apply (erule_tac P="a \ b" for a b in disjE) apply (clarsimp simp: do_user_op_H_def do_user_op_A_def monad_to_transition_def) apply (rule rev_mp, rule_tac tc1=tc and f1=uop and P="ct_running and einvs" in corres_guard_imp2[OF do_user_op_corres]) @@ -1450,20 +993,20 @@ lemma fw_sim_A_H: apply (erule_tac P="a \ b" for a b in disjE) apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule checkActiveIRQ_corres') + apply (rule rev_mp, rule check_active_irq_corres) apply (clarsimp simp: corres_underlying_def) apply fastforce apply (erule_tac P="a \ b" for a b in disjE) apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule checkActiveIRQ_corres') + apply (rule rev_mp, rule check_active_irq_corres) apply (clarsimp simp: corres_underlying_def) apply fastforce apply (clarsimp simp: check_active_irq_H_def check_active_irq_A_def) - apply (rule rev_mp, rule checkActiveIRQ_corres') + apply (rule rev_mp, rule check_active_irq_corres) apply (clarsimp simp: corres_underlying_def) - apply fastforce + apply fastforce apply (clarsimp simp: absKState_correct dest!: lift_state_relationD) done diff --git a/proof/refine/ARM/Reply_R.thy b/proof/refine/ARM/Reply_R.thy deleted file mode 100644 index d28d035942..0000000000 --- a/proof/refine/ARM/Reply_R.thy +++ /dev/null @@ -1,1829 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory Reply_R -imports Schedule_R -begin - -defs replyUnlink_assertion_def: - "replyUnlink_assertion - \ \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 valid_queues[wp]: "valid_queues" - 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" - by typ_at_props' - -lemma updateReply_replyNext_reply_projs[wp]: - "\\s. P ((replyNexts_of s)(rptr := getReplyNextPtr next)) (replyPrevs_of s) - (replyTCBs_of s) ((replySCs_of s)(rptr := getHeadScPtr next))\ - updateReply rptr (replyNext_update (\_. next)) - \\_ s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)\" - unfolding updateReply_def - apply wpsimp - apply (erule rsubst4[where P=P]) - apply (clarsimp simp: ext opt_map_def obj_at'_def projectKO_eq)+ - done - -lemma updateReply_replyPrev_reply_projs[wp]: - "\\s. P (replyNexts_of s) ((replyPrevs_of s)(rptr := prev)) - (replyTCBs_of s) (replySCs_of s)\ - updateReply rptr (replyPrev_update (\_. prev)) - \\_ s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)\" - unfolding updateReply_def - apply wpsimp - apply (erule rsubst4[where P=P]) - apply (clarsimp simp: ext opt_map_def obj_at'_def projectKO_eq)+ - done - -lemma updateReply_replyTCB_reply_projs[wp]: - "\\s. P (replyNexts_of s) (replyPrevs_of s) - ((replyTCBs_of s)(rptr := tptrOpt)) (replySCs_of s)\ - updateReply rptr (replyTCB_update (\_. tptrOpt)) - \\_ s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)\" - unfolding updateReply_def - apply wpsimp - apply (erule rsubst4[where P=P]) - apply (clarsimp simp: ext opt_map_def obj_at'_def projectKO_eq)+ - done - -lemma updateReply_reply_projs: - "\\s. \ko. ko_at' ko rptr s \ - P (\a. if a = rptr then replyNext_of (f ko) else replyNexts_of s a) - (\a. if a = rptr then replyPrev (f ko) else replyPrevs_of s a) - (\a. if a = rptr then replyTCB (f ko) else replyTCBs_of s a) - (\a. if a = rptr then replySC (f ko) else replySCs_of s a)\ - updateReply rptr f - \\_ s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)\" - unfolding updateReply_def - by wpsimp - -lemma updateReply_list_refs_of_replies'_inv: - "\ko. replyNext_of (f ko) = replyNext_of ko \ - \ko. replyPrev (f ko) = replyPrev ko \ - updateReply rptr f \\s. P (list_refs_of_replies' s)\" - unfolding updateReply_def - apply wpsimp - apply (erule rsubst[where P=P]) - apply (rule ext) - apply (clarsimp simp: list_refs_of_reply'_def obj_at'_def projectKO_eq - list_refs_of_replies'_def opt_map_def - split: option.splits) - done - -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" - by typ_at_props' - -lemma replyUnlink_st_tcb_at': - "\\s. tcb_at' t s \ (t' = t \ P (P' Inactive)) \ (t' \ t \ P (st_tcb_at' P' t' s))\ - replyUnlink r t - \\rv s. P (st_tcb_at' P' t' s)\" - unfolding replyUnlink_def - by (wpsimp wp: sts_st_tcb_at'_cases_strong gts_wp' hoare_vcg_imp_lift - cong: conj_cong split: if_split_asm) - -lemma replyUnlink_st_tcb_at'_sym_ref: - "\\s. reply_at' rptr s \ - obj_at' (\reply. replyTCB reply = Some tptr) rptr s \ test Inactive\ - replyUnlink rptr tptr - \\_. st_tcb_at' test tptr\" - apply (wpsimp simp: replyUnlink_def - wp: sts_st_tcb_at'_cases gts_wp') - apply (fastforce simp: obj_at'_def projectKOs) - done - -lemma replyRemoveTCB_st_tcb_at'_Inactive': - "\\\ - replyRemoveTCB tptr - \\_. st_tcb_at' ((=) Inactive) tptr\" - unfolding replyRemoveTCB_def - apply (wpsimp wp: replyUnlink_st_tcb_at' hoare_vcg_if_lift split_del: if_split) - done - -lemma replyRemoveTCB_st_tcb_at'[wp]: - "P Inactive \ \\\ replyRemoveTCB t \\rv. st_tcb_at' P t\" - apply (rule hoare_strengthen_post) - apply (rule replyRemoveTCB_st_tcb_at'_Inactive') - apply (clarsimp elim!: pred_tcb'_weakenE) - done - -lemma replyRemoveTCB_st_tcb_at'_cases: - "\\s. (t = t' \ Q (P Inactive)) \ (t \ t' \ Q (st_tcb_at' P t s))\ - replyRemoveTCB t' - \\_ s. Q (st_tcb_at' P t s)\" - unfolding replyRemoveTCB_def cleanReply_def - by (wpsimp wp: replyUnlink_st_tcb_at' gts_wp' hoare_vcg_imp_lift') - -lemma replyPop_st_tcb_at'_Inactive: - "\\\ replyPop replyPtr tcbPtr \\_. st_tcb_at' ((=) Inactive) tcbPtr\" - apply (clarsimp simp: replyPop_def) - by (wpsimp wp: replyUnlink_st_tcb_at' hoare_vcg_if_lift) - -lemma replyPop_st_tcb_at'[wp]: - "P Inactive \ \\\ replyPop r t \\rv. st_tcb_at' P t\" - apply (rule hoare_strengthen_post) - apply (rule replyPop_st_tcb_at'_Inactive) - apply (clarsimp elim!: pred_tcb'_weakenE) - done - -lemma replyRemove_st_tcb_at'_Inactive: - "\\\ replyRemove replyPtr tcbPtr \\_. st_tcb_at' ((=) Inactive) tcbPtr\" - apply (clarsimp simp: replyRemove_def) - by (wpsimp wp: replyUnlink_st_tcb_at' hoare_vcg_if_lift) - -lemma replyRemove_st_tcb_at'[wp]: - "P Inactive \ \\\ replyRemove r t \\rv. st_tcb_at' P t\" - apply (rule hoare_strengthen_post) - apply (rule replyRemove_st_tcb_at'_Inactive) - apply (clarsimp elim!: pred_tcb'_weakenE) - done - -lemma replyUnlink_tcb_obj_at'_no_change: - "\(\s. P (obj_at' Q tptr s)) and - K (\tcb st. (Q (tcbState_update (\_. Inactive) tcb) = Q tcb) \ - (Q (tcbState_update (\_. replyObject_update Map.empty st) tcb) = Q tcb) \ - (Q (tcbQueued_update (\_. True) tcb) = Q tcb))\ - replyUnlink rptr tptr' - \\_ s. P (obj_at' Q tptr s)\" - unfolding replyUnlink_def scheduleTCB_def rescheduleRequired_def - updateReply_def - apply (rule hoare_gen_asm) - apply (wpsimp wp: setThreadState_tcb_obj_at'_no_change gts_wp') - done - -lemma replyRemoveTCB_st_tcb_at'_sym_ref: - "\(\s. tcb_at' tptr s \ - (\rptr. st_tcb_at' (\st. replyObject st = Some rptr) tptr s \ reply_at' rptr s \ - obj_at' (\reply. replyTCB reply = Some tptr) rptr s)) - and (K (test Inactive))\ - replyRemoveTCB tptr - \\_. st_tcb_at' test tptr\" - unfolding replyRemoveTCB_def cleanReply_def updateReply_def - apply (rule hoare_gen_asm) - supply set_reply'.get_wp[wp del] set_reply'.get_wp_state_only[wp] set_reply'.get_wp_rv_only[wp] - apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_all_lift replyUnlink_st_tcb_at'_sym_ref - set_reply'.set_no_update[where upd="\r. (replyNext_update Map.empty - (replyPrev_update Map.empty r))"] - set_reply'.set_no_update[where upd="\r. (replyNext_update Map.empty r)"] - set_reply'.set_no_update[where upd="\r. (replyPrev_update Map.empty r)"] - hoare_vcg_imp_lift set_reply'.get_ko_at' haskell_assert_inv - simp: disj_imp) - apply (rule_tac Q'="\_. obj_at' (\r. replyTCB r = Some tptr) rptr" in hoare_post_imp, - clarsimp) - apply wp - apply (rule_tac Q'="\_. obj_at' (\r. replyTCB r = Some tptr) rptr" in hoare_post_imp, - clarsimp) - apply (wpsimp wp: gts_wp')+ - apply (clarsimp simp: obj_at'_def pred_tcb_at'_def) - 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 valid_inQ_queues[wp]: valid_inQ_queues - and 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 valid_queues[wp]: valid_queues - 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)" - and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" - and 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 valid_mdb'[wp]: "valid_mdb'" - (wp: crunch_wps updateReply_list_refs_of_replies'_inv simp: crunch_simps) - -lemma replyUnlink_reply_projs[wp]: - "\\s. P (replyNexts_of s) (replyPrevs_of s) - ((replyTCBs_of s)(rptr := None)) (replySCs_of s)\ - replyUnlink rptr tptr - \\_ s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)\" - unfolding replyUnlink_def - apply (wpsimp wp: gts_wp') - apply (erule rsubst4[where P=P]) - apply (clarsimp simp: ext)+ - done - -lemma setReply_valid_pde_mappings'[wp]: - "setReply p r \valid_pde_mappings'\" - unfolding valid_pde_mappings'_def setReply_def - apply (wpsimp wp: hoare_vcg_all_lift) - done - -lemma updateReply_valid_objs': - "\valid_objs' and (\s. \r. valid_reply' r s \ valid_reply' (upd r) s)\ - updateReply rptr upd - \\_. valid_objs'\" - unfolding updateReply_def - apply wpsimp - apply (frule(1) reply_ko_at_valid_objs_valid_reply') - 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]: - "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) - apply (clarsimp simp: valid_reply'_def) - done - -lemma setReply_valid_replies': - "\\s. valid_replies' s - \ (replyNext_of reply \ None \ replyPrev reply \ None \ - (\tptr. replyTCB reply = Some tptr - \ st_tcb_at' - ((=) (Structures_H.thread_state.BlockedOnReply (Some rptr))) - tptr s))\ - setReply rptr reply - \\_. valid_replies'\" - unfolding valid_replies'_def - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_ex_lift) - apply auto - done - -lemma updateReply_valid_replies': - "\\s. valid_replies' s - \ (\reply. ko_at' reply rptr s \ - (replyNext_of (f reply) \ None \ replyPrev (f reply) \ None \ - (\tptr. replyTCB (f reply) = Some tptr - \ st_tcb_at' - ((=) (Structures_H.thread_state.BlockedOnReply (Some rptr))) - tptr s)))\ - updateReply rptr f - \\_. valid_replies'\" - unfolding updateReply_def - by (wpsimp wp: setReply_valid_replies') - -lemma updateReply_valid_replies'_not_linked: - "\\s. valid_replies' s - \ (\reply. ko_at' reply rptr s \ - replyNext_of (f reply) = None \ replyPrev (f reply) = None)\ - updateReply rptr f - \\_. valid_replies'\" - apply (wpsimp wp: updateReply_valid_replies') - by auto - -lemma updateReply_valid_replies'_bound: - "\\s. valid_replies' s - \ (\reply. ko_at' reply rptr s \ - (\tptr. replyTCB (f reply) = Some tptr - \ st_tcb_at' ((=) (BlockedOnReply (Some rptr))) tptr s))\ - updateReply rptr f - \\_. valid_replies'\" - by (wpsimp wp: updateReply_valid_replies') - -lemma updateReply_valid_replies'_except: - "\valid_replies'\ - updateReply rptr f - \\_. valid_replies'_except {rptr}\" - unfolding valid_replies'_def valid_replies'_except_def - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_ex_lift updateReply_reply_projs) - apply (auto simp: opt_map_def) - done - -lemma replyUnlink_valid_replies'[wp]: - "\\s. replyTCBs_of s rptr = Some tptr - \ valid_replies' s \ \ is_reply_linked rptr s\ - replyUnlink rptr tptr - \\_. valid_replies'\" - unfolding replyUnlink_def - 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 projectKOs - replyUnlink_assertion_def) - by (auto simp: opt_map_def split: option.splits) - -lemma replyUnlink_valid_pspace'[wp]: - "\\s. valid_pspace' s \ - (replyTCBs_of s rptr = Some tptr \ \ is_reply_linked rptr s)\ - replyUnlink rptr tptr - \\_. valid_pspace'\" - by (wpsimp simp: valid_pspace'_def) - -lemma replyUnlink_valid_idle'[wp]: - "\valid_idle' and (\s. tptr \ ksIdleThread s)\ - replyUnlink rptr tptr - \\_. valid_idle'\" - unfolding replyUnlink_def replyUnlink_assertion_def updateReply_def - by (wpsimp wp: hoare_vcg_imp_lift') - -lemma decompose_list_refs_of_replies': - "list_refs_of_replies' s - = (\r. get_refs ReplyPrev (replyPrevs_of s r) \ get_refs ReplyNext (replyNexts_of s r))" - apply (fastforce simp: opt_map_def map_set_def list_refs_of_reply'_def - split: option.splits) - done - -lemma cleanReply_reply_projs[wp]: - "\\s. P ((replyNexts_of s)(rptr := None)) ((replyPrevs_of s)(rptr := None)) - (replyTCBs_of s) ((replySCs_of s)(rptr := None))\ - cleanReply rptr - \\_ s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)\" - unfolding cleanReply_def updateReply_def - apply (wpsimp wp: set_reply'.set_wp) - apply (erule rsubst4[where P=P]) - apply (clarsimp simp: ext opt_map_def obj_at'_def projectKO_eq - split: option.splits)+ - done - -lemma cleanReply_valid_objs'[wp]: - "cleanReply rptr \valid_objs'\" - unfolding cleanReply_def - apply (wpsimp wp: updateReply_valid_objs' - simp: valid_reply'_def) - done - -lemma cleanReply_valid_replies'[wp]: - "cleanReply rptr \valid_replies'\" - unfolding valid_replies'_def - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_ex_lift) - apply (auto simp: opt_map_def) - done - -crunch replyRemoveTCB - for ctes_of[wp]: "\s. P (ctes_of s)" - and aligned'[wp]: pspace_aligned' - and distinct'[wp]: pspace_distinct' - and bounded'[wp]: pspace_bounded' - 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)" - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - and ksInterruptState[wp]: "\s. P (ksInterruptState s)" - and ksMachineState[wp]: "\s. P (ksMachineState s)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and sch_act_simple[wp]: "sch_act_simple" - and valid_pde_mappings'[wp]: "valid_pde_mappings'" - and untyped_ranges_zero'[wp]: "untyped_ranges_zero'" - and ifunsafe'[wp]: "if_unsafe_then_cap'" - and global_refs'[wp]: "valid_global_refs'" - and valid_arch'[wp]: "valid_arch_state'" - 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 valid_queues'[wp]: valid_queues' - and valid_queues[wp]: valid_queues - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - and cap_to': "ex_nonz_cap_to' t" - and pspace_domain_valid[wp]: pspace_domain_valid - and valid_mdb'[wp]: valid_mdb' - (wp: crunch_wps hoare_vcg_if_lift valid_mdb'_lift - simp: pred_tcb_at'_def if_distribR if_bool_eq_conj) - -global_interpretation replyUnlink: typ_at_all_props' "replyUnlink replyPtr tcbPtr" - by typ_at_props' - -lemma replyRemoveTCB_valid_objs'[wp]: - "replyRemoveTCB tptr \valid_objs'\" - unfolding replyRemoveTCB_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' - simp: valid_reply'_def) - apply (clarsimp simp: valid_reply'_def if_bool_eq_conj if_distribR) - apply (case_tac "replyPrev ko = None"; clarsimp) - apply (drule(1) sc_ko_at_valid_objs_valid_sc', - clarsimp simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps)+ - done - -lemma updateReply_prev_None_valid_replies'[wp]: - "updateReply p (replyPrev_update (\_. None)) \valid_replies'\" - unfolding valid_replies'_def - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_ex_lift) - by auto - -lemma updateReply_next_None_valid_replies'[wp]: - "updateReply p (replyNext_update (\_. None)) \valid_replies'\" - unfolding valid_replies'_def - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_ex_lift) - by auto - -lemma replyRemoveTCB_valid_replies'[wp]: - "\valid_replies' and pspace_distinct' and pspace_aligned'\ - replyRemoveTCB tptr - \\_. valid_replies'\" - unfolding replyRemoveTCB_def - by (wpsimp wp: hoare_vcg_if_lift hoare_vcg_imp_lift gts_wp') - -lemma replyRemoveTCB_valid_pspace'[wp]: - "replyRemoveTCB tptr \valid_pspace'\" - 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 projectKO_reply) - 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) - -lemma replyUnlink_iflive'[wp]: - "replyUnlink rptr tptr \if_live_then_nonz_cap'\" - unfolding replyUnlink_def - apply (wpsimp wp: updateReply_iflive' gts_wp' simp: live_reply'_def) - done - -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]: - "replyRemoveTCB tptr \if_live_then_nonz_cap'\" - unfolding replyRemoveTCB_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 prev_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 projectKO_eq project_inject) - 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 projectKO_eq project_inject) - 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 - apply (wpsimp wp: updateReply_valid_objs' simp: valid_reply'_def) - done - -lemma cleanReply_list_refs_of_replies': - "\\s. P ((list_refs_of_replies' s)(rptr := {}))\ - cleanReply rptr - \\_ s. P (list_refs_of_replies' s)\" - unfolding cleanReply_def decompose_list_refs_of_replies' - apply wpsimp - apply (erule rsubst[where P=P]) - apply (rule ext) - apply (clarsimp simp: list_refs_of_reply'_def fun_upd_def) - done - -lemma isHead_to_head: - "isHead x = (\scPtr. x = Some (Head scPtr))" - "(\scPtr. y \ Head scPtr) = (\rPtr. y = Next rPtr)" - apply (clarsimp simp: isHead_def split: option.split reply_next.split) - apply (case_tac y; clarsimp) - done - -lemma ks_reply_at'_repliesD: - "\replies_of' s rptr = Some reply; sym_refs (list_refs_of_replies' s)\ - \ replyNexts_of s rptr = replyNext_of reply - \ (case replyNext_of reply of - Some next \ replyPrevs_of s next = Some rptr - | None \ \rptr'. replyPrevs_of s rptr' \ Some rptr) - \ replyPrevs_of s rptr = replyPrev reply - \ (case replyPrev reply of - Some prev \ replyNexts_of s prev = Some rptr - | None \ \rptr'. replyNexts_of s rptr' \ Some rptr)" - apply (prop_tac "replyNexts_of s rptr = replyNext_of reply - \ replyPrevs_of s rptr = replyPrev reply ") - apply (clarsimp simp: opt_map_def) - apply (case_tac "replyNext_of reply" - ; case_tac "replyPrev reply" - ; clarsimp simp: sym_refs_replyNext_None sym_refs_replyPrev_None - sym_refs_replyNext_replyPrev_sym) - done - -\\ Used to "hide" @{term "sym_refs o list_refs_of_replies'"} from simplification. \ -definition protected_sym_refs :: "kernel_state \ bool" where - "protected_sym_refs s \ sym_refs (list_refs_of_replies' s)" - -lemma replyRemoveTCB_sym_refs_list_refs_of_replies': - "replyRemoveTCB tptr \\s. sym_refs (list_refs_of_replies' s)\" - unfolding replyRemoveTCB_def decompose_list_refs_of_replies' - supply if_cong[cong] - apply (wpsimp wp: cleanReply_list_refs_of_replies' hoare_vcg_if_lift hoare_vcg_imp_lift' gts_wp' - haskell_assert_wp - simp: pred_tcb_at'_def - split_del: if_split) - unfolding decompose_list_refs_of_replies'[symmetric] protected_sym_refs_def[symmetric] - \\ opt_mapE will sometimes destroy the @{term "(|>)"} inside @{term replyNexts_of} - and @{term replyPrevs_of}, but we're using those as our local normal form. \ - apply (intro conjI impI allI) - \\ Our 6 cases correspond to various cases of @{term replyNext} and @{term replyPrev}. - We use @{thm ks_reply_at'_repliesD} to turn those cases into facts about - @{term replyNexts_of} and @{term replyPrevs_of}. \ - apply (all \clarsimp simp: isHead_to_head - , normalise_obj_at'\) - apply (all \drule(1) ks_reply_at'_repliesD[OF ko_at'_replies_of', - folded protected_sym_refs_def] - , clarsimp simp: projectKO_reply isHead_to_head\) - \\ Now, for each case we can blow open @{term sym_refs}, which will give us enough new - @{term "(replyNexts_of, replyPrevs_of)"} facts that we can throw it all at metis. \ - apply (clarsimp simp: sym_refs_def split_paired_Ball in_get_refs - , intro conjI impI allI - ; metis sym_refs_replyNext_replyPrev_sym[folded protected_sym_refs_def] option.sel - option.inject)+ - done - -lemma replyRemoveTCB_valid_idle': - "replyRemoveTCB tptr \valid_idle'\" - unfolding replyRemoveTCB_def - apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_imp_lift' gts_wp' setObject_sc_idle') - apply (clarsimp simp: valid_reply'_def pred_tcb_at'_def) - apply (intro conjI impI allI - ; simp? - , normalise_obj_at'? - , (solves \clarsimp simp: valid_idle'_def idle_tcb'_def obj_at'_def isReply_def\)?) - 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') - by (fastforce simp: replyUnlink_assertion_def st_tcb_at'_def obj_at'_def - weak_sch_act_wf_def) - -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 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) - done - -lemma set_reply_obj_ref_noop: - "monadic_rewrite False True (reply_at rptr) - (return ()) - (set_reply_obj_ref (K id) rptr x)" - by (clarsimp simp: set_simple_ko_def monadic_rewrite_def exec_gets - update_sk_obj_ref_def gets_the_def - get_simple_ko_def partial_inv_inj_Some get_object_def bind_assoc obj_at_def - is_reply_def2 set_object_def exec_get put_id_return) - -lemma updateReply_replyPrev_same_corres: - assumes - rr: "\r1 r2. reply_relation r1 r2 \ - reply_relation (g (\y. new) r1) (f r2)" - shows - "corres dc (reply_at rp) (reply_at' rp and obj_at' (\ko. replyPrev_same (f ko) ko) rp) - (set_reply_obj_ref g rp new) - (updateReply rp f)" - apply (simp add: update_sk_obj_ref_def updateReply_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_reply_corres]) - apply (rule set_reply_corres) - apply (simp add: rr) - apply wpsimp+ - by (clarsimp simp: obj_at'_def) - -lemma updateReply_replyPrev_corres: - "corres dc (reply_at rp and (\s. rp \ fst ` replies_with_sc s)) (reply_at' rp) - (set_reply_obj_ref (\_. id) rp r1) - (updateReply rp (replyPrev_update (\_. new)))" - apply (simp add: update_sk_obj_ref_def updateReply_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_reply_corres]) - apply (rule setReply_not_queued_corres) - apply (simp add: reply_relation_def) - by wpsimp+ - -lemma replyPrev_same_replyNext[simp]: - "replyPrev_same (replyNext_update (\_. Some (Head scptr)) ko) ko" - by (clarsimp simp: replyPrev_same_def) - -lemma updateReply_replyNext_not_head_corres: - "\ isHead next_opt \ - corres dc (reply_at rptr) (reply_at' rptr) - (set_reply_obj_ref reply_sc_update rptr None) - (updateReply rptr (\reply. replyNext_update (\_. next_opt) reply))" - unfolding update_sk_obj_ref_def updateReply_def - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_reply_corres set_reply_corres]) - apply (clarsimp simp: reply_relation_def isHead_def - split: option.splits reply_next.splits) - apply wpsimp+ - apply (clarsimp simp: obj_at'_def replyPrev_same_def) - done - -lemma update_sc_reply_stack_update_ko_at'_corres: - "corres dc - (sc_at ptr) - (ko_at' sc' ptr and (\s. heap_ls (replyPrevs_of s) reply_ptr replies)) - (update_sched_context ptr (sc_replies_update (\_. replies))) - (setSchedContext ptr (scReply_update (\_. reply_ptr) sc'))" - apply (rule_tac Q="sc_at' ptr" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD sc_at_cross simp: obj_at'_def) - apply (rule_tac Q="sc_obj_at (objBits sc' - minSchedContextBits) ptr" in corres_cross_add_abs_guard) - apply (fastforce dest!: state_relationD ko_at_sc_cross) - apply (rule corres_guard_imp) - apply (rule_tac P="sc_obj_at (objBits sc' - minSchedContextBits) ptr" - and n1="objBits sc' - minSchedContextBits" - in monadic_rewrite_corres_l[OF update_sched_context_rewrite]) - apply (rule corres_symb_exec_l) - apply (rule corres_guard_imp) - apply (rule setSchedContext_update_corres - [where f'="scReply_update (\_. reply_ptr)" - and f="sc_replies_update (\_. replies)"]) - apply (clarsimp simp: sc_relation_def) - apply (clarsimp simp: objBits_def objBitsKO_def) - apply simp+ - apply (wpsimp wp: get_sched_context_exs_valid simp: is_sc_obj_def obj_at_def) - apply (rename_tac ko; case_tac ko; simp) - apply simp - apply (wpsimp simp: obj_at_def is_sc_obj_def - | fastforce split: Structures_A.kernel_object.splits)+ - done - -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)" - unfolding bind_sc_reply_def bindScReply_def case_list_when sym_refs_asrt_def - apply (clarsimp simp: liftM_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. reply_at' rptr and ko_at' sc scptr"]) - (* This command is the lynch-pin. This does all useful state-relation lifting - and prepares the rest of the argument*) - apply (rule_tac Q'="reply_at' rptr and ko_at' sc scptr - and K (scReply sc = hd_opt (sc_replies x)) - and (\s. scReply sc \ None \ reply_at' (the (scReply sc)) s) - and K (rptr \ set (sc_replies x)) - and (\s. heap_ls (replyPrevs_of s) (scReply sc) (sc_replies x))" - and Q="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)) - and (\s. \n. ko_at (Structures_A.SchedContext x n) scptr s)" - in stronger_corres_guard_imp) - apply (rule corres_guard_imp) - apply (rule corres_split[where r'=dc]) - apply (rule_tac F="(sc_replies x \ []) = (\y. scReply sc = Some y)" in corres_gen_asm2) - apply (erule corres_when2) - apply (rule_tac F="scReply sc = Some (hd (sc_replies x))" in corres_gen_asm2) - apply simp - apply (rule_tac P'="\s. valid_replies s \ sym_refs (state_refs_of s) - \ pspace_aligned s \ pspace_distinct s" - in corres_stateAssert_implied) - apply (rule updateReply_replyNext_not_head_corres) - apply (simp add: isHead_def) - apply (erule valid_replies_sc_cross; clarsimp) - apply (rule corres_add_noop_lhs) - apply (rule monadic_rewrite_corres_l - [OF monadic_rewrite_bind_head, - OF set_reply_obj_ref_noop[where rptr=rptr and x=None]]) - apply (simp add: bind_assoc) - apply (rule corres_split[OF updateReply_replyPrev_corres]) - apply (rule corres_split[OF update_sc_reply_stack_update_ko_at'_corres]) - apply (rule updateReply_replyPrev_same_corres) - apply (clarsimp simp: reply_relation_def) - apply (wpsimp wp: updateReply_reply_projs hoare_vcg_all_lift )+ - apply (rule_tac Q'="\_. reply_at' rptr and ko_at' sc scptr - and (\s. heap_ls (replyPrevs_of s) (Some y) (sc_replies x)) - and K (rptr \ set (sc_replies x))" - in hoare_strengthen_post[rotated]) - apply clarsimp - apply (erule (1) heap_path_heap_upd_not_in[simplified fun_upd_def]) - apply wpsimp - apply (frule Some_to_the, simp) - apply (wpsimp wp: updateReply_reply_projs)+ - 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 x"; simp) - apply assumption - apply (clarsimp simp: obj_at_def is_sc_obj) - apply (frule state_relation_sc_replies_relation) - apply (subgoal_tac "scReply sc = hd_opt (sc_replies sca)") - 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 (clarsimp simp: replies_with_sc_def image_def) - apply (drule_tac x=scptr in spec) - apply (clarsimp simp: sc_at_pred_n_def obj_at_def) - apply (erule (1) sc_replies_relation_prevs_list) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKO_sc) - apply (force dest!: sc_replies_relation_scReplies_of - simp: obj_at'_def projectKOs opt_map_red vs_heap_simps is_sc_obj - obj_at_def) - apply wpsimp+ - done - -lemma setObject_reply_pde_mappings'[wp]: - "setObject ptr (val :: reply) \valid_pde_mappings'\" - by (wp valid_pde_mappings_lift') - -crunch bindScReply - for pspace_aligned'[wp]: pspace_aligned' - and pspace_distinct'[wp]: pspace_distinct' - and bounded'[wp]: pspace_bounded' - 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 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 irqs_masked'[wp]: irqs_masked' - and valid_release_queue'[wp]: valid_release_queue' - and ct_not_inQ[wp]: ct_not_inQ - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and valid_pde_mappings'[wp]: valid_pde_mappings' - 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" - and cte_wp_at'[wp]: "cte_wp_at' P p" - and ctes_of[wp]: "\s. P (ctes_of s)" - (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)\ - updateReply rptr f - \\rv s. P (obj_at' Q p s)\" - apply (simp only: obj_at'_real_def updateReply_def) - apply (wp set_reply'.ko_wp_at) - apply (auto simp: ko_wp_at'_def obj_at'_def projectKO_eq projectKO_reply split: if_splits) - done - -lemma no_tcb_not_in_replies_with_sc: - "\valid_replies s; sym_refs (state_refs_of s); - reply_tcb_reply_at (\tptr. tptr = None) reply_ptr s\ - \ reply_ptr \ fst ` replies_with_sc s" - apply (intro notI) - unfolding valid_replies_defs - apply (erule conjE) - apply (drule (1) set_mp) - apply clarsimp - apply (rename_tac scptr tptr) - apply (frule_tac thread = tptr in st_tcb_reply_state_refs[rotated]) - apply (clarsimp simp: pred_tcb_at_def obj_at_def, rule refl) - apply (clarsimp simp: sk_obj_at_pred_def obj_at_def) - done - -lemma updateReply_list_refs_of_replies': - "\\s. \ko. ko_at' ko rptr s \ P ((list_refs_of_replies' s)(rptr := list_refs_of_reply' (f ko)))\ - updateReply rptr f - \\rv s. P (list_refs_of_replies' s)\" - unfolding updateReply_def by wp - -lemma updateReply_obj_at'_inv: - "\x. P (f x) = P x \ - updateReply rPtr f \\s. Q (obj_at' (P :: reply \ bool) rp s)\" - apply (wpsimp wp: updateReply_wp_all) - apply (subgoal_tac "obj_at' P rp s = (obj_at' P rp (s\ksPSpace := (ksPSpace s)(rPtr \ KOReply (f ko))\))") - apply simp - by (force simp: obj_at'_real_def ko_wp_at'_def objBitsKO_def ps_clear_def - projectKO_reply) - -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 - (\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) - by (auto simp: obj_at'_def projectKOs opt_map_def) - -lemma bindScReply_valid_objs'[wp]: - "\valid_objs' and reply_at' replyPtr\ - bindScReply scp replyPtr - \\_. valid_objs'\" - unfolding bindScReply_def - supply set_sc_valid_objs'[wp del] set_sc'.valid_objs'[wp] - apply (wpsimp wp: updateReply_valid_objs') - apply (rule_tac Q'="\_. valid_objs' and sc_at' scp" in hoare_strengthen_post) - apply wpsimp - apply (simp add: valid_reply'_def valid_bound_obj'_def) - apply (wpsimp wp: updateReply_valid_objs') - apply wpsimp - apply (rule_tac Q'="\_. valid_objs' and reply_at' y and reply_at' replyPtr - and ko_at' sc scp" in hoare_strengthen_post) - apply (wpsimp wp: updateReply_valid_objs') - apply clarsimp - apply (prop_tac "sc_at' scp s") - apply (clarsimp simp: obj_at'_def) - apply (clarsimp simp: valid_reply'_def valid_obj'_def objBits_simps' - valid_sched_context'_def valid_sched_context_size'_def - dest!: sc_ko_at_valid_objs_valid_sc')+ - apply wpsimp+ - apply safe - apply ((clarsimp simp: valid_reply'_def valid_obj'_def objBits_simps' - valid_sched_context'_def valid_sched_context_size'_def - dest!: sc_ko_at_valid_objs_valid_sc')+)[5] - done - -lemma bindScReply_valid_replies'[wp]: - "\\s. valid_replies' s \ pspace_distinct' s \ pspace_aligned' s \ pspace_bounded' s - \ (\tptr. replyTCBs_of s replyPtr = Some tptr - \ st_tcb_at' ((=) (BlockedOnReply (Some replyPtr))) - tptr s)\ - bindScReply scPtr replyPtr - \\_. valid_replies'\" - apply (solves wp | simp (no_asm_use) add: bindScReply_def split del: if_split cong: conj_cong | - wp when_wp haskell_assert_wp hoare_vcg_if_lift2 hoare_vcg_all_lift - hoare_vcg_disj_lift hoare_vcg_imp_lift' hoare_vcg_ex_lift - updateReply_valid_replies'_bound updateReply_obj_at')+ - apply (clarsimp simp: sym_refs_asrt_def) - apply (intro conjI impI allI; clarsimp?) - apply (drule valid_replies'_sc_asrtD) - apply (clarsimp, rule_tac x=scPtr in exI) - apply (erule (3) sym_refs_scReplies[THEN sym_heapD1]) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_def) - apply ((erule impCE)?; fastforce simp: obj_at'_def projectKOs elim!: opt_mapE)+ - done - -crunch bindScReply - for valid_queues[wp]: valid_queues - and valid_queues'[wp]: valid_queues' - and valid_release_queue[wp]: valid_release_queue - (simp: crunch_simps) - -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 - \ (\oldReplyPtr. (scReplies_of s) scPtr = Some oldReplyPtr - \ replySCs_of s oldReplyPtr = Some scPtr)\ - bindScReply scPtr replyPtr - \\_ s. sym_refs (list_refs_of_replies' s)\" - supply if_split [split del] - unfolding bindScReply_def - apply (wpsimp wp: updateReply_list_refs_of_replies' updateReply_obj_at' - hoare_vcg_all_lift hoare_vcg_imp_lift') - by (auto simp: list_refs_of_replies'_def list_refs_of_reply'_def - opt_map_Some_def obj_at'_def projectKO_eq - 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 - apply (simp (no_asm_use) split del: if_split - | wp hoare_vcg_all_lift hoare_vcg_imp_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_reply'_def opt_map_def projectKOs) - 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)\" - unfolding bindScReply_def - apply (wpsimp wp: hoare_drop_imp set_sc'.obj_at') - by (auto simp: obj_at'_real_def ko_wp_at'_def) - -lemma setReply_valid_tcbs'[wp]: - "setReply rp new \valid_tcbs'\" - unfolding valid_tcbs'_def - by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' set_reply'.setObject_wp - simp: setReply_def) - -crunch updateReply - for valid_tcbs'[wp]: valid_tcbs' - -lemma updateReply_None_sym_refs_list_refs_of_replies'[wp]: - "\\s. sym_refs (list_refs_of_replies' s) \ - replySCs_of s rptr \ None\ - updateReply rptr (replyNext_update (\_. None)) - \\_ s. sym_refs (list_refs_of_replies' s)\" - apply (wpsimp wp: updateReply_list_refs_of_replies') - apply (erule delta_sym_refs) - apply (auto simp: list_refs_of_reply'_def map_set_def - opt_map_def obj_at'_def projectKOs - split: option.splits if_splits) - done - -lemma updateReply_replyNext_None_invs': - "\\s. invs' s \ replySCs_of s rptr \ None\ - updateReply rptr (replyNext_update (\_. None)) - \\_. invs'\" - apply (simp only: invs'_def valid_pspace'_def) - apply (wpsimp wp: updateReply_valid_objs' updateReply_iflive') - apply (clarsimp simp: obj_at'_def projectKOs valid_reply'_def live_reply'_def - dest: pspace_alignedD' pspace_distinctD') - done - -context begin interpretation Arch . - -lemma pspace_relation_reply_update_conc_only: - "\ pspace_relation ps ps'; ps x = Some (Structures_A.Reply reply); ps' x = Some (KOReply reply'); - reply_relation reply new\ - \ pspace_relation ps (ps'(x \ (KOReply new)))" - apply (simp add: pspace_relation_def pspace_dom_update dom_fun_upd2 - del: dom_fun_upd) - apply (erule conjE) - apply (rule ballI, drule(1) bspec) - apply (clarsimp simp: split_def) - apply (drule bspec, simp) - apply (clarsimp simp: obj_relation_cuts_def2 cte_relation_def - pte_relation_def pde_relation_def - split: Structures_A.kernel_object.split_asm arch_kernel_obj.split_asm if_split_asm) - done - -end - -lemma replyPrevs_of_replyNext_update: - "ko_at' reply' rp s' \ - replyPrevs_of (s'\ksPSpace := (ksPSpace s')(rp \ - KOReply (reply' \ replyNext := v \))\) = replyPrevs_of s'" - apply (clarsimp simp: obj_at'_def projectKOs isNext_def - split: option.split_asm reply_next.split_asm) - by (fastforce simp: projectKO_opt_reply opt_map_def) - -lemma scs_of'_reply_update: - "reply_at' rp s' \ - scs_of' (s'\ksPSpace := (ksPSpace s')(rp \ KOReply reply)\) = scs_of' s'" - apply (clarsimp simp: obj_at'_def projectKOs isNext_def - split: option.split_asm reply_next.split_asm) - by (fastforce simp: projectKO_opt_sc opt_map_def) - -lemma sc_replies_relation_replyNext_update: - "\sc_replies_relation s s'; ko_at' reply' rp s'\ - \ sc_replies_relation s (s'\ksPSpace := (ksPSpace s')(rp \ - KOReply (reply' \ replyNext := v \))\)" - by (clarsimp simp: scs_of'_reply_update[simplified] obj_at'_def - replyPrevs_of_replyNext_update[simplified]) - -(* sym_refs and prev/next; scReply and replySC *) - -lemma sym_refs_replySCs_of_None: - "\sym_refs (state_refs_of' s'); pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'; - replySCs_of s' rp = None\ - \ \scp. scs_of' s' scp \ None \ scReplies_of s' scp \ Some rp" - apply (clarsimp simp: obj_at'_def projectKOs elim!: opt_mapE) - apply (drule_tac tp=SCReply and y=rp and x=scp in sym_refsD[rotated]) - apply (force simp: state_refs_of'_def dest: pspace_boundedD' pspace_alignedD' pspace_distinctD') - 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 - by (wpsimp simp: objBits_simps) - -lemma no_fail_updateReply [wp]: - "no_fail (reply_at' rp) (updateReply rp f)" - unfolding updateReply_def by wpsimp - -lemma no_fail_cleanReply [wp]: - "no_fail (reply_at' rp) (cleanReply rp)" - unfolding cleanReply_def - apply (rule no_fail_pre, rule no_fail_bind) - apply (wpsimp wp: updateReply_wp_all)+ - apply (clarsimp simp: obj_at'_def ps_clear_upd objBits_simps' projectKOs) - 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 projectKOs) - -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 projectKOs) - -(** sc_with_reply and sc_replies_relations : crossing information **) - -(* modified version of sc_replies_relation_prevs_list in StateRelation.thy; - updates only the abstract sc_relies; useful for the following few lemmas *) -lemma sc_replies_relation_prevs_list': - "\ sc_replies_relation s s'; - kheap s scp = Some (kernel_object.SchedContext sc n)\ - \ heap_ls (replyPrevs_of s') (scReplies_of s' scp) (sc_replies sc)" - apply (clarsimp simp: sc_replies_relation_def sc_replies_of_scs_def scs_of_kh_def map_project_def) - apply (clarsimp simp: opt_map_red) - done - -lemma sc_replies_relation_sc_with_reply_cross_eq_pred: - "\ sc_replies_relation s s'; pspace_relation (kheap s) (ksPSpace s')\ \ - (\sc n. kheap s scp = Some (kernel_object.SchedContext sc n) \ rp \ set (sc_replies sc)) - = (\xs. heap_ls (replyPrevs_of s') (scReplies_of s' scp) xs \ rp \ set xs)" - supply opt_mapE[elim!] - apply (rule iffI; clarsimp) - apply (rule_tac x="the (sc_replies_of2 s scp)" in exI) - apply (clarsimp simp: sc_replies_relation_def sc_replies_of_scs_def scs_of_kh_def map_project_def) - apply (drule_tac x=scp and y="sc_replies sc" in spec2) - apply (clarsimp simp: opt_map_def projectKO_opt_sc split: option.splits) - apply (case_tac "scReplies_of s' scp", simp) - apply (rename_tac p) - apply (drule pspace_relation_sc_at[where scp=scp]) - apply (clarsimp simp: projectKOs opt_map_red opt_pred_def) - apply (clarsimp simp: obj_at_simps is_sc_obj opt_map_red) - apply (drule (1) sc_replies_relation_prevs_list', simp add: opt_map_red) - apply (drule (1) heap_ls_unique, simp) - done - -(* crossing equality for sc_with_reply *) -lemma sc_replies_relation_sc_with_reply_cross_eq: - "\ sc_replies_relation s s'; pspace_relation (kheap s) (ksPSpace s') \ - \ sc_with_reply rp s = sc_with_reply' rp s'" - unfolding sc_with_reply_def sc_with_reply'_def - using sc_replies_relation_sc_with_reply_cross_eq_pred - by simp - -lemma sc_replies_relation_sc_with_reply_heap_path: - "\sc_replies_relation s s'; sc_with_reply rp s = Some scp\ - \ heap_ls (replyPrevs_of s') (scReplies_of s' scp) (the (sc_replies_of s scp)) - \ rp \ set (the (sc_replies_of s scp))" - apply (clarsimp simp: sc_replies_relation_def dest!: sc_with_reply_SomeD) - apply (drule_tac x=scp and y="sc_replies sc" in spec2) - apply (clarsimp simp: vs_heap_simps) - apply (frule (1) heap_path_takeWhile_lookup_next) - by (metis (mono_tags) option.sel sc_replies.Some) - -lemma next_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'); replyNexts_of s' rp = Some nrp; - pspace_aligned' s'; pspace_distinct' s'; pspace_bounded' s'\ - \ \xs ys. sc_replies_of s scp = Some (xs @ nrp # rp # ys)" - apply (frule (1) sc_replies_relation_sc_with_reply_heap_path) - apply (prop_tac "replyPrevs_of s' nrp = Some rp") - apply (simp add: sym_refs_replyNext_replyPrev_sym[symmetric]) - apply (drule sc_with_reply_SomeD, clarsimp) - apply (prop_tac "the (sc_replies_of s scp) = sc_replies sc") - using heap_ls_unique sc_replies_relation_prevs_list' apply blast - apply simp - apply (frule (3) heap_ls_prev_cases[OF _ _ _ reply_sym_heap_Prev_Next]) - apply (drule (3) sym_refs_replySCs_of_None) - apply (rule replyNexts_Some_replySCs_None[where rp=rp], simp) - apply (clarsimp simp: vs_heap_simps opt_pred_def) - apply (drule (1) heap_ls_next_takeWhile_append[rotated -1]) - apply (meson in_opt_map_eq) - 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; - 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) - apply (prop_tac "replyNexts_of s' nrp = Some rp") - apply (simp add: sym_refs_replyNext_replyPrev_sym[symmetric]) - apply (drule sc_with_reply_SomeD, clarsimp) - apply (prop_tac "the (sc_replies_of s scp) = sc_replies sc") - 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]) - apply (frule in_list_decompose_takeWhile[where x=rp]) - apply auto - done - -lemma sc_replies_middle_reply_sc_None: - "\sym_refs (state_refs_of s); valid_replies s; sc_with_reply rp s = Some scp; - (sc_replies_of s |> hd_opt) scp \ Some rp; sc_at scp s; reply_at rp s\ \ - reply_sc_reply_at ((=) None) rp s" - supply subst_all[simp del] - apply (clarsimp simp: obj_at_def is_sc_obj_def is_reply) - apply (rename_tac ko n reply; case_tac ko; clarsimp) - apply (rename_tac sc n) - apply (drule sc_with_reply_SomeD1) - apply (clarsimp simp: vs_heap_simps opt_map_Some) - apply (case_tac "sc_replies sc"; simp) - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def) - apply (rule ccontr) - apply (clarsimp simp: reply_sc_reply_at_def obj_at_def) - apply (case_tac "reply_sc reply"; simp) - apply (drule sym_refs_sc_replies_sc_at) - apply (fastforce simp: reply_sc_reply_at_def obj_at_def) - apply (rename_tac p) - apply clarsimp - apply (prop_tac "sc_replies_sc_at ((\rs. rp \ set rs)) p s") - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def) - apply (metis list.set_intros(1)) - apply (drule valid_replies_sc_replies_unique) - apply fastforce - apply (prop_tac "scp=p") - apply blast - using sc_replies_sc_atE by fastforce - -lemma sc_with_reply_replyNext_Some: - " \sc_replies_relation s s'; valid_objs 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'); - replyNexts_of s' rp = Some nxt_rp; - sc_with_reply rp s = Some scp\ - \ sc_with_reply nxt_rp s = Some scp" - apply (subgoal_tac "sc_with_reply' nxt_rp s' = Some scp") - apply (fastforce simp: sc_replies_relation_sc_with_reply_cross_eq) - apply (frule (1) sc_with_reply_Some_sc_at) - apply (frule (1) sc_with_reply_Some_reply_at) - apply (prop_tac "sc_with_reply' rp s' = Some scp \ 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) - apply (clarsimp simp: obj_at_def is_sc_obj is_reply) - apply (drule (1) sc_replies_relation_sc_with_reply_heap_path[rotated]) - apply (prop_tac "the (sc_replies_of s scp) = sc_replies sc") - apply (clarsimp simp: sc_replies_of_scs_def scs_of_kh_def opt_map_def map_project_def) - apply clarsimp - apply (prop_tac "replyPrevs_of s' nxt_rp = Some rp") - apply (erule (1) sym_refs_replyNext_replyPrev_sym[THEN iffD1]) - apply (prop_tac "\xs. heap_ls (replyPrevs_of s') (scReplies_of s' scp) xs \ nxt_rp \ set xs") - apply (rule_tac x="sc_replies sc" in exI) - apply (frule (2) heap_ls_prev_cases) - apply (erule reply_sym_heap_Prev_Next) - apply (erule disjE) - apply (frule pspace_relation_pspace_bounded') - apply (frule (3) sym_refs_scReplies, clarsimp simp: sym_heap_def) - apply (frule replySCs_Some_replyNexts_None[OF option.discI]) - apply (drule (1) sym_refs_replyNext_None, clarsimp) - apply clarsimp - apply (clarsimp simp: sc_with_reply'_def the_pred_option_def the_equality split: if_split_asm) - apply (rule conjI) - apply blast - by (meson heap_ls_next_in_list) - -lemma sc_with_reply_replyPrev_None: - "\sc_with_reply rp s = None; sc_replies_relation s s'; valid_objs' s'; - pspace_relation (kheap s) (ksPSpace s'); - pspace_distinct s; pspace_aligned s; - sym_refs (state_refs_of' s'); sym_refs (list_refs_of_replies' s'); - replyPrevs_of s' rp = Some prv_rp\ - \ sc_with_reply prv_rp s = None" - apply (subgoal_tac "sc_with_reply' prv_rp s' = None") - apply (fastforce simp: sc_replies_relation_sc_with_reply_cross_eq) - apply (prop_tac "reply_at rp s") - apply (clarsimp simp: projectKOs elim!: opt_mapE) - apply (erule (1) pspace_dom_relatedE) - apply (erule (1) obj_relation_cutsE) - apply ((clarsimp simp: other_obj_relation_def is_reply obj_at_def - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm)+)[7] - 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) - apply clarsimp - apply (drule sc_with_reply'_NoneD) - apply (clarsimp simp: sc_with_reply'_def) - apply (rule the_pred_option_None) - apply (rule notI) - apply (erule FalseI) - apply (simp add: Ex1_def) - apply clarsimp - apply (rename_tac scp replies) - apply (frule (2) heap_ls_prev_cases) - apply (erule reply_sym_heap_Prev_Next) - apply (erule disjE) - apply (frule pspace_relation_pspace_bounded') - apply (frule (3) sym_refs_scReplies, clarsimp simp: sym_heap_def) - apply (frule replySCs_Some_replyNexts_None[OF option.discI]) - apply (drule (1) sym_refs_replyNext_None, clarsimp) - by (meson heap_ls_prev_not_in) - -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'); - replyNexts_of s' rp = Some nxt_rp\ - \ sc_with_reply nxt_rp s = None" - apply (prop_tac "reply_at rp s") - apply (clarsimp simp: projectKOs elim!: opt_mapE) - apply (erule (1) pspace_dom_relatedE) - apply (erule (1) obj_relation_cutsE) - apply ((clarsimp simp: other_obj_relation_def is_reply obj_at_def - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm)+)[7] - apply (prop_tac "pspace_aligned' s' \ pspace_distinct' s'") - apply (fastforce elim!: pspace_distinct_cross pspace_aligned_cross) - apply (rule ccontr) - apply (drule not_Some_eq[THEN iffD2]) - apply (drule not_None_eq[THEN iffD1]) - apply (drule not_ex[THEN iffD2]) - apply (erule FalseI) - apply clarsimp - apply (rename_tac scp) - 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 (drule sc_with_reply_SomeD) - apply (clarsimp simp: vs_heap_simps) - apply (rename_tac sc n) - apply (clarsimp simp: sc_with_reply_def' the_pred_option_def - split: if_split_asm) - apply (simp add: conj_commute) - apply (rule context_conjI) - apply (drule valid_replies_sc_replies_unique[where r=rp]) - apply (fastforce simp: sc_replies_sc_at_def obj_at_def) - apply simp - apply (clarsimp simp: the_equality) - apply (drule_tac x=x and y=scp in spec2) - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def) - done - -(** end : sc_with_reply' **) - -(* sr_inv lemmas for reply_remove_tcb_corres *) - -lemma pspace_relation_reply_at: - assumes p: "pspace_relation (kheap s) (ksPSpace s')" - assumes t: "ksPSpace s' p = Some (KOReply reply')" - 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 is_reply obj_at_def - split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm)+ - done - -lemma next_is_not_head[simp]: - "isNext x \ \ isHead x" - by (clarsimp simp: isNext_def isHead_def split: option.splits reply_next.splits) - -lemma sc_replies_relation_sc_with_reply_None: - "\sc_replies_relation s s'; reply_at rp s; replies_of' s' rp \ None; - sc_with_reply rp s = None; valid_replies s\ - \ sc_replies_relation s (s'\ksPSpace := (ksPSpace s')(rp \ KOReply r)\)" - apply (clarsimp simp: sc_replies_relation_def) - apply (rename_tac scp replies) - apply (drule_tac x=scp and y=replies in spec2) - apply simp - apply (drule_tac sc=scp in valid_replies_sc_with_reply_None, simp) - apply (clarsimp simp: projectKOs obj_at'_def projectKO_opt_sc) - apply (rule conjI; rule impI) - apply (clarsimp simp: obj_at_def is_reply vs_heap_simps) - apply (erule heap_path_heap_upd_not_in) - by (clarsimp simp: sc_replies_sc_at_def obj_at_def vs_heap_simps) - -context begin interpretation Arch . - -lemma updateReply_sr_inv: - "\\s s' r r'. (P and ko_at (kernel_object.Reply r) rp) s \ - (P' and ko_at' r' rp) s' \ - reply_relation r r' \ reply_relation r (f r'); - \s s' reply'. pspace_relation (kheap s) (ksPSpace s') \ - (P' and ko_at' reply' rp) s' \ - (P and reply_at rp) s \ - sc_replies_relation s s' \ - sc_replies_relation s(s'\ksPSpace := (ksPSpace s')(rp \ KOReply (f reply'))\)\ - \ sr_inv P P' (updateReply rp f)" - unfolding sr_inv_def updateReply_def setReply_def getReply_def - apply (clarsimp simp: setReply_def getReply_def getObject_def setObject_def projectKOs - updateObject_default_def loadObject_default_def split_def - in_monad return_def fail_def objBits_simps' in_magnitude_check - split: if_split_asm option.split_asm dest!: readObject_misc_ko_at') - apply (rename_tac reply') - apply (prop_tac "ko_at' reply' rp s'") - apply (clarsimp simp: obj_at'_def objBits_simps' projectKOs) - apply (frule (1) pspace_relation_reply_at[OF state_relation_pspace_relation]) - apply (clarsimp simp: obj_at_def is_reply) - apply (rename_tac reply) - apply (clarsimp simp: state_relation_def) - apply (rule conjI) - apply (frule (1) pspace_relation_absD) - apply (fastforce elim!: pspace_relation_reply_update_conc_only simp: obj_at'_def ) - apply (clarsimp simp: caps_of_state_after_update cte_wp_at_after_update - swp_def fun_upd_def obj_at_def map_to_ctes_upd_other - simp del: fun_upd_def) - done - -lemma updateReply_sr_inv_prev: - "sr_inv ((\s. sc_with_reply rp s = None) and valid_replies) - (reply_at' rp) (updateReply rp (replyPrev_update (\_. Nothing)))" - apply (rule updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def) - by (fastforce elim!: sc_replies_relation_sc_with_reply_None - [where r="replyPrev_update Map.empty reply'" for reply', simplified] - simp: opt_map_red obj_at'_def projectKOs) - -lemma updateReply_sr_inv_next: - "sr_inv (P and (\s. sc_with_reply rp s = None) and valid_replies - and (\s. sym_refs (state_refs_of s))) - P' (updateReply rp (replyNext_update (\_. Nothing)))" - unfolding updateReply_def sr_inv_def - apply (clarsimp simp: setReply_def getReply_def getObject_def setObject_def projectKOs - updateObject_default_def loadObject_default_def split_def - in_monad return_def fail_def objBits_simps' in_magnitude_check - split: if_split_asm option.split_asm dest!: readObject_misc_ko_at') - apply (rename_tac reply') - apply (frule (1) pspace_relation_reply_at[OF state_relation_pspace_relation]) - apply (clarsimp simp: obj_at_def is_reply obj_at'_def projectKOs) - apply (rename_tac reply) - apply (frule sc_with_reply_None_reply_sc_reply_at) - apply (clarsimp simp: obj_at_def is_reply) - apply simp+ - apply (clarsimp simp: reply_sc_reply_at_def obj_at_def state_relation_def) - apply (rule conjI) - apply (frule (1) pspace_relation_absD) - apply clarsimp - apply (erule (2) pspace_relation_reply_update_conc_only) - apply (clarsimp simp: reply_relation_def) - apply (rule conjI) - 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) - apply (rule conjI; clarsimp) - apply (rename_tac sc n) - apply (drule_tac sc=p in valid_replies_sc_with_reply_None, simp) - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def) - apply (erule (1) heap_path_heap_upd_not_in[where r=rp]) - apply (clarsimp simp: caps_of_state_after_update cte_wp_at_after_update - swp_def fun_upd_def obj_at_def map_to_ctes_upd_other - simp del: fun_upd_def) - done - -end - -lemma cleanReply_sr_inv: - "sr_inv (P and (\s. sc_with_reply rp s = None) and valid_replies - and (\s. sym_refs (state_refs_of s))) - P' (cleanReply rp)" - unfolding cleanReply_def - apply (rule sr_inv_bind[rotated]) - apply (rule updateReply_sr_inv) - apply (clarsimp simp: reply_relation_def) - apply (fastforce elim!: sc_replies_relation_sc_with_reply_None - [where r="replyPrev_update Map.empty reply'" for reply', simplified] - simp: opt_map_red obj_at'_def projectKOs) - apply wpsimp - apply (clarsimp intro!: updateReply_sr_inv_next[simplified]) - done - -(* replyRemoveTCB_corres specific wp rules *) - -lemma scReply_update_empty_sc_with_reply': - "\(\s. sc_with_reply' rp s = Some scp) and ko_at' sc' scp - and (\s. sym_refs (state_refs_of' s)) and reply_at' rp - and (\s. sym_refs (list_refs_of_replies' s)) - and K (scReply sc' = Some rp) - and pspace_aligned' and pspace_distinct'\ - setSchedContext scp (scReply_update Map.empty sc') - \\rv s. sc_with_reply' rp s = None\" - supply heap_path.simps[simp del] - apply (wpsimp wp: set_sc'.setObject_wp simp: setSchedContext_def) - apply (simp (no_asm) add: sc_with_reply'_def) - apply (simp add: the_pred_option_def split: if_split_asm) - apply (rule notI) - apply (clarsimp simp add: Ex1_def) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (clarsimp simp: projectKO_opt_reply) - apply (prop_tac "(replyPrevs_of s)(scp := None) = replyPrevs_of s") - apply (rule ext) - apply (clarsimp simp: opt_map_None opt_map_left_None set_reply'.not_sc) - apply (clarsimp simp: sc_with_reply'_def the_pred_option_def) - apply (split if_split_asm; simp) - apply (drule the1_equality) - apply blast - by simp - -(* 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\ - update_sched_context scp (sc_replies_update (takeWhile ((\) rp))) - \\rv s. sc_with_reply rp s = None\" - apply (wpsimp wp: set_object_wp hoare_vcg_all_lift get_object_wp - simp: update_sched_context_def) - apply (clarsimp dest!: sc_with_reply_SomeD1) - apply (prop_tac "\replies. sc_replies_sc_at (\rs. rs = replies) scp s \ rp \ set replies") - apply (fastforce simp: sc_replies_sc_at_def obj_at_def) - apply (thin_tac "sc_replies_sc_at _ _ _") - apply (clarsimp simp: obj_at_def sc_replies_sc_at_def) - apply (clarsimp simp: sc_with_reply_def) - apply (prop_tac "\ rp \ set (takeWhile ((\) rp) (sc_replies x))") - apply (metis (mono_tags, lifting) takeWhile_taken_P) - apply clarsimp - apply (clarsimp simp add: the_pred_option_def Ex1_def) - by (fastforce dest!: valid_replies_sc_replies_unique simp: obj_at_def sc_replies_sc_at_def)+ - -lemma sc_replies_update_takeWhile_middle_sym_refs: - "\ hd (sc_replies sc) \ rp; rp \ set (sc_replies sc) \ \ - \\s. P (state_refs_of s) \ obj_at (\ko. \n. ko = kernel_object.SchedContext sc n) scp s\ - update_sched_context scp (sc_replies_update (takeWhile ((\) rp))) - \\_ s. P (state_refs_of s)\" - apply (wpsimp wp: update_sched_context_state_refs_of) - apply (clarsimp simp: sc_replies_sc_at_def obj_at_def) - apply (prop_tac "takeWhile ((\) rp) (sc_replies sc) \ []") - apply (prop_tac "sc_replies sc \ []") - apply (simp add: set_list_mem_nonempty) - apply (case_tac "sc_replies sc"; simp) - using hd_opt_append(1) takeWhile_dropWhile_id - by (metis (mono_tags) append.right_neutral) - -lemma updateReply_ko_at'_other: - "\K (p \ rp) and ko_at' ko p\ updateReply rp f \\_. ko_at' ko p\" - apply (wpsimp wp: updateReply_wp_all) - by (clarsimp simp: obj_at'_def projectKOs ps_clear_upd) - -lemma update_replyPrev_replyNexts_inv[wp]: - "updateReply rp (replyPrev_update prev) \\s. P (replyNexts_of s)\" - unfolding updateReply_def supply fun_upd_apply[simp del] - apply wpsimp - by (metis ko_at'_replies_of' map_upd_triv opt_map_upd_Some) - -(* replyRemoveTCB_corres specific corres rules *) - -lemma setSchedContext_scReply_update_None_corres: - "corres dc ((\s. (sc_replies_of s |> hd_opt) ptr = Some rp) and valid_objs and pspace_aligned and pspace_distinct) - \ - (update_sched_context ptr (sc_replies_update (takeWhile ((\) rp)))) - (do sc' \ getSchedContext ptr; - setSchedContext ptr (scReply_update Map.empty sc') - od)" - supply opt_mapE[elim!] - apply (rule_tac Q="sc_at' ptr" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD simp: obj_at_def is_sc_obj_def vs_heap_simps - elim!: sc_at_cross valid_objs_valid_sched_context_size) - apply (rule corres_symb_exec_r) - apply (rule_tac P'="ko_at' sc' ptr" in corres_inst) - apply (rule_tac Q="sc_obj_at (objBits sc' - minSchedContextBits) ptr" in corres_cross_add_abs_guard) - apply (fastforce dest!: state_relationD ko_at_sc_cross) - apply (rule corres_guard_imp) - apply (rule_tac P="(\s. (sc_replies_of s |> hd_opt) ptr = Some rp) - and sc_obj_at (objBits sc' - minSchedContextBits) ptr" - and n1="objBits sc' - minSchedContextBits" - in monadic_rewrite_corres_l[OF update_sched_context_rewrite]) - apply (rule corres_symb_exec_l) - apply (rule_tac P="(\s. kheap s ptr = Some (kernel_object.SchedContext sc (objBits sc' - - minSchedContextBits))) - and K (rp = hd (sc_replies sc))" - and P'="ko_at' sc' ptr" in corres_inst) - apply (rule corres_gen_asm') - apply (rule corres_guard_imp) - apply (rule_tac sc=sc and sc'=sc' in setSchedContext_update_corres; simp?) - apply (clarsimp simp: sc_relation_def objBits_simps)+ - apply (wpsimp wp: get_sched_context_exs_valid simp: is_sc_obj_def obj_at_def) - apply (rename_tac ko; case_tac ko; clarsimp) - apply simp - apply (wpsimp simp: obj_at_def is_sc_obj_def vs_heap_simps) - apply (wpsimp simp: obj_at_def is_sc_obj_def - | clarsimp split: Structures_A.kernel_object.splits)+ - done - -lemma replyPrevNext_update_commute: - "replyPrev_update f (replyNext_update g reply) - = replyNext_update g (replyPrev_update f reply)" - by (cases reply; clarsimp) - -lemma updateReply_Prev_Next_rewrite: - "monadic_rewrite False True (reply_at' rp) - (do y <- updateReply rp (replyPrev_update f); - updateReply rp (replyNext_update g) - od) - (do y <- updateReply rp (replyNext_update g); - updateReply rp (replyPrev_update f) - od)" - apply (clarsimp simp: monadic_rewrite_def) - apply (rule monad_state_eqI) - apply (find_goal \match conclusion in "_ = _" \ -\) - subgoal - apply (insert no_fail_updateReply, drule_tac x=rp and y="replyPrev_update f" in meta_spec2) - apply (insert no_fail_updateReply, drule_tac x=rp and y="replyNext_update g" in meta_spec2) - apply (rule; clarsimp simp: in_monad no_fail_def snd_bind split_def) - apply (drule (1) use_valid[OF _ updateReply.typ_at_lifts'(5)], fastforce)+ - done - apply (all \clarsimp simp: updateReply_def getReply_def setReply_def getObject_def2 - obj_at'_def projectKOs updateObject_default_def setObject_def - loadObject_default_def2[simplified] ARM_H.fromPPtr_def - split_def in_monad in_magnitude_check' objBits_simps'\) - apply (fastforce simp add: fun_upd_def replyPrevNext_update_commute)+ - done - -lemma reply_sc_update_sc_with_reply_None: - "set_reply_obj_ref reply_sc_update rp None \\s. sc_with_reply rp s = None\" - apply (wpsimp wp: update_sk_obj_ref_wp) - apply (drule sc_with_reply_NoneD) - apply (simp add: sc_with_reply_def sc_replies_sc_at_def obj_at_def) - apply (rule the_pred_option_None) - by (metis Structures_A.kernel_object.simps(45) option.simps(1)) - -lemma reply_sc_update_sc_with_reply_None_exs_valid: - "\ reply_at rp s; sc_with_reply rp s = None; valid_replies s; - sym_refs (state_refs_of s) \ \ - \(=) s\ set_reply_obj_ref reply_sc_update rp None \\\r. (=) s\" - apply (drule (3) sc_with_reply_None_reply_sc_reply_at) - apply (clarsimp simp: reply_sc_reply_at_def obj_at_def is_reply update_sk_obj_ref_def) - apply (simp add: exs_valid_def set_simple_ko_def get_object_def2 exec_gets bind_assoc - set_object_def exec_get put_def return_def in_monad split_def bind_def - get_simple_ko_def partial_inv_inj_Some) - apply (simp add: gets_def exec_get return_def partial_inv_def) - apply (simp add: get_def) - apply (drule sym[where s=None]) - by (cases s; auto) - -(* cleanReply corres when rp is not in a reply stack *) -lemma cleanReply_sc_with_reply_None_corres': - "corres dc (reply_at rp and pspace_aligned and pspace_distinct - and valid_replies and (\s. sym_refs (state_refs_of s)) and (\s. sc_with_reply rp s = None)) - \ - (set_reply_obj_ref reply_sc_update rp None) - (cleanReply rp)" - apply (rule_tac Q="reply_at' rp" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD reply_at_cross) - apply (rule corres_guard_imp) - apply (rule corres_noop_sr2[OF reply_sc_update_sc_with_reply_None_exs_valid - cleanReply_sr_inv[where P="reply_at rp" and P'="reply_at' rp"]]) - by wpsimp+ - -(* cleanReply corres version 2: - we don't want sym_refs in the preconditions for replyRemoveTCB_corres - we can achieve that by unfolding cleanReply and not using cleanReply_sr_inv *) -lemma cleanReply_sc_with_reply_None_corres: - "corres dc (reply_at rp and pspace_aligned and pspace_distinct - and valid_replies and (\s. sc_with_reply rp s = None)) - \ - (set_reply_obj_ref reply_sc_update rp None) - (cleanReply rp)" - apply (rule_tac Q="reply_at' rp" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD reply_at_cross) - apply (simp add: cleanReply_def bind_assoc) - apply (rule corres_guard_imp) - apply (rule monadic_rewrite_corres_r[OF updateReply_Prev_Next_rewrite]) - apply (rule corres_bind_return) - apply (rule corres_guard_imp) - apply (rule corres_split[OF updateReply_replyNext_not_head_corres]) - apply (simp add: isHead_def) - apply (rule_tac P="reply_at rp and valid_replies and (\s. sc_with_reply rp s = None)" - and P'="reply_at' rp" in corres_noop_sr) - apply (rule sr_inv_imp) - apply (rule updateReply_sr_inv_prev[simplified]) - apply (clarsimp simp: reply_relation_def) - apply simp - apply (wpsimp wp: reply_sc_update_sc_with_reply_None simp: isHead_def)+ - apply simp+ - done - -(* corres between update_sched_context and updateReply *) -lemma updateReply_replyPrev_takeWhile_middle_corres: - assumes - "rp \ set (sc_replies sc)" - "hd (sc_replies sc) \ rp" - shows - "corres dc - (valid_objs and pspace_aligned and pspace_distinct and valid_replies - 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) - (valid_objs' and (\s'. replyNexts_of s' rp = Some nrp) - and (\s. sym_refs (list_refs_of_replies' s))) - (update_sched_context scp (sc_replies_update (takeWhile ((\) rp)))) - (updateReply nrp (replyPrev_update Map.empty))" -proof - - have z: "\s x. reply_at' nrp s - \ map_to_ctes ((ksPSpace s) (nrp \ KOReply (replyPrev_update Map.empty x))) - = map_to_ctes (ksPSpace s)" - by (clarsimp simp: obj_at_simps) - show ?thesis using assms - (* 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'. sc_with_reply' rp s' = Some scp)" in corres_cross_add_guard) - apply clarsimp - apply (prop_tac "reply_at' rp s'") - 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 (fastforce dest: state_relationD simp: sc_replies_relation_sc_with_reply_cross_eq) - (* corres proof *) - apply (clarsimp simp: corres_underlying_def) - apply (rename_tac s s') - apply (rule conjI) - apply (clarsimp simp: update_sched_context_def updateReply_def getReply_def - setReply_def getObject_def2 setObject_def in_monad ARM_H.fromPPtr_def - get_object_def2 set_object_def bind_assoc loadObject_default_def2[simplified] - scBits_simps split_def lookupAround2_known1 exec_gets a_type_def - obj_at'_def projectKOs reply_sc_reply_at_def obj_at_def - updateObject_default_def in_magnitude_check objBits_simps') - apply (clarsimp simp: get_def put_def bind_def) - apply (rename_tac reply' sc' nextr) - apply (prop_tac "reply_at' nrp s'") - apply (clarsimp simp: obj_at'_def projectKOs objBits_simps') - apply (prop_tac "reply_at nrp s") - apply (drule (1) valid_sched_context_objsI) - apply (clarsimp simp: valid_sched_context_def) - apply (frule pspace_relation_pspace_bounded'[OF state_relation_pspace_relation]) - apply (frule_tac nrp=nrp in next_reply_in_sc_replies[where rp=rp, OF state_relation_sc_replies_relation]) - apply (simp add: obj_at'_def projectKOs objBits_simps' opt_map_red)+ - apply (clarsimp simp: vs_heap_simps) - apply (drule_tac x=nextr in z) - apply (clarsimp simp: state_relation_def obj_at_def is_reply obj_at'_def projectKOs) - apply (rule conjI) - (* pspace_relation *) - apply (simp only: pspace_relation_def simp_thms - pspace_dom_update[where x="kernel_object.SchedContext _ _" - and v="kernel_object.SchedContext _ _", - simplified a_type_def, simplified]) - apply (simp only: dom_fun_upd2 simp_thms) - apply (elim conjE) - apply (frule bspec, erule domI) - apply (frule_tac x=nrp in bspec, erule domI) - apply (rule ballI, drule (1) bspec) - apply (drule domD) - apply (prop_tac "scp \ nrp", clarsimp) - apply (clarsimp simp: project_inject split: if_split_asm kernel_object.split_asm) - apply (rule conjI; clarsimp) - apply (clarsimp simp: sc_relation_def) - apply (rename_tac bb aa ba) - apply (drule_tac x="(aa, ba)" in bspec, simp) - apply (clarsimp simp: obj_at_def is_reply) - apply (frule_tac ko'="kernel_object.Reply reply" and x'=nrp in obj_relation_cut_same_type) - apply simp+ - apply (clarsimp simp: reply_relation_def) - apply (rule conjI) - (* sc_replies_relation *) - 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) - apply (intro conjI impI allI) - (* p = scp *) - apply (clarsimp simp: opt_map_red) - apply (prop_tac "replyPrevs_of s' nrp = Some rp") - apply (simp add: sym_refs_replyNext_replyPrev_sym[symmetric]) - apply (clarsimp simp: opt_map_red) - apply (prop_tac "scReply sc' \ Some rp") - apply (drule heap_path_head; clarsimp) - apply (frule (4) heap_ls_next_takeWhile_append_sym[OF _ _ _ _ reply_sym_heap_Prev_Next]) - apply simp - apply (rule heap_path_heap_upd_not_in[rotated]) - using set_takeWhileD apply (metis (full_types)) - apply (erule heap_path_takeWhile_lookup_next) - apply (prop_tac "nrp \ set (takeWhile ((\) rp) (sc_replies sc))") - apply clarsimp - using set_takeWhileD apply metis - (* p \ scp *) - apply (rule heap_path_heap_upd_not_in) - apply clarsimp - apply (clarsimp simp: opt_map_Some) - apply (prop_tac "replyPrevs_of s' nrp = Some rp") - apply (simp add: sym_refs_replyNext_replyPrev_sym[symmetric]) - apply (clarsimp simp: opt_map_red) - apply (frule (2) heap_ls_next_in_list) - apply (simp add: sc_with_reply_def the_pred_option_def - split: if_split_asm) - apply blast - apply (clarsimp simp add: ghost_relation_def) - 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 (clarsimp simp: caps_of_state_after_update cte_wp_at_after_update - swp_def fun_upd_def obj_at_simps) - by (erule no_failD[OF no_fail_updateReply]) -qed - -(* end : related corres rules *) - -end diff --git a/proof/refine/ARM/Retype_R.thy b/proof/refine/ARM/Retype_R.thy index f19da22b7c..523fb20092 100644 --- a/proof/refine/ARM/Retype_R.thy +++ b/proof/refine/ARM/Retype_R.thy @@ -12,19 +12,17 @@ theory Retype_R imports VSpace_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition APIType_map2 :: "kernel_object + ARM_H.object_type \ Structures_A.apiobject_type" where "APIType_map2 ty \ case ty of - Inr (APIObjectType Untyped) \ Structures_A.Untyped - | Inr (APIObjectType TCBObject) \ Structures_A.TCBObject - | Inr (APIObjectType EndpointObject) \ Structures_A.EndpointObject - | Inr (APIObjectType NotificationObject) \ Structures_A.NotificationObject - | Inr (APIObjectType CapTableObject) \ Structures_A.CapTableObject - | Inr (APIObjectType ReplyObject) \ Structures_A.ReplyObject - | Inr (APIObjectType SchedContextObject) \ Structures_A.SchedContextObject + Inr (APIObjectType ArchTypes_H.Untyped) \ Structures_A.Untyped + | Inr (APIObjectType ArchTypes_H.TCBObject) \ Structures_A.TCBObject + | Inr (APIObjectType ArchTypes_H.EndpointObject) \ Structures_A.EndpointObject + | Inr (APIObjectType ArchTypes_H.NotificationObject) \ Structures_A.NotificationObject + | Inr (APIObjectType ArchTypes_H.CapTableObject) \ Structures_A.CapTableObject | Inr PageTableObject \ ArchObject PageTableObj | Inr PageDirectoryObject \ ArchObject PageDirectoryObj | Inr LargePageObject \ ArchObject LargePageObj @@ -56,17 +54,20 @@ lemma createObjects_ret: shiftl_t2n power_add) done +lemma objBitsKO_bounded2[simp]: + "objBitsKO ko < word_bits" + by (simp add: objBits_simps' word_bits_def pageBits_def archObjSize_def pdeBits_def pteBits_def + split: Structures_H.kernel_object.split arch_kernel_object.split) + definition APIType_capBits :: "ARM_H.object_type \ nat \ nat" where "APIType_capBits ty us \ case ty of - APIObjectType Untyped \ us - | APIObjectType TCBObject \ objBits (makeObject :: tcb) - | APIObjectType EndpointObject \ objBits (makeObject :: endpoint) - | APIObjectType NotificationObject \ objBits (makeObject :: notification) - | APIObjectType ReplyObject \ objBits (makeObject :: reply) - | APIObjectType CapTableObject \ objBits (makeObject :: cte) + us - | APIObjectType SchedContextObject \ us + APIObjectType ArchTypes_H.Untyped \ us + | APIObjectType ArchTypes_H.TCBObject \ objBits (makeObject :: tcb) + | APIObjectType ArchTypes_H.EndpointObject \ objBits (makeObject :: endpoint) + | APIObjectType ArchTypes_H.NotificationObject \ objBits (makeObject :: Structures_H.notification) + | APIObjectType ArchTypes_H.CapTableObject \ objBits (makeObject :: cte) + us | SmallPageObject \ pageBitsForSize ARMSmallPage | LargePageObject \ pageBitsForSize ARMLargePage | SectionObject \ pageBitsForSize ARMSection @@ -75,20 +76,15 @@ where | PageDirectoryObject \ 14" definition - makeObjectKO :: "bool \ nat \ domain \ (kernel_object + ARM_H.object_type) \ kernel_object" + makeObjectKO :: "bool \ (kernel_object + ARM_H.object_type) \ kernel_object" where - "makeObjectKO dev us d ty \ case ty of + "makeObjectKO dev ty \ case ty of Inl KOUserData \ Some KOUserData | Inl (KOArch (KOASIDPool _)) \ Some (KOArch (KOASIDPool makeObject)) - | Inr (APIObjectType ArchTypes_H.TCBObject) \ Some (KOTCB (tcbDomain_update (\_. d) makeObject)) + | Inr (APIObjectType ArchTypes_H.TCBObject) \ Some (KOTCB makeObject) | Inr (APIObjectType ArchTypes_H.EndpointObject) \ Some (KOEndpoint makeObject) | Inr (APIObjectType ArchTypes_H.NotificationObject) \ Some (KONotification makeObject) | Inr (APIObjectType ArchTypes_H.CapTableObject) \ Some (KOCTE makeObject) - | Inr (APIObjectType ArchTypes_H.ReplyObject) \ Some (KOReply makeObject) - | Inr (APIObjectType ArchTypes_H.SchedContextObject) \ - Some (KOSchedContext ((makeObject :: sched_context) - \scRefills := replicate (refillAbsoluteMax' us) emptyRefill, - scSize := us - minSchedContextBits\)) | Inr PageTableObject \ Some (KOArch (KOPTE makeObject)) | Inr PageDirectoryObject \ Some (KOArch (KOPDE makeObject)) | Inr SmallPageObject \ Some (if dev then KOUserDataDevice else KOUserData) @@ -112,12 +108,6 @@ lemma valid_obj_makeObject_tcb [simp]: unfolding valid_obj'_def valid_tcb'_def valid_tcb_state'_def by (clarsimp simp: makeObject_tcb makeObject_cte tcb_cte_cases_def minBound_word) -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 - by (clarsimp simp: makeObject_tcb makeObject_cte - tcb_cte_cases_def maxDomain_def maxPriority_def numPriorities_def minBound_word) - lemma valid_obj_makeObject_endpoint [simp]: "valid_obj' (KOEndpoint makeObject) s" unfolding valid_obj'_def valid_ep'_def @@ -128,29 +118,6 @@ lemma valid_obj_makeObject_notification [simp]: unfolding valid_obj'_def valid_ntfn'_def by (clarsimp simp: makeObject_notification) -lemma valid_obj_makeObject_reply [simp]: - "valid_obj' (KOReply makeObject) s" - unfolding valid_obj'_def valid_reply'_def - by (clarsimp simp: makeObject_reply) - -lemma valid_sc_size'_makeObject_sc': - "sc_size_bounds us \ - valid_sched_context_size' - ((makeObject :: sched_context)\scRefills := replicate (refillAbsoluteMax' us) emptyRefill, - scSize := us - minSchedContextBits\)" - by (clarsimp simp: makeObject_sc valid_sched_context_size'_def scBits_simps - objBits_def objBitsKO_def) - -lemma valid_obj_makeObject_sched_context [simp]: - "sc_size_bounds us \ - valid_obj' (KOSchedContext ((makeObject :: sched_context) - \scRefills := replicate (refillAbsoluteMax' us) emptyRefill, - scSize := us - minSchedContextBits\)) s" - unfolding valid_obj'_def valid_sched_context'_def - using sc_size_bounds_def - by (clarsimp simp: valid_sc_size'_makeObject_sc') - (clarsimp simp: makeObject_sc) - lemma valid_obj_makeObject_user_data [simp]: "valid_obj' (KOUserData) s" unfolding valid_obj'_def by simp @@ -175,7 +142,6 @@ lemma valid_obj_makeObject_asid_pool[simp]: lemmas valid_obj_makeObject_rules = valid_obj_makeObject_user_data valid_obj_makeObject_tcb valid_obj_makeObject_endpoint valid_obj_makeObject_notification - valid_obj_makeObject_reply valid_obj_makeObject_sched_context valid_obj_makeObject_cte valid_obj_makeObject_pte valid_obj_makeObject_pde valid_obj_makeObject_asid_pool valid_obj_makeObject_user_data_device @@ -330,14 +296,14 @@ lemma cte_at_next_slot'': lemma state_relation_null_filterE: - "\ (s, s') \ state_relation; t = kheap_update f s; + "\ (s, s') \ state_relation; t = kheap_update f (ekheap_update ef s); \f' g' h'. t' = s'\ksPSpace := f' (ksPSpace s'), gsUserPages := g' (gsUserPages s'), gsCNodes := h' (gsCNodes s')\; 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'; + ekheap_relation (ekheap t) (ksPSpace t'); ready_queues_relation t t'; ghost_relation (kheap t) (gsUserPages t') (gsCNodes t'); valid_list s; pspace_aligned' s'; pspace_distinct' s'; valid_objs s; valid_mdb s; pspace_aligned' t'; pspace_distinct' t'; @@ -355,11 +321,12 @@ lemma state_relation_null_filterE: apply (case_tac "cdt s (a, b)") apply (subst mdb_cte_at_no_descendants, assumption) apply (simp add: cte_wp_at_caps_of_state swp_def) - apply (cut_tac s="kheap_update f s" and + apply (cut_tac s="kheap_update f (ekheap_update ef s)" and s'="s'\ksPSpace := f' (ksPSpace s'), gsUserPages := g' (gsUserPages s'), gsCNodes := h' (gsCNodes s')\" in pspace_relation_ctes_ofI, simp_all)[1] + apply (simp add: trans_state_update[symmetric] del: trans_state_update) apply (erule caps_of_state_cteD) apply (clarsimp simp: descendants_of'_def) apply (case_tac cte) @@ -430,7 +397,7 @@ lemma foldr_update_ko_wp_at': assumes pv: "pspace_aligned' s" "pspace_distinct' s" and pv': "pspace_aligned' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" "pspace_distinct' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" - and al: "\x \ set addrs. is_aligned x (objBitsKO obj)" "objBitsKO obj < word_bits" + and al: "\x \ set addrs. is_aligned x (objBitsKO obj)" shows "ko_wp_at' P p (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s) = (if p \ set addrs then P obj @@ -453,7 +420,7 @@ lemma foldr_update_obj_at': assumes pv: "pspace_aligned' s" "pspace_distinct' s" and pv': "pspace_aligned' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" "pspace_distinct' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" - and al: "\x \ set addrs. is_aligned x (objBitsKO obj)" "objBitsKO obj < word_bits" + and al: "\x \ set addrs. is_aligned x (objBitsKO obj)" shows "obj_at' P p (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s) = (if p \ set addrs then (\obj'. projectKO_opt obj = Some obj' \ P obj') @@ -463,12 +430,12 @@ lemma foldr_update_obj_at': done lemma makeObjectKO_eq: - assumes x: "makeObjectKO dev us d tp = Some v" + assumes x: "makeObjectKO dev tp = Some v" shows "(v = KOCTE cte) = (tp = Inr (APIObjectType ArchTypes_H.CapTableObject) \ cte = makeObject)" "(v = KOTCB tcb) = - (tp = Inr (APIObjectType ArchTypes_H.TCBObject) \ tcb = (tcbDomain_update (\_. d) makeObject))" + (tp = Inr (APIObjectType ArchTypes_H.TCBObject) \ tcb = makeObject)" using x by (simp add: makeObjectKO_def eq_commute split: apiobject_type.split_asm sum.split_asm kernel_object.split_asm @@ -523,11 +490,11 @@ lemma ps_clearD: done lemma cte_wp_at_retype': - assumes ko: "makeObjectKO dev us d tp = Some obj" + assumes ko: "makeObjectKO dev tp = Some obj" and pv: "pspace_aligned' s" "pspace_distinct' s" and pv': "pspace_aligned' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" "pspace_distinct' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" - and al: "\x \ set addrs. is_aligned x (objBitsKO obj)""objBitsKO obj < word_bits" + and al: "\x \ set addrs. is_aligned x (objBitsKO obj)" and pn: "\x \ set addrs. ksPSpace s x = None" shows "cte_wp_at' P p (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s) @@ -544,14 +511,13 @@ lemma cte_wp_at_retype': apply (simp only: cte_wp_at_obj_cases_mask foldr_update_obj_at'[OF pv pv' al]) apply (simp add: projectKOs the_ctes_makeObject makeObjectKO_eq [OF ko] - makeObject_cte + makeObject_cte dom_def split del: if_split cong: if_cong) apply (insert al ko) - apply simp - apply (safe; simp) - apply ((fastforce simp: makeObjectKO_def makeObject_cte makeObject_tcb tcb_cte_cases_def - split: if_split_asm)+)[10] + apply (simp, safe, simp_all) + apply fastforce + apply fastforce apply (clarsimp elim!: obj_atE' simp: projectKOs objBits_simps) apply (drule ps_clearD[where y=p and n=tcbBlockSizeBits]) apply simp @@ -563,11 +529,11 @@ lemma cte_wp_at_retype': done lemma ctes_of_retype: - assumes ko: "makeObjectKO dev us d tp = Some obj" + assumes ko: "makeObjectKO dev tp = Some obj" and pv: "pspace_aligned' s" "pspace_distinct' s" and pv': "pspace_aligned' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" "pspace_distinct' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" - and al: "\x \ set addrs. is_aligned x (objBitsKO obj)" "objBitsKO obj < word_bits" + and al: "\x \ set addrs. is_aligned x (objBitsKO obj)" and pn: "\x \ set addrs. ksPSpace s x = None" shows "map_to_ctes (\ xa. if xa \ set addrs then Some obj else ksPSpace s xa) @@ -592,11 +558,11 @@ lemma None_ctes_of_cte_at: by (fastforce simp add: cte_wp_at_ctes_of) lemma null_filter_ctes_retype: - assumes ko: "makeObjectKO dev us d tp = Some obj" + assumes ko: "makeObjectKO dev tp = Some obj" and pv: "pspace_aligned' s" "pspace_distinct' s" and pv': "pspace_aligned' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" "pspace_distinct' (ksPSpace_update (\x xa. if xa \ set addrs then Some obj else ksPSpace s xa) s)" - and al: "\x \ set addrs. is_aligned x (objBitsKO obj)" "objBitsKO obj < word_bits" + and al: "\x \ set addrs. is_aligned x (objBitsKO obj)" and pn: "\x \ set addrs. ksPSpace s x = None" shows "null_filter' (map_to_ctes (foldr (\addr. data_map_insert addr obj) addrs (ksPSpace s))) @@ -623,12 +589,11 @@ lemma null_filter_ctes_retype: apply (insert ko[symmetric], simp add: makeObjectKO_def objBits_simps) apply clarsimp apply (subst(asm) subtract_mask[symmetric], - erule_tac v="if x \ set addrs then KOTCB (tcbDomain_update (\_. d) makeObject) - else KOCTE cte" + erule_tac v="if x \ set addrs then KOTCB makeObject else KOCTE cte" in tcb_space_clear) apply (simp add: is_aligned_mask word_bw_assocs) apply assumption - apply fastforce + apply simp apply simp apply (simp add: pn) apply (clarsimp simp: makeObjectKO_def) @@ -743,14 +708,7 @@ lemma APIType_map2_Untyped[simp]: "(APIType_map2 tp = Structures_A.Untyped) = (tp = Inr (APIObjectType ArchTypes_H.Untyped))" 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_SchedContext[simp]: - "(APIType_map2 tp = Structures_A.SchedContextObject) - = (tp = Inr (APIObjectType SchedContextObject))" - by (simp add: APIType_map2_def - split: sum.split object_type.split kernel_object.split arch_kernel_object.splits + split: sum.split object_type.split kernel_object.split arch_kernel_object.splits apiobject_type.split) lemma obj_relation_retype_leD: @@ -759,14 +717,13 @@ lemma obj_relation_retype_leD: by (simp add: obj_relation_retype_def) lemma obj_relation_retype_default_leD: - "\ obj_relation_retype (default_object (APIType_map2 ty) dev us d) ko; - ty \ Inr (APIObjectType ArchTypes_H.Untyped); - ty = Inr (APIObjectType SchedContextObject) \ min_sched_context_bits \ us \ + "\ obj_relation_retype (default_object (APIType_map2 ty) dev us) ko; + ty \ Inr (APIObjectType ArchTypes_H.Untyped) \ \ objBitsKO ko \ obj_bits_api (APIType_map2 ty) us" - by (clarsimp simp: obj_relation_retype_def objBits_def obj_bits_dev_irr) + by (simp add: obj_relation_retype_def objBits_def obj_bits_dev_irr) lemma makeObjectKO_Untyped: - "makeObjectKO dev us d ty = Some v \ ty \ Inr (APIObjectType ArchTypes_H.Untyped)" + "makeObjectKO dev ty = Some v \ ty \ Inr (APIObjectType ArchTypes_H.Untyped)" by (clarsimp simp: makeObjectKO_def) lemma obj_relation_cuts_trivial: @@ -789,23 +746,22 @@ lemma obj_relation_cuts_trivial: lemma obj_relation_retype_addrs_eq: assumes not_unt:"ty \ Inr (APIObjectType ArchTypes_H.Untyped)" - assumes tysc: "ty = Inr (APIObjectType SchedContextObject) \ min_sched_context_bits \ us" assumes amp: "m = 2^ ((obj_bits_api (APIType_map2 ty) us) - (objBitsKO ko)) * n" - assumes orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us d) ko" + assumes orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us) ko" shows "\ range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n \ \ (\x \ set (retype_addrs ptr (APIType_map2 ty) n us). - fst ` obj_relation_cuts (default_object (APIType_map2 ty) dev us d) x) + fst ` obj_relation_cuts (default_object (APIType_map2 ty) dev us) x) = set (new_cap_addrs m ptr ko)" apply (rule set_eqI, rule iffI) apply (clarsimp simp: retype_addrs_def) apply (rename_tac p a b) apply (drule obj_relation_retype_cutsD[OF _ orr]) - apply (cut_tac obj_relation_retype_default_leD[OF orr not_unt tysc]) + apply (cut_tac obj_relation_retype_default_leD[OF orr not_unt]) apply (clarsimp simp: new_cap_addrs_def image_def dest!: less_two_pow_divD) apply (rule_tac x="p * 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) + unat y" in rev_bexI) - apply (simp add: amp obj_bits_api_default_object not_unt tysc obj_bits_dev_irr) + apply (simp add: amp obj_bits_api_default_object not_unt obj_bits_dev_irr) apply (rule less_le_trans[OF nat_add_left_cancel_less[THEN iffD2]]) apply (erule unat_mono) apply (subst unat_power_lower) @@ -821,7 +777,7 @@ lemma obj_relation_retype_addrs_eq: apply (clarsimp simp: new_cap_addrs_def retype_addrs_def dest!: less_two_pow_divD) apply (rename_tac p) - apply (cut_tac obj_relation_retype_default_leD[OF orr not_unt tysc]) + apply (cut_tac obj_relation_retype_default_leD[OF orr not_unt]) apply (cut_tac obj_relation_retype_leD[OF orr]) apply (case_tac "n = 0") apply (simp add:amp) @@ -850,20 +806,18 @@ lemma obj_relation_retype_addrs_eq: apply (rule power_strict_increasing) apply (rule le_less_trans[OF diff_le_self]) apply (clarsimp simp: range_cover_def obj_bits_api_default_object obj_bits_dev_irr - not_unt word_bits_def tysc)+ - done + not_unt word_bits_def)+ +done lemma objBits_le_obj_bits_api: - "ty = Inr (APIObjectType SchedContextObject) \ min_sched_context_bits \ us \ - makeObjectKO dev us d ty = Some ko \ + "makeObjectKO dev ty = Some ko \ objBitsKO ko \ obj_bits_api (APIType_map2 ty) us" apply (case_tac ty) - by (auto simp: default_arch_object_def pageBits_def archObjSize_def pteBits_def pdeBits_def - makeObjectKO_def objBits_simps' APIType_map2_def obj_bits_api_def slot_bits_def - scBits_simps - split: Structures_H.kernel_object.splits arch_kernel_object.splits object_type.splits - Structures_H.kernel_object.splits arch_kernel_object.splits apiobject_type.splits - if_split_asm) + apply (auto simp: default_arch_object_def pageBits_def archObjSize_def pteBits_def pdeBits_def + makeObjectKO_def objBits_simps' APIType_map2_def obj_bits_api_def slot_bits_def + split: Structures_H.kernel_object.splits arch_kernel_object.splits object_type.splits + Structures_H.kernel_object.splits arch_kernel_object.splits apiobject_type.splits) + done lemma obj_relation_retype_other_obj: "\ is_other_obj_relation_type (a_type ko); other_obj_relation ko ko' \ @@ -878,68 +832,18 @@ lemma obj_relation_retype_other_obj: arch_kernel_obj.split_asm arch_kernel_object.split) done -lemma retype_kheap_dom_same: - assumes pn: "pspace_no_overlap_range_cover ptr sz s" - and vs: "valid_pspace s" "valid_mdb s" - and cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" - shows - "kheap s x = Some v \ - (foldr (\p ps. ps(p \ default_object (APIType_map2 ty) dev us d)) - (retype_addrs ptr (APIType_map2 ty) n us) (kheap s)) x = Some v" -proof - - have dom_not_ra: - "\x \ dom (kheap s). x \ set (retype_addrs ptr (APIType_map2 ty) n us)" - apply clarsimp - apply (erule(1) pspace_no_overlapC[OF pn _ _ cover vs(1)]) - done - assume H: "kheap s x = Some v" - thus ?thesis - apply - - apply (frule bspec [OF dom_not_ra, OF domI]) - apply (simp add: foldr_upd_app_if) - done -qed - -lemma retype_ksPSpace_dom_same: - fixes x v - assumes 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 num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" - shows - "ksPSpace s' x = Some v \ - foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s') x - = Some v" -proof - - have cover':"range_cover ptr sz (objBitsKO ko) m" - by (rule range_cover_rel[OF cover objBits_le_obj_bits_api[OF tysc ko] num_r]) - assume "ksPSpace s' x = Some v" - thus ?thesis - apply (clarsimp simp:foldr_upd_app_if[folded data_map_insert_def]) - apply (drule domI[where m = "ksPSpace s'"]) - apply (drule(1) IntI) - apply (erule_tac A = "A \ B" for A B in in_emptyE[rotated]) - apply (rule disjoint_subset[OF new_cap_addrs_subset[OF cover']]) - apply (clarsimp simp:ptr_add_def field_simps) - apply (rule pspace_no_overlap_disjoint'[OF vs'(1) pn']) - done -qed - lemma retype_pspace_relation: assumes sr: "pspace_relation (kheap s) (ksPSpace s')" and vs: "valid_pspace s" "valid_mdb s" and vs': "pspace_aligned' s'" "pspace_distinct' s'" and pn: "pspace_no_overlap_range_cover ptr sz 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 ko: "makeObjectKO dev ty = Some ko" 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 orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us) ko" and num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" shows - "pspace_relation (foldr (\p ps. ps(p \ default_object (APIType_map2 ty) dev us d)) + "pspace_relation (foldr (\p ps. ps(p \ default_object (APIType_map2 ty) dev us)) (retype_addrs ptr (APIType_map2 ty) n us) (kheap s)) (foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s'))" (is "pspace_relation ?ps ?ps'") @@ -958,7 +862,7 @@ proof "set (retype_addrs ptr (APIType_map2 ty) n us) \ dom (kheap s) = {}" by auto - note pdom = pspace_dom_upd [OF dom_Int_ra, where ko="default_object (APIType_map2 ty) dev us d"] + note pdom = pspace_dom_upd [OF dom_Int_ra, where ko="default_object (APIType_map2 ty) dev us"] have pdom': "dom ?ps' = dom (ksPSpace s') \ set (new_cap_addrs m ptr ko)" by (clarsimp simp add: foldr_upd_app_if[folded data_map_insert_def] @@ -973,12 +877,26 @@ proof thus "pspace_dom ?ps = dom ?ps'" apply (simp add: pdom pdom') apply (rule arg_cong[where f="\T. S \ T" for S]) - apply (rule obj_relation_retype_addrs_eq[OF not_unt tysc num_r orr cover]) + apply (rule obj_relation_retype_addrs_eq[OF not_unt num_r orr cover]) done - note dom_same = retype_kheap_dom_same[OF pn vs cover] - - note dom_same' = retype_ksPSpace_dom_same[OF vs' pn' ko tysc cover num_r] + have dom_same: + "\x v. kheap s x = Some v \ ?ps x = Some v" + apply (frule bspec [OF dom_not_ra, OF domI]) + apply (simp add: foldr_upd_app_if) + done + have cover':"range_cover ptr sz (objBitsKO ko) m" + by (rule range_cover_rel[OF cover objBits_le_obj_bits_api[OF ko] num_r]) + have dom_same': + "\x v. ksPSpace s' x = Some v \ ?ps' x = Some v" + apply (clarsimp simp:foldr_upd_app_if[folded data_map_insert_def]) + apply (drule domI[where m = "ksPSpace s'"]) + apply (drule(1) IntI) + apply (erule_tac A = "A \ B" for A B in in_emptyE[rotated]) + apply (rule disjoint_subset[OF new_cap_addrs_subset[OF cover']]) + apply (clarsimp simp:ptr_add_def field_simps) + apply (rule pspace_no_overlap_disjoint'[OF vs'(1) pn']) + done show "\x \ dom ?ps. \(y, P) \ obj_relation_cuts (the (?ps x)) x. P (the (?ps x)) (the (?ps' y))" @@ -989,7 +907,7 @@ proof apply (rule conjI) apply (drule obj_relation_retype_cutsD [OF _ orr], clarsimp) apply (rule impI, erule notE) - apply (simp add: obj_relation_retype_addrs_eq[OF not_unt tysc num_r orr cover,symmetric]) + apply (simp add: obj_relation_retype_addrs_eq[OF not_unt num_r orr cover,symmetric]) apply (erule rev_bexI) apply (simp add: image_def) apply (erule rev_bexI, simp) @@ -1016,6 +934,79 @@ lemma foldr_upd_app_if': "foldr (\p ps. ps(p := f p)) as g = (\x apply simp done +lemma etcb_rel_makeObject: "etcb_relation default_etcb makeObject" + apply (simp add: etcb_relation_def default_etcb_def) + apply (simp add: makeObject_tcb default_priority_def default_domain_def) + done + + +lemma ekh_at_tcb_at: "valid_etcbs_2 ekh kh \ ekh x = Some y \ \tcb. kh x = Some (TCB tcb)" + apply (simp add: valid_etcbs_2_def + st_tcb_at_kh_def obj_at_kh_def + is_etcb_at'_def obj_at_def) + apply force + done + +lemma default_etcb_default_domain_futz [simp]: + "default_etcb\tcb_domain := default_domain\ = default_etcb" +unfolding default_etcb_def by simp + +lemma retype_ekheap_relation: + assumes sr: "ekheap_relation (ekheap s) (ksPSpace s')" + and sr': "pspace_relation (kheap s) (ksPSpace s')" + and vs: "valid_pspace s" "valid_mdb s" + and et: "valid_etcbs s" + and vs': "pspace_aligned' s'" "pspace_distinct' s'" + and pn: "pspace_no_overlap_range_cover ptr sz s" + and pn': "pspace_no_overlap' ptr sz s'" + and ko: "makeObjectKO dev ty = Some ko" + 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) ko" + and num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" + shows + "ekheap_relation (foldr (\p ps. ps(p := default_ext (APIType_map2 ty) default_domain)) + (retype_addrs ptr (APIType_map2 ty) n us) (ekheap s)) + (foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s'))" + (is "ekheap_relation ?ps ?ps'") + proof - + have not_unt: "ty \ Inr (APIObjectType ArchTypes_H.Untyped)" + by (rule makeObjectKO_Untyped[OF ko]) + show ?thesis + apply (case_tac "ty \ Inr (APIObjectType apiobject_type.TCBObject)") + apply (insert ko) + apply (cut_tac retype_pspace_relation[OF sr' vs vs' pn pn' ko cover orr num_r]) + apply (simp add: foldr_upd_app_if' foldr_upd_app_if[folded data_map_insert_def]) + apply (simp add: obj_relation_retype_addrs_eq[OF not_unt num_r orr cover,symmetric]) + apply (insert sr) + apply (clarsimp simp add: ekheap_relation_def + pspace_relation_def default_ext_def cong: if_cong + split: if_split_asm) + subgoal by (clarsimp simp add: makeObjectKO_def APIType_map2_def cong: if_cong + split: sum.splits Structures_H.kernel_object.splits + arch_kernel_object.splits ARM_H.object_type.splits apiobject_type.splits) + + apply (frule ekh_at_tcb_at[OF et]) + apply (intro impI conjI) + apply clarsimp + apply (drule_tac x=a in bspec,force) + apply (clarsimp simp add: tcb_relation_cut_def split: if_split_asm) + apply (case_tac ko,simp_all) + apply (clarsimp simp add: makeObjectKO_def cong: if_cong split: sum.splits Structures_H.kernel_object.splits + arch_kernel_object.splits ARM_H.object_type.splits + apiobject_type.splits if_split_asm) + apply (drule_tac x=xa in bspec,simp) + subgoal by force + subgoal by force + apply (simp add: foldr_upd_app_if' foldr_upd_app_if[folded data_map_insert_def]) + apply (simp add: obj_relation_retype_addrs_eq[OF not_unt num_r orr cover,symmetric]) + apply (clarsimp simp add: APIType_map2_def default_ext_def ekheap_relation_def + default_object_def makeObjectKO_def etcb_rel_makeObject + cong: if_cong + split: if_split_asm) + apply force + done +qed + lemma pspace_no_overlapD': "\ ksPSpace s x = Some ko; pspace_no_overlap' p bits s \ \ {x .. x + 2 ^ objBitsKO ko - 1} \ {p .. (p && ~~ mask bits) + 2 ^ bits - 1} = {}" @@ -1080,14 +1071,11 @@ qed lemma retype_aligned_distinct': assumes vs': "pspace_aligned' s'" "pspace_distinct' s'" - and bd : "pspace_bounded' s'" and pn': "pspace_no_overlap' ptr sz s'" and cover: "range_cover ptr sz (objBitsKO ko) n " shows "pspace_distinct' (s' \ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs n ptr ko) (ksPSpace s')\)" - "pspace_bounded' (s' \ksPSpace := foldr (\addr. data_map_insert addr ko) - (new_cap_addrs n ptr ko) (ksPSpace s')\)" "pspace_aligned' (s' \ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs n ptr ko) (ksPSpace s')\)" (is "pspace_aligned' (s'\ksPSpace := ?ps\)") @@ -1106,6 +1094,9 @@ proof - apply (drule bspec, erule domI, simp) done + have okov: "objBitsKO ko < word_bits" + by (simp add: objBits_def) + have new_range_disjoint: "\x. x \ set (new_cap_addrs n ptr ko) \ ({x .. x + 2 ^ (objBitsKO ko) - 1} - {x}) \ set (new_cap_addrs n ptr ko) = {}" @@ -1142,15 +1133,6 @@ proof - apply (rule disjoint_subset[OF Diff_subset]) apply (erule pspace_no_overlapD' [OF _ pn']) done - - show bd': "pspace_bounded' ?s'" using bd - apply (subst foldr_upd_app_if[folded data_map_insert_def]) - apply (clarsimp simp: pspace_bounded'_def split: if_split_asm) - using cover - apply (simp add: range_cover_def word_bits_def) - apply (drule bspec, erule domI, simp) - done - qed definition @@ -1181,7 +1163,7 @@ end global_interpretation update_gs: PSpace_update_eq "update_gs ty us ptrs" by (simp add: PSpace_update_eq_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma ksReadyQueues_update_gs[simp]: "ksReadyQueues (update_gs tp us addrs s) = ksReadyQueues s" @@ -1207,173 +1189,188 @@ lemma update_gs_simps[simp]: else ups x)" by (simp_all add: update_gs_def) -lemma retype_obj_at'_not: - assumes ad: "pspace_aligned' s" "pspace_distinct' s" - and pn: "pspace_no_overlap' ptr sz s" - and cover: "range_cover ptr sz (objBitsKO val + gbits) n" - shows "\P x. x \ set (new_cap_addrs (2 ^ gbits * n) ptr val) \ \ obj_at' P x s" +lemma retype_ksPSpace_dom_same: + fixes x v + assumes vs': "pspace_aligned' s'" "pspace_distinct' s'" + assumes pn': "pspace_no_overlap' ptr sz s'" + assumes ko: "makeObjectKO dev ty = Some ko" + assumes cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" + assumes num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" + shows + "ksPSpace s' x = Some v \ + foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s') x + = Some v" proof - - note cover' = range_cover_rel[where sbit' = "objBitsKO val",OF cover _ refl,simplified] - show "\P x. x \ set (new_cap_addrs (2 ^ gbits * n) ptr val) \ \ obj_at' P x s" - apply (clarsimp simp: obj_at'_def) - apply (drule subsetD [OF new_cap_addrs_subset [OF cover' ]]) - apply (insert pspace_no_overlap_disjoint' [OF ad(1) pn]) - apply (drule domI[where m = "ksPSpace s"]) - apply (drule(1) orthD2) - apply (clarsimp simp:ptr_add_def p_assoc_help) + have cover':"range_cover ptr sz (objBitsKO ko) m" + by (rule range_cover_rel[OF cover objBits_le_obj_bits_api[OF ko] num_r]) + assume "ksPSpace s' x = Some v" + thus ?thesis + apply (clarsimp simp:foldr_upd_app_if[folded data_map_insert_def]) + apply (drule domI[where m = "ksPSpace s'"]) + apply (drule(1) IntI) + apply (erule_tac A = "A \ B" for A B in in_emptyE[rotated]) + apply (rule disjoint_subset[OF new_cap_addrs_subset[OF cover']]) + apply (clarsimp simp:ptr_add_def field_simps) + apply (rule pspace_no_overlap_disjoint'[OF vs'(1) pn']) done qed -lemma retype_ko_wp_at'_not: - assumes ad: "pspace_aligned' s" "pspace_distinct' s" - and pn: "pspace_no_overlap' ptr sz s" - and cover: "range_cover ptr sz (objBitsKO val + gbits) n" - shows "\P x. x \ set (new_cap_addrs (2 ^ gbits * n) ptr val) \ \ ko_wp_at' P x s" +lemma retype_ksPSpace_None: + assumes ad: "pspace_aligned' s" "pspace_distinct' s" "pspace_bounded' s" + assumes pn: "pspace_no_overlap' ptr sz s" + assumes cover: "range_cover ptr sz (objBitsKO val + gbits) n" + shows "\x. x \ set (new_cap_addrs (2 ^ gbits * n) ptr val) \ ksPSpace s x = None" proof - note cover' = range_cover_rel[where sbit' = "objBitsKO val",OF cover _ refl,simplified] - show "\P x. x \ set (new_cap_addrs (2 ^ gbits * n) ptr val) \ \ ko_wp_at' P x s" - apply (clarsimp simp: ko_wp_at'_def) - apply (drule subsetD [OF new_cap_addrs_subset [OF cover' ]]) + show "\x. x \ set (new_cap_addrs (2 ^ gbits * n) ptr val) \ ksPSpace s x = None" + apply (drule subsetD[OF new_cap_addrs_subset [OF cover' ]]) apply (insert pspace_no_overlap_disjoint' [OF ad(1) pn]) - apply (drule domI[where m = "ksPSpace s"]) - apply (drule(1) orthD2) - apply (clarsimp simp:ptr_add_def p_assoc_help) + apply (fastforce simp: ptr_add_def p_assoc_help) done qed -lemma retype_replyPrevs_of: - assumes pr: "pspace_relation (kheap s) (ksPSpace s')" - and vs: "valid_pspace s" "valid_mdb s" - and vs': "pspace_aligned' s'" "pspace_distinct' s'" - and pn: "pspace_no_overlap_range_cover ptr sz 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" +lemma retype_tcbSchedPrevs_of: + assumes vs': "pspace_aligned' s'" "pspace_distinct' s'" + assumes pn': "pspace_no_overlap' ptr sz s'" + assumes ko: "makeObjectKO dev ty = Some ko" + assumes cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" + assumes num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" shows - "replyPrevs_of - (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\) - = replyPrevs_of s'" (is "replyPrevs_of ?ps' = replyPrevs_of s'") + "tcbSchedPrevs_of + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\) + = tcbSchedPrevs_of s'" proof - - note dom_same' = retype_ksPSpace_dom_same[OF vs' pn' ko tysc cover num_r] + note dom_same' = retype_ksPSpace_dom_same[OF vs' pn' ko cover num_r] show ?thesis apply (rule ext) - using pr apply (clarsimp simp: opt_map_def split: option.splits) apply (intro impI conjI allI; (drule dom_same'; simp)?) - apply (clarsimp simp:foldr_upd_app_if[folded data_map_insert_def] projectKO_opt_reply + apply (clarsimp simp: foldr_upd_app_if[folded data_map_insert_def] split: if_split_asm kernel_object.split_asm) using ko by (cases ty; - simp add: makeObjectKO_def makeObject_reply + simp add: makeObjectKO_def makeObject_tcb projectKOs split: kernel_object.split_asm arch_kernel_object.split_asm object_type.split_asm - apiobject_type.split_asm if_split_asm) - fastforce + apiobject_type.split_asm if_split_asm) + fastforce+ qed -lemma retype_sc_replies_relation: - assumes sr: "sc_replies_relation s s'" - and pr: "pspace_relation (kheap s) (ksPSpace s')" - and vs: "valid_pspace s" "valid_mdb s" - and vs': "pspace_aligned' s'" "pspace_distinct' s'" - and pn: "pspace_no_overlap_range_cover ptr sz 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" +lemma retype_tcbSchedNexts_of: + assumes vs': "pspace_aligned' s'" "pspace_distinct' s'" + assumes pn': "pspace_no_overlap' ptr sz s'" + assumes ko: "makeObjectKO dev ty = Some ko" + assumes cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" + assumes num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" shows - "sc_replies_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')\)" + "tcbSchedNexts_of + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\) + = tcbSchedNexts_of s'" proof - - have not_unt: "ty \ Inr (APIObjectType ArchTypes_H.Untyped)" - by (rule makeObjectKO_Untyped[OF ko]) - - note not_unt = makeObjectKO_Untyped [OF ko] - - note dom_same = retype_kheap_dom_same[OF pn vs cover] - - note dom_same' = retype_ksPSpace_dom_same[OF vs' pn' ko tysc cover num_r] + note dom_same' = retype_ksPSpace_dom_same[OF vs' pn' ko cover num_r] + show ?thesis + apply (rule ext) + apply (clarsimp simp: opt_map_def split: option.splits) + apply (intro impI conjI allI; (drule dom_same'; simp)?) + apply (clarsimp simp: foldr_upd_app_if[folded data_map_insert_def] + split: if_split_asm kernel_object.split_asm) + using ko + by (cases ty; + simp add: makeObjectKO_def makeObject_tcb projectKOs + split: kernel_object.split_asm arch_kernel_object.split_asm object_type.split_asm + apiobject_type.split_asm if_split_asm) + fastforce+ +qed +lemma retype_inQ: + assumes vs': "pspace_aligned' s'" "pspace_distinct' s'" + assumes pn': "pspace_no_overlap' ptr sz s'" + assumes ko: "makeObjectKO dev ty = Some ko" + assumes cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" + assumes num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" + shows + "\d p. + inQ d p |< tcbs_of' + (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\) + = inQ d p |< tcbs_of' s'" +proof - + note dom_same' = retype_ksPSpace_dom_same[OF vs' pn' ko cover num_r] show ?thesis - using sr pr - unfolding sc_replies_relation_def - apply (clarsimp simp: sc_replies_of_scs_def map_project_def scs_of_kh_def - split: Structures_A.kernel_object.split_asm - elim!: opt_mapE) - apply (rename_tac sc n'; drule_tac x=p and y="sc_replies sc" in spec2) - 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) + apply (intro allI) + apply (rule ext) + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def split: option.splits) + apply (intro impI conjI allI; (drule dom_same'; simp)?) + apply (clarsimp simp: foldr_upd_app_if[folded data_map_insert_def] + split: if_split_asm kernel_object.split_asm) using ko - apply (clarsimp simp: makeObjectKO_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]) - apply (simp only: retype_replyPrevs_of[OF pr vs vs' pn pn' ko tysc cover orr num_r, simplified]) - apply (clarsimp simp: pspace_relation_def) - apply (drule_tac x=p in bspec, fastforce) - apply (prop_tac "p \ dom (ksPSpace s')") - apply (clarsimp simp: pspace_dom_def split: if_split_asm, fastforce) - apply (clarsimp split: if_split_asm kernel_object.splits) - apply (frule dom_same') - apply (clarsimp simp: opt_map_def) - done + by (cases ty; + fastforce simp add: makeObjectKO_def makeObject_tcb projectKOs + split: kernel_object.split_asm arch_kernel_object.split_asm object_type.split_asm + apiobject_type.split_asm if_split_asm + | fastforce)+ qed +lemma retype_ready_queues_relation: + assumes rlqr: "ready_queues_relation s s'" + assumes vs': "pspace_aligned' s'" "pspace_distinct' s'" + assumes pn': "pspace_no_overlap' ptr sz s'" + assumes ko: "makeObjectKO dev ty = Some ko" + assumes cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" + assumes num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" + shows + "ready_queues_relation + (s \kheap := foldr (\p. data_map_insert p (default_object (APIType_map2 ty) dev us)) + (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')\)" + using rlqr + unfolding ready_queues_relation_def Let_def + by (clarsimp simp: retype_tcbSchedNexts_of[OF vs' pn' ko cover num_r, simplified] + retype_tcbSchedPrevs_of[OF vs' pn' ko cover num_r, simplified] + retype_inQ[OF vs' pn' ko cover num_r, simplified]) + lemma retype_state_relation: notes data_map_insert_def[simp del] assumes sr: "(s, s') \ state_relation" and vs: "valid_pspace s" "valid_mdb s" - and et: "valid_list s" + and et: "valid_etcbs s" "valid_list s" and vs': "pspace_aligned' s'" "pspace_distinct' s'" - and bd': "pspace_bounded' s'" and pn: "pspace_no_overlap_range_cover ptr sz s" and pn': "pspace_no_overlap' ptr sz s'" - 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 ko: "makeObjectKO dev us d ty = Some ko" + and ko: "makeObjectKO dev ty = Some ko" and api: "obj_bits_api (APIType_map2 ty) us \ sz" - and orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us d) ko" + and orr: "obj_relation_retype (default_object (APIType_map2 ty) dev us) ko" and num_r: "m = 2 ^ (obj_bits_api (APIType_map2 ty) us - objBitsKO ko) * n" shows - "(s \kheap := - foldr (\p. data_map_insert p (default_object (APIType_map2 ty) dev us d)) + "(ekheap_update + (\_. foldr (\p ekh a. if a = p then default_ext (APIType_map2 ty) default_domain else ekh a) + (retype_addrs ptr (APIType_map2 ty) n us) (ekheap s)) + s + \kheap := + foldr (\p. data_map_insert p (default_object (APIType_map2 ty) dev us)) (retype_addrs ptr (APIType_map2 ty) n us) (kheap s)\, update_gs (APIType_map2 ty) us (set (retype_addrs ptr (APIType_map2 ty) n us)) (s'\ksPSpace := foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) (ksPSpace s')\)) \ state_relation" - (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'], - simp_all add: trans_state_update[symmetric] del: trans_state_update) (* FIXME: don't simp here *) + (is "(ekheap_update (\_. ?eps) s\kheap := ?ps\, update_gs _ _ _ (s'\ksPSpace := ?ps'\)) + \ state_relation") + proof (rule state_relation_null_filterE[OF sr refl _ _ _ _ _ _ _ _ vs'], simp_all add: trans_state_update[symmetric] del: trans_state_update) have cover':"range_cover ptr sz (objBitsKO ko) m" - by (rule range_cover_rel[OF cover objBits_le_obj_bits_api[OF tysc ko] num_r]) + by (rule range_cover_rel[OF cover objBits_le_obj_bits_api[OF ko] num_r]) have al':"is_aligned ptr (objBitsKO ko)" using cover' by (simp add:range_cover_def) - have bd:"objBitsKO ko < word_bits" - using cover' - by (simp add:range_cover_def word_bits_def) have sz:"sz < word_bits" using cover' by (simp add:range_cover_def word_bits_def) + let ?t = "s\kheap := ?ps\" let ?tp = "APIType_map2 ty" let ?al = "retype_addrs ptr ?tp n us" + let ?t' = "update_gs ?tp us (set ?al) (s'\ksPSpace := ?ps'\)" - note pad' = retype_aligned_distinct' [OF vs' bd' pn' cover'] + note pad' = retype_aligned_distinct' [OF vs' pn' cover'] thus pa': "pspace_aligned' (s'\ksPSpace := ?ps'\)" and pd': "pspace_distinct' (s'\ksPSpace := ?ps'\)" by simp_all @@ -1396,13 +1393,12 @@ lemma retype_state_relation: note nc_al' = nc_al[unfolded objBits_def] show "null_filter' (map_to_ctes ?ps') = null_filter' (ctes_of s')" apply (rule null_filter_ctes_retype [OF ko vs' pa'' pd'']) - apply (simp add: nc_al) - apply (simp add: bd) + apply (simp add: nc_al) apply clarsimp apply (drule subsetD [OF new_cap_addrs_subset [OF cover']]) apply (insert pspace_no_overlap_disjoint'[OF vs'(1) pn']) apply (drule orthD1) - apply (simp add:ptr_add_def field_simps) + apply (simp add:ptr_add_def field_simps) apply clarsimp done @@ -1422,9 +1418,15 @@ lemma retype_state_relation: using sr by (simp add: state_relation_def) thus "pspace_relation ?ps ?ps'" - by (rule retype_pspace_relation [OF _ vs vs' pn pn' ko tysc cover orr num_r, + by (rule retype_pspace_relation [OF _ vs vs' pn pn' ko cover orr num_r, folded data_map_insert_def]) + have "ekheap_relation (ekheap (s)) (ksPSpace s')" + using sr by (simp add: state_relation_def) + + thus "ekheap_relation ?eps ?ps'" + by (fold fun_upd_apply) (rule retype_ekheap_relation[OF _ pspr vs et(1) vs' pn pn' ko cover orr num_r]) + have pn2: "\a\set ?al. kheap s a = None" by (rule ccontr) (clarsimp simp: pspace_no_overlapD1[OF pn _ cover vs(1)]) @@ -1492,30 +1494,6 @@ lemma retype_state_relation: from gr show ?thesis by (simp add: ghost_relation_of_heap, simp add: CapTableObject update_gs_def ext) - next - case ReplyObject - from pn2 - have [simp]: "ups_of_heap ?ps = ups_of_heap (kheap s)" - by - (rule ext, induct (?al), - simp_all add: ups_of_heap_def default_object_def data_map_insert_def ReplyObject) - from pn2 - have [simp]: "cns_of_heap ?ps = cns_of_heap (kheap s)" - by - (rule ext, induct (?al), - simp_all add: cns_of_heap_def default_object_def data_map_insert_def ReplyObject) - from gr show ?thesis - by (simp add: ghost_relation_of_heap, simp add: ReplyObject update_gs_def) - next - case SchedContextObject - from pn2 - have [simp]: "ups_of_heap ?ps = ups_of_heap (kheap s)" - by - (rule ext, induct (?al), - simp_all add: ups_of_heap_def default_object_def data_map_insert_def SchedContextObject) - from pn2 - have [simp]: "cns_of_heap ?ps = cns_of_heap (kheap s)" - by - (rule ext, induct (?al), - simp_all add: cns_of_heap_def default_object_def data_map_insert_def SchedContextObject) - from gr show ?thesis - by (simp add: ghost_relation_of_heap, simp add: SchedContextObject update_gs_def) next case (ArchObject ao) from pn2 @@ -1544,16 +1522,14 @@ lemma retype_state_relation: apply (clarsimp simp: update_gs_def split: Structures_A.apiobject_type.splits) apply (intro conjI impI) - apply (subst ex_comm, rule_tac x=id in exI, - subst ex_comm, rule_tac x=id in exI, fastforce)+ - apply (subst ex_comm, rule_tac x=id in exI) - apply (subst ex_comm) - apply (rule_tac x="\cns x. if x\set ?al then Some us else cns x" in exI, - simp) - apply (rule_tac x="\x. foldr (\addr. data_map_insert addr ko) - (new_cap_addrs m ptr ko) x" in exI, simp) - apply (subst ex_comm, rule_tac x=id in exI, - subst ex_comm, rule_tac x=id in exI, fastforce)+ + apply (subst ex_comm, rule_tac x=id in exI, + subst ex_comm, rule_tac x=id in exI, fastforce)+ + apply (subst ex_comm, rule_tac x=id in exI) + apply (subst ex_comm) + apply (rule_tac x="\cns x. if x\set ?al then Some us else cns x" in exI, + simp) + apply (rule_tac x="\x. foldr (\addr. data_map_insert addr ko) + (new_cap_addrs m ptr ko) x" in exI, simp) apply clarsimp apply (rule_tac x="\x. foldr (\addr. data_map_insert addr ko) (new_cap_addrs m ptr ko) x" in exI) @@ -1571,15 +1547,6 @@ lemma retype_state_relation: apply (rule_tac x=id in exI, simp)+ done - have scr: "sc_replies_relation s s'" - using sr by (simp add: state_relation_def) - - thus - "sc_replies_relation_2 (sc_replies_of_kh ?ps) (?ps' |> sc_of' |> scReply) - (?ps' |> reply_of' |> replyPrev)" - using retype_sc_replies_relation [OF _ pspr vs vs' pn pn' ko tysc cover orr num_r] - by clarsimp - have rdyqrel: "ready_queues_relation s s'" using sr by (simp add: state_relation_def) @@ -1592,33 +1559,242 @@ lemma retype_state_relation: qed lemma new_cap_addrs_fold': - "1 \ n \ map (\n. ptr + (n << objBitsKO ko)) [0.e.n - 1] = new_cap_addrs (unat n) ptr ko" - by (clarsimp simp: new_cap_addrs_def ptr_add_def upto_enum_red' shiftl_t2n power_add field_simps) - -lemma objBitsKO_gt_0: "0 < (objBitsKO ko)" - apply (case_tac ko; simp add: objBits_simps' pageBits_def bit_simps') + "1 \ n \ + map (\n. ptr + (n << objBitsKO ko)) [0.e.n - 1] = + new_cap_addrs (unat n) ptr ko" + by (clarsimp simp:new_cap_addrs_def ptr_add_def upto_enum_red' + shiftl_t2n power_add field_simps) + +lemma objBitsKO_gt_0: "0 < objBitsKO ko" + apply (case_tac ko) + apply (simp_all add: objBits_simps' pageBits_def) apply (rename_tac arch_kernel_object) - by (case_tac arch_kernel_object; simp add: archObjSize_def pageBits_def pteBits_def pdeBits_def) + apply (case_tac arch_kernel_object) + apply (simp_all add:archObjSize_def pageBits_def pteBits_def pdeBits_def) + done + +lemma kheap_ekheap_double_gets: + "(\rv erv rv'. \pspace_relation rv rv'; ekheap_relation erv rv'\ + \ corres r (R rv erv) (R' rv') (b rv erv) (d rv')) \ + corres r (\s. R (kheap s) (ekheap s) s) (\s. R' (ksPSpace s) s) + (do x \ gets kheap; xa \ gets ekheap; b x xa od) (gets ksPSpace >>= d)" + apply (rule corres_symb_exec_l) + apply (rule corres_guard_imp) + apply (rule_tac r'= "\erv rv'. ekheap_relation erv rv' \ pspace_relation x rv'" + in corres_split) + apply (subst corres_gets[where P="\s. x = kheap s" and P'=\]) + apply clarsimp + apply (simp add: state_relation_def) + apply clarsimp + apply assumption + apply (wp gets_exs_valid | simp)+ + done + +(* + +Split out the extended operation that sets the etcb domains. + +This allows the existing corres proofs in this file to more-or-less go +through as they stand. + +A more principled fix would be to change the abstract spec and +generalise init_arch_objects to initialise other object types. + +*) + +definition retype_region2_ext :: "obj_ref list \ Structures_A.apiobject_type \ unit det_ext_monad" where + "retype_region2_ext ptrs type \ modify (\s. ekheap_update (foldr (\p ekh. (ekh(p := default_ext type default_domain))) ptrs) s)" + +crunch retype_region2_ext + for all_but_exst[wp]: "all_but_exst P" +crunch retype_region2_ext + for (empty_fail) empty_fail[wp] + +end + +interpretation retype_region2_ext_extended: is_extended "retype_region2_ext ptrs type" + by (unfold_locales; wp) + +context begin interpretation Arch . (*FIXME: arch-split*) + +definition + "retype_region2_extra_ext ptrs type \ + when (type = Structures_A.TCBObject) (do + cdom \ gets cur_domain; + mapM_x (ethread_set (\tcb. tcb\tcb_domain := cdom\)) ptrs + od)" + +crunch retype_region2_extra_ext + for all_but_exst[wp]: "all_but_exst P" (wp: mapM_x_wp) +crunch retype_region2_extra_ext + for (empty_fail) empty_fail[wp] (wp: mapM_x_wp) + +end + +interpretation retype_region2_extra_ext_extended: is_extended "retype_region2_extra_ext ptrs type" + by (unfold_locales; wp) + +context begin interpretation Arch . (*FIXME: arch-split*) + +definition + retype_region2 :: "obj_ref \ nat \ nat \ Structures_A.apiobject_type \ bool \ (obj_ref list,'z::state_ext) s_monad" +where + "retype_region2 ptr numObjects o_bits type dev \ do + obj_size \ return $ 2 ^ obj_bits_api type o_bits; + ptrs \ return $ map (\p. ptr_add ptr (p * obj_size)) [0..< numObjects]; + when (type \ Structures_A.Untyped) (do + kh \ gets kheap; + kh' \ return $ foldr (\p kh. kh(p \ default_object type dev o_bits)) ptrs kh; + do_extended_op (retype_region2_ext ptrs type); + modify $ kheap_update (K kh') + od); + return $ ptrs + od" + +lemma retype_region_ext_modify_kheap_futz: + "(retype_region2_extra_ext ptrs type :: (unit, det_ext) s_monad) >>= (\_. modify (kheap_update f)) + = (modify (kheap_update f) >>= (\_. retype_region2_extra_ext ptrs type))" + apply (clarsimp simp: retype_region_ext_def retype_region2_ext_def retype_region2_extra_ext_def when_def bind_assoc) + apply (subst oblivious_modify_swap) + defer + apply (simp add: bind_assoc) + apply (rule oblivious_bind) + apply simp + apply (rule oblivious_mapM_x) + apply (clarsimp simp: ethread_set_def set_eobject_def) + apply (rule oblivious_bind) + apply (simp add: gets_the_def) + apply (rule oblivious_bind) + apply (clarsimp simp: get_etcb_def) + apply simp + apply (simp add: modify_def[symmetric]) +done + +lemmas retype_region_ext_modify_kheap_futz' = + fun_cong[OF arg_cong[where f=Nondet_Monad.bind, + OF retype_region_ext_modify_kheap_futz[symmetric]], simplified bind_assoc] + +lemma foldr_upd_app_if_eta_futz: + "foldr (\p ps. ps(p \ f p)) as = (\g x. if x \ set as then Some (f x) else g x)" +apply (rule ext) +apply (rule foldr_upd_app_if) +done + +lemma modify_ekheap_update_comp_futz: + "modify (ekheap_update (f \ g)) = modify (ekheap_update g) >>= (K (modify (ekheap_update f)))" +by (simp add: o_def modify_def bind_def gets_def get_def put_def) + +lemma mapM_x_modify_futz: + assumes "\ptr\set ptrs. ekheap s ptr \ None" + shows "mapM_x (ethread_set F) (rev ptrs) s + = modify (ekheap_update (foldr (\p ekh. ekh(p := Some (F (the (ekh p))))) ptrs)) s" (is "?lhs ptrs s = ?rhs ptrs s") +using assms +proof(induct ptrs arbitrary: s) + case Nil thus ?case by (simp add: mapM_x_Nil return_def simpler_modify_def) +next + case (Cons ptr ptrs s) + have "?rhs (ptr # ptrs) s + = (do modify (ekheap_update (foldr (\p ekh. ekh(p \ F (the (ekh p)))) ptrs)); + modify (ekheap_update (\ekh. ekh(ptr \ F (the (ekh ptr))))) + od) s" + by (simp only: foldr_Cons modify_ekheap_update_comp_futz) simp + also have "... = (do ?lhs ptrs; + modify (ekheap_update (\ekh. ekh(ptr \ F (the (ekh ptr))))) + od) s" + apply (rule monad_eq_split_tail) + apply simp + apply (rule Cons.hyps[symmetric]) + using Cons.prems + apply force + done + also have "... = ?lhs (ptr # ptrs) s" + apply (simp add: mapM_x_append mapM_x_singleton) + apply (rule monad_eq_split2[OF refl, where + P="\s. \ptr\set (ptr # ptrs). ekheap s ptr \ None" + and Q="\_ s. ekheap s ptr \ None"]) + apply (simp add: ethread_set_def + assert_opt_def get_etcb_def gets_the_def gets_def get_def modify_def put_def set_eobject_def + bind_def fail_def return_def split_def + split: option.splits) + apply ((wp mapM_x_wp[OF _ subset_refl] | simp add: ethread_set_def set_eobject_def)+)[1] + using Cons.prems + apply force + done + finally show ?case by (rule sym) +qed + +lemma awkward_fold_futz: + "fold (\p ekh. ekh(p \ the (ekh p)\tcb_domain := cur_domain s\)) ptrs ekh + = (\x. if x \ set ptrs then Some ((the (ekh x))\tcb_domain := cur_domain s\) else ekh x)" +by (induct ptrs arbitrary: ekh) (simp_all add: fun_eq_iff) + +lemma retype_region2_ext_retype_region_ext_futz: + "retype_region2_ext ptrs type >>= (\_. retype_region2_extra_ext ptrs type) + = retype_region_ext ptrs type" +proof(cases type) + case TCBObject + have complete_futz: + "\F x. modify (ekheap_update (\_. F (cur_domain x) (ekheap x))) x = modify (ekheap_update (\ekh. F (cur_domain x) ekh)) x" + by (simp add: modify_def get_def get_etcb_def put_def bind_def return_def) + have second_futz: + "\f G. + do modify (ekheap_update f); + cdom \ gets (\s. cur_domain s); + G cdom + od = + do cdom \ gets (\s. cur_domain s); + modify (ekheap_update f); + G cdom + od" + by (simp add: bind_def gets_def get_def return_def simpler_modify_def) + from TCBObject show ?thesis + apply (clarsimp simp: retype_region_ext_def retype_region2_ext_def retype_region2_extra_ext_def when_def bind_assoc) + apply (clarsimp simp: exec_gets fun_eq_iff) + apply (subst complete_futz) + apply (simp add: second_futz[simplified] exec_gets) + apply (simp add: default_ext_def exec_modify) + apply (subst mapM_x_modify_futz[where ptrs="rev ptrs", simplified]) + apply (simp add: foldr_upd_app_if_eta_futz) + apply (simp add: modify_def exec_get put_def o_def) + apply (simp add: foldr_upd_app_if_eta_futz foldr_conv_fold awkward_fold_futz) + apply (simp cong: if_cong) + done +qed (auto simp: fun_eq_iff retype_region_ext_def retype_region2_ext_def retype_region2_extra_ext_def + put_def gets_def get_def bind_def return_def mk_ef_def modify_def foldr_upd_app_if' when_def default_ext_def) + +lemma retype_region2_ext_retype_region: + "(retype_region ptr numObjects o_bits type dev :: (obj_ref list, det_ext) s_monad) + = (do ptrs \ retype_region2 ptr numObjects o_bits type dev; + retype_region2_extra_ext ptrs type; + return ptrs + od)" +apply (clarsimp simp: retype_region_def retype_region2_def when_def bind_assoc) + apply safe + defer + apply (simp add: retype_region2_extra_ext_def) +apply (subst retype_region_ext_modify_kheap_futz'[simplified bind_assoc]) +apply (subst retype_region2_ext_retype_region_ext_futz[symmetric]) +apply (simp add: bind_assoc) +done lemma getObject_tcb_gets: "getObject addr >>= (\x::tcb. gets proj >>= (\y. G x y)) - = gets proj >>= (\y. getObject addr >>= (\x. G x y))" - by (auto simp: exec_gets fun_eq_iff intro: bind_apply_cong - dest!: in_inv_by_hoareD[OF getObject_tcb_inv]) + = gets proj >>= (\y. getObject addr >>= (\x. G x y))" +by (auto simp: exec_gets fun_eq_iff intro: bind_apply_cong dest!: in_inv_by_hoareD[OF getObject_inv_tcb]) lemma setObject_tcb_gets_ksCurDomain: "setObject addr (tcb::tcb) >>= (\_. gets ksCurDomain >>= G) - = gets ksCurDomain >>= (\x. setObject addr tcb >>= (\_. G x))" - apply (clarsimp simp: exec_gets fun_eq_iff) - apply (rule bind_apply_cong) - apply simp - apply (drule_tac P1="\cdom. cdom = ksCurDomain x" in use_valid[OF _ setObject_cd_inv]) - apply (simp_all add: exec_gets) - done + = gets ksCurDomain >>= (\x. setObject addr tcb >>= (\_. G x))" +apply (clarsimp simp: exec_gets fun_eq_iff) +apply (rule bind_apply_cong) + apply simp +apply (drule_tac P1="\cdom. cdom = ksCurDomain x" in use_valid[OF _ setObject_cd_inv]) +apply (simp_all add: exec_gets) +done lemma curDomain_mapM_x_futz: "curDomain >>= (\cdom. mapM_x (threadSet (F cdom)) addrs) - = mapM_x (\addr. curDomain >>= (\cdom. threadSet (F cdom) addr)) addrs" + = mapM_x (\addr. curDomain >>= (\cdom. threadSet (F cdom) addr)) addrs" proof(induct addrs) case Nil thus ?case by (simp add: curDomain_def mapM_x_def sequence_x_def bind_def gets_def get_def return_def) @@ -1643,42 +1819,55 @@ next done qed +(* + +The existing proof continues below. + +*) + +lemma modify_ekheap_update_ekheap: + "modify (\s. ekheap_update f s) = do s \ gets ekheap; modify (\s'. s'\ekheap := f s\) od" +by (simp add: modify_def gets_def get_def put_def bind_def return_def split_def fun_eq_iff) + lemma corres_retype': assumes not_zero: "n \ 0" and aligned: "is_aligned ptr (objBitsKO ko + gbits)" - and obj_bits_api: "obj_bits_api (APIType_map2 ty) us = objBitsKO ko + gbits" - and check: "(sz < obj_bits_api (APIType_map2 ty) us) = (sz < objBitsKO ko + gbits)" - and ko: "makeObjectKO dev us d ty = Some ko" - and tysc: "ty = Inr (APIObjectType SchedContextObject) \ min_sched_context_bits \ us" + and obj_bits_api: "obj_bits_api (APIType_map2 ty) us = + objBitsKO ko + gbits" + and check: "(sz < obj_bits_api (APIType_map2 ty) us) + = (sz < objBitsKO ko + gbits)" + and usv: "APIType_map2 ty = Structures_A.CapTableObject \ 0 < us" + and ko: "makeObjectKO dev ty = Some ko" and orr: "obj_bits_api (APIType_map2 ty) us \ sz \ - obj_relation_retype (default_object (APIType_map2 ty) dev us d) ko" + obj_relation_retype + (default_object (APIType_map2 ty) dev us) ko" and cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" shows "corres (\rv rv'. rv' = g rv) - (\s. valid_pspace s \ pspace_no_overlap_range_cover ptr sz s - \ valid_mdb s \ valid_list s) - (\s. pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s - \ (ty = Inr (APIObjectType TCBObject) \ d = ksCurDomain s)) - (retype_region ptr n us (APIType_map2 ty) dev) - (do addrs \ createObjects ptr n ko gbits; - _ \ modify (update_gs (APIType_map2 ty) us (set addrs)); - return (g addrs) - od)" + (\s. valid_pspace s \ pspace_no_overlap_range_cover ptr sz s + \ valid_mdb s \ valid_etcbs s \ valid_list s) + (\s. pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s) + (retype_region2 ptr n us (APIType_map2 ty) dev) + (do addrs \ createObjects ptr n ko gbits; + _ \ modify (update_gs (APIType_map2 ty) us (set addrs)); + return (g addrs) od)" (is "corres ?r ?P ?P' ?C ?A") proof - note data_map_insert_def[simp del] - have not_zero':"(of_nat n::machine_word) \ 0" + have not_zero':"((of_nat n)::word32) \ 0" by (rule range_cover_not_zero[OF not_zero cover]) - have shiftr_not_zero:" (of_nat n::machine_word) << gbits \ 0" + have shiftr_not_zero:" ((of_nat n)::word32) << gbits \ 0" apply (rule range_cover_not_zero_shift[OF not_zero cover]) apply (simp add:obj_bits_api) done - have unat_of_nat_shift:"unat ((of_nat n::machine_word) << gbits) = n * 2^ gbits" + have unat_of_nat_shift:"unat (((of_nat n)::word32) << gbits) = + (n * 2^ gbits)" apply (rule range_cover.unat_of_nat_n_shift[OF cover]) using obj_bits_api apply simp done have unat_of_nat_shift': - "unat ((of_nat n::machine_word) * 2^(gbits + objBitsKO ko)) = n * 2^(gbits + objBitsKO ko)" + "unat (((of_nat n)::word32) * 2^(gbits + objBitsKO ko)) = + n * 2^(gbits + objBitsKO ko)" apply (subst mult.commute) apply (simp add:shiftl_t2n[symmetric]) apply (rule range_cover.unat_of_nat_n_shift[OF cover]) @@ -1686,29 +1875,32 @@ proof - apply simp done have unat_of_nat_n': - "unat (((of_nat n)::machine_word) * 2 ^ (gbits + objBitsKO ko)) \ 0" + "unat (((of_nat n)::word32) * 2 ^ (gbits + objBitsKO ko)) \ 0" by (simp add:unat_of_nat_shift' not_zero) have bound:"obj_bits_api (APIType_map2 ty) us \ sz" using cover by (simp add:range_cover_def) have n_estimate: "n < 2 ^ (word_bits - (objBitsKO ko + gbits))" apply (rule le_less_trans) - apply (rule range_cover.range_cover_n_le(2)[OF cover]) + apply (rule range_cover.range_cover_n_le(2)[OF cover]) apply (rule power_strict_increasing) - apply (simp add:obj_bits_api ko) - apply (rule diff_less_mono) + apply (simp add:obj_bits_api ko) + apply (rule diff_less_mono) using cover obj_bits_api - apply (simp_all add:range_cover_def ko word_bits_def) + apply (simp_all add:range_cover_def ko word_bits_def) done have set_retype_addrs_fold: - "image (\n. ptr + 2 ^ obj_bits_api (APIType_map2 ty) us * n) {x. x \ of_nat n - 1} = + "image (\n. ptr + 2 ^ obj_bits_api (APIType_map2 ty) us * n) + {x. x \ of_nat n - 1} = set (retype_addrs ptr (APIType_map2 ty) n us)" - apply (clarsimp simp: retype_addrs_def image_def Bex_def ptr_add_def Collect_eq) + apply (clarsimp simp: retype_addrs_def image_def Bex_def ptr_add_def + Collect_eq) apply (rule iffI) apply (clarsimp simp: field_simps word_le_nat_alt) apply (rule_tac x="unat x" in exI) - apply (simp add: unat_sub_if_size range_cover.unat_of_nat_n[OF cover] not_le not_zero + apply (simp add: unat_sub_if_size range_cover.unat_of_nat_n[OF cover] + not_le not_zero split: if_split_asm) apply (clarsimp simp: field_simps word_le_nat_alt) apply (rule_tac x="of_nat x" in exI) @@ -1735,7 +1927,7 @@ proof - have al': "is_aligned ptr (obj_bits_api (APIType_map2 ty) us)" by (simp add: obj_bits_api ko) show ?thesis - apply (simp add: when_def retype_region_def createObjects'_def + apply (simp add: when_def retype_region2_def createObjects'_def createObjects_def aligned obj_bits_api[symmetric] ko[symmetric] al' shiftl_t2n data_map_insert_def[symmetric] is_aligned_mask[symmetric] split_def unless_def @@ -1743,91 +1935,80 @@ proof - split del: if_split) apply (subst retype_addrs_fold)+ apply (subst if_P) - using ko - apply (clarsimp simp: makeObjectKO_def) - apply (simp add: bind_assoc) - apply (rule corres_guard_imp) - apply (rule_tac r'=pspace_relation in corres_underlying_split) - apply (clarsimp dest!: state_relation_pspace_relation) - apply (simp add: gets_def) - apply (rule corres_symb_exec_l[rotated]) - apply (rule exs_valid_get) - apply (rule get_sp) - apply (simp add: get_def no_fail_def) - apply (rule corres_symb_exec_r) - apply (simp add: not_less modify_modify bind_assoc[symmetric] - obj_bits_api[symmetric] shiftl_t2n upto_enum_red' + using ko + apply (clarsimp simp: makeObjectKO_def) + apply (simp add: bind_assoc retype_region2_ext_def) + apply (rule corres_guard_imp) + apply (subst modify_ekheap_update_ekheap) + apply (simp only: bind_assoc) + apply (rule kheap_ekheap_double_gets) + apply (rule corres_symb_exec_r) + apply (simp add: not_less modify_modify bind_assoc[symmetric] + obj_bits_api[symmetric] shiftl_t2n upto_enum_red' range_cover.unat_of_nat_n[OF cover]) - apply (rule corres_guard_imp) - apply (rule corres_split_nor[OF _ corres_trivial]) - apply (rename_tac ps ps' sa) - apply (rule_tac P="\s. ps = kheap s \ sa = s \ ?P s" and - P'="\s. ps' = ksPSpace s \ ?P' s" in corres_modify) - apply(frule curdomain_relation[THEN sym]) - apply (simp add: set_retype_addrs_fold new_caps_adds_fold) - apply (drule retype_state_relation[OF _ _ _ _ _ _ _ _ _ tysc cover _ _ orr], - simp_all add: ko not_zero obj_bits_api - bound[simplified obj_bits_api ko])[1] - apply (erule pspace_relation_pspace_bounded') - apply (cases ty; simp; rename_tac tp; case_tac tp; - clarsimp simp: default_object_def APIType_map2_def - split: arch_kernel_object.splits apiobject_type.splits) - apply (clarsimp simp: retype_addrs_fold[symmetric] ptr_add_def upto_enum_red' not_zero' - range_cover.unat_of_nat_n[OF cover] word_le_sub1) - apply (rule_tac f=g in arg_cong) - apply clarsimp - apply wpsimp+ - apply simp+ - apply (clarsimp split: option.splits) - apply (intro conjI impI) - apply (clarsimp|wp)+ - apply (clarsimp split: option.splits) - apply wpsimp - apply (clarsimp split: option.splits) - apply (intro conjI impI) - apply wp - apply (clarsimp simp:lookupAround2_char1) - apply wp - apply (clarsimp simp: obj_bits_api ko) - apply (drule(1) pspace_no_overlap_disjoint') - apply (rule_tac x1 = a in ccontr[OF in_empty_interE]) - apply simp - apply (clarsimp simp: not_less shiftL_nat) - apply (erule order_trans) - apply (subst p_assoc_help) - apply (subst word_plus_and_or_coroll2[symmetric,where w = "mask sz"]) - apply (subst add.commute) - apply (subst add.assoc) - apply (rule word_plus_mono_right) - using cover - apply - - apply (rule iffD2[OF word_le_nat_alt]) - apply (subst word_of_nat_minus) - using not_zero - apply simp - apply (rule le_trans[OF unat_plus_gt]) - apply simp - apply (subst unat_minus_one) - apply (subst mult.commute) - apply (rule word_power_nonzero_32) - apply (rule of_nat_less_pow_32[OF n_estimate]) - apply (simp add:word_bits_def objBitsKO_gt_0 ko) - apply (simp add:range_cover_def obj_bits_api ko word_bits_def) - apply (cut_tac not_zero',clarsimp simp:ko) - apply(clarsimp simp:field_simps ko) - apply (subst unat_sub[OF word_1_le_power]) - apply (simp add:range_cover_def) - apply (subst diff_add_assoc[symmetric]) - apply (cut_tac unat_of_nat_n',simp add:ko) - apply (clarsimp simp: obj_bits_api ko) - apply (rule diff_le_mono) - apply (frule range_cover.range_cover_compare_bound) - apply (cut_tac obj_bits_api unat_of_nat_shift') - apply (clarsimp simp:add.commute range_cover_def ko) - apply (rule is_aligned_no_wrap'[OF is_aligned_neg_mask,OF le_refl ]) - apply (simp add:range_cover_def domI)+ - apply wpsimp+ - done + apply (rule corres_split_nor[OF _ corres_trivial]) + apply (rename_tac x eps ps) + apply (rule_tac P="\s. x = kheap s \ eps = ekheap (s) \ ?P s" and + P'="\s. ps = ksPSpace s \ ?P' s" in corres_modify) + apply (simp add: set_retype_addrs_fold new_caps_adds_fold) + apply (erule retype_state_relation[OF _ _ _ _ _ _ _ _ _ cover _ _ orr], + simp_all add: ko not_zero obj_bits_api + bound[simplified obj_bits_api ko])[1] + apply (clarsimp simp: retype_addrs_fold[symmetric] ptr_add_def upto_enum_red' not_zero' + range_cover.unat_of_nat_n[OF cover] word_le_sub1 + simp del: word_of_nat_eq_0_iff) + apply (rule_tac f=g in arg_cong) + apply clarsimp + apply wp+ + apply (clarsimp split: option.splits) + apply (intro conjI impI) + apply (clarsimp|wp)+ + apply (clarsimp split: option.splits) + apply wpsimp + apply (clarsimp split: option.splits) + apply (intro conjI impI) + apply wp + apply (clarsimp simp:lookupAround2_char1) + apply wp + apply (clarsimp simp: obj_bits_api ko) + apply (drule(1) pspace_no_overlap_disjoint') + apply (rule_tac x1 = a in ccontr[OF in_empty_interE]) + apply simp + apply (clarsimp simp: not_less shiftL_nat) + apply (erule order_trans) + apply (subst p_assoc_help) + apply (subst word_plus_and_or_coroll2[symmetric,where w = "mask sz"]) + apply (subst add.commute) + apply (subst add.assoc) + apply (rule word_plus_mono_right) + using cover + apply - + apply (rule iffD2[OF word_le_nat_alt]) + apply (subst word_of_nat_minus) + using not_zero + apply simp + apply (rule le_trans[OF unat_plus_gt]) + apply simp + apply (subst unat_minus_one) + apply (subst mult.commute) + apply (rule word_power_nonzero_32) + apply (rule of_nat_less_pow_32[OF n_estimate]) + apply (simp add:word_bits_def objBitsKO_gt_0 ko) + apply (simp add:range_cover_def obj_bits_api ko word_bits_def) + apply (cut_tac not_zero',clarsimp simp:ko) + apply(clarsimp simp:field_simps ko) + apply (subst unat_sub[OF word_1_le_power]) + apply (simp add:range_cover_def) + apply (subst diff_add_assoc[symmetric]) + apply (cut_tac unat_of_nat_n',simp add:ko) + apply (clarsimp simp: obj_bits_api ko) + apply (rule diff_le_mono) + apply (frule range_cover.range_cover_compare_bound) + apply (cut_tac obj_bits_api unat_of_nat_shift') + apply (clarsimp simp:add.commute range_cover_def ko) + apply (rule is_aligned_no_wrap'[OF is_aligned_neg_mask,OF le_refl ]) + apply (simp add:range_cover_def domI)+ + done qed lemma createObjects_corres': @@ -1835,13 +2016,13 @@ lemma createObjects_corres': \ corres dc P P' f (createObjects' a b ko d)" apply (clarsimp simp:corres_underlying_def createObjects_def return_def) apply (rule conjI) - apply (clarsimp simp:bind_def split_def) - apply (drule(1) bspec) - apply (clarsimp simp:image_def) - apply (drule(1) bspec) - apply clarsimp - apply (erule bexI[rotated]) - apply simp + apply (clarsimp simp:bind_def split_def) + apply (drule(1) bspec) + apply (clarsimp simp:image_def) + apply (drule(1) bspec) + apply clarsimp + apply (erule bexI[rotated]) + apply simp apply (clarsimp simp:bind_def split_def image_def) apply (drule(1) bspec|clarsimp)+ done @@ -1851,7 +2032,6 @@ lemmas retype_aligned_distinct'' = retype_aligned_distinct' lemma retype_ko_wp_at': assumes vs: "pspace_aligned' s" "pspace_distinct' s" - and bd: "pspace_bounded' s" and pn: "pspace_no_overlap' ptr sz s" and cover: "range_cover ptr sz (objBitsKO obj) n" shows @@ -1861,16 +2041,14 @@ lemma retype_ko_wp_at': else ko_wp_at' P p s)" apply (subst foldr_upd_app_if[folded data_map_insert_def]) apply (rule foldr_update_ko_wp_at' [OF vs]) - apply (simp add: retype_aligned_distinct'' [OF vs bd pn cover])+ - apply (rule new_cap_addrs_aligned) - using cover - apply (simp add:range_cover_def cover) + apply (simp add: retype_aligned_distinct'' [OF vs pn cover])+ + apply (rule new_cap_addrs_aligned) using cover - apply (simp add:range_cover_def word_bits_def) + apply (simp add:range_cover_def cover) done lemma retype_obj_at': - assumes vs: "pspace_aligned' s" "pspace_distinct' s" "pspace_bounded' s" + assumes vs: "pspace_aligned' s" "pspace_distinct' s" and pn: "pspace_no_overlap' ptr sz s" and cover: "range_cover ptr sz (objBitsKO obj) n" shows @@ -1879,10 +2057,11 @@ lemma retype_obj_at': = (if p \ set (new_cap_addrs n ptr obj) then (\ko. projectKO_opt obj = Some ko \ P ko) else obj_at' P p s)" unfolding obj_at'_real_def - by (rule retype_ko_wp_at'[OF vs pn cover]) + apply (rule retype_ko_wp_at'[OF vs pn cover]) +done lemma retype_obj_at_disj': - assumes vs: "pspace_aligned' s" "pspace_distinct' s" "pspace_bounded' s" + assumes vs: "pspace_aligned' s" "pspace_distinct' s" and pn: "pspace_no_overlap' ptr sz s" and cover: "range_cover ptr sz (objBitsKO obj) n" shows @@ -1899,14 +2078,14 @@ lemma retype_obj_at_disj': apply (simp add:ptr_add_def p_assoc_help domI)+ done -declare word_unat_power[symmetric,simp] (* FIXME: remove *) +declare word_unat_power[symmetric,simp] lemma createObjects_ko_at_strg: fixes ptr :: word32 assumes cover: "range_cover ptr sz ((objBitsKO ko) + gbits) n" assumes not_0: "n\ 0" assumes pi: "projectKO_opt ko = Some val" - shows "\\s. pspace_no_overlap' ptr sz s \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ + shows "\\s. pspace_no_overlap' ptr sz s \ pspace_aligned' s \ pspace_distinct' s\ createObjects ptr n ko gbits \\r s. \x \ set r. \offs < 2 ^ gbits. ko_at' val (x + (offs << objBitsKO ko)) s\" proof - @@ -1920,96 +2099,101 @@ proof - have in_new:"\idx offs. \idx \ of_nat n - 1;offs<2 ^ gbits\ \ ptr + (idx << objBitsKO ko + gbits) + (offs << objBitsKO ko) \ set (new_cap_addrs (n * 2 ^ gbits) ptr ko)" - apply (insert range_cover_not_zero[OF not_0 cover] not_0) - apply (clarsimp simp:new_cap_addrs_def image_def) - apply (rule_tac x ="unat (2 ^ gbits * idx + offs)" in bexI) - apply (subst add.commute) - apply (simp add:shiftl_shiftl[symmetric]) - apply (simp add:shiftl_t2n distrib_left[symmetric]) - apply simp - apply (rule unat_less_helper) - apply (rule less_le_trans) - apply (erule word_plus_strict_mono_right) - apply (subst distrib_left[where c = "1 :: 32 word",symmetric,simplified]) - apply (subst mult.commute[where a = "2^gbits"])+ - apply (insert cover) - apply (rule word_mult_le_iff[THEN iffD2]) - apply (simp add:p2_gt_0) - apply (clarsimp simp:range_cover_def word_bits_def) - apply (drule range_cover_rel[where sbit' = "objBitsKO ko "]) - apply simp - apply simp - apply (rule less_le_trans) - apply (rule range_cover.range_cover_le_n_less) + apply (insert range_cover_not_zero[OF not_0 cover] not_0) + apply (clarsimp simp:new_cap_addrs_def image_def) + apply (rule_tac x ="unat (2 ^ gbits * idx + offs)" in bexI) + apply (subst add.commute) + apply (simp add:shiftl_shiftl[symmetric]) + apply (simp add:shiftl_t2n distrib_left[symmetric]) + apply simp + apply (rule unat_less_helper) + apply (rule less_le_trans) + apply (erule word_plus_strict_mono_right) + apply (subst distrib_left[where c = "1 :: 32 word",symmetric,simplified]) + apply (subst mult.commute[where a = "2^gbits"])+ + apply (insert cover) + apply (rule word_mult_le_iff[THEN iffD2]) + apply (simp add:p2_gt_0) + apply (clarsimp simp:range_cover_def word_bits_def) + apply (drule range_cover_rel[where sbit' = "objBitsKO ko "]) + apply simp + apply simp + apply (rule less_le_trans) + apply (rule range_cover.range_cover_le_n_less) + apply simp + apply (subst unat_power_lower) + using cover + apply (clarsimp simp:range_cover_def) + apply (simp add:field_simps) + apply (rule unat_le_helper) + apply (erule order_trans[OF _ word_sub_1_le]) + apply (simp add:range_cover_not_zero[OF not_0 cover]) + apply (simp add:word_bits_def) + apply (drule range_cover_rel[where sbit' = "objBitsKO ko "]) + apply simp apply simp + apply (erule less_le_trans[OF range_cover.range_cover_le_n_less(1)]) apply (subst unat_power_lower) using cover apply (clarsimp simp:range_cover_def) apply (simp add:field_simps) - apply (rule unat_le_helper) - apply (erule order_trans[OF _ word_sub_1_le]) - apply (simp add:range_cover_not_zero[OF not_0 cover]) + apply (rule unat_le_helper[OF inc_le]) + apply (simp add:word_leq_minus_one_le) apply (simp add:word_bits_def) - apply (drule range_cover_rel[where sbit' = "objBitsKO ko "]) - apply simp - apply simp - apply (erule less_le_trans[OF range_cover.range_cover_le_n_less(1)]) - apply (subst unat_power_lower) - using cover - apply (clarsimp simp:range_cover_def) - apply (simp add:field_simps) - apply (rule unat_le_helper[OF inc_le]) - apply (simp add:word_leq_minus_one_le) - apply (simp add:word_bits_def) - apply (rule no_plus_overflow_neg) - apply (rule less_le_trans[where y = "of_nat n"]) - apply unat_arith - using range_cover.range_cover_n_less[OF cover] + apply (rule no_plus_overflow_neg) + apply (rule less_le_trans[where y = "of_nat n"]) + apply unat_arith + using range_cover.range_cover_n_less[OF cover] apply (simp add:word_bits_def) apply (subst distrib_left[where c = "1 :: 32 word",symmetric,simplified]) - apply (subst mult.commute) - apply simp - apply (rule word_mult_le_iff[THEN iffD2]) + apply (subst mult.commute) + apply simp + apply (rule word_mult_le_iff[THEN iffD2]) apply (simp add:p2_gt_0) - apply (simp add:range_cover_def word_bits_def) - apply (drule range_cover_rel[where sbit' = "objBitsKO ko "]) - apply simp - apply simp - apply (rule less_le_trans) - apply (rule range_cover.range_cover_le_n_less) - apply simp - apply (subst unat_power_lower) - using cover - apply (clarsimp simp:range_cover_def) - apply (simp add:field_simps) - apply (rule unat_le_helper) - apply unat_arith - apply (simp add:word_bits_def) + apply (simp add:range_cover_def word_bits_def) apply (drule range_cover_rel[where sbit' = "objBitsKO ko "]) apply simp apply simp apply (rule less_le_trans) - apply (erule range_cover.range_cover_le_n_less) - apply (simp add:range_cover.unat_of_nat_n[OF cover]) - apply (simp add: unat_le_helper) - apply (simp add:word_bits_def) + apply (rule range_cover.range_cover_le_n_less) + apply simp + apply (subst unat_power_lower) + using cover + apply (clarsimp simp:range_cover_def) + apply (simp add:field_simps) + apply (rule unat_le_helper) apply unat_arith - done + apply (simp add:word_bits_def) + apply (drule range_cover_rel[where sbit' = "objBitsKO ko "]) + apply simp + apply simp + apply (rule less_le_trans) + apply (erule range_cover.range_cover_le_n_less) + apply (simp add:range_cover.unat_of_nat_n[OF cover]) + apply (simp add: unat_le_helper) + apply (simp add:word_bits_def) + apply unat_arith + done show ?thesis - apply (simp add: split_def createObjects_def lookupAround2_pspace_no - alignError_def unless_def createObjects'_def) - apply (wp|simp add:data_map_insert_def[symmetric] - cong: if_cong del: fun_upd_apply data_map_insert_def)+ - apply (wpc|wp|clarsimp simp del:fun_upd_apply)+ - apply (subst new_cap_addrs_fold'[OF shiftr_not_zero])+ - apply (subst data_map_insert_def[symmetric])+ - apply (subst retype_obj_at_disj'; simp add:valid_pspace'_def unat_of_nat_shiftl)+ - apply (rule range_cover_rel[OF cover]; simp) - apply (subst retype_obj_at_disj'; simp add:valid_pspace'_def unat_of_nat_shiftl) - apply (rule range_cover_rel[OF cover]; simp) - using range_cover.unat_of_nat_n_shift[OF cover,where gbits = gbits,simplified] pi - apply (simp add: in_new) - done + apply (simp add: split_def createObjects_def lookupAround2_pspace_no + alignError_def unless_def createObjects'_def) + apply (rule hoare_pre) + apply (wp|simp add:data_map_insert_def[symmetric] + cong: if_cong del: fun_upd_apply data_map_insert_def)+ + apply (wpc|wp|clarsimp simp del:fun_upd_apply)+ + apply (subst new_cap_addrs_fold'[OF shiftr_not_zero])+ + apply (subst data_map_insert_def[symmetric])+ + apply (subst retype_obj_at_disj') + apply (simp add:valid_pspace'_def unat_of_nat_shiftl)+ + apply (rule range_cover_rel[OF cover]) + apply simp+ + apply (subst retype_obj_at_disj') + apply (simp add:valid_pspace'_def unat_of_nat_shiftl)+ + apply (rule range_cover_rel[OF cover]) + apply simp+ + using range_cover.unat_of_nat_n_shift[OF cover,where gbits = gbits,simplified] pi + apply (simp add: in_new) + done qed lemma createObjects_ko_at: @@ -2039,6 +2223,9 @@ lemma createObjects_obj_at: apply (clarsimp elim!: obj_at'_weakenE) done +(* until we figure out what we really need of page + mappings it's just alignment, which, fortunately, + is trivial *) lemma createObjects_aligned: assumes al: "is_aligned ptr (objBitsKO ko + gbits)" and bound :"n < 2 ^ word_bits" "n\0" @@ -2049,7 +2236,7 @@ lemma createObjects_aligned: apply (rule createObjects_ret[OF bound]) apply (clarsimp dest!: less_two_pow_divD) apply (rule is_aligned_ptr_add_helper[OF al]) - apply (simp_all add:bound') + apply (simp_all add:bound') done lemma createObjects_aligned2: @@ -2096,27 +2283,6 @@ lemma objBits_if_dev: "objBitsKO (if dev then KOUserDataDevice else KOUserData) = pageBits" by (simp add: objBitsKO_def) -lemma createObjects_sc_at'_n: - fixes ptr :: word32 and val :: sched_context - assumes cover:"range_cover ptr sz ((objBitsKO ko) + gbits) n" - and not_0:"n \ 0" - and pi: "\(val::sched_context). projectKO_opt ko = Some val" - shows - "\\s. pspace_no_overlap' ptr sz s \ valid_pspace' s\ - createObjects ptr n ko gbits - \\r s. \x \ set r. \offs < 2 ^ gbits. - sc_at'_n (objBitsKO ko) (x + (offs << objBitsKO ko)) s\" - apply (rule exE[OF pi]) - apply (prop_tac "objBitsKO ko = objBits x") - apply (clarsimp simp: projectKOs objBits_def) - apply (erule_tac val1 = x in - hoare_post_imp [OF _ createObjects_ko_at [OF cover not_0 ],rotated]) - apply (intro allI ballI impI) - apply (drule(1) bspec) - apply (drule spec, drule(1) mp) - apply (clarsimp simp: ko_wp_at'_def obj_at'_def projectKOs objBits_def) - done - lemma cwo_ret: assumes cover:"range_cover ptr sz v n" assumes not_0:"n\ 0" @@ -2167,7 +2333,6 @@ show ?thesis projectKO_opts_defs split: kernel_object.splits) done qed - lemmas capFreeIndex_update_valid_untyped' = capFreeIndex_update_valid_cap'[unfolded valid_cap'_def,simplified,THEN conjunct2,THEN conjunct1] @@ -2177,14 +2342,14 @@ lemma createNewCaps_valid_cap: assumes not_0: "n \ 0" assumes ct: "ty = APIObjectType ArchTypes_H.CapTableObject \ 0 < us" "ty = APIObjectType apiobject_type.Untyped \ minUntypedSizeBits \ us \ us \ maxUntypedSizeBits" - "ty = APIObjectType ArchTypes_H.SchedContextObject \ sc_size_bounds us" assumes ptr: " ptr \ 0" shows "\\s. pspace_no_overlap' ptr sz s \ valid_pspace' s\ createNewCaps ty ptr n us dev \\r s. (\cap \ set r. s \' cap)\" proof - - note [simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps - note [split del] = if_split + note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex + note if_split_def[split del] = if_splits show ?thesis proof(cases "Types_H.toAPIType ty") @@ -2198,7 +2363,7 @@ proof - split: ARM_H.object_type.splits) \ \SmallPageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2206,7 +2371,7 @@ proof - | simp add: objBits_if_dev pageBits_def ptr range_cover_n_wb)+ apply (simp add:pageBits_def ptr word_bits_def) \ \LargePageObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2215,7 +2380,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \SectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2224,7 +2389,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \SuperSectionObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits ball_conj_distrib) apply (wp createObjects_aligned2 createObjects_nonzero[OF not_0 ,simplified] @@ -2233,7 +2398,7 @@ proof - apply (simp add:pageBits_def ptr word_bits_def) \ \PageTableObject\ - apply wp + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_table_at'_def typ_at_to_obj_at_arches) @@ -2253,8 +2418,7 @@ proof - pdeBits_def pteBits_def) apply clarsimp \ \PageDirectoryObject\ - apply (wp hoare_vcg_const_Ball_lift) - apply (wp mapM_x_wp' ) + apply (wp mapM_x_wp' hoare_vcg_op_lift) apply (simp add: valid_cap'_def capAligned_def n_less_word_bits) apply (simp only: imp_conv_disj page_directory_at'_def typ_at_to_obj_at_arches) @@ -2311,17 +2475,16 @@ proof - apply (simp_all add: ARM_H.toAPIType_def fromIntegral_def toInteger_nat fromInteger_nat APIType_capBits_def curDomain_def split: ARM_H.object_type.splits) - apply wp - apply (rule hoare_post_imp) - prefer 2 - apply (rule createObjects_obj_at [where 'a = "tcb" and sz=sz,OF _ not_0]) - using cover - apply (clarsimp simp: ARM_H.toAPIType_def APIType_capBits_def objBits_simps - split: ARM_H.object_type.splits) - apply (simp add: projectKOs) - apply (clarsimp simp: valid_cap'_def objBits_simps) - apply (fastforce intro: capAligned_tcbI) - apply wp + apply (wp mapM_x_wp' hoare_vcg_const_Ball_lift)+ + apply (rule hoare_post_imp) + prefer 2 + apply (rule createObjects_obj_at [where 'a = "tcb",OF _ not_0]) + using cover + apply (clarsimp simp: ARM_H.toAPIType_def APIType_capBits_def objBits_simps + split: ARM_H.object_type.splits) + apply (simp add: projectKOs) + apply (clarsimp simp: valid_cap'_def objBits_simps) + apply (fastforce intro: capAligned_tcbI) done next case EndpointObject with Some cover ct show ?thesis @@ -2394,56 +2557,15 @@ proof - apply (clarsimp simp add: shiftl_t2n) apply simp done - next - case ReplyObject with Some cover ct show ?thesis - including no_pre - apply (clarsimp simp: Arch_createNewCaps_def createNewCaps_def) - apply (simp_all add: ARM_H.toAPIType_def - fromIntegral_def toInteger_nat fromInteger_nat APIType_capBits_def - split: ARM_H.object_type.splits) - apply wp - apply (rule hoare_post_imp) - prefer 2 - apply (rule createObjects_obj_at [where 'a=reply, OF _ not_0]) - using cover - apply (clarsimp simp: ARM_H.toAPIType_def objBits_simps - split: ARM_H.object_type.splits) - apply (simp add: projectKOs) - apply (simp add: valid_cap'_def) - apply (clarsimp simp: valid_cap'_def objBits_simps) - apply (fastforce intro: capAligned_replyI) - done - next - case SchedContextObject with Some cover ct show ?thesis - including no_pre - apply (clarsimp simp: Arch_createNewCaps_def createNewCaps_def) - apply (simp_all add: ARM_H.toAPIType_def - fromIntegral_def toInteger_nat fromInteger_nat APIType_capBits_def - split: ARM_H.object_type.splits) - apply wp - apply (rule hoare_post_imp) - prefer 2 - apply (rule createObjects_sc_at'_n [OF _ not_0]) - using cover ct(3) - apply (clarsimp simp: ARM_H.toAPIType_def objBits_simps APIType_capBits_def scBits_simps - split: ARM_H.object_type.splits - dest!: ct(3)) - apply (simp add: projectKOs) - apply (clarsimp, drule bspec, simp) - apply (prop_tac "sc_at'_n us cap s") - apply (clarsimp simp: objBitsKO_def scBits_simps) - apply (clarsimp simp: valid_cap'_def capAligned_sched_contextI sc_size_bounds_def) - done qed qed qed lemma other_objs_default_relation: "\ case ty of Structures_A.EndpointObject \ ko = injectKO (makeObject :: endpoint) - | Structures_A.NotificationObject \ ko = injectKO (makeObject :: notification) - | Structures_A.TCBObject \ ko = injectKO (tcbDomain_update (\_. d) makeObject) - | _ \ False \ \ - obj_relation_retype (default_object ty dev n d) ko" + | Structures_A.NotificationObject \ ko = injectKO (makeObject :: Structures_H.notification) + | _ \ False \ \ + obj_relation_retype (default_object ty dev n) ko" apply (rule obj_relation_retype_other_obj) apply (clarsimp simp: default_object_def is_other_obj_relation_type_def @@ -2455,7 +2577,7 @@ lemma other_objs_default_relation: default_ep_def makeObject_endpoint default_notification_def makeObject_notification default_ntfn_def fault_rel_optionation_def - initContext_def default_priority_def + initContext_def arch_tcb_context_get_def atcbContextGet_def default_arch_tcb_def newArchTCB_def arch_tcb_relation_def @@ -2471,7 +2593,7 @@ lemma tcb_relation_retype: lemma captable_relation_retype: "n < word_bits \ - obj_relation_retype (default_object Structures_A.CapTableObject dev n d) (KOCTE makeObject)" + obj_relation_retype (default_object Structures_A.CapTableObject dev n) (KOCTE makeObject)" apply (clarsimp simp: obj_relation_retype_def default_object_def wf_empty_bits objBits_simps' dom_empty_cnode ex_with_length cte_level_bits_def) @@ -2488,26 +2610,8 @@ lemma captable_relation_retype: apply (simp add: less_mask_eq) done -lemma reply_relation_retype: - "obj_relation_retype (default_object Structures_A.ReplyObject dev n d) - (KOReply makeObject)" - by (simp add: default_object_def reply_relation_def default_reply_def - makeObject_reply obj_relation_retype_def - objBits_simps word_bits_def replySizeBits_def) - -lemma sc_relation_retype: - "\sc_size_bounds n\ \ - obj_relation_retype (default_object Structures_A.SchedContextObject dev n d) - (KOSchedContext ((makeObject :: sched_context) - \scRefills := replicate (refillAbsoluteMax' n) emptyRefill, - scSize := n - minSchedContextBits\))" - by (clarsimp simp: default_object_def sc_relation_def default_sched_context_def - makeObject_sc obj_relation_retype_def valid_sched_context_size_def - objBits_simps word_bits_def scBits_simps refills_map_def refill_map_def - emptyRefill_def) - lemma pagetable_relation_retype: - "obj_relation_retype (default_object (ArchObject PageTableObj) dev n d) + "obj_relation_retype (default_object (ArchObject PageTableObj) dev n) (KOArch (KOPTE makeObject))" apply (simp add: default_object_def default_arch_object_def makeObject_pte obj_relation_retype_def @@ -2521,7 +2625,7 @@ lemma pagetable_relation_retype: done lemma pagedirectory_relation_retype: - "obj_relation_retype (default_object (ArchObject PageDirectoryObj) dev n d) + "obj_relation_retype (default_object (ArchObject PageDirectoryObj) dev n) (KOArch (KOPDE makeObject))" apply (simp add: default_object_def default_arch_object_def makeObject_pde obj_relation_retype_def @@ -2542,32 +2646,31 @@ lemma corres_retype: and aligned: "is_aligned ptr (objBitsKO ko + gbits)" and obj_bits_api: "obj_bits_api (APIType_map2 ty) us = objBitsKO ko + gbits" and tp: "APIType_map2 ty \ no_gs_types" - and ko: "makeObjectKO dev us d ty = Some ko" - and tysc: "ty = Inr (APIObjectType SchedContextObject) \ min_sched_context_bits \ us" + and ko: "makeObjectKO dev ty = Some ko" and orr: "obj_bits_api (APIType_map2 ty) us \ sz \ - obj_relation_retype (default_object (APIType_map2 ty) dev us d) ko" + obj_relation_retype (default_object (APIType_map2 ty) dev us) ko" and cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" shows "corres (=) (\s. valid_pspace s \ pspace_no_overlap_range_cover ptr sz s - \ valid_mdb s \ valid_list s) + \ valid_mdb s \ valid_etcbs s \ valid_list s) (\s. pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s - \ (\val. ko = injectKO val) - \ (ty = Inr (APIObjectType TCBObject) \ d = ksCurDomain s)) - (retype_region ptr n us (APIType_map2 ty) dev) (createObjects ptr n ko gbits)" + \ (\val. ko = injectKO val)) + (retype_region2 ptr n us (APIType_map2 ty) dev) (createObjects ptr n ko gbits)" apply (rule corres_guard_imp) apply (rule_tac F = "(\val. ko = injectKO val)" in corres_gen_asm2) apply (erule exE) apply (rule corres_rel_imp) - apply (rule corres_retype'[where g=id and ty=ty and sz = sz,OF not_zero aligned _ _ ko + apply (rule corres_retype'[where g=id and ty=ty and sz = sz,OF not_zero aligned _ _ _ ko ,simplified update_gs_id[OF tp] modify_id_return,simplified]) - using assms - apply (simp_all add: objBits_def no_gs_types_def) - by auto + using assms + apply (simp_all add: objBits_def no_gs_types_def) + apply auto + done lemma init_arch_objects_APIType_map2: - "init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs = + "init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs = (case ty of APIObjectType _ \ return () - | _ \ init_arch_objects (APIType_map2 (Inr ty)) ptr bits sz refs)" + | _ \ init_arch_objects (APIType_map2 (Inr ty)) dev ptr bits sz refs)" apply (clarsimp split: ARM_H.object_type.split) apply (simp add: init_arch_objects_def APIType_map2_def split: apiobject_type.split) @@ -2584,7 +2687,7 @@ lemma pde_relation_aligned_eq: done lemma copyGlobalMappings_corres: - "corres dc (valid_arch_state and pspace_aligned and page_directory_at pd) + "corres dc (valid_arch_state and valid_etcbs and pspace_aligned and page_directory_at pd) (valid_arch_state' and page_directory_at' pd) (copy_global_mappings pd) (copyGlobalMappings pd)" @@ -2599,7 +2702,8 @@ lemma copyGlobalMappings_corres: apply (simp add: liftM_def[symmetric]) apply (rule_tac S="(=)" and r'=dc and Q="\xs s. \x \ set xs. pde_at (global_pd + (x << 2)) s - \ pde_at (pd + (x << 2)) s \ pspace_aligned s" + \ pde_at (pd + (x << 2)) s \ pspace_aligned s \ + valid_etcbs s" and Q'="\xs s. \x \ set xs. pde_at' (global_pd + (x << 2)) s \ pde_at' (pd + (x << 2)) s" in corres_mapM_list_all2, (simp add: pdeBits_def)+) @@ -2610,7 +2714,7 @@ lemma copyGlobalMappings_corres: apply (drule(1) pde_relation_aligned_eq) apply fastforce apply (wp hoare_vcg_const_Ball_lift | simp)+ - apply (simp add: kernel_base_def pptrBase_def list_all2_refl pageBits_def) + apply (simp add: kernel_base_def ARM.pptrBase_def pptrBase_def list_all2_refl pageBits_def) apply wp+ apply (clarsimp simp: valid_arch_state_def) apply (auto elim: page_directory_pde_atI is_aligned_weaken[OF pd_aligned])[1] @@ -2658,7 +2762,8 @@ lemma nullPointer_0_simp[simp]: lemma descendants_of_retype': assumes P: "\p. P p \ m p = None" - shows "descendants_of' p (\p. if P p then Some makeObject else m p) = descendants_of' p m" + shows "descendants_of' p (\p. if P p then Some makeObject else m p) = + descendants_of' p m" apply (rule set_eqI) apply (simp add: descendants_of'_def) apply (rule iffI) @@ -2693,7 +2798,7 @@ locale retype_mdb = vmdb + assumes 0: "\P 0" defines "n \ \p. if P p then Some makeObject else m p" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n: "no_0 n" using no_0 by (simp add: no_0_def n_def 0) @@ -2918,12 +3023,21 @@ lemma dist_z_n: "distinct_zombies n" apply (clarsimp simp: isCap_simps) done +lemma reply_masters_rvk_fb_m: "reply_masters_rvk_fb m" + using valid by auto + +lemma reply_masters_rvk_fb_n: "reply_masters_rvk_fb n" + using reply_masters_rvk_fb_m + by (simp add: n_def reply_masters_rvk_fb_def + ball_ran_eq makeObject_cte isCap_simps) + lemma valid_n: "valid_mdb_ctes n" by (simp add: valid_mdb_ctes_def dlist_n no_0_n mdb_chain_0_n valid_badges_n caps_contained_n untyped_mdb_n untyped_inc_n mdb_chunked_n valid_nullcaps_n ut_rev_n - class_links_n irq_control_n dist_z_n) + class_links_n irq_control_n dist_z_n + reply_masters_rvk_fb_n) end @@ -2959,20 +3073,18 @@ proof - using not_0 n_less apply simp done - have bd[simp]: "objBitsKO val < word_bits" - using assms by (clarsimp simp: range_cover_def word_bits_def) have "ptr' + 2 ^ objBitsKO val - 1 \ ptr + of_nat n * 2 ^ objBitsKO val - 1" using cover apply (subst decomp) apply (simp add:add.assoc[symmetric]) apply (simp add:p_assoc_help) apply (rule order_trans[OF word_plus_mono_left word_plus_mono_right]) - using mem_p not_0 + using mem_p not_0 apply (clarsimp simp:new_cap_addrs_def shiftl_t2n) apply (rule word_plus_mono_right) apply (subst mult.commute) apply (rule word_mult_le_mono1[OF word_of_nat_le]) - using n_less not_0 + using n_less not_0 apply (simp add:unat_of_nat_minus_1) apply (rule p2_gt_0[THEN iffD2]) apply (simp add:word_bits_def range_cover_def) @@ -2980,17 +3092,17 @@ proof - apply (clarsimp simp: unat_of_nat_minus_1[OF n_less(1) not_0]) apply (rule nat_less_power_trans2 [OF range_cover.range_cover_le_n_less(2),OF cover, folded word_bits_def]) - apply (simp add:unat_of_nat_m1 less_imp_le) - apply (simp add:range_cover_def word_bits_def) - apply (rule machine_word_plus_mono_right_split[where sz = sz]) + apply (simp add:unat_of_nat_m1 less_imp_le) + apply (simp add:range_cover_def word_bits_def) + apply (rule machine_word_plus_mono_right_split[where sz = sz]) using range_cover.range_cover_compare[OF cover,where p = "unat (of_nat n - (1::machine_word))"] - apply (clarsimp simp:unat_of_nat_m1) - apply (simp add:range_cover_def word_bits_def) - apply (rule olen_add_eqv[THEN iffD2]) - apply (subst add.commute[where a = "2^objBitsKO val - 1"]) - apply (subst p_assoc_help[symmetric]) - apply (rule is_aligned_no_overflow) - apply (clarsimp simp:range_cover_def word_bits_def) + apply (clarsimp simp:unat_of_nat_m1) + apply (simp add:range_cover_def word_bits_def) + apply (rule olen_add_eqv[THEN iffD2]) + apply (subst add.commute[where a = "2^objBitsKO val - 1"]) + apply (subst p_assoc_help[symmetric]) + apply (rule is_aligned_no_overflow) + apply (clarsimp simp:range_cover_def word_bits_def) apply (erule aligned_add_aligned[OF _ is_aligned_mult_triv2]; simp) apply simp by (meson assms(1) is_aligned_add is_aligned_mult_triv2 is_aligned_no_overflow' range_cover_def) @@ -3001,7 +3113,7 @@ proof - apply (frule(1) obj_range'_subset) apply (simp add: obj_range'_def) apply (cases "n = 0"; clarsimp simp:new_cap_addrs_def) - done + done qed lemma caps_no_overlapD'': @@ -3009,75 +3121,72 @@ lemma caps_no_overlapD'': \ untypedRange c \ {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ {} \ {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ untypedRange c" apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps caps_no_overlap''_def - simp del: atLeastAtMost_simps) + simp del:atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff) apply (drule_tac x = cte in bspec) apply fastforce apply (erule(1) impE) apply blast done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma valid_untyped'_helper: assumes valid : "valid_cap' c s" and cte_at : "cte_wp_at' (\cap. cteCap cap = c) q s" and cover : "range_cover ptr sz (objBitsKO val) n" and range : "caps_no_overlap'' ptr sz s" and pres : "isUntypedCap c \ usableUntypedRange c \ {ptr..ptr + of_nat n * 2 ^ objBitsKO val - 1} = {}" - shows "\pspace_aligned' s; pspace_distinct' s; pspace_bounded' s; pspace_no_overlap' ptr sz s\ - \ valid_cap' c (s\ksPSpace := foldr (\addr. data_map_insert addr val) - (new_cap_addrs n ptr val) (ksPSpace s)\)" -proof - - note blah[simp del] = atLeastAtMost_simps - note cover' = range_cover_rel[where sbit' = "objBitsKO val",OF cover _ refl,simplified] - assume pn : "pspace_aligned' s" "pspace_distinct' s" "pspace_bounded' s" - and no_overlap: "pspace_no_overlap' ptr sz s" + shows "\pspace_aligned' s; pspace_distinct' s; pspace_no_overlap' ptr sz s\ + \ valid_cap' c (s\ksPSpace := foldr (\addr. data_map_insert addr val) (new_cap_addrs n ptr val) (ksPSpace s)\)" + proof - + note blah[simp del] = atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff + assume pn : "pspace_aligned' s" "pspace_distinct' s" + and no_overlap: "pspace_no_overlap' ptr sz s" show ?thesis - using pn pres no_overlap valid cover cte_wp_at_ctes_of[THEN iffD1,OF cte_at] - caps_no_overlapD''[OF cte_at range] - apply (clarsimp simp:valid_cap'_def retype_ko_wp_at') - apply (case_tac "cteCap cte"; simp add: valid_cap'_def cte_wp_at_obj_cases' - valid_pspace'_def retype_obj_at_disj' retype_ko_wp_at' - split: zombie_type.split_asm) - apply (rename_tac arch_capability) - apply (case_tac arch_capability; - simp add: retype_obj_at_disj' typ_at_to_obj_at_arches - page_table_at'_def page_directory_at'_def split del: if_split) - apply (fastforce simp: typ_at_to_obj_at_arches retype_obj_at_disj') - unfolding valid_untyped'_def - apply (intro allI) - apply (rule ccontr) - apply clarify - using cover[unfolded range_cover_def] - apply (clarsimp simp:isCap_simps retype_ko_wp_at' split:if_split_asm) - apply (thin_tac "\x. Q x" for Q) - apply (frule aligned_untypedRange_non_empty) - apply (simp add:isCap_simps) - apply (elim disjE) - apply (frule(1) obj_range'_subset) - apply (erule impE) - apply (drule(1) psubset_subset_trans) - apply (drule Int_absorb1[OF psubset_imp_subset]) - apply (drule aligned_untypedRange_non_empty) - apply (simp add:isCap_simps) - apply (simp add:Int_ac) - apply (drule(1) subset_trans) - apply blast - apply (frule(1) obj_range'_subset_strong) - apply (drule(1) non_disjoing_subset) - apply blast - apply (thin_tac "\x. Q x" for Q) - apply (frule aligned_untypedRange_non_empty) - apply (simp add:isCap_simps) - apply (frule(1) obj_range'_subset) - apply (drule(1) subset_trans) - apply (erule impE) - apply clarsimp - apply blast - apply blast + using pn pres no_overlap valid cover cte_wp_at_ctes_of[THEN iffD1,OF cte_at] + caps_no_overlapD''[OF cte_at range] + apply (clarsimp simp:valid_cap'_def retype_ko_wp_at') + apply (case_tac "cteCap cte"; simp add: valid_cap'_def cte_wp_at_obj_cases' + valid_pspace'_def retype_obj_at_disj' + split: zombie_type.split_asm) + apply (rename_tac arch_capability) + apply (case_tac arch_capability; + simp add: retype_obj_at_disj' typ_at_to_obj_at_arches + page_table_at'_def page_directory_at'_def split del: if_splits) + apply (fastforce simp: typ_at_to_obj_at_arches retype_obj_at_disj') + unfolding valid_untyped'_def + apply (intro allI) + apply (rule ccontr) + apply clarify + using cover[unfolded range_cover_def] + apply (clarsimp simp:isCap_simps retype_ko_wp_at' split:if_split_asm) + apply (thin_tac "\x. Q x" for Q) + apply (frule aligned_untypedRange_non_empty) + apply (simp add:isCap_simps) + apply (elim disjE) + apply (frule(1) obj_range'_subset) + apply (erule impE) + apply (drule(1) psubset_subset_trans) + apply (drule Int_absorb1[OF psubset_imp_subset]) + apply (drule aligned_untypedRange_non_empty) + apply (simp add:isCap_simps) + apply (simp add:Int_ac) + apply (drule(1) subset_trans) + apply blast + apply (frule(1) obj_range'_subset_strong) + apply (drule(1) non_disjoing_subset) + apply blast + apply (thin_tac "\x. Q x" for Q) + apply (frule aligned_untypedRange_non_empty) + apply (simp add:isCap_simps) + apply (frule(1) obj_range'_subset) + apply (drule(1) subset_trans) + apply (erule impE) apply clarsimp - apply (drule (3) retype_ko_wp_at'_not[where gbits=0, simplified, OF _ _ _ cover]) - apply (erule notE, simp) - done + apply blast + apply blast + done qed definition caps_overlap_reserved' :: "word32 set \ kernel_state \ bool" @@ -3086,17 +3195,13 @@ where (isUntypedCap (cteCap cte) \ usableUntypedRange (cteCap cte) \ S = {})" lemma createObjects_valid_pspace': - assumes mko: "makeObjectKO dev us d ty = Some val" - and max_d: "ty = Inr (APIObjectType TCBObject) \ d \ maxDomain" + assumes mko: "makeObjectKO dev ty = Some val" and not_0: "n \ 0" - and tysc: "ty = Inr (APIObjectType SchedContextObject) \ sc_size_bounds us" and cover: "range_cover ptr sz (objBitsKO val + gbits) n" shows "\\s. pspace_no_overlap' ptr sz s \ valid_pspace' s \ caps_no_overlap'' ptr sz s \ caps_overlap_reserved' {ptr .. ptr + of_nat (n * 2^gbits * 2 ^ objBitsKO val ) - 1} s \ ptr \ 0\ - createObjects' ptr n val gbits - \\r. valid_pspace'\" - (* FIXME: clean this up *) + createObjects' ptr n val gbits \\r. valid_pspace'\" apply (cut_tac not_0) apply (simp add: split_def createObjects'_def lookupAround2_pspace_no @@ -3125,9 +3230,7 @@ proof (intro conjI impI) assume pn: "pspace_no_overlap' ptr sz s" and vo: "valid_objs' s" - and vr: "valid_replies' s" and ad: "pspace_aligned' s" "pspace_distinct' s" - and bd: "pspace_bounded' s" and pc: "caps_no_overlap'' ptr sz s" and mdb: "valid_mdb' s" and p_0: "ptr \ 0" @@ -3141,7 +3244,7 @@ proof (intro conjI impI) note cover' = range_cover_rel[where sbit' = "objBitsKO val",OF cover _ refl,simplified] - note ad' = retype_aligned_distinct'[OF ad bd pn cover'] + note ad' = retype_aligned_distinct'[OF ad pn cover'] note shift = range_cover.unat_of_nat_n_shift[OF cover,where gbits=gbits,simplified] @@ -3157,7 +3260,7 @@ proof (intro conjI impI) using ad' shift by (simp add:field_simps) - note obj_at_disj = retype_obj_at_disj' [OF ad bd pn cover'] + note obj_at_disj = retype_obj_at_disj' [OF ad pn cover'] note obj_at_disj' = obj_at_disj [unfolded foldr_upd_app_if[folded data_map_insert_def]] @@ -3172,7 +3275,7 @@ proof (intro conjI impI) have valid_cap: "\cap q. \ s \' cap; cte_wp_at' (\cte. cteCap cte = cap) q s \ \ ?s' \' cap" - apply (rule valid_untyped'_helper[OF _ _ _ pc _ ad bd pn ]) + apply (rule valid_untyped'_helper[OF _ _ _ pc _ ad pn ]) apply simp+ apply (subst mult.commute) apply (rule cover') @@ -3183,13 +3286,13 @@ proof (intro conjI impI) apply simp done - show valid_objs: "valid_objs' ?s'" using vo tysc + show valid_objs: "valid_objs' ?s'" using vo apply (clarsimp simp: valid_objs'_def foldr_upd_app_if[folded data_map_insert_def] elim!: ranE split: if_split_asm) apply (insert sym[OF mko])[1] - apply (clarsimp simp: makeObjectKO_def max_d + apply (clarsimp simp: makeObjectKO_def split: bool.split_asm sum.split_asm ARM_H.object_type.split_asm apiobject_type.split_asm @@ -3198,73 +3301,49 @@ proof (intro conjI impI) 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) - apply (case_tac ntfn, simp_all, (clarsimp simp: obj_at_disj' split:option.splits)+) - apply (rename_tac tcb) - apply (case_tac tcb, clarsimp simp add: valid_tcb'_def) - apply (frule pspace_alignedD' [OF _ ad(1)]) - apply (frule pspace_distinctD' [OF _ ad(2)]) - apply (simp add: objBits_simps) - apply (subst mult.commute) - apply (intro conjI ballI) - apply (clarsimp elim!: ranE) - apply (rule valid_cap[unfolded foldr_upd_app_if[folded data_map_insert_def]]) - apply (fastforce) - apply (rule_tac ptr="x + xa" in cte_wp_at_tcbI', assumption+) - apply fastforce - apply simp - apply (rename_tac thread_state mcp priority inQ inRQ option vptr bound tcbsc tcbyt user_context) - apply (case_tac thread_state, simp_all add: valid_tcb_state'_def - valid_bound_ntfn'_def obj_at_disj' - split: option.splits)[4] - apply (simp add: valid_cte'_def) - apply (frule pspace_alignedD' [OF _ ad(1)]) - apply (frule pspace_distinctD' [OF _ ad(2)]) - apply (simp add: objBits_simps') - apply (subst mult.commute) - apply (erule valid_cap[unfolded foldr_upd_app_if[folded data_map_insert_def]]) - apply (erule(2) cte_wp_at_cteI'[unfolded cte_level_bits_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) + apply (case_tac ntfn, simp_all, (clarsimp simp: obj_at_disj' split:option.splits)+) + apply (rename_tac tcb) + apply (case_tac tcb, clarsimp simp add: valid_tcb'_def) + apply (frule pspace_alignedD' [OF _ ad(1)]) + apply (frule pspace_distinctD' [OF _ ad(2)]) + apply (simp add: objBits_simps) + apply (subst mult.commute) + apply (intro conjI ballI) + apply (clarsimp elim!: ranE) + apply (rule valid_cap[unfolded foldr_upd_app_if[folded data_map_insert_def]]) + apply (fastforce) + apply (rule_tac ptr="x + xa" in cte_wp_at_tcbI', assumption+) + apply fastforce apply simp - apply (rename_tac arch_kernel_object) - apply (case_tac arch_kernel_object; simp) - apply (rename_tac asidpool) - apply (case_tac asidpool, clarsimp simp: page_directory_at'_def - typ_at_to_obj_at_arches - obj_at_disj') - apply (rename_tac pte) - apply (case_tac pte; simp add: valid_mapping'_def) - apply (rename_tac pde) - apply (case_tac pde; simp add: valid_mapping'_def page_table_at'_def - typ_at_to_obj_at_arches obj_at_disj') - apply (rename_tac sc) - apply (case_tac sc; simp add: valid_sched_context'_def valid_bound_tcb'_def obj_at_disj' - split: option.splits) - apply (rename_tac reply) - apply (case_tac reply; fastforce simp: valid_reply'_def valid_bound_tcb'_def obj_at_disj' - split: option.splits) - done - - show valid_replies': "valid_replies' ?s'" using vr - apply (subst mult.commute) - apply (clarsimp simp: valid_replies'_def pred_tcb_at'_def obj_at_disj' - foldr_upd_app_if[folded data_map_insert_def] - elim!: ranE - split: if_split_asm) - apply (insert sym[OF mko])[1] - apply (clarsimp simp: makeObjectKO_def projectKOs opt_map_def makeObject_reply - split: bool.split_asm sum.split_asm - ARM_H.object_type.split_asm - apiobject_type.split_asm - kernel_object.split_asm - arch_kernel_object.split_asm - if_splits option.splits) - apply fastforce + apply (rename_tac thread_state mcp priority bool option nat cptr vptr bound tcbprev tcbnext user_context) + apply (case_tac thread_state, simp_all add: valid_tcb_state'_def valid_bound_tcb'_def + valid_bound_ntfn'_def obj_at_disj' opt_tcb_at'_def + split: option.splits)[4] + apply (simp add: valid_cte'_def) + apply (frule pspace_alignedD' [OF _ ad(1)]) + apply (frule pspace_distinctD' [OF _ ad(2)]) + apply (simp add: objBits_simps') + apply (subst mult.commute) + apply (erule valid_cap[unfolded foldr_upd_app_if[folded data_map_insert_def]]) + apply (erule(2) cte_wp_at_cteI'[unfolded cte_level_bits_def]) + apply simp + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object; simp) + apply (rename_tac asidpool) + apply (case_tac asidpool, clarsimp simp: page_directory_at'_def + typ_at_to_obj_at_arches + obj_at_disj') + apply (rename_tac pte) + apply (case_tac pte; simp add: valid_mapping'_def) + apply (rename_tac pde) + apply (case_tac pde; simp add: valid_mapping'_def page_table_at'_def + typ_at_to_obj_at_arches obj_at_disj') done - have not_0: "0 \ set (new_cap_addrs (2 ^ gbits * n) ptr val)" using p_0 apply clarsimp @@ -3275,13 +3354,12 @@ proof (intro conjI impI) apply (simp add: valid_mdb'_def foldr_upd_app_if[folded data_map_insert_def]) apply (subst mult.commute) apply (subst ctes_of_retype [OF mko ad]) - apply (rule ad'[unfolded foldr_upd_app_if[folded data_map_insert_def]])+ - apply (simp add: objBits_def[symmetric] new_cap_addrs_aligned [OF al]) - using cover apply (clarsimp simp: range_cover_def word_bits_def) + apply (rule ad'[unfolded foldr_upd_app_if[folded data_map_insert_def]])+ + apply (simp add: objBits_def[symmetric] new_cap_addrs_aligned [OF al]) apply (rule ballI, drule subsetD [OF new_cap_addrs_subset [OF cover']]) apply (insert pspace_no_overlap_disjoint' [OF ad(1) pn]) apply (drule_tac x = x in orthD1) - apply (simp add:ptr_add_def p_assoc_help) + apply (simp add:ptr_add_def p_assoc_help) apply fastforce apply (fold makeObject_cte) apply (rule retype_mdb.valid_n) @@ -3325,24 +3403,19 @@ proof (intro conjI impI) using not_0 no_0_obj' by (simp add: no_0_obj'_def data_map_ext field_simps foldr_upd_app_other) - show bounded': "pspace_bounded' ?s'" - using ad' shift range_cover.unat_of_nat_n_shift[OF cover,where gbits=gbits,simplified] - by (simp add: field_simps ) qed abbreviation "injectKOS \ (injectKO :: ('a :: pspace_storable) \ kernel_object)" lemma createObjects_valid_pspace_untyped': - assumes mko: "makeObjectKO dev us d ty = Some val" - and max_d: "ty = Inr (APIObjectType TCBObject) \ d \ maxDomain" + assumes mko: "makeObjectKO dev ty = Some val" and not_0: "n \ 0" - and tysc: "ty = Inr (APIObjectType SchedContextObject) \ sc_size_bounds us" and cover: "range_cover ptr sz (objBitsKO val + gbits) n" shows "\\s. pspace_no_overlap' ptr sz s \ valid_pspace' s \ caps_no_overlap'' ptr sz s \ ptr \ 0 \ caps_overlap_reserved' {ptr .. ptr + of_nat (n * 2^gbits * 2 ^ objBitsKO val ) - 1} s \ createObjects' ptr n val gbits \\r. valid_pspace'\" - apply (wp createObjects_valid_pspace' [OF mko max_d not_0 tysc cover]) + apply (wp createObjects_valid_pspace' [OF mko not_0 cover]) apply simp done @@ -3351,28 +3424,34 @@ lemma getObject_valid_pde'[wp]: apply (rule hoare_chain) apply (rule hoare_vcg_conj_lift) apply (rule getObject_ko_at, simp) + apply (simp add: objBits_simps archObjSize_def pdeBits_def) apply (rule getObject_inv[where P=valid_objs']) + apply (simp add: loadObject_default_inv) apply simp apply (clarsimp simp: projectKOs valid_obj'_def dest!: obj_at_valid_objs') done crunch copyGlobalMappings for valid_objs'[wp]: "valid_objs'" - and pspace_aligned'[wp]: "pspace_aligned'" - and pspace_distinct'[wp]: "pspace_distinct'" - and pspace_bounded'[wp]: "pspace_bounded'" - and valid_mdb[wp]: "valid_mdb'" - and no_0_obj' [wp]: no_0_obj' (ignore: storePDE wp: crunch_wps) +crunch copyGlobalMappings + for pspace_aligned'[wp]: "pspace_aligned'" + (wp: crunch_wps) +crunch copyGlobalMappings + for pspace_distinct'[wp]: "pspace_distinct'" + (wp: crunch_wps) + +lemmas storePDE_valid_mdb[wp] + = storePDE_ctes[where P=valid_mdb_ctes, folded valid_mdb'_def] +crunch copyGlobalMappings + for valid_mdb[wp]: "valid_mdb'" + (wp: crunch_wps) -lemma copyGlobalMappings_valid_replies'[wp]: - "\valid_replies' and pspace_aligned' and pspace_distinct'\ - copyGlobalMappings pd - \\_. valid_replies'\" (is "\?Pre\ _ \_\") - unfolding copyGlobalMappings_def - by (wpsimp wp: mapM_x_inv_wp[where I="?Pre"]) +crunch copyGlobalMappings + for no_0_obj'[wp]: no_0_obj' + (wp: crunch_wps) -lemma copyGlobalMappings_valid_pspace'[wp]: +lemma copyGlobalMappings_valid_pspace[wp]: "\valid_pspace'\ copyGlobalMappings pd \\rv. valid_pspace'\" by (simp add: valid_pspace'_def | wp)+ @@ -3387,14 +3466,11 @@ proof - note unat_of_nat_shift = range_cover.unat_of_nat_n_shift[OF cover,where gbits=gbits,simplified] have cover' :"range_cover ptr sz (objBitsKO val) (n*2^gbits)" by (rule range_cover_rel[OF cover],simp+) - have bd: "objBitsKO val < word_bits" - using cover - by (simp add: range_cover_def word_bits_def) have upbound:" unat ((((of_nat n)::word32) * 2 ^ gbits)) * unat ((2::word32) ^ objBitsKO val) < 2 ^ word_bits" - using range_cover.range_cover_le_n_less[OF cover' le_refl] cover' bd + using range_cover.range_cover_le_n_less[OF cover' le_refl] cover' apply - - apply (drule nat_less_power_trans) - apply (simp add:range_cover_def) + apply (drule nat_less_power_trans) + apply (simp add:range_cover_def) apply (fold word_bits_def) using unat_of_nat_shift not_0 apply (simp add:field_simps shiftl_t2n) @@ -3407,63 +3483,63 @@ proof - using cover by (simp add:range_cover_def word_bits_def) thus ?thesis - apply - - apply (insert not_0 cover ptr_in bd) - apply (frule range_cover.range_cover_le_n_less[OF _ le_refl]) - apply (fold word_bits_def) - apply (simp add:shiftL_nat ) - apply (simp add:range_cover.unat_of_nat_n_shift) - apply (clarsimp simp:new_cap_addrs_def shiftl_t2n) - apply (rename_tac pa) - apply (rule word_plus_mono_right) - apply (rule order_trans) - apply (subst mult.commute) - apply (rule word_mult_le_iff[THEN iffD2]) - apply (clarsimp simp:p2_gt_0 range_cover_def word_bits_def) - apply (drule range_cover_rel[where sbit' = "0"]) - apply (simp+)[2] - apply (erule less_le_trans[OF range_cover.range_cover_le_n_less(2)]) - apply (clarsimp simp:field_simps power_add) - apply (rule unat_le_helper) - apply (rule of_nat_mono_maybe_le[THEN iffD1]) - using range_cover.range_cover_le_n_less[OF cover' le_refl] - apply (simp_all only:word_bits_def[symmetric]) - apply simp - apply (drule nat_less_power_trans) - apply (simp add:range_cover_def word_bits_def) - apply (rule less_le_trans[OF mult_less_mono1]) - apply (rule unat_mono) - apply (rule_tac y1= "pa" in of_nat_mono_maybe'[THEN iffD1,rotated -1]) - apply (assumption) - apply (simp add:word_bits_def) - apply (simp add:word_bits_def) + apply - + apply (insert not_0 cover ptr_in) + apply (frule range_cover.range_cover_le_n_less[OF _ le_refl]) + apply (fold word_bits_def) + apply (simp add:shiftL_nat ) + apply (simp add:range_cover.unat_of_nat_n_shift) + apply (clarsimp simp:new_cap_addrs_def shiftl_t2n) + apply (rename_tac pa) + apply (rule word_plus_mono_right) + apply (rule order_trans) + apply (subst mult.commute) + apply (rule word_mult_le_iff[THEN iffD2]) + apply (clarsimp simp:p2_gt_0 range_cover_def word_bits_def) + apply (drule range_cover_rel[where sbit' = "0"]) + apply (simp+)[2] + apply (erule less_le_trans[OF range_cover.range_cover_le_n_less(2)]) + apply (clarsimp simp:field_simps power_add) + apply (rule unat_le_helper) + apply (rule of_nat_mono_maybe_le[THEN iffD1]) + using range_cover.range_cover_le_n_less[OF cover' le_refl] + apply (simp_all only:word_bits_def[symmetric]) + apply simp + apply (drule nat_less_power_trans) + apply (simp add:range_cover_def word_bits_def) + apply (rule less_le_trans[OF mult_less_mono1]) + apply (rule unat_mono) + apply (rule_tac y1= "pa" in of_nat_mono_maybe'[THEN iffD1,rotated -1]) + apply (assumption) + apply (simp add:word_bits_def) + apply (simp add:word_bits_def) + apply simp + using unat_of_nat_shift + apply (simp add:field_simps shiftl_t2n) apply simp - using unat_of_nat_shift - apply (simp add:field_simps shiftl_t2n) - apply simp - apply (rule word_less_sub_1) - apply (simp add:power_add field_simps) - apply (subst mult.assoc[symmetric]) - apply (rule word_mult_less_mono1) - apply (rule word_of_nat_less) - using unat_of_nat_shift - apply (simp add:shiftl_t2n field_simps) - apply (meson less_exp of_nat_less_pow_32 word_gt_a_gt_0) - using upbound - apply (simp add:word_bits_def) - apply (rule machine_word_plus_mono_right_split[where sz = sz]) - apply (rule less_le_trans[rotated -1]) - apply (rule range_cover.range_cover_compare_bound[OF cover']) - apply (simp add: unat_minus_one[OF not_0']) - using range_cover.unat_of_nat_n_shift[OF cover le_refl] - apply (simp add:shiftl_t2n power_add field_simps) - apply (simp add:range_cover_def word_bits_def) - done + apply (rule word_less_sub_1) + apply (simp add:power_add field_simps) + apply (subst mult.assoc[symmetric]) + apply (rule word_mult_less_mono1) + apply (rule word_of_nat_less) + using unat_of_nat_shift + apply (simp add:shiftl_t2n field_simps) + apply (meson less_exp objBitsKO_bounded2 of_nat_less_pow_32 word_gt_a_gt_0) + using upbound + apply (simp add:word_bits_def) + apply (rule machine_word_plus_mono_right_split[where sz = sz]) + apply (rule less_le_trans[rotated -1]) + apply (rule range_cover.range_cover_compare_bound[OF cover']) + apply (simp add: unat_minus_one[OF not_0']) + using range_cover.unat_of_nat_n_shift[OF cover le_refl] + apply (simp add:shiftl_t2n power_add field_simps) + apply (simp add:range_cover_def word_bits_def) + done qed lemma createObjects_orig_ko_wp_at2': "\\s. range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ P (ko_wp_at' P' p s) \ (P' val \ P True) \ pspace_no_overlap' ptr sz s\ @@ -3510,7 +3586,7 @@ lemma createObjects_orig_ko_wp_at2': lemma createObjects_orig_obj_at2': "\\s. n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ P (obj_at' P' p s) \ \ (case_option False P' (projectKO_opt val)) \ pspace_no_overlap' ptr sz s\ @@ -3522,7 +3598,7 @@ lemma createObjects_orig_cte_wp_at2': "\\s. P (cte_wp_at' P' p s) \ n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ \ (case_option False P' (projectKO_opt val)) \ (\(getF, setF) \ ran tcb_cte_cases. \ (case_option False (P' \ getF) (projectKO_opt val))) @@ -3537,13 +3613,19 @@ lemma createObjects_orig_cte_wp_at2': | simp add: o_def cong: option.case_cong)+ done +lemma threadSet_cte_wp_at2'T: + assumes "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + shows "\\s. P (cte_wp_at' P' p s)\ threadSet F t \\rv s. P (cte_wp_at' P' p s)\" + using assms by (rule threadSet_cte_wp_at'T) + +lemmas threadSet_cte_wp_at2' = + threadSet_cte_wp_at2'T [OF all_tcbI, OF ball_tcb_cte_casesI] + lemma createNewCaps_cte_wp_at2: "\\s. P (cte_wp_at' P' p s) \ \ P' makeObject \ n \ 0 - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ minSchedContextBits \ objsz) \ range_cover ptr sz (APIType_capBits ty objsz) n - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createNewCaps ty ptr n objsz dev \\rv s. P (cte_wp_at' P' p s)\" @@ -3554,19 +3636,24 @@ lemma createNewCaps_cte_wp_at2: split del: if_split cong: if_cong) apply (rename_tac apiobject_type) apply (case_tac apiobject_type; simp split del: if_split) - apply (rule hoare_pre, wp, simp add:createObjects_def) - by (wpsimp wp: createObjects_orig_cte_wp_at2'[where sz = sz] mapM_x_wp' split_del: if_split - simp: createObjects_def curDomain_def objBits_simps APIType_capBits_def - | simp add: projectKO_opts_defs makeObject_tcb tcb_cte_cases_def Let_def - scBits_simps objBits_if_dev objBits_simps - archObjSize_def pdBits_def pdeBits_def ptBits_def pteBits_def pageBits_def - split del: if_split - | simp)+ + apply (rule hoare_pre, wp, simp add:createObjects_def) + apply ((wp createObjects_orig_cte_wp_at2'[where sz = sz] + mapM_x_wp' threadSet_cte_wp_at2')+ + | assumption + | clarsimp simp: APIType_capBits_def + projectKOs projectKO_opts_defs + makeObject_tcb tcb_cte_cases_def + pageBits_def archObjSize_def ptBits_def + pdBits_def createObjects_def curDomain_def + Let_def objBits_if_dev + split del: if_split + | simp add: objBits_simps pteBits_def pdeBits_def)+ + done lemma createObjects_orig_obj_at': "\\s. n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ obj_at' P p s \ pspace_no_overlap' ptr sz s\ createObjects' ptr n val gbits \\r. obj_at' P p\" @@ -3610,7 +3697,7 @@ crunch doMachineOp lemma createObjects_orig_cte_wp_at': "\\s. range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ cte_wp_at' P p s \ pspace_no_overlap' ptr sz s\ createObjects' ptr n val gbits \\r s. cte_wp_at' P p s\" @@ -3622,9 +3709,7 @@ lemma createObjects_orig_cte_wp_at': lemma createNewCaps_cte_wp_at': "\\s. cte_wp_at' P p s \ range_cover ptr sz (APIType_capBits ty us) n \ n \ 0 - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createNewCaps ty ptr n us dev \\rv. cte_wp_at' P p\" @@ -3638,8 +3723,7 @@ lemma createNewCaps_cte_wp_at': apply (wp createObjects_orig_cte_wp_at'[where sz = sz] mapM_x_wp' threadSet_cte_wp_at'T | clarsimp simp: objBits_simps APIType_capBits_def createObjects_def curDomain_def - pageBits_def ptBits_def pdBits_def archObjSize_def pteBits_def - pdeBits_def scBits_simps + pageBits_def ptBits_def pdBits_def archObjSize_def pteBits_def pdeBits_def | intro conjI impI | force simp: tcb_cte_cases_def)+ done @@ -3670,20 +3754,23 @@ lemma valid_cap'_range_no_overlap: page_table_at'_def page_directory_at'_def) apply (fastforce simp: typ_at_to_obj_at_arches retype_obj_at_disj') apply (rename_tac word nat1 nat2) - apply (clarsimp simp: valid_untyped'_def retype_ko_wp_at' - simp del: atLeastAtMost_simps) + apply (clarsimp simp:valid_untyped'_def retype_ko_wp_at' + simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff) apply (frule aligned_untypedRange_non_empty) apply (simp add:isCap_simps) apply (intro conjI impI) apply (intro allI) apply (drule_tac x = ptr' in spec) apply (rule ccontr) - apply (clarsimp simp del: atLeastAtMost_simps) + apply (clarsimp simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff) apply (erule disjE) apply (drule(2) disjoint_subset2 [OF obj_range'_subset]) apply (drule(1) disjoint_subset2[OF psubset_imp_subset]) apply (simp add: Int_absorb ptr_add_def p_assoc_help - del: atLeastAtMost_simps) + del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff) apply (drule(1) obj_range'_subset) apply (drule_tac A'=" {word + of_nat nat2..word + 2 ^ nat1 - 1}" in disjoint_subset[rotated]) apply clarsimp @@ -3696,14 +3783,13 @@ lemma valid_cap'_range_no_overlap: apply (intro allI) apply (drule_tac x = ptr' in spec) apply (rule ccontr) - apply (clarsimp simp del: atLeastAtMost_simps) + apply (clarsimp simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff) apply (drule(2) disjoint_subset2 [OF obj_range'_subset]) apply (drule(1) disjoint_subset2) apply (simp add: Int_absorb ptr_add_def p_assoc_help - del: atLeastAtMost_simps) - apply (clarsimp simp: retype_ko_wp_at') - apply (drule (4) retype_ko_wp_at'_not[where gbits=0, simplified]) - apply (erule notE, simp) + del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff) done lemma createObjects_cte_wp_at': @@ -3728,13 +3814,11 @@ lemma createObjects_cte_wp_at': lemma createNewCaps_cte_wp_at: 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. cte_wp_at' P p s \ valid_pspace' s \ pspace_no_overlap' ptr sz s\ createNewCaps ty ptr n us dev \\_. cte_wp_at' P p\" apply (wp createNewCaps_cte_wp_at') - apply (auto simp: cover not_0 tysc) + apply (auto simp: cover not_0) done lemma createObjects_ret2: @@ -3763,7 +3847,7 @@ lemma createObjects_state_refs_of'': "\\s. n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n \ P (state_refs_of' s) \ refs_of' val = {} - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createObjects' ptr n val gbits \\rv s. P (state_refs_of' s)\" @@ -3781,16 +3865,13 @@ lemma createObjects_state_refs_of'': apply simp+ done -crunch copyGlobalMappings, curDomain -for state_refs_of'[wp]: "\s. P (state_refs_of' s)" -and replies_of'[wp]: "\s. P (replies_of' s)" +crunch copyGlobalMappings + for state_refs_of'[wp]: "\s. P (state_refs_of' s)" (wp: crunch_wps) lemma createNewCaps_state_refs_of': 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 \ P (state_refs_of' s)\ @@ -3804,20 +3885,21 @@ lemma createNewCaps_state_refs_of': apply (rename_tac apiobject_type) apply (case_tac apiobject_type; simp split del: if_split) apply (rule hoare_pre, wp, simp) - apply (insert cover not_0 tysc) - by (wp mapM_x_wp' createObjects_state_refs_of'' threadSet_state_refs_of' - | simp add: not_0 pspace_no_overlap'_def objBitsKO_def APIType_capBits_def - valid_pspace'_def makeObject_tcb makeObject_endpoint objBits_def - makeObject_notification pageBits_def ptBits_def pdBits_def - archObjSize_def createObjects_def curDomain_def scBits_simps - pdeBits_def pteBits_def makeObject_sc makeObject_reply - | intro conjI impI )+ + apply (insert cover not_0) + apply (wp mapM_x_wp' createObjects_state_refs_of'' threadSet_state_refs_of' + | simp add: not_0 pspace_no_overlap'_def objBitsKO_def APIType_capBits_def + valid_pspace'_def makeObject_tcb makeObject_endpoint objBits_def + makeObject_notification pageBits_def ptBits_def pdBits_def + archObjSize_def createObjects_def curDomain_def + pdeBits_def pteBits_def + | intro conjI impI)+ + 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_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createObjects' ptr n val gbits \\rv s. if_live_then_nonz_cap' s\" @@ -3829,114 +3911,15 @@ lemma createObjects_iflive': createObjects_orig_cte_wp_at') apply clarsimp apply (intro conjI allI impI) - apply simp_all + 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_list_refs_of_replies'': - "\\s. n \ 0 - \ range_cover ptr sz (objBitsKO val + gbits) n - \ P (list_refs_of_replies' s) - \ (case val of KOReply r \ replyNext_of r = None \ replyPrev r = None - | _ \ True) - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s - \ pspace_no_overlap' ptr sz s\ - createObjects' ptr n val gbits - \\rv s. P (list_refs_of_replies' s)\" (is "\ \s. _ \ _ \ ?Pre s \ _ \\_. _\") -proof - - show ?thesis - apply (rule hoare_grab_asm) - apply (rule hoare_grab_asm) - proof - - assume not_0: "\ n = 0" - and cover: "range_cover ptr sz ((objBitsKO val) + gbits) n" - then show - "\\s. ?Pre s\ - createObjects' ptr n val gbits - \\rv s. P (list_refs_of_replies' s)\" - proof - - have shiftr_not_zero:" 1 \ ((of_nat n)::word32) << gbits" - using range_cover_not_zero_shift[OF not_0 cover,where gbits = gbits] - by (simp add:word_le_sub1) - note unat_of_nat_shiftl = range_cover.unat_of_nat_n_shift[OF cover,where gbits = gbits,simplified] - show ?thesis - apply (clarsimp simp: createObjects'_def unless_def alignError_def split_def) - apply (wp | clarsimp simp del: fun_upd_apply)+ - apply (erule ssubst[where P = P,rotated]) - apply (clarsimp simp: shiftL_nat data_map_insert_def[symmetric] - new_cap_addrs_fold'[OF shiftr_not_zero] - simp del: data_map_insert_def) - using range_cover.unat_of_nat_n_shift[OF cover, where gbits=gbits, simplified] - apply simp - apply (rule ext) - apply (rule set_eqI) - apply (rule iffI; clarsimp simp: map_set_def opt_map_def foldr_upd_app_if - projectKO_opt_reply list_refs_of_reply'_def - split: option.splits if_split_asm) - apply (cases val; fastforce) - apply (intro conjI impI) - apply clarsimp - apply (frule_tac x=x in retype_obj_at'_not[OF _ _ _ cover, where P=\], simp+) - apply (simp add: semiring_normalization_rules(7)) - apply (erule notE) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (frule pspace_alignedD'; clarsimp) - apply (frule pspace_distinctD'; clarsimp) - apply (frule pspace_boundedD'; clarsimp) - apply (clarsimp split: kernel_object.splits) - apply (rule_tac x=x2a in exI) - apply (fastforce simp: projectKO_opts_defs)+ - apply (intro allI impI) - apply (split kernel_object.split_asm; simp add: get_refs_def2) - apply (frule_tac x=x in retype_obj_at'_not[OF _ _ _ cover, where P=\], simp+) - apply (simp add: semiring_normalization_rules(7)) - apply (erule notE) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (frule pspace_alignedD'; clarsimp) - apply (frule pspace_distinctD'; clarsimp) - apply (frule pspace_boundedD'; clarsimp) - apply (clarsimp split: kernel_object.splits) - apply (rule_tac x=x2a in exI) - apply (fastforce simp: projectKO_opts_defs) - done - qed - qed -qed - -lemma createNewCaps_list_refs_of_replies': - 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 - \ P (list_refs_of_replies' s)\ - createNewCaps ty ptr n us dev - \\rv s. P (list_refs_of_replies' s)\" - unfolding createNewCaps_def - apply (clarsimp simp: ARM_H.toAPIType_def - split del: if_split) - apply (cases ty; simp add: createNewCaps_def Arch_createNewCaps_def - split del: if_split) - apply (rename_tac apiobject_type) - apply (case_tac apiobject_type; simp split del: if_split) - apply (rule hoare_pre, wp, simp) - apply (insert cover not_0 tysc) - apply (wpsimp wp: mapM_x_wp' createObjects_list_refs_of_replies'' - simp: curDomain_def) - by (wpsimp wp: mapM_x_wp' createObjects_list_refs_of_replies''[simplified o_def] - | simp add: not_0 pspace_no_overlap'_def objBitsKO_def APIType_capBits_def - valid_pspace'_def makeObject_tcb makeObject_endpoint objBits_def - makeObject_notification pageBits_def ptBits_def pdBits_def - archObjSize_def createObjects_def curDomain_def o_def scBits_simps - pdeBits_def pteBits_def makeObject_sc makeObject_reply - | intro conjI impI )+ - crunch copyGlobalMappings - for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" (wp: updateObject_default_inv crunch_wps) crunch copyGlobalMappings for ksReadyQueuesL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" @@ -3944,9 +3927,6 @@ crunch copyGlobalMappings crunch copyGlobalMappings for ksReadyQueuesL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" (wp: updateObject_default_inv crunch_wps) -crunch copyGlobalMappings - for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" - (wp: updateObject_default_inv crunch_wps) crunch copyGlobalMappings for valid_idle'[wp]: "valid_idle'" @@ -3960,31 +3940,30 @@ crunch copyGlobalMappings lemma createNewCaps_iflive'[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 (insert cover) + apply (clarsimp simp: toAPIType_def ARM_H.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 - valid_pspace'_def makeObject_tcb makeObject_endpoint - makeObject_notification objBitsKO_def curDomain_def scBits_simps - live_ntfn'_def live_sc'_def live_reply'_def makeObject_sc - APIType_capBits_def objBits_def pageBits_def makeObject_reply - archObjSize_def ptBits_def pdBits_def pteBits_def pdeBits_def - split del: if_split - | simp split: if_split - | fastforce)+ + apply (rule hoare_pre, wp, simp) + apply (wp mapM_x_wp' createObjects_iflive' threadSet_iflive' + | simp add: not_0 pspace_no_overlap'_def createObjects_def + valid_pspace'_def makeObject_tcb makeObject_endpoint + makeObject_notification objBitsKO_def + APIType_capBits_def objBits_def pageBits_def + archObjSize_def ptBits_def pdBits_def + pteBits_def pdeBits_def + curDomain_def split del:if_split + | simp split: if_split + | fastforce)+ + done lemma createObjects_pspace_only: "\ \f s. P (ksPSpace_update f s) = P s \ @@ -3998,10 +3977,6 @@ lemma createObjects'_qs[wp]: "\\s. P (ksReadyQueues s)\ createObjects' ptr n val gbits \\rv s. P (ksReadyQueues s)\" by (rule createObjects_pspace_only, simp) -lemma createObjects'_rlq[wp]: - "\\s. P (ksReleaseQueue s)\ createObjects' ptr n val gbits \\rv s. P (ksReleaseQueue s)\" - by (rule createObjects_pspace_only, simp) - lemma createObjects'_qsL1[wp]: "\\s. P (ksReadyQueuesL1Bitmap s)\ createObjects' ptr n val gbits \\rv s. P (ksReadyQueuesL1Bitmap s)\" by (rule createObjects_pspace_only, simp) @@ -4010,9 +3985,17 @@ lemma createObjects'_qsL2[wp]: "\\s. P (ksReadyQueuesL2Bitmap s)\ createObjects' ptr n val gbits \\rv s. P (ksReadyQueuesL2Bitmap s)\" by (rule createObjects_pspace_only, simp) +(* FIXME move these 2 to TcbAcc_R *) +lemma threadSet_qsL1[wp]: + "\\s. P (ksReadyQueuesL1Bitmap s)\ threadSet f t \\rv s. P (ksReadyQueuesL1Bitmap s)\" + by (simp add: threadSet_def | wp updateObject_default_inv)+ + +lemma threadSet_qsL2[wp]: + "\\s. P (ksReadyQueuesL2Bitmap s)\ threadSet f t \\rv s. P (ksReadyQueuesL2Bitmap s)\" + by (simp add: threadSet_def | wp updateObject_default_inv)+ + crunch createObjects, createNewCaps for qs[wp]: "\s. P (ksReadyQueues s)" - and rlqs[wp]: "\s. P (ksReleaseQueue s)" and qsL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" and qsL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" (simp: crunch_simps wp: crunch_wps) @@ -4067,7 +4050,7 @@ lemma copyGlobalMappings_ko_wp_at: apply (simp add: objBits_simps archObjSize_def) apply (simp add: pdeBits_def) apply (simp cong: if_cong split del: if_split) - apply (wp getObject_inv | simp split del: if_split)+ + apply (wp getObject_inv loadObject_default_inv | simp split del: if_split)+ apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) apply (wp | simp)+ done @@ -4076,20 +4059,20 @@ 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 \\_ s. P (ko_wp_at' P' p s)\" - apply (simp add: threadSet_def split del: if_split) - apply (wp setObject_ko_wp_at getObject_tcb_wp | simp add: objBits_simps')+ - apply (auto simp: ko_wp_at'_def obj_at'_def projectKOs) - done +apply (simp add: threadSet_def split del: if_split) +apply (wp setObject_ko_wp_at getObject_tcb_wp | simp add: objBits_simps')+ +apply (auto simp: ko_wp_at'_def obj_at'_def projectKOs) +done lemma threadSet_ko_wp_at2'_futz: "\\s. P (ko_wp_at' P' p s) \ obj_at' Q ptr s - \ (\tcb_x :: tcb. Q tcb_x \ P' (injectKO (F tcb_x)) = P' (injectKO tcb_x))\ - threadSet F ptr - \\_ s. P (ko_wp_at' P' p s)\" - apply (simp add: threadSet_def split del: if_split) - apply (wp setObject_ko_wp_at getObject_tcb_wp | simp add: objBits_simps')+ - apply (auto simp: ko_wp_at'_def obj_at'_def projectKOs) - done + \ (\tcb_x :: tcb. Q tcb_x \ P' (injectKO (F tcb_x)) = P' (injectKO tcb_x))\ + threadSet F ptr + \\_ s. P (ko_wp_at' P' p s)\" +apply (simp add: threadSet_def split del: if_split) +apply (wp setObject_ko_wp_at getObject_tcb_wp | simp add: objBits_simps')+ +apply (auto simp: ko_wp_at'_def obj_at'_def projectKOs) +done lemma mapM_x_threadSet_createNewCaps_futz: "\\s. P (ko_wp_at' P' p s) \ (\addr\set addrs. obj_at' (\tcb. \tcbQueued tcb \ tcbState tcb = Inactive) addr s) @@ -4108,7 +4091,7 @@ lemma mapM_x_threadSet_createNewCaps_futz: lemma createObjects_makeObject_not_tcbQueued: assumes "range_cover ptr sz (objBitsKO tcb) n" assumes "n \ 0" "tcb = injectKO (makeObject::tcb)" - shows "\\s. pspace_no_overlap' ptr sz s \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ + shows "\\s. pspace_no_overlap' ptr sz s \ pspace_aligned' s \ pspace_distinct' s\ createObjects ptr n tcb 0 \\rv s. \addr\set rv. obj_at' (\tcb. \ tcbQueued tcb \ tcbState tcb = Structures_H.thread_state.Inactive) addr s\" apply (rule hoare_strengthen_post[OF createObjects_ko_at_strg[where 'a=tcb]]) @@ -4119,31 +4102,29 @@ lemma createObjects_makeObject_not_tcbQueued: lemma createObjects_ko_wp_at2: "\\s. range_cover ptr sz (objBitsKO ko + gbits) n \ n \ 0 - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ P (ko_wp_at' P' p s) \ (P' ko \ P True) \ pspace_no_overlap' ptr sz s\ createObjects ptr n ko gbits \\_ s. P (ko_wp_at' P' p s)\" - apply (simp add: createObjects_def) - apply (wp createObjects_orig_ko_wp_at2') - apply auto - done +apply (simp add: createObjects_def) +apply (wp createObjects_orig_ko_wp_at2') +apply auto +done lemma createNewCaps_ko_wp_atQ': "\(\s. P (ko_wp_at' P' p s) \ range_cover ptr sz (APIType_capBits ty us) n \ n \ 0 - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s) and K (\pde_x :: pde. P' (injectKO pde_x) \ (\pde_y :: pde. P' (injectKO pde_y))) and K (\d (tcb_x :: tcb). \tcbQueued tcb_x \ tcbState tcb_x = Inactive \ P' (injectKO (tcb_x \ tcbDomain := d \)) = P' (injectKO tcb_x)) - and (\s. \v. makeObjectKO dev us (ksCurDomain s) (Inr ty) = Some v + and K (\v. makeObjectKO d (Inr ty) = Some v \ P' v \ P True)\ - createNewCaps ty ptr n us dev + createNewCaps ty ptr n us d \\rv s. P (ko_wp_at' P' p s)\" apply (rule hoare_name_pre_state) apply (clarsimp simp: createNewCaps_def ARM_H.toAPIType_def @@ -4153,14 +4134,19 @@ lemma createNewCaps_ko_wp_atQ': apply (rename_tac apiobject_type) apply (case_tac apiobject_type, simp_all split del: if_split)[1] apply (rule hoare_pre, wp, simp) - by (wpsimp wp: mapM_x_wp' createObjects_makeObject_not_tcbQueued - createObjects_obj_at createObjects_ko_wp_at2[where sz=sz] - copyGlobalMappings_ko_wp_at[where v="\pde :: pde. P' (injectKO pde)"] - split_del: if_split - simp: curDomain_def APIType_capBits_def objBitsKO_def objBits_def makeObjectKO_def - pageBits_def pdBits_def ptBits_def scBits_simps - pteBits_def pdeBits_def sc_size_bounds_def archObjSize_def - | split if_split_asm[where Q=dev] | fastforce)+ + apply ((wp mapM_x_threadSet_createNewCaps_futz + mapM_x_wp' + createObjects_obj_at + createObjects_ko_wp_at2 createObjects_makeObject_not_tcbQueued + copyGlobalMappings_ko_wp_at[where v="\pde :: pde. P' (injectKO pde)"] + | simp add: makeObjectKO_def objBitsKO_def archObjSize_def APIType_capBits_def + objBits_def pageBits_def pdBits_def ptBits_def curDomain_def + pteBits_def pdeBits_def + split del: if_split + | split if_split_asm[where Q=d] + | intro conjI impI | fastforce)+) + done + lemmas createNewCaps_ko_wp_at' = createNewCaps_ko_wp_atQ'[simplified, unfolded fold_K] @@ -4175,34 +4161,29 @@ lemmas createNewCaps_obj_at2 = lemma createNewCaps_obj_at'': "\\s. obj_at' (P :: ('a :: pspace_storable) \ bool) p s \ range_cover ptr sz (APIType_capBits ty us) n \ n \ 0 - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ (koType(TYPE('a)) = koType(TYPE(pde)) \ (\x. P x) \ (\pde :: pde. \x :: 'a. injectKO x = injectKO pde)) - \ (\tcb d. \tcbQueued tcb \ tcbState tcb = Inactive - \ ((\obj :: 'a. injectKOS obj = KOTCB (tcb\tcbDomain := d\) \ P obj) - \ (\obj :: 'a. injectKOS obj = KOTCB tcb \ P obj)))\ + \ (\tcb d. \tcbQueued tcb \ tcbState tcb = Inactive \ ((\obj :: 'a. injectKOS obj = KOTCB (tcb\tcbDomain := d\) \ P obj) \ (\obj :: 'a. injectKOS obj = KOTCB tcb \ P obj)))\ createNewCaps ty ptr n us d \\rv s. obj_at' P p s\" apply (simp add: obj_at'_real_def) apply (wp createNewCaps_ko_wp_at') apply clarsimp apply (intro conjI impI) - apply simp+ - apply (clarsimp simp: projectKOs dest!: iffD1 [OF project_koType, OF exI]) - apply (clarsimp simp:project_inject)+ - done + apply simp+ + apply clarsimp + apply (clarsimp simp: projectKOs dest!: iffD1 [OF project_koType, OF exI]) + apply (clarsimp simp:project_inject)+ +done lemma createNewCaps_obj_at': "\\s. obj_at' (P :: ('a :: pspace_storable) \ bool) p s \ range_cover ptr sz (APIType_capBits ty us) n \ n \ 0 - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ koType(TYPE('a)) \ koType(TYPE(pde)) \ (\tcb d. \tcbQueued tcb \ tcbState tcb = Inactive \ ((\obj :: 'a. injectKOS obj = KOTCB (tcb\tcbDomain := d\) \ P obj) \ (\obj :: 'a. injectKOS obj = KOTCB tcb \ P obj)))\ createNewCaps ty ptr n us d @@ -4217,8 +4198,6 @@ lemma createNewCaps_cur: "\range_cover ptr sz (APIType_capBits ty us) n ; n \ 0\ \ \\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ - (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ cur_tcb' s\ createNewCaps ty ptr n us d \\rv. cur_tcb'\" @@ -4238,8 +4217,6 @@ lemma createNewCaps_ifunsafe': "\\s. valid_pspace' s \ pspace_no_overlap' ptr sz s \ range_cover ptr sz (APIType_capBits ty us) n \ n \ 0 \ - (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ if_unsafe_then_cap' s\ createNewCaps ty ptr n us d \\rv s. if_unsafe_then_cap' s\" @@ -4249,8 +4226,10 @@ lemma createNewCaps_ifunsafe': apply (rule hoare_use_eq_irq_node' [OF createNewCaps_ksInterrupt]) apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift createNewCaps_cte_wp_at2 hoare_vcg_ex_lift) - by (auto simp: makeObject_cte pspace_no_overlap'_def sc_size_bounds_def - valid_pspace'_def) + apply (simp add: makeObject_cte pspace_no_overlap'_def + valid_pspace'_def) + apply auto + done lemma createObjects_nosch'[wp]: "\\s. P (ksSchedulerAction s)\ @@ -4277,10 +4256,10 @@ lemma createObjects_idle': 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 (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 projectKOs o_def pred_tcb_at'_def valid_pspace'_def cong: option.case_cong) @@ -4289,8 +4268,6 @@ lemma createObjects_idle': lemma createNewCaps_idle'[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'\" @@ -4299,27 +4276,30 @@ lemma createNewCaps_idle'[wp]: 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] - by (wpsimp wp: createObjects_idle'[where sz=sz] mapM_x_wp' split_del: if_split - simp: curDomain_def APIType_capBits_def createObjects_def - | simp add: tcb_cte_cases_def projectKO_opt_tcb projectKO_opt_cte makeObject_tcb makeObject_cte - objBits_def objBitsKO_def ptBits_def pdBits_def pteBits_def pdeBits_def pageBits_def - scBits_simps archObjSize_def)+ + apply (rename_tac apiobject_type) + apply (case_tac apiobject_type, simp_all split del: if_split)[1] + apply wpsimp + apply (wpsimp wp: mapM_x_wp' createObjects_idle' threadSet_idle' + | simp add: projectKO_opt_tcb projectKO_opt_cte + makeObject_cte makeObject_tcb archObjSize_def + tcb_cte_cases_def objBitsKO_def APIType_capBits_def + ptBits_def pdBits_def pageBits_def objBits_def + createObjects_def pteBits_def pdeBits_def + | intro conjI impI + | clarsimp simp: curDomain_def)+ + done crunch createNewCaps for ksArch[wp]: "\s. P (ksArchState s)" (simp: crunch_simps unless_def wp: crunch_wps) crunch createNewCaps - for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" + for gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" (simp: crunch_simps unless_def wp: crunch_wps updateObject_default_inv) lemma createNewCaps_global_refs': "\\s. range_cover ptr sz (APIType_capBits ty us) n \ n \ 0 - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ valid_global_refs' s - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ 0 < gsMaxObjectSize s\ createNewCaps ty ptr n us d \\rv. valid_global_refs'\" @@ -4335,7 +4315,8 @@ lemma createNewCaps_global_refs': apply (rule hoare_use_eq [where f=irq_node', OF createNewCaps_ksInterrupt]) apply (rule hoare_use_eq [where f=gsMaxObjectSize], wp) apply (wp hoare_vcg_all_lift createNewCaps_cte_wp_at2[where sz=sz]) - apply (clarsimp simp: cte_wp_at_ctes_of global_refs'_def sc_size_bounds_def makeObject_cte) + apply (clarsimp simp: cte_wp_at_ctes_of global_refs'_def + makeObject_cte) apply (auto simp: linorder_not_less ball_ran_eq) done @@ -4346,9 +4327,7 @@ lemma koTypeOf_eq_UserDataT: lemma createNewCaps_valid_arch_state: "\(\s. valid_arch_state' s \ valid_pspace' s \ pspace_no_overlap' ptr sz s - \ (tp = APIObjectType ArchTypes_H.CapTableObject \ us > 0) - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us)) + \ (tp = APIObjectType ArchTypes_H.CapTableObject \ us > 0)) and K (range_cover ptr sz (APIType_capBits ty us) n \ n \ 0)\ createNewCaps ty ptr n us d \\rv. valid_arch_state'\" @@ -4390,9 +4369,7 @@ lemma valid_irq_handlers_cte_wp_at_form': lemma createNewCaps_irq_handlers': "\valid_irq_handlers' and pspace_no_overlap' ptr sz - and pspace_aligned' and pspace_distinct' and pspace_bounded' - and K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) + and pspace_aligned' and pspace_distinct' and K (range_cover ptr sz (APIType_capBits ty us) n \ n \ 0)\ createNewCaps ty ptr n us d \\rv. valid_irq_handlers'\" @@ -4400,7 +4377,7 @@ lemma createNewCaps_irq_handlers': apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift createNewCaps_cte_wp_at2) apply (clarsimp simp: makeObject_cte) - apply (auto simp: sc_size_bounds_def) + apply auto done lemma valid_pde_mappings'_def3: @@ -4413,7 +4390,7 @@ lemma valid_pde_mappings'_def3: lemma createObjects'_pde_mappings'[wp]: "\\s. valid_pde_mappings' s \ range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ (\pde. projectKO_opt val = Some pde \ pde = InvalidPDE)\ createObjects' ptr n val gbits @@ -4429,7 +4406,7 @@ lemma createObjects'_pde_mappings'[wp]: lemma createObjects_pde_mappings'[wp]: "\\s. valid_pde_mappings' s \ range_cover ptr sz (objBitsKO ko + gbits) n \ n \ 0 - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ (\pde. projectKO_opt ko = Some pde \ pde = InvalidPDE)\ createObjects ptr n ko gbits @@ -4475,10 +4452,8 @@ lemma mapM_x_copyGlobalMappings_pde_mappings': lemma createNewCaps_pde_mappings'[wp]: "\\s. valid_pde_mappings' s \ range_cover ptr sz (APIType_capBits ty us) n \ n \ 0 - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ valid_arch_state' s - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createNewCaps ty ptr n us d \\_. valid_pde_mappings'\" @@ -4486,7 +4461,9 @@ lemma createNewCaps_pde_mappings'[wp]: split del: if_split cong: option.case_cong object_type.case_cong) apply (rule hoare_pre) - apply (wp mapM_x_copyGlobalMappings_pde_mappings' | wpc + apply (wp mapM_x_copyGlobalMappings_pde_mappings' + mapM_x_wp'[where f="\r. doMachineOp (m r)" for m] + | wpc | simp split del: if_split)+ apply (rule_tac P="range_cover ptr sz (APIType_capBits ty us) n \ n\ 0" in hoare_gen_asm) apply (rule hoare_strengthen_post) @@ -4502,8 +4479,9 @@ lemma createNewCaps_pde_mappings'[wp]: apply (case_tac ty; simp) apply (rename_tac apiobject_type) apply (case_tac apiobject_type) - by (auto simp: ARM_H.toAPIType_def objBits_simps ptBits_def pageBits_def pteBits_def pdeBits_def - makeObject_pde valid_arch_state'_def pdBits_def page_directory_at'_def scBits_simps) + apply (auto simp: ARM_H.toAPIType_def objBits_simps ptBits_def pageBits_def pteBits_def pdeBits_def + makeObject_pde valid_arch_state'_def pdBits_def page_directory_at'_def) + done lemma createObjects'_irq_states' [wp]: "\valid_irq_states'\ createObjects' a b c d \\_. valid_irq_states'\" @@ -4519,6 +4497,9 @@ crunch createNewCaps crunch createObjects for ksMachine[wp]: "\s. P (ksMachineState s)" (simp: crunch_simps unless_def) +crunch createObjects + for cur_domain[wp]: "\s. P (ksCurDomain s)" + (simp: unless_def) lemma createObjects_valid_bitmaps: "createObjects' ptr n val gbits \valid_bitmaps\" @@ -4678,14 +4659,9 @@ lemma mapM_x_threadSet_valid_pspace: lemma createNewCaps_valid_pspace: assumes not_0: "n \ 0" and cover: "range_cover ptr sz (APIType_capBits ty us) n" - and tysc: "ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us" - shows - "\\s. pspace_no_overlap' ptr sz s \ valid_pspace' s - \ caps_no_overlap'' ptr sz s \ ptr \ 0 \ caps_overlap_reserved' {ptr..ptr + of_nat n * 2^(APIType_capBits ty us) - 1} s - \ ksCurDomain s \ maxDomain\ - createNewCaps ty ptr n us dev - \\r. valid_pspace'\" + shows "\\s. pspace_no_overlap' ptr sz s \ valid_pspace' s + \ caps_no_overlap'' ptr sz s \ ptr \ 0 \ caps_overlap_reserved' {ptr..ptr + of_nat n * 2^(APIType_capBits ty us) - 1} s \ ksCurDomain s \ maxDomain\ + createNewCaps ty ptr n us dev \\r. valid_pspace'\" unfolding createNewCaps_def Arch_createNewCaps_def using valid_obj_makeObject_rules apply (clarsimp simp: ARM_H.toAPIType_def @@ -4693,22 +4669,17 @@ lemma createNewCaps_valid_pspace: apply (cases ty, simp_all split del: if_split) apply (rename_tac apiobject_type) apply (case_tac apiobject_type, simp_all split del: if_split) - apply (rule hoare_pre, wp, clarsimp) - apply (insert cover tysc) - (* for TCBObject, we need to know a bit more about tcbDomain *) - apply (simp add: curDomain_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (clarsimp simp: createObjects_def) - apply (rule hoare_assume_pre) - by (wpsimp wp: createObjects_valid_pspace_untyped'[of dev us _ "Inr ty", where ptr=ptr] - mapM_x_wp' - split_del: if_split - simp: createObjects_def makeObjectKO_def objBits_def objBitsKO_def scBits_simps - not_0 APIType_capBits_def field_simps pageBits_def - archObjSize_def ptBits_def pteBits_def scBits_simps - pt_bits_def word_size_bits_def archObjSize_def ptBits_def pdBits_def - pteBits_def pdeBits_def - | simp add: power_add)+ + apply (rule hoare_pre, wp, clarsimp) + apply (insert cover) + apply (wp createObjects_valid_pspace_untyped' [OF _ not_0 , where ty="Inr ty" and sz = sz] + mapM_x_threadSet_valid_pspace mapM_x_wp' + | simp add: makeObjectKO_def archObjSize_def APIType_capBits_def + objBits_simps pageBits_def pdBits_def ptBits_def not_0 + createObjects_def curDomain_def + pteBits_def pdeBits_def + | intro conjI impI + | simp add: power_add field_simps)+ +done lemma copyGlobalMappings_inv[wp]: "\\s. P (ksMachineState s)\ @@ -4738,11 +4709,8 @@ lemma doMachineOp_mapM_x_wp: lemma createNewCaps_vms: - "\pspace_aligned' and pspace_distinct' and pspace_bounded' - and pspace_no_overlap' ptr sz and + "\pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and K (range_cover ptr sz (APIType_capBits ty us) n \ 0 < n) and - K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) and valid_machine_state'\ createNewCaps ty ptr n us dev \\archCaps. valid_machine_state'\" @@ -4762,8 +4730,9 @@ lemma createNewCaps_vms: split del: if_split | assumption)+ apply (case_tac ty) - by (auto simp: APIType_capBits_def archObjSize_def objBits_simps pageBits_def ptBits_def - pdBits_def ARM_H.toAPIType_def object_type.splits pteBits_def pdeBits_def scBits_simps) + apply (auto simp: APIType_capBits_def archObjSize_def objBits_simps pageBits_def ptBits_def + pdBits_def ARM_H.toAPIType_def object_type.splits pteBits_def pdeBits_def) + done lemma createObjects_pspace_domain_valid': "\\s. range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 @@ -4801,16 +4770,17 @@ lemma createObjects_pspace_domain_valid: apply (simp add: objBits_def) done -crunch copyGlobalMappings, doMachineOp +crunch copyGlobalMappings for pspace_domain_valid[wp]: "pspace_domain_valid" (wp: crunch_wps) +crunch doMachineOp + for pspace_domain_valid[wp]: pspace_domain_valid + lemma createNewCaps_pspace_domain_valid[wp]: "\pspace_domain_valid and K ({ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ kernel_data_refs = {} - \ range_cover ptr sz (APIType_capBits ty us) n \ 0 < n) - and K (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us)\ + \ range_cover ptr sz (APIType_capBits ty us) n \ 0 < n)\ createNewCaps ty ptr n us dev \\rv. pspace_domain_valid\" apply (simp add: createNewCaps_def) @@ -4821,8 +4791,14 @@ lemma createNewCaps_pspace_domain_valid[wp]: split del: if_split)+ apply (simp add: ARM_H.toAPIType_def split: object_type.splits) - by (auto simp: objBits_simps APIType_capBits_def pageBits_def scBits_simps - pteBits_def pdeBits_def archObjSize_def ptBits_def pdBits_def) + apply (auto simp: objBits_simps APIType_capBits_def pageBits_def + pteBits_def pdeBits_def + archObjSize_def ptBits_def pdBits_def) + done + +crunch createNewCaps + for cur_domain[wp]: "\s. P (ksCurDomain s)" + (wp: crunch_wps) (* FIXME: move *) lemma ct_idle_or_in_cur_domain'_lift_futz: @@ -4845,26 +4821,22 @@ proof - 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 (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 projectKOs st_tcb_at'_def) done qed lemma 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) \ + "\ct_idle_or_in_cur_domain' and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and ct_active' and K (range_cover ptr sz (APIType_capBits ty us) n \ 0 < n) \ createNewCaps ty ptr n us dev \\rv. ct_idle_or_in_cur_domain'\" - by (wp ct_idle_or_in_cur_domain'_lift_futz createNewCaps_obj_at'[where sz=sz] | simp)+ +apply (wp ct_idle_or_in_cur_domain'_lift_futz createNewCaps_obj_at'[where sz=sz] | simp)+ +done 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 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)\" @@ -4896,11 +4868,7 @@ lemma sch_act_wf_lift_asm_futz: done lemma 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)\ + "\(\s. sch_act_wf (ksSchedulerAction s) s) and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz 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\" apply (wp sch_act_wf_lift_asm_futz @@ -4936,45 +4904,39 @@ crunch createNewCaps (wp: mapM_x_wp' simp: crunch_simps) lemma createObjects_null_filter': - "\\s. P (null_filter' (ctes_of s)) \ makeObjectKO dev us d ty = Some val \ + "\\s. P (null_filter' (ctes_of s)) \ makeObjectKO dev ty = Some val \ range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ pspace_no_overlap' ptr sz s\ + pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createObjects' ptr n val gbits \\addrs a. P (null_filter' (ctes_of a))\" - apply (clarsimp simp: createObjects'_def split_def) - apply (wp unless_wp| wpc - | clarsimp simp: alignError_def split del: if_split simp del:fun_upd_apply)+ - apply (subst new_cap_addrs_fold') - apply (simp add:unat_1_0 unat_gt_0) - apply (rule range_cover_not_zero_shift) + apply (clarsimp simp: createObjects'_def split_def) + apply (wp unless_wp|wpc + | clarsimp simp:haskell_assert_def alignError_def + split del: if_splits simp del:fun_upd_apply)+ + apply (subst new_cap_addrs_fold') + apply (simp add:unat_1_0 unat_gt_0) + apply (rule range_cover_not_zero_shift) apply fastforce+ - apply (subst new_cap_addrs_fold') - apply (simp add:unat_1_0 unat_gt_0) - apply (rule range_cover_not_zero_shift) - apply simp - apply assumption - apply simp - apply (subst data_map_insert_def[symmetric])+ - apply (frule (3) retype_aligned_distinct'[where ko = val]) - apply (erule range_cover_rel) - apply simp+ - apply (frule (3) retype_aligned_distinct'(2)[where ko = val]) - apply (erule range_cover_rel) - apply simp+ - apply (frule (3) retype_aligned_distinct'(3)[where ko = val]) - apply (erule range_cover_rel) - apply simp+ - apply (frule null_filter_ctes_retype[where addrs = - "new_cap_addrs (unat ((of_nat n::word32) << gbits)) ptr val"]) - apply assumption+ - apply (prop_tac "objBitsKO val < word_bits") - apply (clarsimp simp: range_cover_def word_bits_def) - apply (clarsimp simp: field_simps foldr_upd_app_if[folded data_map_insert_def] shiftl_t2n - range_cover.unat_of_nat_shift)+ + apply (subst new_cap_addrs_fold') + apply (simp add:unat_1_0 unat_gt_0) + apply (rule range_cover_not_zero_shift) + apply simp + apply assumption + apply simp + apply (subst data_map_insert_def[symmetric])+ + apply (frule(2) retype_aligned_distinct'[where ko = val]) + apply (erule range_cover_rel) + apply simp+ + apply (frule(2) retype_aligned_distinct'(2)[where ko = val]) + apply (erule range_cover_rel) + apply simp+ + apply (frule null_filter_ctes_retype + [where addrs = "(new_cap_addrs (unat (((of_nat n)::word32) << gbits)) ptr val)"]) + apply assumption+ + apply (clarsimp simp:field_simps foldr_upd_app_if[folded data_map_insert_def] shiftl_t2n range_cover.unat_of_nat_shift)+ apply (rule new_cap_addrs_aligned[THEN bspec]) - apply (erule range_cover.aligned[OF range_cover_rel]) - apply simp+ - apply (clarsimp simp: range_cover_def word_bits_def) + apply (erule range_cover.aligned[OF range_cover_rel]) + apply simp+ apply (clarsimp simp:shiftl_t2n field_simps range_cover.unat_of_nat_shift) apply (drule subsetD[OF new_cap_addrs_subset,rotated]) apply (erule range_cover_rel) @@ -4987,36 +4949,36 @@ lemma createObjects_null_filter': apply (drule(1) pspace_alignedD') apply (clarsimp) apply (erule is_aligned_no_overflow) - apply (simp del: atLeastAtMost_simps - add: Int_ac ptr_add_def p_assoc_help) + apply (simp del:atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff add:Int_ac ptr_add_def p_assoc_help) apply (simp add:field_simps foldr_upd_app_if[folded data_map_insert_def] shiftl_t2n) apply auto done lemma createNewCaps_null_filter': "\(\s. P (null_filter' (ctes_of 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 pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and K (range_cover ptr sz (APIType_capBits ty us) n \ n \ 0) \ createNewCaps ty ptr n us dev \\_ s. P (null_filter' (ctes_of s))\" apply (rule hoare_gen_asm) apply (simp add: createNewCaps_def toAPIType_def Arch_createNewCaps_def - split del: if_split cong: option.case_cong) + split del: if_split cong: option.case_cong) apply (cases ty, simp_all split del: if_split) apply (rename_tac apiobject_type) apply (case_tac apiobject_type, simp_all split del: if_split) apply (rule hoare_pre, wp,simp) - by (simp add: createObjects_def makeObjectKO_def scBits_simps - APIType_capBits_def objBits_def pageBits_def - archObjSize_def ptBits_def pdBits_def curDomain_def objBits_if_dev - split del: if_split - | wp createObjects_null_filter'[where ty = "Inr ty" and sz = sz and dev=dev] - copyGlobalMappings_ctes_of threadSet_ctes_of mapM_x_wp' - | simp add: objBits_simps pteBits_def pdeBits_def - | fastforce)+ + apply (simp add: createObjects_def makeObjectKO_def + APIType_capBits_def objBits_def pageBits_def + archObjSize_def ptBits_def pdBits_def curDomain_def + objBits_if_dev + split del: if_split + | wp createObjects_null_filter'[where ty = "Inr ty" and sz = sz and dev=dev] + copyGlobalMappings_ctes_of threadSet_ctes_of mapM_x_wp' + | simp add: objBits_simps pteBits_def pdeBits_def + | fastforce)+ + done crunch createNewCaps for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" @@ -5038,9 +5000,7 @@ lemma untyped_ranges_zero_inv_null_filter_cteCaps_of: lemma createNewCaps_urz: "\untyped_ranges_zero' - 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 pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and K (range_cover ptr sz (APIType_capBits ty us) n \ n \ 0) \ createNewCaps ty ptr n us dev \\archCaps. untyped_ranges_zero'\" @@ -5052,30 +5012,42 @@ lemma createNewCaps_urz: done lemma createNewCaps_invs': - "\((\s. invs' s \ ct_active' s \ pspace_no_overlap' ptr sz s + "\(\s. invs' s \ ct_active' s \ pspace_no_overlap' ptr sz s \ caps_no_overlap'' ptr sz s \ ptr \ 0 \ {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} \ kernel_data_refs = {} \ caps_overlap_reserved' {ptr..ptr + of_nat n * 2^(APIType_capBits ty us) - 1} s \ (ty = APIObjectType ArchTypes_H.CapTableObject \ us > 0) \ gsMaxObjectSize s > 0) - and K (ty = APIObjectType ArchTypes_H.SchedContextObject \ sc_size_bounds us)) and K (range_cover ptr sz (APIType_capBits ty us) n \ n \ 0)\ createNewCaps ty ptr n us dev \\rv. invs'\" (is "\?P and K ?Q\ ?f \\rv. invs'\") proof (rule hoare_gen_asm, erule conjE) assume cover: "range_cover ptr sz (APIType_capBits ty us) n" and not_0: "n \ 0" + have cnc_ct_not_inQ: + "\ct_not_inQ and valid_pspace' and pspace_no_overlap' ptr sz\ + createNewCaps ty ptr n us dev \\_. ct_not_inQ\" + unfolding ct_not_inQ_def + apply (rule_tac P'="\s. ksSchedulerAction s = ResumeCurrentThread + \ (obj_at' (Not \ tcbQueued) (ksCurThread s) s + \ valid_pspace' s \ pspace_no_overlap' ptr sz s)" + in hoare_pre_imp, clarsimp) + apply (rule hoare_convert_imp [OF createNewCaps_nosch]) + apply (rule hoare_weaken_pre) + apply (wps createNewCaps_ct) + apply (wp createNewCaps_obj_at') + using cover not_0 + apply (fastforce simp: valid_pspace'_def) + done show "\?P\ createNewCaps ty ptr n us dev \\rv. invs'\" - apply (rule hoare_gen_asm) - apply (simp add: invs'_def valid_dom_schedule'_def + apply (simp add: invs'_def valid_state'_def pointerInUserData_def typ_at'_def) apply (rule hoare_pre) apply (wp createNewCaps_valid_pspace [OF not_0 cover] - createNewCaps_state_refs_of' [OF cover not_0] - createNewCaps_list_refs_of_replies' [OF cover not_0] - createNewCaps_iflive' [OF cover not_0] + createNewCaps_state_refs_of' [OF cover not_0 ] + createNewCaps_iflive' [OF cover not_0 ] irqs_masked_lift createNewCaps_ifunsafe' createNewCaps_cur [OF cover not_0] @@ -5101,7 +5073,7 @@ qed lemma createObjects_pred_tcb_at': "\pred_tcb_at' proj P t and K (range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0) - and pspace_aligned' and pspace_distinct' and pspace_bounded' and pspace_no_overlap' ptr sz\ + and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz\ createObjects ptr n val gbits \\rv. pred_tcb_at' proj P t\" apply (simp add: pred_tcb_at'_def createObjects_def) apply (wp createObjects_orig_obj_at') @@ -5110,7 +5082,7 @@ lemma createObjects_pred_tcb_at': lemma createObjects_ex_cte_cap_to [wp]: "\\s. range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 \ pspace_aligned' s \ - pspace_distinct' s \ pspace_bounded' s \ ex_cte_cap_to' p s \ pspace_no_overlap' ptr sz s\ + pspace_distinct' s \ ex_cte_cap_to' p s \ pspace_no_overlap' ptr sz s\ createObjects ptr n val gbits \\r. ex_cte_cap_to' p\" apply (simp add: ex_cte_cap_to'_def createObjects_def) apply (rule hoare_lift_Pf2 [where f="irq_node'"]) @@ -5121,14 +5093,13 @@ lemma createObjects_ex_cte_cap_to [wp]: lemma createObjects_orig_obj_at3: "\\s. obj_at' P p s \ range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 \ - pspace_aligned' s \ pspace_bounded' s \ + pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createObjects ptr n val gbits \\r. obj_at' P p\" by (wp createObjects_orig_obj_at'[where sz = sz] | simp add: createObjects_def)+ 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 + "\(\s. sch_act_wf (ksSchedulerAction s) s) and pspace_aligned' and pspace_distinct' 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\" @@ -5161,7 +5132,7 @@ lemma createObjects_no_cte_ifunsafe': lemma createObjects_no_cte_valid_global: assumes no_cte: "\c. projectKO_opt val \ Some (c::cte)" assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" - shows "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + shows "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 \ valid_global_refs' s\ @@ -5189,7 +5160,7 @@ lemma createObjects'_typ_at: "\\s. n \ 0 \ range_cover ptr sz (objBitsKO val + gbits) n \ typ_at' T p s \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createObjects' ptr n val gbits \\r s. typ_at' T p s\" apply (rule hoare_grab_asm)+ @@ -5229,7 +5200,7 @@ lemma createObjects'_typ_at: done lemma createObjects_valid_arch: - "\\s. valid_arch_state' s \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + "\\s. valid_arch_state' s \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 \ createObjects ptr n val gbits \\rv s. valid_arch_state' s\" @@ -5246,7 +5217,7 @@ lemma createObjects_valid_arch: done lemma createObjects_irq_state: - "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 \ valid_irq_node' (irq_node' s) s\ @@ -5260,7 +5231,7 @@ lemma createObjects_no_cte_irq_handlers: assumes no_cte: "\c. projectKO_opt val \ Some (c::cte)" assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" shows - "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ range_cover ptr sz (objBitsKO val + gbits) n \ n \ 0 \ valid_irq_handlers' s\ @@ -5274,7 +5245,7 @@ lemma createObjects_no_cte_irq_handlers: done lemma createObjects_cur': - "\\s. pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + "\\s. pspace_aligned' s \ pspace_distinct' 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 @@ -5288,7 +5259,7 @@ lemma createObjects_cur': lemma createObjects_vms'[wp]: "\(\_. (range_cover ptr sz (objBitsKO val + gbits) n \ 0 < n)) and pspace_aligned' and - pspace_distinct' and pspace_bounded' and pspace_no_overlap' ptr sz and valid_machine_state'\ + pspace_distinct' and pspace_no_overlap' ptr sz and valid_machine_state'\ createObjects ptr n val gbits \\rv. valid_machine_state'\" apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def @@ -5304,10 +5275,10 @@ lemma createObjects_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 +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 @@ -5318,8 +5289,12 @@ lemma untyped_zero_ranges_cte_def: apply (safe, metis+) done +crunch createObjects + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (simp: unless_def) + lemma createObjects_untyped_ranges_zero': - assumes moKO: "makeObjectKO dev us d ty = Some val" + assumes moKO: "makeObjectKO dev ty = Some val" shows "\ct_active' and valid_pspace' and pspace_no_overlap' ptr sz and untyped_ranges_zero' @@ -5345,13 +5320,9 @@ lemma createObjects_untyped_ranges_zero': done lemma createObjects_no_cte_invs: - assumes moKO: "makeObjectKO dev us d ty = Some val" + assumes moKO: "makeObjectKO dev ty = Some val" assumes no_cte: "\c. projectKO_opt val \ Some (c::cte)" assumes no_tcb: "\t. projectKO_opt val \ Some (t::tcb)" - and tysc: "ty = Inr (APIObjectType SchedContextObject) \ sc_size_bounds us" - and mdom: "ty = - Inr (APIObjectType ArchTypes_H.apiobject_type.TCBObject) \ - d \ maxDomain" shows "\\s. range_cover ptr sz ((objBitsKO val) + gbits) n \ n \ 0 \ invs' s \ ct_active' s \ pspace_no_overlap' ptr sz s \ ptr \ 0 @@ -5359,8 +5330,6 @@ lemma createObjects_no_cte_invs: \ caps_overlap_reserved' {ptr..ptr + of_nat (n * 2 ^ gbits * 2 ^ objBitsKO val) - 1} s \ caps_no_overlap'' ptr sz s \ refs_of' val = {} \ \ live' val - \ (case val of KOReply r \ replyNext_of r = None \ replyPrev r = None - | _ \ True) \ (\pde. projectKO_opt val = Some pde \ pde = InvalidPDE)\ createObjects ptr n val gbits \\rv. invs'\" @@ -5381,90 +5350,159 @@ proof - apply (simp)+ done show ?thesis - apply (rule hoare_grab_asm)+ - apply (clarsimp simp: invs'_def valid_dom_schedule'_def) - apply (rule hoare_pre) - apply (rule hoare_vcg_conj_lift) - apply (simp add: createObjects_def,wp createObjects_valid_pspace_untyped') - apply (wp assms | simp add: objBits_def)+ - apply (wp createObjects_sch createObjects_queues) - apply (rule hoare_vcg_conj_lift) - apply (simp add: createObjects_def) - apply (wp createObjects_state_refs_of'') - apply (wpsimp wp: createObjects_list_refs_of_replies'') - 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_valid_arch createObjects_irq_state - createObjects_no_cte_irq_handlers createObjects_cur' - createObjects_queues' [OF no_tcb] - createObjects_release_queue' [OF no_tcb] - createObjects_release_queue - 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_valid_arch createObjects_irq_state - createObjects_no_cte_irq_handlers createObjects_cur' - createObjects_queues' [OF no_tcb] assms - createObjects_release_queue' [OF no_tcb] - createObjects_release_queue - createObjects_pspace_domain_valid co_ct_not_inQ - createObjects_ct_idle_or_in_cur_domain' - createObjects_untyped_ranges_zero'[OF moKO] - | simp)+ - apply clarsimp - apply ((intro conjI; assumption?); simp add: valid_pspace'_def objBits_def) - done + apply (rule hoare_grab_asm)+ + apply (clarsimp simp: invs'_def valid_state'_def) + apply wp + apply (rule hoare_pre) + apply (rule hoare_vcg_conj_lift) + apply (simp add: createObjects_def,wp createObjects_valid_pspace_untyped') + apply (wp assms | simp add: objBits_def)+ + apply (wp createObjects_sch) + apply (rule hoare_vcg_conj_lift) + apply (simp add: createObjects_def) + apply (wp createObjects_state_refs_of'') + 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_valid_arch createObjects_irq_state + createObjects_no_cte_irq_handlers createObjects_cur' + assms | simp add: objBits_def)+ + apply (rule hoare_vcg_conj_lift) + apply (simp add: createObjects_def) + apply (wp createObjects_idle') + apply (wp createObjects_no_cte_ifunsafe' irqs_masked_lift + createObjects_idle' createObjects_no_cte_valid_global + createObjects_valid_arch createObjects_irq_state + createObjects_no_cte_irq_handlers createObjects_cur' + assms + createObjects_pspace_domain_valid co_ct_not_inQ + createObjects_ct_idle_or_in_cur_domain' + createObjects_untyped_ranges_zero'[OF moKO] + | simp)+ + apply (rule hoare_vcg_conj_lift) + apply (simp add: createObjects_def) + apply (wpsimp wp: createObjects_sched_queues) + 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 (wpsimp wp: createObjects_valid_bitmaps) + apply (wp createObjects_no_cte_ifunsafe' irqs_masked_lift + createObjects_idle' createObjects_no_cte_valid_global + createObjects_valid_arch createObjects_irq_state + createObjects_no_cte_irq_handlers createObjects_cur' + assms + createObjects_pspace_domain_valid co_ct_not_inQ + createObjects_ct_idle_or_in_cur_domain' + createObjects_untyped_ranges_zero'[OF moKO] + | simp)+ + apply clarsimp + apply ((intro conjI; assumption?); simp add: valid_pspace'_def objBits_def) + apply (fastforce simp add: no_cte no_tcb split_def split: option.splits) + apply (auto simp: invs'_def no_tcb valid_state'_def no_cte + split: option.splits kernel_object.splits) + done qed lemma corres_retype_update_gsI: assumes not_zero: "n \ 0" and aligned: "is_aligned ptr (objBitsKO ko + gbits)" - and obj_bits_api: "obj_bits_api (APIType_map2 ty) us = objBitsKO ko + gbits" - and check: "sz < obj_bits_api (APIType_map2 ty) us \ sz < objBitsKO ko + gbits" - and ko: "makeObjectKO dev us d ty = Some ko" - and tysc: "ty = Inr (APIObjectType SchedContextObject) \ min_sched_context_bits \ us" + and obj_bits_api: "obj_bits_api (APIType_map2 ty) us = + objBitsKO ko + gbits" + and check: "sz < obj_bits_api (APIType_map2 ty) us \ + sz < objBitsKO ko + gbits" + and usv: "APIType_map2 ty = Structures_A.CapTableObject \ 0 < us" + and ko: "makeObjectKO dev ty = Some ko" and orr: "obj_bits_api (APIType_map2 ty) us \ sz \ - obj_relation_retype (default_object (APIType_map2 ty) dev us d) ko" + obj_relation_retype + (default_object (APIType_map2 ty) dev us) ko" and cover: "range_cover ptr sz (obj_bits_api (APIType_map2 ty) us) n" and f: "f = update_gs (APIType_map2 ty) us" shows "corres (\rv rv'. rv' = g rv) (\s. valid_pspace s \ pspace_no_overlap_range_cover ptr sz s - \ valid_mdb s \ valid_list s) + \ valid_mdb s \ valid_etcbs s \ valid_list s) (\s. pspace_aligned' s \ pspace_distinct' s \ - pspace_no_overlap' ptr sz s \ - (ty = Inr (APIObjectType TCBObject) \ d = ksCurDomain s)) - (retype_region ptr n us (APIType_map2 ty) dev) + pspace_no_overlap' ptr sz s) + (retype_region2 ptr n us (APIType_map2 ty) dev) (do addrs \ createObjects ptr n ko gbits; _ \ modify (f (set addrs)); return (g addrs) od)" - using corres_retype' [OF not_zero aligned obj_bits_api check ko tysc orr cover] - by (clarsimp simp: f) + using corres_retype' [OF not_zero aligned obj_bits_api check usv ko orr cover] + by (simp add: f) lemma gcd_corres: "corres (=) \ \ (gets cur_domain) curDomain" by (simp add: curDomain_def state_relation_def) -lemma createObjects_tcb_at': +lemma retype_region2_extra_ext_mapM_x_corres: + shows "corres dc + (valid_etcbs and (\s. \addr\set addrs. tcb_at addr s)) + (\s. \addr\set addrs. obj_at' (Not \ tcbQueued) addr s) + (retype_region2_extra_ext addrs Structures_A.apiobject_type.TCBObject) + (mapM_x (\addr. do cdom \ curDomain; + threadSet (tcbDomain_update (\_. cdom)) addr + od) + addrs)" + apply (rule corres_guard_imp) + apply (simp add: retype_region2_extra_ext_def curDomain_mapM_x_futz[symmetric] when_def) + apply (rule corres_split_eqr[OF gcd_corres]) + apply (rule_tac S="Id \ {(x, y). x \ set addrs}" + and P="\s. (\t \ set addrs. tcb_at t s) \ valid_etcbs s" + and P'="\s. \t \ set addrs. obj_at' (Not \ tcbQueued) t s" + in corres_mapM_x) + apply simp + apply (rule corres_guard_imp) + apply (rule ethread_set_corres, simp_all add: etcb_relation_def non_exst_same_def)[1] + apply (case_tac tcb') + apply simp + apply fastforce + apply (fastforce simp: obj_at'_def) + apply (wp hoare_vcg_ball_lift | simp)+ + apply (clarsimp simp: obj_at'_def) + apply fastforce + apply auto[1] + apply (wp | simp add: curDomain_def)+ + done + +lemma retype_region2_extra_ext_trivial: + "ty \ APIType_map2 (Inr (APIObjectType apiobject_type.TCBObject)) + \ retype_region2_extra_ext ptrs ty = return ()" +by (simp add: retype_region2_extra_ext_def when_def APIType_map2_def) + +lemma retype_region2_ext_retype_region_ArchObject_PageDirectoryObj: + "retype_region ptr n us (APIType_map2 (Inr PageDirectoryObject)) dev = + (retype_region2 ptr n us (APIType_map2 (Inr PageDirectoryObject)) dev :: obj_ref list det_ext_monad)" +by (simp add: retype_region2_ext_retype_region retype_region2_extra_ext_def when_def APIType_map2_def) + +lemma retype_region2_valid_etcbs[wp]:"\valid_etcbs\ retype_region2 a b c d dev \\_. valid_etcbs\" + apply (simp add: retype_region2_def) + apply (simp add: retype_region2_ext_def bind_assoc) + apply wp + apply (clarsimp simp del: fun_upd_apply) + apply (blast intro: valid_etcb_fold_update) + done + +lemma retype_region2_obj_at: + assumes tytcb: "ty = Structures_A.apiobject_type.TCBObject" + shows "\\\ retype_region2 ptr n us ty dev \\rv s. \x \ set rv. tcb_at x s\" + using tytcb unfolding retype_region2_def + apply (simp only: return_bind bind_return foldr_upd_app_if fun_app_def K_bind_def) + apply (wp dxo_wp_weak | simp)+ + apply (auto simp: obj_at_def default_object_def is_tcb_def) + done + +lemma createObjects_Not_tcbQueued: "\range_cover ptr sz (objBitsKO (injectKOS (makeObject::tcb))) n; n \ 0\ \ - \\s. pspace_no_overlap' ptr sz s \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s\ - createObjects ptr n (KOTCB makeObject) 0 \\ptrs s. \addr\set ptrs. tcb_at' addr s\" + \\s. pspace_no_overlap' ptr sz s \ pspace_aligned' s \ pspace_distinct' s\ + createObjects ptr n (KOTCB makeObject) 0 + \\ptrs s. \addr\set ptrs. obj_at' (Not \ tcbQueued) addr s\" apply (rule hoare_strengthen_post[OF createObjects_ko_at_strg[where val = "(makeObject :: tcb)"]]) apply (auto simp: obj_at'_def projectKOs project_inject objBitsKO_def objBits_def makeObject_tcb) done -lemma init_arch_objects_APIType_map2_noop: - "tp \ Inr PageDirectoryObject - \ init_arch_objects (APIType_map2 tp) ptr n m addrs - = return ()" - apply (simp add: init_arch_objects_def APIType_map2_def) - apply (cases tp, simp_all split: kernel_object.split arch_kernel_object.split - object_type.split apiobject_type.split) - done - lemma data_page_relation_retype: "obj_relation_retype (ArchObj (DataPage False pgsz)) KOUserData" "obj_relation_retype (ArchObj (DataPage True pgsz)) KOUserDataDevice" @@ -5474,30 +5512,43 @@ lemma data_page_relation_retype: apply (clarsimp simp: image_def)+ done +lemma regroup_createObjects_dmo_userPages: + "(do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return (f addrs) + od) = (do + (addrs, faddrs) <- (do + addrs <- createObjects y n ko sz; + _ <- modify (\ks. ks\gsUserPages := g ks addrs\); + return (addrs, f addrs) + od); + _ <- when P (mapM_x (\addr. doMachineOp (m addr)) addrs); + return faddrs + od)" + by (simp add: bind_assoc) + lemma corres_retype_region_createNewCaps: "corres ((\r r'. length r = length r' \ list_all2 cap_relation r r') \ map (\ref. default_cap (APIType_map2 (Inr ty)) ref us dev)) - (\s. valid_pspace s \ valid_mdb s \ valid_list s \ valid_arch_state s + (\s. valid_pspace s \ valid_mdb s \ valid_etcbs s \ valid_list s \ valid_arch_state s \ caps_no_overlap y sz s \ pspace_no_overlap_range_cover y sz s \ caps_overlap_reserved {y..y + of_nat n * 2 ^ (obj_bits_api (APIType_map2 (Inr ty)) us) - 1} s \ (\slot. cte_wp_at (\c. up_aligned_area y sz \ cap_range c \ cap_is_device c = dev) slot s) - \ (APIType_map2 (Inr ty) = Structures_A.CapTableObject \ 0 < us) - \ (APIType_map2 (Inr ty) = Structures_A.SchedContextObject - \ sc_size_bounds us)) + \ (APIType_map2 (Inr ty) = Structures_A.CapTableObject \ 0 < us)) (\s. pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' y sz s \ valid_pspace' s \ valid_arch_state' s \ range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n\ 0) (do x \ retype_region y n us (APIType_map2 (Inr ty)) dev :: obj_ref list det_ext_monad; - init_arch_objects (APIType_map2 (Inr ty)) y n us x; + init_arch_objects (APIType_map2 (Inr ty)) dev y n us x; return x od) (createNewCaps ty y n us dev)" apply (rule_tac F="range_cover y sz (obj_bits_api (APIType_map2 (Inr ty)) us) n \ n \ 0 \ (APIType_map2 (Inr ty) = Structures_A.CapTableObject - \ 0 < us) - \ (APIType_map2 (Inr ty) = Structures_A.SchedContextObject - \ sc_size_bounds us)" + \ 0 < us)" in corres_req, simp) apply (clarsimp simp add: createNewCaps_def toAPIType_def split del: if_split cong: if_cong) @@ -5506,173 +5557,228 @@ lemma corres_retype_region_createNewCaps: split del: if_split) apply (rename_tac apiobject_type) apply (case_tac apiobject_type, simp_all split del: if_split) - \ \Untyped\ - apply (simp add: retype_region_def obj_bits_api_def - APIType_map2_def - split del: if_split - cong: if_cong) - apply (subst upto_enum_red') - apply (drule range_cover_not_zero[rotated]) + \ \Untyped\ + apply (simp add: retype_region_def obj_bits_api_def + APIType_map2_def + split del: if_split + cong: if_cong) + apply (subst upto_enum_red') + apply (drule range_cover_not_zero[rotated]) + apply simp + apply unat_arith + apply (clarsimp simp: list_all2_same enum_word_def range_cover.unat_of_nat_n + list_all2_map1 list_all2_map2 + ptr_add_def fromIntegral_def toInteger_nat fromInteger_nat) + apply (subst unat_of_nat_minus_1) + apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing]) apply simp - apply unat_arith - apply (clarsimp simp: list_all2_same enum_word_def range_cover.unat_of_nat_n - list_all2_map1 list_all2_map2 - ptr_add_def fromIntegral_def toInteger_nat fromInteger_nat) - apply (subst unat_of_nat_minus_1) - apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing]) - apply simp - apply (clarsimp simp: range_cover_def) - apply (arith+)[4] - \ \TCB\ - apply (simp_all add: curDomain_def split del: if_split) - apply (rule corres_underlying_gets_pre_rhs[rotated]) - apply (rule gets_sp) - apply (rule corres_guard_imp) - apply (rule corres_bind_return) - apply (rule corres_split_eqr) - apply (rule corres_retype[where 'a = tcb], - simp_all add: obj_bits_api_def objBits_simps' pageBits_def - APIType_map2_def makeObjectKO_def)[1] - apply (fastforce simp: range_cover_def) - apply (simp add: other_objs_default_relation) - apply (rule corres_returnTT, simp) + apply (clarsimp simp: range_cover_def) + apply (arith+)[4] + \ \TCB, EP, NTFN\ + apply (simp_all add: retype_region2_ext_retype_region bind_cong[OF curDomain_mapM_x_futz refl, unfolded bind_assoc] + split del: if_split)[9] (* not PageDirectoryObject *) + apply (rule corres_guard_imp) + apply (rule corres_split_eqr) + apply (rule corres_retype[where 'a = tcb], + simp_all add: obj_bits_api_def objBits_simps' pageBits_def + APIType_map2_def makeObjectKO_def + tcb_relation_retype)[1] + apply (fastforce simp: range_cover_def) + apply (rule corres_split_nor) + apply (simp add: APIType_map2_def) + apply (rule retype_region2_extra_ext_mapM_x_corres) + apply (rule corres_trivial, simp) apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 - objBits_simps APIType_map2_def) - apply ((wp | simp add: APIType_map2_def)+)[1] - apply ((wp createObjects_tcb_at'[where sz=sz] | simp add: APIType_map2_def objBits_simps' obj_bits_api_def)+)[1] - apply simp - apply simp - \ \CapTable\ - apply (find_goal \match premises in "_ = ArchTypes_H.apiobject_type.CapTableObject" \ \-\\) - apply (subst bind_assoc_return_reverse[of "createObjects y n (KOCTE makeObject) us"]) - apply (subst liftM_def [of "map (\addr. capability.CNodeCap addr us 0 0)", symmetric]) + objBits_simps APIType_map2_def) + apply wp + apply wp + apply ((wp retype_region2_obj_at | simp add: APIType_map2_def)+)[1] + apply ((wp createObjects_Not_tcbQueued[where sz=sz] | simp add: APIType_map2_def objBits_simps' obj_bits_api_def)+)[1] apply simp - apply (rule corres_rel_imp) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: obj_bits_api_def objBits_simps' pageBits_def - APIType_map2_def makeObjectKO_def slot_bits_def - field_simps ext)[1] - apply ((clarsimp simp : range_cover_def APIType_map2_def word_bits_def - list_all2_same list_all2_map1 list_all2_map2 - | rule captable_relation_retype)+)[5] - \ \EP, 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 = endpoint], - simp_all add: obj_bits_api_def objBits_simps' pageBits_def - APIType_map2_def makeObjectKO_def - other_objs_default_relation)[1] - apply ((simp add: range_cover_def APIType_map2_def - list_all2_same list_all2_map1 list_all2_map2)+)[4] + apply simp + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) 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], + 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] - apply ((simp add: range_cover_def APIType_map2_def - list_all2_same list_all2_map1 list_all2_map2)+)[4] - \ \SchedContext\ + apply (fastforce simp: range_cover_def) + apply simp + apply simp + apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 + objBits_simps APIType_map2_def) + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) 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 = sched_context], + apply (rule corres_retype[where 'a = notification], simp_all add: obj_bits_api_def objBits_simps' pageBits_def - APIType_map2_def makeObjectKO_def scBits_simps - sc_relation_retype)[1] - apply ((simp add: range_cover_def APIType_map2_def sc_size_bounds_def - list_all2_same list_all2_map1 list_all2_map2 sc_const_eq)+)[4] - \ \Reply\ - apply (simp add: liftM_def[symmetric] split del: if_split) + APIType_map2_def makeObjectKO_def + other_objs_default_relation)[1] + apply (fastforce simp: range_cover_def) + apply simp + apply simp + apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 + objBits_simps APIType_map2_def) + \ \CapTable\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (subst bind_assoc_return_reverse[of "createObjects y n (KOCTE makeObject) us"]) + apply (subst liftM_def + [of "map (\addr. capability.CNodeCap addr us 0 0)", symmetric]) + apply simp apply (rule corres_rel_imp) apply (rule corres_guard_imp) - apply (rule corres_retype[where 'a = reply], - simp_all add: obj_bits_api_def objBits_simps' pageBits_def - APIType_map2_def makeObjectKO_def - reply_relation_retype)[1] - apply ((simp add: range_cover_def APIType_map2_def - list_all2_same list_all2_map1 list_all2_map2)+)[4] + apply (rule corres_retype_update_gsI, + simp_all add: obj_bits_api_def objBits_simps' pageBits_def + APIType_map2_def makeObjectKO_def slot_bits_def + field_simps ext)[1] + apply (simp add: range_cover_def) + apply (rule captable_relation_retype,simp add: range_cover_def word_bits_def) + apply simp + apply simp + apply (clarsimp simp: list_all2_same list_all2_map1 list_all2_map2 + objBits_simps allRights_def APIType_map2_def + split del: if_split) \ \SmallPageObject\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) - \ \LargePageObject\ - apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] + \ \LargePageObject\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] \ \SectionObject\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] \ \SuperSectionObject\ + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) apply (simp add: corres_liftM2_simp[unfolded liftM_def] split del: if_split) - apply (rule corres_rel_imp) - apply (simp add: init_arch_objects_APIType_map2_noop split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_retype_update_gsI, - simp_all add: APIType_map2_def makeObjectKO_def - arch_default_cap_def obj_bits_api_def - default_object_def default_arch_object_def pageBits_def - ext objBits_simps range_cover.aligned, - simp_all add: data_page_relation_retype)[1] - apply simp+ - apply (simp add: APIType_map2_def arch_default_cap_def vmrights_map_def - vm_read_write_def list_all2_map1 list_all2_map2 list_all2_same) + apply (simp add: init_arch_objects_def split del: if_split) + apply (subst regroup_createObjects_dmo_userPages) + apply (rule corres_guard_imp) + apply (rule corres_split) + apply (rule corres_retype_update_gsI, + simp_all add: APIType_map2_def makeObjectKO_def + arch_default_cap_def obj_bits_api_def3 + default_object_def default_arch_object_def pageBits_def + ext objBits_simps range_cover.aligned, + simp_all add: data_page_relation_retype)[1] + apply (simp add: APIType_map2_def vs_apiobj_size_def + flip: when_def split del: if_split cong: if_cong) + apply (rule corres_split) + apply corres + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: APIType_map2_def arch_default_cap_def vm_read_write_def vmrights_map_def + list_all2_map1 list_all2_map2 list_all2_same) + apply ((wpsimp split_del: if_split)+)[6] \ \PageTable\ - apply (simp_all add: corres_liftM2_simp[unfolded liftM_def]) + apply (subst retype_region2_extra_ext_trivial) + apply (simp add: APIType_map2_def) + apply (simp add: corres_liftM2_simp[unfolded liftM_def]) + apply (simp add: init_arch_objects_def bind_assoc split del: if_split) apply (rule corres_guard_imp) - apply (simp add: init_arch_objects_APIType_map2_noop) - apply (rule corres_rel_imp) - apply (rule corres_retype[where 'a =pte], - simp_all add: APIType_map2_def obj_bits_api_def - default_arch_object_def objBits_simps - archObjSize_def ptBits_def pageBits_def - pteBits_def pdeBits_def - makeObjectKO_def range_cover.aligned)[1] - apply (rule pagetable_relation_retype) - apply (wp | simp)+ - apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same - - APIType_map2_def arch_default_cap_def) - apply simp+ + apply (rule corres_split) + apply (rule corres_retype[where 'a =pte], + simp_all add: APIType_map2_def obj_bits_api_def + default_arch_object_def objBits_simps + archObjSize_def ptBits_def pteBits_def + makeObjectKO_def range_cover.aligned)[1] + apply (rule pagetable_relation_retype) + apply (clarsimp simp: APIType_map2_def vs_apiobj_size_def + pt_bits_def ptBits_def pageBits_def pteBits_def) + apply (rule corres_split) + apply (rule corres_mapM_x', clarsimp) + apply (corres corres: corres_machine_op) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply corres + apply (clarsimp simp: list_all2_map1 list_all2_map2 list_all2_same + APIType_map2_def arch_default_cap_def) + apply ((wpsimp split_del: if_split)+)[6] \ \PageDirectory\ + apply (simp add: bind_assoc) apply (rule corres_guard_imp) apply (rule corres_split_eqr) apply (rule corres_retype[where ty = "Inr PageDirectoryObject" and 'a = pde - , simplified], + , simplified, folded retype_region2_ext_retype_region_ArchObject_PageDirectoryObj], simp_all add: APIType_map2_def obj_bits_api_def default_arch_object_def objBits_simps archObjSize_def pdBits_def pageBits_def @@ -5680,87 +5786,71 @@ lemma corres_retype_region_createNewCaps: makeObjectKO_def)[1] apply (simp add: range_cover_def)+ apply (rule pagedirectory_relation_retype) - apply (simp add: init_arch_objects_def APIType_map2_def - bind_assoc) - apply (rule corres_split_nor) - apply (simp add: mapM_x_mapM) - apply (rule corres_underlying_split[where r' = dc]) - apply (rule_tac Q="\xs s. (\x \ set xs. page_directory_at x s) - \ valid_arch_state s \ pspace_aligned s" - and Q'="\xs s. (\x \ set xs. page_directory_at' x s) \ valid_arch_state' s" - in corres_mapM_list_all2[where r'=dc and S="(=)"]) - apply simp+ - apply (rule corres_guard_imp, rule copyGlobalMappings_corres) - apply simp+ - apply (wp hoare_vcg_const_Ball_lift | simp)+ - apply (simp add: list_all2_same) - apply (rule corres_return[where P =\ and P'=\,THEN iffD2]) - apply simp - apply wp+ - apply (simp add: liftM_def[symmetric] o_def list_all2_map1 - list_all2_map2 list_all2_same - arch_default_cap_def mapM_x_mapM) - apply (simp add: dc_def[symmetric]) - apply (rule corres_machine_op) - apply (rule corres_Id) - apply (simp add: shiftl_t2n shiftL_nat - pdBits_def ptBits_def pageBits_def pt_bits_def) - defer - apply simp - apply (simp add: mapM_discarded[where g = "return ()",simplified,symmetric]) - apply (rule no_fail_pre) - apply (wp no_fail_mapM|clarsimp)+ + apply (rename_tac pds) + apply (simp add: init_arch_objects_def bind_assoc APIType_map2_def + vs_apiobj_size_def pdBits_eq + split del: if_split) + apply (rule corres_split) + apply (rule_tac P="valid_arch_state and valid_etcbs and pspace_aligned and + (\s. \pd \ set pds. typ_at (AArch APageDirectory) pd s)" and + P'="valid_arch_state' and (\s. \pd \ set pds. page_directory_at' pd s)" + in corres_mapM_x') + apply (clarsimp, rule corres_guard_imp, rule copyGlobalMappings_corres; simp) + apply (wpsimp wp: hoare_vcg_op_lift)+ + apply (rule corres_split, rule corres_mapM_x', rule corres_machine_op) + apply (clarsimp cong: corres_weak_cong) + apply (rule corres_underlying_trivial_dc) + apply wp+ + apply (rule refl) + apply (rule corres_returnTT) + apply (simp add: list_all2_map1 list_all2_map2 list_all2_same arch_default_cap_def) + apply (wpsimp wp: retype_region_valid_arch retype_region_aligned)+ + apply (rule hoare_post_imp) + prefer 2 apply (rule hoare_vcg_conj_lift) - apply (rule hoare_post_imp) - prefer 2 - apply (rule hoare_vcg_conj_lift) - apply (rule retype_region_obj_at) - apply (simp add: APIType_map2_def) - apply (subst APIType_map2_def, simp) - apply (rule retype_region_ret) - apply (clarsimp simp: retype_addrs_def obj_bits_api_def APIType_map2_def - default_arch_object_def default_object_def) - apply (clarsimp simp: obj_at_def a_type_def) - apply (wp retype_region_valid_arch retype_region_aligned|simp)+ - apply (clarsimp simp: objBits_simps retype_addrs_def obj_bits_api_def - APIType_map2_def default_arch_object_def default_object_def) + apply (rule retype_region_obj_at) + apply (simp add: APIType_map2_def) + apply (simp add: APIType_map2_def) + apply (rule retype_region_ret) + apply (clarsimp simp: retype_addrs_def obj_bits_api_def APIType_map2_def + default_arch_object_def default_object_def obj_at_def a_type_def) + apply (wpsimp wp: createObjects_valid_arch) + apply (rule hoare_post_imp) + prefer 2 apply (rule hoare_vcg_conj_lift) - apply (rule hoare_post_imp) - prefer 2 - apply (rule hoare_vcg_conj_lift) - apply (rule createObjects_ko_at[where sz = sz and 'a = pde]) - apply (simp add: objBits_simps archObjSize_def pdBits_def - pteBits_def pdeBits_def - pageBits_def page_directory_at'_def)+ - apply (simp add: projectKOs) - apply (rule createObjects_aligned) - apply (simp add: objBits_simps archObjSize_def pdBits_def - pageBits_def page_directory_at'_def)+ - apply (simp add: range_cover_def pteBits_def pdeBits_def) - apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing]) - apply simp - apply (clarsimp simp: range_cover_def word_bits_def) - apply arith+ - apply (simp add: objBits_simps archObjSize_def pdBits_def - pageBits_def page_directory_at'_def)+ - apply (simp add: range_cover_def word_bits_def pteBits_def pdeBits_def) - apply clarsimp - apply (drule (1) bspec)+ - apply (simp add: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def - ptBits_def APIType_map2_def default_arch_object_def default_object_def - archObjSize_def) - apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def - pageBits_def page_directory_at'_def - pteBits_def pdeBits_def) - apply (drule_tac x = ya in spec) - apply (clarsimp simp:typ_at'_def obj_at'_real_def) - apply (erule ko_wp_at'_weakenE) - apply (clarsimp simp: projectKOs) - apply (wp createObjects_valid_arch) - apply (auto simp: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def ptBits_def - APIType_map2_def default_arch_object_def default_object_def archObjSize_def - pteBits_def pdeBits_def - pd_bits_def fromIntegral_def toInteger_nat fromInteger_nat) + apply (rule createObjects_ko_at[where sz = sz and 'a = pde]) + apply (simp add: objBits_simps archObjSize_def pdBits_def + pteBits_def pdeBits_def APIType_map2_def + obj_bits_api_def default_arch_object_def projectKOs + pageBits_def page_directory_at'_def)+ + apply (rule createObjects_aligned) + apply (simp add: objBits_simps archObjSize_def pdBits_def + pageBits_def page_directory_at'_def)+ + apply (simp add: range_cover_def pteBits_def pdeBits_def) + apply (rule le_less_trans[OF range_cover.range_cover_n_le(2) power_strict_increasing]) + apply simp + apply (clarsimp simp: range_cover_def word_bits_def) + apply arith+ + apply (simp add: objBits_simps archObjSize_def pdBits_def + pageBits_def page_directory_at'_def)+ + apply (simp add: word_bits_def pteBits_def pdeBits_def) + apply clarsimp + apply (drule (1) bspec)+ + apply (simp add: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def + ptBits_def APIType_map2_def default_arch_object_def default_object_def + archObjSize_def) + apply (clarsimp simp: objBits_simps archObjSize_def pdBits_def + pageBits_def page_directory_at'_def + pteBits_def pdeBits_def) + apply (rename_tac offset) + apply (drule_tac x = offset in spec) + apply (clarsimp simp:typ_at'_def obj_at'_real_def) + apply (erule ko_wp_at'_weakenE) + apply (clarsimp simp: projectKOs) + apply (auto simp: objBits_simps retype_addrs_def obj_bits_api_def pdBits_def pageBits_def + APIType_map2_def default_arch_object_def default_object_def archObjSize_def + pteBits_def pdeBits_def ptBits_def + pd_bits_def fromIntegral_def toInteger_nat fromInteger_nat) done end diff --git a/proof/refine/ARM/SchedContextInv_R.thy b/proof/refine/ARM/SchedContextInv_R.thy deleted file mode 100644 index 4fb2d8cd92..0000000000 --- a/proof/refine/ARM/SchedContextInv_R.thy +++ /dev/null @@ -1,1616 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory SchedContextInv_R -imports Invocations_R Tcb_R -begin - -global_interpretation schedContextCompleteYieldTo: typ_at_all_props' "schedContextCompleteYieldTo scp" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) - -primrec valid_sc_inv' :: "sched_context_invocation \ kernel_state \ bool" where - "valid_sc_inv' (InvokeSchedContextConsumed scptr args) = - (sc_at' scptr and ex_nonz_cap_to' scptr and case_option \ valid_ipc_buffer_ptr' args)" -| "valid_sc_inv' (InvokeSchedContextBind scptr cap) = - (ex_nonz_cap_to' scptr and valid_cap' cap and - (case cap of - ThreadCap t \ - ex_nonz_cap_to' t and - bound_sc_tcb_at' ((=) None) t and - obj_at' (\sc. scTCB sc = None) scptr \<^cancel>\ and - FIXME RT: can hopefully be established via assertions: - (\s. st_tcb_at' (ipc_queued_thread_state) t s - \ sc_at_pred' (sc_released (cur_time s)) scptr s) \ - | NotificationCap n _ _ _ \ - ex_nonz_cap_to' n and - obj_at' (\ntfn. ntfnSc ntfn = None) n and - obj_at' (\sc. scNtfn sc = None) scptr - | _ \ \))" -| "valid_sc_inv' (InvokeSchedContextUnbindObject scptr cap) = - (ex_nonz_cap_to' scptr and valid_cap' cap and - (case cap of - ThreadCap t \ - ex_nonz_cap_to' t and obj_at' (\sc. scTCB sc = Some t) scptr and - (\s. t \ ksCurThread s) - | NotificationCap n _ _ _ \ - ex_nonz_cap_to' n and obj_at' (\sc. scNtfn sc = Some n) scptr - | _ \ \))" -| "valid_sc_inv' (InvokeSchedContextUnbind scptr) = (sc_at' scptr and ex_nonz_cap_to' scptr)" -| "valid_sc_inv' (InvokeSchedContextYieldTo scptr args) = - (\s. ex_nonz_cap_to' scptr s - \ case_option \ valid_ipc_buffer_ptr' args s - \ (\ct. ct = ksCurThread s \ - bound_yt_tcb_at' ((=) None) ct s \ - obj_at' (\sc. \t. scTCB sc = Some t \ t \ ct) scptr s))" - -definition - valid_refills_number' :: "nat \ nat \ bool" -where - "valid_refills_number' max_refills n \ max_refills \ refillAbsoluteMax' n" - -primrec valid_sc_ctrl_inv' :: "sched_control_invocation \ kernel_state \ bool" where - "valid_sc_ctrl_inv' (InvokeSchedControlConfigureFlags scptr budget period mrefills badge flags) = - ((\s. \n. sc_at'_n n scptr s \ valid_refills_number' mrefills n) and - ex_nonz_cap_to' scptr and K (MIN_REFILLS \ mrefills) and - K (budget \ MAX_PERIOD \ budget \ MIN_BUDGET \ - period \ MAX_PERIOD \ budget \ MIN_BUDGET \ - budget \ period))" - -primrec sc_inv_rel :: "Invocations_A.sched_context_invocation \ sched_context_invocation \ bool" - where - "sc_inv_rel (Invocations_A.InvokeSchedContextConsumed sc_ptr bf) sci' = - (sci' = InvokeSchedContextConsumed sc_ptr bf)" -| "sc_inv_rel (Invocations_A.InvokeSchedContextBind sc_ptr cap) sci' = - (\cap'. cap_relation cap cap' \ sci' = InvokeSchedContextBind sc_ptr cap')" -| "sc_inv_rel (Invocations_A.InvokeSchedContextUnbindObject sc_ptr cap) sci' = - (\cap'. cap_relation cap cap' \ sci' = InvokeSchedContextUnbindObject sc_ptr cap')" -| "sc_inv_rel (Invocations_A.InvokeSchedContextUnbind sc_ptr) sci' = - (sci' = InvokeSchedContextUnbind sc_ptr)" -| "sc_inv_rel (Invocations_A.InvokeSchedContextYieldTo sc_ptr bf) sci' = - (sci' = InvokeSchedContextYieldTo sc_ptr bf)" - -primrec sc_ctrl_inv_rel :: - "Invocations_A.sched_control_invocation \ sched_control_invocation \ bool" where - "sc_ctrl_inv_rel (Invocations_A.InvokeSchedControlConfigureFlags sc_ptr budget period refills badge flags) sci' = - (sci' = InvokeSchedControlConfigureFlags sc_ptr budget period refills badge flags)" - -lemma decodeSchedContext_Bind_wf: - "\\s. \n. valid_cap' (SchedContextCap sc_ptr n) s - \ ex_nonz_cap_to' sc_ptr s - \ (\cap\set excaps. \r\zobj_refs' cap. ex_nonz_cap_to' r s) - \ (\x\set excaps. valid_cap' x s)\ - decodeSchedContext_Bind sc_ptr excaps - \valid_sc_inv'\, -" - apply (clarsimp simp: decodeSchedContext_Bind_def) - apply (wpsimp wp: gts_wp' threadGet_wp getNotification_wp - simp: scReleased_def scActive_def isBlocked_def refillReady_def) - apply (clarsimp simp: valid_cap'_def) - apply (drule_tac x="hd excaps" in bspec, fastforce dest: hd_in_set)+ - apply (fastforce simp: pred_tcb_at'_def obj_at'_def) - done - -lemma decodeSchedContext_UnbindObject_wf: - "\\s. \n. valid_cap' (SchedContextCap sc_ptr n) s - \ ex_nonz_cap_to' sc_ptr s - \ (\cap\set excaps. \r\zobj_refs' cap. ex_nonz_cap_to' r s) - \ (\x\set excaps. valid_cap' x s)\ - decodeSchedContext_UnbindObject sc_ptr excaps - \valid_sc_inv'\, -" - apply (clarsimp simp: decodeSchedContext_UnbindObject_def) - apply (wpsimp wp: gts_wp' threadGet_wp getNotification_wp - simp: scReleased_def scActive_def isBlocked_def refillReady_def) - apply (clarsimp simp: valid_cap'_def) - apply (drule_tac x="hd excaps" in bspec, fastforce dest: hd_in_set)+ - apply (fastforce simp: pred_tcb_at'_def obj_at'_def) - done - -lemma decodeSchedContext_YieldTo_wf: - "\\s. \n. valid_cap' (SchedContextCap sc_ptr n) s \ ex_nonz_cap_to' sc_ptr s - \ case_option \ valid_ipc_buffer_ptr' args s\ - decodeSchedContext_YieldTo sc_ptr args - \valid_sc_inv'\, -" - apply (clarsimp simp: decodeSchedContext_YieldTo_def) - apply (wpsimp wp: gts_wp' threadGet_wp getNotification_wp getTCB_wp - simp: scReleased_def scActive_def isBlocked_def refillReady_def) - apply (clarsimp simp: valid_cap'_def) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def projectKOs) - done - -lemma decodeSchedContextInvocation_wf: - "\\s. \n. valid_cap' (SchedContextCap sc_ptr n) s - \ ex_nonz_cap_to' sc_ptr s - \ case_option \ valid_ipc_buffer_ptr' args s - \ (\cap\set excaps. \r\zobj_refs' cap. ex_nonz_cap_to' r s) - \ (\x\set excaps. valid_cap' x s)\ - decodeSchedContextInvocation label sc_ptr excaps args - \valid_sc_inv'\, -" - apply (simp add: decodeSchedContextInvocation_def) - apply (wpsimp wp: decodeSchedContext_Bind_wf - decodeSchedContext_UnbindObject_wf - decodeSchedContext_YieldTo_wf) - apply (fastforce dest: valid_SchedContextCap_sc_at') - done - -lemma decodeSchedControlInvocation_wf: - "\invs' and (\s. \cap\set excaps. \r\zobj_refs' cap. ex_nonz_cap_to' r s) - and (\s. \x\set excaps. valid_cap' x s)\ - decodeSchedControlInvocation label args excaps - \valid_sc_ctrl_inv'\, -" - apply (clarsimp simp: decodeSchedControlInvocation_def) - apply (case_tac "genInvocationType label"; simp; (solves wpsimp)?) - apply (wpsimp simp: decodeSchedControl_ConfigureFlags_def) - apply (cases excaps; simp) - apply (rename_tac a list, case_tac a; simp add: isSchedContextCap_def) - apply (clarsimp simp: valid_cap'_def ko_wp_at'_def scBits_simps valid_refills_number'_def - MAX_PERIOD_def maxPeriodUs_def usToTicks_def us_to_ticks_mono - MIN_BUDGET_def kernelWCET_ticks_def timeArgSize_def minBudgetUs_def - MIN_REFILLS_def minRefills_def not_less - cong: conj_cong) - apply (insert getCurrentTime_buffer_bound) - apply (intro conjI impI; (fastforce intro: us_to_ticks_mono)?) - apply (rule_tac order_trans[OF MIN_BUDGET_helper]) - apply (rule us_to_ticks_mono) - apply blast - apply (fastforce intro: order_trans[OF mult_le_mono1] - simp: word_le_nat_alt) - apply (fastforce intro: order_trans[OF mult_le_mono1] us_to_ticks_mono - simp: word_le_nat_alt) - done - -lemma decodeSchedcontext_Bind_corres: - "list_all2 cap_relation excaps excaps' - \ corres (ser \ sc_inv_rel) - (invs and valid_sched and sc_at sc_ptr and (\s. \x\set excaps. s \ x)) - (invs' and (\s. \x\set excaps'. valid_cap' x s)) - (decode_sched_context_bind sc_ptr excaps) - (decodeSchedContext_Bind sc_ptr excaps')" - apply (clarsimp simp: decode_sched_context_bind_def decodeSchedContext_Bind_def) - apply (cases excaps; clarsimp) - apply (rename_tac cap list) - apply (cases excaps'; clarsimp) - apply (rule corres_splitEE_forwards') - apply (corresKsimp corres: get_sc_corres) - apply (fastforce intro: sc_at'_cross_rel[unfolded cross_rel_def, rule_format]) - apply (rule liftE_validE[THEN iffD2, OF get_sched_context_sp]) - apply (rule liftE_validE[THEN iffD2, OF get_sc_sp']) - apply (case_tac cap; clarsimp) - apply (clarsimp simp: bindE_assoc) - apply (rule corres_splitEE_skip; (solves wpsimp)?) - apply (corresKsimp simp: sc_relation_def) - apply (rule corres_splitEE_forwards'[where r'="(=)"]; (solves wpsimp)?) - 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 (rule corres_splitEE_skip; (solves wpsimp)?) - apply (corresKsimp corres: getNotification_corres - simp: get_sk_obj_ref_def sc_relation_def) - apply (clarsimp simp: returnOk_def) - apply (clarsimp simp: bindE_assoc get_tcb_obj_ref_def) - apply (rule corres_splitEE_skip; (solves wpsimp)?) - apply (corresKsimp simp: sc_relation_def) - apply (rule corres_splitEE_forwards'[where r'="(=)"]) - apply (subst corres_liftE_rel_sum) - apply (rule corres_guard_imp) - apply (rule threadGet_corres) - apply (clarsimp simp: tcb_relation_def) - apply (clarsimp simp: valid_cap_def) - apply (clarsimp simp: valid_cap'_def) - apply (rule liftE_validE[THEN iffD2, OF thread_get_sp]) - apply (rule liftE_validE[THEN iffD2, OF threadGet_sp]) - apply (rule corres_splitEE_skip; (solves \wpsimp simp: valid_cap'_def obj_at'_def\)?) - apply (corresKsimp corres: getNotification_corres - simp: get_sk_obj_ref_def sc_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqrE) - apply (rule corres_liftE_rel_sum[THEN iffD2, OF get_sc_released_corres]) - apply (rule corres_splitEE) - apply (subst corres_liftE_rel_sum) - apply (rule isBlocked_corres) - apply (rule whenE_throwError_corres) - apply simp - apply simp - apply (rule corres_trivial, clarsimp simp: returnOk_def) - apply wpsimp - apply wpsimp - apply wpsimp - apply (wpsimp simp: scReleased_def scActive_def) - apply (fastforce simp: obj_at_def is_tcb_def) - apply (clarsimp simp: obj_at'_def) - done - -lemma decodeSchedContext_UnbindObject_corres: - "list_all2 cap_relation excaps excaps' - \ corres (ser \ sc_inv_rel) - (invs and sc_at sc_ptr) - invs' - (decode_sched_context_unbind_object sc_ptr excaps) - (decodeSchedContext_UnbindObject sc_ptr excaps')" - apply (clarsimp simp: decode_sched_context_unbind_object_def decodeSchedContext_UnbindObject_def) - apply (cases excaps; clarsimp) - apply (rename_tac cap list) - apply (cases excaps'; clarsimp) - apply (case_tac cap; clarsimp) - apply (clarsimp simp: bindE_assoc get_sc_obj_ref_def liftE_bind_return_bindE_returnOk) - apply (rule corres_splitEE_forwards') - apply (corresKsimp corres: get_sc_corres) - apply (fastforce intro: sc_at'_cross_rel[unfolded cross_rel_def, rule_format]) - apply (rule liftE_validE[THEN iffD2, OF get_sched_context_sp]) - apply (rule liftE_validE[THEN iffD2, OF get_sc_sp']) - apply (corresKsimp simp: sc_relation_def) - apply (clarsimp simp: bindE_assoc get_sc_obj_ref_def liftE_bind_return_bindE_returnOk) - apply (rule corres_splitEE_forwards') - apply (corresKsimp corres: get_sc_corres) - apply (fastforce intro: sc_at'_cross_rel[unfolded cross_rel_def, rule_format]) - apply (rule liftE_validE[THEN iffD2, OF get_sched_context_sp]) - apply (rule liftE_validE[THEN iffD2, OF get_sc_sp']) - apply (rule corres_splitEE_forwards') - apply (corresKsimp simp: sc_relation_def) - apply (rule whenE_throwError_sp[simplified validE_R_def])+ - apply (rule corres_splitEE_forwards') - apply (corresKsimp corres: getCurThread_corres) - apply (rule liftE_validE[THEN iffD2, OF gets_sp]) - apply (rule liftE_validE[THEN iffD2, OF getCurThread_sp]) - apply corresKsimp - done - -lemma decodeSchedContext_YieldTo_corres: - "corres (ser \ sc_inv_rel) - (invs and sc_at sc_ptr) - invs' - (decode_sched_context_yield_to sc_ptr args') - (decodeSchedContext_YieldTo sc_ptr args')" - apply add_cur_tcb' - apply (clarsimp simp: decode_sched_context_yield_to_def decodeSchedContext_YieldTo_def) - apply (clarsimp simp: bindE_assoc get_sc_obj_ref_def liftE_bind_return_bindE_returnOk) - apply (rule corres_splitEE_forwards') - apply (corresKsimp corres: get_sc_corres) - apply (fastforce intro: sc_at'_cross_rel[unfolded cross_rel_def, rule_format]) - apply (rule liftE_validE[THEN iffD2, OF get_sched_context_sp]) - apply (rule liftE_validE[THEN iffD2, OF get_sc_sp']) - apply (rule corres_splitEE_forwards') - apply (corresKsimp simp: sc_relation_def) - apply (rule whenE_throwError_sp[simplified validE_R_def])+ - apply (rule corres_splitEE_forwards') - apply (corresKsimp corres: getCurThread_corres) - apply (rule liftE_validE[THEN iffD2, OF gets_sp]) - apply (rule liftE_validE[THEN iffD2, OF getCurThread_sp]) - apply (rule corres_splitEE_skip; (solves wpsimp)?) - apply (corresKsimp simp: sc_relation_def) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_splitEE_forwards'[where r'="(=)"]) - apply (subst corres_liftE_rel_sum) - apply (rule corres_guard_imp) - apply (rule threadGet_corres) - apply (clarsimp simp: tcb_relation_def) - apply (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_sched_context'_def) - apply (rule liftE_validE[THEN iffD2, OF thread_get_sp]) - apply (rule liftE_validE[THEN iffD2, OF threadGet_sp]) - apply (rule corres_splitEE_forwards'[where r'="(=)"]) - apply (subst corres_liftE_rel_sum) - apply (rule corres_guard_imp) - apply (rule threadGet_corres) - apply (clarsimp simp: tcb_relation_def) - apply fastforce - apply (fastforce simp: cur_tcb'_def) - apply (rule liftE_validE[THEN iffD2, OF thread_get_sp]) - apply (rule liftE_validE[THEN iffD2, OF threadGet_sp]) - apply (rule corres_splitEE_skip; corresKsimp; fastforce?) - apply (rule corres_splitEE_forwards'[where r'="(=)"]) - apply (subst corres_liftE_rel_sum) - apply (rule corres_guard_imp) - apply (rule threadGet_corres) - apply (clarsimp simp: tcb_relation_def) - apply fastforce - apply fastforce - apply (rule liftE_validE[THEN iffD2, OF thread_get_sp]) - apply (rule liftE_validE[THEN iffD2, OF threadGet_sp]) - apply (rule corres_splitEE_skip; corresKsimp; fastforce?) - done - -lemma decode_sc_inv_corres: - "list_all2 cap_relation excaps excaps' \ - corres (ser \ sc_inv_rel) - (invs and valid_sched and sc_at sc_ptr and (\s. \x\set excaps. s \ x) - and case_option \ in_user_frame args') - (invs' and (\s. \x\set excaps'. valid_cap' x s) - and case_option \ valid_ipc_buffer_ptr' args') - (decode_sched_context_invocation (mi_label mi) sc_ptr excaps args') - (decodeSchedContextInvocation (mi_label mi) sc_ptr excaps' args')" - apply (clarsimp simp: decode_sched_context_invocation_def decodeSchedContextInvocation_def - split del: if_split) - apply (cases "gen_invocation_type (mi_label mi)" - ; clarsimp split: gen_invocation_labels.split list.splits - split del: if_split) - apply (clarsimp simp: returnOk_def) - apply (corresKsimp corres: decodeSchedcontext_Bind_corres) - defer - apply (corresKsimp corres: decodeSchedContext_UnbindObject_corres) - apply (corresKsimp corres: decodeSchedContext_YieldTo_corres) - apply (rule corres_splitEE_forwards') - apply (corresKsimp corres: get_sc_corres) - apply (fastforce intro: sc_at'_cross_rel[unfolded cross_rel_def, rule_format]) - apply (rule liftE_validE[THEN iffD2, OF get_sched_context_sp]) - apply (rule liftE_validE[THEN iffD2, OF get_sc_sp']) - apply (rule corres_splitEE_forwards') - apply (corresKsimp corres: getCurThread_corres) - apply (rule liftE_validE[THEN iffD2, OF gets_sp]) - apply (rule liftE_validE[THEN iffD2, OF getCurThread_sp]) - apply (rule corres_splitEE_skip; corresKsimp; fastforce?) - apply (clarsimp simp: sc_relation_def) - done - -lemma decode_sc_ctrl_inv_corres: - "list_all2 cap_relation excaps excaps' \ - corres (ser \ sc_ctrl_inv_rel) \ \ - (decode_sched_control_invocation_flags (mi_label mi) args' excaps) - (decodeSchedControlInvocation (mi_label mi) args' excaps')" - apply (clarsimp simp: decode_sched_control_invocation_flags_def decodeSchedControlInvocation_def) - apply (cases "gen_invocation_type (mi_label mi)" - ; clarsimp simp: decodeSchedControl_ConfigureFlags_def TIME_ARG_SIZE_def timeArgSize_def) - apply (cases excaps; clarsimp) - apply (rename_tac cap list) - apply (cases excaps'; clarsimp) - apply (rule corres_splitEE_skip; (solves wpsimp)?) - apply corresKsimp - apply (rule corres_splitEE_forwards') - apply corresKsimp - apply (case_tac cap; clarsimp simp: isSchedContextCap_def) - apply (rule whenE_throwError_sp[simplified validE_R_def])+ - apply corresKsimp - apply (auto simp: minBudgetUs_def MIN_BUDGET_US_def maxPeriodUs_def parse_time_arg_def - parseTimeArg_def usToTicks_def minRefills_def MIN_REFILLS_def - max_num_refills_eq_refillAbsoluteMax' refillAbsoluteMax_def max_refills_cap_def - split: cap.splits) - done - -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)) - (ntfn_at' ntfnp and sc_at' scp) - (sched_context_bind_ntfn scp ntfnp) (schedContextBindNtfn scp ntfnp)" - unfolding sched_context_bind_ntfn_def schedContextBindNtfn_def - apply (clarsimp simp: update_sk_obj_ref_def bind_assoc) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getNotification_corres]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF setNotification_corres]) - apply (clarsimp simp: ntfn_relation_def split: Structures_A.ntfn.splits) - apply (fold updateSchedContext_def) - apply (rule updateSchedContext_corres) - apply (clarsimp simp: opt_map_red opt_pred_def obj_at_simps is_sc_obj) - apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - apply (clarsimp simp: sc_relation_def) - apply (clarsimp simp: opt_map_red obj_at_simps is_sc_obj) - apply (drule (1) sc_replies_relation_prevs_list'[OF state_relation_sc_replies_relation]) - apply (clarsimp simp: opt_map_red) - apply (clarsimp simp: objBits_simps') - apply wpsimp - apply wpsimp - apply simp+ - apply wpsimp+ - apply (fastforce simp: obj_at_simps sc_ntfn_sc_at_def is_ntfn is_sc_obj valid_obj_def) - apply clarsimp - done - -crunch tcb_sched_action, complete_yield_to, reschedule_required, sched_context_resume - for in_user_frame[wp]: "in_user_frame buf" - (simp: crunch_simps wp: crunch_wps ignore: set_tcb_obj_ref) - -lemma - schedContext_valid_ipc_buffer_ptr'[wp]: - "setSchedContext scp sc \valid_ipc_buffer_ptr' x\" and - threadSet_valid_ipc_buffer_ptr'[wp]: - "threadSet f tp \valid_ipc_buffer_ptr' x\" and - modifyReadyQueuesL1Bitmap_valid_ipc_buffer_ptr'[wp]: - "modifyReadyQueuesL1Bitmap d g \valid_ipc_buffer_ptr' x\" and - modifyReadyQueuesL2Bitmap_valid_ipc_buffer_ptr'[wp]: - "modifyReadyQueuesL2Bitmap d n g \valid_ipc_buffer_ptr' x\" and - setQueue_valid_ipc_buffer_ptr'[wp]: - "setQueue d prio p \valid_ipc_buffer_ptr' x\" - unfolding valid_ipc_buffer_ptr'_def - by wpsimp+ - -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 threadSet_tcbYieldTo_update_valid_queues: - "threadSet (tcbYieldTo_update f) t \valid_queues\" - apply (simp add: threadSet_def) - apply wp - apply (simp add: valid_queues_def valid_queues_no_bitmap_def' pred_tcb_at'_def) - apply (wp hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def' pred_tcb_at'_def) - apply (fastforce simp: obj_at'_def projectKOs inQ_def) - done - -lemma sc_yield_from_update_sc_tcb_sc_at[wp]: - "set_sc_obj_ref sc_yield_from_update scp ptr \sc_tcb_sc_at P scp\" - apply (wpsimp wp: update_sched_context_wp) - by (clarsimp simp: sc_tcb_sc_at_def obj_at_def) - -lemma schedContextYieldTo_corres: - "corres dc - ((case_option \ in_user_frame buf and einvs) and - (\s. bound_yt_tcb_at ((=) None) (cur_thread s) s - \ sc_tcb_sc_at (\sctcb. \t. sctcb = Some t \ t \ cur_thread s) scp s)) - ((case_option \ valid_ipc_buffer_ptr' buf and invs') and - (\s. bound_yt_tcb_at' ((=) None) (ksCurThread s) s \ - obj_at' (\sc. \t. scTCB sc = Some t \ t \ ksCurThread s) scp s)) - (sched_context_yield_to scp buf) (schedContextYieldTo scp buf)" - (is "corres _ (?abs_buf and (\s. ?ct s \ ?scp s)) (?con_buf and ?scp') _ _") - apply add_cur_tcb' - unfolding sched_context_yield_to_def schedContextYieldTo_def get_sc_obj_ref_def bind_assoc - contextYieldToUpdateQueues_def - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_sc_corres]) - apply (rename_tac sc sc') - apply (rule_tac P="?abs_buf and ?ct and ?scp and (\s. \n. ko_at (Structures_A.SchedContext sc n) scp s)" - and P'="?con_buf and cur_tcb' and ko_at' sc' scp" - in corres_inst) - apply simp - apply (erule exE) - apply (rule corres_underlying_split[where r'=dc]) - apply (simp only: when_def fromJust_def) - apply (rule corres_guard_imp) - apply (rule corres_if2) - apply (clarsimp simp: sc_relation_def) - apply (rule_tac F="scYieldFrom sc' = sc_yield_from sc" in corres_req) - apply (clarsimp simp: sc_relation_def) - apply (rule_tac P="?abs_buf and ?ct and ?scp - and (\s. \n. ko_at (Structures_A.SchedContext sc n) scp s) - and K (bound (sc_yield_from sc))" - and P'="?con_buf and cur_tcb' 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) - apply (rule corres_bind_return2) - apply (rule corres_split[OF schedContextCompleteYieldTo_corres]) - apply (rule_tac P="?abs_buf and ?ct and ?scp and sc_yf_sc_at ((=) None) scp" - and P'="?con_buf and cur_tcb'" - in corres_inst) - apply simp - apply (rule corres_symb_exec_l) - apply (rename_tac sc'') - apply (rule corres_bind_return) - apply (rule corres_assert_assume_l) - apply simp - apply (wpsimp wp: get_sched_context_exs_valid simp: sc_yf_sc_at_def obj_at_def) - apply (wpsimp simp: sc_yf_sc_at_def obj_at_def) - apply (wpsimp simp: sc_yf_sc_at_def obj_at_def) - supply if_split[split del] - apply ((wpsimp wp: complete_yield_to_sc_yf_sc_at_None hoare_case_option_wp - complete_yield_to_invs complete_yield_to_sc_tcb_sc_at - | wps)+)[1] - apply (wpsimp wp: hoare_case_option_wp) - apply clarsimp - apply (fastforce simp: valid_obj_def valid_sched_context_def obj_at_def sc_yf_sc_at_def - dest!: invs_valid_objs) - apply clarsimp - apply (fastforce simp: valid_obj'_def valid_sched_context'_def obj_at'_def projectKOs - dest!: invs_valid_objs') - - apply (rule_tac P="?abs_buf and sc_at scp" - and P'="?con_buf 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) - apply clarsimp - apply simp - apply (rule_tac P="?abs_buf and sc_yf_sc_at ((=) None) scp and ?ct and ?scp" - and P'="?con_buf and cur_tcb' and sc_at' scp" - in corres_inst) - apply (rule corres_guard_imp) - apply (rule corres_split[OF schedContextResume_corres]) - apply (rule corres_split[OF get_sc_corres _ get_sched_context_wp getSchedContext_wp]) - apply (rename_tac sc0 sc0') - apply (rule_tac F="scTCB sc0' = sc_tcb sc0" in corres_req) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_assert_opt_assume_l) - apply (rule_tac P="?abs_buf and sc_yf_sc_at ((=) None) scp and ?ct and ?scp - and (\s. \n. ko_at (Structures_A.SchedContext sc0 n) scp s) - and K (bound (sc_tcb sc0))" - and P'="?con_buf and cur_tcb' and ko_at' sc0' scp" - in corres_inst) - apply (rule corres_gen_asm') - apply (elim exE) - apply (rename_tac tp) - apply (simp only: option.sel pred_conj_def simp_thms(21)) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF isSchedulable_corres]) - apply (rename_tac sched) - apply (rule corres_split_eqr) - apply (rule_tac P="?abs_buf and sc_yf_sc_at ((=) None) scp and ?ct and ?scp - and (\s. sched = schedulable tp s) and tcb_at tp - and sc_tcb_sc_at ((=) (Some tp)) scp" - and P'="?con_buf 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) - apply (rule corres_if2, simp) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rename_tac ct_ptr) - 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_if2) - apply simp - apply simp - apply (rule corres_split[OF tcbSchedDequeue_corres]) - apply (rule corres_split[OF tcbSchedEnqueue_corres]) - apply simp - apply (wpsimp wp: tcbSchedDequeue_valid_queues)+ - apply (rule corres_split[OF tcb_yield_to_update_corres]) - apply (rule_tac sc'1=sc0' in corres_split[OF update_sc_no_reply_stack_update_ko_at'_corres]) - apply ((clarsimp simp: sc_relation_def objBits_simps')+)[4] - apply (rule_tac P="valid_objs and pspace_aligned and pspace_distinct - and weak_valid_sched_action and active_scs_valid - and sc_yf_sc_at ((=) (Some ct_ptr)) scp and ?scp - and bound_yt_tcb_at ((=) (Some scp)) ct_ptr - and tcb_at ct_ptr and tcb_at tp - and sc_tcb_sc_at ((=) (Some tp)) scp" - and P'="valid_objs' and valid_queues and valid_queues' and cur_tcb' - and valid_release_queue_iff 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)" - in corres_inst) - apply (rule corres_guard_imp) - apply (rule corres_split[OF tcbSchedDequeue_corres]) - apply (rule corres_split[OF tcbSchedEnqueue_corres]) - apply (rule corres_split[OF tcbSchedEnqueue_corres]) - apply (rule corres_split[OF rescheduleRequired_corres]) - apply simp - apply (wpsimp wp: tcbSchedDequeue_valid_queues)+ - apply (clarsimp simp: obj_at'_def projectKOs valid_objs'_valid_tcbs' - elim!: opt_mapE) - apply (prop_tac "\tcb. ko_at' tcb tp s") - apply (fastforce simp: valid_obj'_def valid_sched_context'_def obj_at'_def) - apply clarsimp - apply (drule (1) tcb_ko_at_valid_objs_valid_tcb'[rotated]) - apply (clarsimp simp: valid_tcb'_def obj_at'_def projectKOs inQ_def tcb_cte_cases_def) - apply (wpsimp wp: hoare_case_option_wp set_yf_sc_yf_sc_at[simplified op_equal]) - apply (wpsimp wp:hoare_case_option_wp) - apply (wpsimp wp: set_sc'.obj_at' set_sc'.set_wp) - apply (wpsimp wp: syt_bound_tcb_at') - apply (clarsimp cong: conj_cong) - apply (wpsimp wp: threadSet_valid_queues threadSet_valid_queues' - threadSet_vrq'_inv threadSet_vrq_inv threadSet_cur - threadSet_valid_objs' hoare_drop_imp - simp: fun_upd_def[symmetric]) - apply (rule_tac - Q="\_. sc_at scp and - valid_objs and - pspace_aligned and - pspace_distinct and - weak_valid_sched_action and - active_scs_valid and - (\s. bound_yt_tcb_at ((=) None) (cur_thread s) s) and - (\s. sc_tcb_sc_at (\sctcb. \t. sctcb = Some t \ t \ cur_thread s) scp s) and - tcb_at ct_ptr and - tcb_at tp and sc_tcb_sc_at ((=) (Some tp)) scp" - in hoare_strengthen_post) - apply (wpsimp cong: conj_cong imp_cong wp: hoare_drop_imp hoare_vcg_conj_lift) - apply clarsimp - 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 - and valid_release_queue_iff and valid_queues and valid_queues'" - in hoare_strengthen_post) - apply (wpsimp wp: setSchedContext_scTCBs_of) - apply (clarsimp simp: projectKOs opt_map_red) - apply (frule (1) sc_ko_at_valid_objs_valid_sc'[rotated]) - apply (clarsimp simp: valid_sched_context'_def valid_sched_context_size'_def - obj_at'_def projectKOs) - apply (erule_tac x=tp in valid_objsE', simp) - apply (fastforce simp: valid_obj'_def valid_tcb'_def obj_at'_def projectKOs - inQ_def tcb_cte_cases_def objBits_simps' scBits_simps) - apply (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imp) - apply (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imp) - apply wpsimp - apply wpsimp - apply (rule_tac P="?abs_buf and sc_yf_sc_at ((=) None) scp and ?scp - and (\s. sched = schedulable tp s)" - and P'="?con_buf and cur_tcb' and ko_at' sc0' scp" - in corres_inst) - apply simp - apply (intro conjI impI; clarsimp cong: conj_cong) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def - valid_sched_action_weak_valid_sched_action pred_tcb_at_def - sc_tcb_sc_at_def obj_at_def is_tcb is_sc_obj) - apply (fastforce simp: obj_at_def elim!: valid_sched_context_size_objsI) - apply (clarsimp cong: conj_cong simp: invs'_def valid_pspace'_def cur_tcb'_def) - apply (rule corres_when, simp) - apply (rule setConsumed_corres) - apply (clarsimp simp:obj_at'_def projectKOs) - apply (wpsimp wp: thread_get_wp hoare_case_option_wp)+ - apply (wpsimp wp: threadGet_wp)+ - apply (wpsimp wp: is_schedulable_wp) - apply (wpsimp wp: isSchedulable_wp) - 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; - clarsimp simp: obj_at_def sc_tcb_sc_at_def is_sc_obj - elim!: valid_sched_context_size_objsI dest!: invs_valid_objs) - apply (fastforce simp: valid_obj_def obj_at_def valid_sched_context_def) - apply (intro conjI impI; clarsimp simp: is_tcb pred_tcb_at_def obj_at_def) - apply (erule (1) valid_sched_context_size_objsI)+ - apply (clarsimp simp: invs'_def valid_pspace'_def valid_objs'_valid_tcbs') - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - apply (rule_tac Q'="\rv. (case buf of None \ \_. True | Some x \ in_user_frame x) and - einvs and sc_yf_sc_at ((=) None) scp and - (\s. bound_yt_tcb_at ((=) None) (cur_thread s) s \ - sc_tcb_sc_at (\sctcb. \t. sctcb = Some t \ t \ cur_thread s) scp s)" - in hoare_strengthen_post[rotated]) - apply (fastforce simp: sc_tcb_sc_at_def obj_at_def is_sc_obj - elim!: valid_sched_context_size_objsI[OF invs_valid_objs]) - apply (wpsimp wp: hoare_case_option_wp sched_context_resume_valid_sched) - apply ((wpsimp | wps)+)[1] - apply (rule_tac Q'="\rv'. (case buf of None \ \_. True | Some x \ valid_ipc_buffer_ptr' x) - and invs' and sc_at' scp and cur_tcb'" - in hoare_strengthen_post[rotated]) - apply clarsimp - apply (wpsimp wp:hoare_case_option_wp) - apply clarsimp - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def) - apply (fastforce simp: sc_tcb_sc_at_def obj_at_def) - apply (clarsimp simp: invs'_def valid_pspace'_def obj_at'_def projectKOs) - apply wpsimp - apply (rule_tac Q'="\_ s. (case buf of None \ \_. True | Some x \ in_user_frame x) s \ - invs s \ valid_list s \ valid_sched s \ - bound_yt_tcb_at ((=) None) (cur_thread s) s \ - sc_tcb_sc_at (\sctcb. \t. sctcb = Some t \ t \ cur_thread s) scp s" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: sc_yf_sc_at_def obj_at_def) - apply (wpsimp wp: hoare_case_option_wp complete_yield_to_invs split: option.splits) - apply ((wpsimp wp: complete_yield_to_sc_tcb_sc_at | wps)+) - apply (clarsimp split: if_split simp: sc_yf_sc_at_def obj_at_def) - apply (wpsimp wp: hoare_case_option_wp schedContextCompleteYieldTo_invs' split: option.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]) - apply clarsimp - done - -crunch sched_context_unbind_ntfn, sched_context_unbind_all_tcbs - for sc_at[wp]: "sc_at scp" - (wp: crunch_wps) - -crunch schedContextUnbindNtfn, schedContextUnbindAllTCBs - for sc_at'[wp]: "sc_at' scp" - (wp: crunch_wps) - -lemma invokeSchedContext_corres: - "sc_inv_rel sc_inv sc_inv' \ - corres (=) - (einvs and valid_sched_context_inv sc_inv and simple_sched_action - and current_time_bounded) - (invs' and sch_act_simple and valid_sc_inv' sc_inv') - (invoke_sched_context sc_inv) - (invokeSchedContext sc_inv')" - apply (simp add: invoke_sched_context_def invokeSchedContext_def) - apply (cases sc_inv; cases sc_inv'; clarsimp simp: cap_relation_def) - apply (rule corres_rel_imp) - apply (rule corres_guard_imp) - apply (rule setConsumed_corres) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply clarsimp - apply simp - apply (clarsimp split: cap.split capability.split; intro conjI impI allI; clarsimp) - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule schedContextBindTCB_corres, simp) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule schedContextBindNtfn_corres) - apply simp - apply clarsimp - apply (clarsimp simp: obj_at'_def) - apply (clarsimp split: cap.split capability.split; intro conjI impI allI; clarsimp) - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule schedContextUnbindTCB_corres, simp) - apply (clarsimp simp: sc_tcb_sc_at_def obj_at_def obj_at'_def)+ - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule schedContextUnbindNtfn_corres, simp) - apply (clarsimp simp: sc_ntfn_sc_at_def obj_at_def is_sc_obj)+ - apply (fastforce simp: valid_sched_context_size_objsI dest!: invs_valid_objs) - apply simp - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule corres_split[OF schedContextUnbindAllTCBs_corres]) - apply (rule corres_split[OF schedContextUnbindNtfn_corres]) - apply (rule schedContextUnbindReply_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 (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule schedContextYieldTo_corres) - apply simp - apply clarsimp - apply clarsimp - done - -lemmas sc_relation_refillResetRR1 = - sc_relation_updateRefillTl[where f="r_amount_update (\_. 0)" and f'="rAmount_update (\_. 0)"] - -lemma sc_relation_refillResetRR2: - "\sc_relation sc n sc'; length (sc_refills sc) = 2; sc_refill_max sc = MIN_REFILLS; - sc_valid_refills' sc'; 1 < scRefillCount sc'\ - \ sc_relation - (sc_refills_update - (\refills. r_amount_update (\m. m + r_amount (hd (tl refills))) (hd refills) # tl refills) - sc) - n ((scRefills_update - (\_. updateAt (scRefillHead sc') (scRefills sc') - (\hd. rAmount_update (\_. rAmount hd + rAmount (refillTl sc')) hd))) - sc')" - apply (case_tac "sc_refills sc"; simp) - apply (rename_tac ls; case_tac ls; clarsimp simp: MIN_REFILLS_def) - apply (cases sc; simp add: sc_relation_def refills_map_def) - apply (prop_tac "scRefillCount sc' = 2") - apply (insert length_wrap_slice[of "scRefillCount sc'" "scRefillMax sc'" "scRefillHead sc'" "scRefills sc'"]) - apply (case_tac "scRefillHead sc'"; simp) - apply (clarsimp simp: refill_map_def updateAt_def Let_def null_def) - apply (clarsimp simp: wrap_slice_def) - apply (intro conjI; clarsimp simp: updateAt_def Let_def null_def refill_map_def) - apply (case_tac "scRefills sc'"; simp) - apply (rename_tac list; case_tac list; simp add: refill_map_def refillTl_def refillTailIndex_def) - apply (case_tac "scRefillHead sc'"; simp) - apply (intro conjI; clarsimp) - apply (case_tac "scRefills sc'"; simp) - apply (rename_tac list; case_tac list; simp add: refill_map_def refillTl_def refillTailIndex_def) - done - -lemma sc_relation_refillResetRR: - "\sc_relation sc n sc'; length (sc_refills sc) = 2; sc_refill_max sc = MIN_REFILLS; - sc_valid_refills' sc'; 1 < scRefillCount sc'\ - \ sc_relation - (sc_refills_update - ((\refills. butlast refills @ [last refills\r_amount := 0\]) \ - (\refills. r_amount_update (\m. m + r_amount (hd (tl refills))) (hd refills) # tl refills)) - sc) - n (((\sc. scRefills_update (\_. updateAt (refillTailIndex sc) (scRefills sc) (rAmount_update (\_. 0))) - sc) \ - (\sc. scRefills_update - (\_. updateAt (scRefillHead sc) (scRefills sc) - (\hd. rAmount_update (\_. rAmount hd + rAmount (refillTl sc)) hd)) - sc)) - sc')" - apply (drule sc_relation_refillResetRR2; fastforce?) - by (drule sc_relation_refillResetRR1; clarsimp simp: refill_map_def) - -lemma refillResetRR_corres: - "corres dc (sc_at csc_ptr and is_active_sc csc_ptr - and round_robin csc_ptr and valid_refills csc_ptr) - (valid_objs' and sc_at' csc_ptr) - (refill_reset_rr csc_ptr) (refillResetRR csc_ptr)" - (is "corres dc ?abs ?conc _ _") - supply projection_rewrites[simp] - 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) - apply (fastforce dest!: is_active_sc'_cross[OF state_relation_pspace_relation]) - apply (rule_tac Q="\s'. ((\sc'. scRefillCount sc' = 2) |< scs_of' s') csc_ptr" - in corres_cross_add_guard) - apply (clarsimp simp: obj_at'_def projectKOs round_robin2_def obj_at_def is_sc_obj - rr_valid_refills_def is_active_sc2_def is_active_sc'_def opt_map_red - opt_pred_def) - apply (drule (1) pspace_relation_absD[where x=csc_ptr, OF _ state_relation_pspace_relation]) - apply (erule (1) valid_objsE') - apply (clarsimp simp: sc_relation_def refills_map_def valid_sched_context'_def valid_obj'_def) - apply (clarsimp simp: refill_reset_rr_def refillResetRR_def get_refills_def updateRefillTl_def - update_sched_context_decompose[symmetric, simplified] update_refill_tl_def) - apply (rule corres_guard_imp) - apply (rule monadic_rewrite_corres_r[OF monadic_rewrite_sym[OF updateSchedContext_decompose[simplified]]]) - apply (rule updateSchedContext_corres_gen[where - P="(\s. ((\sc. length (sc_refills sc) = 2 \ sc_refill_max sc = MIN_REFILLS) |< scs_of2 s) csc_ptr)" - and P'="valid_objs' and is_active_sc' csc_ptr and (\s'. ((\sc'. scRefillCount sc' = 2) |< scs_of' s') csc_ptr)"]) - apply (clarsimp, drule (2) state_relation_sc_relation) - apply (clarsimp simp: is_sc_obj obj_at_simps is_active_sc'_def opt_map_red opt_pred_def) - apply (erule (1) valid_objsE', clarsimp simp: valid_obj'_def valid_sched_context'_def) - apply (fastforce elim!: sc_relation_refillResetRR[simplified]) - apply (fastforce simp: obj_at_simps is_sc_obj opt_map_red - dest!: state_relation_sc_replies_relation_sc) - apply (clarsimp simp: objBits_simps)+ - apply (clarsimp simp: round_robin2_def obj_at_def is_sc_obj rr_valid_refills_def opt_map_red - opt_pred_def) - by (clarsimp simp: objBits_simps) - -lemma refillNew_corres: - "\1 < max_refills; valid_refills_number' max_refills (minSchedContextBits + n)\ - \ corres dc - (pspace_aligned and pspace_distinct and sc_obj_at n sc_ptr) valid_objs' - (refill_new sc_ptr max_refills budget period) - (refillNew sc_ptr max_refills budget period)" - supply projection_rewrites[simp] - supply getSchedContext_wp[wp del] set_sc'.get_wp[wp del] - apply (rule corres_cross_add_guard[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 opt_map_red opt_pred_def objBits_simps projectKOs) - apply (unfold refillNew_def refill_new_def setRefillHd_def updateRefillHd_def) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF getCurTime_corres]) - (* period *) - apply (rule corres_split[OF updateSchedContext_corres]; clarsimp simp: objBits_simps) - apply (fastforce simp: obj_at_simps is_sc_obj sc_relation_def opt_map_red opt_pred_def - dest!: state_relation_sc_relation) - apply (fastforce simp: obj_at_simps is_sc_obj opt_map_red - dest!: state_relation_sc_replies_relation_sc) - (* budget, max_refills, sc_refills update: rewrite into one step updateSchedContext corres *) - apply (rename_tac ctime) - apply (rule_tac P="sc_obj_at n sc_ptr and (\s. ctime = cur_time s)" - and P'="sc_at' sc_ptr and (\s'. ctime = ksCurTime s') - and (\s'. ((\sc'. scSize sc' = n - \ length (scRefills sc') = - refillAbsoluteMax' (minSchedContextBits + scSize sc')) - |< scs_of' s') sc_ptr)" - in corres_inst) - apply (subst bind_assoc[symmetric])+ - apply (subst update_sched_context_decompose[symmetric, simplified])+ - apply (subst bind_assoc) - apply (rule corres_guard_imp) - apply (rule corres_split[OF monadic_rewrite_corres_r - [OF monadic_rewrite_sym - [OF updateSchedContext_decompose_x2[simplified]]]]) - apply (clarsimp simp: objBits_simps)+ - (* use setSchedContext_corres *) - apply (rule monadic_rewrite_corres_l[OF update_sched_context_rewrite[where n=n]]) - apply (simp add: updateSchedContext_def) - apply (rule corres_split[OF get_sc_corres_size[where n=n]]) - apply (rename_tac sc') - apply (rule_tac P="ko_at (kernel_object.SchedContext sc n) sc_ptr" - and P'="\s'. ko_at' sc' sc_ptr s' - \ ((\sc'. length (scRefills sc') = - refillAbsoluteMax' (minSchedContextBits + scSize sc') - \ scSize sc' = n) - |< scs_of' s') sc_ptr" - in corres_inst) - apply (rule_tac F="length (scRefills sc') = - refillAbsoluteMax' (minSchedContextBits + scSize sc')" - in corres_req) - apply (fastforce simp: obj_at_simps opt_map_red opt_pred_def) - apply (rule stronger_corres_guard_imp) - apply (rule_tac sc'="sc'\ scRefillMax := max_refills, - scRefillHead := 0, - scRefillCount := Suc 0, - scRefills := updateAt 0 (scRefills sc') (\r. Refill ctime budget)\" - in setSchedContext_corres) - apply (clarsimp simp: sc_relation_def refills_map_def valid_refills_number'_def - wrap_slice_start_0 max_num_refills_eq_refillAbsoluteMax') - apply (case_tac "scRefills sc'"; simp add: updateAt_def null_def refill_map_def) - apply (clarsimp simp: objBits_simps scBits_simps sc_relation_def) - apply simp - apply (fastforce simp: obj_at_simps is_sc_obj opt_map_red - dest!: sc_replies_relation_prevs_list[OF state_relation_sc_replies_relation]) - apply (wpsimp wp: getSchedContext_wp')+ - (* last step : add tail *) - apply (rule_tac P="sc_obj_at n sc_ptr and is_active_sc2 sc_ptr" - and P'="sc_at' sc_ptr - and (\s'. ((\sc'. length (scRefills sc') = - refillAbsoluteMax' (minSchedContextBits + scSize sc') - \ scSize sc' = n - \ scRefillHead sc' = 0 \ scRefillCount sc' = 1 - \ scRefillMax sc' = max_refills) - |< scs_of' s') sc_ptr)" - in corres_inst) - apply (rule stronger_corres_guard_imp) - apply (rule maybeAddEmptyTail_corres) - apply simp - apply (clarsimp simp: obj_at_simps is_sc_obj scBits_simps opt_map_red opt_pred_def - valid_refills_number'_def) - apply (clarsimp simp: valid_sched_context'_def) - apply (wpsimp wp: update_sched_context_wp updateSchedContext_wp)+ - apply (clarsimp simp: obj_at_def is_sc_obj is_active_sc2_def) - apply (clarsimp simp: obj_at_simps fun_upd_def[symmetric] valid_objs'_def ps_clear_upd - opt_map_red opt_pred_def) - apply (wpsimp wp: update_sched_context_wp updateSchedContext_wp)+ - apply (clarsimp simp: obj_at_def is_sc_obj is_active_sc2_def) - apply (clarsimp simp: obj_at_simps fun_upd_def[symmetric] ps_clear_upd opt_map_red opt_pred_def) - apply (fastforce simp: valid_objs'_def valid_obj'_def valid_sched_context'_def - split: kernel_object.splits) - done - -lemma refillUpdate_corres: - "\1 < max_refills; valid_refills_number' max_refills (minSchedContextBits + n)\ - \ corres dc - ((is_active_sc2 sc_ptr and sc_obj_at n sc_ptr) and (pspace_aligned and pspace_distinct)) - (valid_refills' sc_ptr and valid_objs') - (refill_update sc_ptr period budget max_refills) - (refillUpdate sc_ptr period budget max_refills)" - (is "_ \ _ \ corres _ (?pred and _) ?conc _ _") - supply getSchedContext_wp[wp del] set_sc'.get_wp[wp del] projection_rewrites[simp] - 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="is_active_sc' sc_ptr" in corres_cross_add_guard) - apply (rule is_active_sc'_cross, fastforce+) - apply (rule corres_guard_imp) - apply (rule_tac P="?pred" and P'="?conc and sc_at' sc_ptr" in corres_inst) - apply (unfold refillUpdate_def refill_update_def) - apply simp - (* rewrite the refill list update steps into one step updateSchedContext corres *) - apply (subst bind_assoc[where m="update_sched_context _ _", symmetric]) - apply (subst update_sched_context_decompose[symmetric, simplified]) - apply (subst bind_assoc[where m="updateSchedContext _ _", symmetric]) - apply (subst bind_assoc[where m="do _ \ updateSchedContext _ _; updateSchedContext _ _ od", symmetric]) - apply (subst bind_assoc[where m="do _ \ (do _ \ updateSchedContext _ _; updateSchedContext _ _ od); - updateSchedContext _ _ od", symmetric]) - apply (subst bind_assoc[where m="updateSchedContext _ _"]) - apply (subst bind_assoc[where m="updateSchedContext _ _"]) - apply (subst bind_assoc[where m="updateSchedContext _ _"]) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[OF monadic_rewrite_corres_r - [OF monadic_rewrite_sym - [OF updateSchedContext_decompose_x3[simplified]]]]) - apply ((clarsimp simp: objBits_simps)+)[2] - (* now use setSchedContext_corres *) - apply (rule corres_inst[where P="?pred and sc_obj_at n sc_ptr" and P'="?conc and sc_at' sc_ptr"]) - (* one of the sc_obj_at n sc_ptr will be consumed by the next line *) - apply (rule monadic_rewrite_corres_l[OF update_sched_context_rewrite[where n=n]]) - apply (simp add: updateSchedContext_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[OF get_sc_corres_size[where n=n]]) - apply (rename_tac sc sc') - apply (rule_tac P="?pred and ko_at (kernel_object.SchedContext sc n) sc_ptr" - and P'="ko_at' sc' sc_ptr and valid_sched_context' sc' - and K (0 < scRefillMax sc' \ sc_valid_refills' sc')" - in corres_inst) - apply (rule_tac F="0 < scRefillMax sc' \ sc_valid_refills' sc' - \ length (scRefills sc') = max_num_refills (minSchedContextBits + n)" - in corres_req) - apply (clarsimp simp: obj_at'_def objBits_simps scBits_simps - valid_sched_context'_def sc_relation_def) - apply (rule stronger_corres_guard_imp) - apply (rule setSchedContext_corres) - apply (unfold sc_relation_def; elim conjE exE; intro conjI; fastforce?) - apply (clarsimp simp: refills_map_def wrap_slice_start_0 hd_map neq_Nil_lengthI - refill_map_def updateAt_def null_def refillHd_def hd_wrap_slice - valid_refills_number'_def max_num_refills_eq_refillAbsoluteMax') - apply (clarsimp simp: objBits_simps scBits_simps sc_relation_def) - apply simp - apply (clarsimp simp: obj_at_simps scBits_simps is_sc_obj) - apply (fastforce elim!: sc_replies_relation_prevs_list[OF state_relation_sc_replies_relation]) - apply wpsimp - apply (wpsimp wp: getSchedContext_wp') - apply (clarsimp simp: obj_at_def is_sc_obj) - apply (drule state_relation_sc_relation[where ptr=sc_ptr]; - (fastforce simp: obj_at_simps is_sc_obj obj_bits_def)?) - apply (clarsimp simp: obj_at_simps is_sc_obj valid_refills_number'_def scBits_simps - opt_map_red opt_pred_def valid_refills'_def sc_relation_def - valid_objs'_def valid_obj'_def) - apply force - apply ((clarsimp simp: objBits_simps)+)[2] - (* sc_budget and sc_period *) - apply (subst bind_assoc[where m="update_sched_context _ _", symmetric]) - apply (subst update_sched_context_decompose[symmetric, simplified]) - apply (rule corres_split[OF updateSchedContext_corres]) - apply (fastforce dest!: state_relation_sc_relation - simp: obj_at_simps is_sc_obj sc_relation_def opt_map_red opt_pred_def) - apply (fastforce dest!: state_relation_sc_replies_relation_sc - simp: obj_at_simps is_sc_obj sc_relation_def opt_map_red) - apply (simp add: objBits_simps) - (* the rest *) - apply (rule_tac P="sc_obj_at n sc_ptr and - (\s. ((\sc. sc_refills sc\ [] \ 0 < sc_refill_max sc) |< scs_of s) sc_ptr)" - and P'="sc_at' sc_ptr and - (\s'. ((\ko. 1 < scRefillMax ko \ scRefillCount ko = 1 \ sc_valid_refills' ko) - |< scs_of' s') sc_ptr)" - in corres_inst) - apply (simp add: when_def[symmetric] whenM_def ifM_def bind_assoc split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF refillReady_corres]) (* projection version *) - (* when-block *) - apply (rule corres_split[OF corres_when], simp) - apply (rule corres_split[OF getCurTime_corres]) - apply (rule corres_guard_imp) - apply (rule updateRefillHd_corres, simp) - apply (simp add: refill_map_def) - apply (simp+)[2] - apply (wpsimp+)[2] - apply (simp add: liftM_def bind_assoc) - apply (rule corres_split[OF get_sc_corres]) - (* if-block *) - apply (rename_tac sc sc') - apply (rule_tac P="ko_at (kernel_object.SchedContext sc n) sc_ptr - and K (0 < sc_refill_max sc) and K (sc_refills sc \ []) - and K (valid_sched_context_size n)" - and P'="ko_at' sc' sc_ptr - and K (1 < scRefillMax sc' \ scRefillCount sc' = 1 - \ sc_valid_refills' sc')" - in corres_inst) - apply (rule_tac F="refill_hd sc = refill_map (refillHd sc')" in corres_req) - apply (fastforce dest!: refill_hd_relation) - apply (rule corres_guard_imp) - apply (rule corres_if) - apply (clarsimp simp: refill_map_def) - apply (rule corres_split[OF updateRefillHd_corres], simp) - apply (clarsimp simp: refill_map_def) - apply (rule maybeAddEmptyTail_corres[simplified dc_def]) - apply (wpsimp simp: update_refill_hd_rewrite) - apply (wpsimp simp: updateRefillHd_def wp: updateSchedContext_wp) - apply (rule refillAddTail_corres[simplified dc_def]) - apply (clarsimp simp: refill_map_def) - apply (clarsimp simp: obj_at_def is_sc_obj is_active_sc2_def opt_map_red opt_pred_def) - apply (clarsimp simp: obj_at_simps opt_map_red opt_pred_def is_sc_obj ps_clear_upd - scBits_simps fun_upd_def[symmetric] valid_refills'_def) - apply wpsimp - apply (wpsimp wp: getSchedContext_wp') - apply (wpsimp simp: update_refill_hd_def wp: update_sched_context_wp) - apply (wpsimp simp: updateRefillHd_def objBits_simps - wp: updateSchedContext_wp) - apply (wpsimp wp: get_sc_refill_ready_wp) - apply (wpsimp wp: refillReady_wp') - apply (fastforce simp: obj_at_def is_sc_obj is_active_sc2_def opt_map_red opt_pred_def) - apply (clarsimp simp: obj_at_simps ps_clear_upd fun_upd_def[symmetric] - valid_refills'_def opt_map_red opt_pred_def) - apply ((wpsimp wp: updateSchedContext_wp update_sched_context_wp simp: objBits_simps)+)[5] - apply (clarsimp simp: obj_at_def is_sc_obj is_active_sc2_def opt_map_red opt_pred_def) - apply (clarsimp simp: obj_at_simps scBits_simps ps_clear_upd fun_upd_def[symmetric] - valid_refills_number'_def is_sc_obj) - apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - apply (fastforce simp: valid_sched_context'_def valid_obj'_def valid_refills_number'_def - scBits_simps opt_map_red sc_relation_def) - apply clarsimp+ - done - -crunch maybeAddEmptyTail, setRefillHd - for invs'[wp]: invs' - (simp: crunch_simps wp: crunch_wps) - -lemma refillNew_invs': - "\\s. invs' s \ (\n. sc_at'_n n scPtr s \ valid_refills_number' maxRefills n) - \ ex_nonz_cap_to' scPtr s \ MIN_REFILLS \ maxRefills\ - refillNew scPtr maxRefills budget period - \\_. invs'\" - (is "\?P\ _ \?Q\") - apply (clarsimp simp: refillNew_def) - apply (rule bind_wp_fwd_skip, wpsimp) - - apply (rule bind_wp_fwd_skip) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) - apply (wpsimp wp: updateSchedContext_invs') - apply (fastforce dest: invs'_ko_at_valid_sched_context' - simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps) - apply (wpsimp wp: updateSchedContext_wp) - apply (clarsimp simp: obj_at_simps ko_wp_at'_def ps_clear_def opt_map_def) - - apply (simp flip: bind_assoc) - apply (rule bind_wp) - apply wpsimp - apply (rule bind_wp) - apply wpsimp - - apply (clarsimp simp: pred_conj_def) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply (find_goal \match conclusion in "\P\ f \\_. active_sc_at' scPtr\" for P f \ -\) - apply (wpsimp wp: updateSchedContext_wp) - apply (clarsimp simp: active_sc_at'_def obj_at_simps MIN_REFILLS_def ps_clear_def) - apply (clarsimp simp: updateSchedContext_def bind_assoc) - apply (subst bind_dummy_ret_val)+ - apply (rule hoare_weaken_pre) - apply (rule_tac P'="?P" and P''="sc_at' scPtr" and Q="?Q" - in monadic_rewrite_refine_valid[OF getSchedContext_setSchedContext_decompose]; - (solves wpsimp)?) - apply (wpsimp wp: setSchedContext_invs') - apply (fastforce dest: invs'_ko_at_valid_sched_context' - simp: valid_sched_context'_def valid_sched_context_size'_def obj_at_simps - ko_wp_at'_def valid_refills_number'_def) - apply (clarsimp simp: obj_at_simps ko_wp_at'_def) - apply (case_tac ko; clarsimp) - done - -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\ - refillUpdate scPtr newPeriod newBudget newMaxRefills - \\_. invs'\" - (is "\?P\ _ \_\") - apply (clarsimp simp: refillUpdate_def) - apply (simp flip: bind_assoc) - apply (rule_tac Q'="\_. invs' and active_sc_at' scPtr" in bind_wp) - apply (wpsimp wp: updateRefillHd_invs') - apply (clarsimp simp: pred_conj_def) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply (find_goal \match conclusion in "\P\ f \\_. active_sc_at' scPtr\" for P f \ -\) - 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'" in bind_wp) - apply wpsimp - apply (rule_tac Q'="\_. invs' and active_sc_at' scPtr" in bind_wp) - apply (wpsimp wp: updateRefillHd_invs' refillReady_wp) - apply (clarsimp simp: pred_conj_def) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply (find_goal \match conclusion in "\P\ f \\_. active_sc_at' scPtr\" for P f \ -\) - 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 (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)?) - apply (wpsimp wp: updateSchedContext_invs') - apply (fastforce dest: invs'_ko_at_valid_sched_context' - simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps) - apply (wpsimp wp: updateSchedContext_wp) - apply (clarsimp simp: obj_at_simps ko_wp_at'_def ps_clear_def opt_map_def) - apply (rule_tac Q'="\_. ?P and (\s'. ((\sc'. scRefillHead sc' = 0) |< scs_of' s') scPtr)" - in bind_wp_fwd) - apply (clarsimp simp: pred_conj_def) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) - apply (wpsimp wp: updateSchedContext_invs') - apply (fastforce dest: invs'_ko_at_valid_sched_context' - simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps) - apply (wpsimp wp: updateSchedContext_wp) - apply (clarsimp simp: obj_at_simps ko_wp_at'_def ps_clear_def opt_map_def) - apply (wpsimp wp: updateSchedContext_wp) - apply (rule_tac Q'="\_. ?P and (\s'. ((\sc'. scRefillHead sc' = 0) |< scs_of' s') scPtr) - and (\s'. ((\sc'. scRefillCount sc' = 1) |< scs_of' s') scPtr)" - in bind_wp_fwd) - apply (clarsimp simp: pred_conj_def) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) - apply (wpsimp wp: updateSchedContext_invs') - apply (fastforce dest: invs'_ko_at_valid_sched_context' - simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps) - apply (wpsimp wp: updateSchedContext_wp) - apply (clarsimp simp: obj_at_simps ko_wp_at'_def ps_clear_def opt_map_def) - apply (wpsimp wp: updateSchedContext_wp) - apply (clarsimp simp: obj_at_simps ko_wp_at'_def ps_clear_def opt_map_def opt_pred_def) - apply (wpsimp wp: updateSchedContext_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 - ko_wp_at'_def valid_refills_number'_def opt_map_red opt_pred_def) - done - -lemma tcbSchedDequeue_valid_refills'[wp]: - "tcbSchedDequeue tcbPtr \valid_refills' scPtr\" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (wpsimp wp: threadSet_wp threadGet_wp - simp: bitmap_fun_defs setQueue_def - | intro conjI impI)+ - apply (fastforce simp: obj_at_simps valid_refills'_def opt_map_def opt_pred_def split: option.splits) - done - -crunch tcbSchedDequeue, tcbReleaseRemove - for ksCurSc[wp]: "\s. P (ksCurSc s)" - (wp: crunch_wps threadSet_wp simp: setQueue_def valid_refills'_def bitmap_fun_defs crunch_simps) - -lemma tcbReleaseRemove_valid_refills'[wp]: - "tcbReleaseRemove tcbPtr \valid_refills' scPtr\" - apply (clarsimp simp: tcbReleaseRemove_def) - apply (wpsimp wp: threadSet_wp threadGet_wp - simp: bitmap_fun_defs setReleaseQueue_def setReprogramTimer_def - | intro conjI impI)+ - apply (fastforce simp: obj_at_simps valid_refills'_def opt_map_def opt_pred_def split: option.splits)+ - done - -crunch commitTime, refillNew, refillUpdate - for ksCurSc[wp]: "\s. P (ksCurSc s)" - (wp: crunch_wps simp: crunch_simps) - -crunch commitTime - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" - (wp: crunch_wps simp: crunch_simps) - -lemma invokeSchedControlConfigureFlags_corres: - "sc_ctrl_inv_rel sc_inv sc_inv' \ - corres dc - (einvs and valid_sched_control_inv sc_inv and cur_sc_active and schact_is_rct - and ct_not_in_release_q and ct_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 sch_act_simple and valid_sc_ctrl_inv' sc_inv' and ct_active') - (invoke_sched_control_configure_flags sc_inv) - (invokeSchedControlConfigureFlags sc_inv')" - apply (cases sc_inv) - apply (rename_tac sc_ptr budget period mrefills badge flag) - apply (simp add: invoke_sched_control_configure_flags_def invokeSchedControlConfigureFlags_def) - apply (subst bind_dummy_ret_val)+ - - apply (rule_tac Q="\s. sc_at sc_ptr s" in corres_cross_add_abs_guard) - apply (fastforce intro: valid_sched_context_size_objsI - simp: sc_at_pred_n_def obj_at_def is_sc_obj_def) - apply (simp add: pred_conj_comm) - apply (rule_tac Q="\s'. sc_at' sc_ptr s'" in corres_cross_add_guard) - apply (fastforce intro: sc_at_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 (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 (rule_tac Q="\_ s. ?abs s \ sc_at sc_ptr s \ sc_at (cur_sc s) s" - and Q'="\_ s'. ?conc s' \ ex_nonz_cap_to' sc_ptr s' \ sc_at' sc_ptr s' - \ active_sc_at' (ksCurSc s') s'" - in corres_underlying_split) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply wps_conj_solves - apply (wpsimp wp: update_sc_badge_invs') - apply (fastforce dest: ex_nonz_cap_to_not_idle_sc_ptr) - apply (wpsimp wp: update_sched_context_wp) - apply (clarsimp simp: obj_at_def) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply (wps_conj_solves wp: ct_in_state_thread_state_lift' updateSchedContext_active_sc_at') - apply (clarsimp simp: updateSchedContext_def) - apply (wpsimp wp: setSchedContext_invs') - apply (fastforce dest!: sc_ko_at_valid_objs_valid_sc') - - apply (corresKsimp corres: updateSchedContext_corres) - apply (intro conjI impI allI) - apply (rename_tac abs_state conc_state n') - apply (frule_tac ptr=sc_ptr and s=abs_state in state_relation_sc_relation; simp?) - apply (clarsimp simp: sc_relation_def opt_map_def opt_pred_def is_sc_obj_def obj_at_simps - split: Structures_A.kernel_object.splits) - apply (rename_tac abs_state conc_state) - apply (frule_tac s=abs_state in state_relation_sc_replies_relation) - apply (clarsimp simp: sc_replies_relation2_def sc_replies_relation_rewrite) - apply (fastforce simp: opt_map_def opt_pred_def is_sc_obj_def obj_at_simps - split: option.splits Structures_A.kernel_object.splits) - apply (clarsimp simp: obj_at_simps) - - apply (clarsimp split del: if_split) - apply (rule_tac Q="\_ s. sc_at sc_ptr s \ ?abs s \ sc_at (cur_sc s) s" - and Q'="\_ s'. ?conc s' \ sc_at' sc_ptr s' \ active_sc_at' (ksCurSc s') s' - \ ex_nonz_cap_to' sc_ptr s'" - in corres_underlying_split) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply wps_conj_solves - apply (wpsimp wp: update_sc_sporadic_invs') - apply (fastforce dest: ex_nonz_cap_to_not_idle_sc_ptr) - apply (wpsimp wp: update_sched_context_wp) - apply (clarsimp simp: obj_at_def) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply (wps_conj_solves wp: ct_in_state_thread_state_lift' updateSchedContext_active_sc_at') - apply (clarsimp simp: updateSchedContext_def) - apply (wpsimp wp: setSchedContext_invs') - apply (fastforce dest!: sc_ko_at_valid_objs_valid_sc') - - apply (corresKsimp corres: updateSchedContext_corres) - apply (intro conjI impI allI) - apply (rename_tac abs_state conc_state n') - apply (frule_tac ptr=sc_ptr and s=abs_state in state_relation_sc_relation; simp?) - apply (clarsimp simp: sc_relation_def opt_map_def opt_pred_def is_sc_obj_def obj_at_simps - split: Structures_A.kernel_object.splits) - apply (rename_tac abs_state conc_state) - apply (frule_tac s=abs_state in state_relation_sc_replies_relation) - apply (clarsimp simp: sc_replies_relation2_def sc_replies_relation_rewrite) - apply (fastforce simp: opt_map_def opt_pred_def is_sc_obj_def obj_at_simps - split: option.splits Structures_A.kernel_object.splits) - apply (clarsimp simp: obj_at_simps) - - apply (rule_tac F="budget \ MIN_BUDGET \ period \ MAX_PERIOD \ MIN_REFILLS \ mrefills - \ budget \ period" - in corres_req) - apply simp - - apply (clarsimp simp: sc_at_sc_obj_at pred_conj_def) - apply (rule abs_ex_lift_corres) - apply (rename_tac n) - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (rule corres_guard_imp) - apply (rule_tac n=n in get_sc_corres_size) - apply fast - apply fast - - apply (rule_tac F="valid_refills_number' mrefills (minSchedContextBits + n)" in corres_req) - apply (clarsimp simp: obj_at_simps valid_refills_number'_def ko_wp_at'_def sc_const_eq - sc_relation_def) - - apply (rename_tac sc') - 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 - \ sc_at (cur_sc s) s - \ sc_not_in_release_q sc_ptr s \ sc_not_in_ready_q sc_ptr s - \ sc_ptr \ idle_sc_ptr \ sc_at sc_ptr s - \ sc_refill_max_sc_at (\rm. rm = sc_refill_max sc) sc_ptr s - \ sc_tcb_sc_at (\to. to = sc_tcb sc) sc_ptr s - \ sc_obj_at n sc_ptr s - \ (\tcb_ptr. sc_tcb_sc_at ((=) (Some tcb_ptr)) sc_ptr s \ tcb_at tcb_ptr s)" - and Q'="\_ s'. invs' s' \ sc_at' (ksCurSc s') s' - \ (\n. sc_at'_n n sc_ptr s' \ valid_refills_number' mrefills n) - \ ex_nonz_cap_to' sc_ptr s'" - and r'=dc - in corres_underlying_split) - - apply (clarsimp simp: when_def split del: if_split) - apply (rule corres_if_split; (solves \corresKsimp simp: sc_relation_def\)?) - apply (rule corres_symb_exec_l[rotated]) - apply (wpsimp wp: exs_valid_assert_opt) - apply (rule assert_opt_sp) - apply wpsimp - apply (rule_tac F="scTCB sc' = Some tcb_ptr" in corres_req) - apply (fastforce simp: sc_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF tcbReleaseRemove_corres]) - apply (clarsimp simp: sc_relation_def) - apply clarsimp - apply (rule corres_split[OF tcbSchedDequeue_corres]) - apply (rule corres_split[OF getCurSc_corres]) - apply clarsimp - apply (simp add: dc_def[symmetric]) - apply (rule commitTime_corres) - apply (wpsimp wp: hoare_drop_imps tcbReleaseRemove_valid_queues | wps)+ - 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 (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) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply wps_conj_solves - apply (wpsimp wp: commit_time_invs) - apply (wpsimp wp: commit_time_valid_sched_action hoare_vcg_imp_lift') - apply fastforce - apply (wpsimp wp: commit_time_active_scs_valid - hoare_vcg_imp_lift') - apply (fastforce intro: cur_sc_active_offset_ready_and_sufficient_implies_cur_sc_more_than_ready) - apply (wpsimp wp: commit_time_valid_ready_qs hoare_vcg_imp_lift' - tcb_sched_dequeue_valid_ready_qs hoare_vcg_disj_lift) - apply (fastforce intro: cur_sc_active_offset_ready_and_sufficient_implies_cur_sc_more_than_ready) - apply (wpsimp wp: commit_time_valid_release_q hoare_vcg_imp_lift' - tcb_release_remove_cur_sc_in_release_q_imp_zero_consumed' - | strengthen invs_valid_stateI)+ - apply (frule cur_sc_tcb_are_bound_cur_sc_in_release_q_imp_zero_consumed[rotated 2]) - apply (fastforce intro: invs_strengthen_cur_sc_tcb_are_bound) - apply fastforce - apply (fastforce simp: cur_sc_in_release_q_imp_zero_consumed_2_def) - apply (wpsimp wp: tcb_release_remove_sc_not_in_release_q) - apply (intro conjI impI; fastforce?) - apply (rule disjI2) - apply (intro conjI) - apply (fastforce dest!: invs_sym_refs sym_ref_sc_tcb - simp: heap_refs_inv_def vs_all_heap_simps obj_at_def sc_at_pred_n_def) - apply (fastforce intro: sym_refs_inj_tcb_scps) - apply (drule valid_sched_valid_release_q) - apply (clarsimp simp: vs_all_heap_simps) - apply (frule_tac ref=t in valid_release_q_no_sc_not_in_release_q) - apply (fastforce dest!: invs_sym_refs sym_ref_tcb_sc - simp: obj_at_def vs_all_heap_simps is_sc_obj_def) - apply fastforce - apply (wpsimp wp: tcb_sched_dequeue_sc_not_in_ready_q) - - apply (intro conjI impI; fastforce?) - apply (fastforce dest!: invs_sym_refs sym_ref_sc_tcb - simp: heap_refs_inv_def vs_all_heap_simps obj_at_def sc_at_pred_n_def) - apply (fastforce intro: sym_refs_inj_tcb_scps) - apply (frule invs_valid_objs) - apply (frule_tac r=sc_ptr in valid_sched_context_objsI) - apply (fastforce simp: obj_at_def) - apply (clarsimp simp: valid_sched_context_def) - apply (drule valid_sched_valid_ready_qs) - apply (clarsimp simp: vs_all_heap_simps) - apply (frule_tac ref=t in valid_ready_qs_no_sc_not_queued) - apply (fastforce dest!: invs_sym_refs sym_ref_tcb_sc - simp: obj_at_def vs_all_heap_simps is_sc_obj_def) - apply fastforce - apply wpsimp - using idle_sc_no_ex_cap apply fastforce - apply wpsimp - apply (clarsimp simp: sc_at_pred_n_def obj_at_def) - - apply (rule hoare_when_cases, simp) - apply (clarsimp simp: sc_at_pred_n_def obj_at_def) - apply (rule_tac P'="sc_tcb_sc_at (\to. to = sc_tcb sc) sc_ptr" in hoare_weaken_pre[rotated]) - apply (clarsimp simp: sc_at_pred_n_def obj_at_def) - apply (rule bind_wp_fwd_skip, wpsimp)+ - apply wpsimp - - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') - apply (fastforce dest: invs_valid_objs valid_sched_context_objsI - simp: valid_sched_context_def valid_bound_obj_def sc_at_pred_n_def obj_at_def - split: option.splits) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply (wps_conj_solves wp: commitTime_invs' tcbReleaseRemove_invs' - simp: active_sc_at'_rewrite) - - 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 - \ sc_at (cur_sc s) s - \ sc_at sc_ptr s - \ sc_tcb_sc_at (\to. to = sc_tcb sc) sc_ptr s - \ (\tcb_ptr. sc_tcb_sc_at ((=) (Some tcb_ptr)) sc_ptr s \ tcb_at tcb_ptr s)" - and Q'="\_ s'. invs' s' \ sc_at' (ksCurSc s') s'" - and r'=dc - in corres_underlying_split) - - apply (rule corres_if_split; (solves simp)?) - - apply clarsimp - apply (rule corres_guard_imp) - apply (rule_tac n=n in refillNew_corres) - apply (clarsimp simp: MIN_REFILLS_def) - apply (clarsimp simp: valid_refills_number'_def MIN_REFILLS_def) - apply fastforce - apply fastforce - - apply (rule corres_if_split) - apply (clarsimp simp: sc_relation_def) - - apply (rule corres_symb_exec_l[rotated 2, OF assert_opt_sp]; (solves wpsimp)?) - apply (rule corres_underlying_split[rotated 2, OF gts_sp isRunnable_sp]) - apply (corresKsimp corres: isRunnable_corres') - apply (fastforce simp: sc_relation_def sc_at_pred_n_def obj_at_def - intro!: tcb_at_cross Some_to_the) - - apply (rule corres_if_split; (solves simp)?) - - apply (rule_tac Q="is_active_sc' sc_ptr" in corres_cross_add_guard) - apply (fastforce simp: is_active_sc_rewrite[symmetric] sc_at_pred_n_def obj_at_def - is_sc_obj_def vs_all_heap_simps opt_map_def active_sc_def - intro!: is_active_sc'_cross) - - apply (rule corres_guard_imp) - apply (rule_tac n=n in refillUpdate_corres) - apply (clarsimp simp: MIN_REFILLS_def) - apply (clarsimp simp: valid_refills_number'_def MIN_REFILLS_def) - apply clarsimp - apply (fastforce simp: is_active_sc_rewrite[symmetric] sc_at_pred_n_def obj_at_def - vs_all_heap_simps active_sc_def) - apply clarsimp - apply (intro conjI) - 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 fastforce - - apply (rule corres_guard_imp) - apply (rule_tac n=n in refillNew_corres) - apply (clarsimp simp: MIN_REFILLS_def) - apply (clarsimp simp: valid_refills_number'_def MIN_REFILLS_def) - apply fastforce - apply fastforce - - apply (rule corres_guard_imp) - apply (rule_tac n=n in refillNew_corres) - apply (clarsimp simp: MIN_REFILLS_def) - apply (clarsimp simp: valid_refills_number'_def MIN_REFILLS_def) - apply fastforce - apply fastforce - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply (rule hoare_if) - apply (wps_conj_solves wp: refill_new_valid_sched_action refill_new_valid_release_q) - apply (wpsimp wp: refill_new_active_scs_valid) - apply (clarsimp simp: current_time_bounded_def sc_at_pred_n_def obj_at_def) - apply (wpsimp wp: refill_new_valid_ready_qs) - apply (clarsimp simp: current_time_bounded_def active_sc_def MIN_REFILLS_def) - apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - - apply (rule hoare_if) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp[OF _ gts_sp]) - apply (rule hoare_if) - - apply (wps_conj_solves wp: refill_update_valid_sched_action refill_update_invs) - apply (wpsimp wp: refill_update_active_scs_valid) - apply (clarsimp simp: current_time_bounded_def sc_at_pred_n_def obj_at_def - active_scs_valid_def vs_all_heap_simps active_sc_def) - apply (wpsimp wp: refill_update_valid_ready_qs) - apply (simp add: obj_at_kh_kheap_simps pred_map_eq_normalise) - apply (wpsimp wp: refill_update_valid_release_q) - apply (clarsimp simp: active_scs_valid_def vs_all_heap_simps) - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') - - apply (wps_conj_solves wp: refill_new_valid_sched_action refill_new_valid_release_q) - apply (wpsimp wp: refill_new_active_scs_valid) - apply (clarsimp simp: current_time_bounded_def sc_at_pred_n_def obj_at_def) - apply (wpsimp wp: refill_new_valid_ready_qs) - apply (clarsimp simp: current_time_bounded_def active_sc_def MIN_REFILLS_def) - apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - - apply (wps_conj_solves wp: refill_new_valid_sched_action refill_new_valid_release_q) - apply (wpsimp wp: refill_new_active_scs_valid) - apply (clarsimp simp: current_time_bounded_def sc_at_pred_n_def obj_at_def) - apply (wpsimp wp: refill_new_valid_ready_qs) - apply (clarsimp simp: current_time_bounded_def active_sc_def MIN_REFILLS_def) - apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply (rule hoare_if) - apply wps_conj_solves - apply (wpsimp wp: refillNew_invs') - apply (clarsimp simp: ko_wp_at'_def valid_refills_number'_def) - apply (rule hoare_if) - apply wps_conj_solves - apply (rule bind_wp[OF _ isRunnable_sp]) - apply (rule hoare_if) - apply (wpsimp wp: refillUpdate_invs') - apply (clarsimp simp: ko_wp_at'_def valid_refills_number'_def) - apply (wpsimp wp: refillNew_invs') - apply (clarsimp simp: ko_wp_at'_def valid_refills_number'_def) - apply wps_conj_solves - apply (wpsimp wp: refillNew_invs') - apply (clarsimp simp: ko_wp_at'_def valid_refills_number'_def) - - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'=dc]) - apply (rule corres_when) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_assert_opt_l) - apply (rule corres_split[OF isRunnable_corres']) - apply (clarsimp simp: sc_relation_def Some_to_the split: if_splits) - apply (rule corres_split[OF schedContextResume_corres]) - apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_if) - apply (fastforce dest!: Some_to_the simp: sc_relation_def) - apply (rule rescheduleRequired_corres) - apply (erule corres_when) - apply (rule possibleSwitchTo_corres) - apply (fastforce simp: sc_relation_def Some_to_the) - apply wpsimp - apply wpsimp - apply ((wpsimp wp: hoare_vcg_imp_lift' sched_context_resume_valid_sched_action - | strengthen valid_objs_valid_tcbs)+)[1] - apply (rule_tac Q'="\_. invs'" in hoare_post_imp, fastforce) - apply (rule schedContextResume_invs') - apply (wpsimp wp: gts_wp) - apply wpsimp - apply (rule corres_split[OF updateSchedContext_corres]) - apply (clarsimp simp: opt_map_red opt_pred_def obj_at_simps is_sc_obj) - apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - apply (clarsimp simp: sc_relation_def) - apply (fastforce dest: state_relation_sc_replies_relation sc_replies_relation_prevs_list - simp: opt_map_def obj_at_simps is_sc_obj_def - split: Structures_A.kernel_object.splits) - apply (clarsimp simp: objBits_simps) - apply (rule updateSchedContext_corres) - apply (clarsimp simp: opt_map_red opt_pred_def obj_at_simps is_sc_obj) - apply (drule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - apply (clarsimp simp: sc_relation_def) - apply (fastforce dest: state_relation_sc_replies_relation sc_replies_relation_prevs_list - simp: opt_map_def obj_at_simps is_sc_obj_def - split: Structures_A.kernel_object.splits) - apply (clarsimp simp: objBits_simps) - apply wpsimp+ - apply (fastforce simp: sc_at_pred_n_def obj_at_def schact_is_rct_def - intro: valid_sched_action_weak_valid_sched_action) - apply (fastforce intro: sc_at_cross) - done - -end - -end diff --git a/proof/refine/ARM/SchedContext_R.thy b/proof/refine/ARM/SchedContext_R.thy deleted file mode 100644 index 90e87133c7..0000000000 --- a/proof/refine/ARM/SchedContext_R.thy +++ /dev/null @@ -1,860 +0,0 @@ -(* - * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) - * - * SPDX-License-Identifier: GPL-2.0-only - *) - -theory SchedContext_R -imports VSpace_R -begin - -lemma live_sc'_scConsumed_update[simp]: - "live_sc' (scConsumed_update f koc) = live_sc' koc" - by (clarsimp simp: live_sc'_def) - -lemma live_sc'_scRefills_update[simp]: - "live_sc' (scRefills_update f koc) = live_sc' koc" - by (clarsimp simp: live_sc'_def) - -lemma live_sc'_scRefillCount_update[simp]: - "live_sc' (scRefillCount_update f koc) = live_sc' koc" - by (clarsimp simp: live_sc'_def) - -lemma valid_sched_context'_updates[simp]: - "\f. valid_sched_context' sc' (ksReprogramTimer_update f s) = valid_sched_context' sc' s" - "\f. valid_sched_context' sc' (ksReleaseQueue_update f s) = valid_sched_context' sc' s" - by (auto simp: valid_sched_context'_def valid_bound_obj'_def split: option.splits) - -lemma valid_sched_context'_scConsumed_update[simp]: - "valid_sched_context' (scConsumed_update f ko) s = valid_sched_context' ko s" - by (clarsimp simp: valid_sched_context'_def) - -lemma valid_sched_context_size'_scConsumed_update[simp]: - "valid_sched_context_size' (scConsumed_update f sc') = valid_sched_context_size' sc'" - by (clarsimp simp: valid_sched_context_size'_def objBits_simps) - -lemma readSchedContext_SomeD: - "readSchedContext scp s = Some sc' - \ ksPSpace s scp = Some (KOSchedContext sc')" - by (clarsimp simp: readSchedContext_def asks_def obj_at'_def projectKOs - dest!: readObject_misc_ko_at') - -lemma no_ofail_readSchedContext: - "no_ofail (sc_at' p) (readSchedContext p)" - unfolding readSchedContext_def by wpsimp - -lemma sym_refs_tcbSchedContext: - "\ko_at' tcb tcbPtr s; sym_refs (state_refs_of' s); tcbSchedContext tcb = Some scPtr\ - \ obj_at' (\sc. scTCB sc = Some tcbPtr) scPtr s" - apply (drule (1) sym_refs_obj_atD') - apply (auto simp: state_refs_of'_def ko_wp_at'_def obj_at'_def - refs_of_rev' projectKOs) - 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'\" - apply (simp add: invs'_def valid_dom_schedule'_def) - apply (wpsimp wp: valid_pde_mappings_lift' untyped_ranges_zero_lift simp: cteCaps_of_def o_def) - done - -lemma setSchedContext_active_sc_at': - "\active_sc_at' scPtr' and K (scPtr' = scPtr \ 0 < scRefillMax sc)\ - setSchedContext scPtr sc - \\rv s. active_sc_at' scPtr' s\" - apply (simp add: active_sc_at'_def obj_at'_real_def setSchedContext_def) - apply (wpsimp wp: setObject_ko_wp_at) - apply (clarsimp simp: ko_wp_at'_def obj_at'_real_def) - done - -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'\" - apply (simp add: updateSchedContext_def) - by (wpsimp wp: setSchedContext_invs') - -lemma sym_refs_sc_trivial_update: - "ko_at' ko scPtr s - \ sym_refs (\a. if a = scPtr - then get_refs SCNtfn (scNtfn ko) \ - get_refs SCTcb (scTCB ko) \ - get_refs SCYieldFrom (scYieldFrom ko) \ - get_refs SCReply (scReply ko) - else state_refs_of' s a) - = sym_refs (state_refs_of' s)" - apply (rule arg_cong[where f=sym_refs]) - apply (rule ext) - by (clarsimp simp: state_refs_of'_def obj_at'_real_def ko_wp_at'_def projectKO_sc) - -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 projectKO_sc) - -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'\" - 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 projectKO_sc) - done - -lemma invs'_ko_at_valid_sched_context': - "\invs' s; ko_at' ko scPtr s\ \ valid_sched_context' ko s \ valid_sched_context_size' ko" - apply (drule invs_valid_objs') - apply (drule (1) sc_ko_at_valid_objs_valid_sc', simp) - done - -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 projectKO_eq projectKO_sc live_sc'_def) - apply (frule (1) invs'_ko_at_valid_sched_context', simp) - done - -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma schedContextUpdateConsumed_corres: - "corres (=) (sc_at scp) (sc_at' scp) - (sched_context_update_consumed scp) - (schedContextUpdateConsumed scp)" - apply (clarsimp simp: sched_context_update_consumed_def schedContextUpdateConsumed_def) - apply (simp add: maxTicksToUs_def ticksToUs_def) - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (corresKsimp corres: get_sc_corres) - apply (rename_tac abs_sc conc_sc) - apply (rule corres_if_split) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_underlying_split) - apply (rule corres_guard_imp) - apply clarsimp - apply (rule_tac f="\sc. sc\sc_consumed := sc_consumed abs_sc - max_ticks_to_us\" - and f'="\sc'. scConsumed_update (\_. scConsumed conc_sc - maxTicksToUs) sc'" - in setSchedContext_update_sched_context_no_stack_update_corres) - apply (clarsimp simp: sc_relation_def maxTicksToUs_def) - apply (clarsimp simp: sc_relation_def) - apply (clarsimp simp: sc_relation_def objBits_simps) - apply (clarsimp simp: sc_relation_def) - apply (clarsimp simp: obj_at_def) - apply (clarsimp simp: obj_at_simps) - apply (clarsimp simp: maxTicksToUs_def ticksToUs_def) - apply wpsimp - apply wpsimp - apply (rule corres_underlying_split) - apply (rule corres_guard_imp) - apply clarsimp - apply (rule_tac f="\sc. sc\sc_consumed := 0\" - and f'="\sc'. scConsumed_update (\_. 0) sc'" - in setSchedContext_update_sched_context_no_stack_update_corres) - apply (clarsimp simp: sc_relation_def maxTicksToUs_def) - apply (clarsimp simp: sc_relation_def) - apply (clarsimp simp: sc_relation_def objBits_simps) - apply (clarsimp simp: sc_relation_def) - apply (clarsimp simp: obj_at_def) - apply (clarsimp simp: obj_at_simps) - apply (clarsimp simp: maxTicksToUs_def ticksToUs_def sc_relation_def) - apply wpsimp - apply wpsimp - done - -end - -crunch sched_context_update_consumed - for in_user_Frame[wp]: "in_user_frame buffer" - -lemma schedContextUpdateConsumed_valid_ipc_buffer_ptr'[wp]: - "schedContextUpdateConsumed scp \valid_ipc_buffer_ptr' x\" - 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) - apply (clarsimp elim!: if_live_then_nonz_capE' simp: obj_at'_def projectKOs ko_wp_at'_def) - done - -lemma schedContextUpdateConsumed_valid_idle'[wp]: - "schedContextUpdateConsumed scp \valid_idle'\" - apply (wpsimp simp: schedContextUpdateConsumed_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 - apply wpsimp - apply (clarsimp dest!: ko_at_state_refs_ofD' elim!: rsubst[where P=P]) - apply (rule ext; clarsimp) - done - -lemma schedContextUpdateConsumed_objs'[wp]: - "schedContextUpdateConsumed sc \valid_objs'\" - unfolding schedContextUpdateConsumed_def - apply wpsimp - apply (drule (1) ko_at_valid_objs'_pre) - apply (clarsimp simp: valid_obj'_def valid_sched_context'_def valid_sched_context_size'_def) - done - -lemma schedContextUpdateConsumed_sym_refs_lis_refs_of_replies'[wp]: - "schedContextUpdateConsumed scPtr \\s. sym_refs (list_refs_of_replies' s)\" - apply (clarsimp simp: schedContextUpdateConsumed_def) - apply wpsimp - apply (clarsimp simp: opt_map_def o_def) - done - -crunch schedContextUpdateConsumed - for aligned'[wp]: "pspace_aligned'" - and distinct'[wp]:"pspace_distinct'" - and bounded'[wp]: "pspace_bounded'" - 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 it'[wp]: "\s. P (ksIdleThread s)" - 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 valid_queues'[wp]: valid_queues' - 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)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - and ctes_of[wp]: "\s. P (ctes_of s)" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - and ct_not_inQ[wp]: ct_not_inQ - and valid_pde_mappings'[wp]: valid_pde_mappings' - and valid_queues[wp]: valid_queues - 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' - and st_tcb_at'[wp]: "\s. P (st_tcb_at' P' t s)" - (wp: crunch_wps simp: crunch_simps) - -global_interpretation schedContextUpdateConsumed: typ_at_all_props' "schedContextUpdateConsumed scPtr" - by typ_at_props' - -lemma schedContextUpdateConsumed_if_unsafe_then_cap'[wp]: - "schedContextUpdateConsumed scPtr \if_unsafe_then_cap'\" - apply (clarsimp simp: schedContextUpdateConsumed_def) - apply (wpsimp wp: threadSet_ifunsafe' threadGet_wp) - done - -lemma schedContextUpdateConsumed_invs'[wp]: - "schedContextUpdateConsumed scPtr \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 cur_tcb_lift - untyped_ranges_zero_lift - 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)\ - 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 projectKOs scBits_simps objBits_simps opt_map_red opt_pred_def) - -lemma valid_tcb'_tcbYieldTo_update: - "valid_tcb' tcb s \ valid_tcb' (tcbYieldTo_update Map.empty tcb) s" - by (simp add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def ) - -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 - | strengthen valid_tcb'_tcbYieldTo_update)+ - apply normalise_obj_at' - apply (rename_tac ko) - apply (rule_tac x=ko in exI) - apply clarsimp - apply (frule (1) tcb_ko_at_valid_objs_valid_tcb') - by (fastforce simp: valid_obj'_def opt_map_def obj_at_simps valid_tcb'_def - valid_sched_context'_def valid_sched_context_size'_def opt_pred_def) - -lemma schedContextCancelYieldTo_valid_mdb'[wp]: - "schedContextCancelYieldTo tptr \valid_mdb'\" - apply (clarsimp simp: schedContextCancelYieldTo_def updateSchedContext_def threadSet_def) - apply (wpsimp wp: getObject_tcb_wp hoare_drop_imps hoare_vcg_ex_lift threadGet_wp) - apply (fastforce simp: obj_at'_def projectKOs tcb_cte_cases_def) - 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) - apply (fastforce simp: obj_at'_def projectKOs) - 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: threadSet_iflive' setSchedContext_iflive' hoare_vcg_imp_lift' hoare_vcg_all_lift - threadGet_wp) - by (fastforce elim: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def live_sc'_def projectKOs) - -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) - apply (fastforce simp: obj_at'_def projectKOs) - 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 projectKOs idle_tcb'_def) - done - -lemma schedContextCancelYieldTo_valid_release_queue[wp]: - "schedContextCancelYieldTo tptr \valid_release_queue\" - apply (clarsimp simp: schedContextCancelYieldTo_def updateSchedContext_def) - apply (wpsimp wp: threadSet_valid_release_queue threadGet_wp) - apply (fastforce simp: obj_at'_def projectKOs) - 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) - apply (fastforce simp: obj_at'_def projectKOs) - done - -lemma schedContextCancelYieldTo_valid_pde_mappings'[wp]: - "schedContextCancelYieldTo tptr \valid_pde_mappings'\" - apply (clarsimp simp: schedContextCancelYieldTo_def setSchedContext_def updateSchedContext_def) - apply (wpsimp wp: threadGet_wp) - apply (fastforce simp: valid_pde_mappings'_def obj_at'_def projectKOs ps_clear_upd) - done - -lemma schedContextCancelYieldTo_cur_tcb'[wp]: - "schedContextCancelYieldTo tptr \cur_tcb'\" - apply (wpsimp simp: schedContextCancelYieldTo_def updateSchedContext_def - wp: threadSet_cur threadGet_wp) - apply (fastforce simp: obj_at'_def projectKOs) - done - -lemma schedContextCancelYeldTo_valid_release_queue'[wp]: - "schedContextCancelYieldTo t \valid_release_queue'\" - apply (clarsimp simp: schedContextCancelYieldTo_def updateSchedContext_def) - apply (rule bind_wp[OF _ threadGet_sp]) - apply (rule hoare_when_cases; (solves \wpsimp\)?) - apply (rule_tac Q'="\_. valid_release_queue'" in bind_wp_fwd) - apply wpsimp - apply (wpsimp wp: threadSet_valid_release_queue' setObject_tcb_wp) - apply (clarsimp simp: valid_release_queue'_def obj_at'_def) - done - -crunch schedContextCancelYieldTo - 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 ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - and list_refs_of_replies[wp]: "\s. sym_refs (list_refs_of_replies' s)" - 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 sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - 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 valid_queues[wp]: valid_queues - and valid_queues'[wp]: valid_queues' - 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)" - and ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" - and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - and ctes_of[wp]: "\s. P (ctes_of s)" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - and reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" - and valid_replies' [wp]: valid_replies' - and st_tcb_at'[wp]: "\s. P (st_tcb_at' P' t s)" - (wp: crunch_wps threadSet_pred_tcb_no_state simp: crunch_simps updateSchedContext_def comp_def) - -global_interpretation schedContextCancelYieldTo: typ_at_all_props' "schedContextCancelYieldTo t" - by typ_at_props' - -lemma schedContextCancelYieldTo_invs': - "schedContextCancelYieldTo t \invs'\" - apply (simp add: invs'_def valid_pspace'_def setSchedContext_def valid_dom_schedule'_def) - apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift - untyped_ranges_zero_lift - simp: cteCaps_of_def o_def) - apply (fastforce simp: inQ_def valid_queues_def valid_queues_no_bitmap_def) - done - -crunch schedContextCompleteYieldTo - for ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - and tcb_at'[wp]: "\s. Q (tcb_at' t s)" - (simp: crunch_simps wp: crunch_wps) - -crunch setConsumed - for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" - (wp: crunch_wps simp: crunch_simps) - -lemma setConsumed_invs': - "setConsumed scp buffer \invs'\" - apply (simp add: setConsumed_def cur_tcb'_asrt_def) - apply (wpsimp wp: schedContextUpdateConsumed_invs' - simp: cur_tcb'_def - | wps)+ - done - -lemma schedContextCompleteYieldTo_invs'[wp]: - "schedContextCompleteYieldTo thread \invs'\" - unfolding schedContextCompleteYieldTo_def - by (wpsimp wp: schedContextCancelYieldTo_invs' setConsumed_invs' - hoare_drop_imp hoare_vcg_if_lift2 - simp: sch_act_simple_def) - -lemma setConsumed_corres: - "corres dc (case_option \ in_user_frame buf and sc_at scp - and cur_tcb and pspace_aligned and pspace_distinct) - (case_option \ valid_ipc_buffer_ptr' buf and sc_at' scp) - (set_consumed scp buf) - (setConsumed scp buf)" - apply add_cur_tcb' - apply (simp add: set_consumed_def setConsumed_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: cur_tcb'_asrt_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF schedContextUpdateConsumed_corres]) - apply (rule corres_split[OF getCurThread_corres], simp) - apply (rule corres_split[OF setMRs_corres setMessageInfo_corres]) - by (wpsimp wp: hoare_case_option_wp simp: setTimeArg_def cur_tcb_def cur_tcb'_def | wps)+ - -lemma get_tcb_yield_to_corres: - "corres (=) (pspace_aligned and pspace_distinct and tcb_at t) \ - (get_tcb_obj_ref tcb_yield_to t) (threadGet tcbYieldTo t)" - apply (rule_tac Q="tcb_at' t" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD elim!: tcb_at_cross) - apply (simp add: get_tcb_obj_ref_def getBoundNotification_def) - apply (rule corres_guard_imp) - apply (rule threadGet_corres) - apply (simp add: tcb_relation_def)+ - done - -lemma tcb_yield_to_update_corres: - "corres dc (pspace_aligned and pspace_distinct and tcb_at t) \ - (set_tcb_obj_ref tcb_yield_to_update t yt) (threadSet (tcbYieldTo_update (\_. yt)) t)" - apply (rule_tac Q="tcb_at' t" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD elim!: tcb_at_cross) - apply (rule corres_guard_imp) - apply (rule set_tcb_obj_ref_corres; simp add: tcb_relation_def) - apply simp+ - done - -lemma sc_relation_tcb_yield_to_update: - "sc_relation sc n sc' - \ sc_relation (sc_yield_from_update Map.empty (sc)) n (scYieldFrom_update Map.empty sc')" - by (clarsimp simp: sc_relation_def) - -lemma schedContextCancelYieldTo_corres: - "corres dc - (pspace_aligned and pspace_distinct and valid_objs and tcb_at t) - \ - (sched_context_cancel_yield_to t) - (schedContextCancelYieldTo t)" (is "corres _ ?abs_guard _ _ _") - apply (rule_tac Q="tcb_at' t" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD elim!: tcb_at_cross) - apply (clarsimp simp: sched_context_cancel_yield_to_def schedContextCancelYieldTo_def - updateSchedContext_def comp_def maybeM_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_tcb_yield_to_corres _ gyt_sp threadGet_sp - , where Q="?abs_guard"]) - defer - apply (simp add: obj_at_def is_tcb_def) - apply simp - apply (case_tac scPtrOpt; clarsimp?) - apply (rule corres_guard_imp) - apply (rule corres_split[OF update_sc_no_reply_stack_update_corres]) - apply (simp add: sc_relation_tcb_yield_to_update) - apply simp - apply (clarsimp simp: objBits_simps') - apply simp - apply (rule tcb_yield_to_update_corres) - apply wpsimp - apply wpsimp - apply (clarsimp simp: valid_objs_def obj_at_def is_tcb_def) - apply (fastforce simp: valid_obj_def valid_tcb_def valid_bound_obj_def pred_tcb_at_def obj_at_def - dest!: bspec - split: option.splits) - apply clarsimp - done - -lemma schedContextCompleteYieldTo_corres: - "corres dc (invs and tcb_at thread) (invs' and tcb_at' thread) - (complete_yield_to thread) (schedContextCompleteYieldTo thread)" - apply add_cur_tcb' - apply (simp add: complete_yield_to_def schedContextCompleteYieldTo_def) - apply (subst maybeM_when) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_tcb_yield_to_corres], simp) - apply (rule corres_when2[OF refl]) - apply (clarsimp, wpfix) - apply (rule corres_split[OF lookupIPCBuffer_corres], simp) - apply (rule corres_split[OF setConsumed_corres]) - apply (rule schedContextCancelYieldTo_corres[simplified dc_def]) - apply wpsimp - apply wpsimp - apply wpsimp - apply wpsimp - apply (wpsimp wp: get_tcb_obj_ref_wp) - apply (wpsimp wp: threadGet_wp) - 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 - dest: invs_valid_objs) - apply (clarsimp simp: invs'_def valid_pspace'_def cur_tcb'_def - obj_at'_real_def ko_wp_at'_def pred_tcb_at'_def projectKO_tcb) - apply (subgoal_tac "valid_tcb' obj s", clarsimp simp: valid_tcb'_def cur_tcb'_def) - apply (fastforce simp: obj_at'_real_def ko_wp_at'_def) - apply (fastforce simp: valid_objs'_def valid_obj'_def) - done - -crunch schedContextDonate - for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - -global_interpretation schedContextDonate: typ_at_all_props' "schedContextDonate scPtr tcbPtr" - by typ_at_props' - -crunch schedContextDonate - for aligned'[wp]: "pspace_aligned'" - and distinct'[wp]:"pspace_distinct'" - and it'[wp]: "\s. P (ksIdleThread s)" - and irq_node'[wp]: "\s. P (irq_node' s)" - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and ct'[wp]: "\s. P (ksCurThread s)" - and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - and cte_wp_at'[wp]: "cte_wp_at' P p" - -crunch schedContextDonate - for ctes_of[wp]: "\s. P (ctes_of s)" - -crunch schedContextDonate, schedContextUnbindAllTCBs, unbindFromSC, - schedContextSetInactive, schedContextUnbindYieldFrom, schedContextUnbindReply - for st_tcb_at'[wp]: "\s. P (st_tcb_at' P' p s)" - (simp: crunch_simps wp: threadSet_pred_tcb_no_state crunch_wps) - -lemma setSchedContext_ct_in_state'[wp]: - "setSchedContext ptr sc \ct_in_state' P\" - by (rule ct_in_state_thread_state_lift'; wpsimp) - -crunch setSchedContext - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - (wp: weak_sch_act_wf_lift) - -lemma schedContextDonate_weak_sch_act_wf[wp]: - "schedContextDonate scPtr tcbPtr \\s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp only: schedContextDonate_def) - apply (wpsimp wp: threadSet_weak_sch_act_wf) - apply (rule_tac Q'="\_ s. weak_sch_act_wf (ksSchedulerAction s) s" in hoare_strengthen_post[rotated], fastforce) - apply (wpsimp wp: threadSet_weak_sch_act_wf) - apply wpsimp+ - done - -lemma schedContextDonate_valid_objs': - "\valid_objs' and tcb_at' tcbPtr\ - schedContextDonate scPtr tcbPtr - \\_. valid_objs'\" - (is "valid ?pre _ _") - apply (clarsimp simp: schedContextDonate_def) - apply (rule bind_wp[OF _ get_sc_sp'], rename_tac sc) - apply (rule_tac P'="?pre and valid_sched_context' sc and K (valid_sched_context_size' sc) and sc_at' scPtr" - in hoare_weaken_pre[rotated]) - apply (fastforce simp: sc_ko_at_valid_objs_valid_sc' obj_at'_def) - apply (rule bind_wp_fwd_skip) - apply (rule hoare_when_cases, clarsimp) - apply (rule bind_wp_fwd_skip, wpsimp wp: tcbSchedDequeue_valid_objs') - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp_fwd_skip, wpsimp wp: threadSet_valid_objs') - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) - apply wpsimp - apply (rule_tac Q'="\_. ?pre and sc_at' scPtr" in bind_wp_fwd) - apply (wpsimp wp: set_sc_valid_objs') - apply (clarsimp simp: valid_sched_context'_def valid_sched_context_size'_def - sc_size_bounds_def objBits_def objBitsKO_def) - apply (wpsimp wp: threadSet_valid_objs') - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) - done - -lemma tcbReleaseRemove_list_refs_of_replies'[wp]: - "tcbReleaseRemove tcbPtr \\s. P (list_refs_of_replies' s)\" - by (wpsimp simp: tcbReleaseRemove_def) - -lemma schedContextDonate_list_refs_of_replies' [wp]: - "schedContextDonate scPtr tcbPtr \\s. P (list_refs_of_replies' s)\" - unfolding schedContextDonate_def - by (wpsimp simp: comp_def | rule hoare_strengthen_post[where Q'="\_ s. P (list_refs_of_replies' s)"])+ - -lemma schedContextDonate_sch_act_wf [wp]: - "schedContextDonate scPtr tcbPtr \\s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp only: schedContextDonate_def) - apply (wpsimp wp: threadSet_sch_act threadSet_wp) - apply (rule_tac Q'="\_ s. sch_act_wf (ksSchedulerAction s) s" in hoare_strengthen_post[rotated]) - apply (fastforce simp: sch_act_wf_def ct_in_state'_def tcb_in_cur_domain'_def - pred_tcb_at'_def obj_at'_def projectKO_eq projectKO_tcb - split: if_splits) - apply wpsimp+ - done - -lemma schedContextDonate_valid_idle': - "\\s. valid_idle' s \ tcbPtr \ idle_thread_ptr \ - obj_at' (\sc. scTCB sc \ Some idle_thread_ptr) scPtr s\ - schedContextDonate scPtr tcbPtr - \\_. valid_idle'\" - apply (simp only: schedContextDonate_def) - apply (wp threadSet_idle' setSchedContext_valid_idle') - apply (rule_tac Q'="\_ s. tcbPtr \ ksIdleThread s" in hoare_strengthen_post; wpsimp) - apply (rule_tac Q'="\_ s. valid_idle' s \ scPtr \ idle_sc_ptr \ tcbPtr \ ksIdleThread s" - in hoare_strengthen_post; wpsimp) - apply (wpsimp wp: threadSet_idle' hoare_drop_imps threadSet_idle') - apply (rule_tac Q'="\_ s. valid_idle' s \ scPtr \ idle_sc_ptr \ - tcbPtr \ ksIdleThread s \ from \ ksIdleThread s" - in hoare_strengthen_post) - apply wpsimp+ - apply (auto simp: obj_at'_def projectKO_eq projectKO_sc valid_idle'_def) - done - -lemma schedContextDonate_bound_tcb_sc_at[wp]: - "\\\ schedContextDonate scPtr tcbPtr \\_. obj_at' (\a. \y. scTCB a = Some y) scPtr\" - unfolding schedContextDonate_def - by (wpsimp wp: set_sc'.obj_at') - -lemma updateSchedContext_obj_at'[wp]: - "\sc'. objBits sc' = objBits (f' sc'::sched_context) \ - updateSchedContext scp f' \\s. P (sc_at' p s)\" - apply (wpsimp simp: updateSchedContext_def wp: set_sc'.set_wp) - apply (clarsimp simp: obj_at'_def ps_clear_upd projectKOs objBits_simps) - done - -(* corres rules for updateRefillHd / updateRefillTl *) - -(* using the abstract 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)) (obj_bits (the (kheap s ptr)) - min_sched_context_bits) (the ((scs_of' s') ptr))" - supply projection_rewrites[simp] - apply (clarsimp simp: 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) - -(* 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: 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)))" - supply projection_rewrites[simp] opt_map_red[simp] - apply (clarsimp simp: obj_at_simps is_sc_obj) - by (fastforce dest!: sc_replies_relation_prevs_list[OF state_relation_sc_replies_relation]) - -lemma sc_relation_updateRefillHd: - "\sc_relation sc n sc'; \refill'. f (refill_map refill') = refill_map (f' refill'); - sc_valid_refills' sc'\ - \ sc_relation (sc_refills_update (\refills. f (hd refills) # tl refills) sc) n - (scRefills_update (\_. updateAt (scRefillHead sc') (scRefills sc') f') sc')" - apply (prop_tac "wrap_slice (scRefillHead sc') (scRefillCount sc') (scRefillMax sc') (scRefills sc') \ []") - apply (clarsimp intro!: neq_Nil_lengthI) - apply (clarsimp simp: sc_relation_def refills_map_def tl_map hd_map) - apply (subst hd_Cons_tl[where xs="wrap_slice _ _ _ (updateAt _ _ _)", symmetric]) - apply (clarsimp intro!: neq_Nil_lengthI) - apply simp - apply (subst hd_wrap_slice; (simp add: updateAt_index tl_wrap_slice neq_Nil_lengthI)?)+ - apply (case_tac "Suc (scRefillHead sc') < scRefillMax sc'") - apply (prop_tac "wrap_slice (Suc (scRefillHead sc')) (scRefillCount sc' - Suc 0) - (scRefillMax sc') (updateAt (scRefillHead sc') (scRefills sc') f') - = wrap_slice (Suc (scRefillHead sc')) (scRefillCount sc' - Suc 0) (scRefillMax sc') (scRefills sc')") - apply (subst wrap_slice_updateAt_eq[symmetric]; clarsimp) - apply (fastforce simp: neq_Nil_lengthI)+ - apply (clarsimp simp: not_less le_eq_less_or_eq[where m="scRefillMax sc'" for sc']) - done - -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')" - supply projection_rewrites[simp] - apply (clarsimp simp: update_refill_hd_def updateRefillHd_def) - apply (rule corres_guard_imp) - apply (rule updateSchedContext_corres_gen[where P=\ - and P'="valid_refills' sc_ptr"]) - apply (clarsimp, drule (2) state_relation_sc_relation) - apply (fastforce simp: is_sc_obj obj_at_simps opt_map_red opt_pred_def valid_refills'_def - elim!: sc_relation_updateRefillHd) - apply (fastforce simp: obj_at_simps is_sc_obj opt_map_red - dest!: state_relation_sc_replies_relation_sc) - by (clarsimp simp: objBits_simps)+ - -lemma sc_relation_updateRefillTl: - "\ sc_relation sc n sc'; \refill'. f (refill_map refill') = refill_map (f' refill'); - sc_valid_refills' sc'\ - \ sc_relation - (sc_refills_update (\refills. butlast refills @ [f (last refills)]) sc) n - (scRefills_update (\_. updateAt (refillTailIndex sc') (scRefills sc') f') sc')" - apply (prop_tac "scRefills sc' \ []") - apply fastforce - apply (clarsimp simp: sc_relation_def refills_map_def) - apply (simp add: snoc_eq_iff_butlast) - apply (prop_tac "wrap_slice (scRefillHead sc') (scRefillCount sc') (scRefillMax sc') - (scRefills sc') \ []") - apply (clarsimp intro!: neq_Nil_lengthI) - apply (prop_tac "wrap_slice (scRefillHead sc') (scRefillCount sc') (scRefillMax sc') - (updateAt (refillTailIndex sc') (scRefills sc') f') \ []") - apply (clarsimp intro!: neq_Nil_lengthI) - apply clarsimp - apply (prop_tac "wrap_slice (scRefillHead sc') (scRefillCount sc' - Suc 0) - (scRefillMax sc') - (updateAt (refillTailIndex sc') (scRefills sc') f') = wrap_slice (scRefillHead sc') (scRefillCount sc' - Suc 0) - (scRefillMax sc') - (scRefills sc')") - apply (subst wrap_slice_updateAt_eq[symmetric]; (simp add: refillTailIndex_def Let_def split: if_split_asm)?) - apply (intro conjI impI; linarith) - apply (clarsimp simp: butlast_map butlast_wrap_slice) - apply (clarsimp simp: last_map) - apply (subst last_wrap_slice; simp?)+ - apply (intro conjI impI) - apply (subst updateAt_index; simp add: refillTailIndex_def)+ - done - -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')" - supply projection_rewrites[simp] - apply (clarsimp simp: update_refill_tl_def updateRefillTl_def) - apply (rule corres_guard_imp) - apply (rule updateSchedContext_corres_gen[where P=\ and P'="valid_refills' scPtr"]) - apply (clarsimp, drule (2) state_relation_sc_relation) - apply (clarsimp simp: is_sc_obj obj_at_simps is_active_sc'_def valid_refills'_def) - apply (clarsimp simp: sc_relation_updateRefillTl opt_map_red opt_pred_def) - apply (fastforce simp: obj_at_simps is_sc_obj opt_map_red - dest!: state_relation_sc_replies_relation_sc) - by (clarsimp simp: objBits_simps)+ - -lemma readRefillReady_no_ofail[wp]: - "no_ofail (sc_at' t) (readRefillReady t)" - apply (clarsimp simp: readRefillReady_def readSchedContext_def) - apply (wpsimp wp: no_ofail_readCurTime) - done - -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma get_sc_released_corres: - "corres (=) (active_scs_valid and sc_at sc_ptr) (valid_objs' and sc_at' sc_ptr) - (get_sc_released sc_ptr) (scReleased sc_ptr)" - apply (simp add: get_sc_released_def scReleased_def scActive_def refillReady_def) - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (corresKsimp corres: get_sc_corres) - apply (rename_tac sc') - apply (rule corres_symb_exec_l[rotated 2, OF gets_sp]; (solves wpsimp)?) - apply (rule corres_symb_exec_r[rotated, OF gets_the_sp]; (solves wpsimp)?) - apply (wpsimp wp: no_ofail_gets_the readRefillReady_no_ofail) - apply (clarsimp simp: sc_released_def readRefillReady_def readSchedContext_def - dest!: readObject_misc_ko_at') - apply (subgoal_tac "sc_active sc = (0 < scRefillMax sc')") - apply (case_tac "sc_active sc"; clarsimp) - apply (drule active_scs_validE[where scp=sc_ptr, rotated]) - apply (clarsimp simp: is_active_sc_def sc_at_ppred_def obj_at_def) - apply (drule_tac s'=s' in refill_hd_relation2) - apply (fastforce simp: refill_ready_def refill_sufficient_def refill_capacity_def - kernelWCETTicks_def vs_all_heap_simps cfg_valid_refills_def - rr_valid_refills_def sp_valid_refills_def obj_at_def - valid_obj'_def obj_at'_def projectKOs readCurTime_def ogets_def - state_relation_def - dest!: readObject_ko_at'_sc - split: if_splits)+ - apply (clarsimp simp: refill_ready_def readCurTime_def ogets_def sc_relation_def active_sc_def) - done - -end - -end diff --git a/proof/refine/ARM/Schedule_R.thy b/proof/refine/ARM/Schedule_R.thy index d385b0f81c..105b19a1bb 100644 --- a/proof/refine/ARM/Schedule_R.thy +++ b/proof/refine/ARM/Schedule_R.thy @@ -5,121 +5,20 @@ *) theory Schedule_R -imports SchedContext_R InterruptAcc_R +imports VSpace_R begin -crunch scReleased, getReprogramTimer, getCurTime, getRefills, getReleaseQueue, refillSufficient, - refillReady, isRoundRobin - for inv[wp]: P - -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare hoare_weak_lift_imp[wp_split del] (* Levity: added (20090713 10:04:12) *) declare sts_rel_idle [simp] -crunch refillHeadOverlappingLoop, headInsufficientLoop, setRefillHd - for valid_queues[wp]: valid_queues - and valid_queues'[wp]: valid_queues' - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - and typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n T p s)" - (wp: crunch_wps) - -crunch tcbReleaseDequeue - for sc_at'_n[wp]: "\s. Q (sc_at'_n n p s)" - (simp: crunch_simps wp: crunch_wps) - -crunch refillUnblockCheck, refillBudgetCheck, ifCondRefillUnblockCheck, refillBudgetCheckRoundRobin - for valid_queues[wp]: valid_queues - and valid_queues'[wp]: valid_queues' - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - and typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. Q (sc_at'_n n p s)" - and 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 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' - 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 irqs_masked'[wp]: irqs_masked' - and valid_pde_mappings'[wp]: valid_pde_mappings' - and pspace_domain_valid[wp]: pspace_domain_valid - and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" - 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)" - (wp: crunch_wps valid_dom_schedule'_lift simp: crunch_simps refillSingle_def) - -crunch commitTime, refillNew, refillUpdate - 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 simp: crunch_simps) - -end - -global_interpretation tcbReleaseDequeue: typ_at_all_props' tcbReleaseDequeue - by typ_at_props' - -global_interpretation refillPopHead: typ_at_all_props' "refillPopHead scPtr" - by typ_at_props' - -global_interpretation updateRefillTl: typ_at_all_props' "updateRefillTl scPtr f" - by typ_at_props' - -global_interpretation handleOverrunLoopBody: typ_at_all_props' "handleOverrunLoopBody usage" - by typ_at_props' - -global_interpretation handleOverrunLoop: typ_at_all_props' "handleOverrunLoop usage" - by typ_at_props' - -global_interpretation scheduleUsed: typ_at_all_props' "scheduleUsed scPtr new" - by typ_at_props' - -global_interpretation updateRefillHd: typ_at_all_props' "updateRefillHd scPtr f" - by typ_at_props' - -global_interpretation mergeRefills: typ_at_all_props' "mergeRefills scPtr" - by typ_at_props' - -global_interpretation setRefillHd: typ_at_all_props' "setRefillHd scPtr v" - by typ_at_props' - -global_interpretation nonOverlappingMergeRefills: typ_at_all_props' "nonOverlappingMergeRefills scPtr" - by typ_at_props' - -global_interpretation refillBudgetCheck: typ_at_all_props' "refillBudgetCheck usage" - by typ_at_props' - -global_interpretation refillBudgetCheckRoundRobin: typ_at_all_props' "refillBudgetCheckRoundRobin usage" - by typ_at_props' - -global_interpretation commitTime: typ_at_all_props' "commitTime" - by typ_at_props' - -global_interpretation refillNew: typ_at_all_props' "refillNew scPtr maxRefills budget period" - by typ_at_props' - -global_interpretation refillUpdate: typ_at_all_props' "refillUpdate scPtr newPeriod newBudget newMaxRefills" - by typ_at_props' - -global_interpretation updateSchedContext: typ_at_all_props' "updateSchedContext scPtr f" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) +lemma corres_if2: + "\ G = G'; G \ corres r P P' a c; \ G' \ corres r Q Q' b d \ + \ corres r (if G then P else Q) (if G' then P' else Q') (if G then a else b) (if G' then c else d)" + by simp lemma findM_awesome': assumes x: "\x xs. suffix (x # xs) xs' \ @@ -146,7 +45,7 @@ proof - apply (rule corres_guard_imp) apply (rule corres_split[OF x]) apply assumption - apply (rule corres_if3) + apply (rule corres_if2) apply (case_tac ra, clarsimp+)[1] apply (rule corres_trivial, clarsimp) apply (case_tac ra, simp_all)[1] @@ -159,6 +58,9 @@ qed lemmas findM_awesome = findM_awesome' [OF _ _ _ suffix_order.refl] +(* Levity: added (20090721 10:56:29) *) +declare objBitsT_koTypeOf [simp] + lemma arch_switchToThread_corres: "corres dc (valid_arch_state and valid_objs and valid_asid_map and valid_vspace_objs and pspace_aligned and pspace_distinct @@ -179,8 +81,7 @@ lemma arch_switchToThread_corres: apply (rule corres_machine_op[OF corres_rel_imp]) apply (rule corres_underlying_trivial) apply (simp add: ARM.clearExMonitor_def | wp)+ - apply clarsimp - apply (clarsimp simp: valid_pspace'_def) + apply clarsimp done lemma schedule_choose_new_thread_sched_act_rct[wp]: @@ -188,17 +89,7 @@ lemma schedule_choose_new_thread_sched_act_rct[wp]: unfolding schedule_choose_new_thread_def by wp -lemma obj_at'_tcbQueued_cross: - "(s,s') \ state_relation \ obj_at' tcbQueued t s' \ valid_queues' s' \ - obj_at (\ko. \tcb. ko = TCB tcb \ tcb_priority tcb = p \ tcb_domain tcb = d) t s \ - t \ set (ready_queues s d p)" - apply (clarsimp simp: state_relation_def ready_queues_relation_def valid_queues'_def) - apply (subgoal_tac "obj_at' (inQ d p) t s'", simp) - apply (clarsimp simp: obj_at'_def inQ_def obj_at_def projectKO_eq projectKO_tcb) - apply (frule (2) pspace_relation_tcb_domain_priority) - apply clarsimp - done - +\ \This proof shares many similarities with the proof of @{thm tcbSchedEnqueue_corres}\ lemma tcbSchedAppend_corres: "tcb_ptr = tcbPtr \ corres dc @@ -570,14 +461,13 @@ crunch tcbSchedEnqueue (wp: threadSet_cur) lemma tcbSchedEnqueue_invs'[wp]: - "\invs' and st_tcb_at' runnable' t\ + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ tcbSchedEnqueue t \\_. invs'\" - apply (simp add: invs'_def valid_dom_schedule'_def) - apply (wpsimp wp: valid_irq_node_lift irqs_masked_lift valid_irq_handlers_lift' cur_tcb_lift - untyped_ranges_zero_lift + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) + apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift + untyped_ranges_zero_lift tcbSchedEnqueue_ct_not_inQ simp: cteCaps_of_def o_def) - apply (auto elim!: st_tcb_ex_cap'') done crunch tcbSchedAppend @@ -672,43 +562,44 @@ lemma tcbSchedAppend_valid_bitmaps[wp]: apply (clarsimp simp: valid_bitmaps_def) done -crunch tcbSchedAppend - for list_refs_of_replies'[wp]: "\s. P (list_refs_of_replies' s)" - -lemma tcbSchedAppend_valid_release_queue[wp]: - "tcbSchedAppend t \valid_release_queue\" - unfolding tcbSchedAppend_def - apply (wpsimp simp: valid_release_queue_def Ball_def addToBitmap_def - modifyReadyQueuesL2Bitmap_def getReadyQueuesL2Bitmap_def - modifyReadyQueuesL1Bitmap_def getReadyQueuesL1Bitmap_def - wp: hoare_vcg_all_lift hoare_vcg_imp_lift' threadGet_wp) - by (auto simp: obj_at'_def) - -crunch addToBitmap - for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" - -lemma tcbSchedAppend_valid_release_queue'[wp]: - "tcbSchedAppend t \valid_release_queue'\" - unfolding tcbSchedAppend_def threadGet_def - apply (wpsimp simp: valid_release_queue'_def - wp: threadSet_valid_release_queue' hoare_vcg_all_lift hoare_vcg_imp_lift' - getObject_tcb_wp) - apply (clarsimp simp: obj_at'_def) - done - lemma tcbSchedAppend_invs'[wp]: - "\invs' and st_tcb_at' runnable' t\ + "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ tcbSchedAppend t \\_. invs'\" - apply (simp add: invs'_def valid_dom_schedule'_def) - apply (rule hoare_pre) - apply (wp tcbSchedAppend_ct_not_inQ valid_irq_node_lift irqs_masked_lift hoare_vcg_disj_lift - valid_irq_handlers_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift2 - untyped_ranges_zero_lift - | simp add: cteCaps_of_def o_def - | auto elim!: st_tcb_ex_cap'' valid_objs'_maxDomain valid_objs'_maxPriority split: thread_state.split_asm simp: valid_pspace'_def)+ + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) + apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift + untyped_ranges_zero_lift tcbSchedAppend_ct_not_inQ + ct_idle_or_in_cur_domain'_lift2 cur_tcb_lift + simp: cteCaps_of_def o_def) done +lemma tcbSchedAppend_all_invs_but_ct_not_inQ': + "\invs'\ + tcbSchedAppend t + \\_. all_invs_but_ct_not_inQ'\" + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) + apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift + untyped_ranges_zero_lift tcbSchedAppend_ct_not_inQ + ct_idle_or_in_cur_domain'_lift2 cur_tcb_lift + simp: cteCaps_of_def o_def) + done + +lemma tcbSchedEnqueue_invs'_not_ResumeCurrentThread: + "\invs' + and st_tcb_at' runnable' t + and (\s. ksSchedulerAction s \ ResumeCurrentThread)\ + tcbSchedEnqueue t + \\_. invs'\" + by wpsimp + +lemma tcbSchedAppend_invs'_not_ResumeCurrentThread: + "\invs' + and st_tcb_at' runnable' t + and (\s. ksSchedulerAction s \ ResumeCurrentThread)\ + tcbSchedAppend t + \\_. invs'\" + by wpsimp + lemma tcb_at'_has_tcbDomain: "tcb_at' t s \ \p. obj_at' (\tcb. tcbDomain tcb = p) t s" by (clarsimp simp add: obj_at'_def) @@ -762,14 +653,10 @@ lemma tcbSchedDequeue_valid_mdb'[wp]: lemma tcbSchedDequeue_invs'[wp]: "tcbSchedDequeue t \invs'\" - unfolding invs'_def - apply (rule hoare_pre) - apply (wp valid_irq_node_lift irqs_masked_lift - valid_irq_handlers_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift2 - tcbSchedDequeue_valid_queues untyped_ranges_zero_lift - | simp add: cteCaps_of_def o_def valid_dom_schedule'_def)+ - apply (auto simp: valid_pspace'_def obj_at'_def - dest: valid_objs'_maxDomain[where t=t] valid_objs'_maxPriority[where t=t]) + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) + apply (wpsimp wp: valid_irq_node_lift valid_irq_handlers_lift'' irqs_masked_lift + untyped_ranges_zero_lift ct_idle_or_in_cur_domain'_lift2 cur_tcb_lift + simp: cteCaps_of_def o_def) done lemma ready_qs_runnable_cross: @@ -817,18 +704,25 @@ lemma valid_idle_tcb_at: by (clarsimp simp: valid_idle_def pred_tcb_at_def obj_at_def is_tcb_def) lemma setCurThread_corres: - "corres dc (pspace_aligned and pspace_distinct and valid_ready_qs) \ - (modify (cur_thread_update (\_. t))) (setCurThread t)" - apply add_ready_qs_runnable - apply (unfold setCurThread_def) - apply (rule corres_stateAssert_add_assertion[rotated]; clarsimp) + "corres dc (valid_idle and valid_queues and valid_etcbs and pspace_aligned and pspace_distinct) \ + (modify (cur_thread_update (\_. t))) (setCurThread t)" + apply (clarsimp simp: setCurThread_def) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply (clarsimp simp: idleThreadNotQueued_def) + apply (frule (2) idle_thread_not_queued) + apply (frule state_relation_pspace_relation) + apply (frule state_relation_ready_queues_relation) + apply (frule state_relation_idle_thread) + apply (frule valid_idle_tcb_at) + apply (frule (3) tcb_at_cross) + apply (fastforce dest!: in_ready_q_tcbQueued_eq[THEN arg_cong_Not, THEN iffD1] + simp: obj_at'_def projectKOs opt_pred_def opt_map_def) apply (rule corres_modify) apply (simp add: state_relation_def swp_def) done -lemma arch_switch_thread_tcb_at' [wp]: - "Arch.switchToThread t \\s. P (tcb_at' t s)\" - by (unfold ARM_H.switchToThread_def, wp typ_at_lifts) +lemma arch_switch_thread_tcb_at' [wp]: "\tcb_at' t\ Arch.switchToThread t \\_. tcb_at' t\" + by (unfold ARM_H.switchToThread_def, wp typ_at_lift_tcb') crunch "switchToThread" for typ_at'[wp]: "\s. P (typ_at' T p s)" @@ -849,8 +743,6 @@ proof - by (rule lift_neg_pred_tcb_at' [OF ArchThreadDecls_H_ARM_H_switchToThread_typ_at' pos]) qed -crunch doMachineOp - for ksQ[wp]: "\s. P (ksReadyQueues s)" crunch storeWordUser for ksQ[wp]: "\s. P (ksReadyQueues s p)" @@ -894,18 +786,14 @@ lemma valid_queues_ready_qs_distinct[elim!]: "valid_queues s \ ready_qs_distinct s" by (clarsimp simp: valid_queues_def ready_qs_distinct_def) -crunch arch_switch_to_thread - for pspace_aligned[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - lemma switchToThread_corres: "corres dc (valid_arch_state and valid_objs and valid_asid_map - and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_ready_qs + and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_vs_lookup and valid_global_objs and unique_table_refs o caps_of_state - and st_tcb_at runnable t) - (valid_arch_state' and valid_pspace' and Invariants_H.valid_queues - and st_tcb_at' runnable' t and cur_tcb') + and st_tcb_at runnable t and valid_etcbs + and valid_queues and valid_idle) + (no_0_obj' and sym_heap_sched_pointers and valid_objs' and valid_arch_state') (switch_to_thread t) (switchToThread t)" apply (rule_tac Q'="st_tcb_at' runnable' t" in corres_cross_add_guard) apply (fastforce intro!: st_tcb_at_runnable_cross simp: obj_at_def is_tcb_def) @@ -924,23 +812,14 @@ lemma switchToThread_corres: apply (rule corres_guard_imp) apply (rule corres_split[OF arch_switchToThread_corres]) apply (rule corres_split[OF tcbSchedDequeue_corres setCurThread_corres]) - apply (wpsimp wp: tcb_sched_dequeue_valid_ready_qs | clarsimp simp: st_tcb_at_tcb_at)+ - done - - show ?thesis - apply - - apply (simp add: switch_to_thread_def Thread_H.switchToThread_def) - apply add_ready_qs_runnable - apply (rule corres_stateAssert_add_assertion) - apply (rule corres_symb_exec_l[where Q = "\ s rv. (?PA and (=) rv) s"]) - apply (rule corres_symb_exec_l) - apply (rule corres_guard_imp[OF mainpart]) - apply (auto intro: no_fail_pre [OF no_fail_assert] no_fail_pre [OF no_fail_get] - dest: st_tcb_at_tcb_at [THEN get_tcb_at] - | simp add: assert_def - | wp)+ - done -qed + apply (wpsimp simp: is_tcb_def)+ + apply (fastforce intro!: st_tcb_at_tcb_at) + apply wpsimp + apply wpsimp + apply (fastforce dest!: st_tcb_at_tcb_at simp: tcb_at_def) + apply wpsimp + apply (fastforce dest!: st_tcb_at_tcb_at simp: tcb_at_def) + done lemma arch_switchToIdleThread_corres: "corres dc (valid_arch_state and valid_objs and valid_asid_map and unique_table_refs \ caps_of_state and @@ -954,34 +833,26 @@ lemma arch_switchToIdleThread_corres: apply (clarsimp simp: valid_idle_def valid_idle'_def pred_tcb_at_def obj_at_def is_tcb obj_at'_def) done -crunch switchToIdleThread - for ready_qs_runnable[wp]: "\s. \d p. \t\set (ksReadyQueues s (d, p)). - st_tcb_at' runnable' t s" - (simp: crunch_simps) - lemma switchToIdleThread_corres: - "corres dc (invs and valid_ready_qs) invs' switch_to_idle_thread switchToIdleThread" - apply add_ready_qs_runnable - apply add_valid_idle' + "corres dc + (invs and valid_queues and valid_etcbs) + invs_no_cicd' + switch_to_idle_thread switchToIdleThread" apply (simp add: switch_to_idle_thread_def Thread_H.switchToIdleThread_def) - apply (rule corres_stateAssert_add_assertion[rotated]) - apply clarsimp - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_def) + apply add_ready_qs_runnable + apply (rule corres_stateAssert_ignore, fastforce) apply (rule corres_guard_imp) apply (rule corres_split[OF getIdleThread_corres]) apply (rule corres_split[OF arch_switchToIdleThread_corres]) - apply (unfold setCurThread_def) - apply (rule corres_stateAssert_add_assertion) - apply clarsimp - apply (rule corres_modify) - apply (simp add: state_relation_def cdt_relation_def) - apply (simp only: ready_qs_runnable_def) - apply wpsimp+ + apply clarsimp + apply (rule setCurThread_corres) + apply wpsimp + apply (simp add: state_relation_def cdt_relation_def) + apply wpsimp+ apply (simp add: invs_unique_refs invs_valid_vs_lookup invs_valid_objs invs_valid_asid_map invs_arch_state invs_valid_global_objs invs_psp_aligned invs_distinct invs_valid_idle invs_vspace_objs) - apply (simp add: invs'_def valid_pspace'_def ready_qs_runnable_def) + apply (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def valid_pspace'_def) done lemma gq_sp: "\P\ getQueue d p \\rv. P and (\s. ksReadyQueues s (d, p) = rv)\" @@ -996,86 +867,55 @@ lemma sch_act_wf: declare gq_wp[wp] declare setQueue_obj_at[wp] -lemma setCurThread_invs': - "\invs' and tcb_at' t\ - setCurThread t - \\_. invs'\" - apply (simp add: setCurThread_def) - apply wp - apply (clarsimp simp add: invs'_def cur_tcb'_def valid_queues_def valid_release_queue_def - valid_release_queue'_def sch_act_wf ct_in_state'_def - state_refs_of'_def ps_clear_def valid_irq_node'_def valid_queues'_def - ct_idle_or_in_cur_domain'_def - bitmapQ_defs valid_queues_no_bitmap_def valid_dom_schedule'_def - cong: option.case_cong) - done - -lemma valid_queues_not_runnable_not_queued: - fixes s - assumes vq: "valid_queues s" - and rqr: "\d p. (\t \ set (ksReadyQueues s (d, p)). st_tcb_at' runnable' t s)" - and vq': "valid_queues' s" - and st: "st_tcb_at' (Not \ runnable') t s" - shows "obj_at' (Not \ tcbQueued) t s" -proof (rule ccontr) - assume "\ obj_at' (Not \ tcbQueued) t s" - moreover from st have "typ_at' TCBT t s" - by (rule pred_tcb_at' [THEN tcb_at_typ_at' [THEN iffD1]]) - ultimately have "obj_at' tcbQueued t s" - by (clarsimp simp: not_obj_at' comp_def) - - moreover - from st [THEN pred_tcb_at', THEN tcb_at'_has_tcbPriority] - obtain p where tp: "obj_at' (\tcb. tcbPriority tcb = p) t s" - by clarsimp - - moreover - from st [THEN pred_tcb_at', THEN tcb_at'_has_tcbDomain] - obtain d where td: "obj_at' (\tcb. tcbDomain tcb = d) t s" - by clarsimp - - ultimately - have "t \ set (ksReadyQueues s (d, p))" using vq' - unfolding valid_queues'_def - apply - - apply (drule_tac x=d in spec) - apply (drule_tac x=p in spec) - apply (drule_tac x=t in spec) - apply (erule impE) - apply (fastforce simp add: inQ_def obj_at'_def) - apply (assumption) - done +lemma threadSet_timeslice_invs: + "\invs' and tcb_at' t\ threadSet (tcbTimeSlice_update b) t \\rv. invs'\" + by (wp threadSet_invs_trivial, simp_all add: inQ_def cong: conj_cong) - with vq rqr have "st_tcb_at' runnable' t s" - unfolding Invariants_H.valid_queues_def valid_queues_no_bitmap_def - apply - - apply clarsimp +lemma setCurThread_invs_no_cicd': + "\invs_no_cicd' and st_tcb_at' activatable' t and obj_at' (\x. \ tcbQueued x) t and tcb_in_cur_domain' t\ + setCurThread t + \\rv. invs'\" +proof - + have ct_not_inQ_ct: "\s t . \ ct_not_inQ s; obj_at' (\x. \ tcbQueued x) t s\ \ ct_not_inQ (s\ ksCurThread := t \)" + apply (simp add: ct_not_inQ_def o_def) done - - with st show False - apply (clarsimp simp: st_tcb_at'_def obj_at'_def) + show ?thesis + apply (simp add: setCurThread_def) + apply wp + apply (clarsimp simp add: all_invs_but_ct_idle_or_in_cur_domain'_def invs'_def cur_tcb'_def + valid_state'_def sch_act_wf ct_in_state'_def state_refs_of'_def + ps_clear_def valid_irq_node'_def ct_not_inQ_ct + ct_idle_or_in_cur_domain'_def bitmapQ_defs valid_bitmaps_def + cong: option.case_cong) done qed -(* - * The idle thread is not part of any ready queues. - *) -lemma idle'_not_tcbQueued': - assumes vq: "Invariants_H.valid_queues s" - and rqr: "\d p. (\t \ set (ksReadyQueues s (d, p)). st_tcb_at' runnable' t s)" - and vq': "valid_queues' s" - and idle: "valid_idle' s" - shows "obj_at' (Not \ tcbQueued) (ksIdleThread s) s" - proof - - from idle have stidle: "st_tcb_at' (Not \ runnable') (ksIdleThread s) s" - by (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def projectKOs idle_tcb'_def) - - with vq rqr vq' show ?thesis - by (rule valid_queues_not_runnable_not_queued) - qed +(* Don't use this rule when considering the idle thread. The invariant ct_idle_or_in_cur_domain' + says that either "tcb_in_cur_domain' t" or "t = ksIdleThread s". + Use setCurThread_invs_idle_thread instead. *) +lemma setCurThread_invs: + "\invs' and st_tcb_at' activatable' t and obj_at' (\x. \ tcbQueued x) t and + tcb_in_cur_domain' t\ setCurThread t \\rv. invs'\" + by (rule hoare_pre, rule setCurThread_invs_no_cicd') + (simp add: invs'_to_invs_no_cicd'_def) + +lemma setCurThread_invs_no_cicd'_idle_thread: + "\invs_no_cicd' and (\s. t = ksIdleThread s) \ setCurThread t \\_. invs'\" + apply (simp add: setCurThread_def) + apply wp + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def invs'_def cur_tcb'_def + valid_state'_def valid_idle'_def + sch_act_wf ct_in_state'_def state_refs_of'_def + ps_clear_def valid_irq_node'_def + ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def + valid_queues_def bitmapQ_defs valid_bitmaps_def pred_tcb_at'_def + cong: option.case_cong) + apply (clarsimp simp: idle_tcb'_def ct_not_inQ_def ps_clear_def obj_at'_def projectKOs + st_tcb_at'_def idleThreadNotQueued_def) + done lemma clearExMonitor_invs'[wp]: - "doMachineOp ARM.clearExMonitor \invs'\" + "\invs'\ doMachineOp ARM.clearExMonitor \\rv. invs'\" apply (wp dmo_invs' no_irq) apply (simp add: no_irq_clearExMonitor) apply (clarsimp simp: ARM.clearExMonitor_def machine_op_lift_def @@ -1083,7 +923,7 @@ lemma clearExMonitor_invs'[wp]: done lemma Arch_switchToThread_invs[wp]: - "\invs'\ Arch.switchToThread t \\rv. invs'\" + "\invs' and tcb_at' t\ Arch.switchToThread t \\rv. invs'\" apply (simp add: ARM_H.switchToThread_def) apply (wp; auto) done @@ -1132,8 +972,16 @@ lemma Arch_switchToThread_obj_at[wp]: declare doMachineOp_obj_at[wp] +lemma clearExMonitor_invs_no_cicd'[wp]: + "\invs_no_cicd'\ doMachineOp ARM.clearExMonitor \\rv. invs_no_cicd'\" + apply (wp dmo_invs_no_cicd' no_irq) + apply (simp add: no_irq_clearExMonitor) + apply (clarsimp simp: ARM.clearExMonitor_def machine_op_lift_def + in_monad select_f_def) + done + crunch asUser - for valid_arch_state'[wp]: "valid_arch_state'" + for valid_arch_state'[wp]: "valid_arch_state'" (wp: crunch_wps simp: crunch_simps) crunch asUser @@ -1170,22 +1018,36 @@ crunch asUser lemmas asUser_cteCaps_of[wp] = cteCaps_of_ctes_of_lift[OF asUser_ctes_of] -lemma switchToThread_invs'_helper: - "\invs' and tcb_at' t\ - do y \ ARM_H.switchToThread t; - y \ tcbSchedDequeue t; - setCurThread t - od - \\rv. invs' \" - apply (wp setCurThread_invs' tcbSchedDequeue_not_tcbQueued Arch_switchToThread_pred_tcb') - apply auto +lemma Arch_switchToThread_invs_no_cicd': + "\invs_no_cicd'\ Arch.switchToThread t \\rv. invs_no_cicd'\" + apply (simp add: ARM_H.switchToThread_def) + by (wp|rule setVMRoot_invs_no_cicd')+ + + +lemma tcbSchedDequeue_invs_no_cicd'[wp]: + "tcbSchedDequeue t \invs_no_cicd'\" + unfolding all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def valid_pspace'_def + apply (wp tcbSchedDequeue_ct_not_inQ sch_act_wf_lift valid_irq_node_lift irqs_masked_lift + valid_irq_handlers_lift' cur_tcb_lift ct_idle_or_in_cur_domain'_lift2 + untyped_ranges_zero_lift + | simp add: cteCaps_of_def o_def)+ + apply clarsimp done -lemma switchToThread_invs'[wp]: - "\invs' and tcb_at' t\ switchToThread t \\_. invs' \" +lemma switchToThread_invs_no_cicd': + "\invs_no_cicd' and tcb_in_cur_domain' t \ ThreadDecls_H.switchToThread t \\rv. invs' \" + apply (simp add: Thread_H.switchToThread_def) + apply (wp setCurThread_invs_no_cicd' tcbSchedDequeue_not_tcbQueued + Arch_switchToThread_invs_no_cicd' Arch_switchToThread_pred_tcb') + apply (auto elim!: pred_tcb'_weakenE) + done + +lemma switchToThread_invs[wp]: + "\invs' and tcb_in_cur_domain' t \ switchToThread t \\rv. invs' \" apply (simp add: Thread_H.switchToThread_def ) - apply (wp setCurThread_invs' Arch_switchToThread_invs dmo_invs' - doMachineOp_obj_at tcbSchedDequeue_not_tcbQueued) + apply (wp threadSet_timeslice_invs setCurThread_invs + Arch_switchToThread_invs dmo_invs' + doMachineOp_obj_at tcbSchedDequeue_not_tcbQueued) by (auto elim!: pred_tcb'_weakenE) lemma setCurThread_ct_in_state: @@ -1200,10 +1062,13 @@ qed lemma switchToThread_ct_in_state[wp]: "\obj_at' (P \ tcbState) t\ switchToThread t \\rv. ct_in_state' P\" - apply (simp add: Thread_H.switchToThread_def tcbSchedEnqueue_def unless_def) - apply (wp setCurThread_ct_in_state Arch_switchToThread_obj_at +proof - + show ?thesis + apply (simp add: Thread_H.switchToThread_def tcbSchedEnqueue_def unless_def) + apply (wp setCurThread_ct_in_state Arch_switchToThread_obj_at | simp add: o_def cong: if_cong)+ - done + done +qed lemma setCurThread_obj_at[wp]: "\obj_at' P addr\ setCurThread t \\rv. obj_at' P addr\" @@ -1212,6 +1077,9 @@ lemma setCurThread_obj_at[wp]: apply (fastforce intro: obj_at'_pspaceI) done +crunch setQueue + for cap_to'[wp]: "ex_nonz_cap_to' p" + lemma dmo_cap_to'[wp]: "\ex_nonz_cap_to' p\ doMachineOp m @@ -1242,6 +1110,10 @@ lemma iflive_inQ_nonz_cap_strg: lemmas iflive_inQ_nonz_cap[elim] = mp [OF iflive_inQ_nonz_cap_strg, OF conjI[rotated]] +crunch threadSet + for ksRQ[wp]: "\s. P (ksReadyQueues s)" + (wp: updateObject_default_inv) + declare Cons_eq_tails[simp] crunch "ThreadDecls_H.switchToThread" @@ -1252,60 +1124,48 @@ lemma obj_tcb_at': "obj_at' (\tcb::tcb. P tcb) t s \ tcb_at' t s" by (clarsimp simp: obj_at'_def) -lemma valid_queues_not_tcbQueued_not_ksQ: - fixes s - assumes vq: "valid_queues s" - and notq: "obj_at' (Not \ tcbQueued) t s" - shows "\d p. t \ set (ksReadyQueues s (d, p))" -proof (rule ccontr, simp , erule exE, erule exE) - fix d p - assume "t \ set (ksReadyQueues s (d, p))" - with vq have "obj_at' (inQ d p) t s" - by (fastforce intro: valid_queues_obj_at'D) - hence "obj_at' tcbQueued t s" - apply (rule obj_at'_weakenE) - apply (simp only: inQ_def) - done - with notq show "False" - by (clarsimp simp: obj_at'_def) -qed - -lemma not_tcbQueued_not_ksQ: - fixes s - assumes "invs' s" - and "obj_at' (Not \ tcbQueued) t s" - shows "\d p. t \ set (ksReadyQueues s (d, p))" - apply (insert assms) - apply (clarsimp simp add: invs'_def) - apply (drule(1) valid_queues_not_tcbQueued_not_ksQ) - apply clarsimp - done - -lemma ct_not_ksQ: - "\ ct_not_inQ s; valid_queues s; ksSchedulerAction s = ResumeCurrentThread \ - \ \p. ksCurThread s \ set (ksReadyQueues s p)" - apply (clarsimp simp: ct_not_inQ_def) - apply (frule(1) valid_queues_not_tcbQueued_not_ksQ) - apply (fastforce) +lemma tcb_at_typ_at': + "tcb_at' p s = typ_at' TCBT p s" + unfolding typ_at'_def + apply rule + apply (clarsimp simp add: obj_at'_def ko_wp_at'_def projectKOs) + apply (clarsimp simp add: obj_at'_def ko_wp_at'_def projectKOs) + apply (case_tac ko, simp_all) done -lemma scheduleTCB_rct: - "\\s. (t = ksCurThread s \ isSchedulable_bool t s) - \ ksSchedulerAction s = ResumeCurrentThread\ - scheduleTCB t - \\_ s. ksSchedulerAction s = ResumeCurrentThread\" - unfolding scheduleTCB_def - by (wpsimp wp: isSchedulable_wp | rule hoare_pre_cont)+ +crunch getCurThread + for nosch[wp]: "\s. P (ksSchedulerAction s)" lemma setThreadState_rct: - "\\s. (t = ksCurThread s \ runnable' st - \ pred_map (\tcb. \(tcbInReleaseQueue tcb)) (tcbs_of' s) t - \ pred_map (\scPtr. isScActive scPtr s) (tcbSCs_of s) t) + "\\s. (runnable' st \ ksCurThread s \ t) \ ksSchedulerAction s = ResumeCurrentThread\ setThreadState st t \\_ s. ksSchedulerAction s = ResumeCurrentThread\" - unfolding setThreadState_def - by (wpsimp wp: scheduleTCB_rct hoare_vcg_all_lift hoare_vcg_imp_lift' threadSet_isSchedulable_bool) + apply (simp add: setThreadState_def) + apply (rule hoare_pre_disj') + apply (rule bind_wp [OF _ + hoare_vcg_conj_lift + [OF threadSet_tcbState_st_tcb_at' [where P=runnable'] + threadSet_nosch]]) + apply (rule bind_wp [OF _ + hoare_vcg_conj_lift [OF isRunnable_const isRunnable_inv]]) + apply (clarsimp simp: when_def) + apply (case_tac rv) + apply (clarsimp, wp)[1] + apply (clarsimp) + apply (rule bind_wp [OF _ + hoare_vcg_conj_lift + [OF threadSet_ct threadSet_nosch]]) + apply (rule bind_wp [OF _ isRunnable_inv]) + apply (rule bind_wp [OF _ + hoare_vcg_conj_lift + [OF gct_wp gct_wp]]) + apply (rename_tac ct) + apply (case_tac "ct\t") + apply (clarsimp simp: when_def) + apply (wp)[1] + apply (clarsimp) + done lemma bitmapQ_lookupBitmapPriority_simp: (* neater unfold, actual unfold is really ugly *) "\ ksReadyQueuesL1Bitmap s d \ 0 ; @@ -1444,39 +1304,29 @@ lemma getReadyQueuesL2Bitmap_inv[wp]: unfolding getReadyQueuesL2Bitmap_def by wp lemma switchToThread_lookupBitmapPriority_wp: - "\\s. invs' s \ bitmapQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) s \ - t = hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s)) \ + "\\s. invs_no_cicd' s \ bitmapQ (ksCurDomain s) (lookupBitmapPriority (ksCurDomain s) s) s \ + t = the (tcbQueueHead (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s)))\ ThreadDecls_H.switchToThread t \\rv. invs'\" -proof - - have switchToThread_pre: - "\s p t.\ valid_queues s ; \d p. \t \ set (ksReadyQueues s (d, p)). st_tcb_at' runnable' t s; - bitmapQ (ksCurDomain s) p s ; t = hd (ksReadyQueues s (ksCurDomain s, p)) \ - \ st_tcb_at' runnable' t s \ tcb_in_cur_domain' t s" - unfolding valid_queues_def - apply (clarsimp dest!: bitmapQ_ksReadyQueuesI) - apply (case_tac "ksReadyQueues s (ksCurDomain s, p)", simp) - apply (rename_tac t ts) - apply (drule_tac t=t and p=p and d="ksCurDomain s" in valid_queues_no_bitmap_objD) - apply simp - apply (fastforce intro: cons_set_intro - elim: obj_at'_weaken - simp: inQ_def tcb_in_cur_domain'_def) - done - thus ?thesis - apply (simp add: Thread_H.switchToThread_def) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (wp switchToThread_invs'_helper) - apply (fastforce simp: st_tcb_at'_def obj_at_simps invs'_def ready_qs_runnable_def) - done -qed + apply (simp add: Thread_H.switchToThread_def) + apply (wp setCurThread_invs_no_cicd' tcbSchedDequeue_not_tcbQueued + Arch_switchToThread_invs_no_cicd') + apply (auto elim!: pred_tcb'_weakenE) + apply (prop_tac "valid_bitmapQ s") + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_bitmaps_def) + apply (clarsimp simp: ready_queue_relation_def ksReadyQueues_asrt_def valid_bitmapQ_bitmapQ_simp) + apply (drule_tac x="ksCurDomain s" in spec) + apply (drule_tac x="lookupBitmapPriority (ksCurDomain s) s" in spec) + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def) + apply (frule (3) obj_at'_tcbQueueHead_ksReadyQueues) + apply (clarsimp simp: tcb_in_cur_domain'_def obj_at'_def tcbQueueEmpty_def inQ_def) + done -lemma switchToIdleThread_invs': - "switchToIdleThread \invs'\" +lemma switchToIdleThread_invs_no_cicd': + "\invs_no_cicd'\ switchToIdleThread \\rv. invs'\" apply (clarsimp simp: Thread_H.switchToIdleThread_def ARM_H.switchToIdleThread_def) - apply (wpsimp wp: setCurThread_invs') - apply (clarsimp simp: invs'_def valid_idle'_asrt_def - dest!: valid_idle'_tcb_at') + apply (wp setCurThread_invs_no_cicd'_idle_thread setVMRoot_invs_no_cicd') + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_idle'_def) done crunch "Arch.switchToIdleThread" @@ -1491,9 +1341,11 @@ lemma setCurThread_const: -crunch switchToIdleThread, switchToThread, chooseThread +crunch switchToIdleThread for it[wp]: "\s. P (ksIdleThread s)" - (wp: crunch_wps) +crunch switchToThread + for it[wp]: "\s. P (ksIdleThread s)" + (ignore: clearExMonitor) lemma switchToIdleThread_curr_is_idle: "\\\ switchToIdleThread \\rv s. ksCurThread s = ksIdleThread s\" @@ -1504,6 +1356,16 @@ lemma switchToIdleThread_curr_is_idle: apply (simp) done +lemma chooseThread_it[wp]: + "\\s. P (ksIdleThread s)\ chooseThread \\_ s. P (ksIdleThread s)\" + supply if_split[split del] + by (wpsimp simp: chooseThread_def curDomain_def bitmap_fun_defs) + +lemma threadGet_inv [wp]: "\P\ threadGet f t \\rv. P\" + apply (simp add: threadGet_def) + apply (wp | simp)+ + done + lemma corres_split_sched_act: "\sched_act_relation act act'; corres r P P' f1 g1; @@ -1525,16 +1387,28 @@ lemma corres_split_sched_act: apply (rule corres_guard_imp, force+)+ done +lemma corres_assert_ret: + "corres dc (\s. P) \ (assert P) (return ())" + apply (rule corres_no_failI) + apply simp + apply (simp add: assert_def return_def fail_def) + done + +lemma corres_assert_assume_r: + "corres dc P Q f (g ()) + \ corres dc P (Q and (\s. Q')) f (assert Q' >>= g)" + by (force simp: corres_underlying_def assert_def return_def bind_def fail_def) + crunch tcbSchedEnqueue - for cur[wp]: cur_tcb' + for cur[wp]: cur_tcb' (simp: unless_def) -lemma is_schedulable_exs_valid[wp]: - "active_sc_tcb_at t s \ \(=) s\ is_schedulable t \\\r. (=) s\" - apply (clarsimp simp: is_schedulable_def exs_valid_def Bex_def pred_map_def vs_all_heap_simps - split: option.splits) - apply (clarsimp simp: in_monad get_tcb_ko_at obj_at_def get_sched_context_def Option.is_none_def - get_object_def) +lemma thread_get_exs_valid[wp]: + "tcb_at t s \ \(=) s\ thread_get f t \\\r. (=) s\" + apply (clarsimp simp: get_thread_state_def assert_opt_def fail_def + thread_get_def gets_the_def exs_valid_def gets_def + get_def bind_def return_def split: option.splits) + apply (erule get_tcb_at) done lemma gts_exs_valid[wp]: @@ -1550,24 +1424,17 @@ lemma guarded_switch_to_corres: and valid_vspace_objs and pspace_aligned and pspace_distinct and valid_vs_lookup and valid_global_objs and unique_table_refs o caps_of_state - and schedulable t and valid_ready_qs) - (valid_arch_state' and valid_pspace' and Invariants_H.valid_queues - and st_tcb_at' runnable' t and cur_tcb') + and st_tcb_at runnable t and valid_etcbs and valid_queues and valid_idle) + (valid_arch_state' and no_0_obj' and sym_heap_sched_pointers and valid_objs') (guarded_switch_to t) (switchToThread t)" apply (simp add: guarded_switch_to_def) apply (rule corres_guard_imp) - apply (rule corres_symb_exec_l'[OF _ thread_get_exs_valid]) - apply (rule corres_assert_opt_assume_l) - apply (rule corres_symb_exec_l'[OF _ is_schedulable_exs_valid]) - apply (rule corres_assert_assume_l) - apply (rule switchToThread_corres) - apply assumption - apply (wpsimp wp: is_schedulable_wp) - apply assumption - apply (wpsimp wp: thread_get_wp') - apply (clarsimp simp: schedulable_def2 tcb_at_kh_simps pred_map_def vs_all_heap_simps - obj_at_def is_tcb) - apply simp + apply (rule corres_symb_exec_l'[OF _ gts_exs_valid]) + apply (rule corres_assert_assume_l) + apply (rule switchToThread_corres) + apply (force simp: st_tcb_at_tcb_at) + apply (wp gts_st_tcb_at) + apply (force simp: st_tcb_at_tcb_at projectKOs)+ done abbreviation "enumPrio \ [0.e.maxPriority]" @@ -1602,144 +1469,30 @@ lemma corres_gets_queues_getReadyQueuesL1Bitmap: apply (fastforce simp: bitmapL1_zero_ksReadyQueues list_queue_relation_def tcbQueueEmpty_def) done -lemma tcb_at'_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and tcb_at t) (tcb_at' t)" - unfolding cross_rel_def state_relation_def - apply clarsimp - by (erule (3) tcb_at_cross) - -lemma sc_at'_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and sc_at t) (sc_at' t)" - unfolding cross_rel_def state_relation_def - apply clarsimp - by (erule (3) sc_at_cross) - -lemma ntfn_at'_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and ntfn_at t) (ntfn_at' t)" - unfolding cross_rel_def state_relation_def - apply clarsimp - by (erule (3) ntfn_at_cross) - -lemma runnable_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and st_tcb_at runnable t) - (\s'. pred_map (\tcb. runnable' (tcbState tcb)) (tcbs_of' s') t)" - apply (rule cross_rel_imp[OF tcb_at'_cross_rel[where t=t]]) - apply (clarsimp simp: cross_rel_def) - apply (subgoal_tac "pspace_relation (kheap s) (ksPSpace s')") - apply (clarsimp simp: tcb_at_kh_simps pred_map_def cross_rel_def obj_at'_def) - apply (clarsimp simp: vs_all_heap_simps pspace_relation_def) - apply (drule_tac x=t in bspec; clarsimp) - apply (clarsimp simp: other_obj_relation_def split: option.splits) - apply (case_tac "ko"; simp) - apply (clarsimp simp: opt_map_def) - apply (clarsimp simp: tcb_relation_def thread_state_relation_def) - apply (case_tac "tcb_state b"; simp add: runnable_def) - apply clarsimp - apply clarsimp - done - -lemma tcbInReleaseQueue_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and tcb_at t and not_in_release_q t) - (\s'. valid_release_queue' s' \ pred_map (\tcb. \ tcbInReleaseQueue tcb) (tcbs_of' s') t)" - apply (rule cross_rel_imp[OF tcb_at'_cross_rel[where t=t]]) - apply (clarsimp simp: cross_rel_def) - apply (subgoal_tac "pspace_relation (kheap s) (ksPSpace s')") - apply (clarsimp simp: pred_map_def cross_rel_def obj_at'_def obj_at_def is_tcb) - apply (clarsimp simp: vs_all_heap_simps pspace_relation_def) - apply (drule_tac x=t in bspec; clarsimp) - apply (clarsimp simp: other_obj_relation_def split: option.splits) - apply (case_tac "koa"; simp) - apply (clarsimp simp: opt_map_def) - apply (subgoal_tac "obj_at' tcbInReleaseQueue t s'") - apply (subgoal_tac "release_queue_relation (release_queue s) (ksReleaseQueue s')") - apply (clarsimp simp: release_queue_relation_def not_in_release_q_def valid_release_queue'_def) - apply (clarsimp simp: state_relation_def) - apply (clarsimp simp: obj_at'_def projectKO_eq Bits_R.projectKO_tcb) - apply clarsimp - apply clarsimp - done - -lemma isScActive_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and valid_objs and active_sc_tcb_at t) - (\s'. pred_map ((\scPtr. isScActive scPtr s')) (tcbSCs_of s') t)" - apply (rule cross_rel_imp[OF tcb_at'_cross_rel[where t=t]]) - apply (clarsimp simp: cross_rel_def) - apply (subgoal_tac "pspace_relation (kheap s) (ksPSpace s')") - apply (clarsimp simp: pred_map_def obj_at'_real_def ko_wp_at'_def vs_all_heap_simps) - apply (subgoal_tac "sc_at' ref' s'") - apply (clarsimp simp: vs_all_heap_simps pspace_relation_def) - apply (drule_tac x=t in bspec, clarsimp) - apply (clarsimp simp: other_obj_relation_def split: option.splits) - apply (rename_tac s s' scp ko' tcb sc n x) - apply (case_tac "ko'"; simp) - apply (subgoal_tac "pspace_relation (kheap s) (ksPSpace s')") - apply (clarsimp simp: vs_all_heap_simps pspace_relation_def) - apply (drule_tac x=scp in bspec, clarsimp) - apply (subgoal_tac "valid_sched_context_size n") - apply (clarsimp simp: other_obj_relation_def split: option.splits) - apply (clarsimp simp: obj_at'_def projectKO_eq Bits_R.projectKO_sc) - apply (clarsimp simp: opt_map_def tcb_relation_def) - apply (rule_tac x=scp in exI, simp) - apply (clarsimp simp: isScActive_def active_sc_def) - apply (clarsimp simp: obj_at'_def projectKO_eq Bits_R.projectKO_sc pred_map_def opt_map_def) - apply (clarsimp simp: sc_relation_def) - apply (rule_tac sc=sc in valid_objs_valid_sched_context_size, assumption) - apply (fastforce) - apply clarsimp - apply (erule (2) sc_at_cross) - apply (clarsimp simp: obj_at_def is_sc_obj_def) - apply (rule_tac sc=ya in valid_objs_valid_sched_context_size, assumption) - apply (fastforce) - apply clarsimp - apply (clarsimp simp: obj_at_kh_kheap_simps pred_map_def vs_all_heap_simps is_tcb) - done - -lemma isSchedulable_bool_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and valid_objs and schedulable t) (\s'. valid_release_queue' s' \ isSchedulable_bool t s')" - apply (rule cross_rel_imp[OF isScActive_cross_rel[where t=t]]) - apply (rule cross_rel_imp[OF tcbInReleaseQueue_cross_rel[where t=t]]) - apply (rule cross_rel_imp[OF runnable_cross_rel[where t=t]]) - apply (clarsimp simp: isSchedulable_bool_def pred_map_conj[simplified pred_conj_def]) - apply (clarsimp simp: schedulable_def2)+ - done - -lemmas tcb_at'_example = corres_cross[where Q' = "tcb_at' t" for t, OF tcb_at'_cross_rel] - lemma guarded_switch_to_chooseThread_fragment_corres: "corres dc - (P and schedulable t and invs and valid_ready_qs) - (P' and invs' and tcb_at' t) - (guarded_switch_to t) - (do schedulable \ isSchedulable t; - y \ assert schedulable; - ThreadDecls_H.switchToThread t - od)" - apply add_cur_tcb' - apply (rule corres_cross'[OF isSchedulable_bool_cross_rel[where t=t], rotated]) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply (clarsimp simp: invs'_def) - unfolding guarded_switch_to_def - apply simp - apply (rule corres_guard_imp) - apply (rule corres_symb_exec_l_Ex) - apply (rule corres_symb_exec_l_Ex) - apply (rule corres_split[OF isSchedulable_corres]) - apply (rule corres_assert_assume_l) - apply (rule corres_assert_assume_r) - apply (rule switchToThread_corres) - apply (wpsimp wp: is_schedulable_wp) - apply (wpsimp wp: isSchedulable_wp) - apply (prop_tac "st_tcb_at runnable t s \ bound_sc_tcb_at bound t s") - apply (clarsimp simp: schedulable_def2 tcb_at_kh_simps pred_map_def vs_all_heap_simps) - apply (clarsimp simp: st_tcb_at_tcb_at invs_def valid_state_def valid_pspace_def valid_sched_def + (P and st_tcb_at runnable t and invs and valid_sched) + (P' and invs_no_cicd') + (guarded_switch_to t) + (do runnable \ isRunnable t; + y \ assert runnable; + ThreadDecls_H.switchToThread t + od)" + apply (rule_tac Q'="st_tcb_at' runnable' t" in corres_cross_add_guard) + apply (fastforce intro!: st_tcb_at_runnable_cross simp: obj_at_def is_tcb_def) + unfolding guarded_switch_to_def isRunnable_def + apply simp + apply (rule corres_guard_imp) + apply (rule corres_split[OF getThreadState_corres]) + apply (rule corres_assert_assume_l) + apply (rule corres_assert_assume_r) + apply (rule switchToThread_corres) + apply (wp gts_st_tcb_at)+ + apply (clarsimp simp: st_tcb_at_tcb_at invs_def valid_state_def valid_pspace_def valid_sched_def invs_valid_vs_lookup invs_unique_refs) - apply (clarsimp simp: thread_get_def in_monad pred_tcb_at_def obj_at_def get_tcb_ko_at) - apply (prop_tac "st_tcb_at' runnable' t s") - apply (clarsimp simp: pred_tcb_at'_def isSchedulable_bool_def pred_map_def obj_at'_def - projectKO_eq - elim!: opt_mapE) - apply fastforce - by (auto simp: invs'_def) + apply (auto elim!: pred_tcb'_weakenE split: thread_state.splits + simp: pred_tcb_at' runnable'_def all_invs_but_ct_idle_or_in_cur_domain'_def) + done lemma Max_prio_helper: "ready_queues_relation s s' @@ -1760,28 +1513,31 @@ lemma Max_prio_helper: lemma bitmap_lookup_queue_is_max_non_empty: "\ valid_bitmaps s'; (s, s') \ state_relation; invs s; ksReadyQueuesL1Bitmap s' (ksCurDomain s') \ 0 \ - \ ksReadyQueues s' (ksCurDomain s', lookupBitmapPriority (ksCurDomain s') s') = - max_non_empty_queue (ready_queues s (cur_domain s))" - unfolding valid_queues_def - by (clarsimp simp add: max_non_empty_queue_def lookupBitmapPriority_Max_eqI - state_relation_def ready_queues_relation_def) + \ the (tcbQueueHead (ksReadyQueues s' (ksCurDomain s', lookupBitmapPriority (ksCurDomain s') s'))) + = hd (max_non_empty_queue (ready_queues s (cur_domain s)))" + apply (clarsimp simp: max_non_empty_queue_def valid_bitmaps_def lookupBitmapPriority_Max_eqI) + apply (frule curdomain_relation) + apply (drule state_relation_ready_queues_relation) + apply (simp add: Max_prio_helper) + apply (clarsimp simp: ready_queues_relation_def ready_queue_relation_def Let_def + list_queue_relation_def) + apply (frule (2) bitmapL1_zero_ksReadyQueues[THEN arg_cong_Not, THEN iffD1]) + apply clarsimp + apply (cut_tac P="\x. \ tcbQueueEmpty (ksReadyQueues s' (ksCurDomain s', x))" + in setcomp_Max_has_prop) + apply fastforce + apply (clarsimp simp: ready_queues_relation_def Let_def list_queue_relation_def tcbQueueEmpty_def) + apply (drule_tac x="ksCurDomain s'" in spec) + apply (drule_tac x="Max {prio. \ tcbQueueEmpty (ksReadyQueues s' (ksCurDomain s', prio))}" + in spec) + using heap_path_head tcbQueueEmpty_def + by fastforce lemma ksReadyQueuesL1Bitmap_return_wp: "\\s. P (ksReadyQueuesL1Bitmap s d) s \ getReadyQueuesL1Bitmap d \\rv s. P rv s\" unfolding getReadyQueuesL1Bitmap_def by wp -lemma ksReadyQueuesL1Bitmap_st_tcb_at': - "\ ksReadyQueuesL1Bitmap s (ksCurDomain s) \ 0; valid_queues s; - (\d p. (\t \ set (ksReadyQueues s (d, p)). st_tcb_at' runnable' t s))\ - \ st_tcb_at' runnable' (hd (ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s))) s" - apply (drule bitmapQ_from_bitmap_lookup; clarsimp simp: valid_queues_def) - apply (clarsimp simp add: valid_bitmapQ_bitmapQ_simp) - apply (case_tac "ksReadyQueues s (ksCurDomain s, lookupBitmapPriority (ksCurDomain s) s)") - apply simp - apply (fastforce intro: cons_set_intro) - done - lemma curDomain_or_return_0: "\ \P\ curDomain \\rv s. Q rv s \; \s. P s \ ksCurDomain s \ maxDomain \ \ \P\ if 1 < numDomains then curDomain else return 0 \\rv s. Q rv s \" @@ -1789,59 +1545,74 @@ lemma curDomain_or_return_0: apply (simp add: valid_def curDomain_def simpler_gets_def return_def maxDomain_def) done +lemma invs_no_cicd_ksCurDomain_maxDomain': + "invs_no_cicd' s \ ksCurDomain s \ maxDomain" + unfolding invs_no_cicd'_def by simp + lemma chooseThread_corres: - "corres dc (invs and valid_ready_qs and ready_or_release) invs' - choose_thread chooseThread" (is "corres _ ?PREI ?PREH _ _") - apply add_ready_qs_runnable - unfolding choose_thread_def chooseThread_def - apply (rule corres_stateAssert_add_assertion[rotated]) - apply (clarsimp simp: ready_qs_runnable_def) - apply (simp only: return_bind Let_def K_bind_def) - apply (subst if_swap[where P="_ \ 0"]) (* put switchToIdleThread on first branch*) - apply (rule corres_guard_imp) - apply (rule corres_split[OF curDomain_corres']) - apply clarsimp - apply (rule corres_split[OF corres_gets_queues_getReadyQueuesL1Bitmap]) - apply (erule corres_if2[OF sym]) - apply (rule switchToIdleThread_corres) - apply (rule corres_symb_exec_r) - apply (rule corres_symb_exec_r) - apply (rule_tac - P="\s. ?PREI s \ queues = ready_queues s (cur_domain s) \ - schedulable (hd (max_non_empty_queue queues)) s" and - P'="\s. (?PREH s ) \ st_tcb_at' runnable' (hd queue) s \ - l1 = ksReadyQueuesL1Bitmap s (ksCurDomain s) \ - l1 \ 0 \ - queue = ksReadyQueues s (ksCurDomain s, - lookupBitmapPriority (ksCurDomain s) s)" and - F="hd queue = hd (max_non_empty_queue queues)" in corres_req) - apply (fastforce simp: bitmap_lookup_queue_is_max_non_empty invs'_def) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule_tac P=\ and P'=\ in guarded_switch_to_chooseThread_fragment_corres) - apply (wp | clarsimp simp: getQueue_def getReadyQueuesL2Bitmap_def)+ - apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift ksReadyQueuesL1Bitmap_return_wp) - apply (wpsimp wp: curDomain_or_return_0)+ - apply (fastforce simp: invs_ksCurDomain_maxDomain') - apply (clarsimp simp: valid_sched_def DetSchedInvs_AI.valid_ready_qs_def max_non_empty_queue_def) - apply (erule_tac x="cur_domain s" in allE) - apply (erule_tac x="Max {prio. ready_queues s (cur_domain s) prio \ []}" in allE) - apply (case_tac "ready_queues s (cur_domain s) (Max {prio. ready_queues s (cur_domain s) prio \ []})") - apply (clarsimp) - apply (subgoal_tac - "ready_queues s (cur_domain s) (Max {prio. ready_queues s (cur_domain s) prio \ []}) \ []") - apply (fastforce elim!: setcomp_Max_has_prop) - apply (fastforce elim!: setcomp_Max_has_prop) - apply (clarsimp simp: tcb_at_kh_simps schedulable_def2 released_sc_tcb_at_def) - apply (subgoal_tac "in_ready_q a s", fastforce simp: ready_or_release_def) - apply (clarsimp simp: in_ready_q_def) - apply (rule_tac x="cur_domain s" in exI) - apply (rule_tac x="Max {prio. ready_queues s (cur_domain s) prio \ []}" in exI) + "corres dc (invs and valid_sched) invs_no_cicd' choose_thread chooseThread" + (is "corres _ ?PREI ?PREH _ _") +proof - + + (* if we only have one domain, we are in it *) + have one_domain_case: + "\s. \ invs_no_cicd' s; numDomains \ 1 \ \ ksCurDomain s = 0" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def maxDomain_def) + + show ?thesis + supply if_split[split del] + apply (clarsimp simp: choose_thread_def chooseThread_def) + apply add_ready_qs_runnable + apply (rule corres_stateAssert_add_assertion[rotated]) + apply (fastforce intro: ksReadyQueues_asrt_cross) + apply (rule corres_stateAssert_add_assertion[rotated]) + apply fastforce + apply (simp only: return_bind Let_def) + apply (subst if_swap[where P="_ \ 0"]) (* put switchToIdleThread on first branch*) + apply (rule corres_guard_imp) + apply (rule corres_split[OF curDomain_corres']) + apply clarsimp + apply (rule corres_split[OF corres_gets_queues_getReadyQueuesL1Bitmap]) + apply (erule corres_if2[OF sym]) + apply (rule switchToIdleThread_corres) + apply (rule corres_symb_exec_r) + apply (rule corres_symb_exec_r) + apply (rule_tac P="\s. ?PREI s \ queues = ready_queues s (cur_domain s) + \ st_tcb_at runnable (hd (max_non_empty_queue queues)) s" + and P'="\s. ?PREH s \ l1 = ksReadyQueuesL1Bitmap s (ksCurDomain s) + \ l1 \ 0 + \ queue = ksReadyQueues s (ksCurDomain s, + lookupBitmapPriority (ksCurDomain s) s)" + and F="the (tcbQueueHead queue) = hd (max_non_empty_queue queues)" + in corres_req) + apply (fastforce simp: bitmap_lookup_queue_is_max_non_empty + all_invs_but_ct_idle_or_in_cur_domain'_def) + apply clarsimp + apply (rule corres_guard_imp) + apply (rule_tac P=\ and P'=\ in guarded_switch_to_chooseThread_fragment_corres) + apply (wpsimp simp: getQueue_def getReadyQueuesL2Bitmap_def)+ + apply (wp hoare_vcg_conj_lift hoare_vcg_imp_lift ksReadyQueuesL1Bitmap_return_wp) + apply (wpsimp wp: curDomain_or_return_0 simp: curDomain_def)+ + apply (clarsimp simp: valid_sched_def max_non_empty_queue_def valid_queues_def split: if_splits) + apply (erule_tac x="cur_domain s" in allE) + apply (erule_tac x="Max {prio. ready_queues s (cur_domain s) prio \ []}" in allE) + apply (case_tac "ready_queues s (cur_domain s) + (Max {prio. ready_queues s (cur_domain s) prio + \ []})") + apply (clarsimp) + apply (subgoal_tac "ready_queues s (cur_domain s) + (Max {prio. ready_queues s (cur_domain s) prio \ []}) + \ []") + apply fastforce + apply (fastforce elim!: setcomp_Max_has_prop) + apply fastforce apply clarsimp - apply (simp add: invs_ksCurDomain_maxDomain') - apply (clarsimp simp: ready_qs_runnable_def) - apply (fastforce intro: ksReadyQueuesL1Bitmap_st_tcb_at') - done + apply (frule invs_no_cicd_ksCurDomain_maxDomain') + apply (prop_tac "valid_bitmaps s") + apply (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def) + apply (fastforce dest: one_domain_case split: if_splits) + done +qed lemma thread_get_comm: "do x \ thread_get f p; y \ gets g; k x y od = do y \ gets g; x \ thread_get f p; k x y od" @@ -1861,49 +1632,38 @@ lemma schact_bind_inside: "do x \ f; (case act of resume_cur_thread \ apply (case_tac act,simp_all) done +interpretation tcb_sched_action_extended: is_extended' "tcb_sched_action f a" + by (unfold_locales) + lemma getDomainTime_corres: "corres (=) \ \ (gets domain_time) getDomainTime" by (simp add: getDomainTime_def state_relation_def) -lemma \s_in_ms_equiv: - "\s_in_ms = usInMs" - by (simp add: usInMs_def \s_in_ms_def) - -lemma us_to_ticks_equiv: - "us_to_ticks = usToTicks" - by (simp add: usToTicks_def) - -lemma reset_work_units_equiv: - "do_extended_op (modify (work_units_completed_update (\_. 0))) - = (modify (work_units_completed_update (\_. 0)))" - by (clarsimp simp: reset_work_units_def[symmetric]) - lemma nextDomain_corres: "corres dc \ \ next_domain nextDomain" - apply (clarsimp simp: next_domain_def nextDomain_def reset_work_units_equiv modify_modify) + apply (simp add: next_domain_def nextDomain_def) apply (rule corres_modify) - apply (simp add: state_relation_def Let_def dschLength_def dschDomain_def cdt_relation_def - \s_in_ms_equiv us_to_ticks_equiv) + apply (simp add: state_relation_def Let_def dschLength_def dschDomain_def) done lemma next_domain_valid_sched[wp]: "\ valid_sched and (\s. scheduler_action s = choose_new_thread)\ next_domain \ \_. valid_sched \" apply (simp add: next_domain_def Let_def) apply (wp, simp add: valid_sched_def valid_sched_action_2_def ct_not_in_q_2_def) - apply (fastforce simp: valid_blocked_defs) + apply (simp add:valid_blocked_2_def) done -lemma nextDomain_invs': - "nextDomain \invs'\" - apply (simp add: nextDomain_def Let_def dschLength_def) +lemma nextDomain_invs_no_cicd': + "\ invs' and (\s. ksSchedulerAction s = ChooseNewThread)\ nextDomain \ \_. invs_no_cicd' \" + apply (simp add: nextDomain_def Let_def dschLength_def dschDomain_def) apply wp - apply (clarsimp simp: invs'_def valid_machine_state'_def dschDomain_def valid_dom_schedule'_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_machine_state'_def + ct_not_inQ_def cur_tcb'_def ct_idle_or_in_cur_domain'_def dschDomain_def + all_invs_but_ct_idle_or_in_cur_domain'_def) done lemma scheduleChooseNewThread_fragment_corres: - "corres dc (invs and valid_ready_qs and ready_or_release - and (\s. scheduler_action s = choose_new_thread)) - (invs' and (\s. ksSchedulerAction s = ChooseNewThread)) + "corres dc (invs and valid_sched and (\s. scheduler_action s = choose_new_thread)) (invs' and (\s. ksSchedulerAction s = ChooseNewThread)) (do _ \ when (domainTime = 0) next_domain; choose_thread od) @@ -1913,18 +1673,18 @@ lemma scheduleChooseNewThread_fragment_corres: apply (subst bind_dummy_ret_val) apply (subst bind_dummy_ret_val) apply (rule corres_guard_imp) - apply (rule corres_split[OF corres_when]) - apply simp + apply (rule corres_split) + apply (rule corres_when, simp) apply (rule nextDomain_corres) apply simp apply (rule chooseThread_corres) - apply (wp nextDomain_invs')+ - apply (clarsimp simp: valid_sched_def invs'_def)+ + apply (wp nextDomain_invs_no_cicd')+ + apply (clarsimp simp: valid_sched_def invs'_def valid_state'_def all_invs_but_ct_idle_or_in_cur_domain'_def)+ done lemma scheduleSwitchThreadFastfail_corres: "\ ct \ it \ (tp = tp' \ cp = cp') ; ct = ct' ; it = it' \ \ - corres ((=)) (tcb_at ct) (tcb_at' ct) + corres ((=)) (is_etcb_at ct) (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) @@ -1963,23 +1723,26 @@ lemma isHighestPrio_corres: apply (wpsimp simp: if_apply_def2 wp: hoare_drop_imps ksReadyQueuesL1Bitmap_return_wp)+ done +crunch set_scheduler_action + for valid_idle_etcb[wp]: valid_idle_etcb + crunch isHighestPrio - for inv[wp]: P + for inv[wp]: P crunch curDomain - for inv[wp]: P + for inv[wp]: P +crunch schedule_switch_thread_fastfail + for inv[wp]: P crunch scheduleSwitchThreadFastfail - for inv[wp]: P + for inv[wp]: P lemma setSchedulerAction_invs': (* not in wp set, clobbered by ssa_wp *) - "\\s. invs' s \ setSchedulerAction ChooseNewThread \\_. invs' \" - by (wpsimp simp: invs'_def cur_tcb'_def valid_irq_node'_def ct_not_inQ_def - valid_queues_def valid_release_queue_def valid_release_queue'_def - valid_queues_no_bitmap_def valid_queues'_def ct_idle_or_in_cur_domain'_def - valid_dom_schedule'_def) + "setSchedulerAction ChooseNewThread \invs' \" + by (wpsimp simp: invs'_def cur_tcb'_def valid_state'_def valid_irq_node'_def ct_not_inQ_def + ct_idle_or_in_cur_domain'_def) lemma scheduleChooseNewThread_corres: "corres dc - (\s. invs s \ valid_ready_qs s \ ready_or_release s \ scheduler_action s = choose_new_thread) + (\s. invs s \ valid_sched s \ scheduler_action s = choose_new_thread) (\s. invs' s \ ksSchedulerAction s = ChooseNewThread) schedule_choose_new_thread scheduleChooseNewThread" unfolding schedule_choose_new_thread_def scheduleChooseNewThread_def @@ -1989,17 +1752,239 @@ lemma scheduleChooseNewThread_corres: apply (rule setSchedulerAction_corres) apply (wp | simp)+ apply (wp | simp add: getDomainTime_def)+ + apply auto + done + +crunch guarded_switch_to + for static_inv[wp]: "\_. P" + +lemma ethread_get_when_corres: + assumes x: "\etcb tcb'. etcb_relation etcb tcb' \ r (f etcb) (f' tcb')" + shows "corres (\rv rv'. b \ r rv rv') (is_etcb_at t) (tcb_at' t) + (ethread_get_when b f t) (threadGet f' t)" + apply (clarsimp simp: ethread_get_when_def) + apply (rule conjI; clarsimp) + apply (rule corres_guard_imp, rule ethreadget_corres; simp add: x) + apply (clarsimp simp: threadGet_def) + apply (rule corres_noop) + apply wpsimp+ + done + +lemma tcb_sched_enqueue_in_correct_ready_q[wp]: + "tcb_sched_action tcb_sched_enqueue t \in_correct_ready_q\ " + unfolding tcb_sched_action_def tcb_sched_enqueue_def set_tcb_queue_def + apply wpsimp + apply (clarsimp simp: in_correct_ready_q_def obj_at_def etcb_at_def is_etcb_at_def + split: option.splits) done +lemma tcb_sched_append_in_correct_ready_q[wp]: + "tcb_sched_action tcb_sched_append tcb_ptr \in_correct_ready_q\ " + unfolding tcb_sched_action_def tcb_sched_append_def + apply wpsimp + apply (clarsimp simp: in_correct_ready_q_def obj_at_def etcb_at_def is_etcb_at_def + split: option.splits) + done + +lemma tcb_sched_enqueue_ready_qs_distinct[wp]: + "tcb_sched_action tcb_sched_enqueue t \ready_qs_distinct\ " + unfolding tcb_sched_action_def set_tcb_queue_def + apply (wpsimp wp: thread_get_wp') + apply (clarsimp simp: ready_qs_distinct_def etcb_at_def is_etcb_at_def split: option.splits) + done + +lemma tcb_sched_append_ready_qs_distinct[wp]: + "tcb_sched_action tcb_sched_append t \ready_qs_distinct\ " + unfolding tcb_sched_action_def tcb_sched_append_def set_tcb_queue_def + apply (wpsimp wp: thread_get_wp') + apply (clarsimp simp: ready_qs_distinct_def etcb_at_def is_etcb_at_def split: option.splits) + done + +crunch set_scheduler_action + for in_correct_ready_q[wp]: in_correct_ready_q + and ready_qs_distinct[wp]: ready_qs_distinct + (wp: crunch_wps simp: in_correct_ready_q_def ready_qs_distinct_def) + +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 ignore_del: reschedule_required) + +lemma schedule_corres: + "corres dc (invs and valid_sched and valid_list) invs' (Schedule_A.schedule) ThreadDecls_H.schedule" + supply ethread_get_wp[wp del] + supply tcbSchedEnqueue_invs'[wp del] + supply tcbSchedEnqueue_invs'_not_ResumeCurrentThread[wp del] + supply setSchedulerAction_direct[wp] + supply if_split[split del] + + apply (clarsimp simp: Schedule_A.schedule_def Thread_H.schedule_def) + apply (subst thread_get_test) + apply (subst thread_get_comm) + apply (subst schact_bind_inside) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getCurThread_corres[THEN corres_rel_imp[where r="\x y. y = x"],simplified]]) + apply (rule corres_split[OF getSchedulerAction_corres]) + apply (rule corres_split_sched_act,assumption) + apply (rule_tac P="tcb_at ct" in corres_symb_exec_l') + apply (rule_tac corres_symb_exec_l) + apply simp + apply (rule corres_assert_ret) + apply ((wpsimp wp: thread_get_wp' gets_exs_valid)+) + prefer 2 + (* choose thread *) + apply clarsimp + apply (rule corres_split[OF thread_get_isRunnable_corres]) + apply (rule corres_split) + apply (rule corres_when, simp) + apply (rule tcbSchedEnqueue_corres, simp) + apply (rule scheduleChooseNewThread_corres, simp) + apply (wp thread_get_wp' tcbSchedEnqueue_invs' hoare_vcg_conj_lift hoare_drop_imps + | clarsimp)+ + (* switch to thread *) + apply (rule corres_split[OF thread_get_isRunnable_corres], + rename_tac was_running wasRunning) + apply (rule corres_split) + apply (rule corres_when, simp) + apply (rule tcbSchedEnqueue_corres, simp) + apply (rule corres_split[OF getIdleThread_corres], rename_tac it it') + apply (rule_tac F="was_running \ ct \ it" in corres_gen_asm) + apply (rule corres_split) + apply (rule ethreadget_corres[where r="(=)"]) + apply (clarsimp simp: etcb_relation_def) + apply (rename_tac tp tp') + apply (rule corres_split) + apply (rule ethread_get_when_corres[where r="(=)"]) + apply (clarsimp simp: etcb_relation_def) + apply (rename_tac cp cp') + apply (rule corres_split) + apply (rule scheduleSwitchThreadFastfail_corres; simp) + apply (rule corres_split[OF curDomain_corres]) + apply (rule corres_split[OF isHighestPrio_corres]; simp only:) + apply (rule corres_if, simp) + apply (rule corres_split[OF tcbSchedEnqueue_corres], simp) + apply (simp, fold dc_def) + apply (rule corres_split) + apply (rule setSchedulerAction_corres; simp) + apply (rule scheduleChooseNewThread_corres) + apply (wp | simp)+ + apply (simp add: valid_sched_def) + apply wp + apply (rule hoare_vcg_conj_lift) + apply (rule_tac t=t in set_scheduler_action_cnt_valid_blocked') + apply (wpsimp wp: setSchedulerAction_invs')+ + apply (wp tcb_sched_action_enqueue_valid_blocked hoare_vcg_all_lift enqueue_thread_queued) + apply (wp tcbSchedEnqueue_invs'_not_ResumeCurrentThread) + apply (rule corres_if, fastforce) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) + apply (simp, fold dc_def) + apply (rule corres_split) + apply (rule setSchedulerAction_corres; simp) + apply (rule scheduleChooseNewThread_corres) + apply (wp | simp)+ + apply (simp add: valid_sched_def) + apply wp + apply (rule hoare_vcg_conj_lift) + apply (rule_tac t=t in set_scheduler_action_cnt_valid_blocked') + apply (wpsimp wp: setSchedulerAction_invs')+ + apply (wp tcb_sched_action_append_valid_blocked hoare_vcg_all_lift append_thread_queued) + apply (wp tcbSchedAppend_invs'_not_ResumeCurrentThread) + + apply (rule corres_split[OF guarded_switch_to_corres], simp) + apply (rule setSchedulerAction_corres[simplified dc_def]) + apply (wp | simp)+ + + (* isHighestPrio *) + apply (clarsimp simp: if_apply_def2) + apply ((wp (once) hoare_drop_imp)+)[1] + + apply (simp add: if_apply_def2) + apply ((wp (once) hoare_drop_imp)+)[1] + apply wpsimp+ + + apply (clarsimp simp: conj_ac cong: conj_cong) + apply wp + apply (rule_tac Q'="\_ s. valid_blocked_except t s \ scheduler_action s = switch_thread t" + in hoare_post_imp, fastforce) + apply (wp add: tcb_sched_action_enqueue_valid_blocked_except + tcbSchedEnqueue_invs'_not_ResumeCurrentThread thread_get_wp + del: gets_wp + | strengthen valid_objs'_valid_tcbs')+ + apply (clarsimp simp: conj_ac if_apply_def2 cong: imp_cong conj_cong) + apply (wp gets_wp)+ + + (* abstract final subgoal *) + apply clarsimp + + subgoal for s + apply (clarsimp split: Deterministic_A.scheduler_action.splits + simp: invs_psp_aligned invs_distinct invs_valid_objs invs_arch_state + invs_vspace_objs[simplified] tcb_at_invs) + apply (rule conjI, clarsimp) + apply (fastforce simp: invs_def + valid_sched_def valid_sched_action_def is_activatable_def + st_tcb_at_def obj_at_def valid_state_def only_idle_def + ) + apply (rule conjI, clarsimp) + subgoal for candidate + apply (clarsimp simp: valid_sched_def invs_def valid_state_def cur_tcb_def + valid_arch_caps_def valid_sched_action_def + weak_valid_sched_action_def tcb_at_is_etcb_at + tcb_at_is_etcb_at[OF st_tcb_at_tcb_at[rotated]] + valid_blocked_except_def valid_blocked_def) + apply (fastforce simp add: pred_tcb_at_def obj_at_def is_tcb valid_idle_def) + done + (* choose new thread case *) + apply (intro impI conjI allI tcb_at_invs + | fastforce simp: invs_def cur_tcb_def valid_etcbs_def + valid_sched_def st_tcb_at_def obj_at_def valid_state_def + weak_valid_sched_action_def not_cur_thread_def)+ + done + + (* haskell final subgoal *) + apply (clarsimp simp: if_apply_def2 invs'_def valid_state'_def valid_sched_def + cong: imp_cong split: scheduler_action.splits) + apply (fastforce simp: cur_tcb'_def valid_pspace'_def) + done + +lemma ssa_all_invs_but_ct_not_inQ': + "\all_invs_but_ct_not_inQ' and sch_act_wf sa and + (\s. sa = ResumeCurrentThread \ ksCurThread s = ksIdleThread s \ tcb_in_cur_domain' (ksCurThread s) s)\ + setSchedulerAction sa \\rv. all_invs_but_ct_not_inQ'\" +proof - + show ?thesis + apply (simp add: setSchedulerAction_def) + apply wp + apply (clarsimp simp add: invs'_def valid_state'_def cur_tcb'_def + state_refs_of'_def ps_clear_def valid_irq_node'_def + tcb_in_cur_domain'_def ct_idle_or_in_cur_domain'_def bitmapQ_defs + cong: option.case_cong) + done +qed + 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_all_invs_but_ct_not_inQ''[simplified]: + "\\s. (all_invs_but_ct_not_inQ' s \ sch_act_wf sa s) + \ (sa = ResumeCurrentThread \ ksCurThread s = ksIdleThread s \ tcb_in_cur_domain' (ksCurThread s) s) + \ (sa = ResumeCurrentThread \ obj_at' (Not \ tcbQueued) (ksCurThread s) s)\ + setSchedulerAction sa \\rv. invs'\" + apply (simp only: all_invs_but_not_ct_inQ_check' [symmetric]) + apply (rule hoare_elim_pred_conj) + apply (wp hoare_vcg_conj_lift [OF ssa_all_invs_but_ct_not_inQ' ssa_ct_not_inQ]) + apply (clarsimp) + done + lemma ssa_invs': - "setSchedulerAction sa \invs'\" - apply (wp ssa_ct_not_inQ) - apply (clarsimp simp: invs'_def valid_irq_node'_def valid_dom_schedule'_def) + "\invs' and sch_act_wf sa and + (\s. sa = ResumeCurrentThread \ ksCurThread s = ksIdleThread s \ tcb_in_cur_domain' (ksCurThread s) s) and + (\s. sa = ResumeCurrentThread \ obj_at' (Not \ tcbQueued) (ksCurThread s) s)\ + setSchedulerAction sa \\rv. invs'\" + apply (wp ssa_all_invs_but_ct_not_inQ'') + apply (clarsimp simp add: invs'_def valid_state'_def) done lemma getDomainTime_wp[wp]: "\\s. P (ksDomainTime s) s \ getDomainTime \ P \" @@ -2007,12 +1992,12 @@ lemma getDomainTime_wp[wp]: "\\s. P (ksDomainTime s) s \ by wp lemma switchToThread_ct_not_queued_2: - "\invs' and tcb_at' t\ switchToThread t \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s\" + "\invs_no_cicd' 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 (wp) apply (simp add: ARM_H.switchToThread_def setCurThread_def) - apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued hoare_drop_imps)+ + apply (wp tcbSchedDequeue_not_tcbQueued hoare_drop_imp | simp )+ done lemma setCurThread_obj_at': @@ -2025,982 +2010,177 @@ proof - done qed -lemma switchToIdleThread_ct_not_queued: - "\ invs' \ switchToIdleThread \\_ s. obj_at' (Not \ tcbQueued) (ksCurThread s) s \" +lemma switchToIdleThread_ct_not_queued_no_cicd': + "\invs_no_cicd'\ switchToIdleThread \\_ s. obj_at' (Not \ tcbQueued) (ksCurThread s) s \" apply (simp add: Thread_H.switchToIdleThread_def) apply (wp setCurThread_obj_at') - apply (intro impI) - apply (rule idle'_not_tcbQueued') - apply (simp add: ready_qs_runnable_def invs'_def valid_idle'_asrt_def)+ + apply (clarsimp simp: ready_qs_runnable_def) + apply (drule_tac x="ksIdleThread s" in spec) + apply (clarsimp simp: invs_no_cicd'_def valid_idle'_def st_tcb_at'_def idle_tcb'_def obj_at'_def) done lemma switchToIdleThread_activatable_2[wp]: - "\invs'\ switchToIdleThread \\_. ct_in_state' activatable'\" + "\invs_no_cicd'\ switchToIdleThread \\rv. ct_in_state' activatable'\" apply (simp add: Thread_H.switchToIdleThread_def ARM_H.switchToIdleThread_def) apply (wp setCurThread_ct_in_state) - apply (clarsimp simp: invs'_def valid_idle'_def valid_idle'_asrt_def + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def valid_idle'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) done lemma switchToThread_tcb_in_cur_domain': "\tcb_in_cur_domain' thread\ ThreadDecls_H.switchToThread thread - \\_ s. tcb_in_cur_domain' (ksCurThread s) s\" + \\y s. tcb_in_cur_domain' (ksCurThread s) s\" apply (simp add: Thread_H.switchToThread_def setCurThread_def) - apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued tcbSchedDequeue_tcbDomain - hoare_drop_imps) + apply (wpsimp wp: tcbSchedDequeue_not_tcbQueued hoare_drop_imps) done -lemma chooseThread_invs'_posts: (* generic version *) - "\ invs' \ chooseThread +lemma chooseThread_invs_no_cicd'_posts: (* generic version *) + "\ invs_no_cicd' \ chooseThread \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s \ ct_in_state' activatable' s \ (ksCurThread s = ksIdleThread s \ tcb_in_cur_domain' (ksCurThread s) s) \" - unfolding chooseThread_def Let_def - apply (simp only: return_bind, simp split del: if_split) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[where Q'="\rv s. invs' s \ rv = ksCurDomain s \ ready_qs_runnable s"]) - apply (rule_tac Q'="\rv s. invs' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom \ ready_qs_runnable s" - in bind_wp) - apply (rename_tac l1) - apply (case_tac "l1 = 0") - (* switch to idle thread *) - apply simp - apply (rule hoare_pre) - apply (wp (once) switchToIdleThread_ct_not_queued) - apply (wp (once)) - apply ((wp hoare_disjI1 switchToIdleThread_curr_is_idle)+)[1] - apply simp + (is "\_\ _ \\_. ?POST\") +proof - + note switchToThread_invs[wp del] + note switchToThread_invs_no_cicd'[wp del] + note switchToThread_lookupBitmapPriority_wp[wp] + note assert_wp[wp del] + note if_split[split del] + + (* if we only have one domain, we are in it *) + have one_domain_case: + "\s. \ invs_no_cicd' s; numDomains \ 1 \ \ ksCurDomain s = 0" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def maxDomain_def) + + show ?thesis + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule bind_wp[OF _ stateAssert_sp])+ + apply (simp only: return_bind, simp) + apply (rule bind_wp[where Q'="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) + apply (rule_tac Q'="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in bind_wp) + apply (rename_tac l1) + apply (case_tac "l1 = 0") + (* switch to idle thread *) + apply simp + apply (rule hoare_pre) + apply (wp (once) switchToIdleThread_ct_not_queued_no_cicd') + apply (wp (once)) + apply ((wp hoare_disjI1 switchToIdleThread_curr_is_idle)+)[1] + apply simp (* we have a thread to switch to *) - apply (clarsimp simp: bitmap_fun_defs) - apply (wp assert_inv switchToThread_ct_not_queued_2 assert_inv hoare_disjI2 - switchToThread_tcb_in_cur_domain' isSchedulable_wp) - apply clarsimp - apply (clarsimp simp: valid_queues_def lookupBitmapPriority_def[symmetric] - ready_qs_runnable_def invs'_def) - apply (drule (3) lookupBitmapPriority_obj_at') - apply normalise_obj_at' - apply (fastforce simp: tcb_in_cur_domain'_def inQ_def elim: obj_at'_weaken) - apply (wpsimp simp: bitmap_fun_defs) - apply (wpsimp wp: curDomain_or_return_0[simplified] simp: invs_ksCurDomain_maxDomain') - done + apply (clarsimp simp: bitmap_fun_defs) + apply (wp assert_inv switchToThread_ct_not_queued_2 assert_inv hoare_disjI2 + switchToThread_tcb_in_cur_domain') + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def + valid_bitmaps_def) + apply (frule (6) lookupBitmapPriority_obj_at') + apply (clarsimp simp: tcb_in_cur_domain'_def obj_at'_def tcbQueueEmpty_def inQ_def) + apply (wpsimp simp: bitmap_fun_defs curDomain_def one_domain_case)+ + done +qed lemma chooseThread_activatable_2: - "\invs'\ chooseThread \\_. ct_in_state' activatable'\" + "\invs_no_cicd'\ chooseThread \\rv. ct_in_state' activatable'\" apply (rule hoare_pre, rule hoare_strengthen_post) - apply (rule chooseThread_invs'_posts) + apply (rule chooseThread_invs_no_cicd'_posts) apply simp+ done lemma chooseThread_ct_not_queued_2: - "\ invs' \ chooseThread \\_ s. obj_at' (Not \ tcbQueued) (ksCurThread s) s\" + "\ invs_no_cicd'\ chooseThread \\rv s. obj_at' (Not \ tcbQueued) (ksCurThread s) s\" (is "\_\ _ \\_. ?POST\") apply (rule hoare_pre, rule hoare_strengthen_post) - apply (rule chooseThread_invs'_posts) + apply (rule chooseThread_invs_no_cicd'_posts) apply simp+ done -lemma chooseThread_invs'': - "chooseThread \invs'\" - unfolding chooseThread_def Let_def - apply (simp only: return_bind, simp split del: if_split) - apply (rule bind_wp[OF _ stateAssert_sp]) - apply (rule bind_wp[where Q'="\rv s. invs' s \ rv = ksCurDomain s \ ready_qs_runnable s"]) - apply (rule_tac Q'="\rv s. invs' s \ curdom = ksCurDomain s \ - rv = ksReadyQueuesL1Bitmap s curdom \ ready_qs_runnable s" - in bind_wp) - apply (rename_tac l1) - apply (case_tac "l1 = 0") - (* switch to idle thread *) - apply (simp, wp switchToIdleThread_invs', simp) - (* we have a thread to switch to *) - apply (clarsimp simp: bitmap_fun_defs) - apply (wp assert_inv isSchedulable_wp) - apply (clarsimp simp: valid_queues_def invs'_def) - apply (wpsimp simp: bitmap_fun_defs) - apply (wpsimp wp: curDomain_or_return_0[simplified] simp: invs_ksCurDomain_maxDomain') - done +lemma chooseThread_invs_no_cicd': + "\ invs_no_cicd' \ chooseThread \\rv. invs' \" +proof - + note switchToThread_invs[wp del] + note switchToThread_invs_no_cicd'[wp del] + note switchToThread_lookupBitmapPriority_wp[wp] + note assert_wp[wp del] + note if_split[split del] + + (* if we only have one domain, we are in it *) + have one_domain_case: + "\s. \ invs_no_cicd' s; numDomains \ 1 \ \ ksCurDomain s = 0" + by (simp add: all_invs_but_ct_idle_or_in_cur_domain'_def maxDomain_def) + + (* NOTE: do *not* unfold numDomains in the rest of the proof, + it should work for any number *) + + (* FIXME this is almost identical to the chooseThread_invs_no_cicd'_posts proof, can generalise? *) + show ?thesis + apply (clarsimp simp: chooseThread_def Let_def curDomain_def) + apply (rule bind_wp[OF _ stateAssert_sp])+ + apply (simp only: return_bind, simp) + apply (rule bind_wp[where Q'="\rv s. invs_no_cicd' s \ rv = ksCurDomain s + \ ksReadyQueues_asrt s \ ready_qs_runnable s"]) + apply (rule_tac Q'="\rv s. invs_no_cicd' s \ curdom = ksCurDomain s \ + rv = ksReadyQueuesL1Bitmap s curdom \ + ksReadyQueues_asrt s \ ready_qs_runnable s" in bind_wp) + apply (rename_tac l1) + apply (case_tac "l1 = 0") + (* switch to idle thread *) + apply (simp, wp switchToIdleThread_invs_no_cicd', simp) + (* we have a thread to switch to *) + apply (clarsimp simp: bitmap_fun_defs) + apply (wp assert_inv) + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_pspace'_def + valid_bitmaps_def) + apply (frule (6) lookupBitmapPriority_obj_at') + apply (clarsimp simp: tcb_in_cur_domain'_def obj_at'_def tcbQueueEmpty_def inQ_def) + apply (fastforce elim: bitmapQ_from_bitmap_lookup simp: lookupBitmapPriority_def) + apply (wpsimp simp: bitmap_fun_defs curDomain_def one_domain_case)+ + done +qed lemma chooseThread_in_cur_domain': - "\ invs' \ chooseThread \\rv s. ksCurThread s = ksIdleThread s \ tcb_in_cur_domain' (ksCurThread s) s\" + "\ invs_no_cicd' \ chooseThread \\rv s. ksCurThread s = ksIdleThread s \ tcb_in_cur_domain' (ksCurThread s) s\" apply (rule hoare_pre, rule hoare_strengthen_post) - apply (rule chooseThread_invs'_posts, simp_all) + apply (rule chooseThread_invs_no_cicd'_posts, simp_all) done lemma scheduleChooseNewThread_invs': - "scheduleChooseNewThread \invs'\" + "\ invs' and (\s. ksSchedulerAction s = ChooseNewThread) \ + scheduleChooseNewThread + \ \_ s. invs' s \" unfolding scheduleChooseNewThread_def - apply (wpsimp wp: ssa_invs' chooseThread_invs'' chooseThread_ct_not_queued_2 - chooseThread_activatable_2 chooseThread_invs'' - chooseThread_in_cur_domain' nextDomain_invs' chooseThread_ct_not_queued_2) - done - -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) - -lemma machine_op_lift_underlying_memory_invar: - "(x, b) \ fst (machine_op_lift a m) \ underlying_memory b = underlying_memory m" - by (clarsimp simp: in_monad machine_op_lift_def machine_rest_lift_def select_f_def) - -lemma setNextInterrupt_invs'[wp]: - "setNextInterrupt \invs'\" - unfolding setNextInterrupt_def - apply (wpsimp wp: dmo_invs' ARM.setDeadline_irq_masks threadGet_wp getReleaseQueue_wp) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - by (auto simp: in_monad setDeadline_def machine_op_lift_underlying_memory_invar) - -lemma setCurSc_invs'[wp]: - "setCurSc v \invs'\" - unfolding setCurSc_def - apply wpsimp - apply (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_queues_def valid_queues_no_bitmap_def valid_bitmapQ_def bitmapQ_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def valid_irq_node'_def - valid_queues'_def valid_release_queue_def valid_release_queue'_def - valid_dom_schedule'_def) - done - -lemma setConsumedTime_invs'[wp]: - "setConsumedTime v \invs'\" - unfolding setConsumedTime_def - apply wpsimp - apply (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_queues_def valid_queues_no_bitmap_def valid_bitmapQ_def bitmapQ_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def valid_irq_node'_def - valid_queues'_def valid_release_queue_def valid_release_queue'_def - valid_dom_schedule'_def) - done - -lemma setDomainTime_invs'[wp]: - "setDomainTime v \invs'\" - unfolding setDomainTime_def - apply wpsimp - done - -lemma valid_idle'_ko_at_idle_sc_is_idle': - "\valid_idle' s; ko_at' ko scPtr s\ \ (scPtr = idle_sc_ptr \ idle_sc' ko)" - apply (clarsimp simp: valid_idle'_def obj_at'_real_def ko_wp_at'_def) - done - -lemma refillTailIndex_bounded: - "valid_sched_context' ko s \ 0 < scRefillMax ko \ refillTailIndex ko < scRefillMax ko" - apply (clarsimp simp: valid_sched_context'_def refillTailIndex_def Let_def split: if_split) - by linarith - -lemma refillAddTail_valid_objs'[wp]: - "refillAddTail scPtr t \valid_objs'\" - apply (simp add: refillAddTail_def) - apply (wpsimp wp: set_sc_valid_objs' getRefillNext_wp getRefillSize_wp - simp: updateSchedContext_def) - apply (frule (1) sc_ko_at_valid_objs_valid_sc', clarsimp) - apply (clarsimp simp: valid_obj'_def obj_at'_def projectKOs opt_map_red opt_pred_def) - apply (intro conjI) - apply (frule refillTailIndex_bounded) - apply (clarsimp simp: valid_sched_context'_def) - apply (frule refillTailIndex_bounded) - apply (clarsimp simp: valid_sched_context_size'_def objBits_simps valid_sched_context'_def) - done - -lemma refillAddTail_invs'[wp]: - "refillAddTail scPtr t \invs'\" - apply (simp add: refillAddTail_def) - apply (wpsimp wp: setSchedContext_invs' getRefillNext_wp getRefillSize_wp - simp: updateSchedContext_def) - apply (frule (1) invs'_ko_at_valid_sched_context', clarsimp) - apply (drule ko_at'_inj, assumption, clarsimp)+ - apply (intro conjI) - apply (fastforce dest: live_sc'_ko_ex_nonz_cap_to') - apply (frule refillTailIndex_bounded) - apply (clarsimp simp: valid_sched_context'_def) - apply (frule refillTailIndex_bounded) - apply (clarsimp simp: valid_sched_context_size'_def objBits_def objBitsKO_def valid_sched_context'_def) - done - -lemma refillBudgetCheckRoundRobin_invs'[wp]: - "\invs' and (\s. active_sc_at' (ksCurSc s) s)\ - refillBudgetCheckRoundRobin consumed - \\_. invs'\" - supply if_split [split del] - apply (simp add: refillBudgetCheckRoundRobin_def updateRefillTl_def updateRefillHd_def) - apply (wpsimp simp: wp: updateSchedContext_refills_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 - ko_wp_at'_def valid_sched_context_size'_def objBits_def objBitsKO_def) - apply (wpsimp wp: updateSchedContext_refills_invs' getCurTime_wp updateSchedContext_active_sc_at') - apply (wpsimp wp: ) - apply clarsimp - 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) - done - -lemma updateRefillTl_valid_objs'[wp]: - "updateRefillTl scPtr f \valid_objs'\" - apply (clarsimp simp: updateRefillTl_def updateSchedContext_def) - apply (wpsimp wp: set_sc_valid_objs') - apply (fastforce dest: sc_ko_at_valid_objs_valid_sc' - simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps) - done - -crunch scheduleUsed - for valid_objs'[wp]: valid_objs' - (simp: refillFull_def refillEmpty_def) - -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_sc'_def projectKOs) - apply (fastforce dest: sc_ko_at_valid_objs_valid_sc' - simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps) - 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_sc'_def projectKOs) - done - -lemma scheduleUsed_if_live_then_nonz_cap'[wp]: - "scheduleUsed scPtr refill \if_live_then_nonz_cap'\" - apply (wpsimp simp: scheduleUsed_def refillAddTail_def updateSchedContext_def - wp: getRefillSize_wp refillFull_wp refillEmpty_wp getRefillNext_wp) - apply (fastforce intro: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_real_def projectKO_sc live_sc'_def) - done - -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') - -lemma scheduleUsed_invs'[wp]: - "scheduleUsed scPtr refill \invs'\" - apply (simp add: scheduleUsed_def) - apply (wpsimp wp: refillFull_wp refillEmpty_wp) - done - -lemma refillPopHead_valid_objs'[wp]: - "\valid_objs' and obj_at' (\sc'. 1 < scRefillCount sc') scPtr \ - refillPopHead scPtr - \\_. valid_objs'\" - apply (clarsimp simp: refillPopHead_def updateSchedContext_def getRefillNext_def) - apply (wpsimp wp: set_sc_valid_objs') - apply (frule (1) sc_ko_at_valid_objs_valid_sc') - apply (clarsimp simp: readRefillNext_def readSchedContext_def) - by (fastforce simp: obj_at'_def projectKOs scBits_simps refillNextIndex_def - valid_sched_context'_def valid_sched_context_size'_def objBits_simps' - dest!: readObject_misc_ko_at') - -lemma refillPopHead_invs'[wp]: - "\invs' and obj_at' (\sc'. 1 < scRefillCount sc') scPtr\ - refillPopHead scPtr - \\_. invs'\" - apply (simp add: refillPopHead_def) - apply (wpsimp wp: updateSchedContext_invs' getRefillNext_wp) - apply (intro conjI; intro allI impI) - apply (clarsimp simp: obj_at'_def) - apply (rule if_live_then_nonz_capE') - apply (erule invs_iflive') - apply (clarsimp simp: ko_wp_at'_def obj_at'_def projectKO_eq projectKO_sc live_sc'_def) - apply (fastforce dest!: invs'_ko_at_valid_sched_context' - simp: valid_sched_context'_def valid_sched_context_size'_def - refillNextIndex_def obj_at_simps) - done - -lemma refillPopHead_active_sc_at'[wp]: - "refillPopHead scPtr \active_sc_at' scPtr'\" - apply (simp add: refillPopHead_def) - apply (wpsimp wp: updateSchedContext_active_sc_at' getRefillNext_wp) - done - -lemma refillAddTail_active_sc_at'[wp]: - "refillAddTail scPtr refill \active_sc_at' scPtr'\" - apply (simp add: refillAddTail_def getRefillSize_def refillTailIndex_def) - apply (wpsimp wp: updateSchedContext_active_sc_at' hoare_drop_imps getRefillNext_wp) - done - -lemma updateRefillTl_active_sc_at'[wp]: - "updateRefillTl scPtr f \active_sc_at' scPtr'\" - apply (simp add: updateRefillTl_def) - apply (wpsimp wp: updateSchedContext_active_sc_at' hoare_drop_imps getRefillNext_wp) - done - -crunch scheduleUsed - for active_sc_at'[wp]: "active_sc_at' scPtr" - (wp: crunch_wps) - -crunch refillPopHead - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' scPtr" - -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) - done - -lemma updateRefillHd_active_sc_at'[wp]: - "updateRefillHd scPtr f \active_sc_at' scPr\" - apply (clarsimp simp: updateRefillHd_def) - apply (wpsimp wp: updateSchedContext_active_sc_at') - done - -lemma updateRefillHd_active_sc_at'_ksCurSc[wp]: - "updateRefillHd scPtr f \\s. active_sc_at' (ksCurSc s) s\" - apply (rule_tac f=ksCurSc in hoare_lift_Pf) - apply wpsimp - apply (clarsimp simp: updateRefillHd_def updateSchedContext_def) - apply wpsimp - done - -lemma setRefillHd_active_sc_at'[wp]: - "setRefillHd scPtr f \active_sc_at' scPr\" - apply (clarsimp simp: setRefillHd_def) - apply (wpsimp wp: updateSchedContext_active_sc_at') - done - -lemma setReprogramTimer_obj_at'[wp]: - "setReprogramTimer b \\s. Q (obj_at' P t s)\" - unfolding active_sc_at'_def - by (wpsimp simp: setReprogramTimer_def) - -lemma setReprogramTimer_active_sc_at'[wp]: - "setReprogramTimer b \active_sc_at' scPtr\" - unfolding active_sc_at'_def - by wpsimp - -crunch refillBudgetCheck, refillUnblockCheck - for valid_queues[wp]: valid_queues - and valid_queues'[wp]: valid_queues' - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - 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 active_sc_at'[wp]: "active_sc_at' scPtr" - (wp: crunch_wps) - -lemma mergeRefills_valid_objs': - "\\s. valid_objs' s \ sc_at' scPtr s \ ((\sc. 1 < scRefillCount sc) |< scs_of' s) scPtr\ - mergeRefills scPtr - \\_. valid_objs'\" - apply (clarsimp simp: mergeRefills_def updateRefillHd_def) - apply (rule_tac Q'="\_ s. valid_objs' s \ sc_at' scPtr s" in bind_wp_fwd) - apply wpsimp - apply (clarsimp simp: obj_at_simps opt_map_red opt_pred_def) - apply (wpsimp wp: set_sc_valid_objs' simp: updateSchedContext_def) - apply (clarsimp simp: valid_sched_context'_def obj_at_simps valid_obj'_def - valid_sched_context_size'_def opt_map_red opt_pred_def - dest!: sc_ko_at_valid_objs_valid_sc') - done - -lemma no_ofail_refillHeadOverlapping: - "no_ofail (sc_at' scp) (refillHeadOverlapping scp)" - unfolding refillHeadOverlapping_def oreturn_def obind_def oliftM_def no_ofail_def - readRefillSize_def readRefillNext_def - by (clarsimp dest!: no_ofailD[OF no_ofail_readSchedContext]) - -lemma refillHeadOverlapping_implies_count_greater_than_one: - "\the (refillHeadOverlapping scPtr s); sc_at' scPtr s\ - \ ((\sc. 1 < scRefillCount sc) |< scs_of' s) scPtr" - apply (clarsimp simp: refillHeadOverlapping_def readSchedContext_def oliftM_def - readRefillNext_def readRefillSize_def obind_def omonad_defs - split: option.splits dest!: readObject_misc_ko_at') - apply (fastforce dest: no_ofail_sc_at'_readObject[unfolded no_ofail_def, rule_format]) - apply (clarsimp simp: obj_at_simps opt_map_red opt_pred_def MIN_REFILLS_def) - done - -lemma refillHeadOverlappingLoop_valid_objs': - "\\s. valid_objs' s \ sc_at' scPtr s\ - refillHeadOverlappingLoop scPtr - \\_. valid_objs'\" - (is "valid ?pre _ _") - apply (clarsimp simp: refillHeadOverlappingLoop_def) - apply (wpsimp wp: valid_whileLoop[where I="\_. ?pre"] mergeRefills_valid_objs') - apply (clarsimp simp: runReaderT_def) - apply (prop_tac "((\sc. 1 < scRefillCount sc) |< scs_of' s) scPtr") - apply (fastforce elim: refillHeadOverlapping_implies_count_greater_than_one - simp: obj_at_simps opt_map_red) - apply simp+ - done - -lemma updateRefillHd_valid_objs': - "\\s. valid_objs' s \ sc_at' scPtr s\ - updateRefillHd scPtr f - \\_. valid_objs'\" - apply (clarsimp simp: updateRefillHd_def) - apply (wpsimp wp: set_sc_valid_objs' simp: updateSchedContext_def) - apply (clarsimp simp: is_active_sc'_def valid_sched_context'_def obj_at_simps valid_obj'_def - valid_sched_context_size'_def opt_map_red opt_pred_def active_sc_at'_rewrite - dest!: sc_ko_at_valid_objs_valid_sc') - done - -lemma setRefillHd_valid_objs': - "\\s. valid_objs' s \ sc_at' scPtr s\ - setRefillHd scPtr f - \\_. valid_objs'\" - apply (wpsimp simp: setRefillHd_def - wp: updateRefillHd_valid_objs') - done - -lemma refillUnblockCheck_valid_objs'[wp]: - "refillUnblockCheck scPtr \valid_objs'\" - apply (clarsimp simp: refillUnblockCheck_def isRoundRobin_def refillReady_def) - apply (wpsimp wp: updateRefillHd_valid_objs' refillHeadOverlappingLoop_valid_objs' scActive_wp) - done - -lemma refillUnblockCheck_valid_mdb'[wp]: - "refillUnblockCheck scPtr \valid_mdb'\" - apply (clarsimp simp: refillUnblockCheck_def valid_mdb'_def) - apply (wpsimp wp: scActive_wp) - done - -lemma refillUnblockCheck_valid_machine_state'[wp]: - "refillUnblockCheck scPtr \valid_machine_state'\" - apply (clarsimp simp: refillUnblockCheck_def refillReady_def isRoundRobin_def - refillHeadOverlappingLoop_def mergeRefills_def updateRefillHd_def - refillPopHead_def updateSchedContext_def setReprogramTimer_def - valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) - apply (wpsimp wp: whileLoop_valid_inv hoare_vcg_all_lift hoare_vcg_disj_lift scActive_wp - hoare_drop_imps getRefillNext_wp) - apply fastforce - done - -lemma refillUnblockCheck_list_refs_of_replies'[wp]: - "refillUnblockCheck scPtr \\s. P (list_refs_of_replies' s)\" - apply (clarsimp simp: refillUnblockCheck_def valid_mdb'_def refillHeadOverlappingLoop_def - mergeRefills_def updateRefillHd_def refillPopHead_def updateSchedContext_def - setReprogramTimer_def refillReady_def isRoundRobin_def) - apply (wpsimp wp: whileLoop_valid_inv hoare_drop_imps scActive_wp getRefillNext_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 projectKO_sc live_sc'_def) - done - -lemma mergeRefills_if_live_then_nonz_cap'[wp]: - "mergeRefills scPtr \if_live_then_nonz_cap'\" - apply (clarsimp simp: mergeRefills_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp simp: updateRefillHd_def updateSchedContext_def) - apply (fastforce intro: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_real_def projectKO_sc live_sc'_def) - done - -lemma nonOverlappingMergeRefills_if_live_then_nonz_cap'[wp]: - "nonOverlappingMergeRefills scPtr \if_live_then_nonz_cap'\" - apply (clarsimp simp: nonOverlappingMergeRefills_def updateRefillHd_def) - apply (rule bind_wp_fwd_skip, wpsimp)+ - by (wpsimp simp: updateSchedContext_def, - fastforce intro: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_real_def projectKO_sc live_sc'_def)+ - -crunch refillHeadOverlappingLoop, headInsufficientLoop - for if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - (wp: crunch_wps) - -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 projectKO_sc live_sc'_def) - done - -lemma setRefillHd_if_live_then_nonz_cap'[wp]: - "setRefillHd scPtr f \if_live_then_nonz_cap'\" - apply (wpsimp simp: setRefillHd_def) - done - -crunch handleOverrunLoop - for if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - (wp: crunch_wps) - -lemma refillUnblockCheck_if_live_then_nonz_cap'[wp]: - "refillUnblockCheck scPtr \if_live_then_nonz_cap'\" - apply (clarsimp simp: refillUnblockCheck_def setReprogramTimer_def refillReady_def - isRoundRobin_def) - apply (wpsimp wp: scActive_wp) - done - -lemma mergeRefills_valid_idle'[wp]: - "mergeRefills scPtr \valid_idle'\" - apply (clarsimp simp: mergeRefills_def updateRefillHd_def updateSchedContext_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp simp: valid_idle'_def obj_at'_def) - done - -lemma nonOverlappingMergeRefills_valid_idle'[wp]: - "nonOverlappingMergeRefills scPtr \valid_idle'\" - apply (clarsimp simp: nonOverlappingMergeRefills_def updateRefillHd_def) - apply (rule bind_wp_fwd_skip, wpsimp)+ - apply (clarsimp simp: updateSchedContext_def, - rule bind_wp[OF _ get_sc_sp'], - wpsimp simp: valid_idle'_def obj_at'_def)+ - done - -crunch refillHeadOverlappingLoop, headInsufficientLoop, handleOverrunLoop - for valid_idle'[wp]: valid_idle' - (wp: crunch_wps) - -lemma refillUnblockCheck_valid_idle'[wp]: - "refillUnblockCheck scPtr \valid_idle'\" - apply (clarsimp simp: refillUnblockCheck_def isRoundRobin_def refillReady_def - setReprogramTimer_def updateRefillHd_def updateSchedContext_def) - apply (wpsimp wp: scActive_wp) - apply (clarsimp simp: valid_idle'_def obj_at'_def) - done - -crunch refillHeadOverlappingLoop, headInsufficientLoop, handleOverrunLoop - for ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - (wp: crunch_wps) - -lemma refillUnblockCheck_ct_idle_or_in_cur_domain'[wp]: - "refillUnblockCheck scPtr \ct_idle_or_in_cur_domain'\" - apply (clarsimp simp: refillUnblockCheck_def isRoundRobin_def refillReady_def - setReprogramTimer_def updateRefillHd_def) - apply (wpsimp wp: scActive_wp) - done - -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" - and valid_replies'[wp]: valid_replies' - (wp: crunch_wps valid_replies'_lift) - -lemma refillUnblockCheck_invs': - "refillUnblockCheck scPtr \invs'\" - apply (clarsimp simp: invs'_def valid_pspace'_def pred_conj_def) - apply wpsimp - done - -crunch ifCondRefillUnblockCheck - for invs'[wp]: invs' - (wp: hoare_vcg_if_lift2 crunch_wps simp: crunch_simps) - -lemma nonOverlappingMergeRefills_valid_objs': - "\\s. valid_objs' s \ sc_at' scPtr s\ - nonOverlappingMergeRefills scPtr - \\_. valid_objs'\" - apply (clarsimp simp: nonOverlappingMergeRefills_def updateRefillHd_def) - apply (rule bind_wp[OF _ get_sc_sp']) - apply (rule_tac bind_wp[OF _ assert_sp]) - apply (rule_tac Q'="\_ s. valid_objs' s \ sc_at' scPtr s" in bind_wp_fwd) - apply wpsimp - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def) - apply (wpsimp wp: set_sc_valid_objs' simp: updateSchedContext_def) - apply (rule_tac Q'="\_. valid_objs' and sc_at' scPtr" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_sched_context'_def obj_at_simps valid_obj'_def - valid_sched_context_size'_def opt_map_red opt_pred_def - dest!: sc_ko_at_valid_objs_valid_sc') - apply (wpsimp wp: set_sc_valid_objs' setSchedContext_active_sc_at' simp: updateSchedContext_def)+ - apply (fastforce simp: valid_sched_context'_def obj_at_simps valid_obj'_def - valid_sched_context_size'_def opt_map_red opt_pred_def - dest!: sc_ko_at_valid_objs_valid_sc') - done - -crunch refillHeadOverlappingLoop, headInsufficientLoop, handleOverrunLoop - for active_sc_at'[wp]: "active_sc_at' scPtr" - and ksCurSc[wp]: "\s. P (ksCurSc s)" - (wp: crunch_wps) - -lemma headInsufficientLoop_valid_objs': - "\\s. valid_objs' s \ sc_at' scPtr s\ - headInsufficientLoop scPtr - \\_. valid_objs'\" - (is "valid ?pre _ _") - apply (clarsimp simp: headInsufficientLoop_def) - apply (wpsimp wp: valid_whileLoop[where I="\_. ?pre"] nonOverlappingMergeRefills_valid_objs') - done - -lemma handleOverrunLoop_valid_objs': - "\\s. valid_objs' s \ active_sc_at' (ksCurSc s) s\ - handleOverrunLoop usage - \\_. valid_objs'\" - (is "valid ?pre _ _") - apply (clarsimp simp: handleOverrunLoop_def) - apply (wpsimp wp: valid_whileLoop[where I="\_. ?pre"]) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply (clarsimp simp: handleOverrunLoopBody_def) - apply (wpsimp wp: updateRefillHd_valid_objs' simp: refillSingle_def) - apply (frule (1) sc_ko_at_valid_objs_valid_sc') - apply (fastforce simp: valid_sched_context'_def active_sc_at'_def obj_at_simps refillTailIndex_def Let_def - split: if_split_asm) - apply (rule_tac f=ksCurSc in hoare_lift_Pf3) - apply wpsimp+ - done - -lemma refillBudgetCheck_valid_objs': - "refillBudgetCheck usage \valid_objs'\" - apply (clarsimp simp: refillBudgetCheck_def isRoundRobin_def refillReady_def getCurSc_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp[OF _ scActive_sp]) - apply (rule bind_wp[OF _ assert_sp]) - apply (wpsimp wp: headInsufficientLoop_valid_objs' handleOverrunLoop_valid_objs' - hoare_vcg_all_lift updateRefillHd_valid_objs' hoare_vcg_if_lift2 hoare_drop_imps) - apply (clarsimp simp: active_sc_at'_def obj_at'_def) - done - -lemma refillBudgetCheck_valid_mdb'[wp]: - "refillBudgetCheck usage \valid_mdb'\" - apply (clarsimp simp: handleOverrunLoop_def valid_mdb'_def) - apply (wpsimp wp: scActive_wp) - done - -lemma handleOverrunLoop_list_refs_of_replies'[wp]: - "handleOverrunLoop usage \\s. sym_refs (list_refs_of_replies' s)\" - apply (clarsimp simp: handleOverrunLoop_def) - apply (wpsimp wp: whileLoop_valid_inv hoare_drop_imps getRefillNext_wp - getRefillSize_wp refillFull_wp refillEmpty_wp - simp: o_def handleOverrunLoopBody_def refillPopHead_def updateSchedContext_def - scheduleUsed_def refillAddTail_def updateRefillHd_def setRefillTl_def - updateRefillTl_def refillSingle_def) - done - -lemma refillBudgetCheck_list_refs_of_replies'[wp]: - "refillBudgetCheck usage \\s. sym_refs (list_refs_of_replies' s)\" - apply (clarsimp simp: refillBudgetCheck_def refillPopHead_def updateSchedContext_def - setReprogramTimer_def refillReady_def isRoundRobin_def - headInsufficientLoop_def nonOverlappingMergeRefills_def) - apply (rule bind_wp_fwd_skip, solves wpsimp)+ - apply (wpsimp wp: whileLoop_valid_inv hoare_drop_imps refillFull_wp refillEmpty_wp getRefillNext_wp - getRefillSize_wp hoare_vcg_all_lift hoare_vcg_if_lift2 - simp: o_def scheduleUsed_def refillAddTail_def setRefillHd_def updateRefillHd_def - setRefillTl_def updateRefillTl_def updateSchedContext_def) - done - -lemma refillBudgetCheck_if_live_then_nonz_cap'[wp]: - "refillBudgetCheck uage \if_live_then_nonz_cap'\" - apply (wpsimp simp: refillBudgetCheck_def setReprogramTimer_def refillReady_def - isRoundRobin_def - wp: hoare_drop_imps) - done - -lemma refillBudgetCheck_valid_idle'[wp]: - "refillBudgetCheck usage \valid_idle'\" - apply (clarsimp simp: refillBudgetCheck_def isRoundRobin_def refillReady_def - setReprogramTimer_def updateRefillHd_def setRefillHd_def) - apply (rule bind_wp_fwd_skip, solves wpsimp)+ - apply (wpsimp wp: updateSchedContext_valid_idle') - done - -lemma handleOverrunLoop_valid_machine_state'[wp]: - "handleOverrunLoop usage \valid_machine_state'\" - apply (clarsimp simp: handleOverrunLoop_def) - apply (wpsimp wp: whileLoop_valid_inv hoare_drop_imps getRefillNext_wp - getRefillSize_wp refillFull_wp refillEmpty_wp - simp: handleOverrunLoopBody_def refillPopHead_def updateSchedContext_def - scheduleUsed_def refillAddTail_def updateRefillHd_def setRefillTl_def - updateRefillTl_def refillSingle_def) - done - -lemma refillBudgetCheck_valid_machine_state'[wp]: - "refillBudgetCheck usage \valid_machine_state'\" - apply (clarsimp simp: refillBudgetCheck_def refillPopHead_def updateSchedContext_def - setReprogramTimer_def refillReady_def isRoundRobin_def - headInsufficientLoop_def nonOverlappingMergeRefills_def) - apply (rule bind_wp_fwd_skip, solves wpsimp)+ - apply (wpsimp wp: whileLoop_valid_inv hoare_vcg_all_lift hoare_vcg_disj_lift scActive_wp hoare_drop_imps - refillFull_wp refillEmpty_wp getRefillNext_wp getRefillSize_wp - simp: scheduleUsed_def refillAddTail_def setRefillTl_def updateRefillTl_def - setRefillHd_def updateRefillHd_def updateSchedContext_def) - done - -lemma refillBudgetCheck_ct_idle_or_in_cur_domain'[wp]: - "refillBudgetCheck usage \ct_idle_or_in_cur_domain'\" - apply (clarsimp simp: refillBudgetCheck_def isRoundRobin_def refillReady_def - setReprogramTimer_def updateRefillHd_def) - apply (wpsimp wp: getRefillSize_wp refillFull_wp refillEmpty_wp hoare_vcg_all_lift hoare_drop_imps - hoare_vcg_if_lift2 - simp: scheduleUsed_def refillAddTail_def setRefillTl_def updateRefillTl_def - updateRefillHd_def setRefillHd_def) - done - -lemma refillBudgetCheck_invs'[wp]: - "refillBudgetCheck usage \invs'\" - apply (clarsimp simp: invs'_def valid_pspace'_def pred_conj_def) - apply (wpsimp wp: refillBudgetCheck_valid_objs') - done - -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) - -lemma switchSchedContext_invs': - "switchSchedContext \invs'\" - apply (simp add: switchSchedContext_def) - apply (wpsimp wp: commitTime_invs' getReprogramTimer_wp refillUnblockCheck_invs' threadGet_wp simp: getCurSc_def) - apply (fastforce simp: obj_at'_def projectKO_eq projectKO_opt_tcb) - done - -lemma isSchedulable_bool_runnableE: - "isSchedulable_bool t s \ tcb_at' t s \ st_tcb_at' runnable' t s" - unfolding isSchedulable_bool_def - by (clarsimp simp: pred_tcb_at'_def obj_at'_def pred_map_def projectKO_eq projectKO_opt_tcb - elim!: opt_mapE) - -lemma rescheduleRequired_invs'[wp]: - "rescheduleRequired \invs'\" - unfolding rescheduleRequired_def - apply (wpsimp wp: ssa_invs' isSchedulable_wp) - apply (clarsimp simp: invs'_def isSchedulable_bool_def vs_all_heap_simps - st_tcb_at'_def obj_at_simps pred_map_simps - elim!: opt_mapE) - done - -lemma rescheduleRequired_ksSchedulerAction[wp]: - "\\_. P ChooseNewThread\ rescheduleRequired \\_ s. P (ksSchedulerAction s)\" - unfolding rescheduleRequired_def by (wpsimp wp: isSchedulable_wp) - -lemma inReleaseQueue_wp: - "\\s. \ko. ko_at' ko tcb_ptr s \ P (tcbInReleaseQueue ko) s\ - inReleaseQueue tcb_ptr - \P\" - unfolding inReleaseQueue_def threadGet_getObject - apply (wpsimp wp: getObject_tcb_wp) - apply (clarsimp simp: obj_at'_def) - done - -lemma possibleSwitchTo_weak_sch_act[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t - \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - unfolding possibleSwitchTo_def - apply (wpsimp wp: inReleaseQueue_wp threadGet_wp rescheduleRequired_weak_sch_act_wf) - by (auto simp: obj_at'_def weak_sch_act_wf_def tcb_in_cur_domain'_def - projectKO_eq ps_clear_domE) - -crunch possibleSwitchTo - for valid_pspace'[wp]: valid_pspace' - and valid_queues[wp]: valid_queues - and 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 valid_queues'[wp]: valid_queues' - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - 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)" - and ctes_of[wp]: "\s. P (ctes_of s)" - and ksInterruptState[wp]: "\s. P (ksInterruptState s)" - and irq_states' [wp]: valid_irq_states' - and pde_mappings' [wp]: valid_pde_mappings' - 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 gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - and valid_objs'[wp]: valid_objs' - and ksArchState[wp]: "\s. P (ksArchState s)" - and ksIdleThread[wp]: "\s. P (ksIdleThread s)" - and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" - and valid_irq_handlers'[wp]: valid_irq_handlers' - (wp: crunch_wps cur_tcb_lift valid_irq_handlers_lift'' simp: crunch_simps) - -lemmas possibleSwitchTo_typ_ats[wp] = typ_at_lifts[OF possibleSwitchTo_typ_at'] - -lemma possibleSwitchTo_sch_act[wp]: - "\\s. sch_act_wf (ksSchedulerAction s) s \ st_tcb_at' runnable' t s\ - possibleSwitchTo t - \\rv s. sch_act_wf (ksSchedulerAction s) s\" - apply (wpsimp simp: possibleSwitchTo_def wp: inReleaseQueue_wp threadGet_wp) - by (fastforce simp: obj_at'_def tcb_in_cur_domain'_def) - -lemma possibleSwitchTo_iflive'[wp]: - "\if_live_then_nonz_cap' and ex_nonz_cap_to' t - and (\s. \t. ksSchedulerAction s = SwitchToThread t - \ st_tcb_at' runnable' t s)\ - possibleSwitchTo t - \\rv. if_live_then_nonz_cap'\" - by (wpsimp simp: possibleSwitchTo_def inReleaseQueue_def - wp: hoare_vcg_if_lift2 hoare_drop_imps) - -lemma possibleSwitchTo_ct_idle_or_in_cur_domain'[wp]: - "possibleSwitchTo t \ct_idle_or_in_cur_domain'\" - apply (wpsimp simp: possibleSwitchTo_def - wp: threadGet_wp inReleaseQueue_wp) - apply (fastforce simp: obj_at'_def ct_idle_or_in_cur_domain'_def) - done - -lemma possibleSwitchTo_utr[wp]: - "possibleSwitchTo t \untyped_ranges_zero'\" - by (wpsimp simp: cteCaps_of_def o_def wp: untyped_ranges_zero_lift) - -lemma possibleSwitchTo_invs'[wp]: - "\invs' and st_tcb_at' runnable' tptr\ - possibleSwitchTo tptr - \\_. invs'\" - apply (simp add: possibleSwitchTo_def) - apply (wpsimp wp: hoare_vcg_imp_lift threadGet_wp inReleaseQueue_wp ssa_invs') - apply (clarsimp simp: invs'_def pred_tcb_at'_def obj_at'_def) - done - -lemma possibleSwitchTo_sch_act_not_other: - "\\s. sch_act_not t' s \ t' \ t\ - possibleSwitchTo t - \\_. sch_act_not t'\" - apply (clarsimp simp: possibleSwitchTo_def) - apply (wpsimp wp: threadGet_wp inReleaseQueue_wp) - apply (clarsimp simp: obj_at'_def) - done - -lemma setReleaseQueue_tcb_at'[wp]: - "setReleaseQueue qs \typ_at' T tcbPtr\" - unfolding setReleaseQueue_def - by wpsimp - -lemma setReleaseQueue_ksReleaseQueue[wp]: - "\\_. P qs\ setReleaseQueue qs \\_ s. P (ksReleaseQueue s)\" - by (wpsimp simp: setReleaseQueue_def) - -lemma setReleaseQueue_pred_tcb_at'[wp]: - "setReleaseQueue qs \\s. P (pred_tcb_at' proj P' t' s)\" - by (wpsimp simp: setReleaseQueue_def) - -crunch setReprogramTimer, possibleSwitchTo - for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" - (wp: crunch_wps simp: crunch_simps) - -lemma tcbReleaseDequeue_distinct_release_queue[wp]: - "tcbReleaseDequeue \distinct_release_queue\" - unfolding tcbReleaseDequeue_def - by (wpsimp simp: distinct_tl) - -lemma getReleaseQueue_sp: - "\Q\ getReleaseQueue \\r. (\s. r = ksReleaseQueue s) and Q\" - unfolding getReleaseQueue_def - by wpsimp - -lemma releaseQNonEmptyAndReady_implies_releaseQNonEmpty: - "the (releaseQNonEmptyAndReady s) \ ksReleaseQueue s \ []" - by (clarsimp simp: releaseQNonEmptyAndReady_def readTCBRefillReady_def readReleaseQueue_def - obind_def omonad_defs) - -lemma awaken_invs': - "awaken \invs'\" - apply (clarsimp simp: awaken_def awakenBody_def) - apply (rule_tac I="\_. invs'" in valid_whileLoop; simp add: runReaderT_def) - apply (rule bind_wp[OF _ getReleaseQueue_sp]) - apply (rule bind_wp[OF _ assert_sp]) - apply wpsimp - apply (rule hoare_drop_imps) - apply (rule tcbReleaseDequeue_invs') - apply (fastforce intro!: releaseQNonEmptyAndReady_implies_releaseQNonEmpty) - done - -crunch tcbReleaseDequeue - for st_tcb_at'[wp]: "\s. Q (st_tcb_at' P p s)" - and valid_replies' [wp]: valid_replies' - (wp: crunch_wps threadSet_pred_tcb_no_state valid_replies'_lift) - -lemma awaken_sch_act_wf[wp]: - "awaken \\s. sch_act_wf (ksSchedulerAction s) s\" - apply (clarsimp simp: awaken_def awakenBody_def) - apply (rule_tac I="\_ s. sch_act_wf (ksSchedulerAction s) s" in valid_whileLoop; simp add: runReaderT_def) - apply (rule bind_wp[OF _ getReleaseQueue_sp]) - apply (rule bind_wp[OF _ assert_sp]) - apply wpsimp - apply (rule hoare_drop_imp) - apply wpsimp - apply (fastforce intro!: releaseQNonEmptyAndReady_implies_releaseQNonEmpty) + apply (wpsimp wp: ssa_invs' chooseThread_invs_no_cicd' chooseThread_ct_not_queued_2 + chooseThread_activatable_2 chooseThread_invs_no_cicd' + chooseThread_in_cur_domain' nextDomain_invs_no_cicd' chooseThread_ct_not_queued_2) + apply (clarsimp simp: invs'_to_invs_no_cicd'_def) done -crunch awaken - for cur_tcb'[wp]: cur_tcb' - (wp: crunch_wps) - -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) - lemma schedule_invs': - "schedule \invs'\" - supply if_split [split del] - apply (simp add: schedule_def scAndTimer_def cur_tcb'_asrt_def) - apply (intro bind_wp[OF _ stateAssert_sp]) - apply (clarsimp simp: sch_act_wf_asrt_def) + "\invs'\ ThreadDecls_H.schedule \\rv. invs'\" + supply ssa_wp[wp del] + apply (simp add: schedule_def) apply (rule_tac bind_wp, rename_tac t) - apply (rule_tac P'="invs' and (\s. sch_act_wf (ksSchedulerAction s) s) and cur_tcb'" in hoare_weaken_pre) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule_tac bind_wp[OF _ getCurThread_sp]) - apply (rule_tac bind_wp[OF _ isSchedulable_sp]) - apply (rule_tac bind_wp[OF _ getSchedulerAction_sp]) - apply (rule bind_wp) - apply (wpsimp wp: switchSchedContext_invs') - apply (wpsimp wp: scheduleChooseNewThread_invs' isSchedulable_wp setSchedulerAction_invs' - ssa_invs' hoare_vcg_disj_lift) - apply (wpsimp simp: isHighestPrio_def') - apply (wpsimp wp: curDomain_wp) - apply (wpsimp simp: scheduleSwitchThreadFastfail_def) - apply (rename_tac tPtr x idleThread targetPrio) - apply (rule_tac Q'="\_. invs' and st_tcb_at' runnable' tPtr and cur_tcb'" - in hoare_strengthen_post[rotated]) - apply (prop_tac "st_tcb_at' runnable' tPtr s \ obj_at' (\a. activatable' (tcbState a)) tPtr s") - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply fastforce - apply (wpsimp wp: threadGet_wp hoare_drop_imp hoare_vcg_ex_lift) - apply (rename_tac tPtr x idleThread) - apply (rule_tac Q'="\_. invs' and st_tcb_at' runnable' tPtr and cur_tcb'" - in hoare_strengthen_post[rotated]) - apply (subst obj_at_ko_at'_eq[symmetric], simp) - apply (wpsimp wp: threadGet_wp hoare_drop_imp hoare_vcg_ex_lift) - apply (rename_tac tPtr x) - apply (rule_tac Q'="\_. invs' and st_tcb_at' runnable' tPtr and cur_tcb'" - in hoare_strengthen_post[rotated]) - apply (subst obj_at_ko_at'_eq[symmetric], simp) - apply (wpsimp wp: tcbSchedEnqueue_invs' isSchedulable_wp)+ - apply (fastforce split: if_split dest: isSchedulable_bool_runnableE simp: cur_tcb'_def) - apply assumption - apply (wpsimp wp: awaken_invs') + apply (wp, wpc) + \ \action = ResumeCurrentThread\ + apply (wp)[1] + \ \action = ChooseNewThread\ + apply (wp scheduleChooseNewThread_invs') + \ \action = SwitchToThread candidate\ + apply (wpsimp wp: scheduleChooseNewThread_invs' ssa_invs' + chooseThread_invs_no_cicd' setSchedulerAction_invs' setSchedulerAction_direct + switchToThread_tcb_in_cur_domain' switchToThread_ct_not_queued_2 + | wp hoare_disjI2[where Q'="\_ s. tcb_in_cur_domain' (ksCurThread s) s"] + | wp hoare_drop_imp[where f="isHighestPrio d p" for d p] + | simp only: obj_at'_activatable_st_tcb_at'[simplified comp_def] + | strengthen invs'_invs_no_cicd + | wp hoare_vcg_imp_lift)+ + apply (frule invs_sch_act_wf') + apply (auto simp: invs_sch_act_wf' obj_at'_activatable_st_tcb_at' + st_tcb_at'_runnable_is_activatable) done lemma setCurThread_nosch: @@ -3038,17 +2218,12 @@ lemma chooseThread_nosch: apply (simp only: return_bind, simp) apply (wp findM_inv | simp)+ apply (case_tac queue) - apply (wp stt_nosch isSchedulable_wp | simp add: curDomain_def bitmap_fun_defs)+ + apply (wp stt_nosch | simp add: curDomain_def bitmap_fun_defs)+ done -crunch switchSchedContext, setNextInterrupt - for ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - (wp: crunch_wps hoare_vcg_all_lift simp: crunch_simps) - lemma schedule_sch: "\\\ schedule \\rv s. ksSchedulerAction s = ResumeCurrentThread\" - unfolding schedule_def scAndTimer_def - by (wpsimp wp: setSchedulerAction_direct simp: getReprogramTimer_def scheduleChooseNewThread_def) + by (wp setSchedulerAction_direct | wpc| simp add: schedule_def scheduleChooseNewThread_def)+ lemma schedule_sch_act_simple: "\\\ schedule \\rv. sch_act_simple\" @@ -3072,33 +2247,32 @@ lemma scheduleChooseNewThread_ct_activatable'[wp]: \\_. ct_in_state' activatable'\" unfolding scheduleChooseNewThread_def by (wpsimp simp: ct_in_state'_def - wp: ssa_invs' nextDomain_invs' + wp: ssa_invs' nextDomain_invs_no_cicd' chooseThread_activatable_2[simplified ct_in_state'_def] - | (rule hoare_lift_Pf[where f=ksCurThread], solves wp))+ - -lemma st_tcb_at_activatable_coerce_concrete: - assumes t: "st_tcb_at activatable t s" - assumes sr: "(s, s') \ state_relation" - assumes tcb: "tcb_at' t s'" - shows "st_tcb_at' activatable' t s'" - using t - apply - - apply (rule ccontr) - apply (drule pred_tcb_at'_Not[THEN iffD2, OF conjI, OF tcb]) - apply (drule st_tcb_at_coerce_abstract[OF _ sr]) - apply (clarsimp simp: st_tcb_def2) - apply (case_tac "tcb_state tcb"; simp) - done + | (rule hoare_lift_Pf[where f=ksCurThread], solves wp) + | strengthen invs'_invs_no_cicd)+ -lemma ct_in_state'_activatable_coerce_concrete: - "\ct_in_state activatable s; (s, s') \ state_relation; cur_tcb' s'\ - \ ct_in_state' activatable' s'" - unfolding ct_in_state'_def cur_tcb'_def ct_in_state_def - apply (rule st_tcb_at_activatable_coerce_concrete[rotated], simp, simp) - apply (frule curthread_relation, simp) - done +lemma schedule_ct_activatable'[wp]: + "\invs'\ ThreadDecls_H.schedule \\_. ct_in_state' activatable'\" + supply ssa_wp[wp del] + apply (simp add: schedule_def) + apply (rule_tac bind_wp, rename_tac t) + apply (wp, wpc) + \ \action = ResumeCurrentThread\ + apply (wp)[1] + \ \action = ChooseNewThread\ + apply wpsimp + \ \action = SwitchToThread\ + apply (wpsimp wp: ssa_invs' setSchedulerAction_direct ssa_ct + | wp hoare_drop_imp[where f="isHighestPrio d p" for d p] + | simp only: obj_at'_activatable_st_tcb_at'[simplified comp_def] + | strengthen invs'_invs_no_cicd + | wp hoare_vcg_imp_lift)+ + apply (fastforce dest: invs_sch_act_wf' elim: pred_tcb'_weakenE + simp: sch_act_wf obj_at'_activatable_st_tcb_at') + done -lemma threadSet_sch_act_sane[wp]: +lemma threadSet_sch_act_sane: "\sch_act_sane\ threadSet f t \\_. sch_act_sane\" by (wp sch_act_sane_lift) @@ -3106,2633 +2280,51 @@ lemma rescheduleRequired_sch_act_sane[wp]: "\\\ rescheduleRequired \\rv. sch_act_sane\" apply (simp add: rescheduleRequired_def sch_act_sane_def setSchedulerAction_def) - by (wp isSchedulable_wp | wpc | clarsimp)+ + by (wp | wpc | clarsimp)+ crunch setThreadState, setBoundNotification - for sch_act_sane[wp]: "sch_act_sane" + for sch_act_sane: "sch_act_sane" (simp: crunch_simps wp: crunch_wps) -lemma weak_sch_act_wf_at_cross: - assumes sr: "(s,s') \ state_relation" - assumes aligned: "pspace_aligned s" - assumes distinct: "pspace_distinct s" - assumes t: "valid_sched_action s" - shows "weak_sch_act_wf (ksSchedulerAction s') s'" - using assms - apply (clarsimp simp: valid_sched_action_def weak_valid_sched_action_def weak_sch_act_wf_def) - apply (frule state_relation_sched_act_relation) - apply (rename_tac t) - apply (drule_tac x=t in spec) - apply (prop_tac "scheduler_action s = switch_thread t") - apply (metis sched_act_relation.simps Structures_A.scheduler_action.exhaust - scheduler_action.simps) - apply (intro conjI impI) - apply (rule st_tcb_at_runnable_cross; fastforce?) - apply (clarsimp simp: vs_all_heap_simps pred_tcb_at_def obj_at_def) - apply (clarsimp simp: switch_in_cur_domain_def in_cur_domain_def etcb_at_def vs_all_heap_simps) - apply (prop_tac "tcb_at t s") - apply (clarsimp simp: obj_at_def is_tcb_def) - apply (frule state_relation_pspace_relation) - apply (frule (3) tcb_at_cross) - apply (clarsimp simp: tcb_in_cur_domain'_def obj_at'_def projectKOs) - apply (frule curdomain_relation) - apply (frule (2) pspace_relation_tcb_domain_priority) - apply simp - done - lemma possibleSwitchTo_corres: - "t = t' \ - corres dc - (valid_sched_action and tcb_at t and pspace_aligned and pspace_distinct - and valid_tcbs and active_scs_valid) - (valid_queues and valid_queues' and valid_release_queue_iff and valid_tcbs') - (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) + "corres dc + (valid_etcbs and weak_valid_sched_action and cur_tcb and st_tcb_at runnable t + and in_correct_ready_q and ready_qs_distinct and pspace_aligned and pspace_distinct) + ((\s. weak_sch_act_wf (ksSchedulerAction s) s) + and sym_heap_sched_pointers and valid_sched_pointers and valid_objs') + (possible_switch_to t) (possibleSwitchTo t)" + 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) + supply ethread_get_wp[wp del] + apply (rule corres_cross_over_guard[where P'=Q and Q="tcb_at' t and Q" for Q]) + apply (clarsimp simp: state_relation_def) + apply (rule tcb_at_cross, erule st_tcb_at_tcb_at; assumption) apply (simp add: possible_switch_to_def possibleSwitchTo_def cong: if_cong) apply (rule corres_guard_imp) - apply (simp add: get_tcb_obj_ref_def) - apply (rule corres_split) - apply (rule threadGet_corres[where r="(=)"]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_split[OF inReleaseQueue_corres], simp) - apply (rule corres_when[rotated]) - apply (rule corres_split[OF curDomain_corres], simp) - apply (rule corres_split) - apply (rule 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) - apply (rule corres_if[rotated], simp) - apply (rule corres_split[OF rescheduleRequired_corres]) - apply (rule tcbSchedEnqueue_corres) - apply wp+ - apply (rule setSchedulerAction_corres, simp) - apply (rename_tac rv rv') - apply (case_tac rv; simp) - apply (wpsimp simp: if_apply_def2 valid_sched_action_def - wp: hoare_drop_imp inReleaseQueue_inv)+ - done - -lemma ct_active_cross: - "\ (s,s') \ state_relation; pspace_aligned s; pspace_distinct s; ct_active s \ - \ ct_active' s'" - by (clarsimp simp: state_relation_def ct_in_state_def ct_in_state'_def - st_tcb_at_runnable_cross runnable_eq_active runnable_eq_active'[symmetric]) - -\ \Strengthen the consequent as necessary, there's more that can be derived from the assumptions\ -lemma ct_released_cross_weak: - "\ (s,s') \ state_relation; pspace_aligned s; pspace_distinct s; ct_released s; cur_tcb' s' \ - \ bound_sc_tcb_at' bound (ksCurThread s') s'" - 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) - apply (auto simp: vs_all_heap_simps other_obj_relation_def tcb_relation_def - cur_tcb'_def pred_tcb_at'_def obj_at'_def projectKOs - split: kernel_object.splits) - done - -lemma setReprogramTimer_corres[corres]: - "corres dc \ \ (modify (reprogram_timer_update (\_. b))) (setReprogramTimer b)" - apply (unfold setReprogramTimer_def) - apply (rule corres_modify) - apply (simp add: state_relation_def swp_def) - done - -lemma getCurTime_corres[corres]: - "corres (=) \ \ (gets cur_time) (getCurTime)" - apply (clarsimp simp: getCurTime_def state_relation_def) - done - -lemma readRefillReady_simp: - "readRefillReady scp s - = (case readSchedContext scp s - of None \ None - | Some sc' \ Some (rTime (refillHd sc') \ (ksCurTime s) + kernelWCETTicks))" - by (clarsimp simp: readRefillReady_def readCurTime_def readSchedContext_SomeD asks_def obind_def) - -lemma refillReady_corres: - "corres (=) - (sc_at sc_ptr and - (\s. ((\sc. sc_refills sc \ []) |< scs_of2 s) sc_ptr)) - (sc_at' sc_ptr and valid_refills' sc_ptr) - (get_sc_refill_ready sc_ptr) - (refillReady sc_ptr)" - supply getSchedContext_wp[wp del] set_sc'.get_wp[wp del] projection_rewrites[simp] - apply (clarsimp simp: refill_ready_def refillReady_def get_sc_refill_ready_def) - apply (rule gets_the_corres) - apply (wpsimp wp: no_ofail_read_sc_refill_ready) - apply (clarsimp simp: is_sc_obj obj_at_def) - apply wpsimp - apply (clarsimp simp: obj_at_def is_sc_obj dest!: no_ofailD[OF readRefillReady_no_ofail] - intro: no_ofailD[OF no_ofail_read_sc_refill_ready]) - apply (insert no_ofailD[OF no_ofail_read_sc_refill_ready, rule_format]) - apply (drule_tac x=s and y=sc_ptr in meta_spec2) - apply (prop_tac "\sc n. kheap s sc_ptr = Some (kernel_object.SchedContext sc n)") - apply (clarsimp simp: sc_at_pred_n_def obj_at_def) - apply clarsimp - apply (clarsimp simp: read_sc_refill_ready_simp readRefillReady_simp readSchedContext_def - read_sched_context_def - split: option.splits dest!: readObject_misc_ko_at') - apply (rename_tac n sc' sc) - apply (frule state_relation_sc_relation; (clarsimp simp: obj_at'_def obj_at_def projectKOs is_sc_obj)) - apply fastforce+ - apply (fastforce simp: kernelWCETTicks_def refill_ready_def state_relation_def refill_map_def - obj_at_def opt_map_red opt_pred_def valid_refills'_def - dest!: refill_hd_relation) - done - -lemma readTCBRefillReady_no_ofail: - "no_ofail (\s'. obj_at' (\tcb. \sc. tcbSchedContext tcb = Some sc \ sc_at' sc s') t s') - (readTCBRefillReady t)" - unfolding readTCBRefillReady_def - apply (wpsimp wp: ovalid_threadRead) - apply (clarsimp simp: obj_at'_def) - done - -lemma readTCBRefillReady_simp: - "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; valid_objs s; - active_sc_tcb_at t s; active_scs_valid s; valid_objs' s'\ - \ read_tcb_refill_ready t s = readTCBRefillReady t s'" - apply (frule (1) active_scs_valid_tcb_at) - apply (clarsimp simp: obj_at_kh_kheap_simps vs_all_heap_simps) - apply (rename_tac scp tcb sc n) - apply (prop_tac "tcb_at' t s' \ sc_at' scp s'") - apply (fastforce dest!: state_relationD intro!: sc_at_cross tcb_at_cross - simp: obj_at_def is_tcb is_sc_obj - elim: valid_sched_context_size_objsI) - apply clarsimp - apply (prop_tac "bound (read_tcb_refill_ready t s)") - apply (clarsimp intro!: no_ofailD[OF no_ofail_read_tcb_refill_ready] - simp: pred_tcb_at_def obj_at_def) - apply (frule state_relation_pspace_relation) - apply (clarsimp simp: pspace_relation_def) - apply (drule_tac x=t in bspec, blast) - apply (drule_tac x="(t, other_obj_relation)" in bspec, clarsimp) - apply (clarsimp simp: other_obj_relation_def tcb_relation_def obj_at'_def projectKOs) - apply (prop_tac "bound (readTCBRefillReady t s')") - apply (clarsimp intro!: no_ofailD[OF readTCBRefillReady_no_ofail]) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (rule_tac x=scp in exI; clarsimp) - apply clarsimp - apply (clarsimp simp: read_tcb_refill_ready_def readTCBRefillReady_def oassert_opt_def - readRefillReady_simp read_sc_refill_ready_simp refill_ready'_def obj_at'_def - projectKOs - dest!: read_tcb_obj_ref_SomeD read_sched_context_SomeD readSchedContext_SomeD - threadRead_SomeD - split: option.split_asm) - apply (rename_tac sc' sc_ptr tcbPtr) - apply (prop_tac "valid_sched_context' sc' s' \ valid_sched_context_size' sc'") - apply (frule_tac k=sc' and p=sc_ptr in sc_ko_at_valid_objs_valid_sc'[rotated]) - apply (clarsimp simp: obj_at'_def projectKOs) - apply simp - apply (frule state_relation_pspace_relation) - apply (prop_tac "sc_relation sc n sc'") - apply (clarsimp simp: pspace_relation_def) - apply (drule_tac x=sc_ptr in bspec, blast) - apply (fastforce simp: obj_at'_def projectKOs split: if_splits) - apply (frule refill_hd_relation2) - apply (clarsimp simp: valid_refills_tcb_at_def valid_refills_def rr_valid_refills_def - pred_tcb_at_def obj_at_def vs_all_heap_simps - split: if_splits) - apply (fastforce dest!: sc_ko_at_valid_objs_valid_sc' - simp: obj_at'_def projectKOs) - apply (clarsimp simp: kernelWCETTicks_def state_relation_def) - done - -lemma getReleaseQueue_corres[corres]: - "corres (=) \ \ (gets release_queue) (getReleaseQueue)" - unfolding getReleaseQueue_def - apply (rule corres_gets_trivial) - by (clarsimp simp: state_relation_def release_queue_relation_def) - -lemma releaseQNonEmptyAndReady_simp: - "releaseQNonEmptyAndReady s - = (if ksReleaseQueue s = [] - then Some False - else readTCBRefillReady (head (ksReleaseQueue s)) s)" - by (clarsimp simp: releaseQNonEmptyAndReady_def readReleaseQueue_def asks_def obind_def) - -lemma releaseQNonEmptyAndReady_eq: - "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; - valid_objs s; valid_release_q s; - active_scs_valid s; valid_objs' s'\ - \ read_release_q_non_empty_and_ready s = releaseQNonEmptyAndReady s'" - apply (clarsimp simp: read_release_q_non_empty_and_ready_simp releaseQNonEmptyAndReady_simp) - apply (fastforce simp: state_relation_def release_queue_relation_def - intro!: readTCBRefillReady_simp valid_release_q_active_sc) - done - -lemma ksReleaseQueue_length_well_founded: - "wf {((r :: unit, s :: kernel_state), (r', s')). length (ksReleaseQueue s) - < length (ksReleaseQueue s')}" - apply (insert wf_inv_image[where r="{(m, n). m < n}" - and f="\(r :: unit, s :: kernel_state). length (ksReleaseQueue s)"]) - apply (clarsimp simp: inv_image_def) - apply (prop_tac "wf {(m, n). m < n}") - apply (fastforce intro: wf) - apply (drule meta_mp) - apply simp - apply (prop_tac "{(x :: unit \ global.kernel_state, y :: unit \ global.kernel_state). - (case x of (r, s) \ length (ksReleaseQueue s)) - < (case y of (r, s) \ length (ksReleaseQueue s))} - = {((r, s), r', s'). length (ksReleaseQueue s) < length (ksReleaseQueue s')}") - apply fastforce - apply fastforce - done - -lemma tcbReleaseDequeue_ksReleaseQueue_length_helper: - "\\s'. ksReleaseQueue s' \ [] \ s' = s\ - tcbReleaseDequeue - \\r' s'. length (ksReleaseQueue s') < length (ksReleaseQueue s)\" - apply (wpsimp simp: tcbReleaseDequeue_def getReleaseQueue_def setReleaseQueue_def) - done - -lemma tcbReleaseDequeue_ksReleaseQueue_length: - "\\s'. the (releaseQNonEmptyAndReady s') \ s' = s\ - tcbReleaseDequeue - \\r' s'. length (ksReleaseQueue s') < length (ksReleaseQueue s)\" - apply (wpsimp wp: tcbReleaseDequeue_ksReleaseQueue_length_helper) - apply (fastforce dest: releaseQNonEmptyAndReady_implies_releaseQNonEmpty) - done - -lemma awakenBody_ksReleaseQueue_length: - "\\s'. the (releaseQNonEmptyAndReady s') \ s' = s\ - awakenBody - \\r' s'. length (ksReleaseQueue s') < length (ksReleaseQueue s)\" - apply (clarsimp simp: awakenBody_def) - apply (wpsimp wp: tcbReleaseDequeue_ksReleaseQueue_length hoare_drop_imps) - done - -lemma awaken_terminates: - "whileLoop_terminates (\_ s'. (the (releaseQNonEmptyAndReady s'))) (\_. awakenBody) r' s'" - apply (rule_tac R="{((r', s'), (r, s)). length (ksReleaseQueue s') < length (ksReleaseQueue s)}" - in whileLoop_terminates_inv) - apply simp - apply clarsimp - apply (rule awakenBody_ksReleaseQueue_length) - apply (rule ksReleaseQueue_length_well_founded) - done - -lemma reprogram_timer_update_release_queue_update_monad_commute: - "monad_commute \ (modify (reprogram_timer_update (\_. b))) (modify (release_queue_update q))" - apply (clarsimp simp: monad_commute_def modify_def get_def put_def bind_def return_def) - done - -lemma release_queue_modify_tl: - "\(s, s') \ state_relation; valid_release_q s; release_queue s \ []\ - \ (s\release_queue := filter ((\) (hd (release_queue s))) (release_queue s)\, - s'\ksReleaseQueue := tl (release_queue s)\) \ state_relation" - apply (clarsimp simp: state_relation_def cdt_relation_def) - apply (clarsimp simp: release_queue_relation_def) - apply (prop_tac "ksReleaseQueue s' \ []", fastforce) - apply (rule filter_hd_equals_tl) - apply (prop_tac "distinct (release_queue s)") - apply (clarsimp simp: valid_release_q_def) - apply simp+ - done - -lemma ksReleaseQueue_runnable'_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and valid_release_q) - (\s'. \t \ set (ksReleaseQueue s'). st_tcb_at' runnable' t s')" - apply (clarsimp simp: cross_rel_def) - apply (clarsimp simp: valid_release_q_def release_queue_relation_def) - apply (frule state_relation_release_queue_relation) - apply (clarsimp simp: release_queue_relation_def) - apply (prop_tac "st_tcb_at runnable t s") - apply (fastforce simp: obj_at_kh_kheap_simps) - apply (fastforce intro: sts_rel_runnable - dest!: st_tcb_at_coerce_concrete - simp: st_tcb_at'_def obj_at'_def) - done - -lemma tcbReleaseDequeue_corres: - "corres (=) (pspace_aligned and pspace_distinct and valid_release_q and (\s. release_queue s \ [])) - \ - tcb_release_dequeue - tcbReleaseDequeue" - (is "corres _ _ ?conc _ _") - apply (rule corres_cross[where Q'="\s'. \t \ set (ksReleaseQueue s'). st_tcb_at' runnable' t s'" - , OF ksReleaseQueue_runnable'_cross_rel], blast) - apply (clarsimp simp: tcb_release_dequeue_def tcb_release_remove_def tcbReleaseDequeue_def - setReleaseQueue_def tcb_sched_dequeue_def) - apply (rule corres_symb_exec_l[rotated 2, OF gets_sp]; (solves wpsimp)?) - apply (rename_tac rq) - apply (simp add: bind_assoc) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getReleaseQueue_sp]) - apply (corresKsimp corres: getReleaseQueue_corres) - - apply clarsimp - apply (rename_tac rq') - apply (rule_tac F="rq' \ [] \ rq' = rq" in corres_req) - apply (clarsimp simp: state_relation_def release_queue_relation_def) - apply clarsimp - - apply (subst monad_commute_simple'[OF reprogram_timer_update_release_queue_update_monad_commute]) - apply (rule corres_guard_imp) - apply (rule corres_split) - apply (rule_tac P="valid_release_q and (\s. release_queue s \ [] \ release_queue s = rq)" - and P'="\s'. ksReleaseQueue s' \ []" - in corres_inst) - apply (rule corres_modify) - apply (fastforce intro: release_queue_modify_tl) - apply wpsimp - apply (rule corres_add_noop_lhs) - apply (rule corres_split[OF threadSet_corres_noop]) - apply (clarsimp simp: tcb_relation_def)+ - apply (rule corres_split[OF setReprogramTimer_corres]) - apply wpsimp+ - apply (fastforce simp: st_tcb_at'_def) - done - -lemma tcbInReleaseQueue_update_valid_tcbs'[wp]: - "threadSet (tcbInReleaseQueue_update f) tcbPtr \valid_tcbs'\" - apply (wpsimp wp: threadSet_valid_tcbs') - done - -lemma tcbReleaseDequeue_valid_tcbs'[wp]: - "tcbReleaseDequeue \valid_tcbs'\" - apply (clarsimp simp: tcbReleaseDequeue_def setReleaseQueue_def setReprogramTimer_def) - apply ((rule bind_wp_fwd_skip, wpsimp simp: valid_tcbs'_def) | wpsimp)+ - done - -lemma ksReleaseQueue_distinct_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and valid_release_q) - (\s'. distinct (ksReleaseQueue s'))" - apply (clarsimp simp: cross_rel_def) - apply (fastforce dest: state_relation_release_queue_relation - intro!: tcb_at_cross - simp: valid_release_q_def release_queue_relation_def vs_all_heap_simps - obj_at_def is_tcb_def) - done - -lemma ksReleaseQueue_nonempty_cross_rel: - "cross_rel (pspace_aligned and pspace_distinct and (\s. release_queue s \ [])) - (\s'. ksReleaseQueue s' \ [])" - apply (clarsimp simp: cross_rel_def) - apply (fastforce dest: state_relation_release_queue_relation - intro!: tcb_at_cross - simp: valid_release_q_def release_queue_relation_def vs_all_heap_simps - obj_at_def is_tcb_def) - done - -lemma isRunnable_no_fail[wp]: - "no_fail (tcb_at' tcbPtr) (isRunnable tcbPtr)" - apply (wpsimp simp: isRunnable_def) - done - -lemma awakenBody_corres: - "corres dc ((pspace_aligned and pspace_distinct and valid_objs and valid_sched_action - and valid_tcbs and valid_release_q and active_scs_valid) - and (\s. release_queue s \ [])) - (valid_objs' and valid_queues and valid_queues' and valid_release_queue_iff) - awaken_body - awakenBody" - (is "corres _ (?pred and _) ?conc _ _") - apply (rule corres_cross[where Q'="\s'. distinct (ksReleaseQueue s')" - , OF ksReleaseQueue_distinct_cross_rel], blast) - apply (rule corres_cross[where Q'="\s'. ksReleaseQueue s' \ []" - , OF ksReleaseQueue_nonempty_cross_rel], blast) - apply (rule corres_cross[where Q'="\s'. \t \ set (ksReleaseQueue s'). st_tcb_at' runnable' t s'" - , OF ksReleaseQueue_runnable'_cross_rel], blast) - - apply (clarsimp simp: awaken_body_def awakenBody_def) - apply (rule corres_symb_exec_r[rotated, OF getReleaseQueue_sp]) - apply (wpsimp wp: gets_sp simp: getReleaseQueue_def) - apply (wpsimp wp: gets_exs_valid - simp: getReleaseQueue_def) - apply (rule corres_symb_exec_r[rotated, OF assert_inv]; (solves wpsimp)?) - apply (rule_tac Q="\rv. ?pred and tcb_at rv" - and Q'="\rv. ?conc and st_tcb_at' runnable' rv" - in corres_underlying_split[rotated 2]) - apply (wpsimp simp: tcb_release_dequeue_def) - apply (force simp: valid_release_q_def vs_all_heap_simps obj_at_def is_tcb_def) - apply wpsimp - apply (corresKsimp corres: tcbReleaseDequeue_corres) - apply (rule corres_symb_exec_r[OF _ isRunnable_sp, rotated]; (solves wpsimp)?) - apply (rule corres_symb_exec_r[OF _ assert_sp, rotated]; (solves wpsimp)?) - apply wpsimp - apply (clarsimp simp: st_tcb_at'_def obj_at'_def projectKOs objBitsKO_def) - apply (case_tac "tcbState tcb'"; clarsimp) - apply (corresKsimp corres: possibleSwitchTo_corres) - done - -lemma tcbReleaseDequeue_no_fail: - "no_fail (\s'. (\tcbPtr \ set (ksReleaseQueue s'). tcb_at' tcbPtr s') \ ksReleaseQueue s' \ []) - tcbReleaseDequeue" - apply (wpsimp simp: tcbReleaseDequeue_def getReleaseQueue_def setReleaseQueue_def - setReprogramTimer_def) - done - -lemma addToBitmap_no_fail[wp]: - "no_fail \ (addToBitmap tdom tprio)" - apply (wpsimp simp: bitmap_fun_defs) - done - -lemma tcbSchedEnqueue_no_fail[wp]: - "no_fail (tcb_at' tcbPtr) (tcbSchedEnqueue tcbPtr)" - apply (clarsimp simp: tcbSchedEnqueue_def) - apply (wpsimp wp: hoare_vcg_if_lift2 hoare_drop_imps) - done - -lemma inReleaseQueue_no_fail[wp]: - "no_fail (tcb_at' tcbPtr) (inReleaseQueue tcbPtr)" - apply (wpsimp simp: inReleaseQueue_def) - done - -lemma isSchedulable_no_fail: - "no_fail (tcb_at' tcbPtr and valid_objs') (isSchedulable tcbPtr)" - apply (clarsimp simp: isSchedulable_def isRunnable_def inReleaseQueue_def) - apply (wpsimp wp: no_fail_bind hoare_vcg_imp_lift' hoare_vcg_conj_lift getTCB_wp) - apply (fastforce dest: tcb_ko_at_valid_objs_valid_tcb' - simp: valid_tcb'_def) - done - -lemma rescheduleRequired_no_fail: - "no_fail (\s'. weak_sch_act_wf (ksSchedulerAction s') s' \ valid_objs' s') rescheduleRequired" - apply (clarsimp simp: rescheduleRequired_def getSchedulerAction_def isSchedulable_def - setSchedulerAction_def) - apply (wpsimp wp: isSchedulable_no_fail hoare_vcg_if_lift2 hoare_drop_imps) - apply (clarsimp simp: weak_sch_act_wf_def) - done - -lemma possibleSwitchTo_no_fail: - "no_fail (\s'. weak_sch_act_wf (ksSchedulerAction s') s' \ valid_objs' s' \ tcb_at' tcbPtr s') - (possibleSwitchTo tcbPtr)" - apply (clarsimp simp: possibleSwitchTo_def inReleaseQueue_def curDomain_def getSchedulerAction_def - setSchedulerAction_def) - apply (wpsimp wp: rescheduleRequired_no_fail threadGet_wp simp: setSchedulerAction_def) - apply (fastforce simp: obj_at'_def projectKOs objBitsKO_def) - done - -lemma tcbReleaseDequeue_weak_sch_act_wf[wp]: - "tcbReleaseDequeue \\s'. weak_sch_act_wf (ksSchedulerAction s') s'\" - apply (clarsimp simp: tcbReleaseDequeue_def setReleaseQueue_def setReprogramTimer_def) - apply (wpsimp wp: threadSet_wp) - apply (fastforce simp: weak_sch_act_wf_def st_tcb_at'_def obj_at'_def projectKOs objBitsKO_def - tcb_in_cur_domain'_def ps_clear_def) - done - -lemma tcbReleaseQueue_tcb_at'_rv: - "\\s'. ksReleaseQueue s' \ [] \ tcb_at' (hd (ksReleaseQueue s')) s'\ - tcbReleaseDequeue - \\rv. tcb_at' rv\" - apply (wpsimp simp: tcbReleaseDequeue_def setReleaseQueue_def) - done - -lemma awakenBody_no_fail: - "no_fail (\s'. weak_sch_act_wf (ksSchedulerAction s') s' \ valid_objs' s' - \ (\tcbPtr \ set (ksReleaseQueue s'). st_tcb_at' runnable' tcbPtr s') - \ ksReleaseQueue s' \ [] \ distinct (ksReleaseQueue s')) - awakenBody" - apply (clarsimp simp: awakenBody_def setReprogramTimer_def) - apply (wpsimp wp: possibleSwitchTo_no_fail tcbReleaseDequeue_no_fail tcbReleaseQueue_tcb_at'_rv - hoare_drop_imps - simp: getReleaseQueue_def) - apply fastforce - done - -lemma tcbReleaseDequeue_dequeue_inv: - "tcbReleaseDequeue \\s. tcbPtr \ set (ksReleaseQueue s)\" - apply (clarsimp simp: tcbReleaseDequeue_def) - apply wpsimp - apply (case_tac "ksReleaseQueue s = []"; simp add: list.set_sel(2)) - done - -lemma awaken_corres: - "corres dc (pspace_aligned and pspace_distinct and valid_objs and valid_release_q - and valid_sched_action and valid_tcbs and active_scs_valid) - (\s'. weak_sch_act_wf (ksSchedulerAction s') s' \ valid_objs' s' \ valid_queues s' - \ valid_queues' s' \ valid_release_queue_iff s') - Schedule_A.awaken - awaken" - apply (rule corres_cross[where Q'="\s'. \t \ set (ksReleaseQueue s'). st_tcb_at' runnable' t s'" - , OF ksReleaseQueue_runnable'_cross_rel], blast) - apply (rule corres_cross[where Q'="\s'. distinct (ksReleaseQueue s')" - , OF ksReleaseQueue_distinct_cross_rel], blast) - apply (clarsimp simp: awaken_def Schedule_A.awaken_def runReaderT_def) - apply (rule corres_whileLoop; simp) - apply (simp add: releaseQNonEmptyAndReady_eq) - apply (rule corres_guard_imp) - apply (rule awakenBody_corres) - apply (fastforce simp: read_release_q_non_empty_and_ready_simp) - apply simp - apply (clarsimp simp: pred_conj_def) - apply (intro hoare_vcg_conj_lift_pre_fix - ; (solves \wpsimp simp: Schedule_A.awaken_body_def tcb_release_dequeue_def\)?) - apply (wpsimp wp: awaken_body_valid_sched_action) - apply (frule valid_release_q_read_release_q_non_empty_and_ready_bound) - apply (fastforce dest: read_release_q_non_empty_and_ready_True_simp) - apply (wpsimp simp: awakenBody_def runReaderT_def - wp: hoare_vcg_ball_lift2 tcbReleaseDequeue_dequeue_inv hoare_drop_imps) - apply (fastforce dest: releaseQNonEmptyAndReady_implies_releaseQNonEmpty) - apply (fastforce intro: no_fail_pre awakenBody_no_fail - dest: releaseQNonEmptyAndReady_implies_releaseQNonEmpty) - apply (fastforce intro!: awaken_terminates) - done - -lemma setDeadline_corres: - "dl = dl' \ corres_underlying Id False True dc \ \ (setDeadline dl) (setDeadline dl')" - by (simp, rule corres_underlying_trivial_gen; wpsimp simp: setDeadline_def) - -(* This is not particularly insightful, it just shortens setNextInterrupt_corres *) -lemma setNextInterrupt_corres_helper: - "\valid_objs' s'; (s, s') \ state_relation; active_sc_tcb_at t s; - valid_objs s; pspace_aligned s; pspace_distinct s\ - \ \tcb. ko_at' tcb t s' \ sc_at' (the (tcbSchedContext tcb)) s' \ - (\ko. ko_at' ko (the (tcbSchedContext tcb)) s' \ sc_valid_refills' ko)" - apply (subgoal_tac "\tcb'. ko_at' (tcb' :: tcb) t s'", clarsimp) - apply (clarsimp simp: pred_map_def vs_all_heap_simps) - apply (rename_tac tcb' scp tcb sc n) - apply (frule_tac pspace_relation_absD, erule state_relation_pspace_relation) - apply (clarsimp simp: other_obj_relation_def) - apply (subgoal_tac "z = KOTCB tcb'", clarsimp) - apply (rule_tac x=tcb' in exI, simp) - apply (prop_tac "tcbSchedContext tcb' = Some scp", clarsimp simp: tcb_relation_def, simp) - apply (subgoal_tac "sc_at' scp s'", clarsimp) - apply (frule_tac x=scp in pspace_relation_absD, erule state_relation_pspace_relation) - apply (frule (1) valid_sched_context_size_objsI, clarsimp) - apply (subgoal_tac "z = KOSchedContext ko", clarsimp) - apply (frule (1) sc_ko_at_valid_objs_valid_sc', clarsimp) - apply (clarsimp simp: valid_sched_context'_def sc_relation_def active_sc_def) - apply (case_tac z; clarsimp simp: obj_at'_def projectKOs) - apply (erule cross_relF [OF _ sc_at'_cross_rel], clarsimp simp: obj_at_def is_sc_obj) - apply (erule (1) valid_sched_context_size_objsI) - apply (case_tac z; clarsimp simp: obj_at'_def projectKOs) - apply (subgoal_tac "tcb_at t s") - apply (frule cross_relF [OF _ tcb_at'_cross_rel], clarsimp, assumption) - apply (clarsimp simp: obj_at'_def projectKOs) - apply (clarsimp simp: obj_at_def vs_all_heap_simps pred_map_def is_tcb) - done - -lemma setNextInterrupt_corres: - "corres dc ((\s. active_sc_tcb_at (cur_thread s) s) - and (\s. \t \ set (release_queue s). active_sc_tcb_at t s) - and valid_objs and pspace_aligned and pspace_distinct) - valid_objs' - set_next_interrupt - setNextInterrupt" - unfolding setNextInterrupt_def set_next_interrupt_def - apply (rule stronger_corres_guard_imp) - apply (rule corres_split [OF getCurTime_corres]) - apply (rule corres_split [OF getCurThread_corres], simp) - apply (rule corres_split_eqr[OF get_tcb_obj_ref_corres]) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_assert_opt_assume_l) - apply (rule corres_split [OF get_sc_corres]) - apply (rule_tac F="sc_valid_refills' rv'" in corres_gen_asm2) - apply (rule corres_split [OF corres_if]) - apply clarsimp - apply (rule corres_split [OF getDomainTime_corres]) - apply (simp only: fun_app_def) - apply (rule corres_return_eq_same) - apply (clarsimp simp: refill_hd_relation refill_map_def) - apply wpsimp - apply wpsimp - apply (rule corres_return_eq_same) - apply (clarsimp simp: refill_hd_relation refill_map_def) - apply (rule corres_split [OF getReleaseQueue_corres]) - apply (rule corres_split [OF corres_if], simp) - apply (rule corres_return_eq_same, simp) - apply (rule corres_split_eqr) - apply (simp, rule get_tcb_obj_ref_corres) - apply (clarsimp simp: tcb_relation_def) - apply (rule corres_assert_opt_assume_l) - apply simp - apply (rule corres_split [OF get_sc_corres]) - apply (rule_tac F="sc_valid_refills' rv'c" in corres_gen_asm2) - apply (rule corres_return_eq_same) - apply (clarsimp simp: refill_hd_relation refill_map_def) - apply wpsimp - apply wpsimp - apply (wpsimp wp: get_tcb_obj_ref_wp) - apply (wpsimp wp: threadGet_wp) - apply (rule corres_machine_op) - apply (simp del: dc_simp, rule setDeadline_corres, simp) - apply wpsimp+ - apply (wpsimp wp: get_tcb_obj_ref_wp) - apply (wpsimp wp: threadGet_wp) - apply wpsimp+ - apply (fastforce intro!: valid_sched_context_size_objsI - dest: list.set_sel(1) - simp: vs_all_heap_simps obj_at_def is_tcb_def is_sc_obj_def) - apply (clarsimp simp: valid_release_q_def) - apply (subgoal_tac "(\tcb. ko_at' tcb (ksCurThread s') s' \ - sc_at' (the (tcbSchedContext tcb)) s' \ - (\ko. ko_at' ko (the (tcbSchedContext tcb)) s' \ sc_valid_refills' ko)) \ (ksReleaseQueue s' \ [] \ (\tcb. ko_at' tcb (hd (ksReleaseQueue s')) s' \ - sc_at' (the (tcbSchedContext tcb)) s' \ - (\ko. ko_at' ko (the (tcbSchedContext tcb)) s' \ sc_valid_refills' ko)))") - apply (safe, blast, blast)[1] - apply (rule_tac x=tcb in exI, simp, safe, blast)[1] - apply (prop_tac "ksCurThread s' = cur_thread s", clarsimp simp: state_relation_def, simp) - apply (subgoal_tac "(ksReleaseQueue s') = release_queue s", simp) - apply (intro conjI impI) - apply (rule setNextInterrupt_corres_helper; simp) - apply (clarsimp simp: state_relation_def release_queue_relation_def) - apply (rule setNextInterrupt_corres_helper; simp?) - apply (clarsimp simp: state_relation_def release_queue_relation_def)+ - done - -(* refillUnblockCheck_corres *) - -lemma isRoundRobin_corres: - "corres (=) (sc_at sc_ptr) (sc_at' sc_ptr) - (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 - -lemma refillPopHead_corres: - "corres (\refill refill'. refill = refill_map refill') - (pspace_aligned and pspace_distinct and sc_at sc_ptr - and sc_refills_sc_at (\refills. 1 < length refills) sc_ptr) - (valid_refills' sc_ptr) - (refill_pop_head sc_ptr) (refillPopHead sc_ptr)" - (is "corres _ ?abs ?conc _ _") - supply if_split[split del] opt_pred_def[simp add] - 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 (clarsimp simp: getRefillNext_getSchedContext get_refills_def liftM_def) - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (rule corres_guard_imp) - apply (rule get_sc_corres) - apply simp - apply simp - apply (rename_tac sc') - apply (rule_tac F="refill_hd sc = refill_map (refillHd sc')" in corres_req) - apply (clarsimp simp: obj_at_def is_sc_obj obj_at'_def projectKOs) - apply (frule (1) pspace_relation_absD[OF _ state_relation_pspace_relation]) - apply (clarsimp elim!: refill_hd_relation simp: valid_refills'_def opt_map_red) - apply (rule corres_guard_imp) - apply (rule corres_underlying_split[OF updateSchedContext_corres_gen[where - P="(\s. ((\sc. 1 < length (sc_refills sc)) |< scs_of2 s) sc_ptr)" - and P'="valid_refills' sc_ptr"]]) - apply (clarsimp, drule (2) state_relation_sc_relation) - apply (clarsimp simp: sc_relation_def refills_map_def tl_map obj_at_simps is_sc_obj opt_map_red) - apply (clarsimp simp: valid_refills'_def opt_map_red) - apply (subst tl_wrap_slice; clarsimp simp: min_def split: if_split) - apply (rule conjI impI; clarsimp simp: refillNextIndex_def wrap_slice_start_0 split: if_splits) - apply (fastforce simp: obj_at_simps is_sc_obj opt_map_red dest!: state_relation_sc_replies_relation_sc) - apply clarsimp - apply (clarsimp simp: objBits_simps) - apply simp - apply (wpsimp wp: update_sched_context_wp) - apply (wpsimp wp: updateSchedContext_wp) - apply (clarsimp simp: sc_refills_sc_at_def obj_at_def opt_map_red) - apply simp - done - -lemma refillPopHead_valid_refills'[wp]: - "\\s. valid_refills' scPtr' s - \ (scPtr = scPtr' \ obj_at' (\sc'. Suc 0 < scRefillCount sc') scPtr s)\ - refillPopHead scPtr - \\_. valid_refills' scPtr'\" - apply (clarsimp simp: refillPopHead_def updateSchedContext_def setSchedContext_def) - apply (wpsimp wp: setObject_sc_wp) - apply (fastforce simp: valid_refills'_def obj_at'_def projectKOs opt_map_def opt_pred_def - refillNextIndex_def) - done - -lemma refillHeadOverlapping_simp: - "sc_at' sc_ptr s' \ - refillHeadOverlapping sc_ptr s' = - (scs_of' s' ||> (\sc'. Suc 0 < scRefillCount sc' - \ rTime (scRefills sc' ! (if scRefillHead sc' = scRefillMax sc' - Suc 0 - then 0 else Suc (scRefillHead sc'))) - \ rTime (refillHd sc') + rAmount (refillHd sc'))) sc_ptr" - unfolding refillHeadOverlapping_def - apply (frule no_ofailD[OF no_ofail_readSchedContext]) - apply (fastforce simp: obind_def omonad_defs oliftM_def obj_at'_def projectKOs readRefillNext_def - readRefillSize_def refillIndex_def opt_map_red readSchedContext_def - dest!: readObject_ko_at'_sc split: option.splits) - done - -lemma refill_head_overlapping_simp: - "sc_at sc_ptr s \ - refill_head_overlapping sc_ptr s = - (scs_of2 s ||> (\sc. Suc 0 < length (sc_refills sc) - \ r_time (hd (tl (sc_refills sc))) - \ r_time (refill_hd sc) + r_amount (refill_hd sc))) sc_ptr" - unfolding refill_head_overlapping_def - apply (insert no_ofailD[OF no_ofail_read_sched_context]) - apply (clarsimp simp: obind_def obj_at_def is_sc_obj opt_map_red - split: option.split) - apply (drule_tac x=s and y=sc_ptr in meta_spec2) - apply (clarsimp dest!: read_sched_context_SomeD) - done - -lemma refillHeadOverlapping_corres_eq: - "\(s, s') \ state_relation; sc_at sc_ptr s; sc_at' sc_ptr s'; valid_refills' sc_ptr s'\ - \ refill_head_overlapping sc_ptr s = refillHeadOverlapping sc_ptr s'" - apply (frule no_ofailD[OF no_ofail_refillHeadOverlapping]) - apply (insert refillHeadOverlapping_implies_count_greater_than_one[of sc_ptr s']) - apply clarsimp - apply (drule (2) state_relation_sc_relation) - apply (clarsimp simp: obj_at_simps is_sc_obj) - apply (rename_tac b n sc sc') - apply (case_tac b; - clarsimp simp: refillHeadOverlapping_simp refill_head_overlapping_simp obj_at_simps - is_sc_obj sc_relation_def valid_refills'_def refillHd_def - neq_Nil_lengthI tl_drop_1 hd_drop_conv_nth refills_map_def hd_map - hd_wrap_slice wrap_slice_index refill_map_def opt_map_red opt_pred_def - split: if_split_asm) - by linarith+ - -lemma refillPopHead_scs_of'[wp]: - "\\s'. P ((scs_of' s')(scp \ (\sc'. scRefillCount_update (\_. scRefillCount sc' - Suc 0) - (scRefillHead_update - (\_. refillNextIndex (scRefillHead sc') sc') sc')) - (the (scs_of' s' scp))))\ - refillPopHead scp - \\_ s'. P (scs_of' s')\" - unfolding refillPopHead_def - by (wpsimp wp: updateSchedContext_wp) - -crunch update_refill_hd, refill_pop_head, merge_refills, schedule_used, handle_overrun_loop_body - for is_active_sc2[wp]: "is_active_sc2 scp" - (wp: crunch_wps ignore: update_sched_context - simp: crunch_simps update_refill_hd_rewrite update_sched_context_set_refills_rewrite) - -lemma merge_refills_scs_of2[wp]: - "\\s. P ((scs_of2 s)(scp \ (\sc. sc_refills_update - (\_. merge_refill (refill_hd sc) (hd (tl (sc_refills sc))) # tl (tl (sc_refills sc))) sc) - (the (scs_of2 s scp)))) \ - merge_refills scp - \\_ s. P (scs_of2 s)\" - unfolding merge_refills_def - apply (wpsimp simp: update_refill_hd_rewrite refill_pop_head_def - wp: get_refills_wp set_refills_wp update_sched_context_wp) - by (clarsimp simp: is_active_sc2_def obj_at_def opt_map_red) - -(* if the loop guard is true, the refill length is greater than one *) -lemma mergeRefills_corres: - "corres dc (sc_at sc_ptr and pspace_aligned and pspace_distinct - and (\s. ((\sc. 1 < length (sc_refills sc)) |< scs_of2 s) sc_ptr)) - (valid_refills' sc_ptr) - (merge_refills sc_ptr) (mergeRefills sc_ptr)" - unfolding mergeRefills_def merge_refills_def merge_refill_def - apply (rule corres_cross[where Q' = "sc_at' sc_ptr", OF sc_at'_cross_rel], fastforce) - apply (rule_tac Q="\s'. ((\sc'. 1 < scRefillCount sc') |< scs_of' s') sc_ptr" in corres_cross_add_guard) - apply clarsimp - apply (drule (2) state_relation_sc_relation) - apply (clarsimp simp: sc_relation_def) - apply (clarsimp simp: valid_refills'_def obj_at_simps is_sc_obj opt_map_red opt_pred_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF refillPopHead_corres]) - apply (rule updateRefillHd_corres, simp) - apply (clarsimp simp: refill_map_def merge_refill_def)+ - apply (rule hoare_strengthen_post[where Q'="\_. sc_at sc_ptr", rotated]) - apply (simp add: active_sc_at_equiv is_active_sc_rewrite[symmetric]) - apply (wpsimp wp: refill_pop_head_sc_active) - apply wpsimp - apply (clarsimp simp: obj_at_def is_sc_obj opt_map_red is_active_sc_rewrite active_sc_at_equiv - sc_refills_sc_at_rewrite) - apply (fastforce simp: valid_refills'_def obj_at_simps opt_map_red opt_pred_def refillNextIndex_def) - done - -lemma mergeRefills_valid_refills'[wp]: - "\(\s. ((\sc. 1 < scRefillCount sc) |< scs_of' s) scp) and valid_refills' scp\ - mergeRefills p - \\_. valid_refills' scp\" - unfolding mergeRefills_def - apply (wpsimp simp: updateRefillHd_def refillPopHead_def wp: updateSchedContext_wp) - by (fastforce simp: valid_refills'_def obj_at_simps refillNextIndex_def opt_map_red opt_pred_def) - -lemma no_fail_refillPopHead[wp]: - "no_fail (sc_at' scPtr) (refillPopHead scPtr)" - by (wpsimp simp: refillPopHead_def obj_at'_def opt_map_def opt_pred_def objBits_simps projectKOs) - -crunch mergeRefills - for (no_fail) no_fail[wp] - (simp: opt_map_red opt_pred_def obj_at_simps) - -lemma refillPopHead_length_decreasing: - "\\s'. ((\sc. 0 < scRefillCount sc) |< scs_of' s') scp \ s' = s\ - refillPopHead scp - \\r' s'. scRefillCount (the (scs_of' s' scp)) < scRefillCount (the (scs_of' s scp))\" - unfolding refillPopHead_def - apply (simp add: liftM_def bind_assoc refillHd_def) - apply (wpsimp wp: updateSchedContext_wp) - by (clarsimp simp: obj_at'_def projectKOs opt_map_red opt_pred_def) - -lemma mergeRefills_length_decreasing: - "\\s'. ((\sc. 0 < scRefillCount sc) |< scs_of' s') scp \ s' = s\ - mergeRefills scp - \\r' s'. scRefillCount (the (scs_of' s' scp)) < scRefillCount (the (scs_of' s scp))\" - unfolding mergeRefills_def updateRefillHd_def - apply (rule bind_wp[OF _ refillPopHead_length_decreasing]) - by (wpsimp wp: refillPopHead_length_decreasing updateSchedContext_wp) - -lemma scRefillCount_wf: - "wf {((r', s'), r, s). - scRefillCount (the (scs_of' s' sc_ptr)) - < scRefillCount (the (scs_of' s sc_ptr))}" - apply (prop_tac "{((r', s'), r, s). scRefillCount (the (scs_of' s' sc_ptr)) - < scRefillCount (the (scs_of' s sc_ptr))} - = measure (\(r, s). scRefillCount (the (scs_of' s sc_ptr)))") - apply (clarsimp simp: measure_def inv_image_def split_def) - apply (drule sym) - apply (erule subst) - apply (rule wf_measure) - done - -lemma mergeRefills_terminates: - "sc_at' sc_ptr s' \ - whileLoop_terminates - (\_ s'. the (refillHeadOverlapping sc_ptr s')) - (\_. mergeRefills sc_ptr) r' s'" - apply (rule_tac - I="\_. sc_at' sc_ptr" and - R="{((r', s'), (r, s)). scRefillCount (the (scs_of' s' sc_ptr)) - < scRefillCount (the (scs_of' s sc_ptr))}" - in whileLoop_terminates_inv) - apply simp - apply (wpsimp wp: mergeRefills_length_decreasing) - apply (fastforce simp: obj_at_simps opt_map_red opt_pred_def - dest!: refillHeadOverlapping_implies_count_greater_than_one) - apply (rule scRefillCount_wf) - done - -lemma refillHeadOverlappingLoop_corres: - "corres dc (sc_at sc_ptr and pspace_aligned and pspace_distinct) - (valid_refills' sc_ptr) - (refill_head_overlapping_loop sc_ptr) (refillHeadOverlappingLoop sc_ptr)" - unfolding refill_head_overlapping_loop_def refillHeadOverlappingLoop_def runReaderT_def - supply refillHeadOverlapping_implies_count_greater_than_one[dest!] - apply (rule corres_cross[where Q' = "sc_at' sc_ptr", OF sc_at'_cross_rel], fastforce) - apply (rule corres_whileLoop) - apply (drule refillHeadOverlapping_corres_eq[where sc_ptr=sc_ptr]; simp add: runReaderT_def) - 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 < scRefillCount 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 clarsimp - apply (drule (2) state_relation_sc_relation) - apply (clarsimp simp: obj_at_simps is_sc_obj valid_refills'_def sc_relation_def - opt_map_red opt_pred_def) - apply (rule corres_guard_imp) - apply (rule mergeRefills_corres) - apply clarsimp+ - apply (wpsimp+)[4] - apply (fastforce intro!: mergeRefills_terminates) - done - -lemma refillUnblockCheck_corres: - "corres dc - (sc_at scp and pspace_aligned and pspace_distinct - and (\s. ((\sc. 0 < length (sc_refills sc)) |< scs_of2 s) scp)) - (valid_refills' scp) - (refill_unblock_check scp) (refillUnblockCheck scp)" - unfolding refill_unblock_check_def refillUnblockCheck_def - apply (rule corres_cross[where Q' = "sc_at' scp", OF sc_at'_cross_rel], fastforce) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF isRoundRobin_corres]) - apply (rule corres_split_eqr[OF refillReady_corres]) - apply simp - apply (rule corres_when, fastforce) - apply (rule corres_split[OF setReprogramTimer_corres]) - apply (rule corres_split[OF getCurTime_corres]) - apply (rule corres_split[OF updateRefillHd_corres], simp) - apply (clarsimp simp: refill_map_def kernelWCETTicks_def) - apply (rule refillHeadOverlappingLoop_corres) - apply wpsimp - apply (wpsimp wp: getCurTime_wp updateSchedContext_wp - simp: updateRefillHd_def)+ - apply (wpsimp wp: refillReady_wp is_round_robin_wp isRoundRobin_wp - simp: setReprogramTimer_def)+ - apply (clarsimp simp: obj_at_simps valid_refills'_def opt_map_red opt_pred_def) - done - -lemma sporadic_implies_active_cross: - "\(s, s') \ state_relation; active_scs_valid s; sc_at scPtr s; ko_at' sc scPtr s'; - scSporadic sc\ - \ is_active_sc' scPtr s'" - apply (frule (1) state_relation_sc_relation[where ptr=scPtr]) - apply fastforce - apply (clarsimp simp: active_scs_valid_def) - apply (drule_tac x=scPtr in spec)+ - by (fastforce dest: is_sc_objD - simp: sc_relation_def vs_all_heap_simps active_sc_def is_active_sc'_def - obj_at_simps opt_map_def opt_pred_def) - -lemma ifCondRefillUnblockCheck_corres: - "corres dc - (\s. case_option True - (\scp. sc_at scp s \ active_scs_valid s - \ pspace_aligned s \ pspace_distinct s - \ (((\sc. case_option (sc_active sc) \ act) |< scs_of2 s) scp)) scp_opt) - (\s. case_option True (\scp. case_option (valid_refills' scp s) (\_. 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) - apply (rule corres_cross[OF sc_at'_cross_rel], fastforce) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[OF get_sc_corres _ get_sched_context_wp getSchedContext_wp]) - apply (rule corres_split[OF getCurSc_corres]) - apply (rule corres_when) - apply (clarsimp simp: active_sc_def sc_relation_def case_bool_if option.case_eq_if) - apply (rule corres_when) - apply fastforce - apply (rule refillUnblockCheck_corres) - apply wpsimp+ - apply (prop_tac "is_active_sc scp s") - apply (cases act; clarsimp) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps opt_map_def opt_pred_def) - apply (clarsimp simp: vs_all_heap_simps active_scs_valid_def obj_at_kh_kheap_simps - split: bool.splits) - apply (drule_tac x=scp in spec)+ - apply force - apply (drule_tac scp=scp in active_scs_validE[rotated, simplified is_active_sc_rewrite]; - 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) - done - -lemma getCurTime_sp: - "\P\ getCurTime \\rv. P and (\s. rv = ksCurTime s)\" - by (wpsimp simp: getCurTime_def) - -lemma ovalid_readRefillReady'[rule_format, simp]: - "ovalid (\s. sc_at' scp s \ P (((\sc'. rTime (refillHd sc') \ ksCurTime s + kernelWCETTicks) |< scs_of' s) scp) s) - (readRefillReady scp) P" - unfolding readRefillReady_def readSchedContext_def ovalid_def - by (fastforce simp: obind_def opt_map_red obj_at'_def projectKOs opt_pred_def - dest: use_ovalid[OF ovalid_readCurTime] - dest!: readObject_misc_ko_at' - split: option.split_asm)+ - -lemma refillReady_wp': - "\\s. sc_at' scp s \ - P (((\sc'. rTime (refillHd sc') \ ksCurTime s + kernelWCETTicks) |< scs_of' s) scp) s\ - refillReady scp - \P\" - unfolding refillReady_def - by wpsimp (drule use_ovalid[OF ovalid_readRefillReady']) - -lemma refillAddTail_corres: - "new = refill_map new' - \ corres dc (sc_at sc_ptr) - (sc_at' sc_ptr and - (\s'. ((\sc'. scRefillCount sc' < scRefillMax sc' \ sc_valid_refills' sc') |< scs_of' s') sc_ptr)) - (refill_add_tail sc_ptr new) - (refillAddTail sc_ptr new')" - supply projection_rewrites[simp] opt_pred_def[simp add] - apply (clarsimp simp: refill_add_tail_def refillAddTail_def getRefillNext_getSchedContext - getRefillSize_def2 liftM_def get_refills_def) - apply (rule corres_symb_exec_r[OF _ get_sc_sp', rotated]; (solves wpsimp)?)+ - apply (rename_tac sc') - apply (rule corres_guard_imp) - apply (rule corres_assert_assume_r) - apply (rule updateSchedContext_corres_gen[where P=\ - and P'="(\s'. ((\sc'. scRefillCount sc' < scRefillMax sc' \ sc_valid_refills' sc') |< scs_of' s') sc_ptr)"]) - apply (clarsimp, drule (2) state_relation_sc_relation) - apply (clarsimp simp: obj_at_simps is_sc_obj) - apply (rename_tac sc') - apply (clarsimp simp: sc_relation_def neq_Nil_lengthI opt_map_red) - apply (prop_tac "scRefills sc' \ []") - apply (clarsimp simp: neq_Nil_lengthI) - apply (clarsimp simp: refills_map_def) - apply (subst wrap_slice_append; simp) - apply (insert less_linear)[1] - apply (drule_tac x="scRefillMax sc'" and y="scRefillHead sc' + scRefillCount sc' + Suc 0" in meta_spec2) - apply (erule disjE) - apply (simp add: refillNextIndex_def refillTailIndex_def Let_def) - apply (intro conjI impI; - clarsimp simp: Suc_diff_Suc wrap_slice_updateAt_eq[symmetric] neq_Nil_lengthI - nat_le_Suc_less refill_map_def updateAt_index) - apply (erule disjE) - apply clarsimp - apply (rule conjI) - apply (simp add: refillNextIndex_def refillTailIndex_def Let_def) - apply (clarsimp simp: wrap_slice_updateAt_eq not_le) - apply (metis add_leE le_SucI le_refl lessI mult_is_add.mult_commute not_add_less2 not_less_eq wrap_slice_updateAt_eq) - apply (clarsimp simp: refillNextIndex_def refillTailIndex_def Let_def not_le) - apply (clarsimp simp: updateAt_index refill_map_def) - apply clarsimp - apply (rule conjI) - apply (clarsimp simp: refillNextIndex_def refillTailIndex_def Let_def) - apply (intro conjI impI; (clarsimp simp: not_le wrap_slice_updateAt_eq)?) - apply (metis add_leE le_refl le_simps(1) less_SucI mult_is_add.mult_commute nat_neq_iff - not_less_eq trans_less_add2 wrap_slice_updateAt_eq) - apply (clarsimp simp: refillNextIndex_def refillTailIndex_def Let_def not_le) - apply (clarsimp simp: updateAt_index refill_map_def) - apply (fastforce simp: obj_at_simps is_sc_obj opt_map_red - dest!: state_relation_sc_replies_relation_sc) - apply (clarsimp simp: objBits_simps) - apply (clarsimp simp: obj_at_def is_sc_obj) - apply (clarsimp simp: obj_at'_def projectKOs opt_map_red) - done - -lemma isRoundRobin_sp: - "\P\ - isRoundRobin scPtr - \\rv s. P s \ (\sc. ko_at' sc scPtr s \ rv = (scPeriod sc = 0))\" - apply (simp add: isRoundRobin_def) - apply (rule bind_wp_fwd) - apply (rule get_sc_sp') - apply (wp hoare_return_sp) - apply (clarsimp simp: obj_at'_def projectKOs) - done - -lemma maybeAddEmptyTail_corres: - "corres dc - (is_active_sc2 sc_ptr) - (sc_at' sc_ptr and - (\s'. ((\sc'. scRefillCount sc' < scRefillMax sc' \ sc_valid_refills' sc') |< scs_of' s') sc_ptr)) - (maybe_add_empty_tail sc_ptr) - (maybeAddEmptyTail sc_ptr)" (is "corres _ ?abs ?conc _ _") - supply projection_rewrites[simp] - apply (rule corres_cross_add_abs_guard[where Q="sc_at sc_ptr"]) - apply (fastforce dest!: sc_at'_cross[OF state_relation_pspace_relation]) - apply (clarsimp simp: maybe_add_empty_tail_def maybeAddEmptyTail_def get_refills_def) - apply (rule corres_underlying_split[rotated 2, OF is_round_robin_sp isRoundRobin_sp]) - apply (corresKsimp corres: isRoundRobin_corres) - apply (clarsimp simp: obj_at_def is_sc_obj) - apply (clarsimp simp: when_def) - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (corresKsimp corres: get_sc_corres) - apply (fastforce intro: valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj_def) - apply (rename_tac sc') - apply (corresKsimp corres: refillAddTail_corres) - apply (frule refill_hd_relation; clarsimp simp: obj_at'_def projectKOs opt_map_red opt_pred_def) - apply (fastforce dest: valid_objs_valid_sched_context_size - simp: obj_at_def is_sc_obj_def refill_map_def) - done - -lemma getRefills_sp: - "\P\ - getRefills scPtr - \\rv s. P s \ (\sc. ko_at' sc scPtr s \ (rv = scRefills sc))\" - apply (simp add: getRefills_def) - apply (rule bind_wp_fwd) - apply (rule get_sc_sp') - apply (wp hoare_return_sp) - apply (clarsimp simp: obj_at'_def projectKOs) - done - -lemma getCurSc_sp: - "\P\ - getCurSc - \\rv s. P s \ rv = ksCurSc s\" - apply (simp add: getCurSc_def) - apply (wpsimp wp: hoare_return_sp) - done - -lemma refillBudgetCheckRoundRobin_corres: - "corres dc - (cur_sc_active and (\s. sc_at (cur_sc s) s)) - ((\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] - apply (subst is_active_sc_rewrite) - apply (clarsimp simp: refill_budget_check_round_robin_def refillBudgetCheckRoundRobin_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurSc_sp]) - apply (corresKsimp corres: getCurSc_corres) - apply (rule_tac Q="\s. is_active_sc' (ksCurSc s) s" in corres_cross_add_guard) - apply (rule_tac ptr="ksCurSc s'" in is_active_sc'_cross[OF state_relation_pspace_relation]; simp) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_split[OF updateRefillHd_corres], simp) - apply (clarsimp simp: refill_map_def) - apply (rule updateRefillTl_corres, simp) - apply (clarsimp simp: refill_map_def) - apply (wpsimp simp: update_refill_hd_rewrite wp: set_refills_wp get_refills_wp) - apply (wpsimp wp: hoare_vcg_conj_lift) - apply (wpsimp simp: updateRefillHd_def wp: updateSchedContext_wp) - apply (wpsimp wp: updateRefillHd_valid_objs') - apply (clarsimp simp: obj_at_def is_active_sc2_def is_sc_obj opt_map_red - split: option.split_asm Structures_A.kernel_object.split_asm) - apply (clarsimp simp: obj_at_simps fun_upd_def[symmetric] scBits_simps ps_clear_upd) - apply (clarsimp simp: is_active_sc'_def valid_obj'_def valid_sched_context'_def valid_refills'_def - opt_pred_def - split: option.split_asm) - done - -lemma head_insufficient_length_greater_than_one: - "\the (head_insufficient sc_ptr s); - pred_map (\cfg. unat MIN_BUDGET \ refills_unat_sum (scrc_refills cfg)) (sc_refill_cfgs_of s) sc_ptr\ - \ pred_map (\cfg. Suc 0 < length (scrc_refills cfg)) (sc_refill_cfgs_of s) sc_ptr" - apply (frule head_insufficient_true_imp_insufficient) - apply (clarsimp simp: vs_all_heap_simps) - apply (clarsimp simp: vs_all_heap_simps sc_at_ppred_def refills_unat_sum_def word_less_nat_alt) - apply (case_tac "sc_refills y"; fastforce dest!: member_le_sum_list) - done - -lemma length_sc_refills_cross: - "\(s, s') \ state_relation; sc_at scp s; sc_at' scp s'; valid_refills' scp s'\ - \ ((\sc. P (length (sc_refills sc))) |< scs_of2 s) scp - = ((\sc'. P (scRefillCount sc')) |< scs_of' s') scp" - apply (drule (2) state_relation_sc_relation) - apply (clarsimp simp: obj_at_simps is_sc_obj valid_refills'_def sc_relation_def opt_map_red - opt_pred_def) - done - -lemma update_refill_hd_comp: - "update_refill_hd scPtr (f \ g) - = do update_refill_hd scPtr g; - update_refill_hd scPtr f - od" - apply (clarsimp simp: update_refill_hd_def) - apply (rule box_equals[OF update_sched_context_decompose]; fastforce) - done - -lemma updateRefillHd_valid_refills'[wp]: - "updateRefillHd scPtr f \valid_refills' scPtr'\" - apply (clarsimp simp: updateRefillHd_def updateSchedContext_def setSchedContext_def) - apply (wpsimp wp: setObject_sc_wp) - apply (clarsimp simp: valid_refills'_def obj_at'_def projectKOs opt_map_def opt_pred_def) - done - -lemma updateRefillTl_valid_refills'[wp]: - "updateRefillTl scPtr f \valid_refills' scPtr'\" - apply (clarsimp simp: updateRefillTl_def updateSchedContext_def setSchedContext_def) - apply (wpsimp wp: setObject_sc_wp) - apply (clarsimp simp: valid_refills'_def obj_at'_def projectKOs opt_map_def opt_pred_def) - done - -lemma refill_pop_head_is_active_sc[wp]: - "refill_pop_head sc_ptr \is_active_sc sc_ptr'\" - apply (wpsimp simp: refill_pop_head_def wp: update_sched_context_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_kh_kheap_simps active_sc_def) - done - -lemma setSchedContext_is_active_sc_at': - "\is_active_sc' scPtr' and K (scPtr' = scPtr \ 0 < scRefillMax sc)\ - setSchedContext scPtr sc - \\_ s. is_active_sc' scPtr' s\" - apply (wpsimp wp: set_sc'.set_wp opt_map_red - simp: StateRelation.is_active_sc'_def opt_pred_def split: if_splits) - done - -lemma updateSchedContext_is_active_sc_at': - "\is_active_sc' scPtr' - and (\s. scPtr = scPtr' \ (\ko. ko_at' ko scPtr s \ 0 < scRefillMax ko \ 0 < scRefillMax (f ko)))\ - updateSchedContext scPtr f - \\_. is_active_sc' scPtr'\" - apply (simp add: updateSchedContext_def) - apply (wpsimp wp: setSchedContext_is_active_sc_at') - apply (clarsimp simp: is_active_sc'_def obj_at'_def projectKOs opt_map_red opt_pred_def) - done - -lemma refillPopHead_is_active_sc_at'[wp]: - "refillPopHead scPtr \is_active_sc' scPtr'\" - apply (simp add: refillPopHead_def) - apply (wpsimp wp: updateSchedContext_is_active_sc_at' getRefillNext_wp) - done - -lemma nonOverlappingMergeRefills_corres: - "sc_ptr = scPtr \ - corres dc (pspace_aligned and pspace_distinct and sc_at sc_ptr and is_active_sc sc_ptr - and valid_objs - and (\s. pred_map (\cfg. Suc 0 < length (scrc_refills cfg)) (sc_refill_cfgs_of s) sc_ptr)) - (valid_refills' sc_ptr) - (non_overlapping_merge_refills sc_ptr) - (nonOverlappingMergeRefills scPtr)" - apply (clarsimp simp: non_overlapping_merge_refills_def nonOverlappingMergeRefills_def) - apply (rule corres_cross[OF sc_at'_cross_rel[where t=scPtr]], simp) - apply (rule corres_symb_exec_r[OF _ get_sc_sp', rotated]; (solves wpsimp)?) - apply (rule_tac Q="is_active_sc' scPtr" in corres_cross_add_guard) - apply (fastforce dest: is_active_sc'2_cross) - apply (rule_tac Q="obj_at' (\sc'. Suc 0 < scRefillCount sc') scPtr" - in corres_cross_add_guard) - 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 projectKOs) - apply (rule corres_symb_exec_r[OF _ assert_sp, rotated]) - apply wpsimp - apply (rule no_fail_pre) - apply (rule no_fail_assert) - apply (clarsimp simp: no_fail_def obj_at'_def projectKOs) - - apply (rule_tac Q="\_. sc_at sc_ptr and is_active_sc sc_ptr" - and Q'="\_. valid_refills' scPtr and sc_at' scPtr" - in corres_underlying_split - ; (solves wpsimp)?) - apply (corresKsimp corres: refillPopHead_corres - simp: obj_at_def vs_all_heap_simps pred_map_simps sc_at_ppred_def) - apply (subst update_refill_hd_comp) - 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 (wpsimp simp: updateRefillHd_def simp: objBits_simps) - apply (simp add: is_active_sc_rewrite[symmetric]) - apply blast - done - -lemma head_insufficient_simp: - "sc_at scp s - \ head_insufficient scp s = Some (sc_at_pred (\sc. r_amount (refill_hd sc) < MIN_BUDGET) scp s)" - unfolding head_insufficient_def - by (clarsimp simp: obind_def read_sched_context_def obj_at_def is_sc_obj sc_at_pred_n_def) - -lemma refillHdInsufficient_simp: - "sc_at' scp s - \ refillHdInsufficient scp s - = Some (obj_at' (\sc :: sched_context. rAmount (refillHd sc) < minBudget) scp s)" - unfolding refillHdInsufficient_def - apply (clarsimp simp: obind_def readSchedContext_def split: option.splits) - apply (frule no_ofailD[OF no_ofail_sc_at'_readObject]) - apply (clarsimp simp: obj_at'_def dest!: readObject_misc_ko_at') - done - -lemma head_insufficient_equiv: - "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; valid_objs s; - pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) scPtr; valid_refills' scPtr s'\ - \ head_insufficient scPtr s = refillHdInsufficient scPtr s'" - apply (prop_tac "sc_at scPtr s") - apply (fastforce dest: valid_objs_valid_sched_context_size - simp: vs_all_heap_simps obj_at_kh_kheap_simps is_sc_obj_def) - apply (frule state_relation_pspace_relation) - apply (frule sc_at_cross; simp?) - apply (frule state_relation_sc_relation; simp?) - apply (subst head_insufficient_simp; simp?) - apply (subst refillHdInsufficient_simp; simp) - apply (frule refill_hd_relation) - apply (fastforce simp: vs_all_heap_simps valid_refills'_def opt_map_def opt_pred_def obj_at_simps) - apply (clarsimp simp: obj_at_def sc_at_ppred_def obj_at'_def projectKOs minBudget_def refill_map_def - MIN_BUDGET_def kernelWCETTicks_def opt_map_def vs_all_heap_simps) - done - -lemma refill_pop_head_no_fail: - "no_fail (\s. (\sc n. kheap s sc_ptr = Some (Structures_A.SchedContext sc n)) - \ pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) sc_ptr) - (refill_pop_head sc_ptr)" - apply (wpsimp simp: refill_pop_head_def get_refills_def get_sched_context_def - wp: get_object_wp update_sched_context_no_fail) - apply (clarsimp simp: obj_at_def a_type_def vs_all_heap_simps is_sc_obj_def) - done - -lemma refill_pop_head_sched_context_at[wp]: - "refill_pop_head sc_ptr' \\s. \sc n. kheap s sc_ptr = Some (Structures_A.SchedContext sc n)\" - apply (clarsimp simp: refill_pop_head_def) - apply (wpsimp wp: update_sched_context_wp) - done - -lemma non_overlapping_merge_refills_no_fail: - "no_fail (\s. (\sc n. kheap s sc_ptr = Some (Structures_A.SchedContext sc n)) - \ pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) sc_ptr) - (non_overlapping_merge_refills sc_ptr)" - apply (wpsimp wp: refill_pop_head_no_fail - simp: non_overlapping_merge_refills_def update_refill_hd_def) - done - -lemma non_overlapping_merge_refills_is_active_sc[wp]: - "non_overlapping_merge_refills sc_ptr \is_active_sc sc_ptr'\" - apply (clarsimp simp: non_overlapping_merge_refills_def update_refill_hd_def) - apply (rule bind_wp_fwd_skip, solves wpsimp) - apply (wpsimp wp: update_sched_context_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_def) - done - -crunch non_overlapping_merge_refills - for valid_objs[wp]: valid_objs - -lemma nonOverLappingMergeRefills_valid_refills'[wp]: - "nonOverlappingMergeRefills scPtr \valid_refills' scPtr\" - apply (wpsimp simp: nonOverlappingMergeRefills_def) - apply (clarsimp simp: obj_at'_def) - done - -definition head_insufficient_loop_measure where - "head_insufficient_loop_measure sc_ptr - \ measure (\(_, s). case kheap s sc_ptr of Some (Structures_A.SchedContext sc _) - \ (length (sc_refills sc)))" - -lemma non_overlapping_merge_refills_terminates: - "\pred_map (\cfg. refills_unat_sum (scrc_refills cfg) \ unat max_time) - (sc_refill_cfgs_of s) sc_ptr; - pred_map (\cfg. unat MIN_BUDGET \ refills_unat_sum (scrc_refills cfg)) - (sc_refill_cfgs_of s) sc_ptr\ - \ whileLoop_terminates (\_ s. the (head_insufficient sc_ptr s)) - (\_. non_overlapping_merge_refills sc_ptr) r s" - (is "\?P s; ?Q s\ \ _") - apply (rule_tac I="\_. ?P and ?Q" - in whileLoop_terminates_inv[where R="head_insufficient_loop_measure sc_ptr"]) - apply simp - apply (intro hoare_vcg_conj_lift_pre_fix) - apply (wpsimp wp: non_overlapping_merge_refills_refills_unat_sum_lower_bound - non_overlapping_merge_refills_refills_unat_sum) - apply (fastforce dest: head_insufficient_length_at_least_two) - apply (wpsimp wp: update_sched_context_wp - simp: head_insufficient_loop_measure_def non_overlapping_merge_refills_def - refill_pop_head_def update_refill_hd_def) - apply (fastforce dest: head_insufficient_length_at_least_two - simp: vs_all_heap_simps obj_at_def) - apply (clarsimp simp: head_insufficient_loop_measure_def) - done - -lemma refills_unat_sum_MIN_BUDGET_implies_non_empty_refills: - "pred_map (\cfg. unat MIN_BUDGET \ refills_unat_sum (scrc_refills cfg)) (sc_refill_cfgs_of s) sc_ptr - \ pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) sc_ptr" - apply (auto simp: vs_all_heap_simps refills_unat_sum_def MIN_BUDGET_nonzero unat_eq_zero) - done - -lemma headInsufficientLoop_corres: - "sc_ptr = scPtr - \ corres dc (pspace_aligned and pspace_distinct and sc_at sc_ptr and is_active_sc sc_ptr - and valid_objs - and (\s. pred_map (\cfg. unat MIN_BUDGET \ refills_unat_sum (scrc_refills cfg)) - (sc_refill_cfgs_of s) sc_ptr) - and (\s. pred_map (\cfg. refills_unat_sum (scrc_refills cfg) \ unat max_time) - (sc_refill_cfgs_of s) sc_ptr)) - (valid_refills' sc_ptr) - (head_insufficient_loop sc_ptr) - (headInsufficientLoop scPtr)" - apply (clarsimp simp: head_insufficient_loop_def headInsufficientLoop_def runReaderT_def) - apply (rule_tac Q="active_sc_at' scPtr" in corres_cross_add_guard) - apply (fastforce dest: active_sc_at'_cross) - apply (rule corres_whileLoop_abs; simp?) - apply (frule head_insufficient_equiv[where scPtr=scPtr]; simp?) - apply (fastforce intro: refills_unat_sum_MIN_BUDGET_implies_non_empty_refills) - apply (corresKsimp corres: nonOverlappingMergeRefills_corres) - apply (fastforce dest: head_insufficient_length_at_least_two) - apply (wpsimp wp: non_overlapping_merge_refills_no_fail) - apply (wpsimp wp: non_overlapping_merge_refills_refills_unat_sum_lower_bound - non_overlapping_merge_refills_refills_unat_sum) - apply (fastforce dest: head_insufficient_length_greater_than_one) - apply (wpsimp wp: nonOverlappingMergeRefills_valid_objs') - apply (fastforce intro!: non_overlapping_merge_refills_terminates) - done - -lemma refillEmpty_sp: - "\P\refillEmpty scp \\rv s. P s \ (\ko. ko_at' ko scp s \ rv = (scRefillCount ko = 0))\" - apply (wpsimp wp: refillEmpty_wp) - apply (clarsimp simp: obj_at'_def) - done - -lemma refillFull_sp: - "\P\ refillFull scp \\rv s. P s \ (\ko. ko_at' ko scp s \ rv = (scRefillCount ko = scRefillMax ko))\" - apply (wpsimp wp: refillFull_wp) - apply (clarsimp simp: obj_at'_def) - done - -lemma refillFull_corres: - "sc_ptr = scPtr - \ corres (=) (sc_at sc_ptr and pspace_aligned and pspace_distinct) - (valid_refills' scPtr) - (refill_full sc_ptr) - (refillFull scPtr)" - apply (rule_tac Q="sc_at' scPtr" in corres_cross_add_guard) - apply (fastforce intro: sc_at_cross) - apply (clarsimp simp: refill_full_def refillFull_def) - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (corresKsimp corres: get_sc_corres) - apply (corresKsimp corres: corres_return_eq_same) - apply (fastforce simp: sc_relation_def obj_at_simps valid_refills'_def opt_map_red opt_pred_def) - done - -lemma scheduleUsed_corres: - "\sc_ptr = scPtr; new = refill_map new'\ \ - corres dc (sc_at sc_ptr and is_active_sc2 sc_ptr and pspace_aligned and pspace_distinct) - (valid_refills' scPtr) - (schedule_used sc_ptr new) - (scheduleUsed scPtr new')" - apply (clarsimp simp: schedule_used_def scheduleUsed_def get_refills_def bind_assoc) - apply (rule_tac Q="sc_at' scPtr" in corres_cross_add_guard) - apply (fastforce intro: sc_at_cross) - apply (rule_tac Q="is_active_sc' scPtr" in corres_cross_add_guard) - apply (fastforce intro: is_active_sc'_cross) - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (corresKsimp corres: get_sc_corres) - apply (rename_tac sc sc') - apply (rule corres_symb_exec_r[rotated, OF assert_sp]; (solves wpsimp)?) - apply wpsimp - apply (clarsimp simp: is_active_sc'_def obj_at_simps opt_map_red opt_pred_def) - apply (rule corres_symb_exec_r[rotated, OF refillEmpty_sp] - ; (solves \wpsimp simp: refillEmpty_def\)?) - apply (rule_tac F="empty = (sc_refills sc = [])" in corres_req) - apply (fastforce dest: length_sc_refills_cross[where P="\l. 0 = l"] - simp: valid_refills'_def obj_at_simps opt_map_red opt_pred_def) - apply (rule corres_if_split; (solves simp)?) - apply (corresKsimp corres: refillAddTail_corres simp: refill_map_def) - apply (clarsimp simp: valid_refills'_def obj_at_simps opt_map_red opt_pred_def) - apply (rule_tac F="sc_valid_refills' sc'" in corres_req) - apply (clarsimp simp: valid_refills'_def obj_at_simps opt_map_red opt_pred_def) - apply (rule corres_if_split; (solves simp)?) - apply (fastforce dest: refills_tl_equal - simp: refill_map_def can_merge_refill_def) - apply (corresKsimp corres: updateRefillTl_corres - simp: refill_map_def) - apply (rule corres_underlying_split[rotated 2, OF refill_full_sp refillFull_sp]) - apply (corresKsimp corres: refillFull_corres) - apply (rule corres_if_split; (solves simp)?) - apply (corresKsimp corres: refillAddTail_corres) - apply (clarsimp simp: refill_map_def obj_at_simps opt_map_red opt_pred_def) - apply (corresKsimp corres: updateRefillTl_corres simp: refill_map_def) - done - -lemma head_time_buffer_simp: - "sc_at (cur_sc s) s - \ head_time_buffer usage s - = Some (sc_at_pred (\sc. r_amount (refill_hd sc) \ usage - \ r_time (refill_hd sc) < MAX_RELEASE_TIME) - (cur_sc s) s)" - unfolding head_time_buffer_def - apply (clarsimp simp: obind_def read_sched_context_def obj_at_def is_sc_obj sc_at_pred_n_def - ogets_def) - done - -lemma headTimeBuffer_simp: - "sc_at' (ksCurSc s) s - \ headTimeBuffer usage s - = Some (obj_at' (\sc :: sched_context. rAmount (refillHd sc) \ usage - \ rTime (refillHd sc) < maxReleaseTime) - (ksCurSc s) s)" - unfolding headTimeBuffer_def - apply (clarsimp simp: obind_def readSchedContext_def split: option.splits) - apply (frule no_ofailD[OF no_ofail_sc_at'_readObject]) - apply (fastforce simp: readObject_def obind_def omonad_defs split_def loadObject_default_def - readCurSc_def obj_at'_def ogets_def - split: option.splits if_split_asm) - done - -lemma head_time_buffer_equiv: - "\(s, s') \ state_relation; pspace_aligned s; pspace_distinct s; valid_objs s; - pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) (cur_sc s); - valid_refills' (ksCurSc s') s'; usage = usage'\ - \ head_time_buffer usage s = headTimeBuffer usage' s'" - apply (prop_tac "sc_at (cur_sc s) s") - apply (fastforce dest: valid_objs_valid_sched_context_size - simp: vs_all_heap_simps obj_at_kh_kheap_simps is_sc_obj_def) - apply (frule state_relation_pspace_relation) - apply (frule sc_at_cross; simp?) - apply (frule state_relation_sc_relation; simp?) - apply (subst head_time_buffer_simp; simp?) - apply (subst headTimeBuffer_simp) - apply (clarsimp simp: state_relation_def) - apply (frule refill_hd_relation) - apply (clarsimp simp: valid_refills'_def obj_at_simps state_relation_def) - apply (clarsimp simp: sc_ko_at_valid_objs_valid_sc' opt_map_def opt_pred_def obj_at_simps) - apply (clarsimp simp: obj_at_def sc_at_ppred_def obj_at'_def projectKOs state_relation_def - maxReleaseTime_equiv opt_map_def vs_all_heap_simps refill_map_def) - done - -lemma refillSingle_sp: - "\P\ - refillSingle scp - \\rv s. P s \ (\ko. ko_at' ko scp s \ rv = (scRefillHead ko = refillTailIndex ko))\" - apply (clarsimp simp: refillSingle_def) - apply wpsimp - apply (clarsimp simp: obj_at'_def) - done - -crunch updateRefillHd, scheduleUsed - for valid_sched_context'[wp]: "valid_sched_context' sc" - -lemma handleOverrunLoopBody_corres: - "r = r' - \ corres (=) (\s. sc_at (cur_sc s) s \ is_active_sc2 (cur_sc s) s - \ pspace_aligned s \ pspace_distinct s - \ pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) (cur_sc s)) - (\s'. valid_refills' (ksCurSc s') s') - (handle_overrun_loop_body r) - (handleOverrunLoopBody r')" - apply (rule_tac Q="\s'. sc_at' (ksCurSc s') s'" in corres_cross_add_guard) - apply (fastforce intro: sc_at_cross 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: state_relation_def) - apply (clarsimp simp: handle_overrun_loop_body_def handleOverrunLoopBody_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurSc_sp]) - apply (corresKsimp corres: getCurSc_corres) - apply (rule corres_underlying_split[rotated 2, OF refill_single_sp refillSingle_sp]) - apply (corresKsimp corres: refillSingle_corres) - apply (fastforce simp: obj_at_simps valid_refills'_def opt_map_red opt_pred_def) - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (corresKsimp corres: get_sc_corres) - apply (rename_tac sc sc') - apply (rule_tac Q="\_ s. sc_refills sc \ []" - and Q'="\_ _. sc_valid_refills' sc'" - and r'=dc - in corres_underlying_split[rotated]) - apply corresKsimp - apply (fastforce dest: refill_hd_relation simp: refill_map_def) - apply (wpsimp simp: update_refill_hd_def - wp: update_sched_context_wp) - apply (clarsimp simp: vs_all_heap_simps obj_at_def) - apply wpsimp - apply (clarsimp simp: valid_refills'_def obj_at_simps opt_map_red opt_pred_def) - apply (rule corres_if_split; simp?) - apply (corresKsimp corres: updateRefillHd_corres) - apply (fastforce simp: refill_map_def sc_relation_def) - apply (rule_tac F="1 < scRefillCount sc'" in corres_req) - apply (frule_tac scp="scPtr" and P="\l. 1 < l" in length_sc_refills_cross) - apply (clarsimp simp: state_relation_def) - apply simp - apply (fastforce simp: refill_map_def sc_relation_def) - apply (clarsimp simp: opt_map_red opt_pred_def vs_all_heap_simps obj_at'_def projectKOs Suc_lessI) - apply (rule corres_guard_imp) - apply (rule corres_split[OF refillPopHead_corres]) - apply (rule scheduleUsed_corres) - apply simp - apply (clarsimp simp: refill_map_def sc_relation_def) - apply wpsimp - apply wpsimp - apply (clarsimp simp: is_active_sc2_def sc_at_ppred_def obj_at_def is_sc_obj_def active_sc_def - vs_all_heap_simps opt_map_red Suc_lessI) - apply (clarsimp simp: obj_at_simps) - done - -lemma schedule_used_no_fail[wp]: - "no_fail (\s. (\sc n. kheap s sc_ptr = Some (Structures_A.SchedContext sc n))) - (schedule_used sc_ptr new)" - apply (wpsimp simp: schedule_used_defs get_refills_def refill_full_def - wp: update_sched_context_wp) - done - -lemma handle_overrun_loop_body_no_fail: - "no_fail (\s. (\sc n. kheap s (cur_sc s) = Some (Structures_A.SchedContext sc n)) - \ pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) (cur_sc s)) - (handle_overrun_loop_body usage)" - unfolding handle_overrun_loop_body_def - apply (wpsimp simp: refill_single_def refill_size_def get_refills_def update_refill_hd_def - wp: refill_pop_head_no_fail) - done - -lemma scheduleUsed_is_active_sc'[wp]: - "scheduleUsed scPtr new \is_active_sc' sc_Ptr'\" - apply (clarsimp simp: scheduleUsed_def) - apply (wpsimp simp: refillAddTail_def updateRefillTl_def - wp: updateSchedContext_wp refillFull_wp refillEmpty_wp) - apply (clarsimp simp: obj_at_simps is_active_sc'_def opt_map_def opt_pred_def) - done - -lemma handleOverrunLoopBody_is_active_sc'[wp]: - "handleOverrunLoopBody usage \is_active_sc' sc_ptr\" - apply (clarsimp simp: handleOverrunLoopBody_def) - apply (wpsimp simp: updateRefillHd_def refillSingle_def - wp: updateSchedContext_wp) - apply (clarsimp simp: obj_at_simps is_active_sc'_def opt_map_def opt_pred_def) - done - -lemma refillAddTail_valid_refills'[wp]: - "refillAddTail scPtr refill \valid_refills' ptr\" - apply (clarsimp simp: refillAddTail_def) - apply (wpsimp wp: updateSchedContext_wp) - apply (clarsimp simp: valid_refills'_def obj_at_simps opt_map_red opt_pred_def) - done - -lemma scheduleUsed_valid_refills'[wp]: - "scheduleUsed ptr new \valid_refills' scPtr\" - apply (clarsimp simp: scheduleUsed_def) - apply (wpsimp wp: refillFull_wp refillEmpty_wp) - done - -crunch handle_overrun_loop_body - for valid_objs[wp]: valid_objs - -lemma handleOverrunLoopBody_valid_refills'[wp]: - "handleOverrunLoopBody r' \valid_refills' scPtr\" - apply (clarsimp simp: handleOverrunLoopBody_def updateRefillHd_def refillSingle_def) - apply wpsimp - apply (fastforce simp: valid_refills'_def opt_map_red opt_pred_def obj_at_simps - refillSingle_equiv[THEN arg_cong_Not, symmetric]) - done - -lemma schedule_used_length_nonzero[wp]: - "\\s. if sc_ptr' = sc_ptr - then pred_map \ (scs_of s) sc_ptr - else pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) sc_ptr\ - schedule_used sc_ptr' new - \\_ s. pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) sc_ptr\" - apply (wpsimp wp: update_sched_context_wp get_refills_wp - simp: schedule_used_defs) - apply (clarsimp simp: obj_at_def vs_all_heap_simps) - done - -lemma handle_overrun_loop_body_terminates_wf_helper: - "wf {((r' :: ticks, s' :: 'a state), (r, s)). unat r' < unat r}" - apply (insert wf_inv_image[where r="{(m, n). m < n}" - and f="\(r :: ticks, s :: 'a state). unat r"]) - apply (clarsimp simp: inv_image_def) - apply (prop_tac "wf {(m, n). m < n}") - apply (fastforce intro: wf) - apply (drule meta_mp, simp) - apply (prop_tac "{(x :: ticks \ 'a state, y :: ticks \ 'a state). - (case x of (r, s) \ unat r) - < (case y of (r, s) \ unat r)} - = {((r, s), r', s'). unat r < unat r'}") - apply fastforce - apply fastforce - done - -\ \The following method can be used to try to solve Hoare triples in the following way. - Note that the method works best when the precondition is not schematic. - First, if the postcondition is not a conjunction, it will try to solve the goal with the - method given to `solves`. The goal will be left untouched if it cannot solve the goal. - If the postcondition is a conjunction, the method will pull it apart into all the conjuncts - using hoare_vcg_conj_lift_pre_fix. It will then attempt to solve each of these individually.\ -method wps_conj_solves uses wp simp wps - = (clarsimp simp: pred_conj_def)? - , (intro hoare_vcg_conj_lift_pre_fix - ; (solves \rule hoare_weaken_pre, (wpsimp wp: wp simp: simp | wps wps)+\)?) - | (solves \rule hoare_weaken_pre, (wpsimp wp: wp simp: simp | wps wps)+\)? - -lemma handle_overrun_loop_body_terminates: - "\sc_at (cur_sc s) s; - pred_map (\cfg. \refill \ set (scrc_refills cfg). 0 < unat (r_amount refill)) - (sc_refill_cfgs_of s) (cur_sc s); - pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) (cur_sc s); - pred_map (\cfg. refills_unat_sum (scrc_refills cfg) = unat (scrc_budget cfg)) - (sc_refill_cfgs_of s) (cur_sc s)\ - \ whileLoop_terminates (\r s. the (head_time_buffer r s)) handle_overrun_loop_body usage s" - (is "\?P1 s; ?P2 s; ?P3 s; ?P4 s\ \ _") - apply (rule_tac R="{((r' :: ticks, s' :: 'a state), (r, s)). unat r' < unat r}" - and I="\_ s'. ?P1 s' \ ?P2 s' \ ?P3 s' \ ?P4 s' \ cur_sc s' = cur_sc s" - in whileLoop_terminates_inv) - apply simp - prefer 2 - apply (fastforce simp: handle_overrun_loop_body_terminates_wf_helper) - apply (rename_tac r s') - apply (wps_conj_solves wp: handle_overrun_loop_body_non_zero_refills - handle_overrun_loop_body_refills_unat_sum_equals_budget) - apply (wpsimp simp: handle_overrun_loop_body_def) - apply (rename_tac sc n) - apply (subst unat_sub) - apply (prop_tac "sc_at (cur_sc s') s'", simp) - apply (frule_tac usage=r and s=s' in head_time_buffer_simp) - apply (clarsimp simp: sc_at_ppred_def obj_at_def) - apply (clarsimp simp: obj_at_def vs_all_heap_simps) - apply (frule_tac x="refill_hd sc" in bspec, fastforce) - apply (prop_tac "0 < unat r") - apply (prop_tac "sc_at (cur_sc s') s'") - apply (clarsimp simp: obj_at_def is_sc_obj_def) - apply (frule_tac usage=r and s=s' in head_time_buffer_simp) - apply (clarsimp simp: sc_at_ppred_def obj_at_def) - apply (frule_tac x="refill_hd sc" in bspec, fastforce) - apply (fastforce simp: word_le_nat_alt) - apply fastforce - done - -lemma handleOverrunLoop_corres: - "usage = usage' \ - corres (=) (\s. sc_at (cur_sc s) s \ is_active_sc2 (cur_sc s) s - \ pspace_aligned s \ pspace_distinct s - \ valid_objs s - \ pred_map (\cfg. scrc_refills cfg \ []) (sc_refill_cfgs_of s) (cur_sc s) - \ pred_map (\cfg. \refill\set (scrc_refills cfg). 0 < unat (r_amount refill)) - (sc_refill_cfgs_of s) (cur_sc s) - \ pred_map (\cfg. refills_unat_sum (scrc_refills cfg) = unat (scrc_budget cfg)) - (sc_refill_cfgs_of s) (cur_sc s)) - (\s'. valid_refills' (ksCurSc s') s') - (handle_overrun_loop usage) - (handleOverrunLoop usage')" - apply (rule_tac Q="\s'. sc_at' (ksCurSc s') s'" in corres_cross_add_guard) - apply (fastforce intro: sc_at_cross 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: state_relation_def) - apply (clarsimp simp: handle_overrun_loop_def handleOverrunLoop_def runReaderT_def) - apply (rule corres_whileLoop_abs; simp?) - apply (frule_tac usage=r' in head_time_buffer_equiv; simp?) - apply fastforce - apply (corresKsimp corres: handleOverrunLoopBody_corres) - apply (wps_conj_solves wp: handle_overrun_loop_body_non_zero_refills - handle_overrun_loop_body_refills_unat_sum_equals_budget) - apply wps_conj_solves - apply (fastforce intro: handle_overrun_loop_body_terminates) - done - -lemma handle_overrun_loop_is_active_sc[wp]: - "handle_overrun_loop usage \\s. is_active_sc sc_ptr s\" - apply handle_overrun_loop_simple - done - -lemma get_refills_exs_valid[wp]: - "sc_at sc_ptr s \ \(=) s\ get_refills sc_ptr \\\r. (=) s\" - apply (clarsimp simp: get_refills_def) - apply (wpsimp wp: get_sched_context_exs_valid) - apply (erule sc_atD1) - apply simp - done - -crunch handleOverrunLoop - for valid_refills'[wp]: "valid_refills' scPtr" - (wp: crunch_wps) - -lemma refillBudgetCheck_corres: - "usage = usage' - \ corres dc ((\s. sc_at (cur_sc s) s \ is_active_sc (cur_sc s) s - \ valid_objs s - \ pspace_aligned s \ pspace_distinct s) - and (\s. \ round_robin (cur_sc s) s \ valid_refills (cur_sc s) s)) - (\s'. valid_refills' (ksCurSc s') s') - (refill_budget_check usage) - (refillBudgetCheck usage')" - (is "_ \ corres _ (?P and _) _ _ _") - apply (rule_tac Q="\s'. sc_at' (ksCurSc s') s'" in corres_cross_add_guard) - apply (fastforce intro: sc_at_cross 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'2_cross simp: state_relation_def) - - apply (clarsimp simp: refill_budget_check_def refillBudgetCheck_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurSc_sp]) - apply (corresKsimp corres: getCurSc_corres) - apply (rule corres_symb_exec_r[rotated, OF scActive_sp]; (solves \wpsimp simp: scActive_def\)?) - apply (rule corres_symb_exec_r[rotated, OF assert_sp]; (solves wpsimp)?) - apply (wpsimp wp: no_fail_assert - simp: is_active_sc'_def opt_map_red opt_pred_def obj_at_simps) - apply (rule corres_underlying_split[rotated 2, OF is_round_robin_sp isRoundRobin_sp]) - apply (corresKsimp corres: isRoundRobin_corres) - apply (rule corres_symb_exec_l[rotated, OF _ assert_sp]; (solves wpsimp)?) - apply (rule_tac F="\roundRobin" in corres_req) - apply clarsimp - apply (rule corres_symb_exec_r[rotated, OF assert_sp]; (solves wpsimp)?) - - apply (rule_tac Q="\usage' s. ?P s - \ pred_map (\cfg. refills_unat_sum (scrc_refills cfg) - = unat (scrc_budget cfg)) - (sc_refill_cfgs_of s) sc_ptr - \ pred_map (\cfg. MIN_BUDGET \ scrc_budget cfg) - (sc_refill_cfgs_of s) sc_ptr - \ sc_ptr = cur_sc s - \ (pred_map (\cfg. r_time (hd (scrc_refills cfg)) < MAX_RELEASE_TIME) - (sc_refill_cfgs_of s) (cur_sc s) - \ pred_map (\cfg. usage' < r_amount (hd (scrc_refills cfg))) - (sc_refill_cfgs_of s) (cur_sc s)) - \ pred_map (\cfg. scrc_refills cfg \ []) - (sc_refill_cfgs_of s) sc_ptr" - and Q'="\_ s'. valid_refills' scPtr s' \ active_sc_at' scPtr s' \ scPtr = ksCurSc s'" - in corres_underlying_split) - apply (corresKsimp corres: handleOverrunLoop_corres) - apply (fastforce intro: valid_refills_refills_unat_sum_equals_budget - simp: vs_all_heap_simps cfg_valid_refills_def round_robin_def - sp_valid_refills_def is_active_sc_rewrite[symmetric]) - apply (find_goal \match conclusion in "\P\ handle_overrun_loop _ \Q\" for P Q \ -\) - apply (clarsimp simp: pred_conj_def) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves handle_overrun_loop_simple)?) - apply wps_conj_solves - apply (wpsimp wp: handle_overrun_loop_refills_unat_sum_equals_budget) - apply (fastforce intro: valid_refills_refills_unat_sum_equals_budget - simp: vs_all_heap_simps cfg_valid_refills_def round_robin_def - sp_valid_refills_def) - apply (clarsimp simp: handle_overrun_loop_def) - apply (wpsimp wp: valid_whileLoop[where I="\_ s. pred_map \ (scs_of s) (cur_sc s)"]) - apply (fastforce simp: head_time_buffer_true_imp_unat_buffer vs_all_heap_simps - word_less_nat_alt word_le_nat_alt) - apply (clarsimp simp: vs_all_heap_simps) - apply (find_goal \match conclusion in "\P\ handleOverrunLoop _ \Q\" for P Q \ -\) - apply wpsimp - apply (clarsimp simp: active_sc_at'_def obj_at_simps) - - apply (clarsimp simp: get_refills_def) - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (corresKsimp corres: get_sc_corres - simp: state_relation_def active_sc_at'_def obj_at_simps) - apply (rename_tac sc sc') - apply (rule_tac Q="\_ s. ?P s - \ pred_map (\cfg. refills_unat_sum (scrc_refills cfg) - = unat (scrc_budget cfg)) - (sc_refill_cfgs_of s) scPtr - \ pred_map (\cfg. MIN_BUDGET \ scrc_budget cfg) - (sc_refill_cfgs_of s) scPtr - \ scPtr = cur_sc s" - and Q'="\_ s'. valid_refills' scPtr s' \ active_sc_at' scPtr s' \ scPtr = ksCurSc s'" - and r'=dc - in corres_underlying_split[rotated]) - apply (corresKsimp corres: headInsufficientLoop_corres) - apply (fastforce simp: vs_all_heap_simps word_le_nat_alt) - apply (intro hoare_vcg_conj_lift_pre_fix; (solves wpsimp)?) - apply schedule_used_simple - apply (clarsimp simp: obj_at_def is_sc_obj_def) - apply schedule_used_simple - apply (wpsimp wp: schedule_used_refills_unat_sum update_sched_context_wp - simp: update_refill_hd_def) - apply (clarsimp simp: obj_at_def vs_all_heap_simps refills_unat_sum_cons - refills_unat_sum_append) - apply (subst unat_sub) - apply fastforce - apply (clarsimp simp: word_less_nat_alt) - apply (drule less_imp_le) - apply (clarsimp simp: refills_unat_sum_def) - apply (case_tac "sc_refills sc"; clarsimp simp: refills_unat_sum_cons) - apply schedule_used_simple - apply wpsimp - - apply (rule_tac F="refill_hd sc = refill_map (refillHd sc')" in corres_req) - apply clarsimp - apply (rule refill_hd_relation) - apply fastforce - apply (clarsimp simp: vs_all_heap_simps obj_at_def) - apply (fastforce simp: valid_refills'_def obj_at_simps opt_map_red opt_pred_def) - - apply (clarsimp simp: maxReleaseTime_equiv) - apply (simp add: when_def split del: if_split) - apply (rule corres_if_split; (solves simp)?) - apply (clarsimp simp: refill_map_def) - apply (rule corres_symb_exec_l[rotated 2, OF get_sched_context_sp]) - apply wpsimp - apply (clarsimp simp: obj_at_def) - apply (find_goal \match conclusion in "\P\ f \\Q\" for P f Q \ -\) - apply (wpsimp wp: get_sched_context_exs_valid) - apply (clarsimp simp: obj_at_def) - apply simp - apply (rename_tac new_sc) - apply (rule_tac F="new_sc=sc" in corres_req) - apply (clarsimp simp: obj_at_def) - apply (subst update_refill_hd_comp) - apply (clarsimp simp: bind_assoc) - apply (rule corres_guard_imp) - apply (rule corres_split[OF updateRefillHd_corres]) - apply simp - apply (clarsimp simp: refill_map_def) - apply (rule corres_split[OF updateRefillHd_corres]) - apply simp - apply (clarsimp simp: refill_map_def) - apply (rule scheduleUsed_corres) - apply simp - apply (clarsimp simp: refill_map_def sc_relation_def) - apply wpsimp - apply wpsimp - apply wpsimp - apply wpsimp - apply (clarsimp simp: is_active_sc_rewrite) - apply (fastforce simp: active_sc_at'_def is_active_sc'_def obj_at_simps opt_map_red) - done - -(* schedule_corres *) - -crunch setReprogramTimer - for valid_tcbs'[wp]: valid_tcbs' - and valid_refills'[wp]: "valid_refills' scPtr" - and ksCurSc[wp]: "\s. P (ksCurSc s)" - (simp: valid_refills'_def) - -lemma checkDomainTime_corres: - "corres dc (valid_tcbs and weak_valid_sched_action and active_scs_valid and pspace_aligned - and pspace_distinct) - (valid_tcbs' and valid_queues and valid_queues' and valid_release_queue_iff) - check_domain_time - checkDomainTime" - apply (clarsimp simp: check_domain_time_def checkDomainTime_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF isCurDomainExpired_corres]) - apply (rule corres_when) - apply simp - apply (rule corres_split[OF setReprogramTimer_corres]) - apply (rule rescheduleRequired_corres) - apply (wpsimp wp: hoare_drop_imps - simp: isCurDomainExpired_def)+ - done - -crunch refill_budget_check_round_robin - for sc_at[wp]: "sc_at sc_ptr" - and valid_objs[wp]: valid_objs - and pspace_aligned[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - -lemma commitTime_corres: - "corres dc (\s. sc_at (cur_sc s) s \ valid_objs s \ pspace_aligned s \ pspace_distinct s - \ (cur_sc_active s \ valid_refills (cur_sc s) s)) - (\s'. is_active_sc' (ksCurSc s') s' \ valid_refills' (ksCurSc s') s') - commit_time - commitTime" - supply if_split[split del] - apply (rule_tac Q="\s'. sc_at' (ksCurSc s') s'" in corres_cross_add_guard) - apply (fastforce intro: sc_at_cross simp: state_relation_def) - apply (clarsimp simp: commit_time_def commitTime_def liftM_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurSc_sp]) - apply (corresKsimp corres: getCurSc_corres) - apply clarsimp - apply (rule corres_underlying_split[rotated 2, OF get_sched_context_sp get_sc_sp']) - apply (corresKsimp corres: get_sc_corres) - apply (rule corres_symb_exec_r[rotated, OF getIdleSC_sp]) - apply wpsimp - apply (wpsimp simp: getIdleSC_def) - apply (rename_tac idleSCPtr) - apply (rule corres_underlying_split[rotated, where r'=dc]) - apply (rule setConsumedTime_corres) - apply simp - apply wpsimp - apply wpsimp - apply (clarsimp simp: when_def) - apply (rule_tac F="idleSCPtr = idle_sc_ptr" in corres_req) - apply (clarsimp simp: state_relation_def) - apply (rule corres_if_split; fastforce?) - apply (fastforce simp: sc_relation_def active_sc_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getConsumedTime_sp]) - apply corresKsimp - apply clarsimp - apply (rename_tac consumed) - apply (rule_tac Q="\_ s. sc_at (cur_sc s) s \ csc = cur_sc s" - and Q'="\_ s'. sc_at' (ksCurSc s') s' \ csc = ksCurSc s'" - and r'=dc - in corres_underlying_split[rotated]) - apply (clarsimp simp: updateSchedContext_def) - apply (rule corres_symb_exec_r[rotated, OF get_sc_sp']) - apply wpsimp - apply wpsimp - apply (rename_tac sc') - apply (prop_tac "(\sc. sc\sc_consumed := sc_consumed sc + consumed\) - = sc_consumed_update (\c. c + consumed)") - apply force - apply (prop_tac "scConsumed_update (\_. scConsumed sc' + consumed) sc' - = scConsumed_update (\c. c + consumed) sc'") - apply (fastforce intro: sched_context.expand) - apply (rule_tac P="\t. corres dc _ _ (update_sched_context csc t) _" in subst[OF sym]) - apply assumption - apply (rule_tac P="\t. corres dc _ _ _ (setSchedContext csc t)" in subst[OF sym]) - apply assumption - apply (rule corres_guard_imp) - apply (rule_tac f'="\sched_context'. (scConsumed_update (\c. c + consumed)) sched_context'" - in setSchedContext_update_sched_context_no_stack_update_corres) - apply (clarsimp simp: sc_relation_def opt_map_red opt_map_def active_sc_def) - apply fastforce - apply (fastforce simp: obj_at_simps) - apply (wpsimp simp: isRoundRobin_def | wps)+ - apply (clarsimp simp: ifM_def split: if_split) - apply (rule corres_underlying_split[rotated 2, OF is_round_robin_sp isRoundRobin_sp]) - apply (corresKsimp corres: isRoundRobin_corres) - apply (corresKsimp corres: refillBudgetCheckRoundRobin_corres refillBudgetCheck_corres) - apply (fastforce simp: obj_at_def vs_all_heap_simps is_sc_obj_def obj_at_simps sc_relation_def - is_active_sc'_def opt_map_red opt_pred_def active_sc_def) - done - -crunch ifCondRefillUnblockCheck - for valid_objs'[wp]: valid_objs' - (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" - apply (clarsimp simp: valid_state_def) - apply add_cur_tcb' - apply (clarsimp simp: switch_sched_context_def switchSchedContext_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurSc_sp]) - apply (corresKsimp corres: getCurSc_corres) - apply (clarsimp, rename_tac curScPtr) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurThread_sp]) - apply corresKsimp - apply (clarsimp, rename_tac ct) - apply (rule corres_underlying_split[rotated 2, OF gsc_sp threadGet_sp, where r'="(=)"]) - apply (rule corres_guard_imp) - apply (rule get_tcb_obj_ref_corres) - apply (fastforce simp: tcb_relation_def) - apply (fastforce simp: cur_tcb_def) - apply (fastforce simp: cur_tcb'_def) - apply (clarsimp, rename_tac ctScOpt) - apply (rule corres_symb_exec_l[rotated, OF _ assert_opt_sp]) - apply wpsimp - apply (fastforce simp: obj_at_def pred_tcb_at_def vs_all_heap_simps) - apply wpsimp - apply (fastforce simp: obj_at_def pred_tcb_at_def vs_all_heap_simps) - apply (rename_tac scp) - apply (rule corres_symb_exec_l[rotated, OF _ get_sched_context_sp]) - apply (rule get_sched_context_exs_valid) - apply (clarsimp simp: sc_at_pred_n_def obj_at_def is_sc_obj_def) - apply (rename_tac ko n, case_tac ko; clarsimp) - apply wpsimp - apply (clarsimp simp: sc_at_pred_n_def obj_at_def is_sc_obj_def) - apply (rename_tac ko n, case_tac ko; clarsimp) - apply (rule_tac F="the ctScOpt = scp" in corres_req, simp) - apply (rule_tac Q="\_ s. sc_at (cur_sc s) s \ valid_objs s \ pspace_aligned s \ pspace_distinct s - \ (cur_sc_active s \ valid_refills (cur_sc s) s)" - and Q'="\_. valid_objs'" - and r'=dc - in corres_underlying_split; - (solves wpsimp)?) - apply (clarsimp simp: when_def) - 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 - 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) - 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)?) - apply (corresKsimp corres: commitTime_corres) - apply (fastforce intro!: valid_objs'_valid_refills' sc_at_cross - simp: state_relation_def) - apply (corresKsimp corres: setCurSc_corres) - apply (wpsimp wp: hoare_vcg_imp_lift' | wps)+ - apply (fastforce intro: valid_sched_context_size_objsI active_scs_validE - simp: obj_at_def is_sc_obj_def) - done - -lemma commit_time_active_sc_tcb_at[wp]: - "commit_time \active_sc_tcb_at t\" - by (wpsimp simp: commit_time_def) - -crunch switch_sched_context - for active_sc_tcb_at[wp]: "active_sc_tcb_at t" - and not_in_release_q[wp]: "\s. t \ set (release_queue s)" - and pspace_aligned[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - (wp: crunch_wps simp: crunch_simps) - -crunch schedule_choose_new_thread - for sc_at[wp]: "sc_at sc_ptr" - (wp: crunch_wps dxo_wp_weak simp: crunch_simps) - -lemma scAndTimer_corres: - "corres dc (\s. valid_state s \ cur_tcb s \ sc_at (cur_sc s) s - \ active_scs_valid s \ valid_release_q s - \ current_time_bounded s \ active_sc_tcb_at (cur_thread s) s) - invs' - sc_and_timer - scAndTimer" - apply (clarsimp simp: sc_and_timer_def scAndTimer_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF switchSchedContext_corres]) - apply (rule corres_split[OF getReprogramTimer_corres]) - apply (clarsimp simp: when_def) - apply (rule corres_split[OF setNextInterrupt_corres]) - apply (rule setReprogramTimer_corres) - apply (wpsimp wp: hoare_vcg_ball_lift2| wps)+ - apply (rule_tac Q'="\_.invs" in hoare_post_imp, fastforce) - apply wpsimp+ - apply (rule_tac Q'="\_. invs'" in hoare_post_imp, fastforce) - apply (wpsimp wp: switchSchedContext_invs') - apply (clarsimp simp: valid_state_def valid_release_q_def) - apply fastforce - done - -lemma tcb_sched_action_valid_state[wp]: - "tcb_sched_action action thread \valid_state\" - by (wpsimp simp: tcb_sched_action_def set_tcb_queue_def get_tcb_queue_def valid_state_def - wp: hoare_drop_imps hoare_vcg_all_lift) - -crunch setQueue, addToBitmap - for isSchedulable_bool[wp]: "isSchedulable_bool tcbPtr" - (simp: bitmap_fun_defs isSchedulable_bool_def isScActive_def) - -lemma tcbSchedEnqueue_isSchedulable_bool[wp]: - "tcbSchedEnqueue tcbPtr \isSchedulable_bool tcbPtr'\" - apply (clarsimp simp: tcbSchedEnqueue_def unless_def) - apply (rule bind_wp_fwd_skip, wpsimp)+ - apply (rule hoare_when_cases, simp) - apply (rule bind_wp_fwd_skip, wpsimp)+ - apply (wpsimp wp: threadSet_wp) - apply (fastforce simp: obj_at_simps isSchedulable_bool_def pred_map_simps opt_map_def - isScActive_def - split: option.splits) - done - -lemma schedule_switch_thread_branch_sc_at_cur_sc: - "\valid_objs and cur_sc_tcb\ - schedule_switch_thread_branch candidate ct ct_schdlble - \\_ s. sc_at (cur_sc s) s\" - apply (rule hoare_weaken_pre) - apply (rule_tac f=cur_sc in hoare_lift_Pf2) - apply (wpsimp simp: schedule_switch_thread_fastfail_def wp: hoare_drop_imps)+ - apply (fastforce intro: cur_sc_tcb_sc_at_cur_sc) - done - -lemma schedule_switch_thread_branch_valid_state_and_cur_tcb: - "\\s. invs s \ scheduler_action s = switch_thread candidate\ - schedule_switch_thread_branch candidate ct ct_schdlble - \\_ s. valid_state s \ cur_tcb s\" - apply (wpsimp simp: schedule_switch_thread_fastfail_def set_scheduler_action_def - wp: switch_to_thread_invs thread_get_inv hoare_drop_imps) - done - -lemma schedule_corres: - "corres dc (invs and valid_sched and current_time_bounded and ct_ready_if_schedulable - and (\s. schact_is_rct s \ cur_sc_active s)) - invs' - (Schedule_A.schedule) - schedule" - apply add_sch_act_wf - apply add_cur_tcb' - apply (clarsimp simp: Schedule_A.schedule_def schedule_def sch_act_wf_asrt_def cur_tcb'_asrt_def) - apply (rule corres_stateAssert_add_assertion[rotated], simp)+ - 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 intro: weak_sch_act_wf_at_cross - simp: invs_def valid_state_def) - apply (rule corres_split_skip) - apply (wpsimp wp: hoare_vcg_imp_lift' cur_sc_active_lift) - apply wpsimp - apply (corresKsimp corres: checkDomainTime_corres) - apply (fastforce intro: weak_sch_act_wf_at_cross - simp: invs_def valid_state_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurThread_sp]) - apply corresKsimp - apply (rule corres_underlying_split[rotated 2, OF is_schedulable_sp' isSchedulable_sp]) - apply (corresKsimp corres: isSchedulable_corres) - apply (fastforce intro: weak_sch_act_wf_at_cross - simp: invs_def valid_state_def state_relation_def cur_tcb_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getSchedulerAction_sp]) - apply (corresKsimp corres: getSchedulerAction_corres) - - apply (case_tac "action = resume_cur_thread"; clarsimp) - apply (corresKsimp corres: scAndTimer_corres) - subgoal by (fastforce intro: valid_sched_context_size_objsI - dest: schact_is_rct_ct_active_sc - simp: invs_def cur_sc_tcb_def sc_at_pred_n_def obj_at_def is_sc_obj_def - valid_state_def valid_sched_def) - - apply (case_tac "action = choose_new_thread") - apply (clarsimp simp: bind_assoc) - apply (rule corres_guard_imp) - apply (rule corres_split[OF corres_when]) - apply simp - apply (rule tcbSchedEnqueue_corres) - apply (rule corres_split[OF scheduleChooseNewThread_corres]) - apply (rule scAndTimer_corres) - apply (subst conj_assoc[symmetric]) - apply ((wpsimp wp: schedule_choose_new_thread_valid_state_cur_tcb - schedule_choose_new_thread_active_sc_tcb_at_cur_thread - | rule_tac f=cur_sc in hoare_lift_Pf2 - | rule_tac f=cur_thread in hoare_lift_Pf2)+)[1] - apply (wpsimp wp: scheduleChooseNewThread_invs') - apply (wpsimp | wps)+ - subgoal by (fastforce intro!: cur_sc_tcb_sc_at_cur_sc valid_sched_context_size_objsI - simp: schedulable_def2 pred_tcb_at_def obj_at_def get_tcb_def - invs_def cur_tcb_def is_tcb_def ct_ready_if_schedulable_def - vs_all_heap_simps valid_sched_def) - apply (fastforce simp: invs'_def isSchedulable_bool_def st_tcb_at'_def pred_map_simps - obj_at_simps cur_tcb'_def - elim!: opt_mapE) - - apply (case_tac action; clarsimp) - apply (rule corres_underlying_split[OF _ scAndTimer_corres, where r'=dc]) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply (subst bind_dummy_ret_val)+ - apply (subst conj_assoc[symmetric]) - apply (rule hoare_vcg_conj_lift_pre_fix) - apply (wpsimp wp: schedule_switch_thread_branch_valid_state_and_cur_tcb) - apply (intro hoare_vcg_conj_lift_pre_fix; - (solves \wpsimp simp: schedule_switch_thread_fastfail_def - wp: thread_get_inv hoare_drop_imps\)?) - apply (wpsimp wp: schedule_switch_thread_branch_sc_at_cur_sc) - apply fastforce - apply (wpsimp wp: schedule_switch_thread_branch_active_sc_tcb_at_cur_thread) - apply (fastforce simp: valid_sched_def valid_sched_action_def weak_valid_sched_action_def - vs_all_heap_simps) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply (rename_tac target) - apply (rule_tac Q'="\_ s. invs' s \ curThread = ksCurThread s \ st_tcb_at' runnable' target s" - in bind_wp_fwd) - apply wpsimp - apply (clarsimp simp: invs'_def isSchedulable_bool_def st_tcb_at'_def pred_map_simps - obj_at_simps cur_tcb'_def sch_act_wf_cases - elim!: opt_mapE - split: scheduler_action.splits) - apply (rule bind_wp_fwd_skip, solves wpsimp)+ - apply (wpsimp wp: scheduleChooseNewThread_invs' ksReadyQueuesL1Bitmap_return_wp - simp: isHighestPrio_def scheduleSwitchThreadFastfail_def) - - apply (rename_tac candidate) - apply (rule corres_split_skip[where r'="(=)"]) - apply wpsimp - apply (clarsimp simp: schedulable_def2 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 isSchedulable_bool_def st_tcb_at'_def pred_map_simps - obj_at_simps vs_all_heap_simps cur_tcb'_def - elim!: opt_mapE) - apply (corresKsimp corres: tcbSchedEnqueue_corres) - apply (fastforce dest: invs_cur - simp: cur_tcb_def) - - 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'="(=)"]) - apply (rule corres_guard_imp) - apply (rule threadGet_corres) - apply (clarsimp simp: tcb_relation_def) - apply (fastforce simp: valid_sched_def valid_sched_action_def weak_valid_sched_action_def - vs_all_heap_simps obj_at_def is_tcb_def) - apply (clarsimp simp: sch_act_wf_cases split: scheduler_action.splits) - - 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 - \ st_tcb_at' runnable' candidate s" - and r'="(=)" - in corres_underlying_split) - apply clarsimp - apply (rule corres_guard_imp) - apply (rule threadGet_corres) - apply (clarsimp simp: tcb_relation_def) - apply clarsimp - apply (clarsimp simp: cur_tcb'_def) - - 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 - in_queue_2_def) - - apply (find_goal \match conclusion in "\P\ f \Q\" for P f Q \ -\) - apply (wpsimp wp: threadGet_wp) - apply (clarsimp simp: cur_tcb'_def obj_at_simps sch_act_wf_cases - split: scheduler_action.splits) - - apply (rule corres_underlying_split[rotated 2, OF schedule_switch_thread_fastfail_inv - scheduleSwitchThreadFastfail_inv]) - apply (corresKsimp corres: scheduleSwitchThreadFastfail_corres) - apply (fastforce dest: invs_cur - simp: cur_tcb_def obj_at_def is_tcb_def state_relation_def cur_tcb'_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp curDomain_sp]) - apply (corresKsimp corres: curDomain_corres) - apply (clarsimp simp: isHighestPrio_def' split del: if_split) - - apply (rule corres_underlying_split[rotated 2, OF gets_sp gets_sp, where r'="(=)"]) - apply (corresKsimp corres: isHighestPrio_corres) - apply (clarsimp simp: is_highest_prio_def) - apply (subst bitmapL1_zero_ksReadyQueues) - apply (fastforce dest: invs_queues simp: valid_queues_def) - apply (fastforce dest: invs_queues simp: valid_queues_def) - apply (rule disj_cong) - apply (fastforce simp: ready_queues_relation_def dest!: state_relationD) - apply clarsimp - apply (subst lookupBitmapPriority_Max_eqI) - apply (fastforce dest: invs_queues simp: valid_queues_def) - apply (fastforce dest: invs_queues simp: valid_queues_def) - apply (subst bitmapL1_zero_ksReadyQueues) - apply (fastforce dest: invs_queues simp: valid_queues_def) - apply (fastforce dest: invs_queues simp: valid_queues_def) - apply (fastforce simp: ready_queues_relation_def dest!: state_relationD) - apply (clarsimp simp: ready_queues_relation_def dest!: state_relationD) - - apply (rule corres_if_split; (solves simp)?) - apply (rule corres_guard_imp) - apply (rule corres_split[OF tcbSchedEnqueue_corres]) - 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 (rule corres_if_split; (solves simp)?) - apply (rule corres_guard_imp) - apply (rule corres_split[OF tcbSchedAppend_corres]) - 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 (rule corres_guard_imp) - apply (rule corres_split[OF switchToThread_corres]) - apply clarsimp - apply (rule setSchedulerAction_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) - apply fastforce + apply (rule corres_split[OF curDomain_corres], simp) + apply (rule corres_split) + apply (rule ethreadget_corres[where r="(=)"]) + apply (clarsimp simp: etcb_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 action; simp) + apply (rule corres_split[OF rescheduleRequired_corres]) + apply (rule tcbSchedEnqueue_corres, simp) + apply (wp reschedule_required_valid_queues | strengthen valid_objs'_valid_tcbs')+ + apply (rule setSchedulerAction_corres, simp) + apply (wpsimp simp: if_apply_def2 + wp: hoare_drop_imp[where f="ethread_get a b" for a b])+ + apply (wp hoare_drop_imps)[1] + apply wp+ + apply (clarsimp simp: valid_sched_def invs_def valid_state_def cur_tcb_def st_tcb_at_tcb_at + valid_sched_action_def weak_valid_sched_action_def + tcb_at_is_etcb_at[OF st_tcb_at_tcb_at[rotated]]) + apply (fastforce simp: tcb_at_is_etcb_at) done end - -lemma schedContextDonate_valid_queues[wp]: - "\valid_queues and valid_objs'\ schedContextDonate scPtr tcbPtr \\_. valid_queues\" - (is "valid ?pre _ _") - apply (clarsimp simp: schedContextDonate_def) - apply (rule bind_wp[OF _ get_sc_sp']) - apply (rule_tac Q'="\_. ?pre" in bind_wp_fwd) - apply (rule hoare_when_cases, clarsimp) - apply (rule_tac Q'="\_. ?pre" in bind_wp_fwd) - apply (wpsimp wp: tcbSchedDequeue_valid_queues) - apply (fastforce intro: valid_objs'_maxDomain valid_objs'_maxPriority) - apply (rule bind_wp_fwd_skip) - apply (wpsimp wp: tcbReleaseRemove_valid_queues) - apply (rule bind_wp_fwd_skip) - apply (wpsimp wp: threadSet_valid_queues_new threadSet_valid_objs') - apply (clarsimp simp: obj_at'_def inQ_def valid_tcb'_def tcb_cte_cases_def) - apply (wpsimp wp: rescheduleRequired_valid_queues) - apply fastforce - apply (wpsimp wp: threadSet_valid_queues_new hoare_vcg_all_lift hoare_vcg_imp_lift') - apply (clarsimp simp: obj_at'_def inQ_def) - done - -lemma schedContextDonate_valid_queues'[wp]: - "schedContextDonate sc t \valid_queues'\" - apply (clarsimp simp: schedContextDonate_def) - apply (rule bind_wp_fwd_skip, solves wpsimp) - apply (rule bind_wp_fwd_skip) - apply (rule hoare_when_cases, simp) - apply ((rule bind_wp_fwd_skip - , wpsimp wp: threadSet_valid_queues' hoare_vcg_imp_lift' simp: inQ_def) - | wpsimp wp: threadSet_valid_queues' hoare_vcg_imp_lift' simp: inQ_def)+ - done - -crunch tcbSchedDequeue - for ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" - -crunch schedContextDonate - for vrq[wp]: valid_release_queue - and vrq'[wp]: valid_release_queue' - (wp: threadSet_vrq_inv threadSet_vrq'_inv simp: crunch_simps) - -crunch schedContextDonate - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" - (wp: threadSet_cap_to simp: tcb_cte_cases_def) - -crunch schedContextDonate - for valid_irq_handlers'[wp]: "\s. valid_irq_handlers' s" - and valid_mdb'[wp]: valid_mdb' - (ignore: threadSet - simp: comp_def valid_mdb'_def crunch_simps - wp: valid_irq_handlers_lift'' threadSet_ctes_of) - -crunch schedContextDonate - for sch_act_sane[wp]: sch_act_sane - and sch_act_simple[wp]: sch_act_simple - and sch_act_not[wp]: "sch_act_not t" - (wp: crunch_wps simp: crunch_simps rule: sch_act_sane_lift) - -crunch schedContextDonate - for no_0_obj'[wp]: no_0_obj' - and ksInterruptState[wp]: "\s. P (ksInterruptState 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 valid_irq_node'[wp]: "\s. valid_irq_node' (irq_node' s) s" - and valid_irq_states'[wp]: "\s. valid_irq_states' s" - and valid_machine_state'[wp]: "\s. valid_machine_state' s" - and ct_not_inQ[wp]: "ct_not_inQ" - and ct_idle_or_in_cur_domain'[wp]: "ct_idle_or_in_cur_domain'" - and valid_pde_mappings'[wp]: "\s. valid_pde_mappings' s" - and pspace_domain_valid[wp]: "\s. pspace_domain_valid s" - and irqs_masked'[wp]: "\s. irqs_masked' s" - and cur_tcb'[wp]: "cur_tcb'" - and urz[wp]: untyped_ranges_zero' - 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' - and pspace_bounded'[wp]: "pspace_bounded'" - (simp: comp_def tcb_cte_cases_def crunch_simps - wp: threadSet_not_inQ hoare_vcg_imp_lift' valid_irq_node_lift - setQueue_cur threadSet_ifunsafe'T threadSet_cur crunch_wps - cur_tcb_lift valid_dom_schedule'_lift valid_replies'_lift) - -lemma schedContextDonate_valid_pspace': - "\valid_pspace' and tcb_at' tcbPtr\ schedContextDonate scPtr tcbPtr \\_. valid_pspace'\" - by (wpsimp wp: schedContextDonate_valid_objs' simp: valid_pspace'_def) - -lemma schedContextDonate_if_live_then_nonz_cap': - "\\s. if_live_then_nonz_cap' s \ valid_objs' s \ - ex_nonz_cap_to' tcbPtr s \ ex_nonz_cap_to' scPtr s\ - schedContextDonate scPtr tcbPtr - \\_. if_live_then_nonz_cap'\" - unfolding schedContextDonate_def - by (wpsimp wp: threadSet_iflive'T setSchedContext_iflive' hoare_vcg_all_lift threadSet_cap_to' - simp: conj_ac cong: conj_cong | wp hoare_drop_imps | fastforce simp: tcb_cte_cases_def)+ - -(* `obj_at' (\x. scTCB x \ Some idle_thread_ptr) scPtr s` is - needed because sometimes sym_refs doesn't hold in its entirety here. *) -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\ - schedContextDonate scPtr tcbPtr - \\_. invs'\" - apply (simp only: invs'_def) - apply (rule_tac E="\s. sc_at' scPtr s" in hoare_strengthen_pre_via_assert_backward) - apply (simp only: schedContextDonate_def) - apply (rule bind_wp[OF _ get_sc_sp']) - apply (rule_tac hoare_weaken_pre[OF hoare_pre_cont]) - apply (clarsimp simp: obj_at'_def) - apply (wp schedContextDonate_valid_pspace' - schedContextDonate_valid_queues schedContextDonate_valid_queues' - schedContextDonate_if_live_then_nonz_cap') - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_sc) - apply (auto dest!: global'_sc_no_ex_cap - simp: ko_wp_at'_def obj_at'_def projectKO_eq projectKO_tcb - pred_tcb_at'_def) - done - -lemma tcbSchedDequeue_notksQ: - "tcbSchedDequeue t \\s. t' \ set(ksReadyQueues s p)\" - apply (simp add: tcbSchedDequeue_def) - apply (wp hoare_when_weak_wp) - apply (rule_tac Q'="\_ s. t' \ set(ksReadyQueues s p)" in hoare_post_imp) - apply wpsimp+ - done - -lemma tcbSchedDequeue_nonq: - "\\s. if t=t' then valid_queues s else t' \ set (ksReadyQueues s p)\ - tcbSchedDequeue t - \\_ s. t' \ set (ksReadyQueues s p)\" - unfolding tcbSchedDequeue_def - apply (wpsimp wp: threadGet_wp) - apply (case_tac p) - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def - split: if_splits) - done - -crunch tcbReleaseRemove - for not_queued[wp]: "\s. t' \ set (ksReadyQueues s p)" - (wp: crunch_wps simp: crunch_simps) - -lemma reprogram_timer_corres: - "corres dc \ \ - (modify (reprogram_timer_update (\_. True))) - (setReprogramTimer True)" - unfolding setReprogramTimer_def - by (rule corres_modify) (simp add: state_relation_def swp_def) - -lemma release_queue_corres: - "corres (=) \ \ (gets release_queue) getReleaseQueue" - by (simp add: getReleaseQueue_def state_relation_def release_queue_relation_def) - -lemma tcbReleaseRemove_corres: - "t = t' \ - corres dc (pspace_aligned and pspace_distinct and tcb_at t) \ - (tcb_release_remove t) (tcbReleaseRemove t')" - unfolding tcb_release_remove_def tcbReleaseRemove_def tcb_sched_dequeue_def setReleaseQueue_def - apply clarsimp - apply (rule stronger_corres_guard_imp) - apply (rule_tac r'="(=)" in corres_split) - apply (rule release_queue_corres) - apply (rule corres_split) - apply (rule corres_when) - apply clarsimp - apply (rule reprogram_timer_corres) - apply (rule corres_add_noop_lhs2) - apply (rule corres_split) - apply (rule corres_modify) - apply (auto simp: release_queue_relation_def state_relation_def swp_def)[1] - apply (rule threadSet_corres_noop; clarsimp simp: tcb_relation_def) - apply wp - apply wp - apply clarsimp - apply wp - apply (rule when_wp) - apply clarsimp - apply wp - apply wp - apply clarsimp - apply wpsimp - apply simp - apply metis - apply (fastforce simp: state_relation_def tcb_at_cross) - done - -lemma threadSet_valid_queues_no_state: - "\valid_queues and (\s. \p. t \ set (ksReadyQueues s p))\ - threadSet f t - \\_. valid_queues\" - apply (simp add: threadSet_def) - apply wp - apply (simp add: valid_queues_def valid_queues_no_bitmap_def' pred_tcb_at'_def) - apply (wp hoare_Ball_helper - hoare_vcg_all_lift - setObject_tcb_strongest)[1] - apply (wp getObject_tcb_wp) - apply (clarsimp simp: valid_queues_def valid_queues_no_bitmap_def' pred_tcb_at'_def) - apply (clarsimp simp: obj_at'_def) - done - -lemma threadSet_valid_queues'_no_state: - "(\tcb. tcbQueued tcb = tcbQueued (f tcb)) \ - \valid_queues' and (\s. \p. t \ set (ksReadyQueues s p))\ - threadSet f t - \\_. valid_queues'\" - apply (simp add: valid_queues'_def threadSet_def obj_at'_real_def - split del: if_split) - apply (simp only: imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (wp setObject_ko_wp_at | simp add: objBits_simps')+ - apply (wp getObject_tcb_wp updateObject_default_inv - | simp split del: if_split)+ - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs - objBits_simps addToQs_def - split del: if_split cong: if_cong) - apply (fastforce simp: projectKOs inQ_def split: if_split_asm) - done - -lemma setQueue_valid_tcbs'[wp]: - "setQueue qdom prio q \valid_tcbs'\" - unfolding valid_tcbs'_def - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') - done - -lemma removeFromBitmap_valid_tcbs'[wp]: - "removeFromBitmap tdom prio \valid_tcbs'\" - apply (wpsimp simp: valid_tcbs'_def bitmap_fun_defs) - done - -lemma tcbSchedDequeue_valid_tcbs'[wp]: - "tcbSchedDequeue tcbPtr \valid_tcbs'\" - apply (clarsimp simp: tcbSchedDequeue_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (clarsimp simp: when_def) - apply (rule bind_wp_fwd_skip, wpsimp)+ - apply (wpsimp wp: threadSet_valid_tcbs') - done - -lemma schedContextDonate_corres_helper: - "(case rv' of SwitchToThread x \ when (x = t \ t = cur) rescheduleRequired - | _ \ when (t = cur) rescheduleRequired) = - (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 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) - (valid_objs' and valid_queues and valid_queues' and - valid_release_queue and valid_release_queue') - (sched_context_donate scp thread) - (schedContextDonate scp thread)" - apply (simp add: test_reschedule_def get_sc_obj_ref_def set_tcb_obj_ref_thread_set - schedContextDonate_def sched_context_donate_def schedContextDonate_corres_helper) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split [OF get_sc_corres]) - apply (rule corres_split [OF corres_when2]) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_assert_opt_assume_l) - apply (rule corres_split_nor) - apply (rule_tac x="the (sc_tcb sc)" and x'="the (scTCB sca)" in lift_args_corres) - apply (rule tcbSchedDequeue_corres) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_split_nor) - apply (rule tcbReleaseRemove_corres) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_split_nor) - apply (rule_tac x="the (sc_tcb sc)" and x'="the (scTCB sca)" in lift_args_corres) - apply (rule threadset_corresT) - apply (clarsimp simp: tcb_relation_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def) - apply (clarsimp simp: sc_relation_def) - apply (rule corres_split_eqr) - apply (rule getCurThread_corres) - apply (rule_tac r'=sched_act_relation in corres_split) - apply (rule getSchedulerAction_corres) - apply (rule corres_when) - apply (case_tac rv; clarsimp simp: sched_act_relation_def sc_relation_def) - apply (rule rescheduleRequired_corres_weak) - apply wpsimp - apply wpsimp - apply wpsimp - apply wpsimp - apply (wpsimp wp: hoare_drop_imps) - apply (wpsimp wp: hoare_drop_imps - threadSet_valid_release_queue threadSet_valid_release_queue' - threadSet_valid_queues_no_state threadSet_valid_queues'_no_state) - apply (wpsimp | strengthen weak_valid_sched_action_strg)+ - apply (rule_tac Q'="\_. tcb_at' (the (scTCB sca)) and valid_tcbs' and - valid_queues and valid_queues' and - valid_release_queue and valid_release_queue' and - (\s. \d p. the (scTCB sca) \ set (ksReadyQueues s (d, p)))" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_release_queue'_def obj_at'_def) - apply (wpsimp wp: tcbReleaseRemove_valid_queues hoare_vcg_all_lift) - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') - apply (wpsimp wp: tcbSchedDequeue_valid_queues hoare_vcg_all_lift tcbSchedDequeue_nonq) - apply (rule corres_split - [OF update_sc_no_reply_stack_update_ko_at'_corres - [where f'="scTCB_update (\_. Some thread)"] - threadset_corresT]) - apply (clarsimp simp: sc_relation_def) - apply clarsimp - apply (clarsimp simp: objBits_def objBitsKO_def) - apply clarsimp - apply (clarsimp simp: tcb_relation_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def) - apply wpsimp - apply wpsimp - 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 (prop_tac "sc_at' scp s' \ tcb_at' thread s'") - apply (fastforce elim: sc_at_cross tcb_at_cross simp: state_relation_def) - apply clarsimp - apply (frule valid_objs'_valid_tcbs') - apply (rule valid_objsE', assumption) - apply (fastforce simp: obj_at'_def projectKO_eq projectKO_sc) - apply (clarsimp simp: valid_obj'_def valid_sched_context'_def obj_at'_def projectKOs) - apply (frule valid_objs'_valid_tcbs') - apply (fastforce simp: valid_obj'_def valid_tcb'_def) - done - end diff --git a/proof/refine/ARM/StateRelation.thy b/proof/refine/ARM/StateRelation.thy index e81f395e71..b03db17684 100644 --- a/proof/refine/ARM/StateRelation.thy +++ b/proof/refine/ARM/StateRelation.thy @@ -12,7 +12,7 @@ theory StateRelation imports InvariantUpdates_H begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition cte_map :: "cslot_ptr \ word32" where @@ -49,8 +49,6 @@ where Fault_H.UnknownSyscallException n" | "fault_map (ExceptionTypes_A.UserException x y) = Fault_H.UserException x y" -| "fault_map (ExceptionTypes_A.Timeout d) = - Fault_H.Timeout d" text \ @@ -108,12 +106,8 @@ where Structures_H.CNodeCap ref n (of_bl L) (length L))" | "cap_relation (Structures_A.ThreadCap ref) c = (c = Structures_H.ThreadCap ref)" -| "cap_relation (Structures_A.ReplyCap ref r) c = (c = - Structures_H.ReplyCap ref (AllowGrant \ r))" -| "cap_relation (Structures_A.SchedContextCap ref n) c = (c = - Structures_H.SchedContextCap ref (min_sched_context_bits + n))" -| "cap_relation (Structures_A.SchedControlCap) c = (c = - Structures_H.SchedControlCap)" +| "cap_relation (Structures_A.ReplyCap ref master r) c = (c = + Structures_H.ReplyCap ref master (AllowGrant \ r))" | "cap_relation (Structures_A.IRQControlCap) c = (c = Structures_H.IRQControlCap)" | "cap_relation (Structures_A.IRQHandlerCap irq) c = (c = @@ -143,7 +137,7 @@ where 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'" + \ ntfn_bound_tcb ntfn = ntfnBoundTCB ntfn'" definition ep_relation :: "Structures_A.endpoint \ Structures_H.endpoint \ bool" @@ -169,10 +163,10 @@ where = (ts' = Structures_H.Inactive)" | "thread_state_relation (Structures_A.IdleThreadState) ts' = (ts' = Structures_H.IdleThreadState)" -| "thread_state_relation (Structures_A.BlockedOnReply r) ts' - = (ts' = Structures_H.BlockedOnReply (Some r))" -| "thread_state_relation (Structures_A.BlockedOnReceive oref reply sp) ts' - = (ts' = Structures_H.BlockedOnReceive oref (receiver_can_grant sp) reply)" +| "thread_state_relation (Structures_A.BlockedOnReply) ts' + = (ts' = Structures_H.BlockedOnReply)" +| "thread_state_relation (Structures_A.BlockedOnReceive oref sp) ts' + = (ts' = Structures_H.BlockedOnReceive oref (receiver_can_grant sp))" | "thread_state_relation (Structures_A.BlockedOnSend oref sp) ts' = (ts' = Structures_H.BlockedOnSend oref (sender_badge sp) (sender_can_grant sp) (sender_can_grant_reply sp) (sender_is_call sp))" @@ -189,141 +183,18 @@ definition tcb_relation :: "Structures_A.tcb \ Structures_H.tcb \ bool" where "tcb_relation \ \tcb tcb'. - tcb_ipc_buffer tcb = tcbIPCBuffer tcb' + tcb_fault_handler tcb = to_bl (tcbFaultHandler tcb') + \ tcb_ipc_buffer tcb = tcbIPCBuffer tcb' \ arch_tcb_relation (tcb_arch tcb) (tcbArch tcb') \ thread_state_relation (tcb_state tcb) (tcbState tcb') \ fault_rel_optionation (tcb_fault tcb) (tcbFault tcb') \ cap_relation (tcb_ctable tcb) (cteCap (tcbCTable tcb')) \ cap_relation (tcb_vtable tcb) (cteCap (tcbVTable tcb')) - \ cap_relation (tcb_fault_handler tcb) (cteCap (tcbFaultHandler tcb')) - \ cap_relation (tcb_timeout_handler tcb) (cteCap (tcbTimeoutHandler tcb')) + \ cap_relation (tcb_reply tcb) (cteCap (tcbReply tcb')) + \ cap_relation (tcb_caller tcb) (cteCap (tcbCaller tcb')) \ cap_relation (tcb_ipcframe tcb) (cteCap (tcbIPCBufferFrame tcb')) \ tcb_bound_notification tcb = tcbBoundNotification tcb' - \ tcb_sched_context tcb = tcbSchedContext tcb' - \ tcb_yield_to tcb = tcbYieldTo tcb' - \ tcb_mcpriority tcb = tcbMCP tcb' - \ tcb_priority tcb = tcbPriority tcb' - \ tcb_domain tcb = tcbDomain tcb'" - -lemma sc_sporadic_flag_eq_schedContextSporadicFlag[simp]: - "sc_sporadic_flag = schedContextSporadicFlag" - by (simp add: sc_sporadic_flag_def schedContextSporadicFlag_def) - -lemma minRefills_eq_MIN_REFILLS[simp]: - "minRefills = MIN_REFILLS" - by (clarsimp simp: minRefills_def MIN_REFILLS_def) - -definition refill_map :: "Structures_H.refill \ Structures_A.refill" where - "refill_map refill \ \ r_time = rTime refill, r_amount = rAmount refill\" - - -(* Assumes count \ mx; start \ mx; mx \ length xs - Produces count elements from start, wrapping around to the beginning of the list at mx *) -definition wrap_slice :: "nat \ nat \ nat \ 'a list \ 'a list" where - "wrap_slice start count mx xs \ if start + count \ mx - then take count (drop start xs) - else take (mx - start) (drop start xs) @ take (start + count - mx) xs" - -(* Sanity check: *) -lemma "wrap_slice 1 3 4 [1::nat,2,3,4,5,6] = [2,3,4]" by eval -lemma "wrap_slice 3 3 4 [1::nat,2,3,4,5,6] = [4,1,2]" by eval - -lemma length_wrap_slice[simp]: - "\ count \ mx; start \ mx; mx \ length xs \ \ length (wrap_slice start count mx xs) = count" - by (simp add: wrap_slice_def) - -lemma wrap_slice_empty[simp]: - "start \ mx \ wrap_slice start 0 mx xs = []" - by (clarsimp simp: wrap_slice_def) - -lemma hd_wrap_slice: - "\0 < count; mx \ length list; start < mx\ \ hd (wrap_slice start count mx list) = list ! start" - by (auto simp: wrap_slice_def hd_drop_conv_nth) - -definition refills_map :: "nat \ nat \ nat \ refill list \ Structures_A.refill list" where - "refills_map start count mx \ map refill_map \ wrap_slice (min start mx) (min count mx) mx" - -(* This leaves those Haskell refills unconstrained that are not in the abstract sc_refills list. - This is intentional: for instance, refillPopHead will leave "garbage" behind in memory which - is not captured on the abstract side, and we can't demand that the Haskell side has empty - refills there. This should be fine, from concrete to abstract we still have a function. - *) -definition sc_relation :: - "Structures_A.sched_context \ nat \ Structures_H.sched_context \ bool" where - "sc_relation \ \sc n sc'. - sc_period sc = scPeriod sc' \ - sc_consumed sc = scConsumed sc' \ - sc_tcb sc = scTCB sc' \ - sc_ntfn sc = scNtfn sc' \ - sc_refills sc = refills_map (scRefillHead sc') (scRefillCount sc') - (scRefillMax sc') (scRefills sc') \ - n = scSize sc' \ - sc_refill_max sc = scRefillMax sc' \ - sc_badge sc = scBadge sc' \ - sc_sporadic sc = scSporadic sc' \ - sc_yield_from sc = scYieldFrom sc'" - -(* projection rewrite *) - -definition is_active_sc' where - "is_active_sc' p s' \ ((\sc'. 0 < scRefillMax sc') |< scs_of' s') p" - -lemma active_sc_at'_imp_is_active_sc': - "active_sc_at' scp s \ is_active_sc' scp s" - by (clarsimp simp: active_sc_at'_def is_active_sc'_def obj_at'_def opt_map_def projectKO_eq - opt_pred_def) - -lemma active_sc_at'_rewrite: - "active_sc_at' scp s = (is_active_sc' scp s \ sc_at' scp s)" - by (fastforce simp: active_sc_at'_def is_active_sc'_def obj_at'_def opt_map_def projectKO_eq - opt_pred_def) - -(* valid_refills' *) - -(* Most sched contexts should satisfy these conditions. These are the conditions we need for - the refill list circular buffer to make sense. In other words, these are the constraints - we expect for wrap_slice to give what we want. *) - -abbreviation sc_valid_refills' where - "sc_valid_refills' sc \ scRefillMax sc \ length (scRefills sc) \ scRefillHead sc < scRefillMax sc \ - scRefillCount sc \ scRefillMax sc \ 0 < scRefillCount sc" - -definition valid_refills' where - "valid_refills' sc_ptr s' \ (sc_valid_refills' |< scs_of' s') sc_ptr" - -lemma valid_refills'_nonzero_scRefillCount: - "valid_refills' scp s' \ ((\sc. 0 < scRefillCount sc) |< scs_of' s') scp" - by (clarsimp simp: valid_refills'_def opt_pred_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) - 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) - -lemma - valid_refills'_ksSchedulerAction_update[simp]: - "valid_refills' scp (ksSchedulerAction_update g s) = valid_refills' scp s" and - valid_refills'_ksReadyQueues_update[simp]: - "valid_refills' scp (ksReadyQueues_update f s) = valid_refills' scp s" and - valid_refills'_ksReadyQueuesL1Bitmap_update[simp]: - "valid_refills' scp (ksReadyQueuesL1Bitmap_update f' s) = valid_refills' scp s" and - valid_refills'_ksReadyQueuesL2Bitmap_update[simp]: - "valid_refills' scp (ksReadyQueuesL2Bitmap_update f'' s) = valid_refills' scp s" - by (clarsimp simp: valid_refills'_def)+ - -lemma maxReleaseTime_equiv: - "maxReleaseTime = MAX_RELEASE_TIME" - apply (clarsimp simp: maxReleaseTime_def MAX_RELEASE_TIME_def maxBound_max_word maxPeriodUs_def - usToTicks_def MAX_PERIOD_def) - done - -definition reply_relation :: "Structures_A.reply \ Structures_H.reply \ bool" where - "reply_relation \ \reply reply'. - reply_sc reply = replySC reply' \ reply_tcb reply = replyTCB reply'" + \ tcb_mcpriority tcb = tcbMCP tcb'" \ \ A pair of objects @{term "(obj, obj')"} should satisfy the following relation when, under further @@ -417,22 +288,6 @@ where | "aobj_relation_cuts (PageDirectory pd) x = (\y. (x + (ucast y << 2), pde_relation y)) ` UNIV" -abbreviation - sc_relation_cut :: "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" -where - "sc_relation_cut obj obj' \ - (case (obj, obj') of - (Structures_A.SchedContext sc n, KOSchedContext sc') \ sc_relation sc n sc' - | _ \ False)" - -abbreviation - reply_relation_cut :: "Structures_A.kernel_object \ Structures_H.kernel_object \ bool" -where - "reply_relation_cut obj obj' \ - (case (obj, obj') of - (Structures_A.Reply r, KOReply r') \ reply_relation r r' - | _ \ False)" - definition tcb_relation_cut :: "Structures_A.kernel_object \ kernel_object \ bool" where "tcb_relation_cut obj obj' \ case (obj, obj') of @@ -449,9 +304,6 @@ where | "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.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" @@ -460,9 +312,6 @@ lemma obj_relation_cuts_def2: (case ko of CNode sz cs \ if well_formed_cnode_n sz cs then {(cte_map (x, y), cte_relation y) | y. y \ dom cs} else {(x, \\)} - | Structures_A.SchedContext sc n \ - 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)} | ArchObj (PageTable pt) \ (\y. (x + (ucast y << 2), pte_relation y)) ` (UNIV :: word8 set) @@ -476,11 +325,8 @@ lemma obj_relation_cuts_def2: lemma obj_relation_cuts_def3: "obj_relation_cuts ko x = - (case a_type ko of + (case (a_type ko) of ACapTable n \ {(cte_map (x, y), cte_relation y) | y. length y = n} - | ASchedContext n \ - if valid_sched_context_size n then {(x, sc_relation_cut)} else {(x, \\)} - | AReply \ {(x, reply_relation_cut)} | ATCB \ {(x, tcb_relation_cut)} | AArch APageTable \ (\y. (x + (ucast y << 2), pte_relation y)) ` (UNIV :: word8 set) @@ -500,8 +346,6 @@ definition "is_other_obj_relation_type tp \ case tp of ACapTable n \ False - | ASchedContext n \ False - | AReply \ False | ATCB \ False | AArch APageTable \ False | AArch APageDirectory \ False @@ -514,13 +358,6 @@ lemma is_other_obj_relation_type_CapTable: "\ is_other_obj_relation_type (ACapTable n)" by (simp add: is_other_obj_relation_type_def) -lemma is_other_obj_relation_type_SchedContext: - "\ is_other_obj_relation_type (ASchedContext n)" - by (simp add: is_other_obj_relation_type_def) - -lemma is_other_obj_relation_type_Reply: - "\ is_other_obj_relation_type AReply" - lemma is_other_obj_relation_type_TCB: "\ is_other_obj_relation_type ATCB" by (simp add: is_other_obj_relation_type_def) @@ -552,27 +389,21 @@ where (\x \ dom ab. \(y, P) \ obj_relation_cuts (the (ab x)) x. P (the (ab x)) (the (con y)))" -definition - sc_replies_relation_2 :: - "(obj_ref \ obj_ref list) \ (obj_ref \ obj_ref) \ (obj_ref \ obj_ref) \ bool" where - "sc_replies_relation_2 sc_repls scRepl replPrevs \ - \p replies. sc_repls p = Some replies \ heap_ls replPrevs (scRepl p) replies" - -abbreviation sc_replies_relation :: "det_state \ kernel_state \ bool" where - "sc_replies_relation s s' \ - sc_replies_relation_2 (sc_replies_of s) (scReplies_of s') (replyPrevs_of s')" - -lemmas sc_replies_relation_def = sc_replies_relation_2_def +definition etcb_relation :: "etcb \ Structures_H.tcb \ bool" +where + "etcb_relation \ \etcb tcb'. + tcb_priority etcb = tcbPriority tcb' + \ tcb_time_slice etcb = tcbTimeSlice tcb' + \ tcb_domain etcb = tcbDomain tcb'" -abbreviation sc_replies_relation_obj :: - "Structures_A.kernel_object \ kernel_object \ (obj_ref \ obj_ref) \ bool" where - "sc_replies_relation_obj obj obj' nexts \ - case (obj, obj') of - (Structures_A.SchedContext sc _, KOSchedContext sc') \ - heap_ls nexts (scReply sc') (sc_replies sc)" +definition + ekheap_relation :: "(obj_ref \ etcb option) \ (word32 \ Structures_H.kernel_object) \ bool" +where + "ekheap_relation ab con \ + \x \ dom ab. \tcb'. con x = Some (KOTCB tcb') \ etcb_relation (the (ab x)) tcb'" primrec - sched_act_relation :: "Structures_A.scheduler_action \ Structures_H.scheduler_action \ bool" + sched_act_relation :: "Deterministic_A.scheduler_action \ Structures_H.scheduler_action \ bool" where "sched_act_relation resume_cur_thread a' = (a' = ResumeCurrentThread)" | "sched_act_relation choose_new_thread a' = (a' = ChooseNewThread)" | @@ -628,11 +459,6 @@ abbreviation ready_queues_relation :: "det_state \ kernel_state \ KernelStateData_H.release_queue \ bool" -where - "release_queue_relation qs qs' \ (qs = qs')" - definition ghost_relation :: "Structures_A.kheap \ (word32 \ vmpage_size) \ (word32 \ nat) \ bool" where @@ -699,17 +525,12 @@ where "rights_mask_map \ \rs. CapRights (AllowWrite \ rs) (AllowRead \ rs) (AllowGrant \ rs) (AllowGrantReply \ rs)" + lemma obj_relation_cutsE: "\ (y, P) \ obj_relation_cuts ko x; P ko ko'; \sz cs z cap cte. \ ko = CNode sz cs; well_formed_cnode_n sz cs; y = cte_map (x, z); ko' = KOCTE cte; cs z = Some cap; cap_relation cap (cteCap cte) \ \ R; - \sc n sc'. \ y = x; ko = Structures_A.SchedContext sc n; valid_sched_context_size n; - ko' = KOSchedContext sc'; sc_relation sc n sc' \ - \ R; - \reply reply'. \ y = x; ko = Structures_A.Reply reply; - ko' = KOReply reply'; reply_relation reply reply' \ - \ R; \tcb tcb'. \ y = x; ko = TCB tcb; ko' = KOTCB tcb'; tcb_relation tcb tcb' \ \ R; \pt (z :: word8) pte'. \ ko = ArchObj (PageTable pt); y = x + (ucast z << 2); @@ -725,10 +546,10 @@ lemma obj_relation_cutsE: apply (simp add: obj_relation_cuts_def2 is_other_obj_relation_type_def tcb_relation_cut_def a_type_def split: Structures_A.kernel_object.split_asm if_split_asm - ARM_A.arch_kernel_obj.split_asm) - by (clarsimp split: if_splits kernel_object.split_asm, - clarsimp simp: cte_relation_def pte_relation_def pde_relation_def - reply_relation_def sc_relation_def)+ + ARM_A.arch_kernel_obj.split_asm kernel_object.splits) + apply ((clarsimp split: if_splits, + force simp: cte_relation_def pte_relation_def pde_relation_def)+)[5] + done lemma eq_trans_helper: "\ x = y; P y = Q \ \ P x = Q" @@ -801,10 +622,9 @@ definition where "state_relation \ {(s, s'). pspace_relation (kheap s) (ksPSpace s') - \ sc_replies_relation s s' + \ ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ ready_queues_relation s s' - \ release_queue_relation (release_queue s) (ksReleaseQueue s') \ ghost_relation (kheap s) (gsUserPages s') (gsCNodes s') \ cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \ cdt_list_relation (cdt_list s) (cdt s) (ctes_of s') @@ -813,18 +633,12 @@ where \ interrupt_state_relation (interrupt_irq_node s) (interrupt_states s) (ksInterruptState s') \ (cur_thread s = ksCurThread s') \ (idle_thread s = ksIdleThread s') - \ (idle_sc_ptr = ksIdleSC s') \ (machine_state s = ksMachineState s') \ (work_units_completed s = ksWorkUnitsCompleted s') \ (domain_index s = ksDomScheduleIdx s') \ (domain_list s = ksDomSchedule s') \ (cur_domain s = ksCurDomain s') - \ (domain_time s = ksDomainTime s') - \ (consumed_time s = ksConsumedTime s') - \ (cur_time s = ksCurTime s') - \ (cur_sc s = ksCurSc s') - \ (reprogram_timer s = ksReprogramTimer s')}" - + \ (domain_time s = ksDomainTime s')}" text \Rules for using states in the relation.\ @@ -840,13 +654,9 @@ lemma state_relation_pspace_relation[elim!]: "(s,s') \ state_relation \ pspace_relation (kheap s) (ksPSpace s')" by (simp add: state_relation_def) -lemma state_relation_release_queue_relation: - "(s,s') \ state_relation \ release_queue_relation (release_queue s) (ksReleaseQueue 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 +lemma state_relation_ekheap_relation[elim!]: + "(s,s') \ state_relation \ ekheap_relation (ekheap s) (ksPSpace s')" + by (simp add: state_relation_def) lemma state_relation_sched_act_relation[elim!]: "(s,s') \ state_relation \ sched_act_relation (scheduler_action s) (ksSchedulerAction s')" @@ -863,10 +673,9 @@ lemma state_relation_idle_thread[elim!]: lemma state_relationD: assumes sr: "(s, s') \ state_relation" shows "pspace_relation (kheap s) (ksPSpace s') \ - sc_replies_relation s s' \ + ekheap_relation (ekheap s) (ksPSpace s') \ sched_act_relation (scheduler_action s) (ksSchedulerAction s') \ ready_queues_relation s s' \ - release_queue_relation (release_queue s) (ksReleaseQueue s') \ ghost_relation (kheap s) (gsUserPages s') (gsCNodes s') \ cdt_relation (swp cte_at s) (cdt s) (ctes_of s') \ cdt_list_relation (cdt_list s) (cdt s) (ctes_of s') \ @@ -875,26 +684,20 @@ lemma state_relationD: interrupt_state_relation (interrupt_irq_node s) (interrupt_states s) (ksInterruptState s') \ cur_thread s = ksCurThread s' \ idle_thread s = ksIdleThread s' \ - idle_sc_ptr = ksIdleSC s' \ machine_state s = ksMachineState s' \ work_units_completed s = ksWorkUnitsCompleted s' \ domain_index s = ksDomScheduleIdx s' \ domain_list s = ksDomSchedule s' \ cur_domain s = ksCurDomain s' \ - domain_time s = ksDomainTime s' \ - consumed_time s = ksConsumedTime s' \ - cur_time s = ksCurTime s' \ - cur_sc s = ksCurSc s' \ - reprogram_timer s = ksReprogramTimer s'" + domain_time s = ksDomainTime s'" using sr unfolding state_relation_def by simp lemma state_relationE [elim?]: assumes sr: "(s, s') \ state_relation" and rl: "\pspace_relation (kheap s) (ksPSpace s'); - sc_replies_relation s s'; + ekheap_relation (ekheap s) (ksPSpace s'); sched_act_relation (scheduler_action s) (ksSchedulerAction s'); ready_queues_relation s s'; - release_queue_relation (release_queue s) (ksReleaseQueue s'); ghost_relation (kheap s) (gsUserPages s') (gsCNodes 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'); @@ -908,11 +711,7 @@ lemma state_relationE [elim?]: domain_index s = ksDomScheduleIdx s'; domain_list s = ksDomSchedule s'; cur_domain s = ksCurDomain s'; - domain_time s = ksDomainTime s'; - consumed_time s = ksConsumedTime s'; - cur_time s = ksCurTime s'; - cur_sc s = ksCurSc s'; - reprogram_timer s = ksReprogramTimer s' \ \ R" + domain_time s = ksDomainTime s' \ \ R" shows "R" using sr by (blast intro!: rl dest: state_relationD) @@ -923,7 +722,6 @@ lemmas isCap_defs = isThreadCap_def isCNodeCap_def isNotificationCap_def isEndpointCap_def isUntypedCap_def isNullCap_def isIRQHandlerCap_def isIRQControlCap_def isReplyCap_def - isSchedContextCap_def isSchedControlCap_def isPageCap_def isPageTableCap_def isPageDirectoryCap_def isASIDControlCap_def isASIDPoolCap_def isArchPageCap_def isDomainCap_def @@ -934,23 +732,10 @@ lemma isCNodeCap_cap_map [simp]: apply clarsimp+ done -lemma cap_rel_valid_fh: - "cap_relation a b \ valid_fault_handler a = isValidFaultHandler b" - apply (case_tac a - ; case_tac b - ; simp add: valid_fault_handler_def isValidFaultHandler_def) - apply (rule iffI - ; clarsimp simp: has_handler_rights_def split: bool.split_asm) - done - lemma sts_rel_idle : "thread_state_relation st IdleThreadState = (st = Structures_A.IdleThreadState)" by (cases st, auto) -lemma sts_rel_runnable : - "\thread_state_relation st st'; runnable st\ \ runnable' st'" - by (cases st, auto) - lemma pspace_relation_absD: "\ ab x = Some y; pspace_relation ab con \ \ \(x', P) \ obj_relation_cuts y x. \z. con x' = Some z \ P y z" @@ -965,32 +750,10 @@ lemma pspace_relation_absD: apply (simp add: image_def rev_bexI) done -lemma pspace_relation_None: - "\pspace_relation p p'; p' ptr = None \ \ p ptr = None" - apply (rule not_Some_eq[THEN iffD1, OF allI, OF notI]) - apply (drule(1) pspace_relation_absD) - apply (case_tac y; clarsimp simp: cte_map_def of_bl_def well_formed_cnode_n_def split: if_splits) - subgoal for n - apply (drule spec[of _ ptr]) - apply (drule spec) - apply clarsimp - apply (drule spec[of _ "replicate n False"]) - apply (drule mp[OF _ refl]) - apply (drule mp) - subgoal premises by (induct n; simp) - apply clarsimp - done - subgoal for x - apply (cases x; clarsimp) - apply ((drule spec[of _ 0], fastforce)+)[2] - apply (drule spec[of _ ptr]) - apply (drule spec) - apply clarsimp - apply (drule mp[OF _ refl]) - apply (drule spec[of _ 0]) - subgoal for _ sz by (cases sz; simp add: pageBits_def) - done - done +lemma ekheap_relation_absD: + "\ ab x = Some y; ekheap_relation ab con \ + \ \tcb'. con x = Some (KOTCB tcb') \ etcb_relation y tcb'" + by (force simp add: ekheap_relation_def) lemma in_related_pspace_dom: "\ s' x = Some y; pspace_relation s s' \ \ x \ pspace_dom s" @@ -1019,409 +782,5 @@ lemma ghost_relation_typ_at: apply (intro conjI impI iffI allI; force) done -(* more replyNext/replyPrev related lemmas *) - -lemma sc_replies_relation_replyNext_None: - "\sc_replies_relation s s'; reply_at rp s; replies_of' s' rp \ None; - \p'. replyPrevs_of s' p' \ Some rp; \p'. scReplies_of s' p' \ Some rp\ - \ sc_replies_relation s (s'\ksPSpace := (ksPSpace s')(rp \ KOReply r)\)" - apply (clarsimp simp: sc_replies_relation_def) - apply (rename_tac scp replies) - apply (drule_tac x=scp and y=replies in spec2) - apply simp - apply (clarsimp simp: projectKO_opts_defs obj_at'_def opt_map_red obj_at_def is_reply vs_all_heap_simps) - apply (rename_tac ko scp sc reply n) - apply (case_tac ko; clarsimp) - apply (intro conjI; clarsimp) - apply (rename_tac sc reply n) - apply (rule heap_path_heap_upd_not_in, simp) - apply clarsimp - apply (frule split_list) - apply (elim exE) - apply (simp only:) - apply (case_tac ys; simp only:) - apply (clarsimp simp: opt_map_red) - apply (prop_tac "\ls x. a # list = ls @ [x]") - using append_butlast_last_id apply fastforce - apply (elim exE conjE, simp only:) - apply (prop_tac "(ls @ [x]) @ rp # zs = ls @ x # rp # zs", simp) - apply (simp only:) - apply (frule_tac z=x in heap_path_non_nil_lookup_next) - apply (clarsimp simp: opt_map_red) - done - -lemma sc_replies_relation_scReplies_of: - "\sc_replies_relation s s'; sc_at sc_ptr s; bound (scs_of' s' sc_ptr)\ - \ (sc_replies_of s |> hd_opt) sc_ptr = scReplies_of s' sc_ptr" - by (fastforce simp: sc_replies_relation_def sc_replies_of_scs_def scs_of_kh_def map_project_def - hd_opt_def obj_at_def is_sc_obj_def opt_map_def - split: option.splits Structures_A.kernel_object.splits list.splits) - -lemma sc_replies_prevs_walk: - "\ sc_replies_relation s s'; - ksPSpace s' p = Some (KOSchedContext sc'); kheap s p = Some (kernel_object.SchedContext sc n) \ - \ heap_walk (replyPrevs_of s') (scReply sc') [] = sc_replies sc" - unfolding sc_replies_relation_def - apply (erule_tac x=p in allE) - apply (erule_tac x="sc_replies sc" in allE) - apply (clarsimp simp: sc_replies.all_simps) - apply (rule heap_ls_is_walk) - apply (subgoal_tac "scReplies_of s' p = scReply sc'", simp) - apply (clarsimp simp: opt_map_def projectKO_opt_sc) - done - -lemma sc_replies_relation_prevs_list: - "\ sc_replies_relation s s'; - kheap s x = Some (kernel_object.SchedContext sc n); - ksPSpace s' x = Some (KOSchedContext sc')\ - \ heap_ls (replyPrevs_of s') (scReply sc') (sc_replies sc)" - apply (clarsimp simp: sc_replies_relation_def sc_replies_of_scs_def scs_of_kh_def map_project_def) - apply (drule_tac x=x and y="sc_replies sc" in spec2) - apply (clarsimp simp: opt_map_def projectKO_opt_sc split: option.splits) - done - -lemma list_refs_of_replies'_reftype[simp]: - "(p, reftype) \ list_refs_of_replies' s' p' \ reftype \ {ReplyPrev, ReplyNext}" - by (clarsimp simp: list_refs_of_replies'_def list_refs_of_reply'_def get_refs_def2 - elim!: opt_mapE - split: option.split_asm) - -lemma replyNext_replyNexts_of_opt_map: - "\ksPSpace s' p = Some (KOReply reply); replyNext reply = Some (Next p')\ - \ (replyNexts_of s' |> f s') p = f s' p'" - by (clarsimp simp: opt_map_red projectKO_opt_reply split: option.split) - -lemma replyPrevs_of_refs: - "replyPrevs_of s' p = Some p' \ (p', ReplyPrev) \ list_refs_of_replies' s' p" - by (fastforce simp: map_set_def list_refs_of_reply'_def opt_map_def get_refs_def - split: option.splits) - -lemma replyNexts_of_refs: - "replyNexts_of s' p = Some p' \ (p', ReplyNext) \ list_refs_of_replies' s' p" - by (fastforce simp: map_set_def list_refs_of_reply'_def opt_map_def get_refs_def - split: option.splits) - -lemma sym_replies_prev_then_next_id_p: - "\sym_refs (list_refs_of_replies' s'); replyPrevs_of s' p = Some p'\ - \ (replyPrevs_of s' |> replyNexts_of s') p = Some p" - apply (clarsimp simp: replyPrevs_of_refs replyNexts_of_refs opt_map_red) - by (drule (1) sym_refsD[rotated], simp) - -lemma sym_replies_next_then_prev_id_p: - "\sym_refs (list_refs_of_replies' s'); replyNexts_of s' p = Some p'\ - \ (replyNexts_of s' |> replyPrevs_of s') p = Some p" - supply opt_map_red[simp] - apply (clarsimp simp: replyPrevs_of_refs replyNexts_of_refs) - by (drule (1) sym_refsD[rotated], simp) - -(* Some results related to the size of scheduling contexts *) - -lemma sc_const_eq: - "refillSizeBytes = (refill_size_bytes::nat)" - "schedContextStructSize = sizeof_sched_context_t" - "minSchedContextBits = min_sched_context_bits" - by (auto simp: refillSizeBytes_def refill_size_bytes_def minSchedContextBits_def - wordSize_def wordBits_def' word_size_def - sizeof_sched_context_t_def min_sched_context_bits_def schedContextStructSize_def) - -lemma max_num_refills_eq_refillAbsoluteMax': - "max_num_refills = refillAbsoluteMax'" - by (rule ext) - (simp add: max_num_refills_def refillAbsoluteMax'_def shiftL_nat sc_const_eq) - -lemma maxUntyped_eq: - "untyped_max_bits = maxUntypedSizeBits" - by (simp add: untyped_max_bits_def maxUntypedSizeBits_def) - -lemmas sc_const_conc = sc_const_eq[symmetric] max_num_refills_eq_refillAbsoluteMax' maxUntyped_eq - -lemma refillAbsoluteMax'_mono: - fixes x y - assumes "minSchedContextBits \ x" - and "x \ y" - shows "refillAbsoluteMax' x \ refillAbsoluteMax' y" -proof - - show ?thesis - unfolding refillAbsoluteMax'_def - using assms - by (simp add: diff_le_mono div_le_mono shiftL_nat) -qed - -lemmas scBits_simps = refillAbsoluteMax_def sc_size_bounds_def sc_const_conc - -lemma minSchedContextBits_check: - "minSchedContextBits = (LEAST n. schedContextStructSize + MIN_REFILLS * refillSizeBytes \ 2 ^ n)" -proof - - note simps = minSchedContextBits_def sc_const_eq(2) sizeof_sched_context_t_def word_size_def - MIN_REFILLS_def refillSizeBytes_def - show ?thesis - apply (rule sym) - apply (rule Least_equality) - apply (clarsimp simp: simps) - apply (rename_tac n) - apply (rule ccontr) - apply (simp add: not_le) - apply (prop_tac "2 ^ n \ 2 ^ (minSchedContextBits - 1)") - apply (fastforce intro: power_increasing_iff[THEN iffD2]) - using less_le_trans - by (fastforce simp: simps) -qed - -lemma minSchedContextBits_rel: - "schedContextStructSize + MIN_REFILLS * refillSizeBytes \ 2 ^ minSchedContextBits" - apply (simp add: minSchedContextBits_check) - by (meson self_le_ge2_pow order_refl wellorder_Least_lemma(1)) - -lemma refillAbsoluteMax'_greatest: - assumes "schedContextStructSize \ 2 ^ n" - shows "refillAbsoluteMax' n = (GREATEST r. schedContextStructSize + r * refillSizeBytes \ 2 ^ n)" - apply (simp flip: max_num_refills_eq_refillAbsoluteMax' - add: max_num_refills_def scBits_simps(4) scBits_simps(3)) - apply (rule sym) - apply (rule Greatest_equality) - apply (metis assms le_diff_conv2 le_imp_diff_is_add div_mult_le le_add1 diff_add_inverse) - apply (rename_tac r) - apply (prop_tac "r * refillSizeBytes \ 2 ^ n - schedContextStructSize") - apply linarith - apply (drule_tac k=refillSizeBytes in div_le_mono) - by (simp add: refillSizeBytes_def) - -lemma refillAbsoluteMax'_leq: - "schedContextStructSize \ 2 ^ n \ - schedContextStructSize + refillAbsoluteMax' n * refillSizeBytes \ 2 ^ n" - apply (frule refillAbsoluteMax'_greatest) - apply (simp add: refillSizeBytes_def) - apply (rule_tac b="2 ^ n" in GreatestI_ex_nat) - apply presburger - by fastforce - -lemma schedContextStructSize_minSchedContextBits: - "schedContextStructSize \ 2 ^ minSchedContextBits" - apply (insert minSchedContextBits_check) - by (metis LeastI_ex add_leD1 le_refl self_le_ge2_pow) - -lemma MIN_REFILLS_refillAbsoluteMax'[simp]: - "minSchedContextBits \ us \ MIN_REFILLS \ refillAbsoluteMax' us" - apply (insert minSchedContextBits_rel) - apply (frule_tac b1=2 in power_increasing_iff[THEN iffD2, rotated]) - apply fastforce - apply (subst refillAbsoluteMax'_greatest) - apply (insert schedContextStructSize_minSchedContextBits) - apply (fastforce elim!: order_trans) - apply (rule_tac b="2 ^ us" in Greatest_le_nat) - apply (fastforce intro: order_trans) - apply (clarsimp simp: refillSizeBytes_def) - done - -lemma scBits_pos_power2: - assumes "minSchedContextBits + scSize sc < word_bits" - shows "(1::machine_word) < (2::machine_word) ^ (minSchedContextBits + scSize sc)" - apply (insert assms) - apply (subst word_less_nat_alt) - apply (clarsimp simp: minSchedContextBits_def) - by (auto simp: pow_mono_leq_imp_lt) - -lemma objBits_pos_power2[simp]: - assumes "objBits v < word_bits" - shows "(1::machine_word) < (2::machine_word) ^ objBits v" - unfolding objBits_simps' - apply (insert assms) - apply (case_tac "injectKO v"; simp) - by (simp add: pageBits_def archObjSize_def pteBits_def pdeBits_def objBits_simps scBits_pos_power2 - split: arch_kernel_object.split)+ - -lemma objBitsKO_no_overflow[simp, intro!]: - "objBitsKO ko < word_bits \ (1::machine_word) < (2::machine_word)^(objBitsKO ko)" - by (cases ko; simp add: objBits_simps' pageBits_def archObjSize_def pteBits_def pdeBits_def - scBits_pos_power2 - split: arch_kernel_object.splits) - -(* for handling refill buffer *) - -abbreviation replaceAt where - "replaceAt i xs new \ updateAt i xs (\_. new)" - -lemmas replaceAt_def = updateAt_def - -lemma length_updateAt[simp]: - "length (updateAt i xs f) = length xs" - apply (clarsimp simp: updateAt_def) - by (case_tac xs; simp) - -lemma wrap_slice_index: - "\count \ mx; start < mx; mx \ length xs; index < count\ - \ (wrap_slice start count mx xs) ! index - = (if start + index < mx - then (xs ! (start + index)) - else (xs ! (start + index - mx)))" - apply (clarsimp split: if_splits) - apply (intro conjI) - apply (clarsimp simp: wrap_slice_def) - apply (prop_tac "index < mx - start", linarith) - apply (prop_tac "(take (mx - start) (drop start xs) @ take (start + count - mx) xs) ! index - = (take (mx - start) (drop start xs)) ! index") - apply (simp add: nth_append) - apply fastforce - apply (clarsimp simp: wrap_slice_def) - apply (cases "index < mx - start") - apply linarith - apply (drule not_less[THEN iffD1])+ - apply (prop_tac "(take (mx - start) (drop start xs) @ take (start + count - mx) xs) ! index - = (take (start + count - mx) xs) ! (index - (mx - start))") - apply (prop_tac "mx - start \ index", linarith) - apply (simp add: nth_append) - using less_imp_le_nat nat_le_iff_add apply auto - done - -lemma wrap_slice_append: - "\Suc count \ mx; start < mx; mx \ length xs\ - \ wrap_slice start (Suc count) mx xs - = wrap_slice start count mx xs @ [if (start + count < mx) - then (xs ! (start + count)) - else (xs ! (start + count - mx))]" - apply (rule nth_equalityI) - apply simp - apply (rename_tac i) - apply (case_tac "i < count") - apply (prop_tac "(wrap_slice start count mx xs - @ [if start + count < mx - then xs ! (start + count) - else xs ! (start + count - mx)]) ! i - = (wrap_slice start count mx xs) ! i") - apply (metis length_wrap_slice Suc_leD less_imp_le_nat nth_append) - apply (simp add: wrap_slice_index) - apply (prop_tac "(wrap_slice start count mx xs - @ [if start + count < mx - then xs ! (start + count) - else xs ! (start + count - mx)]) ! i - = (if start + count < mx - then xs ! (start + count) - else xs ! (start + count - mx))") - apply (clarsimp simp: nth_append) - apply (simp add: wrap_slice_index) - apply (prop_tac "i = count", linarith) - apply simp - done - -lemma updateAt_index: - "\xs \ []; i < length xs; j < length xs\ - \ (updateAt i xs f) ! j = (if i = j then f (xs ! i) else (xs ! j))" - by (fastforce simp: updateAt_def null_def nth_append) - -lemma wrap_slice_updateAt_eq: - "\if start + count \ mx - then (i < start \ start + count \ i) - else (start + count - mx \ i \ i < start); - count \ mx; start < mx; mx \ length xs; xs \ []; i < mx\ - \ wrap_slice start count mx xs = wrap_slice start count mx (updateAt i xs new)" - apply (rule nth_equalityI) - apply clarsimp - by (subst wrap_slice_index; clarsimp simp: updateAt_index split: if_split_asm)+ - -lemma take_updateAt_eq[simp]: - "n \ i \ take n (updateAt i ls f) = take n ls" - by (clarsimp simp: updateAt_def) - -lemma refills_tl_equal: - "\sc_relation sc n sc'; sc_valid_refills' sc'\ - \ refill_tl sc = refill_map (refillTl sc')" - apply (clarsimp simp: sc_relation_def refillTl_def refills_map_def) - apply (subst last_conv_nth) - apply (prop_tac "0 < scRefillCount sc'", blast) - apply (metis length_wrap_slice Nat.add_0_right le0 le_eq_less_or_eq less_add_eq_less - less_imp_le_nat map_is_Nil_conv not_gr0 plus_nat.add_0 wrap_slice_empty) - apply (subst nth_map) - apply fastforce - apply (subst wrap_slice_index; clarsimp simp: refillTailIndex_def) - done - -(* wrap_slice *) -lemma wrap_slice_start_0: - "\0 < count; mx \ length ls; count \ mx\ \ wrap_slice 0 count mx ls = take count ls" - by (clarsimp simp: wrap_slice_def) - -lemma butlast_wrap_slice: - "\0 < count; start < mx; count \ mx; mx \ length list\ \ - butlast (wrap_slice start count mx list) = wrap_slice start (count -1) mx list" - by (case_tac "start + count - 1 < mx"; clarsimp simp: wrap_slice_def butlast_conv_take add_ac) - -lemma last_wrap_slice: - "\0 < count; start < mx; count \ mx; mx \ length list\ - \ last (wrap_slice start count mx list) - = list ! (if start + count - 1 < mx then start + count - 1 else start + count - mx -1)" - by (fastforce simp: wrap_slice_def last_take last_append not_le) - -lemma tl_wrap_slice: - "\0 < count; mx \ length list; start < mx\ \ - tl (wrap_slice start count mx list) = wrap_slice (start + 1) (count - 1) mx list" - by (fastforce simp: wrap_slice_def tl_take tl_drop drop_Suc) - -lemma wrap_slice_max[simp]: - "wrap_slice start count start list = take count list" - by (clarsimp simp: wrap_slice_def) - -lemma length_refills_map[simp]: - "\ mx \ length list; count \ mx \ \ length (refills_map start count mx list) = count" - by (clarsimp simp: refills_map_def) - -lemma sc_valid_refills_scRefillCount: - "\sc_valid_refills sc; sc_relation sc n sc'\ \ 0 < scRefillCount sc'" - apply (clarsimp simp: valid_sched_context_def sc_relation_def) - apply (case_tac "scRefillCount sc'"; simp) - by (clarsimp simp: refills_map_def sc_valid_refills_def rr_valid_refills_def split: if_splits) - -lemma sc_refills_neq_zero_cross: - "\sc_relation sc n sc'; sc_refills sc \ []\ - \ refills_map (scRefillHead sc') (scRefillCount sc') (scRefillMax sc') (scRefills sc') \ []" - by (clarsimp simp: sc_relation_def) - -lemma refills_map_non_empty_pos_count: - "refills_map start count mx list \ [] \ 0 < count \ 0 < mx" - apply (clarsimp simp: refills_map_def refill_map_def wrap_slice_def split: if_split_asm) - by linarith - -lemma hd_refills_map: - "\refills_map start count mx list \ []; mx \ length list; start < mx\ - \ hd (refills_map start count mx list) = refill_map (list ! start)" - apply (frule refills_map_non_empty_pos_count) - apply (clarsimp simp: refills_map_def) - by (simp add: hd_map hd_wrap_slice) - -lemma refill_hd_relation: - "sc_relation sc n sc' \ sc_valid_refills' sc' \ refill_hd sc = refill_map (refillHd sc')" - apply (clarsimp simp: sc_relation_def refillHd_def refills_map_def valid_sched_context'_def hd_map) - apply (subst hd_map, clarsimp simp: wrap_slice_def) - apply (clarsimp simp: hd_wrap_slice) - done - -lemma refill_hd_relation2: - "\sc_relation sc n sc'; sc_refills sc \ []; valid_sched_context' sc' s'\ - \ rAmount (refillHd sc') = r_amount (refill_hd sc) - \ rTime (refillHd sc') = r_time (refill_hd sc)" - apply (frule refill_hd_relation) - apply (frule (1) sc_refills_neq_zero_cross[THEN refills_map_non_empty_pos_count]) - apply (simp add: valid_sched_context'_def) - apply (clarsimp simp: refill_map_def) - done - -lemma sc_refill_ready_relation: - "\sc_relation sc n sc'; sc_valid_refills' sc'\ \ - sc_refill_ready time sc = (rTime (refillHd sc') \ time + kernelWCETTicks)" - apply (frule (1) refill_hd_relation) - by (clarsimp simp: refill_ready_def kernelWCETTicks_def refill_map_def) - -lemma sc_refill_capacity_relation: - "\sc_relation sc n sc'; sc_valid_refills' sc'\ \ - sc_refill_capacity x sc = refillsCapacity x (scRefills sc') (scRefillHead sc')" - apply (frule (1) refill_hd_relation) - by (clarsimp simp: refillsCapacity_def refill_capacity_def refillHd_def refill_map_def) - -lemma sc_refill_sufficient_relation: - "\sc_relation sc n sc'; sc_valid_refills' sc'\ \ - sc_refill_sufficient x sc = sufficientRefills x (scRefills sc') (scRefillHead sc')" - apply (frule (1) sc_refill_capacity_relation[where x=x]) - by (clarsimp simp: sufficientRefills_def refill_sufficient_def minBudget_def MIN_BUDGET_def - kernelWCETTicks_def) - end end diff --git a/proof/refine/ARM/SubMonad_R.thy b/proof/refine/ARM/SubMonad_R.thy index 5692bc4060..a7ac1b8281 100644 --- a/proof/refine/ARM/SubMonad_R.thy +++ b/proof/refine/ARM/SubMonad_R.thy @@ -47,7 +47,7 @@ lemma doMachineOp_mapM_x: done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "asUser_fetch \ \t s. case (ksPSpace s t) of Some (KOTCB tcb) \ (atcbContextGet o tcbArch) tcb @@ -64,12 +64,12 @@ definition lemma threadGet_stateAssert_gets_asUser: "threadGet (atcbContextGet o tcbArch) t = do stateAssert (tcb_at' t) []; gets (asUser_fetch t) od" apply (rule is_stateAssert_gets [OF _ _ empty_fail_threadGet no_fail_threadGet]) - apply (clarsimp simp: threadGet_def liftM_def, wp, simp) - apply (simp add: threadGet_def liftM_def, wp getObject_tcb_at', - clarsimp simp: threadRead_tcb_at') - apply (wpsimp simp: threadGet_def) - apply (drule use_ovalid[OF ovalid_threadRead_sp], simp) - apply (clarsimp simp: obj_at'_def asUser_fetch_def projectKOs atcbContextGet_def o_def) + apply (clarsimp simp: threadGet_def liftM_def, wp) + apply (simp add: threadGet_def liftM_def, wp getObject_tcb_at') + apply (simp add: threadGet_def liftM_def, wp) + apply (rule hoare_strengthen_post, rule getObject_obj_at') + apply (simp add: objBits_simps')+ + apply (clarsimp simp: obj_at'_def asUser_fetch_def projectKOs atcbContextGet_def o_def)+ done lemma threadSet_modify_asUser: diff --git a/proof/refine/ARM/Syscall_R.thy b/proof/refine/ARM/Syscall_R.thy index d4a9721271..1b6188b32e 100644 --- a/proof/refine/ARM/Syscall_R.thy +++ b/proof/refine/ARM/Syscall_R.thy @@ -9,10 +9,10 @@ *) theory Syscall_R -imports Tcb_R Arch_R Interrupt_R SchedContextInv_R +imports Tcb_R Arch_R Interrupt_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* syscall has 5 sections: m_fault h_fault m_error h_error m_finalise @@ -88,16 +88,12 @@ where (x = InvokeEndpoint w w2 b c)" | "inv_relation (Invocations_A.InvokeNotification w w2) x = (x = InvokeNotification w w2)" -| "inv_relation (Invocations_A.InvokeReply w grant) x = - (x = InvokeReply w grant)" +| "inv_relation (Invocations_A.InvokeReply w ptr grant) x = + (x = InvokeReply w (cte_map ptr) grant)" | "inv_relation (Invocations_A.InvokeTCB i) x = (\i'. tcbinv_relation i i' \ x = InvokeTCB i')" | "inv_relation (Invocations_A.InvokeDomain tptr domain) x = (x = InvokeDomain tptr domain)" -| "inv_relation (Invocations_A.InvokeSchedContext sc_inv) x = - (\sc_inv'. sc_inv_rel sc_inv sc_inv' \ x = InvokeSchedContext sc_inv')" -| "inv_relation (Invocations_A.InvokeSchedControl sc_control_inv) x = - (\sc_inv'. sc_ctrl_inv_rel sc_control_inv sc_inv' \ x = InvokeSchedControl sc_inv')" | "inv_relation (Invocations_A.InvokeIRQControl i) x = (\i'. irq_control_inv_relation i i' \ x = InvokeIRQControl i')" | "inv_relation (Invocations_A.InvokeIRQHandler i) x = @@ -117,18 +113,18 @@ where primrec valid_invocation' :: "Invocations_H.invocation \ kernel_state \ bool" where - "valid_invocation' (InvokeUntyped i) = valid_untyped_inv' i" -| "valid_invocation' (InvokeEndpoint w w2 b c) = (ep_at' w and ex_nonz_cap_to' w)" -| "valid_invocation' (InvokeNotification w w2) = (ntfn_at' w and ex_nonz_cap_to' w)" -| "valid_invocation' (InvokeTCB i) = tcb_inv_wf' i" -| "valid_invocation' (InvokeDomain thread domain) = (tcb_at' thread and K (domain \ maxDomain))" -| "valid_invocation' (InvokeSchedContext i) = valid_sc_inv' i" -| "valid_invocation' (InvokeSchedControl i) = valid_sc_ctrl_inv' i" -| "valid_invocation' (InvokeReply reply grant) = reply_at' reply" -| "valid_invocation' (InvokeIRQControl i) = irq_control_inv_valid' i" -| "valid_invocation' (InvokeIRQHandler i) = irq_handler_inv_valid' i" -| "valid_invocation' (InvokeCNode i) = valid_cnode_inv' i" -| "valid_invocation' (InvokeArchObject i) = valid_arch_inv' i" + "valid_invocation' (Invocations_H.InvokeUntyped i) = valid_untyped_inv' i" +| "valid_invocation' (Invocations_H.InvokeEndpoint w w2 b c) = (ep_at' w and ex_nonz_cap_to' w)" +| "valid_invocation' (Invocations_H.InvokeNotification w w2) = (ntfn_at' w and ex_nonz_cap_to' w)" +| "valid_invocation' (Invocations_H.InvokeTCB i) = tcb_inv_wf' i" +| "valid_invocation' (Invocations_H.InvokeDomain thread domain) = + (tcb_at' thread and K (domain \ maxDomain))" +| "valid_invocation' (Invocations_H.InvokeReply thread slot grant) = + (tcb_at' thread and cte_wp_at' (\cte. \gr. cteCap cte = ReplyCap thread False gr) slot)" +| "valid_invocation' (Invocations_H.InvokeIRQControl i) = irq_control_inv_valid' i" +| "valid_invocation' (Invocations_H.InvokeIRQHandler i) = irq_handler_inv_valid' i" +| "valid_invocation' (Invocations_H.InvokeCNode i) = valid_cnode_inv' i" +| "valid_invocation' (Invocations_H.InvokeArchObject i) = valid_arch_inv' i" (* FIXME: move *) @@ -173,62 +169,54 @@ lemma decodeInvocation_corres: (invs and valid_sched and valid_list and valid_cap cap and cte_at slot and cte_wp_at ((=) cap) slot and (\s. \x\set excaps. s \ fst x \ cte_at (snd x) s) - and case_option \ in_user_frame buffer and (\s. length args < 2 ^ word_bits)) (invs' and valid_cap' cap' and cte_at' slot' and (\s. \x\set excaps'. s \' fst x \ cte_at' (snd x) s) - and case_option \ valid_ipc_buffer_ptr' buffer and (\s. vs_valid_duplicates' (ksPSpace s))) - (decode_invocation first_phase (mi_label mi) args cptr slot cap excaps buffer) - (RetypeDecls_H.decodeInvocation (msgLabel mi') args' cptr' slot' cap' excaps' first_phase buffer)" + (decode_invocation (mi_label mi) args cptr slot cap excaps) + (RetypeDecls_H.decodeInvocation (mi_label mi) args' cptr' slot' cap' excaps')" apply (rule corres_gen_asm) apply (unfold decode_invocation_def decodeInvocation_def) apply (case_tac cap, simp_all only: cap.simps) \ \dammit, simp_all messes things up, must handle cases manually\ \ \Null\ - apply (simp add: isCap_defs) - \ \Untyped\ - apply (simp add: isCap_defs Let_def o_def split del: if_split) + apply (simp add: isCap_defs) + \ \Untyped\ + apply (simp add: isCap_defs Let_def o_def split del: if_split) apply (rule corres_guard_imp, rule decodeUntypedInvocation_corres) - apply ((clarsimp simp:cte_wp_at_caps_of_state)+)[3] - \ \(Async)Endpoint\ - apply (simp add: isCap_defs returnOk_def) - apply (simp add: isCap_defs) - apply (clarsimp simp: returnOk_def neq_Nil_conv) - \ \ReplyCap\ - apply (simp add: isCap_defs Let_def returnOk_def) - \ \CNodeCap\ - apply (rename_tac word nat list) - apply (simp add: isCap_defs Let_def CanModify_def - split del: if_split cong: if_cong) - apply (clarsimp simp add: o_def) - apply (rule corres_guard_imp) - apply (rule_tac F="length list \ 32" in corres_gen_asm) + apply ((clarsimp simp:cte_wp_at_caps_of_state)+)[3] + \ \(Async)Endpoint\ + apply (simp add: isCap_defs returnOk_def) + apply (simp add: isCap_defs) + apply (clarsimp simp: returnOk_def neq_Nil_conv) + \ \ReplyCap\ + apply (simp add: isCap_defs Let_def returnOk_def) + \ \CNodeCap\ + apply (rename_tac word nat list) + apply (simp add: isCap_defs Let_def CanModify_def + split del: if_split cong: if_cong) + apply (clarsimp simp add: o_def) + apply (rule corres_guard_imp) + apply (rule_tac F="length list \ 32" in corres_gen_asm) apply (rule decodeCNodeInvocation_corres, simp+) - apply (simp add: valid_cap_def word_bits_def) - apply simp - \ \ThreadCap\ - apply (simp add: isCap_defs Let_def CanModify_def - split del: if_split cong: if_cong) - apply (clarsimp simp add: o_def) - apply (rule corres_guard_imp) + apply (simp add: valid_cap_def word_bits_def) + apply simp + \ \ThreadCap\ + apply (simp add: isCap_defs Let_def CanModify_def + split del: if_split cong: if_cong) + apply (clarsimp simp add: o_def) + apply (rule corres_guard_imp) apply (rule decodeTCBInvocation_corres, rule refl, - simp_all add: valid_cap_def valid_cap'_def)[3] - apply (simp add: split_def) - apply (rule list_all2_conj) - apply (simp add: list_all2_map2 list_all2_map1) - apply assumption - \ \DomainCap\ - apply (clarsimp simp: isCap_defs) - apply (rule corres_guard_imp) + simp_all add: valid_cap_def valid_cap'_def)[3] + apply (simp add: split_def) + apply (rule list_all2_conj) + apply (simp add: list_all2_map2 list_all2_map1) + apply assumption + \ \DomainCap\ + apply (simp add: isCap_defs) + apply (rule corres_guard_imp) apply (rule decodeDomainInvocation_corres) - apply (simp+)[4] - \ \SchedContextCap\ - apply (clarsimp simp: isCap_defs o_def) - apply (rule corres_guard_imp, erule decode_sc_inv_corres; clarsimp simp: valid_cap_def) - \ \SchedControlCap\ - apply (clarsimp simp: isCap_defs o_def) - apply (rule corres_guard_imp, rule decode_sc_ctrl_inv_corres; clarsimp) + apply (simp+)[4] \ \IRQControl\ apply (simp add: isCap_defs o_def) apply (rule corres_guard_imp, rule decodeIRQControlInvocation_corres, simp+)[1] @@ -244,6 +232,8 @@ lemma decodeInvocation_corres: apply (simp_all add: list_all2_map2 list_all2_map1)+ done +declare mapME_Nil [simp] + lemma hinv_corres_assist: "\ info' = message_info_map info \ \ corres (fr \ (\(p, cap, extracaps, buffer) (p', capa, extracapsa, buffera). @@ -295,8 +285,7 @@ lemma threadSet_tcbDomain_update_ct_not_inQ: apply (simp add: threadSet_def ct_not_inQ_def) apply (wp) apply (rule hoare_convert_imp [OF setObject_nosch]) - apply simp - apply (rule updateObject_default_inv) + apply (rule updateObject_tcb_inv) apply (wps setObject_ct_inv) apply (wp setObject_tcb_strongest getObject_tcb_wp)+ apply (case_tac "t = ksCurThread s") @@ -338,7 +327,7 @@ lemma threadSet_tcbDomain_update_sch_act_wf[wp]: apply (wp hoare_vcg_conj_lift) apply (simp add: threadSet_def) apply wp - apply (wps set_tcb'.ksSchedulerAction) + apply (wps setObject_sa_unchanged) 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 \ @@ -352,186 +341,217 @@ lemma threadSet_tcbDomain_update_sch_act_wf[wp]: lemma setDomain_corres: "corres dc - (valid_tcbs and pspace_aligned and pspace_distinct and weak_valid_sched_action - and active_scs_valid and tcb_at tptr) - (invs' and (\_. new_dom \ maxDomain)) - (set_domain tptr new_dom) - (setDomain tptr new_dom)" + (valid_etcbs and valid_sched and tcb_at tptr and pspace_aligned and pspace_distinct) + (invs' and sch_act_simple and tcb_at' tptr and (\s. new_dom \ maxDomain)) + (set_domain tptr new_dom) (setDomain tptr new_dom)" apply (rule corres_gen_asm2) apply (simp add: set_domain_def setDomain_def thread_set_domain_def) - apply (rule stronger_corres_guard_imp) + apply (rule corres_guard_imp) apply (rule corres_split[OF getCurThread_corres]) - apply (rule corres_split[OF tcbSchedDequeue_corres]) - apply (rule corres_split[OF threadset_corresT]) - apply (clarsimp simp: tcb_relation_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def) - apply (rule corres_split[OF isSchedulable_corres]) - apply (rule corres_split[OF corres_when[OF _ tcbSchedEnqueue_corres]], simp) - apply (rule corres_when[OF _ rescheduleRequired_corres], simp) - apply (wpsimp wp: hoare_drop_imp hoare_vcg_if_lift2 thread_set_valid_tcbs - thread_set_weak_valid_sched_action threadSet_valid_tcbs' - threadSet_vrq_inv threadSet_vrq'_inv threadSet_valid_queues_no_state - threadSet_valid_queues'_no_state)+ - apply (clarsimp cong: conj_cong) - apply (rule hoare_vcg_conj_lift, strengthen valid_tcb'_tcbDomain_update, wpsimp) - apply (wpsimp wp: tcbSchedDequeue_valid_queues tcbSchedDequeue_nonq hoare_vcg_all_lift) - apply wpsimp+ - apply (frule cross_relF[OF _ tcb_at'_cross_rel], fastforce) - apply (frule invs'_valid_tcbs', clarsimp) - apply (frule obj_at_ko_at', clarsimp) - apply (frule tcb_ko_at_valid_objs_valid_tcb', fastforce) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def valid_tcb'_def invs'_def) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split) + apply (rule ethread_set_corres; simp) + apply (clarsimp simp: etcb_relation_def) + apply (rule corres_split[OF isRunnable_corres]) + apply simp + apply (rule corres_split) + apply clarsimp + apply (rule corres_when[OF refl]) + apply (rule tcbSchedEnqueue_corres, simp) + apply (rule corres_when[OF refl]) + apply (rule rescheduleRequired_corres) + apply (wpsimp wp: hoare_drop_imps) + apply ((wpsimp wp: hoare_drop_imps | strengthen valid_objs'_valid_tcbs')+)[1] + apply (wpsimp wp: gts_wp) + apply wpsimp + apply ((wpsimp wp: hoare_vcg_imp_lift' ethread_set_not_queued_valid_queues hoare_vcg_all_lift + | strengthen valid_objs'_valid_tcbs' valid_queues_in_correct_ready_q + valid_queues_ready_qs_distinct)+)[1] + apply (rule_tac Q'="\_. valid_objs' and sym_heap_sched_pointers and valid_sched_pointers + and pspace_aligned' and pspace_distinct' + and (\s. sch_act_wf (ksSchedulerAction s) s) and tcb_at' tptr" + in hoare_strengthen_post[rotated]) + apply (fastforce simp: invs'_def valid_state'_def sch_act_wf_weak st_tcb_at'_def o_def) + apply (wpsimp wp: threadSet_valid_objs' threadSet_sched_pointers + threadSet_valid_sched_pointers)+ + apply (rule_tac Q'="\_ s. valid_queues s \ not_queued tptr s + \ pspace_aligned s \ pspace_distinct s \ valid_etcbs s + \ weak_valid_sched_action s" + in hoare_post_imp) + apply (fastforce simp: pred_tcb_at_def obj_at_def) + apply (wpsimp wp: tcb_dequeue_not_queued) + apply (rule_tac Q'="\_ s. invs' s \ obj_at' (Not \ tcbQueued) tptr s \ sch_act_simple s + \ tcb_at' tptr s" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def sch_act_simple_def) + apply (clarsimp simp: valid_tcb'_def obj_at'_def) + apply (drule (1) bspec) + apply (clarsimp simp: tcb_cte_cases_def cteSizeBits_def) + apply fastforce + apply (wp hoare_vcg_all_lift tcbSchedDequeue_not_queued)+ + apply clarsimp + apply (frule tcb_at_is_etcb_at) + apply simp+ + apply (auto elim: tcb_at_is_etcb_at valid_objs'_maxDomain valid_objs'_maxPriority pred_tcb'_weakenE + simp: valid_sched_def valid_sched_action_def) done lemma performInvocation_corres: "\ inv_relation i i'; call \ block \ \ corres (dc \ (=)) - (einvs and valid_machine_time and valid_invocation i + (einvs and valid_invocation i and schact_is_rct - and current_time_bounded and ct_active - and ct_released - and ct_not_in_release_q - and (\s. (\w w2 b c. i = Invocations_A.InvokeEndpoint w w2 b c) \ st_tcb_at simple (cur_thread s) s) - 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)) + and (\s. (\w w2 b c. i = Invocations_A.InvokeEndpoint w w2 b c) \ st_tcb_at simple (cur_thread s) s)) (invs' and sch_act_simple and valid_invocation' i' and ct_active' and (\s. vs_valid_duplicates' (ksPSpace s))) - (perform_invocation block call can_donate i) (performInvocation block call can_donate i')" + (perform_invocation block call i) (performInvocation block call i')" apply (simp add: performInvocation_def) - apply add_sym_refs apply (case_tac i) - - apply (clarsimp simp: o_def liftE_bindE) - apply (rule corres_stateAssertE_add_assertion) - apply (rule corres_guard_imp) - apply (rule corres_split_norE) - apply (rule corres_rel_imp, rule inv_untyped_corres) - apply simp - apply (case_tac x, simp_all)[1] - apply (rule corres_returnOkTT, simp) - apply wpsimp+ - apply (clarsimp simp: sym_refs_asrt_def) - - apply (clarsimp simp: liftE_bindE) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres]) - apply simp - apply (rule corres_split[OF sendIPC_corres]) - apply simp - apply (rule corres_trivial) - apply simp - apply wp+ - apply (clarsimp simp: invs_def valid_sched_def valid_state_def valid_pspace_def - fault_tcbs_valid_states_to_except_set schact_is_rct_sane - ct_in_state_def released_sc_tcb_at_def active_sc_tcb_at_def2) - - apply (intro conjI) - apply (fastforce elim!: st_tcb_ex_cap) - apply (clarsimp simp: pred_tcb_at_def obj_at_def) - apply simp + apply (clarsimp simp: o_def liftE_bindE) apply (rule corres_guard_imp) - apply (simp add: liftE_bindE) - apply (rule corres_split[OF sendSignal_corres]) - apply (rule corres_trivial) - apply (simp add: returnOk_def) - apply wpsimp+ + apply (rule corres_split_norE) + apply (rule corres_rel_imp, rule inv_untyped_corres) + apply simp + apply (case_tac x, simp_all)[1] + apply (rule corres_returnOkTT) + apply simp + apply wp+ + apply simp+ apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule corres_split_nor[OF doReplyTransfer_corres]) - apply (rule corres_trivial, simp) + apply (rule corres_split[OF getCurThread_corres]) + apply simp + apply (rule corres_split[OF sendIPC_corres]) + apply simp + apply (rule corres_trivial) + apply simp apply wp+ - apply (clarsimp simp: tcb_at_invs) - apply simp - apply (clarsimp simp: liftME_def) + apply (clarsimp simp: ct_in_state_def) + apply (fastforce elim: st_tcb_ex_cap) + apply (clarsimp simp: pred_conj_def invs'_def cur_tcb'_def simple_sane_strg + sch_act_simple_def) apply (rule corres_guard_imp) - apply (erule invokeTCB_corres) - apply (fastforce simp: current_time_bounded_def)+ - \ \domain cap\ - apply (clarsimp simp: invoke_domain_def) + apply (simp add: liftE_bindE) + apply (rule corres_split[OF sendSignal_corres]) + apply (rule corres_trivial) + apply (simp add: returnOk_def) + apply wp+ + apply (simp+)[2] + apply simp apply (rule corres_guard_imp) - apply (rule corres_split[OF setDomain_corres]) - apply (rule corres_trivial, simp) - apply (wp)+ - apply ((clarsimp | fastforce)+)[3] - \ \SchedContext\ + apply (rule corres_split_eqr[OF getCurThread_corres]) + apply (rule corres_split_nor[OF doReplyTransfer_corres']) + apply (rule corres_trivial, simp) + apply wp+ + apply (clarsimp simp: tcb_at_invs) + apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) + apply (erule cte_wp_at_weakenE, fastforce simp: is_reply_cap_to_def) + apply (clarsimp simp: tcb_at_invs') + apply (fastforce elim!: cte_wp_at_weakenE') + apply (clarsimp simp: liftME_def) apply (rule corres_guard_imp) - apply (rule corres_splitEE) - apply (simp) - apply (erule invokeSchedContext_corres) - apply (rule corres_trivial, simp add: returnOk_def) - apply (wpsimp+)[4] - \ \SchedControl\ - apply clarsimp + apply (erule invokeTCB_corres) + apply ((clarsimp dest!: schact_is_rct_simple)+)[2] + \ \domain cap\ + apply (clarsimp simp: invoke_domain_def) apply (rule corres_guard_imp) - apply (rule corres_splitEE) - apply (simp) - apply (erule invokeSchedControlConfigureFlags_corres) - apply (rule corres_trivial, simp add: returnOk_def) - apply (wpsimp+)[4] + apply (rule corres_split[OF setDomain_corres]) + apply (rule corres_trivial, simp) + apply (wp)+ + apply (fastforce+)[2] \ \CNodes\ apply clarsimp - apply (rule corres_stateAssertE_add_assertion) - apply (rule corres_guard_imp) - apply (rule corres_splitEE[OF invokeCNode_corres]) - apply assumption - apply (rule corres_trivial, simp add: returnOk_def) - apply wp+ - apply (clarsimp+)[2] - apply (clarsimp simp: sym_refs_asrt_def) + apply (rule corres_guard_imp) + apply (rule corres_splitEE[OF invokeCNode_corres]) + apply assumption + apply (rule corres_trivial, simp add: returnOk_def) + apply wp+ + apply ((clarsimp dest!: schact_is_rct_simple)+)[2] apply (clarsimp simp: liftME_def[symmetric] o_def dc_def[symmetric]) - apply (rule corres_guard_imp, rule performIRQControl_corres; fastforce) + apply (rule corres_guard_imp, rule performIRQControl_corres, simp+) apply (clarsimp simp: liftME_def[symmetric] o_def dc_def[symmetric]) - apply (rule corres_guard_imp, rule invokeIRQHandler_corres; fastforce) + apply (rule corres_guard_imp, rule invokeIRQHandler_corres, simp+) apply clarsimp apply (rule corres_guard_imp) apply (rule arch_performInvocation_corres, assumption) apply (clarsimp+)[2] done -crunch sendSignal, setDomain - for tcb_at'[wp]: "tcb_at' t" - and typ_at'[wp]: "\s. P (typ_at' T t s)" - (simp: crunch_simps wp: crunch_wps) +lemma sendSignal_tcb_at'[wp]: + "\tcb_at' t\ + sendSignal ntfnptr bdg + \\rv. tcb_at' t\" + apply (simp add: sendSignal_def + cong: list.case_cong Structures_H.notification.case_cong) + apply (wp ntfn'_cases_weak_wp list_cases_weak_wp hoare_drop_imps | wpc | simp)+ + done -crunch restart, bindNotification, performTransfer, invokeTCB, doReplyTransfer, - performIRQControl, InterruptDecls_H.invokeIRQHandler, sendIPC, - invokeSchedContext, invokeSchedControlConfigureFlags, handleFault +lemmas checkCap_inv_typ_at' + = checkCap_inv[where P="\s. P (typ_at' T p s)" for P T p] + +crunch restart, bindNotification, performTransfer for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - (simp: crunch_simps - wp: crunch_wps checkCap_inv hoare_vcg_all_lift - ignore: checkCapAt) -end +lemma invokeTCB_typ_at'[wp]: + "\\s. P (typ_at' T p s)\ + invokeTCB tinv + \\rv s. P (typ_at' T p s)\" + apply (cases tinv, + simp_all add: invokeTCB_def + getThreadBufferSlot_def locateSlot_conv + split del: if_split) + apply (simp only: cases_simp if_cancel simp_thms conj_comms pred_conj_def + Let_def split_def getThreadVSpaceRoot + | (simp split del: if_split cong: if_cong) + | (wp mapM_x_wp[where S=UNIV, simplified] + checkCap_inv_typ_at' + case_options_weak_wp)[1] + | wpcw)+ + done + +lemmas invokeTCB_typ_ats[wp] = typ_at_lifts [OF invokeTCB_typ_at'] -global_interpretation invokeTCB: typ_at_all_props' "invokeTCB i" - by typ_at_props' -global_interpretation doReplyTransfer: typ_at_all_props' "doReplyTransfer s r g" - by typ_at_props' -global_interpretation performIRQControl: typ_at_all_props' "performIRQControl i" - by typ_at_props' -sublocale Arch < arch_invokeIRQHandler: typ_at_all_props' "invokeIRQHandler i" - by typ_at_props' -global_interpretation invokeIRQHandler: typ_at_all_props' "InterruptDecls_H.invokeIRQHandler i" - by typ_at_props' -global_interpretation sendIPC: typ_at_all_props' "sendIPC bl call bdg cg cgr cd t' ep" - by typ_at_props' -global_interpretation invokeSchedContext: typ_at_all_props' "invokeSchedContext i" - by typ_at_props' -global_interpretation invokeSchedControlConfigureFlags: typ_at_all_props' "invokeSchedControlConfigureFlags i" - by typ_at_props' -global_interpretation handleFault: typ_at_all_props' "handleFault t ex" - by typ_at_props' +crunch doReplyTransfer + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: hoare_drop_imps) + +lemmas doReplyTransfer_typ_ats[wp] = typ_at_lifts [OF doReplyTransfer_typ_at'] + +crunch "performIRQControl" + for typ_at'[wp]: "\s. P (typ_at' T p s)" + +lemmas invokeIRQControl_typ_ats[wp] = + typ_at_lifts [OF performIRQControl_typ_at'] + +crunch InterruptDecls_H.invokeIRQHandler + for typ_at'[wp]: "\s. P (typ_at' T p s)" + +lemmas invokeIRQHandler_typ_ats[wp] = + typ_at_lifts [OF invokeIRQHandler_typ_at'] + +crunch setDomain + for tcb_at'[wp]: "tcb_at' tptr" + (simp: crunch_simps) lemma pinv_tcb'[wp]: "\invs' and st_tcb_at' active' tptr and valid_invocation' i and ct_active'\ - RetypeDecls_H.performInvocation block call can_donate i + RetypeDecls_H.performInvocation block call i \\rv. tcb_at' tptr\" - unfolding performInvocation_def - by (cases i; simp; wpsimp wp: invokeArch_tcb_at' stateAssertE_inv simp: pred_tcb_at') + apply (simp add: performInvocation_def) + apply (case_tac i, simp_all) + apply (wp invokeArch_tcb_at' | clarsimp simp: pred_tcb_at')+ + done + +lemma sts_cte_at[wp]: + "\cte_at' p\ setThreadState st t \\rv. cte_at' p\" + apply (simp add: setThreadState_def) + apply (wp|simp)+ + done + +crunch setThreadState + for obj_at_ntfn[wp]: "obj_at' (\ntfn. P (ntfnBoundTCB ntfn) (ntfnObj ntfn)) ntfnptr" + (wp: obj_at_setObject2 crunch_wps + simp: crunch_simps updateObject_default_def in_monad) lemma sts_mcpriority_tcb_at'[wp]: "\mcpriority_tcb_at' P t\ @@ -545,53 +565,49 @@ lemma sts_mcpriority_tcb_at'[wp]: | simp add: pred_tcb_at'_def)+ done -crunch setThreadState - for valid_ipc_buffer_ptr'[wp]: "valid_ipc_buffer_ptr' buf" - -context begin interpretation Arch . (*FIXME: arch_split*) - lemma sts_valid_inv'[wp]: - "setThreadState st t \valid_invocation' i\" - apply (case_tac i; simp) - apply (wpsimp wp: sts_valid_untyped_inv') - apply (wpsimp+)[4] - \\start InvokeTCB\ - apply (rename_tac tcbinvocation) - apply (case_tac tcbinvocation; simp) - apply (wpsimp wp: hoare_case_option_wp2 hoare_case_option_wp sts_mcpriority_tcb_at' - | clarsimp split: option.splits)+ - \\end InvokeTCB\ - \\start InvokeSchedContext\ - apply (rename_tac schedcontextinvocation) - apply (case_tac schedcontextinvocation; simp) - apply (wpsimp wp: hoare_case_option_wp) - apply (rename_tac bindCap, case_tac bindCap; wpsimp) - apply (rename_tac bindCap, case_tac bindCap; wpsimp) - apply wpsimp - apply ((wpsimp wp: hoare_case_option_wp| wps)+)[1] - \\end InvokeSchedContext\ - apply (rename_tac schedcontrolinvocation) - apply (case_tac schedcontrolinvocation; wpsimp wp: hoare_vcg_ex_lift) + "\valid_invocation' i\ setThreadState st t \\rv. valid_invocation' i\" + apply (case_tac i, simp_all add: sts_valid_untyped_inv' sts_valid_arch_inv') + apply (wp | simp)+ + defer apply (rename_tac cnode_invocation) - apply (case_tac cnode_invocation; wpsimp simp: cte_wp_at_ctes_of) + apply (case_tac cnode_invocation, simp_all add: cte_wp_at_ctes_of) + apply (wp | simp)+ apply (rename_tac irqcontrol_invocation) - apply (case_tac irqcontrol_invocation; simp) + apply (case_tac irqcontrol_invocation, simp_all) apply (rename_tac arch_irqhandler_issue) - apply (case_tac arch_irqhandler_issue; wpsimp simp: irq_issued'_def) - apply (wpsimp simp: irq_issued'_def) + apply (case_tac arch_irqhandler_issue) + apply (wp | simp add: irq_issued'_def)+ apply (rename_tac irqhandler_invocation) - apply (case_tac irqhandler_invocation; wpsimp wp: hoare_vcg_ex_lift simp: comp_def) - apply (wpsimp wp: sts_valid_arch_inv') + apply (case_tac irqhandler_invocation, simp_all) + apply (wp hoare_vcg_ex_lift ex_cte_cap_to'_pres | simp)+ + apply (rename_tac tcbinvocation) + apply (case_tac tcbinvocation, + simp_all add: setThreadState_tcb', + auto intro!: hoare_vcg_conj_lift hoare_vcg_disj_lift + simp only: imp_conv_disj simp_thms pred_conj_def, + auto intro!: hoare_vcg_prop + sts_cap_to' sts_cte_cap_to' + setThreadState_typ_ats + split: option.splits)[1] + apply (wp sts_bound_tcb_at' hoare_vcg_all_lift hoare_vcg_const_imp_lift)+ done -crunch decodeDomainInvocation, decodeSchedContextInvocation, decodeSchedControlInvocation +(* FIXME: move to TCB *) +crunch decodeDomainInvocation for inv[wp]: P (wp: crunch_wps simp: crunch_simps) lemma decode_inv_inv'[wp]: - "\P\ decodeInvocation label args cap_index slot cap excaps first_phase buffer \\rv. P\" - unfolding decodeInvocation_def Let_def - by (wpsimp split: capability.split_asm simp: isCap_defs) + "\P\ decodeInvocation label args cap_index slot cap excaps \\rv. P\" + apply (simp add: decodeInvocation_def Let_def + split del: if_split + cong: if_cong) + apply (rule hoare_pre) + apply (wp decodeTCBInvocation_inv | + simp only: o_def | + clarsimp split: capability.split_asm simp: isCap_defs)+ + done (* FIXME: move to TCB *) lemma dec_dom_inv_wf[wp]: @@ -615,7 +631,6 @@ lemma decode_inv_wf'[wp]: "\valid_cap' cap and invs' and sch_act_simple and cte_wp_at' ((=) cap \ cteCap) slot and real_cte_at' slot and (\s. \r\zobj_refs' cap. ex_nonz_cap_to' r s) - and case_option \ valid_ipc_buffer_ptr' buffer and (\s. \r\cte_refs' cap (irq_node' s). ex_cte_cap_to' r s) and (\s. \cap \ set excaps. \r\cte_refs' (fst cap) (irq_node' s). ex_cte_cap_to' r s) and (\s. \cap \ set excaps. \r\zobj_refs' (fst cap). ex_nonz_cap_to' r s) @@ -625,18 +640,16 @@ lemma decode_inv_wf'[wp]: and (\s. \x \ set excaps. ex_cte_cap_wp_to' isCNodeCap (snd x) s) and (\s. \x \ set excaps. cte_wp_at' (badge_derived' (fst x) \ cteCap) (snd x) s) and (\s. vs_valid_duplicates' (ksPSpace s))\ - decodeInvocation label args cap_index slot cap excaps first_phase buffer + decodeInvocation label args cap_index slot cap excaps \valid_invocation'\,-" apply (case_tac cap, simp_all add: decodeInvocation_def Let_def isCap_defs uncurry_def split_def split del: if_split cong: if_cong) apply ((rule hoare_pre, - ((wpsimp wp: decodeTCBInv_wf decodeSchedControlInvocation_wf - decodeSchedContextInvocation_wf - simp: o_def)+)[1], + ((wpsimp wp: decodeTCBInv_wf simp: o_def)+)[1], clarsimp simp: valid_cap'_def cte_wp_at_ctes_of) - | intro exI conjI | simp | drule sym)+ + | intro exI conjI | simp)+ done lemma ct_active_imp_simple'[elim!]: @@ -657,8 +670,16 @@ lemma active_ex_cap'[elim]: crunch handleFaultReply for it[wp]: "\s. P (ksIdleThread s)" +lemma handleFaultReply_invs[wp]: + "\invs' and tcb_at' t\ handleFaultReply x t label msg \\rv. invs'\" + apply (simp add: handleFaultReply_def) + apply (case_tac x, simp_all) + apply (wp | clarsimp simp: handleArchFaultReply_def + split: arch_fault.split)+ + done + crunch handleFaultReply - for sch_act_simple[wp]: sch_act_simple + for sch_act_simple[wp]: sch_act_simple (wp: crunch_wps) lemma transferCaps_non_null_cte_wp_at': @@ -680,6 +701,9 @@ proof - done qed +crunch setMessageInfo + for cte_wp_at'[wp]: "cte_wp_at' P p" + lemma copyMRs_cte_wp_at'[wp]: "\cte_wp_at' P ptr\ copyMRs sender sendBuf receiver recvBuf n \\_. cte_wp_at' P ptr\" unfolding copyMRs_def @@ -696,9 +720,17 @@ lemma doNormalTransfer_non_null_cte_wp_at': apply (wp transferCaps_non_null_cte_wp_at' | simp add:PUC)+ done -crunch doFaultTransfer, setMRs - for cte_wp_at'[wp]: "cte_wp_at' P ptr" - (wp: crunch_wps simp: zipWithM_x_mapM) +lemma setMRs_cte_wp_at'[wp]: + "\cte_wp_at' P ptr\ setMRs thread buffer messageData \\_. cte_wp_at' P ptr\" + by (simp add: setMRs_def zipWithM_x_mapM split_def, wp crunch_wps) + +lemma doFaultTransfer_cte_wp_at'[wp]: + "\cte_wp_at' P ptr\ + doFaultTransfer badge sender receiver receiverIPCBuffer + \\_. cte_wp_at' P ptr\" + unfolding doFaultTransfer_def + apply (wp | wpc | simp add: split_def)+ + done lemma doIPCTransfer_non_null_cte_wp_at': assumes PUC: "\cap. P cap \ \ isUntypedCap cap" @@ -738,77 +770,80 @@ lemma st_tcb_at'_eqD: lemma isReply_awaiting_reply': "isReply st = awaiting_reply' st" - by (case_tac st, (clarsimp simp add: isReply_def isBlockedOnReply_def)+) + by (case_tac st, (clarsimp simp add: isReply_def)+) -lemma handleTimeout_invs': - "\invs' and st_tcb_at' active' tptr and sch_act_not tptr and ex_nonz_cap_to' tptr\ - handleTimeout tptr timeout +lemma doReply_invs[wp]: + "\tcb_at' t and tcb_at' t' and + cte_wp_at' (\cte. \grant. cteCap cte = ReplyCap t False grant) slot and + invs' and sch_act_simple\ + doReplyTransfer t' t slot grant \\_. invs'\" - apply (clarsimp simp: handleTimeout_def) - apply wpsimp - apply (rename_tac tcb) - apply (rule_tac Q'="\_. invs'" - and E'="\_. invs' and valid_idle' and st_tcb_at' active' tptr and sch_act_not tptr - and (\s. False \ bound_sc_tcb_at' (\a. a \ None) tptr s) - and ex_nonz_cap_to' tptr - and (\s. \n\dom tcb_cte_cases. cte_wp_at' (\cte. cteCap cte - = cteCap (tcbTimeoutHandler tcb)) - (tptr + n) s)" - in hoare_strengthen_postE) - apply (rule sfi_invs_plus') - apply (wpsimp wp: getTCB_wp - simp: isValidTimeoutHandler_def)+ - apply (clarsimp simp: cte_wp_at'_obj_at' tcb_cte_cases_def projectKOs obj_at'_def valid_idle'_asrt_def) - done - -crunch isValidTimeoutHandler - for inv[wp]: P - -crunch ifCondRefillUnblockCheck - for sch_act_simple[wp]: sch_act_simple - (simp: crunch_simps sch_act_simple_def) - -lemma doReplyTransfer_invs'[wp]: - "\invs' and tcb_at' sender and reply_at' replyPtr and sch_act_simple\ - doReplyTransfer sender replyPtr grant - \\rv. invs'\" - (is "valid ?pre _ _") apply (simp add: doReplyTransfer_def liftM_def) - apply (rule bind_wp[OF _ get_reply_sp'], rename_tac reply) - apply (case_tac "replyTCB reply"; clarsimp) - apply wpsimp - apply (rename_tac receiver) - apply (rule bind_wp[OF _ gts_sp']) - apply (rule hoare_if) - apply wpsimp - apply (rule_tac Q'="\_. ?pre and st_tcb_at' ((=) Inactive) receiver and ex_nonz_cap_to' receiver" - in bind_wp_fwd) - apply (wpsimp wp: replyRemove_invs') - apply (clarsimp simp: pred_tcb_at'_def) - apply (fastforce intro: if_live_then_nonz_capE' - simp: ko_wp_at'_def obj_at'_def projectKOs isReply_def) - apply simp - apply (rule bind_wp[OF _ threadGet_sp]) - apply (rule_tac Q'="\_. ?pre and st_tcb_at' ((=) Inactive) receiver and tcb_at' receiver and ex_nonz_cap_to' receiver" - in bind_wp_fwd, wpsimp) - apply (rule bind_wp[OF _ threadGet_sp], rename_tac fault) - apply (rule_tac Q'="\_. ?pre and tcb_at' receiver and ex_nonz_cap_to' receiver" - in bind_wp) - apply (wpsimp wp: possibleSwitchTo_invs' handleTimeout_invs' threadGet_wp hoare_drop_imps refillReady_wp) - apply (fastforce simp: runnable_eq_active' obj_at'_def) - apply (case_tac fault; clarsimp) - apply (wpsimp wp: doIPCTransfer_invs setThreadState_Running_invs') - apply (fastforce simp: pred_tcb_at'_def obj_at'_def) - apply (rule_tac P'="?pre and st_tcb_at' ((=) Inactive) receiver and ex_nonz_cap_to' receiver" - in hoare_weaken_pre[rotated]) - using global'_no_ex_cap apply fastforce - apply (rule bind_wp_fwd_skip, solves \wpsimp wp: threadSet_fault_invs' threadSet_st_tcb_at2\)+ - apply clarsimp - apply (intro conjI impI) - apply (wpsimp wp: setThreadState_Restart_invs') - apply (fastforce simp: pred_tcb_at'_def obj_at'_def) - apply (wpsimp wp: sts_invs_minor') - apply (fastforce simp: pred_tcb_at'_def obj_at'_def) + apply (rule bind_wp [OF _ gts_sp']) + apply (rule bind_wp [OF _ assert_sp]) + apply (rule bind_wp [OF _ getCTE_sp]) + apply (wp, wpc) + apply wp + apply (wp (once) sts_invs_minor'') + apply simp + apply (wp (once) sts_st_tcb') + apply wp + apply (rule_tac Q'="\_ s. invs' s \ t \ ksIdleThread s \ st_tcb_at' awaiting_reply' t s" + in hoare_post_imp) + apply clarsimp + apply (rule conjI, erule pred_tcb'_weakenE, case_tac st, clarsimp+) + apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def) + apply (drule(1) pred_tcb_at_conj') + apply (subgoal_tac "st_tcb_at' (\_. False) (ksCurThread s) s") + apply clarsimp + apply (erule_tac P="\st. awaiting_reply' st \ activatable' st" + in pred_tcb'_weakenE) + apply (case_tac st, clarsimp+) + apply (wp cteDeleteOne_reply_pred_tcb_at)+ + apply clarsimp + apply (rule_tac Q'="\_. (\s. t \ ksIdleThread s) + and cte_wp_at' (\cte. \grant. cteCap cte + = capability.ReplyCap t False grant) slot" + in hoare_strengthen_post [rotated]) + apply (fastforce simp: cte_wp_at'_def) + apply wp + apply (rule hoare_strengthen_post [OF doIPCTransfer_non_null_cte_wp_at']) + apply (erule conjE) + apply assumption + apply (erule cte_wp_at_weakenE') + apply (fastforce) + apply (wp sts_invs_minor'' sts_st_tcb' hoare_weak_lift_imp) + apply (rule_tac Q'="\_ s. invs' s \ sch_act_simple s + \ st_tcb_at' awaiting_reply' t s + \ t \ ksIdleThread s" + in hoare_post_imp) + apply clarsimp + apply (rule conjI, erule pred_tcb'_weakenE, case_tac st, clarsimp+) + apply (clarsimp simp: invs'_def valid_state'_def ct_in_state'_def) + apply (drule(1) pred_tcb_at_conj') + apply (subgoal_tac "st_tcb_at' (\_. False) (ksCurThread s) s") + apply clarsimp + apply (erule_tac P="\st. awaiting_reply' st \ activatable' st" + in pred_tcb'_weakenE) + apply (case_tac st, clarsimp+) + apply (wp threadSet_invs_trivial threadSet_st_tcb_at2 hoare_weak_lift_imp + | clarsimp simp add: inQ_def)+ + apply (rule_tac Q'="\_. invs' and tcb_at' t + and sch_act_simple and st_tcb_at' awaiting_reply' t" + in hoare_strengthen_post [rotated]) + apply clarsimp + apply (rule conjI) + apply (clarsimp simp: invs'_def valid_state'_def valid_idle'_def obj_at'_def + idle_tcb'_def pred_tcb_at'_def) + apply clarsimp + apply (rule conjI) + apply (clarsimp simp: invs'_def valid_state'_def valid_idle'_def) + apply (erule pred_tcb'_weakenE, clarsimp) + apply (clarsimp simp : invs'_def valid_state'_def valid_idle'_def pred_tcb_at'_def + obj_at'_def idle_tcb'_def) + apply (wp cteDeleteOne_reply_pred_tcb_at hoare_drop_imp hoare_allI)+ + apply (clarsimp simp add: isReply_awaiting_reply' cte_wp_at_ctes_of) + apply (auto dest!: st_tcb_idle'[rotated] simp:isCap_simps) done lemma ct_active_runnable' [simp]: @@ -827,25 +862,67 @@ lemma tcbSchedEnqueue_valid_action: apply clarsimp done -lemma threadSet_tcbDomain_update_invs': - "\invs' and tcb_at' t and (\s. (\p. t \ set (ksReadyQueues s p))) and K (ds \ maxDomain) \ - threadSet (tcbDomain_update (\_. ds)) t - \\_. invs'\" +abbreviation (input) "all_invs_but_sch_extra \ + \s. valid_pspace' s \ + sym_refs (state_refs_of' s) \ + if_live_then_nonz_cap' s \ + sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_bitmaps s \ + if_unsafe_then_cap' s \ + valid_idle' s \ + valid_global_refs' s \ + valid_arch_state' s \ + valid_irq_node' (irq_node' s) s \ + valid_irq_handlers' s \ + valid_irq_states' s \ + irqs_masked' s \ + valid_machine_state' s \ + cur_tcb' s \ + untyped_ranges_zero' s \ + valid_pde_mappings' s \ pspace_domain_valid s \ + ksCurDomain s \ maxDomain \ valid_dom_schedule' s \ + (\x. ksSchedulerAction s = SwitchToThread x \ st_tcb_at' runnable' x s)" + + +lemma rescheduleRequired_all_invs_but_extra: + "\\s. all_invs_but_sch_extra s\ + rescheduleRequired \\_. invs'\" + apply (simp add: invs'_def valid_state'_def) + apply (wpsimp wp: rescheduleRequired_ct_not_inQ rescheduleRequired_sch_act' + valid_irq_node_lift valid_irq_handlers_lift'') + apply auto + done + +lemma threadSet_all_invs_but_sch_extra: + shows "\ tcb_at' t and + all_invs_but_sch_extra and sch_act_simple and + K (ds \ maxDomain) \ + threadSet (tcbDomain_update (\_. ds)) t + \\rv. all_invs_but_sch_extra \" apply (rule hoare_gen_asm) apply (rule hoare_pre) - apply (clarsimp simp: invs'_def) apply (wp threadSet_valid_pspace'T_P[where P = False and Q = \ and Q' = \]) - apply (simp add: tcb_cte_cases_def)+ - apply (wp threadSet_valid_pspace'T_P - threadSet_state_refs_of'T_P[where f'=id and P'=False and Q=\ and g'=id and Q'=\] - threadSet_idle'T threadSet_global_refsT threadSet_cur irqs_masked_lift - valid_irq_node_lift valid_irq_handlers_lift'' threadSet_ctes_ofT threadSet_not_inQ - threadSet_valid_queues'_no_state threadSet_valid_queues threadSet_valid_dom_schedule' - threadSet_iflive'T threadSet_ifunsafe'T untyped_ranges_zero_lift - threadSet_valid_release_queue threadSet_valid_release_queue' - | simp add: tcb_cte_cases_def cteCaps_of_def o_def invs'_def - | intro allI)+ - by (fastforce simp: sch_act_simple_def o_def cteCaps_of_def valid_release_queue'_def obj_at'_def) + apply (simp add:tcb_cte_cases_def cteSizeBits_def)+ + apply (wp + threadSet_valid_pspace'T_P + threadSet_state_refs_of'T_P[where f'=id and P'=False and Q=\ and g'=id and Q'=\] + threadSet_idle'T + threadSet_global_refsT + threadSet_cur + irqs_masked_lift + valid_irq_node_lift + valid_irq_handlers_lift'' + threadSet_ctes_ofT + threadSet_not_inQ + threadSet_valid_dom_schedule' + threadSet_iflive'T + threadSet_ifunsafe'T + untyped_ranges_zero_lift threadSet_sched_pointers threadSet_valid_sched_pointers + | simp add:tcb_cte_cases_def cteSizeBits_def cteCaps_of_def o_def)+ + apply (wp hoare_vcg_all_lift hoare_vcg_imp_lift threadSet_pred_tcb_no_state | simp)+ + apply (clarsimp simp:sch_act_simple_def o_def cteCaps_of_def) + apply (intro conjI) + apply fastforce+ + done lemma threadSet_not_curthread_ct_domain: "\\s. ptr \ ksCurThread s \ ct_idle_or_in_cur_domain' s\ threadSet f ptr \\rv. ct_idle_or_in_cur_domain'\" @@ -854,209 +931,46 @@ lemma threadSet_not_curthread_ct_domain: apply clarsimp 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) - apply (wpsimp wp: setSchedContext_invs' setNotification_invs' hoare_vcg_imp_lift' - hoare_vcg_all_lift getNotification_wp) - apply (rule conjI) - apply (fastforce dest: ntfn_ko_at_valid_objs_valid_ntfn' - simp: valid_ntfn'_def - split: ntfn.splits) - apply (fastforce dest: sc_ko_at_valid_objs_valid_sc' - simp: valid_sched_context'_def valid_sched_context_size'_def objBits_simps) - done - -lemma contextYieldToUpdateQueues_invs'_helper: - "\\s. invs' s \ sc_at' scPtr s \ valid_sched_context' sc s \ valid_sched_context_size' sc - \ ex_nonz_cap_to' scPtr s \ ex_nonz_cap_to' ctPtr s \ tcb_at' ctPtr s\ - do y \ threadSet (tcbYieldTo_update (\_. Some scPtr)) ctPtr; - setSchedContext scPtr (scYieldFrom_update (\_. Some ctPtr) sc) - od - \\_. invs'\" - apply (clarsimp simp: invs'_def valid_pspace'_def valid_dom_schedule'_def) - apply (wp threadSet_valid_objs' threadSet_mdb' threadSet_iflive' threadSet_cap_to - threadSet_ifunsafe'T threadSet_ctes_ofT threadSet_valid_queues_new - threadSet_valid_queues' threadSet_valid_release_queue threadSet_valid_release_queue' - untyped_ranges_zero_lift valid_irq_node_lift valid_irq_handlers_lift'' - hoare_vcg_const_imp_lift hoare_vcg_imp_lift' threadSet_valid_replies' - | clarsimp simp: tcb_cte_cases_def cteCaps_of_def)+ - apply (fastforce simp: obj_at_simps valid_tcb'_def tcb_cte_cases_def comp_def - valid_sched_context'_def valid_sched_context_size'_def - valid_release_queue'_def inQ_def) - done - -crunch schedContextResume - for bound_scTCB[wp]: "obj_at' (\a. \y. scTCB a = Some y) scPtr" - (wp: crunch_wps simp: crunch_simps) - -lemma schedContextCancelYieldTo_bound_scTCB[wp]: - "schedContextCancelYieldTo tptr \obj_at' (\a. \y. scTCB a = Some y) scPtr\" - apply (clarsimp simp: schedContextCancelYieldTo_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule hoare_when_cases, simp) - apply (wpsimp wp: set_sc'.obj_at' simp: updateSchedContext_def) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def split: if_split) - done - -lemma schedContextUpdateConsumed_bound_scTCB[wp]: - "schedContextUpdateConsumed tptr \obj_at' (\a. \y. scTCB a = Some y) scPtr\" - apply (clarsimp simp: schedContextUpdateConsumed_def) - apply (wpsimp wp: set_sc'.obj_at' simp: updateSchedContext_def) - apply (clarsimp simp: obj_at'_real_def ko_wp_at'_def split: if_split) - done - -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 (\s. tcb_at' (ksCurThread s) s)\ - contextYieldToUpdateQueues scPtr - \\_. invs'\" - apply (clarsimp simp: contextYieldToUpdateQueues_def) - apply (rule bind_wp[OF _ get_sc_sp'], rename_tac sc) - apply (rule bind_wp[OF _ isSchedulable_sp]) - apply (rule hoare_if; (solves wpsimp)?) - apply (rule bind_wp[OF _ getCurThread_sp], rename_tac ctPtr) - apply (rule bind_wp_fwd_skip, solves wpsimp)+ - apply (rule hoare_if) - apply wpsimp - apply (erule isSchedulable_bool_runnableE) - apply (frule sc_ko_at_valid_objs_valid_sc') - apply fastforce - apply (clarsimp simp: valid_sched_context'_def valid_bound_obj'_def obj_at_simps opt_map_def) - apply (subst bind_dummy_ret_val[symmetric]) - apply (subst bind_assoc[symmetric]) - apply (rule_tac Q'="\_. invs' and ct_active' and (\s. st_tcb_at' runnable' (the (scTCB sc)) s) - and (\s. ctPtr = ksCurThread s)" - in bind_wp_fwd) - apply (clarsimp simp: pred_conj_def) - apply (intro hoare_vcg_conj_lift_pre_fix) - apply (rule hoare_weaken_pre) - apply (rule contextYieldToUpdateQueues_invs'_helper) - apply (fastforce dest: sc_ko_at_valid_objs_valid_sc' - simp: valid_sched_context'_def valid_sched_context_size'_def) - apply (wpsimp wp: threadSet_ct_in_state' setSchedContext_ct_in_state') - apply (wpsimp wp: threadSet_st_tcb_at2) - apply (erule isSchedulable_bool_runnableE) - apply (frule sc_ko_at_valid_objs_valid_sc') - apply fastforce - apply (frule sc_ko_at_valid_objs_valid_sc') - apply fastforce - apply (clarsimp simp: valid_sched_context'_def scBits_simps obj_at_simps) - apply (wpsimp | wps)+ - apply (clarsimp simp: ct_in_state'_def st_tcb_at'_def obj_at_simps runnable_eq_active') - done - -crunch schedContextResume - for st_tcb_at'[wp]: "\s. Q (st_tcb_at' P tptr s)" - (wp: crunch_wps threadSet_wp mapM_wp_inv simp: crunch_simps) - -crunch schedContextResume - for scTCBs_of[wp]: "\s. P (scTCBs_of s)" - (wp: crunch_wps threadSet_st_tcb_at2 mapM_wp_inv) - -crunch schedContextCompleteYieldTo - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" - (simp: crunch_simps tcb_cte_cases_def wp: crunch_wps threadSet_cap_to) - -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 buffer - \\_. invs'\" - apply (clarsimp simp: schedContextYieldTo_def) - apply (wpsimp wp: contextYieldToUpdateQueues_invs' setConsumed_invs' - simp: ct_in_state'_def - | wps)+ - done - -lemma invokeSchedContext_invs': - "\invs' and ct_active' and valid_sc_inv' iv\ - invokeSchedContext iv - \\_. invs'\" - apply (clarsimp simp: invokeSchedContext_def) - apply (cases iv; clarsimp) - apply (wpsimp wp: setConsumed_invs') - apply (rename_tac scPtr cap) - apply (case_tac cap; clarsimp) - apply (wpsimp wp: schedContextBindTCB_invs') - apply (clarsimp simp: pred_tcb_at'_def obj_at_simps) - apply (wpsimp wp: schedContextBindNtfn_invs') - apply (rename_tac scPtr cap) - apply (case_tac cap; clarsimp) - apply wpsimp - using global'_sc_no_ex_cap apply fastforce - 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)\ - setDomain ptr domain - \\_. invs'\" - (is "\?P\ _ \_\") - apply (simp add: setDomain_def) - apply (rule bind_wp[OF _ getCurThread_sp]) - apply (rule_tac Q'="\_ s. ?P s \ (\p. ptr \ set (ksReadyQueues s p))" in bind_wp_fwd) - apply (wpsimp wp: tcbSchedDequeue_nonq hoare_vcg_all_lift) - apply (rule bind_wp_fwd_skip, wpsimp wp: threadSet_tcbDomain_update_invs') - apply (wpsimp wp: tcbSchedEnqueue_invs' isSchedulable_wp) - apply (clarsimp simp: isSchedulable_bool_def pred_map_simps st_tcb_at'_def obj_at_simps - elim!: opt_mapE) - done - -crunch refillNew, refillUpdate, commitTime - for pred_tcb_at''[wp]: "\s. Q (pred_tcb_at' proj P tcbPtr s)" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - and ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' ptr" - (simp: crunch_simps wp: crunch_wps) - -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) - 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) - done - -lemma invokeSchedControlConfigureFlags_invs': - "\invs' and valid_sc_ctrl_inv' iv\ - invokeSchedControlConfigureFlags iv - \\_. invs'\" - (is "\?pre\ _ \_\") - apply (clarsimp simp: invokeSchedControlConfigureFlags_def) - apply (cases iv; clarsimp) - apply (rule bind_wp[OF _ get_sc_sp']) - apply (rule_tac Q'="\_. ?pre" in bind_wp_fwd) - apply (wpsimp wp: commitTime_invs' tcbReleaseRemove_invs' hoare_vcg_ex_lift) - apply (wpsimp wp: hoare_vcg_if_lift refillNew_invs' refillUpdate_invs' hoare_vcg_imp_lift') - by (fastforce simp: valid_refills_number'_def) + "\invs' and sch_act_simple and ct_active' and + (tcb_at' ptr and + (\s. sch_act_not ptr s) and + (\y. domain \ maxDomain))\ + setDomain ptr domain \\y. invs'\" + apply (simp add:setDomain_def ) + apply (wp add: when_wp hoare_weak_lift_imp hoare_weak_lift_imp_conj rescheduleRequired_all_invs_but_extra + tcbSchedEnqueue_valid_action hoare_vcg_if_lift2) + apply (rule_tac Q'="\r s. all_invs_but_sch_extra s \ curThread = ksCurThread s + \ (ptr \ curThread \ ct_not_inQ s \ sch_act_wf (ksSchedulerAction s) s \ ct_idle_or_in_cur_domain' s)" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp:invs'_def valid_state'_def st_tcb_at'_def[symmetric] valid_pspace'_def) + apply simp + apply (rule hoare_strengthen_post[OF hoare_vcg_conj_lift]) + apply (rule threadSet_all_invs_but_sch_extra) + prefer 2 + apply clarsimp + apply assumption + apply (wp hoare_weak_lift_imp threadSet_pred_tcb_no_state threadSet_not_curthread_ct_domain + threadSet_tcbDomain_update_ct_not_inQ | simp)+ + apply (rule_tac Q'="\r s. invs' s \ curThread = ksCurThread s \ sch_act_simple s + \ domain \ maxDomain + \ (ptr \ curThread \ ct_not_inQ s \ sch_act_not ptr s)" + in hoare_strengthen_post[rotated]) + apply (clarsimp simp:invs'_def valid_state'_def) + apply (wp hoare_vcg_imp_lift)+ + apply (clarsimp simp:invs'_def valid_pspace'_def valid_state'_def)+ + done lemma performInv_invs'[wp]: - "\invs' and (\s. ksSchedulerAction s = ResumeCurrentThread) - and ct_active' and valid_invocation' i - and (\s. can_donate \ bound_sc_tcb_at' bound (ksCurThread s) s)\ - performInvocation block call can_donate i + "\invs' and sch_act_simple and ct_active' and valid_invocation' i\ + RetypeDecls_H.performInvocation block call i \\_. invs'\" - apply (clarsimp simp: performInvocation_def) + unfolding performInvocation_def apply (cases i) - by (clarsimp simp: 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 (clarsimp simp: simple_sane_strg sch_act_simple_def sch_act_sane_def + | wp tcbinv_invs' arch_performInvocation_invs' setDomain_invs' + | rule conjI | erule active_ex_cap')+ + done lemma getSlotCap_to_refs[wp]: "\\\ getSlotCap ref \\rv s. \r\zobj_refs' rv. ex_nonz_cap_to' r s\" @@ -1196,6 +1110,10 @@ lemma st_tcb_at_idle_thread': crunch replyFromKernel for tcb_at'[wp]: "tcb_at' t" +lemma invs_weak_sch_act_wf_strg: + "invs' s \ weak_sch_act_wf (ksSchedulerAction s) s" + by clarsimp + (* FIXME: move *) lemma rct_sch_act_simple[simp]: "ksSchedulerAction s = ResumeCurrentThread \ sch_act_simple s" @@ -1208,42 +1126,43 @@ lemma rct_sch_act_sane[simp]: lemma lookupCapAndSlot_real_cte_at'[wp]: "\valid_objs'\ lookupCapAndSlot thread ptr \\rv. real_cte_at' (snd rv)\, -" - apply (simp add: lookupCapAndSlot_def lookupSlotForThread_def) - apply (wp resolveAddressBits_real_cte_at' | simp add: split_def)+ - done +apply (simp add: lookupCapAndSlot_def lookupSlotForThread_def) +apply (wp resolveAddressBits_real_cte_at' | simp add: split_def)+ +done lemmas set_thread_state_active_valid_sched = set_thread_state_runnable_valid_sched[simplified runnable_eq_active] lemma setTCB_valid_duplicates'[wp]: - "setObject a (tcb::tcb) \\s. vs_valid_duplicates' (ksPSpace s)\" + "\\s. vs_valid_duplicates' (ksPSpace s)\ + setObject a (tcb::tcb) \\rv s. vs_valid_duplicates' (ksPSpace s)\" apply (clarsimp simp: setObject_def split_def valid_def in_monad projectKOs pspace_aligned'_def ps_clear_upd objBits_def[symmetric] lookupAround2_char1 split: if_split_asm) apply (frule pspace_storable_class.updateObject_type[where v = tcb,simplified]) - apply (clarsimp simp: updateObject_default_def assert_def bind_def - alignCheck_def in_monad when_def alignError_def magnitudeCheck_def - assert_opt_def return_def fail_def typeError_def - split: if_splits option.splits Structures_H.kernel_object.splits) + apply (clarsimp simp:updateObject_default_def assert_def bind_def + alignCheck_def in_monad when_def alignError_def magnitudeCheck_def + assert_opt_def return_def fail_def typeError_def + split:if_splits option.splits Structures_H.kernel_object.splits) apply (erule valid_duplicates'_non_pd_pt_I[rotated 3],simp+)+ done crunch threadSet - for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (wp: updateObject_default_inv) + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (wp: setObject_ksInterrupt updateObject_default_inv) crunch addToBitmap - for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (wp: updateObject_default_inv) + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (wp: setObject_ksInterrupt updateObject_default_inv) lemma tcbSchedEnqueue_valid_duplicates'[wp]: "tcbSchedEnqueue tcbPtr \\s. vs_valid_duplicates' (ksPSpace s)\" by (wpsimp simp: tcbSchedEnqueue_def tcbQueuePrepend_def unless_def setQueue_def) crunch rescheduleRequired - for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - (wp: setObject_ksInterrupt updateObject_default_inv crunch_wps) + for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" + (wp: setObject_ksInterrupt updateObject_default_inv) crunch setThreadState for valid_duplicates'[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" @@ -1251,141 +1170,97 @@ crunch setThreadState crunch reply_from_kernel for pspace_aligned[wp]: pspace_aligned and pspace_distinct[wp]: pspace_distinct - and valid_objs[wp]: valid_objs - (simp: crunch_simps wp: crunch_wps) -crunch replyFromKernel - for valid_objs'[wp]: valid_objs' - and valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - (simp: crunch_simps wp: crunch_wps) - -(* Note: the preconditions on the abstract side are based on those of performInvocation_corres. *) lemma handleInvocation_corres: - "call \ blocking \ - cptr = to_bl cptr' \ + "c \ b \ 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. vs_valid_duplicates' (ksPSpace s))) - (handle_invocation call blocking can_donate first_phase cptr) - (handleInvocation call blocking can_donate first_phase cptr')" - apply add_cur_tcb' - apply add_ct_not_inQ - apply add_valid_idle' - apply (rule_tac Q="\s'. bound_sc_tcb_at' bound (ksCurThread s') s'" in corres_cross_add_guard) - apply (fastforce intro: ct_released_cross_weak) + (einvs and schact_is_rct and ct_active) + (invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_active') + (handle_invocation c b) + (handleInvocation c b)" apply (simp add: handle_invocation_def handleInvocation_def liftE_bindE) - apply (rule corres_stateAssertE_add_assertion[rotated]) - apply (clarsimp simp: ct_not_inQ_asrt_def) - apply (rule corres_stateAssertE_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (rule stronger_corres_guard_imp) + apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule corres_split [OF getMessageInfo_corres]) - apply (rule syscall_corres) - apply (rule hinv_corres_assist, simp) - apply (rule corres_when[OF _ handleFault_corres]; simp) - apply (simp only: split_def) - apply (rule corres_split[OF getMRs_corres]) + apply (rule corres_split[OF getMessageInfo_corres]) + apply clarsimp + apply (simp add: liftM_def cap_register_def capRegister_def) + apply (rule corres_split_eqr[OF asUser_getRegister_corres]) + apply (rule syscall_corres) + apply (rule hinv_corres_assist, simp) + apply (clarsimp simp add: when_def) + apply (rule handleFault_corres) apply simp - apply (rule decodeInvocation_corres; simp) - apply (fastforce simp: list_all2_map2 list_all2_map1 elim: list_all2_mono) - apply (fastforce simp: list_all2_map2 list_all2_map1 elim: list_all2_mono) - apply (wpsimp wp: hoare_case_option_wp) - apply (drule sym[OF conjunct1], simp, wp) - apply (clarsimp simp: when_def) - apply (rule replyFromKernel_corres) - apply (rule corres_split [OF setThreadState_corres], simp) - apply (rule corres_splitEE) - apply (rule performInvocation_corres; simp) + apply (simp add: split_def) + apply (rule corres_split[OF getMRs_corres]) + apply (rule decodeInvocation_corres, simp_all)[1] + apply (fastforce simp: list_all2_map2 list_all2_map1 elim: list_all2_mono) + apply (fastforce simp: list_all2_map2 list_all2_map1 elim: list_all2_mono) + apply wp[1] + apply (drule sym[OF conjunct1]) apply simp - apply (rule corres_split [OF getThreadState_corres]) - apply (rename_tac state state') - apply (case_tac state, simp_all)[1] - apply (fold dc_def)[1] - apply (rule corres_split [OF _ setThreadState_corres]) - apply simp - apply (rule corres_when [OF refl replyFromKernel_corres]) - apply simp - apply (clarsimp simp: pred_conj_def, strengthen valid_objs_valid_tcbs) - apply wpsimp - apply (clarsimp simp: pred_conj_def, strengthen valid_objs'_valid_tcbs') - apply wpsimp+ - apply (strengthen invs_valid_objs invs_psp_aligned invs_distinct) - apply (clarsimp cong: conj_cong) - apply (wpsimp wp: hoare_drop_imp) - apply (rule_tac Q'="tcb_at' thread and invs'" in hoare_post_imp_dc2) - apply wpsimp - apply (clarsimp simp: invs'_def) - apply simp - apply (rule_tac Q'="\rv. einvs and valid_machine_time and schact_is_rct - and valid_invocation rve - and (\s. thread = cur_thread s) - and st_tcb_at active thread - and ct_not_in_release_q and ct_released - 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)" - in hoare_post_imp) - apply (clarsimp simp: simple_from_active ct_in_state_def schact_is_rct_def - current_time_bounded_def - elim!: st_tcb_weakenE) - apply (wp sts_st_tcb_at' set_thread_state_simple_sched_action - set_thread_state_active_valid_sched set_thread_state_schact_is_rct_strong) - apply (rule_tac Q'="\_. invs' 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. vs_valid_duplicates' (ksPSpace s)) - and (\s. bound_sc_tcb_at' bound (ksCurThread s) s)" - in hoare_post_imp) - apply (clarsimp simp: ct_in_state'_def) - apply ((wpsimp wp: setThreadState_nonqueued_state_update setThreadState_st_tcb - setThreadState_rct setThreadState_ct_not_inQ sts_bound_sc_tcb_at' - | wps)+)[1] - apply clarsimp - apply (wp | simp add: split_def liftE_bindE[symmetric] - ct_in_state'_def ball_conj_distrib - | rule hoare_vcg_conj_elimE)+ - apply (rule hoare_vcg_conj_lift) - apply (rule hoare_strengthen_post[OF lookup_ipc_buffer_in_user_frame]) - apply meson - apply (wp lookup_ipc_buffer_in_user_frame - | simp add: split_def liftE_bindE[symmetric] - ball_conj_distrib)+ - apply (clarsimp simp: msg_max_length_def word_bits_def) - apply (frule schact_is_rct_sane) - apply (frule invs_valid_objs) - 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 wp[1] + apply (clarsimp simp: when_def) + apply (rule replyFromKernel_corres) + apply (rule corres_split[OF setThreadState_corres], simp) + apply (rule corres_splitEE[OF performInvocation_corres]) + apply simp+ + apply (rule corres_split[OF getThreadState_corres]) + apply (rename_tac state state') + apply (case_tac state, simp_all)[1] + apply (fold dc_def)[1] + apply (rule corres_split) + apply (rule corres_when [OF refl replyFromKernel_corres]) + apply (rule setThreadState_corres) + apply simp + apply (simp add: when_def) + apply (rule conjI, rule impI) + apply (wp reply_from_kernel_tcb_at) + apply (rule impI, wp+) + apply (wpsimp wp: hoare_drop_imps|strengthen invs_distinct invs_psp_aligned)+ + apply (rule_tac Q'="\rv. einvs and schact_is_rct and valid_invocation rve + and (\s. thread = cur_thread s) + and st_tcb_at active thread" + in hoare_post_imp) + apply (clarsimp simp: simple_from_active ct_in_state_def + elim!: st_tcb_weakenE) + apply (wp sts_st_tcb_at' set_thread_state_schact_is_rct + set_thread_state_active_valid_sched) + apply (rule_tac Q'="\rv. invs' and valid_invocation' rve' + and (\s. thread = ksCurThread s) + and st_tcb_at' active' thread + and (\s. ksSchedulerAction s = ResumeCurrentThread) + and (\s. vs_valid_duplicates' (ksPSpace s))" + in hoare_post_imp) + apply (clarsimp simp: ct_in_state'_def) + apply (clarsimp) + apply (wp setThreadState_nonqueued_state_update + setThreadState_st_tcb setThreadState_rct)[1] + apply (wp lec_caps_to lsft_ex_cte_cap_to + | simp add: split_def liftE_bindE[symmetric] + ct_in_state'_def ball_conj_distrib + | rule hoare_vcg_conj_elimE)+ + apply (clarsimp simp: tcb_at_invs invs_valid_objs + valid_tcb_state_def ct_in_state_def + simple_from_active invs_mdb + invs_distinct invs_psp_aligned) + apply (clarsimp simp: msg_max_length_def word_bits_def schact_is_rct_def) apply (erule st_tcb_ex_cap, clarsimp+) apply fastforce - apply (clarsimp cong: conj_cong) - apply (subgoal_tac "ct_schedulable s") - apply (clarsimp simp: invs'_def valid_pspace'_def cur_tcb'_def) - apply (frule valid_objs'_valid_tcbs') - 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_schact, simp) - apply (subgoal_tac "isSchedulable_bool (ksCurThread s') s'") - apply (clarsimp simp: isSchedulable_bool_def pred_map_conj[simplified pred_conj_def]) - apply (frule curthread_relation, simp) - apply (frule_tac t1="cur_thread s" in cross_relF[OF _ isSchedulable_bool_cross_rel]; - simp add: invs_def valid_state_def valid_pspace_def) - apply (clarsimp simp: schedulable_def2 ct_in_state_def runnable_eq_active) + apply (clarsimp) + apply (frule tcb_at_invs') + apply (clarsimp simp: invs'_def valid_state'_def + ct_in_state'_def ct_not_inQ_def) + 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) + apply (frule (1) st_tcb_at_idle_thread') + apply (simp) done lemma ts_Restart_case_helper': - "(case ts of Structures_H.Restart \ A | _ \ B) = (if ts = Structures_H.Restart then A else B)" + "(case ts of Structures_H.Restart \ A | _ \ B) + = (if ts = Structures_H.Restart then A else B)" by (cases ts, simp_all) lemma gts_imp': @@ -1398,12 +1273,14 @@ lemma gts_imp': done crunch replyFromKernel - for st_tcb_at'[wp]: "\s. P (st_tcb_at' P' t s)" - and cap_to'[wp]: "ex_nonz_cap_to' p" - and it'[wp]: "\s. P (ksIdleThread s)" - and sch_act_simple[wp]: sch_act_simple - and reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" - (rule: sch_act_simple_lift simp: crunch_simps wp: crunch_wps) + for st_tcb_at'[wp]: "st_tcb_at' P t" +crunch replyFromKernel + for cap_to'[wp]: "ex_nonz_cap_to' p" +crunch replyFromKernel + for it'[wp]: "\s. P (ksIdleThread s)" +crunch replyFromKernel + for sch_act_simple[wp]: sch_act_simple + (rule: sch_act_simple_lift) lemma rfk_ksQ[wp]: "\\s. P (ksReadyQueues s p)\ replyFromKernel t x1 \\_ s. P (ksReadyQueues s p)\" @@ -1413,14 +1290,13 @@ lemma rfk_ksQ[wp]: done lemma hinv_invs'[wp]: - "\invs' and ct_isSchedulable and (\s. vs_valid_duplicates' (ksPSpace s)) - and (\s. ksSchedulerAction s = ResumeCurrentThread)\ - handleInvocation calling blocking can_donate first_phase cptr - \\_. invs'\" + "\invs' and ct_active' and + (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. ksSchedulerAction s = ResumeCurrentThread)\ + handleInvocation calling blocking + \\rv. invs'\" apply (simp add: handleInvocation_def split_def - ts_Restart_case_helper' ct_not_inQ_asrt_def) - apply (rule validE_valid) - apply (intro bindE_wp[OF _ stateAssertE_sp]) + ts_Restart_case_helper') apply (wp syscall_valid' setThreadState_nonqueued_state_update rfk_invs' hoare_vcg_all_lift hoare_weak_lift_imp) apply simp @@ -1428,66 +1304,56 @@ lemma hinv_invs'[wp]: apply (wp gts_imp' | simp)+ apply (rule_tac Q'="\rv. invs'" in hoare_strengthen_postE_R[rotated]) apply clarsimp + apply (subgoal_tac "thread \ ksIdleThread s", simp_all)[1] apply (fastforce elim!: pred_tcb'_weakenE st_tcb_ex_cap'') + apply (clarsimp simp: valid_idle'_def valid_state'_def + invs'_def pred_tcb_at'_def obj_at'_def idle_tcb'_def) apply wp+ - apply (rule_tac Q'="\rv'. invs' and ct_not_inQ and valid_invocation' rv + apply (rule_tac Q'="\rv'. invs' and valid_invocation' rv and (\s. ksSchedulerAction s = ResumeCurrentThread) and (\s. ksCurThread s = thread) - and st_tcb_at' active' thread - and (\s. bound_sc_tcb_at' bound (ksCurThread s) s)" + and st_tcb_at' active' thread" in hoare_post_imp) apply (clarsimp simp: ct_in_state'_def) - apply (wpsimp wp: sts_invs_minor' setThreadState_st_tcb setThreadState_rct - setThreadState_ct_not_inQ hoare_vcg_imp_lift' - | wps)+ - apply (fastforce simp: ct_in_state'_def simple_sane_strg sch_act_simple_def pred_map_simps - obj_at_simps pred_tcb_at'_def - elim!: pred_tcb'_weakenE st_tcb_ex_cap'' opt_mapE - dest: st_tcb_at_idle_thread')+ - done - -(* NOTE: This is a good candidate for corressimp at some point. For now there are some missing - lemmas regarding corresK and liftM. *) -lemma getCapReg_corres: - "corres (\x y. x = to_bl y) ct_active ct_active' - (get_cap_reg cap_register) (getCapReg ARM_H.capRegister)" - apply (simp add: get_cap_reg_def getCapReg_def cap_register_def capRegister_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres], simp) - apply (rule corres_rel_imp) - apply (rule asUser_getRegister_corres) - apply (wpsimp simp: ct_in_state_def ct_in_state'_def)+ + apply (wp sts_invs_minor' setThreadState_st_tcb setThreadState_rct | simp)+ + apply (clarsimp) + apply (fastforce simp add: tcb_at_invs' ct_in_state'_def + simple_sane_strg + sch_act_simple_def + elim!: pred_tcb'_weakenE st_tcb_ex_cap'' + dest: st_tcb_at_idle_thread')+ done +crunch handleFault + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) + +lemmas handleFault_typ_ats[wp] = typ_at_lifts [OF handleFault_typ_at'] + 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)) + (einvs and schact_is_rct and ct_active) (invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_active') (handle_send blocking) (handleSend blocking)" - apply add_cur_tcb' - apply (simp add: handle_send_def handleSend_def) - apply (rule corres_guard_imp) - apply (rule corres_split_liftEE[OF getCapReg_corres]) - apply (simp, rule handleInvocation_corres; simp) - apply (wpsimp simp: getCapReg_def)+ - apply (clarsimp simp: cur_tcb'_def) - done + by (simp add: handle_send_def handleSend_def handleInvocation_corres) lemma hs_invs'[wp]: - "\invs' and ct_isSchedulable and + "\invs' and ct_active' and (\s. vs_valid_duplicates' (ksPSpace s)) and (\s. ksSchedulerAction s = ResumeCurrentThread)\ handleSend blocking \\r. invs'\" apply (rule validE_valid) - apply (simp add: handleSend_def getCapReg_def) + apply (simp add: handleSend_def) apply (wp | simp)+ done +lemma getThreadCallerSlot_map: + "getThreadCallerSlot t = return (cte_map (t, tcb_cnode_index 3))" + by (simp add: getThreadCallerSlot_def locateSlot_conv + cte_map_def tcb_cnode_index_def tcbCallerSlot_def + cte_level_bits_def) + lemma tcb_at_cte_at_map: "\ tcb_at' t s; offs \ dom tcb_cap_cases \ \ cte_at' (cte_map (t, offs)) s" apply (clarsimp simp: obj_at'_def projectKOs objBits_simps) @@ -1495,204 +1361,178 @@ lemma tcb_at_cte_at_map: apply (auto elim: cte_wp_at_tcbI') done -crunch tcbSchedEnqueue - for sch_act_sane[wp]: sch_act_sane - (rule: sch_act_sane_lift) +lemma deleteCallerCap_corres: + "corres dc (einvs and tcb_at t) (invs' and tcb_at' t) + (delete_caller_cap t) + (deleteCallerCap t)" + apply (simp add: delete_caller_cap_def deleteCallerCap_def + getThreadCallerSlot_map) + apply (rule corres_guard_imp) + apply (rule_tac P'="cte_at' (cte_map (t, tcb_cnode_index 3))" in corres_symb_exec_r_conj) + apply (rule_tac F="isReplyCap rv \ rv = capability.NullCap" + and P="cte_wp_at (\cap. is_reply_cap cap \ cap = cap.NullCap) (t, tcb_cnode_index 3) + and einvs" + and P'="invs' and cte_wp_at' (\cte. cteCap cte = rv) + (cte_map (t, tcb_cnode_index 3))" in corres_req) + apply (clarsimp simp: cte_wp_at_caps_of_state state_relation_def) + apply (drule caps_of_state_cteD) + apply (drule(1) pspace_relation_cte_wp_at, clarsimp+) + apply (clarsimp simp: cte_wp_at_ctes_of is_reply_cap_relation cap_relation_NullCapI) + apply simp + apply (rule corres_guard_imp, rule cap_delete_one_corres) + apply (clarsimp simp: cte_wp_at_caps_of_state is_cap_simps) + apply (auto simp: can_fast_finalise_def)[1] + apply (clarsimp simp: cte_wp_at_ctes_of) + apply ((wp getCTE_wp')+ | simp add: getSlotCap_def)+ + apply clarsimp + apply (frule tcb_at_cte_at[where ref="tcb_cnode_index 3"]) + apply clarsimp + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply (frule tcb_cap_valid_caps_of_stateD, clarsimp) + apply (drule(1) tcb_cnode_index_3_reply_or_null) + apply (auto simp: can_fast_finalise_def is_cap_simps + intro: tcb_at_cte_at_map tcb_at_cte_at)[1] + apply clarsimp + apply (frule_tac offs="tcb_cnode_index 3" in tcb_at_cte_at_map) + apply (simp add: tcb_cap_cases_def) + apply (clarsimp simp: cte_wp_at_ctes_of) + done -lemma possibleSwitchTo_sch_act_sane: - "\ sch_act_sane and (\s. t \ ksCurThread s) \ possibleSwitchTo t \\_. sch_act_sane \" - unfolding possibleSwitchTo_def curDomain_def inReleaseQueue_def - apply (wpsimp wp: threadGet_wp crunch_wps) - apply (fastforce simp: obj_at'_def sch_act_sane_def) +lemma deleteCallerCap_invs[wp]: + "\invs'\ deleteCallerCap t \\rv. invs'\" + apply (simp add: deleteCallerCap_def getThreadCallerSlot_def + locateSlot_conv) + apply (wp cteDeleteOne_invs hoare_drop_imps) + done + +lemma deleteCallerCap_simple[wp]: + "\st_tcb_at' simple' t\ deleteCallerCap t' \\rv. st_tcb_at' simple' t\" + apply (simp add: deleteCallerCap_def getThreadCallerSlot_def + locateSlot_conv) + apply (wp cteDeleteOne_st_tcb_at hoare_drop_imps | simp)+ + done + +lemma cteDeleteOne_reply_cap_to''[wp]: + "\ex_nonz_cap_to' p and + cte_wp_at' (\c. isReplyCap (cteCap c) \ isNullCap (cteCap c)) slot\ + cteDeleteOne slot + \\rv. ex_nonz_cap_to' p\" + apply (simp add: cteDeleteOne_def ex_nonz_cap_to'_def unless_def) + apply (rule bind_wp [OF _ getCTE_sp]) + apply (rule hoare_assume_pre) + apply (subgoal_tac "isReplyCap (cteCap cte) \ isNullCap (cteCap cte)") + apply (wp hoare_vcg_ex_lift emptySlot_cte_wp_cap_other isFinalCapability_inv + | clarsimp simp: finaliseCap_def isCap_simps | simp + | wp (once) hoare_drop_imps)+ + apply (fastforce simp: cte_wp_at_ctes_of) + apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) + done + +lemma deleteCallerCap_nonz_cap: + "\ex_nonz_cap_to' p and tcb_at' t and valid_objs'\ + deleteCallerCap t + \\rv. ex_nonz_cap_to' p\" + apply (simp add: deleteCallerCap_def getSlotCap_def getThreadCallerSlot_map + locateSlot_conv ) + apply (rule hoare_pre) + apply (wp cteDeleteOne_reply_cap_to'' getCTE_wp') + apply clarsimp + apply (frule_tac offs="tcb_cnode_index 3" in tcb_at_cte_at_map) + apply (clarsimp simp: tcb_cap_cases_def) + apply (auto simp: ex_nonz_cap_to'_def isCap_simps cte_wp_at_ctes_of) done crunch cteDeleteOne - for sch_act_sane[wp]: sch_act_sane - (wp: crunch_wps getObject_inv + for sch_act_sane[wp]: sch_act_sane + (wp: crunch_wps loadObject_default_inv getObject_inv simp: crunch_simps unless_def rule: sch_act_sane_lift) -lemma getCapReg_corres_gen: - "corres (\x y. x = to_bl y) cur_tcb cur_tcb' - (get_cap_reg rg) (getCapReg rg)" - apply (simp add: get_cap_reg_def getCapReg_def cap_register_def capRegister_def) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCurThread_corres], simp) - apply (rule corres_rel_imp) - apply (rule asUser_getRegister_corres) - apply (wpsimp simp: cur_tcb_def cur_tcb'_def)+ - done - -lemma lookupReply_corres: - "corres (fr \ cap_relation) - (cur_tcb and valid_objs and pspace_aligned) - (cur_tcb' and valid_objs' and pspace_aligned' and pspace_distinct') - lookup_reply lookupReply" - unfolding lookup_reply_def lookupReply_def withoutFailure_def - apply simp - apply (rule corres_rel_imp) - apply (rule corres_guard_imp) - apply (rule corres_split_liftEE[OF getCapReg_corres_gen]) - apply (rule corres_split_liftEE[OF getCurThread_corres]) - apply simp - apply (rule corres_splitEE[OF corres_cap_fault[OF lookupCap_corres]]) - apply (rename_tac cref cref' ct ct' cap cap') - apply (rule corres_if2) - apply (case_tac cap; case_tac cap'; clarsimp simp: is_reply_cap_def isReplyCap_def) - apply (rule corres_returnOk[where r=cap_relation]) - apply simp - apply (simp add: lookup_failure_map_def) - apply wpsimp+ - apply (wpsimp simp: getCapReg_def) - apply (clarsimp simp: cur_tcb_def, simp) - apply (clarsimp simp: cur_tcb'_def) - apply assumption - done - -lemma lookup_reply_valid [wp]: - "\ valid_objs \ lookup_reply \ valid_cap \, -" - unfolding lookup_reply_def get_cap_reg_def - apply (wpsimp wp: get_cap_wp hoare_vcg_imp_liftE_R) - apply (rule hoare_FalseE_R) - apply wpsimp+ - done - -lemma lookup_reply_is_reply_cap [wp]: - "\ valid_objs \ lookup_reply \\rv s. is_reply_cap rv \, -" - unfolding lookup_reply_def lookup_cap_def - by (wpsimp wp: get_cap_wp) - -crunch lookupReply - for inv[wp]: "P" - (simp: crunch_simps wp: crunch_wps) - -crunch lookup_reply - for valid_cap[wp]: "valid_cap c" - and cte_wp_at[wp]: "\s. Q (cte_wp_at P p s)" - -lemma lookupReply_valid [wp]: - "\ valid_objs' \ lookupReply \ valid_cap' \, -" - unfolding lookupReply_def getCapReg_def - apply (wpsimp wp: get_cap_wp hoare_vcg_imp_liftE_R) - apply (rule hoare_FalseE_R) - apply wpsimp+ - done - -lemma getBoundNotification_corres: - "corres (=) (ntfn_at nptr) (ntfn_at' nptr) - (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) - apply (rule corres_split[OF getNotification_corres]) - apply (simp add: ntfn_relation_def) - apply wpsimp+ - done +crunch deleteCallerCap + for sch_act_sane[wp]: sch_act_sane + (wp: crunch_wps) + +lemma delete_caller_cap_valid_ep_cap: + "\valid_cap (cap.EndpointCap r a b)\ delete_caller_cap thread \\rv. valid_cap (cap.EndpointCap r a b)\" + apply (clarsimp simp: delete_caller_cap_def cap_delete_one_def valid_cap_def) + apply (rule hoare_pre) + by (wp get_cap_wp fast_finalise_typ_at abs_typ_at_lifts(1) + | simp add: unless_def valid_cap_def)+ 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)) + "corres dc (einvs and ct_in_state active + 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)" - (is "corres dc (?pre1) (?pre2) (handle_recv _ _) (handleRecv _ _)") - unfolding handle_recv_def handleRecv_def Let_def - apply add_cur_tcb' - apply (rule_tac Q="ct_active'" in corres_cross_add_guard) - apply (fastforce elim!: ct_active_cross dest: invs_psp_aligned invs_distinct) - apply (simp add: cap_register_def capRegister_def liftM_bind - cong: if_cong cap.case_cong capability.case_cong split del: if_split) + (handle_recv isBlocking) (handleRecv isBlocking)" + (is "corres dc (?pre1) (?pre2) (handle_recv _) (handleRecv _)") + apply (simp add: handle_recv_def handleRecv_def liftM_bind Let_def + cap_register_def capRegister_def + cong: if_cong cap.case_cong capability.case_cong bool.case_cong) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF getCurThread_corres]) apply (rule corres_split_eqr[OF asUser_getRegister_corres]) apply (rule corres_split_catch) - apply (rule corres_splitEE[OF corres_cap_fault[OF lookupCap_corres]]) + apply (rule corres_cap_fault) + apply (rule corres_splitEE[OF lookupCap_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' rv'" 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) - apply (case_tac "AllowRead \ rights \ canReply") - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_splitEE[OF lookupReply_corres]) - apply (rule_tac Q="\_. is_reply_cap reply_cap" in corres_inst_add) - apply (rule corres_gen_asm) - apply simp - apply (rule corres_guard_imp) - apply (rule receiveIPC_corres) - apply simp - apply (clarsimp simp: cap_relation_def) - apply simp+ - apply (wpsimp wp: typ_at_lifts)+ - apply (clarsimp simp: ct_in_state_def invs_def valid_state_def valid_pspace_def) - apply (simp add: invs'_def valid_pspace'_def) - apply (clarsimp simp: lookup_failure_map_def) apply (rule corres_guard_imp) - apply (rule receiveIPC_corres) - apply ((clarsimp simp: cap_relation_def ct_in_state_def)+)[6] - apply (rename_tac rights) - apply (simp add: bool.case_eq_if if_swap[where P="AllowRead \ x" for x, symmetric] split del: if_split) - apply (case_tac "AllowRead \ rights") - apply clarsimp - apply (rule stronger_corres_guard_imp) - apply (rule corres_split_liftEE[OF getBoundNotification_corres]) - apply (case_tac "rv = Some thread \ rv = None") - apply simp - apply (rule receiveSignal_corres) - apply simp - apply (clarsimp simp: cap_relation_def) - apply (clarsimp simp: lookup_failure_map_def) - apply (wpsimp wp: get_sk_obj_ref_wp getNotification_wp)+ - apply (clarsimp simp: valid_cap_def valid_sched_def valid_sched_action_def - current_time_bounded_def ct_in_state_def) - apply (clarsimp simp: valid_cap_def valid_cap'_def dest!: state_relationD) - apply (clarsimp simp: lookup_failure_map_def) - apply wpsimp+ - apply (rule handleFault_corres, clarsimp) - apply (wpsimp wp: get_sk_obj_ref_wp) - apply (rule_tac Q="\_. ?pre1 and (\s. cur_thread s = thread) - and K (valid_fault (ExceptionTypes_A.fault.CapFault x True - (ExceptionTypes_A.lookup_failure.MissingCapability 0)))" - and E=E and F=E for E - in hoare_strengthen_postE[rotated]) - apply (fastforce simp: valid_sched_valid_sched_action valid_sched_active_scs_valid ct_in_state_def) + apply (rename_tac rights) + apply (case_tac "AllowRead \ rights"; simp) + apply (rule corres_split_nor[OF deleteCallerCap_corres]) + apply (rule receiveIPC_corres) + apply (clarsimp)+ + apply (wp delete_caller_cap_nonz_cap delete_caller_cap_valid_ep_cap)+ + apply (clarsimp)+ + apply (clarsimp simp: lookup_failure_map_def)+ + apply (clarsimp simp: valid_cap'_def capAligned_def) + apply (rule corres_guard_imp) + apply (rename_tac rights) + apply (case_tac "AllowRead \ rights"; simp) + apply (rule_tac r'=ntfn_relation in corres_splitEE) + apply clarsimp + apply (rule getNotification_corres) + apply (rule corres_if) + apply (clarsimp simp: ntfn_relation_def) + apply (clarsimp, rule receiveSignal_corres) + prefer 3 + apply (rule corres_trivial) + apply (clarsimp simp: lookup_failure_map_def)+ + apply (wp get_simple_ko_wp getNotification_wp | wpcw | simp)+ + apply (clarsimp simp: lookup_failure_map_def) + apply (clarsimp simp: valid_cap_def ct_in_state_def) + apply (clarsimp simp: valid_cap'_def capAligned_def) + apply wp+ + apply (rule handleFault_corres) apply simp - apply (wpsimp wp: resolve_address_bits_valid_fault2 simp: lookup_cap_def lookup_cap_and_slot_def lookup_slot_for_thread_def) - apply wp - apply (case_tac epCap; simp split del: if_split) - apply wpsimp - apply wpsimp - apply (rename_tac readright; case_tac readright; simp) - apply wp - apply simp - apply wp - apply (wp getNotification_wp) - apply clarsimp - apply (wpsimp wp: hoare_vcg_imp_lift' simp: valid_fault_def)+ - 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 (erule (1) valid_objsE) - apply (clarsimp simp: valid_obj_def valid_tcb_def tcb_cap_cases_def) - apply (clarsimp simp: invs'_def cur_tcb'_def valid_pspace'_def sch_act_sane_def ct_in_state'_def) + apply (wp get_simple_ko_wp | wpcw | simp)+ + apply (rule hoare_vcg_conj_elimE) + apply (simp add: lookup_cap_def lookup_slot_for_thread_def) + apply wp + apply (simp add: split_def) + apply (wp resolve_address_bits_valid_fault2)+ + apply (wp getNotification_wp | wpcw | simp add: valid_fault_def whenE_def split del: if_split)+ + apply (clarsimp simp add: ct_in_state_def ct_in_state'_def conj_comms invs_valid_tcb_ctable + invs_valid_objs tcb_at_invs invs_psp_aligned invs_cur) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def + ct_in_state'_def sch_act_sane_not) done lemma handleRecv_isBlocking_corres: - "corres dc (einvs and ct_active and scheduler_act_sane and current_time_bounded - and ct_not_queued and ct_not_in_release_q) - (invs' and ct_active' and sch_act_sane and - (\s. \p. ksCurThread s \ set (ksReadyQueues s p))) - (handle_recv isBlocking canReply) (handleRecv isBlocking canReply)" + "corres dc (einvs and ct_active) + (invs' and ct_active' and sch_act_sane) + (handle_recv isBlocking) (handleRecv isBlocking)" apply (rule corres_guard_imp) apply (rule 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 (clarsimp simp: ct_in_state'_def invs'_def valid_state'_def) apply (frule(1) st_tcb_ex_cap'') apply (auto elim: pred_tcb'_weakenE) done @@ -1702,540 +1542,90 @@ 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'\ - handleRecv isBlocking canReply - \\_. invs'\" - apply (simp add: handleRecv_def cong: if_cong split del: if_split) - 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)" - 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 (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) + "\invs' and ct_in_state' simple' and sch_act_sane + and (\s. ex_nonz_cap_to' (ksCurThread s) s) + and (\s. ksCurThread s \ ksIdleThread s)\ + handleRecv isBlocking \\r. invs'\" + apply (simp add: handleRecv_def cong: if_cong) + apply (rule hoare_pre) + apply ((wp getNotification_wp | wpc | simp)+)[1] + apply (clarsimp simp: ct_in_state'_def) + apply ((wp deleteCallerCap_nonz_cap hoare_vcg_all_lift + hoare_lift_Pf2[OF deleteCallerCap_simple + deleteCallerCap_ct'] + | wpc | simp)+)[1] + apply simp + apply (wp deleteCallerCap_nonz_cap hoare_vcg_all_lift + hoare_lift_Pf2[OF deleteCallerCap_simple + deleteCallerCap_ct'] + | wpc | simp add: ct_in_state'_def whenE_def split del: if_split)+ + apply (rule validE_validE_R) + apply (rule_tac Q'="\rv s. invs' s + \ sch_act_sane s + \ thread = ksCurThread s + \ ct_in_state' simple' s + \ ex_nonz_cap_to' thread s + \ thread \ ksIdleThread s + \ (\x \ zobj_refs' rv. ex_nonz_cap_to' x s)" + and E'="\_ _. True" + in hoare_strengthen_postE[rotated]) + apply (clarsimp simp: isCap_simps ct_in_state'_def pred_tcb_at' invs_valid_objs' + sch_act_sane_not obj_at'_def projectKOs pred_tcb_at'_def) + apply (assumption) + apply (wp)+ + apply (clarsimp) + apply (auto elim: st_tcb_ex_cap'' pred_tcb'_weakenE + dest!: st_tcb_at_idle_thread' + simp: ct_in_state'_def sch_act_sane_def) + done lemma setSchedulerAction_obj_at'[wp]: "\obj_at' P p\ setSchedulerAction sa \\rv. obj_at' P p\" unfolding setSchedulerAction_def by (wp, clarsimp elim!: obj_at'_pspaceI) -lemma live_sc'_ex_cap: - "if_live_then_nonz_cap' s \ - \ko. ko_at' ko scPtr s \ live_sc' ko \ ex_nonz_cap_to' scPtr s" - by (clarsimp simp: obj_at'_real_def ko_wp_at'_def projectKOs - elim!: if_live_then_nonz_capE') - -lemma valid_sc_strengthen: - "valid_objs' s \ - \ko. ko_at' ko scPtr s \ - valid_sched_context' ko s \ valid_sched_context_size' ko" - by (clarsimp elim!: sc_ko_at_valid_objs_valid_sc') - -lemma endTimeslice_corres: (* called when ct_schedulable *) - "corres dc - (invs and valid_list and valid_sched_action and active_scs_valid and valid_release_q - and valid_ready_qs and cur_sc_active and ct_active and current_time_bounded - and ct_not_queued - and cur_sc_tcb_are_bound and scheduler_act_sane) - invs' - (end_timeslice canTimeout) (endTimeslice canTimeout)" - (is "corres _ ?pre ?pre' _ _") - unfolding end_timeslice_def endTimeslice_def isValidTimeoutHandler_def bind_assoc - apply (rule_tac Q="\s. sc_at' (ksCurSc s) s" in corres_cross_add_guard) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def - dest!: state_relationD) - apply (erule (2) sc_at_cross) - apply (fastforce simp: cur_sc_tcb_def sc_tcb_sc_at_def obj_at_def is_sc_obj - 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 add_cur_tcb' - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule_tac P="?pre and (\s. ct = cur_thread s)" - and P'="?pre' and (\s. is_active_sc' (ksCurSc s) s) and cur_tcb' - and (\s. sc_at' (ksCurSc s) s) and (\s. ct = ksCurThread s)" in corres_inst) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF getCurSc_corres]) - apply (rule_tac P="?pre and (\s. ct = cur_thread s) and (\s. sc_ptr = cur_sc s)" - and P'="?pre' and (\s. is_active_sc' (ksCurSc s) s) and cur_tcb' - and (\s. sc_at' (ksCurSc s) s) and (\s. ct = ksCurThread s) and (\s. sc_ptr = ksCurSc s)" in corres_inst) - apply (rule corres_guard_imp) - apply (rule corres_split[OF get_sc_corres]) - apply (rule corres_split_eqr[OF refillReady_corres]) - apply (rule corres_split_eqr[OF refillSufficient_corres]) - apply simp - apply (rule_tac P="?pre and (\s. ct = cur_thread s) and (\s. sc_ptr = cur_sc s) - and (\s. ready = is_refill_ready sc_ptr s) - and (\s. sufficient = is_refill_sufficient 0 sc_ptr s)" - and P'="?pre' and (\s. is_active_sc' (ksCurSc s) s) and cur_tcb' - and (\s. sc_at' (ksCurSc s) s) and (\s. sc_ptr = ksCurSc s) and (\s. ct = ksCurThread s)" in corres_inst) - apply (simp split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getObject_TCB_corres]) - apply (rename_tac tcb tcb') - apply (rule_tac F="cap_relation (tcb_timeout_handler tcb) (cteCap (tcbTimeoutHandler tcb'))" - in corres_req) - apply (clarsimp simp: tcb_relation_def) - apply (rule_tac F="is_ep_cap (tcb_timeout_handler tcb) - = isEndpointCap (cteCap (tcbTimeoutHandler tcb'))" - in corres_req) - apply (case_tac "tcb_timeout_handler tcb"; - case_tac "cteCap (tcbTimeoutHandler tcb')"; - clarsimp simp: cap_relation_def isEndpointCap_def) - apply (rule corres_symb_exec_r) - apply (rule_tac P="?pre and (\s. ct = cur_thread s) and (\s. sc_ptr = cur_sc s) - and (\s. ready = is_refill_ready sc_ptr s) and ko_at (TCB tcb) ct - and (\s. sufficient = is_refill_sufficient 0 sc_ptr s)" - and P'="?pre' and cur_tcb' and (\s. ct = ksCurThread s) - and (\s. sc_at' (ksCurSc s) s) and (\s. is_active_sc' (ksCurSc s) s) and (\s. sc_ptr = ksCurSc s) and - K (valid = isEndpointCap (cteCap (tcbTimeoutHandler tcb')))" - in corres_inst) - apply (rule corres_gen_asm2') - apply (rule corres_guard_imp) - apply (rule corres_if2) - apply clarsimp - apply simp - apply (rule handleTimeout_corres) - apply clarsimp - apply (clarsimp simp: sc_relation_def) - apply (rule corres_if2, simp) - apply (rule tcbSchedAppend_corres) - apply (rule postpone_corres) - apply (clarsimp cong: conj_cong imp_cong) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def - valid_fault_def valid_fault_handler_def) - apply (rule conjI impI; clarsimp) - apply (clarsimp simp: ct_in_state_def cte_wp_at_def cur_tcb_def) - apply (clarsimp simp: get_cap_caps_of_state obj_at_def is_tcb - caps_of_state_tcb_index_trans[OF get_tcb_rev] - tcb_cnode_map_def) - apply (frule (1) cur_sc_tcb_are_bound_sym) - apply (clarsimp simp: vs_all_heap_simps sc_tcb_sc_at_def obj_at_def is_tcb_def) - apply (clarsimp simp: invs'_def valid_pspace'_def cur_tcb'_def) - apply (wpsimp wp: getTCB_wp)+ - apply (clarsimp dest!: invs_cur simp: cur_tcb_def) - apply (clarsimp simp: cur_tcb'_def isEndpointCap_def) - apply (wpsimp wp: get_sc_refill_sufficient_wp refillReady_wp)+ - apply (clarsimp dest!: valid_sched_active_scs_valid - simp: invs_def cur_sc_tcb_def valid_state_def valid_pspace_def - sc_tcb_sc_at_def obj_at_def is_sc_obj opt_map_red vs_all_heap_simps - sc_refills_sc_at_def opt_pred_def) - apply (drule (1) valid_sched_context_size_objsI, clarsimp) - apply (drule active_scs_validE[rotated]) - apply (fastforce simp: vs_all_heap_simps) - apply (clarsimp simp: vs_all_heap_simps rr_valid_refills_def valid_refills_def split: if_split_asm) - apply (clarsimp simp: cur_tcb'_def invs'_def valid_pspace'_def - elim!: valid_objs'_valid_refills') - apply wpsimp+ - done - -crunch end_timeslice, refill_reset_rr - for pspace_aligned[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - and valid_list[wp]: valid_list - and cur_sc_active[wp]: cur_sc_active - (wp: crunch_wps set_simple_ko_valid_tcbs cur_sc_active_lift - ignore: set_object) - -crunch refill_reset_rr - for cte_wp_at[wp]: "cte_wp_at P c" - -lemma handle_timeout_valid_sched_action: - "\\s. valid_sched_action s \ released_ipc_queues s \ scheduler_act_not tptr s - \ active_scs_valid s - \ (is_timeout_fault ex \ active_sc_tcb_at tptr s \ released_if_bound_sc_tcb_at tptr s)\ - handle_timeout tptr ex - \\_. valid_sched_action :: det_state \ _\" - unfolding handle_timeout_def - apply (wpsimp wp: send_fault_ipc_valid_sched_action) - done - -lemma end_timeslice_valid_sched_action: - "\valid_sched_action and released_ipc_queues and active_scs_valid and scheduler_act_sane - and cur_sc_tcb_are_bound and cur_sc_active and (\s. sym_refs (state_refs_of s))\ - end_timeslice canTimeout - \\_. valid_sched_action :: det_state \ _\" - unfolding end_timeslice_def - apply (wpsimp wp: handle_timeout_valid_sched_action postpone_valid_sched_action) - apply (frule (1) cur_sc_tcb_are_bound_sym) - apply (intro conjI; clarsimp simp: is_timeout_fault_def del: disjCI) - apply (rule disjI1) - apply (fastforce simp: active_sc_tcb_at_def2 tcb_at_kh_simps pred_map_eq_normalise - dest!: get_tcb_SomeD) - apply (clarsimp simp: sc_at_kh_simps pred_map_eq_def[symmetric]) - 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 valid_release_queue'_def obj_at'_def) - apply (fastforce simp: ex_nonz_cap_to'_def cte_wp_at'_def) - done - -lemma handleTimeout_Timeout_invs': - "\invs' and st_tcb_at' active' tptr\ - handleTimeout tptr (Timeout badge) - \\_. invs'\" - apply (clarsimp simp: handleTimeout_def) - apply (wpsimp wp: sendFaultIPC_invs' set_tcb'.getObject_wp' simp: isValidTimeoutHandler_def) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (rule conjI; clarsimp simp: obj_at'_real_def projectKOs pred_tcb_at'_def) - apply (drule invs_iflive') - apply (erule (1) if_live_then_nonz_capD') - apply (fastforce simp: live_def) - apply (clarsimp simp: ko_wp_at'_def projectKOs opt_map_red) - apply (rule_tac x="0x40" in bexI) - apply (clarsimp simp: cte_wp_at_cases') - apply (drule_tac x="0x40" in spec) - apply (clarsimp simp: objBits_simps) - apply fastforce+ - done - -lemma endTimeslice_invs'[wp]: - "\invs' and ct_active'\ - endTimeslice timeout - \\_. invs'\" - unfolding endTimeslice_def - apply (wpsimp wp: handleTimeout_Timeout_invs' isValidTimeoutHandler_inv hoare_drop_imp) - apply (clarsimp simp: runnable_eq_active') - apply (frule (1) active_ex_cap'[OF _ invs_iflive']) - apply (clarsimp simp: ct_in_state'_def sch_act_sane_def) - done - -crunch setConsumedTime, updateSchedContext - for sch_act_sane[wp]: sch_act_sane - and ct_active'[wp]: ct_active' - (simp: sch_act_sane_def ct_in_state'_def ignore: setSchedContext) - -crunch refillResetRR, refillBudgetCheck - for ct_active'[wp]: ct_active' - and sch_act_sane[wp]: sch_act_sane - and ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' p" - and typ_at'[wp]: "\s. Q (typ_at' P p s)" - and sc_at'_n[wp]: "\s. Q (sc_at'_n n p s)" - (wp: crunch_wps) - -crunch chargeBudget - for typ_at'[wp]: "\s. Q (typ_at' P p s)" - (wp: crunch_wps simp: crunch_simps) - -end - -global_interpretation refillResetRR: typ_at_all_props' "refillResetRR scPtr" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) - -lemma refillResetRR_invs'[wp]: - "refillResetRR scp \invs'\" - unfolding refillResetRR_def - apply (wpsimp wp: updateSchedContext_invs') - apply (intro conjI; clarsimp elim!: live_sc'_ex_cap[OF invs_iflive']) - by (fastforce dest!: valid_sc_strengthen[OF invs_valid_objs'] - simp: valid_sched_context'_def valid_sched_context_size'_def scBits_simps objBits_simps') - -lemmas refill_reset_rr_typ_ats [wp] = - abs_typ_at_lifts [OF refill_reset_rr_typ_at] - -crunch refillResetRR - for ksCurSc[wp]: "\s. P (ksCurSc s)" - -crunch setConsumedTime, refillResetRR - for cur_tcb'[wp]: cur_tcb' - (simp: cur_tcb'_def) - -lemma chargeBudget_corres: - "corres dc - (invs and valid_list and valid_sched_action and active_scs_valid and valid_release_q - and valid_ready_qs and released_ipc_queues and cur_sc_active - and current_time_bounded and cur_sc_chargeable and scheduler_act_sane - and ct_not_queued and ct_not_in_release_q and ct_not_blocked - and cur_sc_offset_ready 0) - invs' - (charge_budget consumed canTimeout) (chargeBudget consumed canTimeout True)" - (is "corres _ (?pred and _ and cur_sc_offset_ready 0) _ _ _") - unfolding chargeBudget_def charge_budget_def ifM_def bind_assoc - apply (rule_tac Q="\s. sc_at' (ksCurSc s) s" in corres_cross_add_guard) - apply clarsimp - apply (frule (1) cur_sc_tcb_sc_at_cur_sc[OF invs_valid_objs invs_cur_sc_tcb]) - apply (drule state_relationD, clarsimp) - apply (erule sc_at_cross; fastforce simp: invs_def valid_state_def valid_pspace_def) - 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) - 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' - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurSc_sp]) - apply (corresKsimp corres: getCurSc_corres) - apply (rule corres_symb_exec_r[rotated, OF getIdleSC_sp]; wpsimp simp: getIdleSC_def) - 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'" - in corres_underlying_split) - apply (clarsimp simp: when_def split del: if_split) - apply (rule corres_if_split; (solves corresKsimp)?) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF isRoundRobin_corres]) - apply (rule corres_split[OF corres_if2], simp) - apply (rule refillResetRR_corres) - apply (rule refillBudgetCheck_corres, simp) - apply (rule updateSchedContext_corres) - apply (fastforce simp: sc_relation_def obj_at'_def projectKOs obj_at_def is_sc_obj - opt_map_red opt_pred_def - dest!: state_relation_sc_relation) - apply (fastforce simp: sc_relation_def obj_at'_def projectKOs obj_at_def is_sc_obj opt_map_red - dest!: state_relation_sc_replies_relation elim: sc_replies_relation_prevs_list) - apply (clarsimp simp: objBits_simps) - apply (wpsimp wp: is_round_robin_wp isRoundRobin_wp)+ - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply (drule (1) active_scs_validE, clarsimp) - apply (clarsimp simp: round_robin_def vs_all_heap_simps obj_at_def) - apply (clarsimp simp: obj_at'_def projectKOs invs'_def valid_pspace'_def elim!: valid_objs'_valid_refills') - apply (rule corres_guard_imp) - apply (rule corres_split[OF setConsumedTime_corres], simp) - apply (simp add: andM_def whenM_def ifM_def when_def[symmetric] bind_assoc) - apply (rule corres_split_eqr[OF getCurThread_corres _ gets_sp getCurThread_sp]) - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF isSchedulable_corres _ is_schedulable_sp' isSchedulable_sp]) - apply (rename_tac sched) - apply (rule corres_guard_imp) - apply (rule corres_when2, simp) - apply (rule corres_split[OF endTimeslice_corres]) - apply (rule corres_split[OF rescheduleRequired_corres]) - apply (rule setReprogramTimer_corres) - apply wpsimp - apply wpsimp - apply (rule hoare_strengthen_post - [where Q'="\_. invs and active_scs_valid - and valid_sched_action", rotated]) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_objs_valid_tcbs - valid_sched_action_def) - apply (wpsimp wp: end_timeslice_invs end_timeslice_valid_sched_action) - apply (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 - isSchedulable_bool_def runnable_eq_active' pred_map_def - obj_at'_def projectKOs pred_tcb_at'_def ct_in_state'_def - elim!: opt_mapE) - apply wpsimp - apply (clarsimp 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 - valid_objs_valid_tcbs state_refs_of_def - dest!: cur_sc_chargeable_when_ct_active_sc) - apply clarsimp - apply wpsimp - apply (clarsimp simp: consumed_time_update_arch.state_refs_update sc_consumed_update_eq[symmetric]) - apply ((wpsimp wp: hoare_vcg_conj_lift; (solves wpsimp)? - | strengthen valid_objs_valid_tcbs | wps)+)[1] - apply wpsimp - apply (wpsimp wp: sc_at_typ_at refill_reset_rr_valid_sched_action) - apply (wpsimp wp: sc_at_typ_at refill_reset_rr_valid_sched_action hoare_vcg_disj_lift - refill_budget_check_valid_sched_action_act_not - refill_budget_check_active_scs_valid - 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] - 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 (simp only: scheduler_act_not_def, rule notI) - apply (drule (1) valid_sched_action_switch_thread_is_schedulable) - apply (clarsimp simp: is_schedulable_opt_def tcb_at_kh_simps[symmetric] pred_tcb_at_def obj_at_def - split: option.split_asm dest!: get_tcb_SomeD) - 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 (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') - apply (wpsimp wp: typ_at_lifts - | strengthen live_sc'_ex_cap[OF invs_iflive'] valid_sc_strengthen[OF invs_valid_objs'])+ - done - -lemma checkBudget_corres: (* called when ct_schedulable or in checkBudgetRestart *) - "corres (=) - (einvs and current_time_bounded and cur_sc_offset_ready 0 and cur_sc_chargeable - and cur_sc_active and ct_not_blocked - and ct_not_queued and ct_not_in_release_q and scheduler_act_sane) - invs' - check_budget checkBudget" - unfolding check_budget_def checkBudget_def - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF getCurSc_corres]) - apply (rule corres_split_eqr[OF getConsumedTime_corres]) - apply (rule corres_split_eqr[OF refillSufficient_corres], simp) - apply (rule corres_if2, simp) - apply (rule corres_split_eqr[OF isCurDomainExpired_corres]) - apply simp - apply wpsimp+ - apply (rule corres_split_eqr[OF getConsumedTime_corres]) - apply (rule corres_split[OF chargeBudget_corres]) - apply simp - apply (wpsimp wp: hoare_drop_imp)+ - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply (clarsimp simp: sc_refills_sc_at_def obj_at_def cur_sc_tcb_def sc_tcb_sc_at_def valid_sched_def) - apply (drule (1) active_scs_validE[rotated]) - apply (clarsimp simp: valid_refills_def vs_all_heap_simps rr_valid_refills_def - split: if_split_asm) - apply clarsimp - done - lemma handleYield_corres: "corres dc - (einvs and ct_active and cur_sc_active and schact_is_rct and scheduler_act_sane - and current_time_bounded and cur_sc_offset_ready 0 - and ct_not_queued and ct_not_in_release_q) - invs' + (einvs and ct_active) + (invs' and (\s. ksSchedulerAction s = ResumeCurrentThread)) handle_yield handleYield" - (is "corres _ ?pre ?pre' _ _") - apply (rule_tac Q=ct_active' in corres_cross_add_guard) - apply (fastforce intro!: ct_active_cross simp: invs_def valid_state_def valid_pspace_def) - apply (rule_tac Q="\s. sc_at' (ksCurSc s) s" in corres_cross_add_guard) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def - dest!: state_relationD schact_is_rct) - apply (erule (2) sc_at_cross) - apply (fastforce simp: cur_sc_tcb_def sc_tcb_sc_at_def obj_at_def is_sc_obj - dest: valid_sched_context_size_objsI) apply (clarsimp simp: handle_yield_def handleYield_def) apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF getCurSc_corres]) - apply (rule corres_split[OF get_sc_corres]) - apply (erule exE) - apply (rename_tac cursc sc sc' n) - apply (rule_tac P="(\s. scs_of2 s cursc = Some sc) and ?pre - and (\s. cur_sc s = cursc)" - and P'="?pre' and ko_at' sc' cursc" - in corres_inst) - apply (rule_tac Q="\rv. (\s. scs_of2 s cursc = Some sc) and ?pre - and (\s. cur_sc s = cursc) and K (sc_refills sc = rv)" - and P'="?pre' and ko_at' sc' cursc" - in corres_symb_exec_l) - apply (rename_tac refills) - apply (rule corres_gen_asm') - apply (rule_tac F="r_amount (hd refills) = rAmount (refillHd sc')" in corres_req) - apply (clarsimp dest!: invs_valid_objs' invs_valid_objs simp: obj_at_def obj_at'_def projectKOs - split: Structures_A.kernel_object.splits elim!: opt_mapE) - apply (erule (1) valid_objsE', clarsimp simp: valid_obj'_def) - apply (frule (1) refill_hd_relation2[rotated -1]) - apply (drule (1) active_scs_validE[OF _ valid_sched_active_scs_valid]) - apply (clarsimp simp: valid_refills_def vs_all_heap_simps rr_valid_refills_def - split: if_split_asm) - apply clarsimp - apply simp - apply (rule corres_guard_imp) - apply (rule corres_split[OF chargeBudget_corres]) - apply (rule updateSchedContext_corres) - apply clarsimp - apply (drule (2) state_relation_sc_relation) - apply (clarsimp simp: sc_relation_def obj_at_simps is_sc_obj opt_map_red opt_pred_def) - apply clarsimp - apply (frule (2) state_relation_sc_relation) - apply (drule state_relation_sc_replies_relation) - apply (fastforce simp: sc_relation_def obj_at_simps is_sc_obj opt_map_red - elim: sc_replies_relation_prevs_list) - apply (clarsimp simp: objBits_simps) - apply (rule sc_at_typ_at, wp) - apply (wpsimp wp: typ_at_lifts) - apply (clarsimp simp: valid_sched_def opt_map_def obj_at_def is_sc_obj - split: option.split_asm Structures_A.kernel_object.split_asm) - apply (frule (1) valid_sched_context_size_objsI[OF invs_valid_objs], clarsimp) - apply (frule (1) invs_cur_sc_chargeableE) - apply fastforce - apply clarsimp - apply wpsimp - apply (fastforce intro: cur_sc_tcb_sc_at_cur_sc) - apply simp - apply (wpsimp wp: get_refills_wp) - apply (clarsimp simp: obj_at_def is_sc_obj elim!: opt_mapE) - apply (wpsimp simp: get_refills_def split: Structures_A.kernel_object.splits) - apply (fastforce simp: obj_at_def cur_sc_tcb_def sc_tcb_sc_at_def - dest!: invs_cur_sc_tcb) - apply wpsimp+ - apply (frule invs_valid_objs) - apply (fastforce simp: obj_at_def is_sc_obj cur_sc_tcb_def sc_tcb_sc_at_def opt_map_red - dest!: invs_cur_sc_tcb schact_is_rct elim: valid_sched_context_size_objsI) - apply clarsimp + apply (rule corres_split[OF getCurThread_corres]) + apply simp + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF tcbSchedAppend_corres], simp) + apply (rule rescheduleRequired_corres) + apply (wpsimp wp: weak_sch_act_wf_lift_linear + | strengthen valid_objs'_valid_tcbs' valid_queues_in_correct_ready_q + valid_queues_ready_qs_distinct)+ + apply (simp add: invs_def valid_sched_def valid_sched_action_def cur_tcb_def + tcb_at_is_etcb_at valid_state_def valid_pspace_def ct_in_state_def + runnable_eq_active) + apply (fastforce simp: invs'_def valid_state'_def ct_in_state'_def sch_act_wf_weak cur_tcb'_def + valid_pspace_valid_objs' valid_objs'_maxDomain tcb_in_cur_domain'_def) + done + +lemma tcbSchedAppend_ct_in_state'[wp]: + "tcbSchedAppend t \ct_in_state' test\" + apply (simp add: ct_in_state'_def) + apply (rule hoare_lift_Pf [where f=ksCurThread]; wp) done -lemma chargeBudget_invs'[wp]: - "chargeBudget consumed canTimeout Flag \invs'\" - unfolding chargeBudget_def ifM_def bind_assoc - apply (rule bind_wp[OF _ getCurSc_sp]) - apply (wpsimp wp: isSchedulable_wp) - apply (rule hoare_strengthen_post[where Q'="\_. invs'"]) - apply wpsimp - apply (clarsimp simp: isSchedulable_bool_def obj_at'_def projectKOs - pred_map_def ct_in_state'_def pred_tcb_at'_def runnable_eq_active' - elim!: opt_mapE) - by (wpsimp wp: hoare_drop_imp updateSchedContext_invs' - | strengthen live_sc'_ex_cap[OF invs_iflive'] valid_sc_strengthen[OF invs_valid_objs'])+ - lemma hy_invs': - "handleYield \invs'\" + "\invs' and ct_active'\ handleYield \\r. invs' and ct_active'\" 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'])+ + apply (wpsimp wp: ct_in_state_thread_state_lift' rescheduleRequired_all_invs_but_ct_not_inQ) + apply (rule_tac Q'="\_. all_invs_but_ct_not_inQ' and ct_active'" in hoare_post_imp) + apply clarsimp + apply (subst pred_conj_def) + apply (rule hoare_vcg_conj_lift) + apply (rule tcbSchedAppend_all_invs_but_ct_not_inQ') + apply wpsimp + apply wpsimp + apply wpsimp + apply (simp add:ct_active_runnable'[unfolded ct_in_state'_def]) + done lemma getDFSR_invs'[wp]: "valid invs' (doMachineOp getDFSR) (\_. invs')" @@ -2281,46 +1671,118 @@ lemma simple_from_running': by (clarsimp elim!: pred_tcb'_weakenE simp: ct_in_state'_def)+ +lemma handleReply_corres: + "corres dc (einvs and ct_running) (invs' and ct_running') + handle_reply handleReply" + apply (simp add: handle_reply_def handleReply_def + getThreadCallerSlot_map + getSlotCap_def) + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF getCurThread_corres]) + apply (rule corres_split[OF get_cap_corres]) + apply (rule_tac P="einvs and cte_wp_at ((=) caller_cap) (thread, tcb_cnode_index 3) + and K (is_reply_cap caller_cap \ caller_cap = cap.NullCap) + and tcb_at thread and st_tcb_at active thread + and valid_cap caller_cap" + and P'="invs' and tcb_at' thread + and valid_cap' (cteCap rv') + and cte_at' (cte_map (thread, tcb_cnode_index 3))" + in corres_inst) + apply (auto split: cap_relation_split_asm arch_cap.split_asm bool.split + intro!: corres_guard_imp [OF deleteCallerCap_corres] + corres_guard_imp [OF doReplyTransfer_corres] + corres_fail + simp: valid_cap_def valid_cap'_def is_cap_simps assert_def is_reply_cap_to_def)[1] + apply (fastforce simp: invs_def valid_state_def + cte_wp_at_caps_of_state st_tcb_def2 + dest: valid_reply_caps_of_stateD) + apply (wp get_cap_cte_wp_at get_cap_wp | simp add: cte_wp_at_eq_simp)+ + apply (intro conjI impI allI, + (fastforce simp: invs_def valid_state_def + intro: tcb_at_cte_at)+) + apply (clarsimp, frule tcb_at_invs) + apply (fastforce dest: tcb_caller_cap simp: cte_wp_at_def) + apply clarsimp + apply (clarsimp simp: ct_in_state_def elim!: st_tcb_weakenE) + apply (fastforce intro: cte_wp_valid_cap elim: cte_wp_at_weakenE) + apply (fastforce intro: tcb_at_cte_at_map) + done -crunch cteDeleteOne - for ksCurThread[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps - simp: crunch_simps unless_def) +lemma hr_invs'[wp]: + "\invs' and sch_act_simple\ handleReply \\rv. invs'\" + apply (simp add: handleReply_def getSlotCap_def + getThreadCallerSlot_map getCurThread_def) + apply (wp getCTE_wp | wpc | simp)+ + apply (clarsimp simp: cte_wp_at_ctes_of) + apply (drule ctes_of_valid', clarsimp+) + apply (simp add: valid_cap'_def) + apply (simp add: invs'_def cur_tcb'_def) + done + +crunch handleReply + for ksCurThread[wp]: "\s. P (ksCurThread s)" + (wp: crunch_wps transferCapsToSlots_pres1 setObject_ep_ct + setObject_ntfn_ct + simp: unless_def crunch_simps + ignore: transferCapsToSlots) lemmas cteDeleteOne_st_tcb_at_simple'[wp] = cteDeleteOne_st_tcb_at[where P=simple', simplified] +crunch handleReply + for st_tcb_at_simple'[wp]: "st_tcb_at' simple' t'" + (wp: hoare_TrueI crunch_wps sts_st_tcb_at'_cases + threadSet_pred_tcb_no_state + ignore: setThreadState) + +lemmas handleReply_ct_in_state_simple[wp] = + ct_in_state_thread_state_lift' [OF handleReply_ksCurThread + handleReply_st_tcb_at_simple'] + + +(* FIXME: move *) +lemma doReplyTransfer_st_tcb_at_active: + "\st_tcb_at' active' t and tcb_at' t' and K (t \ t') and + cte_wp_at' (\cte. cteCap cte = (capability.ReplyCap t' False g)) sl\ + doReplyTransfer t t' sl g + \\rv. st_tcb_at' active' t\" + apply (simp add: doReplyTransfer_def liftM_def) + apply (wp setThreadState_st_tcb sts_pred_tcb_neq' cteDeleteOne_reply_pred_tcb_at + hoare_drop_imps threadSet_pred_tcb_no_state hoare_exI + doIPCTransfer_non_null_cte_wp_at2' | wpc | clarsimp simp:isCap_simps)+ + apply (fastforce) + done + +lemma hr_ct_active'[wp]: + "\invs' and ct_active'\ handleReply \\rv. ct_active'\" + apply (simp add: handleReply_def getSlotCap_def getCurThread_def + getThreadCallerSlot_def locateSlot_conv) + apply (rule bind_wp, rename_tac cur_thread) + apply (rule_tac t=cur_thread in ct_in_state'_decomp) + apply (wpsimp wp: getCTE_wp) + apply (fastforce simp: cte_wp_at_ctes_of) + apply (wpsimp wp: getCTE_wp doReplyTransfer_st_tcb_at_active)+ + apply (fastforce simp: ct_in_state'_def cte_wp_at_ctes_of valid_cap'_def + dest: ctes_of_valid') + done + lemma handleCall_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)) + "corres (dc \ dc) (einvs and schact_is_rct and ct_active) (invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and (\s. ksSchedulerAction s = ResumeCurrentThread) and ct_active') handle_call handleCall" - apply add_cur_tcb' - 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) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getCapReg_corres]) - apply (simp, rule handleInvocation_corres; simp) - apply wpsimp+ - done + by (simp add: handle_call_def handleCall_def liftE_bindE handleInvocation_corres) lemma hc_invs'[wp]: "\invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and (\s. ksSchedulerAction s = ResumeCurrentThread) and - ct_isSchedulable\ - handleCall - \\_. invs'\" - apply (clarsimp simp: handleCall_def) - apply (rule validE_valid) - apply (rule bindE_wp[OF _ stateAssertE_sp]) - apply wpsimp + ct_active'\ + handleCall + \\rv. invs'\" + apply (simp add: handleCall_def) + apply (wp) + apply (clarsimp) done lemma cteInsert_sane[wp]: @@ -2330,13 +1792,84 @@ lemma cteInsert_sane[wp]: hoare_convert_imp [OF cteInsert_nosch cteInsert_ct]) done -crunch setExtraBadge, transferCaps, handleFaultReply, doIPCTransfer - for sch_act_sane [wp]: sch_act_sane - (wp: crunch_wps simp: crunch_simps) +crunch setExtraBadge + for sane[wp]: sch_act_sane + +crunch transferCaps + for sane[wp]: "sch_act_sane" + (wp: transferCapsToSlots_pres1 crunch_wps + simp: crunch_simps + ignore: transferCapsToSlots) + +lemma possibleSwitchTo_sane: + "\\s. sch_act_sane s \ t \ ksCurThread s\ possibleSwitchTo t \\_. sch_act_sane\" + apply (simp add: possibleSwitchTo_def setSchedulerAction_def curDomain_def + cong: if_cong) + apply (wp hoare_drop_imps | wpc)+ + apply (simp add: sch_act_sane_def) + done + +crunch handleFaultReply + for sane[wp]: sch_act_sane + ( wp: threadGet_inv hoare_drop_imps crunch_wps + simp: crunch_simps + ignore: setSchedulerAction) + +crunch doIPCTransfer + for sane[wp]: sch_act_sane + ( wp: threadGet_inv hoare_drop_imps crunch_wps + simp: crunch_simps + ignore: setSchedulerAction) + +lemma doReplyTransfer_sane: + "\\s. sch_act_sane s \ t' \ ksCurThread s\ + doReplyTransfer t t' callerSlot g \\rv. sch_act_sane\" + apply (simp add: doReplyTransfer_def liftM_def) + apply (wp possibleSwitchTo_sane hoare_drop_imps hoare_vcg_all_lift|wpc)+ + apply simp + done + +lemma handleReply_sane: + "\sch_act_sane\ handleReply \\rv. sch_act_sane\" + apply (simp add: handleReply_def getSlotCap_def getThreadCallerSlot_def locateSlot_conv) + apply (rule hoare_pre) + apply (wp doReplyTransfer_sane getCTE_wp'| wpc)+ + apply (clarsimp simp: cte_wp_at_ctes_of) + done + +lemma handleReply_nonz_cap_to_ct: + "\ct_active' and invs' and sch_act_simple\ + handleReply + \\rv s. ex_nonz_cap_to' (ksCurThread s) s\" + apply (rule_tac Q'="\rv. ct_active' and invs'" + in hoare_post_imp) + apply (auto simp: ct_in_state'_def elim: st_tcb_ex_cap'')[1] + apply (wp | simp)+ + done crunch handleFaultReply for ksQ[wp]: "\s. P (ksReadyQueues s p)" +crunch possible_switch_to, handle_recv + for valid_etcbs[wp]: "valid_etcbs" + (wp: crunch_wps simp: crunch_simps) + +lemma handleReply_handleRecv_corres: + "corres dc (einvs and ct_running) + (invs' and ct_running' and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (do x \ handle_reply; handle_recv True od) + (do x \ handleReply; handleRecv True od)" + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF handleReply_corres]) + apply (rule handleRecv_isBlocking_corres') + apply (wp handle_reply_nonz_cap_to_ct handleReply_sane + handleReply_nonz_cap_to_ct handle_reply_valid_sched)+ + apply (fastforce simp: ct_in_state_def ct_in_state'_def simple_sane_strg + elim!: st_tcb_weakenE st_tcb_ex_cap') + apply (clarsimp simp: ct_in_state'_def) + apply (fastforce elim: pred_tcb'_weakenE) + done + lemma handleHypervisorFault_corres: "corres dc (einvs and st_tcb_at active thread and ex_nonz_cap_to thread and (%_. valid_fault f)) @@ -2347,6 +1880,108 @@ lemma handleHypervisorFault_corres: apply (cases fault; clarsimp simp add: handleHypervisorFault_def returnOk_def2) done +(* FIXME: move *) +lemma handleEvent_corres: + "corres (dc \ dc) (einvs and (\s. event \ Interrupt \ ct_running s) and + schact_is_rct) + (invs' and (\s. event \ Interrupt \ ct_running' s) and + (\s. vs_valid_duplicates' (ksPSpace s)) and + (\s. ksSchedulerAction s = ResumeCurrentThread)) + (handle_event event) (handleEvent event)" + (is "?handleEvent_corres") +proof - + have hw: + "\isBlocking. corres dc (einvs and ct_running and schact_is_rct) + (invs' and ct_running' + and (\s. ksSchedulerAction s = ResumeCurrentThread)) + (handle_recv isBlocking) (handleRecv isBlocking)" + apply (rule corres_guard_imp [OF handleRecv_isBlocking_corres]) + apply (clarsimp simp: ct_in_state_def ct_in_state'_def + elim!: st_tcb_weakenE pred_tcb'_weakenE)+ + done + show ?thesis + apply (case_tac event) + apply (simp_all add: handleEvent_def) + + apply (rename_tac syscall) + apply (case_tac syscall) + apply (auto intro: corres_guard_imp[OF handleSend_corres] + corres_guard_imp[OF hw] + corres_guard_imp [OF handleReply_corres] + corres_guard_imp[OF handleReply_handleRecv_corres] + corres_guard_imp[OF handleCall_corres] + corres_guard_imp[OF handleYield_corres] + active_from_running active_from_running' + simp: simple_sane_strg schact_is_rct_def)[8] + apply (rule corres_underlying_split) + apply (rule corres_guard_imp[OF getCurThread_corres], simp+) + apply (rule handleFault_corres) + apply simp + apply (simp add: valid_fault_def) + apply wp + apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE + simp: ct_in_state_def) + apply wp + apply (clarsimp) + apply (auto simp: ct_in_state'_def sch_act_simple_def + sch_act_sane_def + elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] + apply (rule corres_underlying_split) + apply (rule corres_guard_imp, rule getCurThread_corres, simp+) + apply (rule handleFault_corres) + apply (simp add: valid_fault_def) + apply wp + apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE + simp: ct_in_state_def valid_fault_def) + apply wp + apply clarsimp + apply (auto simp: ct_in_state'_def sch_act_simple_def + sch_act_sane_def + elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[where R="\_. einvs" + and R'="\rv s. \x. rv = Some x \ R'' x s" + for R'']) + apply (rule corres_machine_op) + apply (rule corres_Id, simp+) + apply wp + apply (case_tac rv, simp_all add: doMachineOp_return)[1] + apply (rule handleInterrupt_corres) + apply (wp hoare_vcg_all_lift + doMachineOp_getActiveIRQ_IRQ_active' + | simp add: imp_conjR | wp (once) hoare_drop_imps)+ + apply (simp add: invs'_def valid_state'_def) + apply (rule_tac corres_underlying_split) + apply (rule corres_guard_imp, rule getCurThread_corres, simp+) + apply (rule corres_split_catch) + apply (rule handleVMFault_corres) + apply (erule handleFault_corres) + apply (rule hoare_elim_pred_conjE2) + apply (rule hoare_vcg_conj_liftE_E, rule valid_validE_E, wp) + apply (wp handle_vm_fault_valid_fault) + apply (rule hv_inv_ex') + apply wp + apply (clarsimp simp: simple_from_running tcb_at_invs) + apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE simp: ct_in_state_def) + apply wp + 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 (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 (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE + simp: ct_in_state_def) + apply wp + apply (clarsimp) + apply (auto simp: ct_in_state'_def sch_act_simple_def + sch_act_sane_def + elim: pred_tcb'_weakenE st_tcb_ex_cap'')[1] + done + qed + crunch handleVMFault,handleHypervisorFault for st_tcb_at'[wp]: "st_tcb_at' P t" and cap_to'[wp]: "ex_nonz_cap_to' t" @@ -2385,601 +2020,81 @@ proof qed lemma ct_running_not_idle'[simp]: - "\valid_idle' s; ct_running' s\ \ ksCurThread s \ ksIdleThread s" + "\invs' s; ct_running' s\ \ ksCurThread s \ ksIdleThread s" apply (rule ct_not_idle') - apply (fastforce simp: ct_in_state'_def + apply (fastforce simp: invs'_def valid_state'_def 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" + "\invs' s; ct_active' s\ \ ksCurThread s \ ksIdleThread s" apply (rule ct_not_idle') - apply (fastforce simp: ct_in_state'_def + apply (fastforce simp: invs'_def valid_state'_def 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) - -lemma checkBudget_true: - "\P\ checkBudget \\rv s. rv \ P s\" - unfolding checkBudget_def - by (wpsimp | rule hoare_drop_imp)+ - -lemma checkBudgetRestart_true: - "\P\ checkBudgetRestart \\rv s. rv \ P s\" - unfolding checkBudgetRestart_def - apply (wpsimp wp: checkBudget_true) - apply (rule hoare_drop_imp) - apply (wpsimp wp: checkBudget_true) - by clarsimp - -lemma checkBudgetRestart_false: - "\P\ checkBudgetRestart \\rv s. Q s\ \ \P\ checkBudgetRestart \\rv s. \ rv \ Q s\" - by (wpsimp wp: hoare_drop_imp) - -crunch checkBudget - for invs'[wp]: invs' - -lemma checkBudgetRestart_invs'[wp]: - "checkBudgetRestart \invs'\" - unfolding checkBudgetRestart_def - 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 ko_wp_at'_def projectKOs opt_map_red is_BlockedOnReply_def)+ - -lemma setEndpoint_valid_duplicates'[wp]: - "setObject a (ep::endpoint) \\s. vs_valid_duplicates' (ksPSpace s)\" - apply (clarsimp simp: setObject_def split_def valid_def in_monad - projectKOs pspace_aligned'_def ps_clear_upd - objBits_def[symmetric] lookupAround2_char1 - split: if_split_asm) - apply (frule pspace_storable_class.updateObject_type[where v = ep,simplified]) - apply (clarsimp simp: updateObject_default_def assert_def bind_def - alignCheck_def in_monad when_def alignError_def magnitudeCheck_def - assert_opt_def return_def fail_def typeError_def - split: if_splits option.splits Structures_H.kernel_object.splits) - apply (erule valid_duplicates'_non_pd_pt_I[rotated 3],simp+)+ - done - -lemma setSchedContext_valid_duplicates'[wp]: - "setObject a (sc::sched_context) \\s. vs_valid_duplicates' (ksPSpace s)\" - apply (clarsimp simp: setObject_def split_def valid_def in_monad - projectKOs pspace_aligned'_def ps_clear_upd - objBits_def[symmetric] lookupAround2_char1 - split: if_split_asm) - apply (frule pspace_storable_class.updateObject_type[where v = sc,simplified]) - apply (clarsimp simp: updateObject_default_def assert_def bind_def - alignCheck_def in_monad when_def alignError_def magnitudeCheck_def - assert_opt_def return_def fail_def typeError_def - split: if_splits option.splits Structures_H.kernel_object.splits) - apply (erule valid_duplicates'_non_pd_pt_I[rotated 3],simp+)+ - done - -lemma setReply_valid_duplicates'[wp]: - "setObject a (r::reply) \\s. vs_valid_duplicates' (ksPSpace s)\" - apply (clarsimp simp: setObject_def split_def valid_def in_monad - projectKOs pspace_aligned'_def ps_clear_upd - objBits_def[symmetric] lookupAround2_char1 - split: if_split_asm) - apply (frule pspace_storable_class.updateObject_type[where v = r,simplified]) - apply (clarsimp simp: updateObject_default_def assert_def bind_def - alignCheck_def in_monad when_def alignError_def magnitudeCheck_def - assert_opt_def return_def fail_def typeError_def - split: if_splits option.splits Structures_H.kernel_object.splits) - apply (erule valid_duplicates'_non_pd_pt_I[rotated 3],simp+)+ - done - -crunch check_budget - for cur_tcb[wp]: cur_tcb - and pspace_aligned[wp]: pspace_aligned - and pspace_distinct[wp]: pspace_distinct - (wp: crunch_wps simp: crunch_simps) - -crunch checkBudgetRestart - for valid_duplicates''[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - and ksInterruptState[wp]: "\s. P (ksInterruptState s)" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps simp: crunch_simps) - -lemma getCurrentTime_invs'[wp]: - "doMachineOp getCurrentTime \invs'\" - apply (simp add: getCurrentTime_def modify_def) - apply (wpsimp wp: dmo_invs' simp: modify_def) - by (simp add: in_get put_def gets_def in_bind in_return) - -lemma invs'_ksCurTime_update[iff]: - "invs' (ksCurTime_update f s) = invs' s" - by (clarsimp simp: invs'_def valid_pspace'_def valid_mdb'_def - valid_queues_def valid_queues_no_bitmap_def valid_bitmapQ_def bitmapQ_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def valid_irq_node'_def - valid_machine_state'_def valid_queues'_def valid_release_queue_def - valid_release_queue'_def valid_dom_schedule'_def) - -crunch setDomainTime, setCurTime, setConsumedTime, setExtraBadge, setReleaseQueue, setQueue, - modifyReadyQueuesL1Bitmap, modifyReadyQueuesL2Bitmap, setReprogramTimer - for ct_in_state'[wp]: "ct_in_state' P" - and isSchedulable[wp]: "isSchedulable_bool p" - and scs_of'_ct[wp]: "\s. P (scs_of' s) (ksCurThread s)" - and isScActive_ct[wp]: "\s. P (isScActive p s) (tcbSCs_of s) (ksCurThread s)" - and pred_map_sc_active_ct[wp]: "\s. pred_map (\p. isScActive p s) (tcbSCs_of s) (ksCurThread s)" - (simp: ct_in_state'_def isScActive_def isSchedulable_bool_def) - -crunch updateTimeStamp, tcbSchedAppend, postpone - for invs'[wp]: invs' - and ct_in_state'[wp]: "ct_in_state' P" - and ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - and valid_duplicates''[wp]: "\s. vs_valid_duplicates' (ksPSpace s)" - and ksInterruptState[wp]: "\s. P (ksInterruptState s)" - (ignore: doMachineOp wp: crunch_wps) - -crunch updateTimeStamp - for tcbSCs_of_scTCBs_of[wp]: "\s. P (tcbSCs_of s) (scTCBs_of s)" - and tcbs_of'_ct[wp]: "\s. P (tcbs_of' s) (ksCurThread s)" - and tcbSCs_of_ct[wp]: "\s. P (tcbSCs_of s) (ksCurThread s)" - and isScActive_ct[wp]: "\s. P (isScActive p s) (tcbSCs_of s) (ksCurThread s)" - and pred_map_sc_active_ct[wp]: "\s. pred_map (\p. isScActive p s) (tcbSCs_of s) (ksCurThread s)" - and typ_at[wp]: "\s. P (typ_at' T p s)" - and pred_tcb_at'[wp]: "\s. P (pred_tcb_at' proj Q p s)" - -lemma installThreadBuffer_ksCurThread[wp]: - "installThreadBuffer target slot buffer \\s. P (ksCurThread s)\ " - unfolding installThreadBuffer_def - by (wpsimp wp: checkCap_inv hoare_drop_imp cteDelete_preservation) - -crunch ARM_H.performInvocation - for ksCurThread[wp]: "\s. P (ksCurThread s)" - (simp: crunch_simps wp: crunch_wps getObject_inv) - -crunch resetUntypedCap - for ksCurThread[wp]: "\s. P (ksCurThread s)" - (simp: crunch_simps wp: mapME_x_inv_wp preemptionPoint_inv crunch_wps) - -crunch performInvocation - for ksCurThread[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps cteRevoke_preservation filterM_preserved cteDelete_preservation - hoare_drop_imps hoare_vcg_all_lift - simp: crunch_simps) + (wp: hoare_drop_imps crunch_wps simp: crunch_simps) lemma he_invs'[wp]: "\invs' and (\s. event \ Interrupt \ ct_running' s) and - (\s. ct_running' s \ ct_isSchedulable s) and (\s. vs_valid_duplicates' (ksPSpace s)) and (\s. ksSchedulerAction s = ResumeCurrentThread)\ handleEvent event \\rv. invs'\" proof - - have nidle: "\s. valid_idle' s \ ct_active' s \ ksCurThread s \ ksIdleThread s" + have nidle: "\s. invs' 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 - | rule conjI active_ex_cap' - | drule ct_not_ksQ[rotated] - | 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 simp: ct_in_state'_def - | wpc)+ - done -qed - -lemma released_imp_active_sc_tcb_at: - "released_sc_tcb_at t s \ active_sc_tcb_at t s" - by (clarsimp simp: vs_all_heap_simps) - -lemma checkBudgetRestart_corres: - "corres (=) - (einvs and current_time_bounded and cur_sc_offset_ready 0 - and cur_sc_active and ct_in_state activatable and schact_is_rct - and ct_not_queued and ct_not_in_release_q) - invs' - check_budget_restart checkBudgetRestart" - unfolding check_budget_restart_def checkBudgetRestart_def - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF checkBudget_corres]) - apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule corres_split[OF isRunnable_corres']) - apply simp - apply (clarsimp simp add: when_def) - apply (rule corres_split[OF setThreadState_corres]) - apply clarsimp - apply clarsimp - apply ((wpsimp simp: cur_tcb_def[symmetric] cong: conj_cong | strengthen valid_objs_valid_tcbs)+)[6] - apply (rule hoare_strengthen_post[where Q'="\_. invs and cur_tcb"]) - apply wpsimp - apply (clarsimp simp: cur_tcb_def invs_def valid_state_def valid_pspace_def) - apply (rule hoare_strengthen_post[where Q'="\_. invs'"]) - apply wpsimp - apply (fastforce simp: invs'_def valid_pspace'_def valid_objs'_valid_tcbs' - dest!: invs_strengthen_cur_sc_tcb_are_bound) - apply (clarsimp simp: invs_cur_sc_chargeableE invs_cur ct_activatable_ct_not_blocked)+ + apply (rename_tac syscall) + apply (case_tac syscall, + (wp handleReply_sane handleReply_nonz_cap_to_ct handleReply_ksCurThread + | clarsimp simp: active_from_running' simple_from_running' simple_sane_strg simp del: split_paired_All + | 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' + | rule conjI + | erule pred_tcb'_weakenE st_tcb_ex_cap'' + | clarsimp simp: tcb_at_invs ct_in_state'_def simple_sane_strg sch_act_simple_def + | drule st_tcb_at_idle_thread' + | wpc | wp (once) hoare_drop_imps)+ done +qed -lemma handleInv_handleRecv_corres: - "corres (dc \ dc) - (einvs and ct_running and (\s. scheduler_action s = resume_cur_thread) and - valid_machine_time and - current_time_bounded and - consumed_time_bounded and - cur_sc_active and - ct_released and - ct_not_in_release_q and - ct_not_queued and - (\s. cur_sc_offset_ready (consumed_time s) s) and - (\s. cur_sc_offset_sufficient (consumed_time s) s)) - (invs' and ct_running' and (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (doE reply_cptr <- liftE (get_cap_reg reg); - y <- handle_invocation False False True True reply_cptr; - liftE (handle_recv True canReply) - odE) - (doE replyCptr <- liftE (getCapReg reg); - y <- handleInvocation False False True True replyCptr; - y \ stateAssertE sch_act_sane_asrt []; - y \ stateAssertE ct_not_ksQ_asrt []; - y \ stateAssertE ct_active'_asrt []; - liftE (handleRecv True canReply) - odE)" - apply add_cur_tcb' - apply (rule_tac Q="\s'. pred_map (\scPtr. isScActive scPtr s') (tcbSCs_of s') (ksCurThread s')" - in corres_cross_add_guard) - apply (clarsimp simp: released_sc_tcb_at_def active_sc_tcb_at_def2) - apply (prop_tac "scp = cur_sc s") - apply (drule invs_cur_sc_tcb_symref, clarsimp simp: schact_is_rct_def) - apply (clarsimp simp: pred_tcb_at_def obj_at_def) - apply (prop_tac "sc_at (cur_sc s) s") - apply (frule invs_cur_sc_tcb) - apply (fastforce simp: cur_sc_tcb_def sc_tcb_sc_at_def obj_at_def is_sc_obj - dest: valid_sched_context_size_objsI[OF invs_valid_objs]) - apply (frule (4) active_sc_at'_cross[OF _ invs_psp_aligned invs_distinct]) - apply (clarsimp simp: active_sc_at'_def obj_at'_def projectKOs cur_tcb'_def pred_tcb_at_def - is_sc_obj obj_at_def) - apply (clarsimp simp: pred_map_def isScActive_def) - apply (rule_tac x="cur_sc s" in exI) - apply (clarsimp simp: opt_map_red dest!: state_relationD) - apply (frule_tac x="ksCurThread s'" in pspace_relation_absD, simp) - apply (fastforce simp: other_obj_relation_def tcb_relation_def) - apply (rule_tac Q="\s'. pred_map (\tcb. \ tcbInReleaseQueue tcb) (tcbs_of' s') (ksCurThread s')" - in corres_cross_add_guard) - apply (clarsimp, frule tcb_at_invs) - apply (fastforce simp: not_in_release_q_def release_queue_relation_def pred_map_def opt_map_red obj_at'_def - invs'_def valid_pspace'_def projectKOs valid_release_queue'_def cur_tcb'_def - dest!: state_relationD) - apply (rule corres_rel_imp) - apply (rule corres_guard_imp) - apply (rule corres_split_liftEE[OF getCapReg_corres_gen]) - apply (rule corres_splitEE[OF handleInvocation_corres]) - apply simp - apply simp - apply (rule_tac P="(einvs and ct_active and scheduler_act_sane and current_time_bounded - and ct_not_queued and ct_not_in_release_q)" - and P'="(invs')" - in corres_inst) - apply (rule corres_stateAssertE_add_assertion) - apply simp - apply (rule corres_stateAssertE_add_assertion) - apply (rule corres_stateAssertE_add_assertion) - apply simp - apply (clarsimp simp: sch_act_sane_asrt_def ct_not_ksQ_asrt_def ct_active'_asrt_def) - apply (rule corres_guard_imp) - apply (rule handleRecv_isBlocking_corres) - apply simp - apply simp - apply (fastforce simp: ct_active'_asrt_def invs_psp_aligned invs_distinct - dest!: ct_active_cross) - apply (clarsimp simp: ct_not_ksQ_asrt_def not_queued_2_def ready_queues_relation_def - dest!: state_relationD) - apply (clarsimp simp: sch_act_sane_asrt_def scheduler_act_not_def sch_act_sane_def sched_act_relation_def - dest!: state_relationD) - apply (case_tac "scheduler_action s"; simp) - apply (wpsimp wp: handle_invocation_valid_sched) - apply wpsimp - apply wpsimp - apply wpsimp - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def active_from_running - schedulable_def2 released_sc_tcb_at_def) - apply (clarsimp simp: ct_in_state_def st_tcb_weakenE) - apply (clarsimp simp: active_from_running') - apply simp +lemma inv_irq_IRQInactive: + "\\\ performIRQControl irqcontrol_invocation + -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + apply (simp add: performIRQControl_def) + apply (rule hoare_pre) + apply (wpc|wp|simp add: ARM_H.performIRQControl_def)+ done -(* these two appreviations are for the two helper lemmas below, which should be identical - except that they are in different monads *) -abbreviation (input) - "a_pre \ (einvs and ct_running and - (\s. scheduler_action s = resume_cur_thread) and - valid_machine_time and - current_time_bounded and - consumed_time_bounded and - cur_sc_active and (ct_active or ct_idle) and - ct_not_in_release_q and - ct_not_queued and - (\s. cur_sc_offset_ready (consumed_time s) s) and - (\s. cur_sc_offset_sufficient (consumed_time s) s) and - ct_released)" - -abbreviation (input) - "c_pre \ (invs' and ct_running' and (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. ksSchedulerAction s = ResumeCurrentThread))" - -lemma updateTimeStamp_checkBudgetRestart_helper: - assumes H: "corres dc a_pre c_pre f f'" - shows "corres dc a_pre c_pre - (do y <- update_time_stamp; - restart <- check_budget_restart; - when restart f - od) - (do y <- updateTimeStamp; - restart <- checkBudgetRestart; - when restart f' - od)" - apply (rule corres_guard_imp) - apply (rule corres_split[OF updateTimeStamp_corres]) - apply (rule_tac P="\ s. (cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s) - \ cur_sc_active s \ ct_running s \ valid_machine_time s - \ ct_released s \ ct_not_in_release_q s \ ct_not_queued s - \ current_time_bounded s \ consumed_time_bounded s \ einvs s - \ scheduler_action s = resume_cur_thread" - and P'=c_pre in corres_inst) - apply (rule corres_guard_imp) - apply (rule corres_split[OF checkBudgetRestart_corres]) - apply (simp add: when_def split del: if_split) - apply (rule corres_if2) - apply simp - apply (rule_tac P="\s. (cur_sc_offset_ready (consumed_time s) s \ einvs s - \ cur_sc_active s \ valid_machine_time s \ ct_running s - \ ct_released s \ ct_not_in_release_q s \ ct_not_queued s - \ current_time_bounded s \ consumed_time_bounded s - \ scheduler_action s = resume_cur_thread) - \ cur_sc_offset_sufficient (consumed_time s) s" - and P'=c_pre in corres_inst) - apply (rule corres_guard_imp) - apply (rule H) - apply (clarsimp simp: active_from_running) - apply simp - apply (simp add: corres_return[where P=cur_sc_more_than_ready]) - apply (wpsimp wp: check_budget_restart_false check_budget_restart_true') - apply (wpsimp wp: checkBudgetRestart_false checkBudgetRestart_true) - apply (clarsimp dest!: active_from_running - simp: cur_sc_offset_ready_def pred_map_def - ct_in_state_weaken[OF _ active_activatable]) - apply clarsimp - apply (wpsimp wp: update_time_stamp_current_time_bounded - update_time_stamp_cur_sc_offset_ready_cs) - apply wpsimp - apply clarsimp+ +lemma inv_arch_IRQInactive: + "\\\ Arch.performInvocation invocation + -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + apply (simp add: ARM_H.performInvocation_def performARMMMUInvocation_def) + apply wp done -lemma updateTimeStamp_checkBudgetRestart_helperE: - assumes H: "corres (dc \ dc) a_pre c_pre f f'" - shows "corres (dc \ dc) a_pre c_pre - (doE y <- liftE update_time_stamp; - restart <- liftE check_budget_restart; - whenE restart f - odE) - (doE y <- liftE updateTimeStamp; - restart <- liftE checkBudgetRestart; - whenE restart f' - odE)" - apply (rule corres_guard_imp) - apply (rule corres_split_liftEE[OF updateTimeStamp_corres]) - apply (rule_tac P="\ s. (cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s) - \ cur_sc_active s \ ct_running s \ valid_machine_time s - \ ct_released s \ ct_not_in_release_q s \ ct_not_queued s - \ current_time_bounded s \ consumed_time_bounded s \ einvs s - \ scheduler_action s = resume_cur_thread" - and P'=c_pre in corres_inst) - apply (rule corres_guard_imp) - apply (rule corres_split_liftEE[OF checkBudgetRestart_corres]) - apply (simp add: whenE_def split del: if_split) - apply (rule corres_if2) - apply simp - apply (rule_tac P="\s. (cur_sc_offset_ready (consumed_time s) s \ einvs s - \ cur_sc_active s \ valid_machine_time s \ ct_running s - \ ct_released s \ ct_not_in_release_q s \ ct_not_queued s - \ current_time_bounded s \ consumed_time_bounded s - \ scheduler_action s = resume_cur_thread) - \ cur_sc_offset_sufficient (consumed_time s) s" - and P'=c_pre in corres_inst) - apply (rule corres_guard_imp) - apply (rule H) - apply (clarsimp simp: active_from_running) - apply simp - apply (rule corres_returnOk[where P=cur_sc_more_than_ready]) - apply simp - apply (wpsimp wp: check_budget_restart_false check_budget_restart_true') - apply (wpsimp wp: checkBudgetRestart_false checkBudgetRestart_true) - apply (clarsimp dest!: active_from_running - simp: cur_sc_offset_ready_def pred_map_def - ct_in_state_weaken[OF _ active_activatable]) - apply clarsimp - apply (wpsimp wp: update_time_stamp_current_time_bounded - update_time_stamp_cur_sc_offset_ready_cs) - apply wpsimp - apply clarsimp+ +lemma retype_pi_IRQInactive: + "\valid_irq_states'\ RetypeDecls_H.performInvocation blocking call v + -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + apply (simp add: Retype_H.performInvocation_def) + apply (rule hoare_pre) + apply (wpc | + wp inv_tcb_IRQInactive inv_cnode_IRQInactive inv_irq_IRQInactive + inv_untyped_IRQInactive inv_arch_IRQInactive | + simp)+ done -lemma handleEvent_corres: - "corres (dc \ dc) - (einvs and (\s. event \ Interrupt \ ct_running s) - and (\s. scheduler_action s = resume_cur_thread) - and valid_machine_time and current_time_bounded - and consumed_time_bounded and cur_sc_active and (ct_active or ct_idle) - and ct_not_in_release_q and ct_not_queued - and (\s. cur_sc_offset_ready (consumed_time s) s) - and (\s. cur_sc_offset_sufficient (consumed_time s) s)) - (invs' and (\s. event \ Interrupt \ ct_running' s) and - (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. ksSchedulerAction s = ResumeCurrentThread)) - (handle_event event) (handleEvent event)" - (is "corres _ (?P and ?ready and _) ?P' _ _") -proof - - have hw: - "\isBlocking canGrant. - corres dc (einvs and ct_running and valid_machine_time and current_time_bounded - and ct_released and (\s. scheduler_action s = resume_cur_thread) - and ct_not_in_release_q and ct_not_queued) - (invs' and ct_running' - and (\s. ksSchedulerAction s = ResumeCurrentThread)) - (handle_recv isBlocking canGrant) (handleRecv isBlocking canGrant)" - apply add_cur_tcb' - apply add_ct_not_inQ - apply (rule corres_guard_imp [OF handleRecv_isBlocking_corres]) - apply (fastforce simp: ct_in_state_def ct_in_state'_def - elim!: st_tcb_weakenE pred_tcb'_weakenE - dest: ct_not_ksQ)+ - done - show ?thesis - apply (rule corres_cross_add_abs_guard[where Q="\s. event \ Interrupt \ ct_released s"]) - apply (simp only: schact_is_rct_def[symmetric]) - apply clarsimp - apply (frule (1) invs_strengthen_cur_sc_tcb_are_bound[OF _ invs_cur_sc_tcb]) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply (erule (5) schact_is_rct_ct_released) - apply (erule (2) cur_sc_not_idle_sc_ptr') - apply (case_tac event) - apply (simp_all add: handleEvent_def) - apply (rename_tac syscall) - apply (rule updateTimeStamp_checkBudgetRestart_helperE) - apply (case_tac syscall; simp) - apply (auto intro: corres_guard_imp[OF handleSend_corres] - corres_guard_imp[OF hw] - corres_guard_imp[OF handleCall_corres] - corres_guard_imp[OF handleInv_handleRecv_corres] - corres_guard_imp[OF handleYield_corres] - active_from_running active_from_running' released_imp_active_sc_tcb_at - simp: simple_sane_strg - dest!: schact_is_rct)[11] - apply (rule updateTimeStamp_checkBudgetRestart_helper) - apply (rule corres_underlying_split) - apply (rule corres_guard_imp[OF getCurThread_corres], simp+) - apply (rule handleFault_corres) - apply simp - apply wpsimp - apply (clarsimp simp: valid_fault_def valid_sched_def current_time_bounded_def - dest!: active_from_running) - apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE simp: ct_in_state_def) - apply wp - apply (fastforce simp: ct_in_state'_def sch_act_simple_def - elim: pred_tcb'_weakenE st_tcb_ex_cap'') - - apply (rule updateTimeStamp_checkBudgetRestart_helper) - apply (rule corres_underlying_split) - apply (rule corres_guard_imp[OF getCurThread_corres], simp+) - apply (rule handleFault_corres) - apply simp - apply wpsimp - apply (clarsimp simp: valid_fault_def valid_sched_def current_time_bounded_def - dest!: active_from_running) - apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE simp: ct_in_state_def) - apply wp - apply (fastforce simp: ct_in_state'_def sch_act_simple_def - elim: pred_tcb'_weakenE st_tcb_ex_cap'') - - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF corres_machine_op]) - apply (rule corres_Id, simp+) - apply wp - apply (rename_tac active) - apply (rule corres_split[OF updateTimeStamp_corres]) - apply (rule_tac P="\ s. (cur_sc_active s \ cur_sc_offset_ready (consumed_time s) s) - \ cur_sc_active s \ valid_machine_time s \ (ct_active s \ ct_idle s) - \ ct_not_in_release_q s \ ct_not_queued s - \ current_time_bounded s \ consumed_time_bounded s \ einvs s - \ scheduler_action s = resume_cur_thread" - and P'="(invs' and (\s. vs_valid_duplicates' (ksPSpace s)) and - (\s. ksSchedulerAction s = ResumeCurrentThread)) and - (\s. \x. active = Some x \ - intStateIRQTable (ksInterruptState s) x \ irqstate.IRQInactive)" - in corres_inst) - apply (rule corres_guard_imp) - apply (rule corres_split[OF checkBudget_corres]) - apply (rule_tac P="einvs and current_time_bounded" - and P'="invs' and (\s. \x. active = Some x \ intStateIRQTable (ksInterruptState s) x \ irqstate.IRQInactive)" - in corres_inst) - apply (case_tac active; simp) - apply (rule handleInterrupt_corres) - apply (wpsimp wp: check_budget_valid_sched) - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift) - apply (wpsimp wp: update_time_stamp_current_time_bounded hoare_vcg_disj_lift - update_time_stamp_cur_sc_offset_ready_cs) - apply (clarsimp simp: cur_sc_offset_ready_weaken_zero active_from_running current_time_bounded_def) - apply (frule invs_cur_sc_chargeableE) - apply (clarsimp simp: schact_is_rct_def) - apply clarsimp - apply (rule conjI) - apply (erule cur_sc_offset_ready_weaken_zero) - apply (rule conjI) - apply (fastforce simp: ct_in_state_def pred_tcb_at_def obj_at_def cur_tcb_def is_tcb dest!: invs_cur) - apply (erule ct_not_blocked_cur_sc_not_blocked) - apply (rule ct_activatable_ct_not_blocked) - apply (fastforce simp: ct_in_state_def pred_tcb_at_def obj_at_def dest!: active_activatable) - apply clarsimp - apply (wpsimp wp: update_time_stamp_current_time_bounded hoare_vcg_disj_lift - update_time_stamp_cur_sc_offset_ready_cs) - apply wpsimp - apply wpsimp - apply (clarsimp simp: ct_in_state_def) - apply (wpsimp wp: doMachineOp_getActiveIRQ_IRQ_active' hoare_vcg_all_lift) - apply (clarsimp elim!: active_from_running) - apply clarsimp - apply (simp add: invs'_def) - apply (rule updateTimeStamp_checkBudgetRestart_helper) - apply (rule corres_underlying_split) - apply (rule corres_guard_imp[OF getCurThread_corres], simp+) - apply (rule corres_split_catch) - apply (rule handleVMFault_corres) - apply (erule handleFault_corres) - apply (rule hoare_elim_pred_conjE2) - apply (rule hoare_vcg_conj_liftE_E, rule valid_validE_E, wp) - apply (wpsimp wp: handle_vm_fault_valid_fault) - apply (rule hv_inv_ex') - apply wp - apply (clarsimp simp: active_from_running tcb_at_invs valid_sched_def current_time_bounded_def) - apply (fastforce elim!: st_tcb_ex_cap st_tcb_weakenE simp: ct_in_state_def) - apply wp - 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 wp - apply (clarsimp simp: active_from_running' invs'_def valid_pspace'_def) - apply (frule (2) ct_not_ksQ) - 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 - end end diff --git a/proof/refine/ARM/TcbAcc_R.thy b/proof/refine/ARM/TcbAcc_R.thy index a40ce993bf..d9ef04af4d 100644 --- a/proof/refine/ARM/TcbAcc_R.thy +++ b/proof/refine/ARM/TcbAcc_R.thy @@ -1,25 +1,20 @@ (* - * Copyright 2022, Proofcraft Pty Ltd * Copyright 2014, General Dynamics C4 Systems * * SPDX-License-Identifier: GPL-2.0-only *) theory TcbAcc_R -imports CSpace_R +imports CSpace_R ArchMove_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) declare if_weak_cong [cong] declare hoare_in_monad_post[wp] declare trans_state_update'[symmetric,simp] declare storeWordUser_typ_at' [wp] -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') - (* Auxiliaries and basic properties of priority bitmap functions *) lemma countLeadingZeros_word_clz[simp]: @@ -87,43 +82,86 @@ lemma l1IndexToPrio_wordRadix_mask[simp]: unfolding l1IndexToPrio_def by (simp add: wordRadix_def') -definition - (* when in the middle of updates, a particular queue might not be entirely valid *) - valid_queues_no_bitmap_except :: "word32 \ kernel_state \ bool" -where - "valid_queues_no_bitmap_except t' \ \s. - (\d p. (\t \ set (ksReadyQueues s (d, p)). t \ t' \ obj_at' (inQ d p) t s) - \ (d > maxDomain \ p > maxPriority \ ksReadyQueues s (d,p) = []))" - -lemma valid_queues_no_bitmap_exceptI[intro]: - "valid_queues_no_bitmap s \ valid_queues_no_bitmap_except t s" - unfolding valid_queues_no_bitmap_except_def valid_queues_no_bitmap_def - by simp - -crunch setThreadState, threadSet - for replies_of'[wp]: "\s. P (replies_of' s)" - and reply_at'[wp]: "\s. P (reply_at' p s)" - and tcb_at'[wp]: "\s. P (tcb_at' p s)" - and 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 set_tcb'.set_preserves_some_obj_at') - -crunch tcbSchedDequeue, tcbSchedEnqueue - for replies_of'[wp]: "\s. P (replies_of' s)" - -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'_sc[wp]: "\s. Q (obj_at' (P :: sched_context \ bool) p s)" - -lemma valid_objs_valid_tcbE': - assumes "valid_objs' s" - "tcb_at' t s" - "\tcb. ko_at' tcb t s \ valid_tcb' tcb s \ R s tcb" - shows "obj_at' (R s) t s" +lemma st_tcb_at_coerce_abstract: + assumes t: "st_tcb_at' P t c" + assumes sr: "(a, c) \ state_relation" + shows "st_tcb_at (\st. \st'. thread_state_relation st st' \ P st') t a" + using assms + apply (clarsimp simp: state_relation_def pred_tcb_at'_def obj_at'_def + projectKOs) + apply (erule (1) pspace_dom_relatedE) + apply (erule (1) obj_relation_cutsE, simp_all) + by (fastforce simp: st_tcb_at_def obj_at_def other_obj_relation_def tcb_relation_def + split: Structures_A.kernel_object.split_asm if_split_asm + arch_kernel_obj.split_asm)+ + +lemma st_tcb_at_runnable_coerce_concrete: + assumes t: "st_tcb_at runnable t a" + assumes sr: "(a, c) \ state_relation" + assumes tcb: "tcb_at' t c" + shows "st_tcb_at' runnable' t c" + using t + apply - + apply (rule ccontr) + apply (drule pred_tcb_at'_Not[THEN iffD2, OF conjI, OF tcb]) + apply (drule st_tcb_at_coerce_abstract[OF _ sr]) + apply (clarsimp simp: st_tcb_def2) + apply (case_tac "tcb_state tcb"; simp) + done + +lemma pspace_relation_tcb_at': + assumes p: "pspace_relation (kheap a) (ksPSpace c)" + assumes t: "tcb_at t a" + assumes aligned: "pspace_aligned' c" + assumes distinct: "pspace_distinct' c" + shows "tcb_at' t c" using assms + apply (clarsimp simp: obj_at_def) + apply (drule(1) pspace_relation_absD) + apply (clarsimp simp: is_tcb tcb_relation_cut_def) + apply (simp split: kernel_object.split_asm) + apply (drule(2) aligned_distinct_obj_atI'[where 'a=tcb], simp) + apply (erule obj_at'_weakenE) + apply simp + done + +lemma tcb_at_cross: + "\tcb_at t s; pspace_aligned s; pspace_distinct s; pspace_relation (kheap s) (ksPSpace s')\ + \ tcb_at' t s'" + apply (drule (2) pspace_distinct_cross) + apply (drule (1) pspace_aligned_cross) + apply (erule (3) pspace_relation_tcb_at') + done + +lemma tcb_at'_cross: + assumes p: "pspace_relation (kheap s) (ksPSpace s')" + assumes t: "tcb_at' ptr s'" + shows "tcb_at ptr s" + 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 pde_relation_def is_tcb_def projectKOs + split: Structures_A.kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm) + +lemma st_tcb_at_runnable_cross: + "\ st_tcb_at runnable t s; pspace_aligned s; pspace_distinct s; (s, s') \ state_relation \ + \ st_tcb_at' runnable' t s'" + apply (frule (1) pspace_distinct_cross, fastforce simp: state_relation_def) + apply (frule pspace_aligned_cross, fastforce simp: state_relation_def) + apply (prop_tac "tcb_at t s", clarsimp simp: st_tcb_at_def obj_at_def is_tcb) + apply (drule (2) tcb_at_cross, fastforce simp: state_relation_def) + apply (erule (2) st_tcb_at_runnable_coerce_concrete) + done + +lemma cur_tcb_cross: + "\ cur_tcb s; pspace_aligned s; pspace_distinct s; (s,s') \ state_relation \ \ cur_tcb' s'" + apply (clarsimp simp: cur_tcb'_def cur_tcb_def state_relation_def) + apply (erule (3) tcb_at_cross) + done + +lemma valid_objs_valid_tcbE: + "\s t.\ valid_objs' s; tcb_at' t s; \tcb. valid_tcb' tcb s \ R s tcb \ \ obj_at' (R s) t s" apply (clarsimp simp add: projectKOs valid_objs'_def ran_def typ_at'_def ko_wp_at'_def valid_obj'_def valid_tcb'_def obj_at'_def) apply (fastforce simp: projectKO_def projectKO_opt_tcb return_def valid_tcb'_def) @@ -133,12 +171,13 @@ lemma valid_tcb'_tcbDomain_update: "new_dom \ maxDomain \ \tcb. valid_tcb' tcb s \ valid_tcb' (tcbDomain_update (\_. new_dom) tcb) s" unfolding valid_tcb'_def - by (clarsimp simp: tcb_cte_cases_def) + apply (clarsimp simp: tcb_cte_cases_def objBits_simps') + done lemma valid_tcb'_tcbState_update: "\valid_tcb_state' st s; valid_tcb' tcb s\ \ valid_tcb' (tcbState_update (\_. st) tcb) s" - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def valid_tcb_state'_def) + apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def valid_tcb_state'_def objBits_simps') done definition valid_tcbs' :: "kernel_state \ bool" where @@ -154,14 +193,14 @@ lemma invs'_valid_tcbs'[elim!]: lemma valid_tcbs'_maxDomain: "\s t. \ valid_tcbs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbDomain tcb \ maxDomain) t s" - apply (clarsimp simp: valid_tcbs'_def obj_at'_def projectKOs valid_tcb'_def) + apply (clarsimp simp: valid_tcbs'_def obj_at'_def valid_tcb'_def projectKOs) done lemmas valid_objs'_maxDomain = valid_tcbs'_maxDomain[OF valid_objs'_valid_tcbs'] lemma valid_tcbs'_maxPriority: "\s t. \ valid_tcbs' s; tcb_at' t s \ \ obj_at' (\tcb. tcbPriority tcb \ maxPriority) t s" - apply (clarsimp simp: valid_tcbs'_def obj_at'_def projectKOs valid_tcb'_def) + apply (clarsimp simp: valid_tcbs'_def obj_at'_def valid_tcb'_def projectKOs) done lemmas valid_objs'_maxPriority = valid_tcbs'_maxPriority[OF valid_objs'_valid_tcbs'] @@ -172,31 +211,25 @@ lemma valid_tcbs'_obj_at': "\tcb. ko_at' tcb t s \ valid_tcb' tcb s \ R s tcb" shows "obj_at' (R s) t s" using assms - apply (clarsimp simp add: projectKOs valid_tcbs'_def ran_def typ_at'_def - ko_wp_at'_def valid_obj'_def valid_tcb'_def obj_at'_def) + apply (clarsimp simp add: valid_tcbs'_def ran_def typ_at'_def + ko_wp_at'_def valid_obj'_def valid_tcb'_def obj_at'_def projectKOs) done lemma update_valid_tcb'[simp]: - "\f. valid_tcb' tcb (ksReleaseQueue_update f s) = valid_tcb' tcb s" - "\f. valid_tcb' tcb (ksReprogramTimer_update f s) = valid_tcb' tcb s" "\f. valid_tcb' tcb (ksReadyQueuesL1Bitmap_update f s) = valid_tcb' tcb s" "\f. valid_tcb' tcb (ksReadyQueuesL2Bitmap_update f s) = valid_tcb' tcb s" "\f. valid_tcb' tcb (ksReadyQueues_update f s) = valid_tcb' tcb s" "\f. valid_tcb' tcb (ksSchedulerAction_update f s) = valid_tcb' tcb s" - by (auto simp: valid_tcb'_def valid_tcb_state'_def valid_bound_obj'_def + "\f. valid_tcb' tcb (ksDomainTime_update f s) = valid_tcb' tcb s" + by (auto simp: valid_tcb'_def valid_tcb_state'_def valid_bound_tcb'_def valid_bound_ntfn'_def split: option.splits thread_state.splits) -lemma update_tcbInReleaseQueue_False_valid_tcb'[simp]: - "valid_tcb' (tcbInReleaseQueue_update a tcb) s = valid_tcb' tcb s" - by (auto simp: valid_tcb'_def tcb_cte_cases_def) - lemma update_valid_tcbs'[simp]: - "\f. valid_tcbs' (ksReleaseQueue_update f s) = valid_tcbs' s" - "\f. valid_tcbs' (ksReprogramTimer_update f s) = valid_tcbs' s" "\f. valid_tcbs' (ksReadyQueuesL1Bitmap_update f s) = valid_tcbs' s" "\f. valid_tcbs' (ksReadyQueuesL2Bitmap_update f s) = valid_tcbs' s" "\f. valid_tcbs' (ksReadyQueues_update f s) = valid_tcbs' s" "\f. valid_tcbs' (ksSchedulerAction_update f s) = valid_tcbs' s" + "\f. valid_tcbs' (ksDomainTime_update f s) = valid_tcbs' s" by (simp_all add: valid_tcbs'_def) lemma doMachineOp_irq_states': @@ -227,6 +260,22 @@ lemma dmo_invs': apply assumption done +lemma dmo_invs_no_cicd': + assumes masks: "\P. \\s. P (irq_masks s)\ f \\_ s. P (irq_masks s)\" + shows "\(\s. \m. \(r,m')\fst (f m). \p. + pointerInUserData p s \ pointerInDeviceData p s \ + underlying_memory m' p = underlying_memory m p) and + invs_no_cicd'\ doMachineOp f \\r. invs_no_cicd'\" + apply (simp add: doMachineOp_def split_def) + apply wp + apply clarsimp + apply (subst invs_no_cicd'_machine) + apply (drule use_valid) + apply (rule_tac P="\m. m = irq_masks (ksMachineState s)" in masks, simp+) + apply (fastforce simp add: valid_machine_state'_def) + apply assumption + done + lemma dmo_lift': assumes f: "\P\ f \Q\" shows "\\s. P (ksMachineState s)\ doMachineOp f @@ -260,8 +309,25 @@ lemma doMachineOp_getActiveIRQ_IRQ_active': apply simp done +lemma preemptionPoint_irq [wp]: + "\valid_irq_states'\ preemptionPoint -, + \\irq s. intStateIRQTable (ksInterruptState s) irq \ IRQInactive\" + apply (simp add: preemptionPoint_def setWorkUnits_def modifyWorkUnits_def getWorkUnits_def) + apply (wp whenE_wp|wpc)+ + apply (rule hoare_post_imp) + prefer 2 + apply (rule doMachineOp_getActiveIRQ_IRQ_active) + apply clarsimp + apply wp+ + apply clarsimp + done + lemmas doMachineOp_obj_at = doMachineOp_obj_at' +lemma updateObject_tcb_inv: + "\P\ updateObject (obj::tcb) ko p q n \\rv. P\" + by simp (rule updateObject_default_inv) + lemma setObject_update_TCB_corres': assumes tcbs: "tcb_relation tcb tcb' \ tcb_relation new_tcb new_tcb'" assumes tables: "\(getF, v) \ ran tcb_cap_cases. getF new_tcb = getF tcb" @@ -270,45 +336,103 @@ lemma setObject_update_TCB_corres': "tcbSchedNext new_tcb' = tcbSchedNext tcb'" assumes flag: "tcbQueued new_tcb' = tcbQueued tcb'" assumes r: "r () ()" - shows "corres r (ko_at (TCB tcb) add) - (ko_at' tcb' add) - (set_object add (TCB tcbu)) (setObject add tcbu')" - apply (rule_tac F="tcb_relation tcb tcb'" in corres_req) + assumes exst: "exst_same tcb' new_tcb'" + shows + "corres r + (ko_at (TCB tcb) ptr) (ko_at' tcb' ptr) + (set_object ptr (TCB new_tcb)) (setObject ptr new_tcb')" + apply (rule_tac F="tcb_relation tcb tcb' \ exst_same tcb' new_tcb'" in corres_req) apply (clarsimp simp: state_relation_def obj_at_def obj_at'_def) apply (frule(1) pspace_relation_absD) - apply (clarsimp simp: projectKOs other_obj_relation_def) - apply (rule corres_guard_imp) - apply (rule corres_rel_imp) - apply (rule setObject_other_corres[where P="(=) tcb'"]) - apply (rule ext)+ - apply simp - defer - apply (simp add: is_other_obj_relation_type_def - projectKOs objBits_simps' - other_obj_relation_def tcbs r)+ - apply (fastforce elim!: obj_at_weakenE dest: bspec[OF tables]) - apply (subst(asm) eq_commute, assumption) - apply (clarsimp simp: projectKOs obj_at'_def objBits_simps) - apply (subst map_to_ctes_upd_tcb, assumption+) - apply (simp add: ps_clear_def3 field_simps objBits_defs mask_def) - apply (subst if_not_P) - apply (fastforce dest: bspec [OF tables', OF ranI]) - apply simp + apply (clarsimp simp: tcb_relation_cut_def exst projectKOs) + apply (rule corres_no_failI) + apply (rule no_fail_pre) + apply wp + apply (clarsimp simp: obj_at'_def) + 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 projectKOs obj_at_def + updateObject_default_def in_magnitude_check obj_at'_def) + apply (rename_tac s s' t') + apply (prop_tac "t' = s'") + apply (clarsimp simp: magnitudeCheck_def in_monad split: option.splits) + apply (drule singleton_in_magnitude_check) + apply (prop_tac "map_to_ctes ((ksPSpace s') (ptr \ injectKO new_tcb')) + = map_to_ctes (ksPSpace s')") + apply (frule_tac tcb=new_tcb' and tcb=tcb' in map_to_ctes_upd_tcb) + apply (clarsimp simp: objBits_simps) + apply (clarsimp simp: objBits_simps ps_clear_def3 field_simps objBits_defs mask_def) + apply (insert tables')[1] + apply (rule ext) + apply (clarsimp split: if_splits) + apply blast + apply (prop_tac "obj_at (same_caps (TCB new_tcb)) ptr s") + using tables + apply (fastforce simp: obj_at_def) + apply (clarsimp simp: caps_of_state_after_update cte_wp_at_after_update swp_def + obj_at_def assms) + apply (clarsimp simp add: state_relation_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 + apply (simp only: pspace_relation_def pspace_dom_update dom_fun_upd2 simp_thms) + apply (elim conjE) + apply (frule bspec, erule domI) + apply clarsimp + apply (rule conjI) + apply (simp only: pspace_relation_def simp_thms + pspace_dom_update[where x="kernel_object.TCB _" + and v="kernel_object.TCB _", + simplified a_type_def, simplified]) + apply (rule conjI) + using assms + apply (simp only: dom_fun_upd2 simp_thms) + apply (frule bspec, erule domI) + apply (rule ballI, drule(1) bspec) + apply (drule domD) + apply (clarsimp simp: tcb_relation_cut_def split: if_split_asm kernel_object.split_asm) + apply (rename_tac aa ba) + apply (drule_tac x="(aa, ba)" in bspec, simp) + apply clarsimp + apply (frule_tac ko'="kernel_object.TCB tcb" and x'=ptr in obj_relation_cut_same_type) + apply (simp add: tcb_relation_cut_def)+ + apply clarsimp + apply (extract_conjunct \match conclusion in "ekheap_relation _ _" \ -\) + apply (simp only: ekheap_relation_def) + apply (rule ballI, drule (1) bspec) + apply (insert exst) + apply (clarsimp simp: etcb_relation_def exst_same_def) + apply (extract_conjunct \match conclusion in "ready_queues_relation_2 _ _ _ _ _" \ -\) + apply (insert sched_pointers flag exst) + apply (clarsimp simp: ready_queues_relation_def Let_def) + apply (prop_tac "(tcbSchedNexts_of s')(ptr := tcbSchedNext new_tcb') = tcbSchedNexts_of s'") + 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) + apply (clarsimp simp: ready_queue_relation_def opt_pred_def opt_map_def exst_same_def + inQ_def projectKOs + split: option.splits) + apply (metis (mono_tags, opaque_lifting)) + apply (clarsimp simp: fun_upd_def caps_of_state_after_update cte_wp_at_after_update swp_def + obj_at_def) done lemma setObject_update_TCB_corres: - "\ tcb_relation tcb tcb' \ tcb_relation tcbu tcbu'; - \(getF, v) \ ran tcb_cap_cases. getF tcbu = getF tcb; - \(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'; - r () ()\ - \ corres r (\s. get_tcb add s = Some tcb) - (\s'. (tcb', s') \ fst (getObject add s')) - (set_object add (TCB tcbu)) (setObject add tcbu')" + "\tcb_relation tcb tcb' \ tcb_relation new_tcb new_tcb'; + \(getF, v) \ ran tcb_cap_cases. getF new_tcb = getF tcb; + \(getF, v) \ ran tcb_cte_cases. getF new_tcb' = getF tcb'; + tcbSchedPrev new_tcb' = tcbSchedPrev tcb'; tcbSchedNext new_tcb' = tcbSchedNext tcb'; + tcbQueued new_tcb' = tcbQueued tcb'; exst_same tcb' new_tcb'; + r () ()\ \ + corres r + (\s. get_tcb ptr s = Some tcb) (\s'. (tcb', s') \ fst (getObject ptr s')) + (set_object ptr (TCB new_tcb)) (setObject ptr new_tcb')" apply (rule corres_guard_imp) - apply (erule (3) setObject_update_TCB_corres', force) - apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def - loadObject_default_def projectKOs objBits_simps' in_magnitude_check - dest!: readObject_misc_ko_at') + apply (erule (7) setObject_update_TCB_corres') + apply (clarsimp simp: getObject_def in_monad split_def obj_at'_def projectKOs + loadObject_default_def objBits_simps' in_magnitude_check)+ done lemma getObject_TCB_corres: @@ -325,31 +449,31 @@ lemma getObject_TCB_corres: lemma threadGet_corres: assumes x: "\tcb tcb'. tcb_relation tcb tcb' \ r (f tcb) (f' tcb')" - shows "corres r (tcb_at t) (tcb_at' t) (thread_get f t) (threadGet f' t)" - apply (simp add: thread_get_def threadGet_getObject) - apply (rule corres_split_skip) - apply wpsimp+ + shows "corres r (tcb_at t and pspace_aligned and pspace_distinct) \ + (thread_get f t) (threadGet f' t)" + apply (simp add: thread_get_def threadGet_def) + apply (fold liftM_def) + apply simp + apply (rule corres_rel_imp) apply (rule getObject_TCB_corres) apply (simp add: x) done -lemmas get_tcb_obj_ref_corres - = threadGet_corres[where 'a="obj_ref option", folded get_tcb_obj_ref_def] - lemma threadGet_inv [wp]: "\P\ threadGet f t \\rv. P\" - by (simp add: threadGet_def getObject_tcb_inv | wp)+ + by (simp add: threadGet_def getObject_inv_tcb | wp)+ lemma ball_tcb_cte_casesI: "\ P (tcbCTable, tcbCTable_update); P (tcbVTable, tcbVTable_update); - P (tcbIPCBufferFrame, tcbIPCBufferFrame_update); - P (tcbFaultHandler, tcbFaultHandler_update); - P (tcbTimeoutHandler, tcbTimeoutHandler_update) \ + P (tcbReply, tcbReply_update); + P (tcbCaller, tcbCaller_update); + P (tcbIPCBufferFrame, tcbIPCBufferFrame_update) \ \ \x \ ran tcb_cte_cases. P x" by (simp add: tcb_cte_cases_def) lemma all_tcbI: - "\ \a b c d e f g h i j k l m n p q r. P (Thread a b c d e f g h i j k l m n p q r) \ \ \tcb. P tcb" + "\ \a b c d e f g h i j k l m n p q r s. P (Thread a b c d e f g h i j k l m n p q r s) \ + \ \tcb. P tcb" by (rule allI, case_tac tcb, simp) lemma threadset_corresT: @@ -358,18 +482,26 @@ lemma threadset_corresT: assumes y: "\tcb. \(getF, setF) \ ran tcb_cap_cases. getF (f tcb) = getF tcb" assumes z: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (f' tcb) = getF tcb" - shows "corres dc (tcb_at t) - (tcb_at' t) - (thread_set f t) (threadSet f' t)" + assumes sched_pointers: "\tcb. tcbSchedPrev (f' tcb) = tcbSchedPrev tcb" + "\tcb. tcbSchedNext (f' tcb) = tcbSchedNext tcb" + assumes flag: "\tcb. tcbQueued (f' tcb) = tcbQueued tcb" + assumes e: "\tcb'. exst_same tcb' (f' tcb')" + shows "corres dc (tcb_at t and pspace_aligned and pspace_distinct) + \ + (thread_set f t) (threadSet f' t)" apply (simp add: thread_set_def threadSet_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getObject_TCB_corres]) apply (rule setObject_update_TCB_corres') - apply (erule x) - apply (rule y) - apply (clarsimp simp: bspec_split [OF spec [OF z]]) - apply fastforce - apply simp + apply (erule x) + apply (rule y) + apply (clarsimp simp: bspec_split [OF spec [OF z]]) + apply fastforce + apply (rule sched_pointers) + apply (rule sched_pointers) + apply (rule flag) + apply simp + apply (rule e) apply wp+ apply (clarsimp simp add: tcb_at_def obj_at_def) apply (drule get_tcb_SomeD) @@ -380,22 +512,37 @@ lemma threadset_corresT: lemmas threadset_corres = threadset_corresT [OF _ _ all_tcbI, OF _ ball_tcb_cap_casesI ball_tcb_cte_casesI] +lemma pspace_relation_tcb_at: + assumes p: "pspace_relation (kheap a) (ksPSpace c)" + assumes t: "tcb_at' t c" + shows "tcb_at t a" using assms + apply (clarsimp simp: obj_at'_def projectKOs) + apply (erule(1) pspace_dom_relatedE) + apply (erule(1) obj_relation_cutsE) + apply (clarsimp simp: other_obj_relation_def is_tcb obj_at_def + split: Structures_A.kernel_object.split_asm if_split_asm + ARM_A.arch_kernel_obj.split_asm)+ + done + lemma threadSet_corres_noopT: assumes x: "\tcb tcb'. tcb_relation tcb tcb' \ tcb_relation tcb (fn tcb')" assumes y: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (fn tcb) = getF tcb" - shows "corres dc \ (tcb_at' t) - (return v) (threadSet fn t)" + assumes s: "\tcb'. tcbSchedPrev (fn tcb') = tcbSchedPrev tcb'" + "\tcb'. tcbSchedNext (fn tcb') = tcbSchedNext tcb'" + assumes f: "\tcb'. tcbQueued (fn tcb') = tcbQueued tcb'" + assumes e: "\tcb'. exst_same tcb' (fn tcb')" + shows "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ + (return v) (threadSet fn t)" proof - have S: "\t s. tcb_at t s \ return v s = (thread_set id t >>= (\x. return v)) s" apply (clarsimp simp: tcb_at_def) - apply (clarsimp simp: return_def thread_set_def gets_the_def - assert_opt_def simpler_gets_def set_object_def get_object_def - put_def get_def bind_def assert_def a_type_def[split_simps kernel_object.split arch_kernel_obj.split] - dest!: get_tcb_SomeD) + apply (simp add: return_def thread_set_def gets_the_def assert_def + assert_opt_def simpler_gets_def set_object_def get_object_def + put_def get_def bind_def) apply (subgoal_tac "(kheap s)(t \ TCB tcb) = kheap s", simp) - apply (simp add: map_upd_triv get_tcb_SomeD) + apply (simp add: map_upd_triv get_tcb_SomeD)+ done show ?thesis apply (rule stronger_corres_guard_imp) @@ -403,16 +550,17 @@ proof - defer apply (subst bind_return [symmetric], rule corres_underlying_split [OF threadset_corresT]) - apply (simp add: x) - apply simp - apply (rule y) - apply (rule corres_noop [where P=\ and P'=\]) - apply wpsimp+ - apply (fastforce dest: pspace_relation_tcb_at - simp: state_relation_def opt_map_def obj_at'_def projectKOs - split: option.splits) - apply clarsimp - apply simp + apply (simp add: x) + apply simp + apply (rule y) + apply (fastforce simp: s) + apply (fastforce simp: s) + apply (fastforce simp: f) + apply (rule e) + apply (rule corres_noop [where P=\ and P'=\]) + apply simp + apply (rule no_fail_pre, wpsimp+)[1] + apply wpsimp+ done qed @@ -426,13 +574,21 @@ lemma threadSet_corres_noop_splitT: getF (fn tcb) = getF tcb" assumes z: "corres r P Q' m m'" assumes w: "\P'\ threadSet fn t \\x. Q'\" - shows "corres r P (tcb_at' t and P') + assumes s: "\tcb'. tcbSchedPrev (fn tcb') = tcbSchedPrev tcb'" + "\tcb'. tcbSchedNext (fn tcb') = tcbSchedNext tcb'" + assumes f: "\tcb'. tcbQueued (fn tcb') = tcbQueued tcb'" + assumes e: "\tcb'. exst_same tcb' (fn tcb')" + shows "corres r (tcb_at t and pspace_aligned and pspace_distinct and P) P' m (threadSet fn t >>= (\rv. m'))" apply (rule corres_guard_imp) apply (subst return_bind[symmetric]) apply (rule corres_split_nor[OF threadSet_corres_noopT]) - apply (simp add: x) - apply (rule y) + apply (simp add: x) + apply (rule y) + apply (fastforce simp: s) + apply (fastforce simp: s) + apply (fastforce simp: f) + apply (rule e) apply (rule z) apply (wp w)+ apply simp @@ -442,6 +598,15 @@ lemma threadSet_corres_noop_splitT: lemmas threadSet_corres_noop_split = threadSet_corres_noop_splitT [OF _ all_tcbI, OF _ ball_tcb_cte_casesI] +lemma threadSet_tcb' [wp]: + "\tcb_at' t\ threadSet f t' \\rv. tcb_at' t\" + by (simp add: threadSet_def) wp + +lemma threadSet_nosch[wp]: + "\\s. P (ksSchedulerAction s)\ threadSet f t \\rv s. P (ksSchedulerAction s)\" + unfolding threadSet_def + by (simp add: updateObject_default_def | wp setObject_nosch)+ + (* The function "thread_set f p" updates a TCB at p using function f. It should not be used to change capabilities, though. *) lemma setObject_tcb_valid_objs: @@ -451,9 +616,16 @@ lemma setObject_tcb_valid_objs: done lemma setObject_tcb_at': - "\\s. P (tcb_at' t' s)\ setObject t (v :: tcb) \\rv s. P (tcb_at' t' s)\" - apply (subst typ_at_tcb'[symmetric])+ - apply (rule setObject_typ_at') + "\tcb_at' t'\ setObject t (v :: tcb) \\rv. tcb_at' t'\" + apply (rule obj_at_setObject1) + apply (clarsimp simp: updateObject_default_def return_def in_monad) + apply (simp add: objBits_simps) + done + +lemma setObject_sa_unchanged: + "\\s. P (ksSchedulerAction s)\ setObject t (v :: tcb) \\rv s. P (ksSchedulerAction s)\" + apply (simp add: setObject_def split_def) + apply (wp | simp add: updateObject_default_def)+ done lemma setObject_queues_unchanged: @@ -463,6 +635,22 @@ lemma setObject_queues_unchanged: apply (wp inv | simp)+ done +lemma setObject_queues_unchanged_tcb[wp]: + "\\s. P (ksReadyQueues s)\ setObject t (v :: tcb) \\rv s. P (ksReadyQueues s)\" + apply (rule setObject_queues_unchanged) + apply (wp|simp add: updateObject_default_def)+ + done + +lemma setObject_queuesL1_unchanged_tcb[wp]: + "\\s. P (ksReadyQueuesL1Bitmap s)\ setObject t (v :: tcb) \\rv s. P (ksReadyQueuesL1Bitmap s)\" + by (clarsimp simp: setObject_def split_def) + (wp | simp add: updateObject_default_def)+ + +lemma setObject_queuesL2_unchanged_tcb[wp]: + "\\s. P (ksReadyQueuesL2Bitmap s)\ setObject t (v :: tcb) \\rv s. P (ksReadyQueuesL2Bitmap s)\" + by (clarsimp simp: setObject_def split_def) + (wp | simp add: updateObject_default_def)+ + lemma setObject_tcb_ctes_of[wp]: "\\s. P (ctes_of s) \ obj_at' (\t. \(getF, setF) \ ran tcb_cte_cases. getF t = getF v) t s\ @@ -488,8 +676,7 @@ lemma setObject_tcb_mdb' [wp]: lemma setObject_tcb_state_refs_of'[wp]: "\\s. P ((state_refs_of' s) (t := tcb_st_refs_of' (tcbState v) - \ tcb_bound_refs' (tcbBoundNotification v) (tcbSchedContext v) - (tcbYieldTo v)))\ + \ tcb_bound_refs' (tcbBoundNotification v)))\ setObject t (v :: tcb) \\rv s. P (state_refs_of' s)\" by (wp setObject_state_refs_of', simp_all add: objBits_simps' fun_upd_def) @@ -506,30 +693,24 @@ lemma setObject_tcb_iflive': in_magnitude_check objBits_simps' prod_eq_iff obj_at'_def) apply fastforce - apply (clarsimp simp: updateObject_default_def bind_def projectKOs in_monad) + apply (clarsimp simp: updateObject_default_def bind_def projectKOs) done lemma setObject_tcb_idle': - "\\s. valid_idle' s \ (t = ksIdleThread s \ idle_tcb' v)\ + "\\s. valid_idle' s \ + (t = ksIdleThread s \ idle' (tcbState v) \ tcbBoundNotification v = None)\ setObject t (v :: tcb) \\rv. valid_idle'\" apply (rule hoare_pre) apply (rule setObject_idle') apply (simp add: objBits_simps')+ apply (simp add: updateObject_default_inv) - apply (simp add: projectKOs idle_tcb_ps_def idle_sc_ps_def) + apply (simp add: projectKOs idle_tcb_ps_def idle_tcb'_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 add: objBits_simps') - apply (simp add: objBits_simps' scBits_pos_power2) - apply (simp add: updateObject_default_inv) - apply (simp add: projectKOs idle_tcb_ps_def idle_sc_ps_def) +lemma setObject_tcb_irq_node'[wp]: + "\\s. P (irq_node' s)\ setObject t (v :: tcb) \\rv s. P (irq_node' s)\" + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ done lemma setObject_tcb_ifunsafe': @@ -541,10 +722,21 @@ lemma setObject_tcb_ifunsafe': in_magnitude_check objBits_simps' prod_eq_iff obj_at'_def) apply fastforce - apply (clarsimp simp: updateObject_default_def bind_def projectKOs in_monad) + apply (clarsimp simp: updateObject_default_def bind_def projectKOs) + apply wp + done + +lemma setObject_tcb_arch' [wp]: + "\\s. P (ksArchState s)\ setObject t (v :: tcb) \\rv s. P (ksArchState s)\" + apply (simp add: setObject_def split_def updateObject_default_def) apply wp + apply simp done +lemma setObject_tcb_valid_arch' [wp]: + "\valid_arch_state'\ setObject t (v :: tcb) \\rv. valid_arch_state'\" + by (wp valid_arch_state_lift' setObject_typ_at') + lemma setObject_tcb_refs' [wp]: "\\s. P (global_refs' s)\ setObject t (v::tcb) \\rv s. P (global_refs' s)\" apply (clarsimp simp: setObject_def split_def updateObject_default_def) @@ -571,6 +763,37 @@ lemma setObject_tcb_valid_globals' [wp]: apply (wp | wp setObject_ksPSpace_only updateObject_default_inv | simp)+ done +lemma setObject_tcb_irq_states' [wp]: + "\valid_irq_states'\ setObject t (v :: tcb) \\rv. valid_irq_states'\" + apply (rule hoare_pre) + apply (rule hoare_use_eq [where f=ksInterruptState, OF setObject_ksInterrupt]) + apply (simp, rule updateObject_default_inv) + apply (rule hoare_use_eq [where f=ksMachineState, OF setObject_ksMachine]) + apply (simp, rule updateObject_default_inv) + apply wp + apply assumption + done + +lemma getObject_tcb_wp: + "\\s. tcb_at' p s \ (\t::tcb. ko_at' t p s \ Q t s)\ getObject p \Q\" + by (clarsimp simp: getObject_def valid_def in_monad + split_def objBits_simps' loadObject_default_def + projectKOs obj_at'_def in_magnitude_check) + +lemma setObject_tcb_pspace_no_overlap': + "\pspace_no_overlap' w s and tcb_at' t\ + setObject t (tcb::tcb) + \\rv. pspace_no_overlap' w s\" + apply (clarsimp simp: setObject_def split_def valid_def in_monad) + apply (clarsimp simp: obj_at'_def projectKOs) + apply (erule (1) ps_clear_lookupAround2) + apply (rule order_refl) + apply (erule is_aligned_no_overflow) + apply simp + apply (clarsimp simp: updateObject_default_def in_monad projectKOs objBits_simps in_magnitude_check) + apply (fastforce simp: pspace_no_overlap'_def objBits_simps) + done + lemma threadSet_pspace_no_overlap' [wp]: "\pspace_no_overlap' w s\ threadSet f t \\rv. pspace_no_overlap' w s\" apply (simp add: threadSet_def) @@ -590,60 +813,39 @@ lemma threadSet_global_refsT: lemmas threadSet_global_refs[wp] = threadSet_global_refsT [OF all_tcbI, OF ball_tcb_cte_casesI] -lemma setObject_tcb_valid_replies': - "\\s. valid_replies' s \ - (\rptr. st_tcb_at' ((=) (BlockedOnReply (Some rptr))) t s - \ tcbState v = BlockedOnReply (Some rptr) - \ \ is_reply_linked rptr s)\ - setObject t (v :: tcb) - \\rv. valid_replies'\" - unfolding valid_replies'_def pred_tcb_at'_def - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift hoare_vcg_ex_lift - set_tcb'.setObject_obj_at'_strongest) - apply (rename_tac rptr) - apply (rule ccontr, clarsimp simp flip: imp_disjL) - apply (drule_tac x=rptr in spec, drule mp, assumption) - apply (auto simp: opt_map_def) - done - lemma threadSet_valid_pspace'T_P: assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" assumes z: "\tcb. (P \ Q (tcbState tcb)) \ (\s. valid_tcb_state' (tcbState tcb) s \ valid_tcb_state' (tcbState (F tcb)) s)" - assumes z': "\tcb. (P \ Q (tcbState tcb)) \ - (\rptr. (tcbState tcb = BlockedOnReply rptr) - \ (tcbState (F tcb) = BlockedOnReply rptr))" - assumes v1: "\tcb. (P \ Q' (tcbBoundNotification tcb)) \ - (\s. valid_bound_ntfn' (tcbBoundNotification tcb) s + assumes v: "\tcb. (P \ Q' (tcbBoundNotification tcb)) \ + (\s. valid_bound_ntfn' (tcbBoundNotification tcb) s \ valid_bound_ntfn' (tcbBoundNotification (F tcb)) s)" - assumes v2: "\tcb. (P \ Q'' (tcbSchedContext tcb)) \ - (\s. valid_bound_sc' (tcbSchedContext tcb) s - \ valid_bound_sc' (tcbSchedContext (F tcb)) s)" - assumes v3: "\tcb. (P \ Q''' (tcbYieldTo tcb)) \ - (\s. valid_bound_sc' (tcbYieldTo tcb) s - \ valid_bound_sc' (tcbYieldTo (F tcb)) s)" - + assumes p: "\tcb. (P \ Q'' (tcbSchedPrev tcb)) \ + (\s. none_top tcb_at' (tcbSchedPrev tcb) s + \ none_top tcb_at' (tcbSchedPrev (F tcb)) s)" + assumes n: "\tcb. (P \ Q''' (tcbSchedNext tcb)) \ + (\s. none_top tcb_at' (tcbSchedNext tcb) s + \ none_top tcb_at' (tcbSchedNext (F tcb)) s)" assumes y: "\tcb. is_aligned (tcbIPCBuffer tcb) msg_align_bits \ is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits" assumes u: "\tcb. tcbDomain tcb \ maxDomain \ tcbDomain (F tcb) \ maxDomain" assumes w: "\tcb. tcbPriority tcb \ maxPriority \ tcbPriority (F tcb) \ maxPriority" assumes w': "\tcb. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" shows - "\valid_pspace' and (\s. P \ st_tcb_at' Q t s \ bound_tcb_at' Q' t s \ - bound_sc_tcb_at' Q'' t s \ bound_yt_tcb_at' Q''' t s)\ + "\valid_pspace' and (\s. P \ st_tcb_at' Q t s \ bound_tcb_at' Q' t s + \ obj_at' (\tcb. Q'' (tcbSchedPrev tcb)) t s + \ obj_at' (\tcb. Q''' (tcbSchedNext tcb)) t s)\ threadSet F t - \\rv. valid_pspace'\" + \\_. valid_pspace'\" apply (simp add: valid_pspace'_def threadSet_def) apply (rule hoare_pre, - wpsimp wp: setObject_tcb_valid_objs setObject_tcb_valid_replies' - getObject_tcb_wp) + wp setObject_tcb_valid_objs getObject_tcb_wp) apply (clarsimp simp: obj_at'_def projectKOs 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 - split_paired_Ball y u w v1 v2 v3 w') - apply (drule sym, fastforce simp: z') + split_paired_Ball y u w v w' p n) done lemmas threadSet_valid_pspace'T = @@ -664,88 +866,48 @@ lemmas threadSet_ifunsafe' = threadSet_ifunsafe'T [OF all_tcbI, OF ball_tcb_cte_casesI] lemma threadSet_state_refs_of'_helper[simp]: - "{r. (r \ tcb_st_refs_of' ts \ r \ tcb_bound_refs' ntfnptr sc_ptr yt_ptr) - \ (snd r = TCBBound \ snd r = TCBSchedContext \ snd r = TCBYieldTo)} - = tcb_bound_refs' ntfnptr sc_ptr yt_ptr" - by (auto simp: tcb_st_refs_of'_def tcb_bound_refs'_def get_refs_def - split: thread_state.splits reftype.splits option.splits) + "{r. (r \ tcb_st_refs_of' ts \ + r \ tcb_bound_refs' ntfnptr) \ + snd r = TCBBound} = + tcb_bound_refs' ntfnptr" + by (auto simp: tcb_st_refs_of'_def tcb_bound_refs'_def + split: thread_state.splits) lemma threadSet_state_refs_of'_helper'[simp]: - "{r. (r \ tcb_st_refs_of' ts \ r \ tcb_bound_refs' ntfnptr sc_ptr yt_ptr) - \ (snd r \ TCBBound \ snd r \ TCBSchedContext \ snd r \ TCBYieldTo)} - = tcb_st_refs_of' ts" - by (auto simp: tcb_st_refs_of'_def tcb_bound_refs'_def get_refs_def - split: thread_state.splits reftype.splits option.splits) - -lemma threadSet_state_refs_of'_helper_TCBBound[simp]: - "{r. (r \ tcb_st_refs_of' (tcbState obj) - \ r \ tcb_bound_refs' (tcbBoundNotification obj)(tcbSchedContext obj) (tcbYieldTo obj)) - \ snd r = TCBBound} - = get_refs TCBBound (tcbBoundNotification obj)" - by (auto simp: tcb_st_refs_of'_def tcb_bound_refs'_def get_refs_def - split: thread_state.splits reftype.splits option.splits) - -lemma threadSet_state_refs_of'_helper_TCBSchedContext[simp]: - "{r. (r \ tcb_st_refs_of' (tcbState obj) - \ r \ tcb_bound_refs' (tcbBoundNotification obj)(tcbSchedContext obj) (tcbYieldTo obj)) - \ snd r = TCBSchedContext} - = get_refs TCBSchedContext (tcbSchedContext obj)" - by (auto simp: tcb_st_refs_of'_def tcb_bound_refs'_def get_refs_def - split: thread_state.splits reftype.splits option.splits) - -lemma threadSet_state_refs_of'_helper_TCBYieldTo[simp]: - "{r. (r \ tcb_st_refs_of' (tcbState obj) - \ r \ tcb_bound_refs' (tcbBoundNotification obj)(tcbSchedContext obj) (tcbYieldTo obj)) - \ snd r = TCBYieldTo} - = get_refs TCBYieldTo (tcbYieldTo obj)" - by (auto simp: tcb_st_refs_of'_def tcb_bound_refs'_def get_refs_def - split: thread_state.splits reftype.splits option.splits) + "{r. (r \ tcb_st_refs_of' ts \ + r \ tcb_bound_refs' ntfnptr) \ + snd r \ TCBBound} = + tcb_st_refs_of' ts" + by (auto simp: tcb_st_refs_of'_def tcb_bound_refs'_def + split: thread_state.splits) lemma threadSet_state_refs_of'T_P: assumes x: "\tcb. (P' \ Q (tcbState tcb)) \ tcb_st_refs_of' (tcbState (F tcb)) = f' (tcb_st_refs_of' (tcbState tcb))" assumes y: "\tcb. (P' \ Q' (tcbBoundNotification tcb)) \ - (get_refs TCBBound (tcbBoundNotification (F tcb)) - = (g' (get_refs TCBBound (tcbBoundNotification tcb))))" - assumes z: "\tcb. (P' \ Q'' (tcbSchedContext tcb)) \ - (get_refs TCBSchedContext (tcbSchedContext (F tcb)) - = (h' (get_refs TCBSchedContext (tcbSchedContext tcb))))" - assumes w: "\tcb. (P' \ Q''' (tcbYieldTo tcb)) \ - (get_refs TCBYieldTo (tcbYieldTo (F tcb)) - = (i' (get_refs TCBYieldTo (tcbYieldTo tcb))))" + tcb_bound_refs' (tcbBoundNotification (F tcb)) + = g' (tcb_bound_refs' (tcbBoundNotification tcb))" shows - "\\s. P ((state_refs_of' s) (t := f' {r \ state_refs_of' s t. snd r \ {TCBBound, TCBSchedContext, TCBYieldTo}} - \ g' {r \ state_refs_of' s t. snd r = TCBBound} - \ h' {r \ state_refs_of' s t. snd r = TCBSchedContext} - \ i' {r \ state_refs_of' s t. snd r = TCBYieldTo})) - \ (P' \ st_tcb_at' Q t s \ bound_tcb_at' Q' t s \ bound_sc_tcb_at' Q'' t s - \ bound_yt_tcb_at' Q''' t s)\ - threadSet F t + "\\s. P ((state_refs_of' s) (t := f' {r \ state_refs_of' s t. snd r \ TCBBound} + \ g' {r \ state_refs_of' s t. snd r = TCBBound})) + \ (P' \ st_tcb_at' Q t s \ bound_tcb_at' Q' t s)\ + threadSet F t \\rv s. P (state_refs_of' s)\" apply (simp add: threadSet_def) apply (wp getObject_tcb_wp) - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def tcb_bound_refs'_def + apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def elim!: rsubst[where P=P] intro!: ext) apply (cut_tac s=s and p=t and 'a=tcb in ko_at_state_refs_ofD') apply (simp add: obj_at'_def projectKOs) - apply (fastforce simp: x y z w) + apply (clarsimp simp: x y) done lemmas threadSet_state_refs_of'T = threadSet_state_refs_of'T_P [where P'=False, simplified] lemmas threadSet_state_refs_of' = - threadSet_state_refs_of'T [OF all_tcbI all_tcbI all_tcbI all_tcbI] - -lemma state_refs_of'_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} - \ {r \ state_refs_of' s t. snd r = TCBSchedContext} - \ {r \ state_refs_of' s t. snd r = TCBYieldTo} - = state_refs_of' s t" - by (auto simp: tcb_st_refs_of'_def tcb_bound_refs'_def get_refs_def - split: thread_state.splits reftype.splits option.splits) + threadSet_state_refs_of'T [OF all_tcbI all_tcbI] lemma threadSet_iflive'T: assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" @@ -753,11 +915,6 @@ lemma threadSet_iflive'T: "\\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. (tcbState tcb = Inactive \ tcbState tcb = IdleThreadState) \ tcbState (F tcb) \ Inactive \ tcbState (F tcb) \ IdleThreadState @@ -778,9 +935,6 @@ lemma threadSet_iflive'T: apply (rule impI, clarsimp) apply (erule if_live_then_nonz_capE') apply (clarsimp simp: ko_wp_at'_def) - apply (intro conjI) - apply (metis if_live_then_nonz_capE' ko_wp_at'_def live'.simps(1)) - apply (metis if_live_then_nonz_capE' ko_wp_at'_def live'.simps(1)) apply (clarsimp simp: bspec_split [OF spec [OF x]]) done @@ -806,13 +960,6 @@ lemma threadSet_cte_wp_at'T: lemmas threadSet_cte_wp_at' = threadSet_cte_wp_at'T [OF all_tcbI, OF ball_tcb_cte_casesI] -lemmas threadSet_cap_to' = ex_nonz_cap_to_pres' [OF threadSet_cte_wp_at'] - -lemma threadSet_cap_to: - "(\tcb. \(getF, v)\ran tcb_cte_cases. getF (f tcb) = getF tcb) - \ \ex_nonz_cap_to' p\ threadSet f tptr \\_. ex_nonz_cap_to' p\" - by (wpsimp wp: hoare_vcg_ex_lift threadSet_cte_wp_at' simp: ex_nonz_cap_to'_def tcb_cte_cases_def) - lemma threadSet_ctes_ofT: assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" @@ -827,9 +974,7 @@ lemma threadSet_ctes_ofT: lemmas threadSet_ctes_of = threadSet_ctes_ofT [OF all_tcbI, OF ball_tcb_cte_casesI] -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] +lemmas threadSet_cap_to' = ex_nonz_cap_to_pres' [OF threadSet_cte_wp_at'] lemma threadSet_cap_to: "(\tcb. \(getF, v)\ran tcb_cte_cases. getF (f tcb) = getF tcb) @@ -838,42 +983,65 @@ lemma threadSet_cap_to: simp: ex_nonz_cap_to'_def tcb_cte_cases_def objBits_simps') lemma threadSet_idle'T: + assumes x: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" shows "\\s. valid_idle' s - \ (t = ksIdleThread s \ (\tcb. ko_at' tcb t s \ idle_tcb' tcb \ idle_tcb' (F tcb)))\ - threadSet F t + \ (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 (wpsimp wp: setObject_tcb_idle' getObject_tcb_wp - simp: obj_at'_def projectKOs valid_idle'_def pred_tcb_at'_def threadSet_def) + apply (wp setObject_tcb_idle' getObject_tcb_wp) + apply (clarsimp simp: obj_at'_def projectKOs) + apply (clarsimp simp: valid_idle'_def pred_tcb_at'_def obj_at'_def projectKOs idle_tcb'_def) done lemmas threadSet_idle' = - (*threadSet_idle'T [OF all_tcbI, OF ball_tcb_cte_casesI]*) - threadSet_idle'T + threadSet_idle'T [OF all_tcbI, OF ball_tcb_cte_casesI] + +lemma set_tcb_valid_bitmapQ[wp]: + "\ valid_bitmapQ \ setObject t (f tcb :: tcb) \\_. valid_bitmapQ \" + apply (rule setObject_tcb_pre) + apply (simp add: bitmapQ_defs setObject_def split_def) + apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ + done + +lemma set_tcb_bitmapQ_no_L1_orphans[wp]: + "\ bitmapQ_no_L1_orphans \ setObject t (f tcb :: tcb) \\_. bitmapQ_no_L1_orphans \" + apply (rule setObject_tcb_pre) + apply (simp add: bitmapQ_defs setObject_def split_def) + apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ + done + +lemma set_tcb_bitmapQ_no_L2_orphans[wp]: + "\ bitmapQ_no_L2_orphans \ setObject t (f tcb :: tcb) \\_. bitmapQ_no_L2_orphans \" + apply (rule setObject_tcb_pre) + apply (simp add: bitmapQ_defs setObject_def split_def) + apply (wp hoare_Ball_helper hoare_vcg_all_lift updateObject_default_inv | simp add: bitmapQ_def)+ + done lemma threadSet_valid_bitmapQ[wp]: "\ valid_bitmapQ \ threadSet f t \ \rv. valid_bitmapQ \" unfolding bitmapQ_defs threadSet_def by (clarsimp simp: setObject_def split_def) - (wp | simp add: updateObject_default_def objBits_simps)+ + (wp | simp add: updateObject_default_def)+ lemma threadSet_valid_bitmapQ_no_L1_orphans[wp]: "\ bitmapQ_no_L1_orphans \ threadSet f t \ \rv. bitmapQ_no_L1_orphans \" unfolding bitmapQ_defs threadSet_def by (clarsimp simp: setObject_def split_def) - (wp | simp add: updateObject_default_def objBits_simps)+ + (wp | simp add: updateObject_default_def)+ lemma threadSet_valid_bitmapQ_no_L2_orphans[wp]: "\ bitmapQ_no_L2_orphans \ threadSet f t \ \rv. bitmapQ_no_L2_orphans \" unfolding bitmapQ_defs threadSet_def by (clarsimp simp: setObject_def split_def) - (wp | simp add: updateObject_default_def objBits_simps)+ + (wp | simp add: updateObject_default_def)+ lemma threadSet_cur: "\\s. cur_tcb' s\ threadSet f t \\rv s. cur_tcb' s\" - apply (wpsimp simp: threadSet_def cur_tcb'_def - wp: hoare_lift_Pf[OF setObject_tcb_at' setObject_ct_inv]) + apply (simp add: threadSet_def cur_tcb'_def) + apply (wp hoare_lift_Pf [OF setObject_tcb_at'] setObject_ct_inv) done lemma modifyReadyQueuesL1Bitmap_obj_at[wp]: @@ -887,17 +1055,22 @@ crunch setThreadState, setBoundNotification for valid_arch' [wp]: valid_arch_state' (simp: unless_def crunch_simps wp: crunch_wps) +crunch threadSet + for ksInterrupt'[wp]: "\s. P (ksInterruptState s)" + (wp: setObject_ksInterrupt updateObject_default_inv) + lemma threadSet_typ_at'[wp]: "\\s. P (typ_at' T p s)\ threadSet t F \\rv s. P (typ_at' T p s)\" - by (wpsimp simp: threadSet_def wp: setObject_typ_at') + by (simp add: threadSet_def, wp setObject_typ_at') + +lemmas threadSet_typ_at_lifts[wp] = typ_at_lifts [OF threadSet_typ_at'] lemma setObject_tcb_pde_mappings'[wp]: "\valid_pde_mappings'\ setObject p (tcb :: tcb) \\rv. valid_pde_mappings'\" - by (wpsimp wp: valid_pde_mappings_lift' setObject_typ_at') - -lemma setObject_sc_pde_mappings'[wp]: - "\valid_pde_mappings'\ setObject p (sc :: sched_context) \\rv. valid_pde_mappings'\" - by (wpsimp wp: valid_pde_mappings_lift' setObject_typ_at') + apply (wp valid_pde_mappings_lift' setObject_typ_at') + apply (rule obj_at_setObject2) + apply (auto dest: updateObject_default_result) + done crunch threadSet for irq_states' [wp]: valid_irq_states' @@ -913,9 +1086,10 @@ lemma threadSet_obj_at'_really_strongest: apply (rule hoare_post_imp[where Q'="\rv s. \ tcb_at' t s \ tcb_at' t s"]) apply simp apply (subst simp_thms(21)[symmetric], rule hoare_vcg_conj_lift) - apply (rule getObject_tcb_inv) + apply (rule getObject_inv_tcb) apply (rule hoare_strengthen_post [OF getObject_ko_at]) - apply simp + apply simp + apply (simp add: objBits_simps') apply (erule obj_at'_weakenE) apply simp apply (cases "t = t'", simp_all) @@ -1003,17 +1177,37 @@ proof - apply (clarsimp) apply (frule_tac P=P' and Q="\tcb. \ P' tcb" in pred_tcb_at_conj') apply (clarsimp)+ - apply (wp hoare_convert_imp pos) - apply (clarsimp simp: tcb_at_typ_at' pred_tcb_at'_def not_obj_at' - elim!: obj_at'_weakenE) + apply (wp hoare_convert_imp) + apply (simp add: typ_at_tcb' [symmetric]) + apply (wp pos)+ + apply (clarsimp simp: pred_tcb_at'_def not_obj_at' elim!: obj_at'_weakenE) done qed -lemma threadSet_mdb': - "\valid_mdb' and obj_at' (\t. \(getF, setF) \ ran tcb_cte_cases. getF t = getF (f t)) t\ - threadSet f t - \\rv. valid_mdb'\" - by (wpsimp wp: setObject_tcb_mdb' getTCB_wp simp: threadSet_def obj_at'_def) +lemma threadSet_ct[wp]: + "\\s. P (ksCurThread s)\ threadSet f t \\rv s. P (ksCurThread s)\" + apply (simp add: threadSet_def) + apply (wp setObject_ct_inv) + done + +lemma threadSet_cd[wp]: + "\\s. P (ksCurDomain s)\ threadSet f t \\rv s. P (ksCurDomain s)\" + apply (simp add: threadSet_def) + apply (wp setObject_cd_inv) + done + + +lemma threadSet_ksDomSchedule[wp]: + "\\s. P (ksDomSchedule s)\ threadSet f t \\rv s. P (ksDomSchedule s)\" + apply (simp add: threadSet_def) + apply (wp setObject_ksDomSchedule_inv) + done + +lemma threadSet_it[wp]: + "\\s. P (ksIdleThread s)\ threadSet f t \\rv s. P (ksIdleThread s)\" + apply (simp add: threadSet_def) + apply (wp setObject_it_inv) + done lemma threadSet_sch_act: "(\tcb. tcbState (F tcb) = tcbState tcb \ tcbDomain (F tcb) = tcbDomain tcb) \ @@ -1037,11 +1231,11 @@ lemma threadSet_sch_actT_P: 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) + in use_valid [OF _ threadSet_nosch], assumption) apply (frule_tac P1="(=) (ksCurThread s)" - in use_valid [OF _ threadSet.ct], rule refl) + in use_valid [OF _ threadSet_ct], rule refl) apply (frule_tac P1="(=) (ksCurDomain s)" - in use_valid [OF _ threadSet.cur_domain], rule refl) + in use_valid [OF _ threadSet_cd], rule refl) apply (case_tac "ksSchedulerAction b", simp_all add: ct_in_state'_def pred_tcb_at'_def) apply (subgoal_tac "t \ ksCurThread s") @@ -1086,7 +1280,7 @@ lemma threadSet_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 (rule updateObject_tcb_inv) apply (wps setObject_ct_inv) apply (wp setObject_tcb_strongest getObject_tcb_wp)+ apply (case_tac "t = ksCurThread s") @@ -1094,9 +1288,8 @@ lemma threadSet_not_inQ: 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" + "{r \ state_refs_of' s t. snd r \ TCBBound} + \ {r \ state_refs_of' s t. snd r = TCBBound} = state_refs_of' s t" by auto lemma threadSet_ct_idle_or_in_cur_domain': @@ -1105,9 +1298,24 @@ lemma threadSet_ct_idle_or_in_cur_domain': apply (wp hoare_vcg_disj_lift| simp)+ done +crunch threadSet + for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + (wp: setObject_ksPSpace_only updateObject_default_inv) +crunch threadSet + for gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: setObject_ksPSpace_only updateObject_default_inv) + +lemma setObject_tcb_ksDomScheduleIdx [wp]: + "\\s. P (ksDomScheduleIdx s) \ setObject t (v::tcb) \\_ s. P (ksDomScheduleIdx s)\" + apply (simp add:setObject_def) + apply (simp add: updateObject_default_def in_monad) + apply (wp|wpc)+ + apply (simp add: projectKOs) + done + lemma threadSet_valid_dom_schedule': "\ valid_dom_schedule'\ threadSet F t \\_. valid_dom_schedule'\" - unfolding threadSet_def valid_dom_schedule'_def + unfolding threadSet_def by (wp setObject_ksDomSchedule_inv hoare_Ball_helper) lemma threadSet_wp: @@ -1223,30 +1431,10 @@ lemma global'_no_ex_cap: apply (clarsimp simp: cte_wp_at'_def dest!: zobj_refs'_capRange, blast) done -lemma global'_sc_no_ex_cap: - "\valid_global_refs' s; valid_pspace' s\ \ \ ex_nonz_cap_to' idle_sc_ptr s" - apply (clarsimp simp: ex_nonz_cap_to'_def valid_global_refs'_def valid_refs'_def2 valid_pspace'_def) - apply (drule cte_wp_at_norm', clarsimp) - apply (frule(1) cte_wp_at_valid_objs_valid_cap', clarsimp) - apply (clarsimp simp: cte_wp_at'_def dest!: zobj_refs'_capRange, blast) - done - lemma getObject_tcb_sp: "\P\ getObject r \\t::tcb. P and ko_at' t r\" by (wp getObject_obj_at'; simp) -lemma threadGet_sp': - "\P\ threadGet f p \\t. obj_at' (\t'. f t' = t) p and P\" - including no_pre - apply (simp add: threadGet_getObject) - apply wp - apply (rule hoare_strengthen_post) - apply (rule getObject_tcb_sp) - apply clarsimp - apply (erule obj_at'_weakenE) - apply simp - done - lemma threadSet_valid_objs': "\valid_objs' and (\s. \tcb. valid_tcb' tcb s \ valid_tcb' (f tcb) s)\ threadSet f t @@ -1269,7 +1457,7 @@ lemma threadSet_valid_objs': lemmas typ_at'_valid_tcb'_lift = typ_at'_valid_obj'_lift[where obj="KOTCB tcb" for tcb, unfolded valid_obj'_def, simplified] -lemmas setObject_valid_tcb' = typ_at'_valid_tcb'_lift[OF setObject_typ_at' setObject_sc_at'_n] +lemmas setObject_valid_tcb' = typ_at'_valid_tcb'_lift[OF setObject_typ_at'] lemma setObject_valid_tcbs': assumes preserve_valid_tcb': "\s s' ko ko' x n tcb tcb'. @@ -1302,13 +1490,13 @@ lemma setObject_valid_tcbs': lemma setObject_tcb_valid_tcbs': "\valid_tcbs' and (tcb_at' t and valid_tcb' v)\ setObject t (v :: tcb) \\rv. valid_tcbs'\" apply (rule setObject_valid_tcbs') - apply (clarsimp simp: updateObject_default_def in_monad projectKOs project_inject) + apply (clarsimp simp: updateObject_default_def in_monad project_inject) done lemma threadSet_valid_tcb': "\valid_tcb' tcb and (\s. \tcb. valid_tcb' tcb s \ valid_tcb' (f tcb) s)\ threadSet f t - \\rv. valid_tcb' tcb\" + \\_. valid_tcb' tcb\" apply (simp add: threadSet_def) apply (wpsimp wp: setObject_valid_tcb') done @@ -1316,18 +1504,18 @@ lemma threadSet_valid_tcb': lemma threadSet_valid_tcbs': "\valid_tcbs' and (\s. \tcb. valid_tcb' tcb s \ valid_tcb' (f tcb) s)\ threadSet f t - \\rv. valid_tcbs'\" + \\_. valid_tcbs'\" apply (simp add: threadSet_def) - apply (rule bind_wp[OF _ get_tcb_sp']) + apply (rule bind_wp[OF _ getObject_tcb_sp]) apply (wpsimp wp: setObject_tcb_valid_tcbs') - apply (clarsimp simp: obj_at'_def projectKOs valid_tcbs'_def) + apply (clarsimp simp: obj_at'_def valid_tcbs'_def projectKOs) done lemma asUser_valid_tcbs'[wp]: "asUser t f \valid_tcbs'\" apply (simp add: asUser_def split_def) apply (wpsimp wp: threadSet_valid_tcbs' hoare_drop_imps - simp: valid_tcb'_def tcb_cte_cases_def) + simp: valid_tcb'_def tcb_cte_cases_def objBits_simps') done lemma asUser_corres': @@ -1345,11 +1533,11 @@ proof - apply (rule corres_cross_over_guard[where Q="tcb_at' t"]) apply (fastforce simp: tcb_at_cross state_relation_def) apply (rule corres_guard_imp) - apply (simp add: threadGet_getObject) - apply (rule corres_bind_return) - apply (rule corres_split[OF getObject_TCB_corres]) - apply (simp add: tcb_relation_def arch_tcb_relation_def) - apply wpsimp+ + apply (rule corres_gets_the) + apply (simp add: threadGet_def) + apply (rule corres_rel_imp [OF corres_get_tcb]) + apply (simp add: tcb_relation_def arch_tcb_relation_def) + apply (simp add: tcb_at_def)+ done have L2: "\tcb tcb' con con'. \ tcb_relation tcb tcb'; con = con'\ \ tcb_relation (tcb \ tcb_arch := arch_tcb_context_set con (tcb_arch tcb) \) @@ -1361,7 +1549,7 @@ proof - (set_object add (TCB (tcb \ tcb_arch := arch_tcb_context_set con (tcb_arch tcb) \))) (setObject add (tcb' \ tcbArch := atcbContextSet con' (tcbArch tcb') \))" by (rule setObject_update_TCB_corres [OF L2], - (simp add: tcb_cte_cases_def tcb_cap_cases_def)+) + (simp add: tcb_cte_cases_def tcb_cap_cases_def cteSizeBits_def exst_same_def)+) have L4: "\con con'. con = con' \ corres (\(irv, nc) (irv', nc'). r irv irv' \ nc = nc') \ \ (select_f (f con)) (select_f (g con'))" @@ -1395,7 +1583,7 @@ lemma asUser_corres: apply (rule corres_guard_imp) apply (rule asUser_corres' [OF y]) apply (simp add: invs_def valid_state_def valid_pspace_def) - apply (simp add: invs'_def valid_pspace'_def) + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) done lemma asUser_inv: @@ -1407,14 +1595,12 @@ proof - have R: "\x. tcbArch_update (\_. tcbArch x) x = x" by (case_tac x, simp) show ?thesis - apply (simp add: asUser_def split_def threadGet_getObject threadSet_def + apply (simp add: asUser_def split_def threadGet_def threadSet_def liftM_def bind_assoc) - apply (clarsimp simp: valid_def in_monad getObject_def readObject_def setObject_def + apply (clarsimp simp: valid_def in_monad getObject_def setObject_def loadObject_default_def projectKOs objBits_simps' modify_def split_def updateObject_default_def - in_magnitude_check select_f_def omonad_defs obind_def - split del: if_split - split: option.split_asm if_split_asm + in_magnitude_check select_f_def dest!: P) apply (simp add: R map_upd_triv) done @@ -1431,44 +1617,18 @@ lemma user_getreg_inv'[wp]: "\P\ asUser t (getRegister r) \\x. P\" by (wp asUser_inv) -end - -crunch asUser - 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 asUser: typ_at_all_props' "asUser tptr f" - by typ_at_props' - -lemma threadGet_wp: - "\\s. tcb_at' t 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) - 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) - apply (clarsimp simp: obj_at'_def) - done +lemma asUser_typ_at' [wp]: + "\\s. P (typ_at' T p s)\ asUser t' f \\rv s. P (typ_at' T p s)\" + by (simp add: asUser_def bind_assoc split_def, wp select_f_inv) -lemma inReleaseQueue_wp: - "\\s. tcb_at' t s \ (\tcb. ko_at' tcb t s \ P (tcbInReleaseQueue tcb) s)\ - inReleaseQueue t - \P\" - apply (simp add: inReleaseQueue_def) - apply (wp threadGet_wp) - done +lemmas asUser_typ_ats[wp] = typ_at_lifts [OF asUser_typ_at'] lemma asUser_invs[wp]: "\invs' and tcb_at' t\ asUser t m \\rv. invs'\" apply (simp add: asUser_def split_def) - apply (wpsimp wp: threadSet_invs_trivial threadGet_wp) - apply (fastforce dest!: invs_valid_release_queue' - simp: obj_at'_def valid_release_queue'_def) + apply (wp hoare_drop_imps | simp)+ + + apply (wp threadSet_invs_trivial hoare_drop_imps | simp)+ done lemma asUser_nosch[wp]: @@ -1506,7 +1666,7 @@ lemma asUser_st_refs_of'[wp]: asUser t m \\rv s. P (state_refs_of' s)\" apply (simp add: asUser_def split_def) - apply (wp threadSet_state_refs_of'[where h'=id and i'=id] hoare_drop_imps | simp)+ + apply (wp threadSet_state_refs_of' hoare_drop_imps | simp)+ done lemma asUser_iflive'[wp]: @@ -1543,22 +1703,28 @@ lemma asUser_pred_tcb_at' [wp]: crunch asUser for ct[wp]: "\s. P (ksCurThread s)" and cur_domain[wp]: "\s. P (ksCurDomain s)" - (simp: crunch_simps wp: hoare_drop_imps getObject_tcb_inv setObject_ct_inv) + (simp: crunch_simps wp: hoare_drop_imps getObject_inv_tcb setObject_ct_inv) lemma asUser_tcb_in_cur_domain'[wp]: "\tcb_in_cur_domain' t'\ asUser t m \\_. tcb_in_cur_domain' t'\" - unfolding asUser_def tcb_in_cur_domain'_def threadGet_getObject - by (wpsimp wp: threadSet_obj_at'_strongish getObject_tcb_wp | wps | clarsimp simp: obj_at'_def)+ + apply (simp add: asUser_def tcb_in_cur_domain'_def threadGet_def) + apply (wp | wpc | simp)+ + apply (rule_tac f="ksCurDomain" in hoare_lift_Pf) + apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | simp)+ + apply (clarsimp simp: obj_at'_def) + done lemma asUser_tcbDomain_inv[wp]: "\obj_at' (\tcb. P (tcbDomain tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbDomain tcb)) t'\" - unfolding asUser_def tcb_in_cur_domain'_def threadGet_getObject - by (wpsimp wp: threadSet_obj_at'_strongish getObject_tcb_wp | wps | clarsimp simp: obj_at'_def)+ + apply (simp add: asUser_def tcb_in_cur_domain'_def threadGet_def) + apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | wpc | simp | clarsimp simp: obj_at'_def)+ + done lemma asUser_tcbPriority_inv[wp]: "\obj_at' (\tcb. P (tcbPriority tcb)) t'\ asUser t m \\_. obj_at' (\tcb. P (tcbPriority tcb)) t'\" - unfolding asUser_def tcb_in_cur_domain'_def threadGet_getObject - by (wpsimp wp: threadSet_obj_at'_strongish getObject_tcb_wp | wps | clarsimp simp: obj_at'_def)+ + apply (simp add: asUser_def tcb_in_cur_domain'_def threadGet_def) + apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | wpc | simp | clarsimp simp: obj_at'_def)+ + done lemma asUser_sch_act_wf[wp]: "\\s. sch_act_wf (ksSchedulerAction s) s\ @@ -1579,8 +1745,6 @@ lemma no_fail_asUser [wp]: apply (wpsimp wp: hoare_drop_imps no_fail_threadGet)+ done -context begin interpretation Arch . (*FIXME: arch_split*) - lemma asUser_setRegister_corres: "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (as_user t (setRegister r v)) @@ -1590,37 +1754,16 @@ lemma asUser_setRegister_corres: apply (rule corres_modify'; simp) done -end - -lemma getThreadState_corres': - "t = t' \ - corres thread_state_relation (tcb_at t) (tcb_at' t) - (get_thread_state t) (getThreadState t')" +lemma getThreadState_corres: + "corres thread_state_relation (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_thread_state t) (getThreadState t)" apply (simp add: get_thread_state_def getThreadState_def) apply (rule threadGet_corres) apply (simp add: tcb_relation_def) done -lemmas getThreadState_corres = getThreadState_corres'[OF refl] - -lemma is_blocked_corres: - "corres (=) (pspace_aligned and pspace_distinct and tcb_at tcb_ptr) \ - (is_blocked tcb_ptr) (isBlocked tcb_ptr)" - apply (rule_tac Q="tcb_at' tcb_ptr" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD elim!: tcb_at_cross) - unfolding is_blocked_def isBlocked_def - apply clarsimp - apply (rule corres_guard_imp) - apply (rule corres_underlying_split[where b=return and Q="\\" and Q'="\\", simplified, - OF getThreadState_corres ]) - apply (rename_tac st st') - apply (case_tac st; clarsimp) - apply wpsimp+ - done - -lemma gts_wf'[wp]: - "\valid_objs'\ getThreadState t \valid_tcb_state'\" - apply (simp add: getThreadState_def threadGet_getObject liftM_def) +lemma gts_wf'[wp]: "\tcb_at' t and invs'\ getThreadState t \valid_tcb_state'\" + apply (simp add: getThreadState_def threadGet_def liftM_def) apply (wp getObject_tcb_wp) apply clarsimp apply (drule obj_at_ko_at', clarsimp) @@ -1629,7 +1772,7 @@ lemma gts_wf'[wp]: 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 (simp add: getThreadState_def threadGet_def liftM_def) apply wp apply (rule hoare_chain) apply (rule obj_at_getObject) @@ -1651,7 +1794,7 @@ lemma getBoundNotification_corres: done lemma gbn_bound_tcb_at'[wp]: "\bound_tcb_at' P t\ getBoundNotification t \\rv s. P rv\" - apply (simp add: getBoundNotification_def threadGet_getObject) + apply (simp add: getBoundNotification_def threadGet_def liftM_def) apply wp apply (rule hoare_strengthen_post) apply (rule obj_at_getObject) @@ -1674,19 +1817,15 @@ lemma isStopped_def2: lemma isRunnable_def2: "isRunnable t = liftM runnable' (getThreadState t)" - apply (simp add: isRunnable_def liftM_def) + apply (simp add: isRunnable_def isStopped_def2 liftM_def) apply (rule bind_eqI, rule ext, rule arg_cong) apply (case_tac state) apply (clarsimp)+ done -lemma isBlocked_inv[wp]: - "\P\ isBlocked t \\rv. P\" - by (simp add: isBlocked_def | wp gts_inv')+ - lemma isStopped_inv[wp]: "\P\ isStopped t \\rv. P\" - by (simp add: isStopped_def | wp gts_inv')+ + by (simp add: isStopped_def2 | wp gts_inv')+ lemma isRunnable_inv[wp]: "\P\ isRunnable t \\rv. P\" @@ -1695,14 +1834,14 @@ lemma isRunnable_inv[wp]: lemma isRunnable_wp[wp]: "\\s. Q (st_tcb_at' (runnable') t s) s\ isRunnable t \Q\" apply (simp add: isRunnable_def2) - apply (wpsimp simp: getThreadState_def threadGet_getObject wp: getObject_tcb_wp) + apply (wpsimp simp: getThreadState_def threadGet_def wp: getObject_tcb_wp) apply (clarsimp simp: getObject_def valid_def in_monad st_tcb_at'_def loadObject_default_def projectKOs obj_at'_def split_def objBits_simps in_magnitude_check) done lemma setQueue_obj_at[wp]: - "setQueue d p q \\s. Q (obj_at' P t s)\" + "\obj_at' P t\ setQueue d p q \\rv. obj_at' P t\" apply (simp add: setQueue_def) apply wp apply (fastforce intro: obj_at'_pspaceI) @@ -1751,7 +1890,42 @@ lemma getObject_obj_at_tcb: lemma threadGet_obj_at': "\obj_at' (\t. P (f t) t) t\ threadGet f t \\rv. obj_at' (P rv) t\" - by (simp add: threadGet_getObject | wp getObject_obj_at_tcb)+ + by (simp add: threadGet_def o_def | wp getObject_obj_at_tcb)+ + +lemma corres_get_etcb: + "corres (etcb_relation) (is_etcb_at t) (tcb_at' t) + (gets_the (get_etcb t)) (getObject t)" + apply (rule corres_no_failI) + apply wp + apply (clarsimp simp add: get_etcb_def gets_the_def gets_def + get_def assert_opt_def bind_def + return_def fail_def + split: option.splits + ) + apply (frule in_inv_by_hoareD [OF getObject_inv_tcb]) + apply (clarsimp simp add: is_etcb_at_def obj_at'_def projectKO_def + projectKO_opt_tcb split_def + getObject_def loadObject_default_def in_monad) + apply (case_tac bb) + apply (simp_all add: fail_def return_def) + apply (clarsimp simp add: state_relation_def ekheap_relation_def) + apply (drule bspec) + apply clarsimp + apply blast + apply (clarsimp simp add: other_obj_relation_def lookupAround2_known1) + done + + +lemma ethreadget_corres: + assumes x: "\etcb tcb'. etcb_relation etcb tcb' \ r (f etcb) (f' tcb')" + shows "corres r (is_etcb_at t) (tcb_at' t) (ethread_get f t) (threadGet f' t)" + apply (simp add: ethread_get_def threadGet_def) + apply (fold liftM_def) + apply simp + apply (rule corres_rel_imp) + apply (rule corres_get_etcb) + apply (simp add: x) + done lemma getQueue_corres: "corres (\ls q. (ls = [] \ tcbQueueEmpty q) \ (ls \ [] \ tcbQueueHead q = Some (hd ls)) @@ -1792,242 +1966,392 @@ lemma removeFromBitmap_corres_noop: by (rule corres_noop) (wp | simp add: bitmap_fun_defs state_relation_def | rule no_fail_pre)+ -crunch addToBitmap, removeFromBitmap +crunch addToBitmap 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: hoare_drop_imps setCTE_typ_at') -global_interpretation addToBitmap: typ_at_all_props' "addToBitmap tdom prio" - by typ_at_props' +crunch removeFromBitmap + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: hoare_drop_imps setCTE_typ_at') -global_interpretation removeFromBitmap: typ_at_all_props' "removeFromBitmap tdom prio" - by typ_at_props' +lemmas addToBitmap_typ_ats [wp] = typ_at_lifts [OF addToBitmap_typ_at'] +lemmas removeFromBitmap_typ_ats [wp] = typ_at_lifts [OF removeFromBitmap_typ_at'] -lemma pspace_relation_tcb_domain_priority: - "\pspace_relation (kheap s) (ksPSpace s'); kheap s t = Some (TCB tcb); +lemma ekheap_relation_tcb_domain_priority: + "\ekheap_relation (ekheap s) (ksPSpace s'); ekheap s t = Some (tcb); ksPSpace s' t = Some (KOTCB tcb')\ - \ tcb_domain tcb = tcbDomain tcb' \ tcb_priority tcb = tcbPriority tcb'" - apply (clarsimp simp: pspace_relation_def) + \ tcbDomain tcb' = tcb_domain tcb \ tcbPriority tcb' = tcb_priority tcb" + apply (clarsimp simp: ekheap_relation_def) apply (drule_tac x=t in bspec, blast) - apply (drule_tac x="(t, other_obj_relation)" in bspec, simp) - apply (clarsimp simp: other_obj_relation_def tcb_relation_def) + apply (clarsimp simp: other_obj_relation_def etcb_relation_def) done -lemma tcbSchedEnqueue_corres: - "corres dc (tcb_at t and pspace_aligned and pspace_distinct) - (Invariants_H.valid_queues and valid_queues') - (tcb_sched_action (tcb_sched_enqueue) t) (tcbSchedEnqueue t)" - (is "corres _ _ ?conc_guard _ _") -proof - +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 - have ready_queues_helper: - "\t tcb s s'. \ obj_at' tcbQueued t s'; valid_queues' s'; kheap s t = Some (TCB tcb); - pspace_relation (kheap s) (ksPSpace s') \ - \ t \ set (ksReadyQueues s' (tcb_domain tcb, tcb_priority tcb))" - unfolding valid_queues'_def - apply (clarsimp dest: simp: obj_at'_def inQ_def tcb_relation_def projectKO_eq projectKO_tcb) - using pspace_relation_tcb_domain_priority by fastforce +lemma pspace_relation_tcb_relation: + "\pspace_relation (kheap s) (ksPSpace s'); kheap s ptr = Some (TCB tcb); + ksPSpace s' ptr = Some (KOTCB tcb')\ + \ tcb_relation tcb tcb'" + apply (clarsimp simp: pspace_relation_def) + apply (drule_tac x=ptr in bspec) + apply (fastforce simp: obj_at_def) + apply (clarsimp simp: tcb_relation_cut_def obj_at_def obj_at'_def) + done + +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 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')\" + supply fun_upd_apply[simp del] + unfolding threadSet_def setObject_def updateObject_default_def + apply (wpsimp wp: getObject_tcb_wp simp: updateObject_default_def) + apply normalise_obj_at' + 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 projectKOs) + apply (frule (1) pspace_relation_tcb_relation) + apply (fastforce simp: obj_at'_def projectKOs) + apply (fastforce dest!: tcb_rel) + done + +lemma ekheap_relation_update_tcbs: + "\ ekheap_relation (ekheap s) (ksPSpace s'); ekheap s x = Some oetcb; + ksPSpace s' x = Some (KOTCB otcb'); etcb_relation etcb tcb' \ + \ ekheap_relation ((ekheap s)(x \ etcb)) ((ksPSpace s')(x \ KOTCB tcb'))" + by (simp add: ekheap_relation_def) + +lemma ekheap_relation_update_concrete_tcb: + "\ekheap_relation (ekheap s) (ksPSpace s'); ekheap s ptr = Some etcb; + ksPSpace s' ptr = Some (KOTCB otcb'); + etcb_relation etcb tcb'\ + \ ekheap_relation (ekheap s) ((ksPSpace s')(ptr \ KOTCB tcb'))" + by (fastforce dest: ekheap_relation_update_tcbs simp: map_upd_triv) + +lemma ekheap_relation_etcb_relation: + "\ekheap_relation (ekheap s) (ksPSpace s'); ekheap s ptr = Some etcb; + ksPSpace s' ptr = Some (KOTCB tcb')\ + \ etcb_relation etcb tcb'" + apply (clarsimp simp: ekheap_relation_def) + apply (drule_tac x=ptr in bspec) + apply (fastforce simp: obj_at_def) + apply (clarsimp simp: obj_at_def obj_at'_def) + done + +lemma threadSet_ekheap_relation: + fixes s :: det_state + assumes etcb_rel: "(\etcb tcb'. etcb_relation etcb tcb' \ etcb_relation etcb (F tcb'))" + shows + "\\s'. ekheap_relation (ekheap s) (ksPSpace s') \ pspace_relation (kheap s) (ksPSpace s') + \ valid_etcbs s\ + threadSet F tcbPtr + \\_ s'. ekheap_relation (ekheap s) (ksPSpace s')\" + supply fun_upd_apply[simp del] + unfolding threadSet_def setObject_def updateObject_default_def + apply (wpsimp wp: getObject_tcb_wp simp: updateObject_default_def) + apply (frule tcb_at'_cross) + apply (fastforce simp: obj_at'_def) + apply normalise_obj_at' + apply (frule (1) tcb_at_is_etcb_at) + apply (clarsimp simp: obj_at_def is_tcb_def is_etcb_at_def) + apply (rename_tac ko, case_tac ko; clarsimp) + apply (rule ekheap_relation_update_concrete_tcb) + apply fastforce + apply fastforce + apply (fastforce simp: obj_at'_def projectKOs) + apply (frule (1) ekheap_relation_etcb_relation) + apply (fastforce simp: obj_at'_def projectKOs) + apply (fastforce dest!: etcb_rel) + done - show ?thesis - apply (rule corres_cross_over_guard[where Q="?conc_guard and tcb_at' t"]) - apply (fastforce intro: tcb_at_cross) - unfolding tcbSchedEnqueue_def tcb_sched_action_def - apply (rule corres_symb_exec_r[where Q'="\rv. tcb_at' t and Invariants_H.valid_queues - and valid_queues' - and obj_at' (\obj. tcbQueued obj = rv) t"]) - defer - apply (wp threadGet_obj_at'; simp_all) - apply (wpsimp wp: threadGet_inv) - apply (rule no_fail_pre, wp, blast) - apply (case_tac queued; simp_all) - apply (rule corres_no_failI) - apply (simp add: no_fail_return) - apply (clarsimp simp: in_monad gets_the_def bind_assoc - assert_opt_def exec_gets get_tcb_queue_def - set_tcb_queue_def simpler_modify_def ready_queues_relation_def - state_relation_def tcb_sched_enqueue_def thread_get_def get_tcb_def - gets_def get_def return_def fail_def bind_def tcb_at_def cdt_relation_def - split: option.splits Structures_A.kernel_object.splits) - using ready_queues_helper apply blast - - apply (clarsimp simp: when_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split[where r'="(=)", OF threadGet_corres], simp add: tcb_relation_def) - apply (rule corres_split[where r'="(=)", OF threadGet_corres], simp add: tcb_relation_def) - apply (rule corres_split[where r'="(=)"]) - apply (simp, rule getQueue_corres) - apply (rule corres_split_noop_rhs2) - apply (simp add: tcb_sched_enqueue_def split del: if_split) - apply (rule_tac P=\ and Q="K (t \ set queuea)" in corres_assume_pre) - apply (simp, rule setQueue_corres[unfolded dc_def]) - apply (rule corres_split_noop_rhs2) - apply (fastforce intro: addToBitmap_noop_corres) - apply (fastforce intro: threadSet_corres_noop simp: tcb_relation_def) - apply wp+ - apply (wp | simp add: threadGet_def)+ - apply (fastforce simp: valid_queues_def valid_queues_no_bitmap_def obj_at'_def inQ_def - projectKO_eq project_inject) - done -qed +lemma tcbQueued_update_pspace_relation[wp]: + fixes s :: det_state + shows "threadSet (tcbQueued_update f) tcbPtr \\s'. pspace_relation (kheap s) (ksPSpace s')\" + by (wpsimp wp: threadSet_pspace_relation simp: tcb_relation_def) -definition - weak_sch_act_wf :: "scheduler_action \ kernel_state \ bool" -where - "weak_sch_act_wf sa = (\s. \t. sa = SwitchToThread t \ st_tcb_at' runnable' t s \ tcb_in_cur_domain' t s)" +lemma tcbQueued_update_ekheap_relation[wp]: + fixes s :: det_state + shows + "\\s'. ekheap_relation (ekheap s) (ksPSpace s') \ pspace_relation (kheap s) (ksPSpace s') + \ valid_etcbs s\ + threadSet (tcbQueued_update f) tcbPtr + \\_ s'. ekheap_relation (ekheap s) (ksPSpace s')\" + by (wpsimp wp: threadSet_ekheap_relation simp: etcb_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 weak_sch_act_wf_updates[simp]: - "\f. weak_sch_act_wf sa (ksDomainTime_update f s) = weak_sch_act_wf sa s" - "\f. weak_sch_act_wf sa (ksReprogramTimer_update f s) = weak_sch_act_wf sa s" - "\f. weak_sch_act_wf sa (ksReleaseQueue_update f s) = weak_sch_act_wf sa s" - by (auto simp: weak_sch_act_wf_def tcb_in_cur_domain'_def) +lemma tcbQueueRemove_ekheap_relation[wp]: + fixes s :: det_state + shows + "\\s'. ekheap_relation (ekheap s) (ksPSpace s') \ pspace_relation (kheap s) (ksPSpace s') + \ valid_etcbs s\ + tcbQueueRemove queue tcbPtr + \\_ s'. ekheap_relation (ekheap s) (ksPSpace s')\" + unfolding tcbQueueRemove_def + by (wpsimp wp: threadSet_ekheap_relation threadSet_pspace_relation hoare_drop_imps + simp: tcb_relation_def etcb_relation_def) -lemma setSchedulerAction_corres: - "sched_act_relation sa sa' - \ corres dc \ \ (set_scheduler_action sa) (setSchedulerAction sa')" - apply (simp add: setSchedulerAction_def set_scheduler_action_def) - apply (rule corres_no_failI) - apply wp - apply (clarsimp simp: in_monad simpler_modify_def state_relation_def swp_def) +lemma threadSet_ghost_relation[wp]: + "threadSet f tcbPtr \\s'. ghost_relation (kheap s) (gsUserPages s') (gsCNodes s')\" + unfolding threadSet_def setObject_def updateObject_default_def + apply (wpsimp wp: getObject_tcb_wp simp: updateObject_default_def) + apply (clarsimp simp: obj_at'_def) done -lemma getSchedulerAction_corres: - "corres sched_act_relation \ \ (gets scheduler_action) getSchedulerAction" - apply (simp add: getSchedulerAction_def) - apply (clarsimp simp: state_relation_def) +lemma removeFromBitmap_ghost_relation[wp]: + "removeFromBitmap tdom prio \\s'. ghost_relation (kheap s) (gsUserPages s') (gsCNodes s')\" + by (rule_tac f=gsUserPages in hoare_lift_Pf2; wpsimp simp: bitmap_fun_defs) + +lemma tcbQueued_update_ctes_of[wp]: + "threadSet (tcbQueued_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, + setQueue, removeFromBitmap + for ghost_relation_projs[wp]: "\s. P (gsUserPages s) (gsCNodes s)" + and ksArchState[wp]: "\s. P (ksArchState s)" + and ksWorkUnitsCompleted[wp]: "\s. P (ksWorkUnitsCompleted s)" + and ksDomainTime[wp]: "\s. P (ksDomainTime s)" + (wp: crunch_wps getObject_tcb_wp simp: setObject_def updateObject_default_def obj_at'_def) + +crunch tcbQueueRemove, tcbQueuePrepend, tcbQueueAppend, tcbQueueInsert, + setQueue, removeFromBitmap + for tcb_at'[wp]: "\s. tcb_at' tcbPtr s" + (wp: crunch_wps ignore: threadSet) + +lemma set_tcb_queue_projs: + "set_tcb_queue d p queue + \\s. P (kheap s) (cdt s) (is_original_cap s) (cur_thread s) (idle_thread s) (scheduler_action s) + (domain_list s) (domain_index s) (cur_domain s) (domain_time 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) (ekheap s)\" + by (wpsimp simp: set_tcb_queue_def) + +lemma set_tcb_queue_cte_at: + "set_tcb_queue d p queue \\s. P (swp cte_at s)\" + unfolding set_tcb_queue_def + apply wpsimp + 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' + \ ekheap s = ekheap 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' + \ 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' + \ 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) + +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 tcbQueuePrepend_ekheap_relation[wp]: + fixes s :: det_state + shows + "\\s'. ekheap_relation (ekheap s) (ksPSpace s') \ pspace_relation (kheap s) (ksPSpace s') + \ valid_etcbs s\ + tcbQueuePrepend queue tcbPtr + \\_ s'. ekheap_relation (ekheap s) (ksPSpace s')\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: threadSet_pspace_relation threadSet_ekheap_relation + simp: tcb_relation_def etcb_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 tcbQueueAppend_ekheap_relation[wp]: + fixes s :: det_state + shows + "\\s'. ekheap_relation (ekheap s) (ksPSpace s') \ pspace_relation (kheap s) (ksPSpace s') + \ valid_etcbs s\ + tcbQueueAppend queue tcbPtr + \\_ s'. ekheap_relation (ekheap s) (ksPSpace s')\" + unfolding tcbQueueAppend_def + by (wpsimp wp: threadSet_pspace_relation threadSet_ekheap_relation + simp: tcb_relation_def etcb_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) + +lemma tcbQueueInsert_ekheap_relation[wp]: + fixes s :: det_state + shows + "\\s'. ekheap_relation (ekheap s) (ksPSpace s') \ pspace_relation (kheap s) (ksPSpace s') + \ valid_etcbs s\ + tcbQueueInsert tcbPtr afterPtr + \\_ s'. ekheap_relation (ekheap s) (ksPSpace s')\" + unfolding tcbQueueInsert_def + by (wpsimp wp: threadSet_pspace_relation threadSet_ekheap_relation hoare_drop_imps + simp: tcb_relation_def etcb_relation_def) + +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 setQueue, removeFromBitmap + for valid_pspace'[wp]: valid_pspace' + and state_refs_of'[wp]: "\s. P (state_refs_of' s)" + 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 valid_irq_states'[wp]: valid_irq_states' + 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 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 + bitmap_fun_defs valid_machine_state'_def) + +crunch tcbSchedEnqueue, tcbSchedAppend, tcbSchedDequeue, setQueue + for pspace_aligned'[wp]: pspace_aligned' + and state_refs_of'[wp]: "\s. P (state_refs_of' s)" + and pspace_distinct'[wp]: pspace_distinct' + and no_0_obj'[wp]: no_0_obj' + and ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" + 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 interrupt_state[wp]: "\s. P (ksInterruptState s)" + and valid_irq_state'[wp]: valid_irq_states' + 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 gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + and ctes_of[wp]: "\s. P (ctes_of s)" + and ksCurThread[wp]: "\s. P (ksCurThread s)" + and ksMachineState[wp]: "\s. P (ksMachineState s)" + and ksIdleThread[wp]: "\s. P (ksIdleThread s)" + (wp: crunch_wps threadSet_state_refs_of'[where f'=id and g'=id] + simp: crunch_simps tcb_cte_cases_def tcb_bound_refs'_def bitmap_fun_defs) + +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'\" + supply fun_upd_apply[simp del] + apply (clarsimp simp: ready_queues_relation_def Let_def) + apply (wpsimp wp: threadSet_wp) + apply (clarsimp simp: list_queue_relation_def obj_at'_def projectKOs) + apply (rename_tac tcb' d p) + apply (drule_tac x=d in spec) + apply (drule_tac x=p in spec) + apply (clarsimp simp: ready_queue_relation_def 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 opt_map_def fun_upd_apply) + apply (auto simp: inQ_def opt_pred_def opt_map_def fun_upd_apply projectKOs split: option.splits) done -\\ - State-preservation lemmas: lemmas of the form @{term "m \P\"}. -\ -lemmas tcb_inv_collection = - getObject_tcb_inv - threadGet_inv - -\\ - State preservation lowered through @{thm use_valid}. Results are of - the form @{term "(rv, s') \ fst (m s) \ P s \ P s'"}. -\ -lemmas tcb_inv_use_valid = - tcb_inv_collection[THEN use_valid[rotated], rotated] - -\\ - Low-level monadic state preservation. Results are of the form - @{term "(rv, s') \ fst (m s) \ s = s'"}. -\ -lemmas tcb_inv_state_eq = - tcb_inv_use_valid[where s=s and P="(=) s" for s, OF _ refl] - -\\ - For when you want an obj_at' goal instead of the ko_at' that @{thm threadGet_wp} - gives you. -\ -lemma threadGet_obj_at'_field: - "\\s. tcb_at' ptr s \ obj_at' (\tcb. P (field tcb) s) ptr s\ - threadGet field ptr - \P\" - by (wpsimp wp: threadGet_wp - simp: obj_at_ko_at') - -\\ - Getting a boolean field of a thread is the same as the thread - "satisfying" the "predicate" which the field represents. -\ -lemma threadGet_obj_at'_bool_field: - "\tcb_at' ptr\ - threadGet field ptr - \\rv s. obj_at' field ptr s = rv\" - by (wpsimp wp: threadGet_wp - simp: obj_at'_def) - -lemma inReleaseQueue_corres: - shows "corres (=) - (tcb_at ptr) - (tcb_at' ptr and valid_release_queue_iff) - (gets (in_release_queue ptr)) - (inReleaseQueue ptr)" - apply (simp add: gets_def) - apply (rule corres_bind_return_l) - apply (clarsimp simp: corres_underlying_def inReleaseQueue_def - valid_release_queue_def valid_release_queue'_def - no_fail_threadGet[unfolded no_fail_def]) - apply (rename_tac s s' rv t') - apply (prop_tac "ksReleaseQueue s' = release_queue s") - subgoal by (clarsimp simp: state_relation_def release_queue_relation_def) - apply (frule tcb_inv_state_eq) - apply (clarsimp simp: split_paired_Bex in_get) - apply (frule tcb_inv_state_eq) - apply (erule allE[where x=ptr])+ - apply (frule use_valid[OF _ threadGet_obj_at'_bool_field], assumption) - apply (fastforce simp: in_release_q_def) - done - -lemma isRunnable_corres: - "tcb_relation tcb_abs tcb_conc \ - corres (=) - (tcb_at t) - (ko_at' tcb_conc t) - (return (runnable (tcb_state tcb_abs))) - (isRunnable t)" - unfolding isRunnable_def getThreadState_def - apply (rule corres_symb_exec_r[where Q'="\rv s. tcbState tcb_conc = rv"]) - apply (case_tac "tcb_state tcb_abs"; clarsimp simp: tcb_relation_def) - apply (wpsimp wp: threadGet_wp) - apply (rule exI, fastforce) - apply (rule tcb_inv_collection) - apply (rule no_fail_pre[OF no_fail_threadGet]) - apply (clarsimp simp: obj_at'_weaken) - done - - -lemma isSchedulable_corres: - "corres (=) - (valid_tcbs and pspace_aligned and pspace_distinct and tcb_at t) - (valid_tcbs' and valid_release_queue_iff) - (is_schedulable t) - (isSchedulable t)" - (is "corres _ _ ?conc_guard _ _") - apply (rule corres_cross_over_guard[where Q="?conc_guard and tcb_at' t"]) - apply (fastforce intro: tcb_at_cross) - unfolding is_schedulable_def isSchedulable_def fun_app_def - apply (rule corres_guard_imp) - apply (rule corres_split[OF getObject_TCB_corres]) - apply (rename_tac tcb_abs tcb_conc) - apply (rule corres_if[OF _ corres_return_eq_same]) - apply (clarsimp simp: tcb_relation_def Option.is_none_def) - apply simp - apply (rule corres_split[OF get_sc_corres[THEN equify]]) - apply (clarsimp simp: tcb_relation_def) - apply (rename_tac sc_abs sc_conc) - apply (rule corres_split[OF isRunnable_corres]) - apply assumption - apply (rule corres_split[OF inReleaseQueue_corres]) - apply (rule corres_trivial) - apply (clarsimp simp: sc_relation_def active_sc_def) - apply wp+ - apply (wpsimp simp: pred_conj_def - wp: hoare_vcg_if_lift2 getObject_tcb_wp) - apply (clarsimp simp: pred_conj_def) - apply (frule (1) valid_tcbs_valid_tcb) - apply (fastforce simp: valid_tcb_def valid_bound_obj_def obj_at_def split: option.splits) - apply (fastforce simp: valid_tcbs'_def valid_tcb'_def obj_at'_def projectKOs) - done - -lemma get_simple_ko_exs_valid: - "\inj C; \ko. ko_at (C ko) p s \ is_simple_type (C ko)\ \ \(=) s\ get_simple_ko C p \\\_. (=) s\" - by (fastforce simp: get_simple_ko_def get_object_def gets_def return_def get_def - partial_inv_def exs_valid_def bind_def obj_at_def is_reply fail_def inj_def - gets_the_def assert_def) - -lemmas get_notification_exs_valid[wp] = - get_simple_ko_exs_valid[where C=kernel_object.Notification, simplified] -lemmas get_reply_exs_valid[wp] = - get_simple_ko_exs_valid[where C=kernel_object.Reply, simplified] -lemmas get_endpoint_exs_valid[wp] = - get_simple_ko_exs_valid[where C=kernel_object.Endpoint, simplified] - -lemma thread_get_exs_valid: - "tcb_at tcb_ptr s \ \(=) s\ thread_get f tcb_ptr \\\_. (=) s\" - 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) +definition in_correct_ready_q_2 where + "in_correct_ready_q_2 queues ekh \ + \d p. \t \ set (queues d p). is_etcb_at' t ekh + \ etcb_at' (\t. tcb_priority t = p \ tcb_domain t = d) t ekh" + +abbreviation in_correct_ready_q :: "det_ext state \ bool" where + "in_correct_ready_q s \ in_correct_ready_q_2 (ready_queues s) (ekheap s)" + +lemmas in_correct_ready_q_def = in_correct_ready_q_2_def + +lemma in_correct_ready_q_lift: + assumes c: "\P. \\s. P (ekheap s)\ f \\rv s. P (ekheap s)\" + assumes r: "\P. f \\s. P (ready_queues s)\" + shows "f \in_correct_ready_q\" + apply (rule hoare_pre) + apply (wps assms | wpsimp)+ + done + +definition ready_qs_distinct :: "det_ext state \ bool" where + "ready_qs_distinct s \ \d p. distinct (ready_queues s d p)" + +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 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') = {}" + apply (clarsimp simp: ready_qs_distinct_def in_correct_ready_q_def) + apply (rule disjointI) + apply (frule_tac x=d in spec) + apply (drule_tac x=d' in spec) + apply (fastforce simp: etcb_at_def is_etcb_at_def split: option.splits) + done lemma isRunnable_sp: "\P\ @@ -2036,159 +2360,371 @@ lemma isRunnable_sp: \ (rv = (tcbState tcb' = Running \ tcbState tcb' = Restart)) \ P s\" unfolding isRunnable_def getThreadState_def - apply (wpsimp wp: hoare_case_option_wp getObject_tcb_wp simp: threadGet_getObject) + apply (wpsimp wp: hoare_case_option_wp getObject_tcb_wp simp: threadGet_def) apply (fastforce simp: obj_at'_def split: Structures_H.thread_state.splits) done -lemma isRunnable_sp': - "\P\ - isRunnable tcb_ptr - \\rv s. (rv = st_tcb_at' active' tcb_ptr s) \ P s\" - apply (clarsimp simp: isRunnable_def getThreadState_def) - apply (wpsimp wp: hoare_case_option_wp getObject_tcb_wp - simp: threadGet_getObject) - apply (fastforce simp: obj_at'_def st_tcb_at'_def - split: Structures_H.thread_state.splits) +crunch isRunnable + for (no_fail) no_fail[wp] + +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')" + +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) + +crunch addToBitmap + for ko_at'[wp]: "\s. P (ko_at' ko ptr s)" + and sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + and valid_sched_pointers[wp]: valid_sched_pointers + and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" + and ksReadyQueues_asrt[wp]: ksReadyQueues_asrt + and st_tcb_at'[wp]: "\s. P (st_tcb_at' Q tcbPtr s)" + and valid_tcbs'[wp]: valid_tcbs' + (simp: bitmap_fun_defs ksReadyQueues_asrt_def) + +lemma tcbQueueHead_ksReadyQueues: + "\list_queue_relation ts queue nexts prevs; + \t. (inQ d p |< tcbs_of' s') t \ t \ set ts\ + \ \ tcbQueueEmpty queue \ (inQ d p |< tcbs_of' s') (the (tcbQueueHead queue))" + by (fastforce dest: heap_path_head + simp: tcbQueueEmpty_def list_queue_relation_def queue_end_valid_def) + +lemma obj_at'_tcbQueueHead_ksReadyQueues: + "\list_queue_relation ts queue nexts prevs; + \t. (inQ d p |< tcbs_of' s') t \ t \ set ts; + pspace_aligned' s'; pspace_distinct' s'\ + \ \ tcbQueueEmpty queue \ obj_at' (inQ d p) (the (tcbQueueHead queue)) s'" + by (fastforce dest!: tcbQueueHead_ksReadyQueues intro: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def opt_pred_def split: option.splits) + +lemma tcbQueueHead_iff_tcbQueueEnd: + "list_queue_relation ts q nexts prevs \ tcbQueueHead q \ None \ tcbQueueEnd q \ None" + apply (clarsimp simp: list_queue_relation_def queue_end_valid_def) + using heap_path_None + apply fastforce done -lemma inReleaseQueue_sp: - "\P\ - inReleaseQueue tcb_ptr - \\rv s. \tcb'. ko_at' tcb' tcb_ptr s \ (rv = (tcbInReleaseQueue tcb')) \ P s\" - unfolding inReleaseQueue_def - apply (wpsimp wp: hoare_case_option_wp getObject_tcb_wp simp: threadGet_getObject) +lemma tcbQueueEnd_ksReadyQueues: + "\list_queue_relation ts queue nexts prevs; + \t. (inQ d p |< tcbs_of' s') t \ t \ set ts\ + \ \ tcbQueueEmpty queue \ (inQ d p |< tcbs_of' s') (the (tcbQueueEnd queue))" + apply (frule tcbQueueHead_iff_tcbQueueEnd) + by (clarsimp simp: tcbQueueEmpty_def list_queue_relation_def queue_end_valid_def) + +lemma obj_at'_tcbQueueEnd_ksReadyQueues: + "\list_queue_relation ts queue nexts prevs; + \t. (inQ d p |< tcbs_of' s') t \ t \ set ts; + pspace_aligned' s'; pspace_distinct' s'\ + \ \ tcbQueueEmpty queue \ obj_at' (inQ d p) (the (tcbQueueEnd queue)) s'" + by (fastforce dest!: tcbQueueEnd_ksReadyQueues intro: aligned'_distinct'_ko_wp_at'I + simp: obj_at'_real_def opt_map_def opt_pred_def split: option.splits) + +lemma thread_get_exs_valid[wp]: + "tcb_at tcb_ptr s \ \(=) s\ thread_get f tcb_ptr \\\_. (=) s\" + 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 ethread_get_sp: + "\P\ ethread_get f ptr + \\rv. etcb_at (\tcb. f tcb = rv) ptr and P\" + apply wpsimp + apply (clarsimp simp: etcb_at_def split: option.splits) + done + +lemma ethread_get_exs_valid[wp]: + "\tcb_at tcb_ptr s; valid_etcbs s\ \ \(=) s\ ethread_get f tcb_ptr \\\_. (=) s\" + apply (frule (1) tcb_at_is_etcb_at) + apply (clarsimp simp: ethread_get_def get_etcb_def gets_the_def gets_def return_def get_def + is_etcb_at_def exs_valid_def bind_def) + done + +lemma no_fail_ethread_get[wp]: + "no_fail (tcb_at tcb_ptr and valid_etcbs) (ethread_get f tcb_ptr)" + unfolding ethread_get_def + apply wpsimp + apply (frule (1) tcb_at_is_etcb_at) + apply (clarsimp simp: is_etcb_at_def get_etcb_def) + done + +lemma threadGet_sp: + "\P\ threadGet f ptr \\rv s. \tcb :: tcb. ko_at' tcb ptr s \ f tcb = rv \ P s\" + unfolding threadGet_def setObject_def + apply (wpsimp wp: getObject_tcb_wp) apply (clarsimp simp: obj_at'_def) done -lemma inReleaseQueue_inv[wp]: - "inReleaseQueue t \P\" - by (simp add: inReleaseQueue_def | wp gts_inv')+ +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_queue_relation_def ready_queues_relation_def Let_def) -lemma conjunct_rewrite: - "P = P' \ Q = Q' \ R = R' \ (P \ Q \ R) = (P' \ Q' \ R')" - by simp +lemma in_ready_q_tcbQueued_eq: + "ready_queues_relation s s' + \ (\d p. t \ set (ready_queues s d p)) \ (tcbQueued |< tcbs_of' s') t" + apply (intro iffI) + apply clarsimp + 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_queue_relation_def ready_queues_relation_def Let_def + inQ_def opt_pred_def + split: option.splits) + done -lemma isSchedulable_inv[wp]: - "isSchedulable tcbPtr \P\" - apply (clarsimp simp: isSchedulable_def inReleaseQueue_def) - apply (rule bind_wp[OF _ getObject_tcb_inv]) - by (wpsimp wp: inReleaseQueue_inv) +lemma tcbSchedEnqueue_corres: + "tcb_ptr = tcbPtr \ + corres dc + (in_correct_ready_q and ready_qs_distinct and valid_etcbs and st_tcb_at runnable tcb_ptr + and pspace_aligned and pspace_distinct) + (sym_heap_sched_pointers and valid_sched_pointers and valid_tcbs') + (tcb_sched_action tcb_sched_enqueue tcb_ptr) (tcbSchedEnqueue tcbPtr)" + supply if_split[split del] + heap_path_append[simp del] fun_upd_apply[simp del] distinct_append[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: obj_at_def is_tcb_def) + apply (rule_tac Q="tcb_at tcb_ptr" in corres_cross_add_abs_guard) + apply (fastforce dest: st_tcb_at_tcb_at) + 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: tcb_sched_action_def tcb_sched_enqueue_def get_tcb_queue_def + tcbSchedEnqueue_def getQueue_def unless_def when_def) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; (solves wpsimp)?) + apply (rename_tac domain) + apply (rule corres_symb_exec_l[OF _ _ ethread_get_sp]; (solves wpsimp)?) + apply (rename_tac priority) + apply (rule corres_symb_exec_l[OF _ _ gets_sp]; (solves wpsimp)?) + apply (rule corres_stateAssert_ignore) + apply (fastforce intro: ksReadyQueues_asrt_cross) + apply (rule corres_symb_exec_r[OF _ isRunnable_sp]; (solves wpsimp)?) + apply (rule corres_symb_exec_r[OF _ assert_sp, rotated]; (solves wpsimp)?) + apply wpsimp + apply (fastforce simp: st_tcb_at'_def runnable_eq_active' obj_at'_def) + 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 (frule state_relation_ready_queues_relation) + apply (frule in_ready_q_tcbQueued_eq[where t=tcbPtr]) + subgoal + by (fastforce dest: tcb_at_ekheap_dom pred_tcb_at_tcb_at + simp: obj_at'_def opt_pred_def opt_map_def obj_at_def is_tcb_def + in_correct_ready_q_def etcb_at_def is_etcb_at_def projectKOs) + 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) + apply (rule monadic_rewrite_guard_imp) + apply (rule monadic_rewrite_modify_noop) + apply (prop_tac "(\d p. if d = domain \ p = priority + then ready_queues s domain priority + else ready_queues s d p) + = ready_queues s") + apply (fastforce split: if_splits) + apply fastforce + apply clarsimp + 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)?) -lemma get_sc_refill_sufficient_sp: - "\P\ - get_sc_refill_sufficient sc_ptr usage - \\rv s. (\sc n. ko_at (kernel_object.SchedContext sc n) sc_ptr s - \ (rv = sc_refill_sufficient usage sc)) - \ P s\" - by (wpsimp simp: get_sc_refill_sufficient_def obj_at_def) + \ \break off the addToBitmap\ + apply (rule corres_add_noop_lhs) + apply (rule corres_underlying_split[rotated 2, + where Q="\_. P" and P=P and Q'="\_. P'" and P'=P' for P P']) + apply wpsimp + apply (wpsimp wp: hoare_vcg_if_lift hoare_vcg_ex_lift) + apply (corres corres: addToBitmap_if_null_noop_corres) -lemma get_sc_refill_ready_sp: - "\P\ - get_sc_refill_ready sc_ptr - \\rv s. (\sc n. ko_at (kernel_object.SchedContext sc n) sc_ptr s - \ (rv = sc_refill_ready (cur_time s) sc)) - \ P s\" - by (wpsimp simp: obj_at_def) - -\ \In sched_context_donate, weak_valid_sched_action does not propagate backwards over the statement - where from_tptr's sched context is set to None because it requires the thread associated with a - switch_thread action to have a sched context. For this instance, we introduce a weaker version - of weak_valid_sched_action that is sufficient to prove refinement for reschedule_required\ -definition weaker_valid_sched_action where - "weaker_valid_sched_action s \ - \t. scheduler_action s = switch_thread t \ - tcb_at t s \ (bound_sc_tcb_at ((\) None) t s \ released_sc_tcb_at t s)" - -lemma weak_valid_sched_action_strg: - "weak_valid_sched_action s \ weaker_valid_sched_action s" - by (fastforce simp: weak_valid_sched_action_def weaker_valid_sched_action_def - obj_at_kh_kheap_simps vs_all_heap_simps is_tcb_def - split: Structures_A.kernel_object.splits) - -lemma no_ofail_get_tcb[wp]: - "no_ofail (tcb_at tp) (get_tcb tp)" - unfolding get_tcb_def no_ofail_def - by (clarsimp simp: obj_at_def is_tcb split: option.splits) - -lemma no_ofail_read_sched_context[wp]: - "no_ofail (\s. \sc n. kheap s scp = Some (Structures_A.SchedContext sc n)) (read_sched_context scp)" - unfolding read_sched_context_def no_ofail_def - by (clarsimp simp: obj_at_def is_sc_obj obind_def) - -lemma no_ofail_read_sc_refill_ready: - "no_ofail (\s. \sc n. kheap s scp = Some (Structures_A.SchedContext sc n)) (read_sc_refill_ready scp)" - unfolding read_sc_refill_ready_def no_ofail_def - by (clarsimp simp: omonad_defs obind_def dest!: no_ofailD[OF no_ofail_read_sched_context]) - -lemma rescheduleRequired_corres_weak: - "corres dc (valid_tcbs and weaker_valid_sched_action and pspace_aligned and pspace_distinct - and active_scs_valid) - (valid_tcbs' and Invariants_H.valid_queues and valid_queues' and valid_release_queue_iff) - reschedule_required rescheduleRequired" - apply (simp add: rescheduleRequired_def reschedule_required_def) - apply (rule corres_underlying_split[OF _ _ gets_sp, rotated 2]) - apply (clarsimp simp: getSchedulerAction_def) - apply (rule gets_sp) - apply (corresKsimp corres: getSchedulerAction_corres) - apply (rule corres_underlying_split[where r'=dc, rotated]; (solves \wpsimp\)?) - apply (corresKsimp corres: setSchedulerAction_corres) - apply (case_tac action; clarsimp?) - apply (rename_tac tp) - apply (rule corres_underlying_split[OF _ _ is_schedulable_sp isSchedulable_inv, rotated 2]) - apply (corresKsimp corres: isSchedulable_corres) - apply (clarsimp simp: weaker_valid_sched_action_def obj_at_def vs_all_heap_simps is_tcb_def) - apply (clarsimp simp: when_def) - - apply (rule corres_symb_exec_l[OF _ thread_get_exs_valid thread_get_sp , rotated]) - apply (clarsimp simp: weaker_valid_sched_action_def vs_all_heap_simps obj_at_def is_tcb_def) - apply (wpsimp simp: thread_get_def get_tcb_def weaker_valid_sched_action_def vs_all_heap_simps) - apply (clarsimp simp: obj_at_def is_tcb_def) - apply (clarsimp split: Structures_A.kernel_object.splits) - apply (rule corres_symb_exec_l[OF _ _ assert_opt_sp, rotated]) - apply (clarsimp simp: exs_valid_def obj_at_def return_def is_schedulable_opt_def get_tcb_def - split: option.splits) - apply (clarsimp simp: no_fail_def obj_at_def return_def is_schedulable_opt_def get_tcb_def - split: Structures_A.kernel_object.splits option.splits) - - apply (rule corres_symb_exec_l[OF _ _ get_sc_refill_sufficient_sp, rotated]) - apply (wpsimp wp: get_sched_context_exs_valid exs_valid_bind - simp: get_sc_refill_sufficient_def is_schedulable_opt_def get_tcb_def obj_at_def - is_sc_active_def - split: Structures_A.kernel_object.splits option.splits) - apply (wpsimp wp: get_sched_context_no_fail simp: get_sc_refill_sufficient_def) - apply (fastforce simp: valid_tcbs_def valid_tcb_def obj_at_def is_schedulable_opt_def get_tcb_def - is_sc_active_def is_sc_obj_def - split: option.splits Structures_A.kernel_object.splits) - - apply (rule corres_symb_exec_l[OF _ _ get_sc_refill_ready_sp, rotated]) - apply (wpsimp wp: get_sched_context_exs_valid gets_the_exs_valid - simp: get_sc_refill_ready_def) - apply (clarsimp intro!: no_ofailD[OF no_ofail_read_sc_refill_ready] simp: obj_at_def is_sc_obj) - apply simp - apply (wpsimp wp: get_sched_context_no_fail simp: get_sc_refill_ready_def) - apply (clarsimp intro!: no_ofailD[OF no_ofail_read_sc_refill_ready] simp: obj_at_def is_sc_obj) - apply (rule_tac F=sufficient in corres_req) - apply (clarsimp simp: obj_at_def is_schedulable_opt_def get_tcb_def) - apply (drule_tac tp=tp in active_valid_budget_sufficient) - apply (clarsimp simp: vs_all_heap_simps is_sc_active_def) - apply (clarsimp simp: return_def vs_all_heap_simps - obj_at_def pred_tcb_at_def weaker_valid_sched_action_def) - apply (rule corres_symb_exec_l[OF _ _ assert_sp, rotated]) - apply (clarsimp simp: exs_valid_def return_def vs_all_heap_simps - obj_at_def pred_tcb_at_def weaker_valid_sched_action_def) - apply (clarsimp simp: no_fail_def return_def vs_all_heap_simps - obj_at_def pred_tcb_at_def weaker_valid_sched_action_def) - apply (corresKsimp corres: tcbSchedEnqueue_corres - simp: obj_at_def is_tcb_def weak_sch_act_wf_def) + 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_if_lift2 | drule Some_to_the)+ + apply (clarsimp simp: ex_abs_underlying_def split: if_splits) + 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 (force dest!: obj_at'_tcbQueueHead_ksReadyQueues simp: obj_at'_def projectKOs) + + 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\)?) + + \ \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 (wpsimp wp: threadSet_wp getObject_tcb_wp simp: setQueue_def tcbQueuePrepend_def) + apply normalise_obj_at' + apply (frule (1) tcb_at_is_etcb_at) + apply (clarsimp simp: obj_at_def is_etcb_at_def etcb_at_def) + apply (rename_tac s d p s' tcb' tcb etcb) + apply (frule_tac t=tcbPtr in ekheap_relation_tcb_domain_priority) + apply (force simp: obj_at_def) + apply (force simp: obj_at'_def projectKOs) + apply (clarsimp split: if_splits) + apply (cut_tac ts="ready_queues s d p" in list_queue_relation_nil) + apply (force dest!: spec simp: list_queue_relation_def) + apply (cut_tac ts="ready_queues s (tcb_domain etcb) (tcb_priority etcb)" + in list_queue_relation_nil) + apply (force dest!: spec simp: list_queue_relation_def) + apply (cut_tac ts="ready_queues s (tcb_domain etcb) (tcb_priority etcb)" and s'=s' + in obj_at'_tcbQueueEnd_ksReadyQueues) + apply fast + apply auto[1] + apply fastforce + apply fastforce + apply (cut_tac xs="ready_queues s d p" and st="tcbQueueHead (ksReadyQueues s' (d, p))" + in heap_path_head') + apply (auto dest: spec simp: list_queue_relation_def tcbQueueEmpty_def)[1] + apply (cut_tac xs="ready_queues s (tcb_domain etcb) (tcb_priority etcb)" + and st="tcbQueueHead (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb))" + in heap_path_head') + apply (auto dest: spec simp: list_queue_relation_def tcbQueueEmpty_def)[1] + apply (clarsimp simp: list_queue_relation_def) + + apply (case_tac "\ (d = tcb_domain etcb \ p = tcb_priority etcb)") + apply (cut_tac d=d and d'="tcb_domain etcb" and p=p and p'="tcb_priority etcb" + in ready_queues_disjoint) + apply force + apply fastforce + apply fastforce + apply (prop_tac "tcbPtr \ set (ready_queues s d p)") + apply (clarsimp simp: obj_at'_def opt_pred_def opt_map_def projectKOs) + apply (metis inQ_def option.simps(5) tcb_of'_TCB) + apply (intro conjI impI; simp) + + \ \the ready queue was originally empty\ + apply (rule heap_path_heap_upd_not_in) + apply (clarsimp simp: fun_upd_apply split: if_splits) + apply fastforce + apply (clarsimp simp: queue_end_valid_def fun_upd_apply split: if_splits) + apply (rule prev_queue_head_heap_upd) + apply (clarsimp simp: fun_upd_apply split: if_splits) + apply (case_tac "ready_queues s d p"; + clarsimp simp: fun_upd_apply tcbQueueEmpty_def split: if_splits) + apply (clarsimp simp: inQ_def in_opt_pred fun_upd_apply obj_at'_def split: if_splits) + apply (clarsimp simp: fun_upd_apply split: if_splits) + apply (clarsimp simp: fun_upd_apply split: if_splits) + + \ \the ready queue was not originally empty\ + apply (clarsimp simp: etcb_at_def obj_at'_def) + apply (prop_tac "the (tcbQueueHead (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb))) + \ set (ready_queues s d p)") + apply (erule orthD2) + apply (clarsimp simp: tcbQueueEmpty_def) + apply (intro conjI impI allI) + apply (intro heap_path_heap_upd_not_in) + apply (clarsimp simp: fun_upd_apply split: if_splits) + apply simp + apply fastforce + apply (clarsimp simp: queue_end_valid_def fun_upd_apply split: if_splits) + apply (intro prev_queue_head_heap_upd) + apply (force simp: fun_upd_apply split: if_splits) + apply (case_tac "ready_queues s d p"; + force simp: fun_upd_apply tcbQueueEmpty_def split: if_splits) + apply (clarsimp simp: fun_upd_apply inQ_def split: if_splits) + apply (case_tac "ready_queues s d p"; force simp: tcbQueueEmpty_def) + apply (case_tac "t = tcbPtr") + apply (clarsimp simp: inQ_def fun_upd_apply obj_at'_def projectKOs split: if_splits) + apply (case_tac "t = the (tcbQueueHead (ksReadyQueues s' (tcb_domain etcb, tcb_priority etcb)))") + apply (clarsimp simp: inQ_def opt_pred_def opt_map_def obj_at'_def projectKOs fun_upd_apply + split: option.splits) + apply metis + apply (clarsimp simp: inQ_def in_opt_pred opt_map_def fun_upd_apply) + apply (clarsimp simp: fun_upd_apply split: if_splits) + apply (clarsimp simp: fun_upd_apply split: if_splits) + + \ \d = tcb_domain etcb \ p = tcb_priority etcb\ + apply clarsimp + apply (drule_tac x="tcb_domain etcb" in spec) + apply (drule_tac x="tcb_priority etcb" in spec) + apply (cut_tac ts="ready_queues s (tcb_domain etcb) (tcb_priority etcb)" + in tcbQueueHead_iff_tcbQueueEnd) + apply (force simp: list_queue_relation_def) + apply (frule valid_tcbs'_maxDomain[where t=tcbPtr], simp add: obj_at'_def projectKOs) + apply (frule valid_tcbs'_maxPriority[where t=tcbPtr], simp add: obj_at'_def projectKOs) + apply (drule valid_sched_pointersD[where t=tcbPtr]) + apply (clarsimp simp: in_opt_pred opt_map_red obj_at'_def) + apply (clarsimp simp: in_opt_pred opt_map_red obj_at'_def projectKOs) + apply (intro conjI; clarsimp simp: tcbQueueEmpty_def) + + \ \the ready queue was originally empty\ + apply (force simp: inQ_def in_opt_pred fun_upd_apply queue_end_valid_def prev_queue_head_def + opt_map_red obj_at'_def projectKOs + split: if_splits) + + \ \the ready queue was not originally empty\ + apply (drule (2) heap_ls_prepend[where new=tcbPtr]) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply) + apply (rule conjI) + apply (subst opt_map_upd_triv) + apply (clarsimp simp: opt_map_def obj_at'_def projectKOs fun_upd_apply split: if_splits) + apply (clarsimp simp: fun_upd_apply obj_at'_def projectKOs split: if_splits) + apply (rule conjI) + apply (clarsimp simp: fun_upd_apply queue_end_valid_def) + apply (rule conjI) + apply (clarsimp simp: prev_queue_head_def fun_upd_apply opt_map_def split: if_splits) + by (auto dest!: hd_in_set + simp: inQ_def in_opt_pred opt_map_def fun_upd_apply obj_at'_def projectKOs + split: if_splits option.splits) + +definition + weak_sch_act_wf :: "scheduler_action \ kernel_state \ bool" +where + "weak_sch_act_wf sa = (\s. \t. sa = SwitchToThread t \ st_tcb_at' runnable' t s \ tcb_in_cur_domain' t s)" + +lemma weak_sch_act_wf_updateDomainTime[simp]: + "weak_sch_act_wf m (ksDomainTime_update f s) = weak_sch_act_wf m s" + by (simp add:weak_sch_act_wf_def tcb_in_cur_domain'_def ) + +lemma setSchedulerAction_corres: + "sched_act_relation sa sa' + \ corres dc \ \ (set_scheduler_action sa) (setSchedulerAction sa')" + apply (simp add: setSchedulerAction_def set_scheduler_action_def) + apply (rule corres_no_failI) + apply wp + apply (clarsimp simp: in_monad simpler_modify_def state_relation_def) + done + +lemma getSchedulerAction_corres: + "corres sched_act_relation \ \ (gets scheduler_action) getSchedulerAction" + apply (simp add: getSchedulerAction_def) + apply (clarsimp simp: state_relation_def) done lemma rescheduleRequired_corres: - "corres dc (valid_tcbs and weak_valid_sched_action and pspace_aligned and pspace_distinct - and active_scs_valid) - (valid_tcbs' and valid_queues and valid_queues' and valid_release_queue_iff) - reschedule_required rescheduleRequired" - by (rule corres_guard_imp[OF rescheduleRequired_corres_weak]) - (auto simp: weak_valid_sched_action_strg) + "corres dc + (weak_valid_sched_action and in_correct_ready_q and ready_qs_distinct and valid_etcbs + and pspace_aligned and pspace_distinct) + (sym_heap_sched_pointers and valid_sched_pointers and valid_tcbs') + (reschedule_required) rescheduleRequired" + apply (simp add: rescheduleRequired_def reschedule_required_def) + apply (rule corres_guard_imp) + apply (rule corres_split[OF getSchedulerAction_corres]) + apply (rule_tac P="case action of switch_thread t \ P t | _ \ \" + and P'="case actiona of SwitchToThread t \ P' t | _ \ \" for P P' + in corres_split[where r'=dc]) + apply (case_tac action) + apply simp + apply simp + apply (rule tcbSchedEnqueue_corres, simp) + apply simp + apply (rule setSchedulerAction_corres) + apply simp + apply (wp | wpc | simp)+ + apply (force dest: st_tcb_weakenE simp: in_monad weak_valid_sched_action_def valid_etcbs_def st_tcb_at_def obj_at_def is_tcb + split: Deterministic_A.scheduler_action.split) + apply (clarsimp split: scheduler_action.splits) + done lemma rescheduleRequired_corres_simple: "corres dc \ sch_act_simple @@ -2236,7 +2772,7 @@ apply (wp threadSet_obj_at'_strongish getObject_tcb_wp | simp add: assms)+ done lemmas threadSet_weak_sch_act_wf - = weak_sch_act_wf_lift[OF threadSet.ksSchedulerAction threadSet_pred_tcb_no_state threadSet_tcbDomain_triv, simplified] + = weak_sch_act_wf_lift[OF threadSet_nosch threadSet_pred_tcb_no_state threadSet_tcbDomain_triv, simplified] lemma removeFromBitmap_nosch[wp]: "\\s. P (ksSchedulerAction s)\ removeFromBitmap d p \\rv s. P (ksSchedulerAction s)\" @@ -2255,13 +2791,26 @@ lemmas addToBitmap_weak_sch_act_wf[wp] = weak_sch_act_wf_lift[OF addToBitmap_nosch] crunch removeFromBitmap - for obj_at'[wp]: "\s. Q (obj_at' P t s)" + for st_tcb_at'[wp]: "st_tcb_at' P t" +crunch removeFromBitmap + for pred_tcb_at'[wp]: "\s. Q (pred_tcb_at' proj P t s)" + +crunch removeFromBitmap + for not_st_tcb_at'[wp]: "\s. \ (st_tcb_at' P' t) s" + crunch addToBitmap - for obj_at'[wp]: "\s. Q (obj_at' P t s)" + for st_tcb_at'[wp]: "st_tcb_at' P' t" +crunch addToBitmap + for pred_tcb_at'[wp]: "\s. Q (pred_tcb_at' proj P t s)" + +crunch addToBitmap + for not_st_tcb_at'[wp]: "\s. \ (st_tcb_at' P' t) s" + crunch removeFromBitmap - for pred_tcb_at'[wp]: "\s. Q (pred_tcb_at' proj P t s)" + for obj_at'[wp]: "\s. Q (obj_at' P t s)" + crunch addToBitmap - for pred_tcb_at'[wp]: "\s. Q (pred_tcb_at' proj P' t s)" + for 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\" @@ -2658,114 +3207,32 @@ lemma thread_get_isRunnable_corres: apply (case_tac "tcb_state x",simp_all) done -lemma 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 simp - done - -lemma threadSet_wp: - "\\s. \tcb :: tcb. ko_at' tcb t s \ P (set_obj' t (f tcb) s)\ - threadSet f t - \\_. P\" - unfolding threadSet_def - apply (wpsimp wp: setObject_tcb_wp set_tcb'.getObject_wp) - done - -\\ - If we don't change the @{term tcbInReleaseQueue} flag of a TCB, - then the release queues stay valid. -\ -lemma setObject_valid_release_queue: - "\valid_release_queue - and obj_at' (\old_tcb. tcbInReleaseQueue old_tcb \ tcbInReleaseQueue tcb) ptr\ - setObject ptr tcb - \\rv. valid_release_queue\" - unfolding valid_release_queue_def - apply (rule hoare_allI) - apply (wpsimp wp: setObject_tcb_obj_at'_strongest hoare_vcg_imp_lift) - apply (clarsimp simp: obj_at'_imp obj_at'_def) - done - -lemma setObject_valid_release_queue': - "\valid_release_queue' - and obj_at' (\old_tcb. tcbInReleaseQueue tcb \ tcbInReleaseQueue old_tcb) ptr\ - setObject ptr tcb - \\rv. valid_release_queue'\" - unfolding valid_release_queue'_def - apply (rule hoare_allI) - apply (wpsimp wp: setObject_tcb_obj_at'_strongest hoare_vcg_imp_lift) - apply (rename_tac t s) - apply (case_tac "ptr = t"; clarsimp) - done - lemma setThreadState_corres: - assumes "thread_state_relation ts ts'" - shows "corres dc - (valid_tcbs and pspace_aligned and pspace_distinct and tcb_at t and valid_tcb_state ts) - (valid_tcbs' and valid_release_queue_iff) + "thread_state_relation ts ts' \ + corres dc + (tcb_at t and pspace_aligned and pspace_distinct) + \ (set_thread_state t ts) (setThreadState ts' t)" - (is "corres _ _ ?conc_guard _ _") - using assms - apply - - apply (rule corres_cross_over_guard - [where Q="?conc_guard and tcb_at' t and valid_tcb_state' ts'"]) - apply (solves \auto simp: state_relation_def intro: valid_tcb_state_cross tcb_at_cross\)[1] - apply (simp add: set_thread_state_def setThreadState_def threadSet_def) + (is "?tsr \ corres dc ?Pre ?Pre' ?sts ?sts'") + apply (simp add: set_thread_state_def setThreadState_def) + apply (simp add: set_thread_state_ext_def[abs_def]) + apply (subst bind_assoc[symmetric], subst thread_set_def[simplified, symmetric]) apply (rule corres_guard_imp) - apply (subst bind_assoc) - apply (rule corres_split[OF getObject_TCB_corres]) - apply (rule corres_split[OF setObject_tcbState_update_corres]) - apply assumption - apply assumption - apply (simp add: set_thread_state_act_def scheduleTCB_def) + apply (rule corres_split[where r'=dc]) + apply (rule threadset_corres, (simp add: tcb_relation_def exst_same_def)+) + apply (subst thread_get_test[where test="runnable"]) + apply (rule corres_split[OF thread_get_isRunnable_corres]) apply (rule corres_split[OF getCurThread_corres]) apply (rule corres_split[OF getSchedulerAction_corres]) - apply (rule corres_split[OF isSchedulable_corres]) - apply (rule corres_split corres_when)+ - apply (rename_tac sched_act sched_act' dont_care dont_care') - apply (case_tac sched_act; clarsimp) - apply (rule rescheduleRequired_corres_simple) - apply wpsimp - apply (wpsimp simp: isSchedulable_def inReleaseQueue_def - wp: threadGet_obj_at'_field getObject_tcb_wp) - apply wp - apply wp - apply wp - apply wp - apply wpsimp - apply (wpsimp simp: pred_conj_def sch_act_simple_def obj_at_ko_at'_eq - wp: setObject_tcb_valid_tcbs' setObject_tcb_obj_at'_strongest - setObject_valid_release_queue setObject_valid_release_queue') - apply wp - apply (wpsimp wp: getObject_tcb_wp) - apply (fastforce intro: valid_tcb_state_update valid_tcbs_valid_tcb - simp: obj_at_def is_tcb_def) - apply (fastforce intro: valid_tcb'_tcbState_update - simp: projectKOs valid_tcbs'_def obj_at'_def)+ + apply (simp only: when_def) + apply (rule corres_if[where Q=\ and Q'=\]) + apply (rule iffI) + apply clarsimp+ + apply (case_tac rva,simp_all)[1] + apply (wp rescheduleRequired_corres_simple corres_return_trivial | simp)+ + apply (wp hoare_vcg_conj_lift[where Q'="\\"] | simp add: sch_act_simple_def)+ done -lemma set_tcb_obj_ref_corresT: - assumes x: "\tcb tcb'. tcb_relation tcb tcb' \ - tcb_relation (f (\_. new) tcb) (f' tcb')" - assumes y: "\tcb. \(getF, setF) \ ran tcb_cap_cases. getF (f (\_. new) tcb) = getF tcb" - assumes z: "\tcb. \(getF, setF) \ ran tcb_cte_cases. - getF (f' tcb) = getF tcb" - shows "corres dc (tcb_at t) (tcb_at' t) - (set_tcb_obj_ref f t new) (threadSet f' t)" - by (clarsimp simp: set_tcb_obj_ref_thread_set threadset_corresT x y z) - -lemmas set_tcb_obj_ref_corres = - set_tcb_obj_ref_corresT [OF _ _ all_tcbI, OF _ ball_tcb_cap_casesI ball_tcb_cte_casesI] - lemma setBoundNotification_corres: "corres dc (tcb_at t and pspace_aligned and pspace_distinct) @@ -2777,36 +3244,49 @@ lemma setBoundNotification_corres: done crunch rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification - 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 ctes_of[wp]: "\s. P (ctes_of s)" - (wp: crunch_wps) - -global_interpretation rescheduleRequired: typ_at_all_props' "rescheduleRequired" - by typ_at_props' - -global_interpretation tcbSchedDequeue: typ_at_all_props' "tcbSchedDequeue thread" - by typ_at_props' + for tcb'[wp]: "tcb_at' addr" -global_interpretation threadSet: typ_at_all_props' "threadSet f p" - by typ_at_props' +lemma tcbSchedNext_update_valid_objs'[wp]: + "\valid_objs' and valid_bound_tcb' ptrOpt\ + threadSet (tcbSchedNext_update (\_. ptrOpt)) tcbPtr + \\_. valid_objs'\" + apply (wpsimp wp: threadSet_valid_objs') + apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done -global_interpretation setThreadState: typ_at_all_props' "setThreadState st p" - by typ_at_props' +lemma tcbSchedPrev_update_valid_objs'[wp]: + "\valid_objs' and valid_bound_tcb' ptrOpt\ + threadSet (tcbSchedPrev_update (\_. ptrOpt)) tcbPtr + \\_. valid_objs'\" + apply (wpsimp wp: threadSet_valid_objs') + apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done -global_interpretation setBoundNotification: typ_at_all_props' "setBoundNotification v p" - by typ_at_props' +lemma tcbQueuePrepend_valid_objs'[wp]: + "\\s. valid_objs' s \ tcb_at' tcbPtr s + \ (\ tcbQueueEmpty queue \ tcb_at' (the (tcbQueueHead queue)) s)\ + tcbQueuePrepend queue tcbPtr + \\_. valid_objs'\" + unfolding tcbQueuePrepend_def + by (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift' simp: tcbQueueEmpty_def) -global_interpretation scheduleTCB: typ_at_all_props' "scheduleTCB tcbPtr" - by typ_at_props' +crunch addToBitmap + for valid_objs'[wp]: valid_objs' + (simp: unless_def crunch_simps wp: crunch_wps) -lemma sts'_valid_mdb'[wp]: - "setThreadState st t \valid_mdb'\" - by (wpsimp simp: valid_mdb'_def) +lemma tcbSchedEnqueue_valid_objs'[wp]: + "\valid_objs' and pspace_aligned' and pspace_distinct'\ + tcbSchedEnqueue tcbPtr + \\_. valid_objs'\" + unfolding tcbSchedEnqueue_def setQueue_def + apply (wpsimp wp: threadSet_valid_objs' getObject_tcb_wp simp: threadGet_def) + apply (fastforce dest!: obj_at'_tcbQueueHead_ksReadyQueues + simp: ready_queue_relation_def ksReadyQueues_asrt_def obj_at'_def) + done -crunch rescheduleRequired, removeFromBitmap, scheduleTCB +crunch rescheduleRequired, removeFromBitmap for valid_objs'[wp]: valid_objs' - (simp: unless_def crunch_simps wp: crunch_wps) + (simp: crunch_simps) lemmas ko_at_valid_objs'_pre = ko_at_valid_objs'[simplified project_inject, atomized, simplified, rule_format] @@ -2836,115 +3316,56 @@ lemma tcbSchedDequeue_valid_objs'[wp]: by (wpsimp wp: threadSet_valid_objs') lemma sts_valid_objs': - "\valid_objs' and valid_tcb_state' st\ - setThreadState st t - \\rv. valid_objs'\" + "\valid_objs' and valid_tcb_state' st and pspace_aligned' and pspace_distinct'\ + setThreadState st t + \\_. valid_objs'\" apply (wpsimp simp: setThreadState_def wp: threadSet_valid_objs') - by (simp add: valid_tcb'_def tcb_cte_cases_def) + apply (rule_tac Q'="\_. valid_objs' and pspace_aligned' and pspace_distinct'" in hoare_post_imp) + apply fastforce + apply (wpsimp wp: threadSet_valid_objs') + apply (simp add: valid_tcb'_def tcb_cte_cases_def cteSizeBits_def) + done lemma sbn_valid_objs': "\valid_objs' and valid_bound_ntfn' ntfn\ setBoundNotification ntfn t \\rv. valid_objs'\" - apply (wpsimp simp: setBoundNotification_def wp: threadSet_valid_objs') - by (simp add: valid_tcb'_def tcb_cte_cases_def) - -crunch setBoundNotification - for reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" - and st_tcb_at'[wp]: "st_tcb_at' P p" - and valid_replies' [wp]: valid_replies' - (wp: valid_replies'_lift threadSet_pred_tcb_no_state) + apply (simp add: setBoundNotification_def) + apply (wp threadSet_valid_objs') + apply (simp add: valid_tcb'_def tcb_cte_cases_def) + done lemma ssa_wp[wp]: "\\s. P (s \ksSchedulerAction := sa\)\ setSchedulerAction sa \\_. P\" by (wpsimp simp: setSchedulerAction_def) -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) - -crunch rescheduleRequired, tcbSchedDequeue, setThreadState +crunch rescheduleRequired, tcbSchedDequeue for aligned'[wp]: "pspace_aligned'" and distinct'[wp]: "pspace_distinct'" - and bounded'[wp]: "pspace_bounded'" - and no_0_obj'[wp]: "no_0_obj'" - (wp: crunch_wps) + and ctes_of[wp]: "\s. P (ctes_of s)" -lemma threadSet_valid_replies': - "\\s. valid_replies' s \ - (\tcb. ko_at' tcb t s - \ (\rptr. tcbState tcb = BlockedOnReply (Some rptr) - \ is_reply_linked rptr s \ tcbState (f tcb) = BlockedOnReply (Some rptr)))\ - threadSet f t - \\_. valid_replies'\" - apply (clarsimp simp: threadSet_def) - apply (wpsimp wp: setObject_tcb_valid_replies' getObject_tcb_wp) - by (force simp: pred_tcb_at'_def obj_at'_def projectKOs) - -lemma sts'_valid_replies': - "\\s. valid_replies' s \ - (\rptr. st_tcb_at' ((=) (BlockedOnReply (Some rptr))) t s - \ is_reply_linked rptr s \ st = BlockedOnReply (Some rptr))\ - setThreadState st t - \\_. valid_replies'\" - apply (clarsimp simp: setThreadState_def) - apply (wpsimp wp: threadSet_valid_replies') - by (auto simp: pred_tcb_at'_def obj_at'_def projectKOs opt_map_def) +crunch rescheduleRequired, tcbSchedDequeue + for no_0_obj'[wp]: "no_0_obj'" 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)\ - setThreadState st t - \ \rv. valid_pspace' \" + "\ valid_pspace' and tcb_at' t and valid_tcb_state' st \ + setThreadState st t + \ \rv. valid_pspace' \" apply (simp add: valid_pspace'_def) - apply (wpsimp wp: sts_valid_objs' sts'_valid_replies') - by (auto simp: opt_map_def) - -abbreviation - "is_replyState st \ is_BlockedOnReply st \ is_BlockedOnReceive st" - -lemma setObject_tcb_valid_replies'_except_Blocked: - "\\s. valid_replies'_except {rptr} s \ replyTCBs_of s rptr = Some t - \ st_tcb_at' (\st. is_replyState st \ replyObject st = None) t s - \ (tcbState v = BlockedOnReply (Some rptr))\ - setObject t (v :: tcb) - \\rv. valid_replies'\" - supply opt_mapE[elim!] - unfolding valid_replies'_def valid_replies'_except_def - apply (subst pred_tcb_at'_eq_commute)+ - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift' hoare_vcg_ex_lift - set_tcb'.setObject_obj_at'_strongest - simp: pred_tcb_at'_def simp_del: imp_disjL) - apply (rename_tac rptr' rp obj) - apply (case_tac "rptr' = rptr") - apply (fastforce simp: opt_map_def) - apply (drule_tac x=rptr' in spec, drule mp, clarsimp) - apply (auto simp: opt_map_def obj_at'_def) - done - -lemma threadSet_valid_replies'_except_Blocked: - "\\s. valid_replies'_except {rptr} s \ replyTCBs_of s rptr = Some t - \ st_tcb_at' (\st. is_replyState st \ replyObject st = None) t s - \ (\tcb. tcbState (f tcb) = BlockedOnReply (Some rptr))\ - threadSet f t - \\_. valid_replies'\" - apply (clarsimp simp: threadSet_def) - apply (wpsimp wp: setObject_tcb_valid_replies'_except_Blocked[where rptr=rptr] getObject_tcb_wp) - by (auto simp: pred_tcb_at'_def obj_at'_def projectKOs) - -lemma sts'_valid_replies'_except_Blocked: - "\\s. valid_replies'_except {rptr} s \ replyTCBs_of s rptr = Some t - \ st_tcb_at' (\st. is_replyState st \ replyObject st = None) t s\ - setThreadState (BlockedOnReply (Some rptr)) t - \\_. valid_replies'\" - apply (clarsimp simp: setThreadState_def) - apply (wpsimp wp: threadSet_valid_replies'_except_Blocked) - by (auto simp: pred_tcb_at'_def obj_at'_def projectKOs opt_map_def) + apply (rule hoare_pre) + apply (wp sts_valid_objs') + apply (simp add: setThreadState_def threadSet_def + setQueue_def bind_assoc valid_mdb'_def) + apply (wp getObject_obj_at_tcb | simp)+ + 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) + done crunch setQueue - for ct[wp]: "\s. P (ksCurThread s)" + for ct[wp]: "\s. P (ksCurThread s)" crunch setQueue for cur_domain[wp]: "\s. P (ksCurDomain s)" @@ -2956,10 +3377,10 @@ crunch removeFromBitmap 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 projectKOs obj_at'_def) - done +apply (simp add: setQueue_def tcb_in_cur_domain'_def) +apply wp +apply (simp add: ps_clear_def projectKOs obj_at'_def) +done lemma sbn'_valid_pspace'_inv[wp]: "\ valid_pspace' and tcb_at' t and valid_bound_ntfn' ntfn \ @@ -2969,7 +3390,7 @@ lemma sbn'_valid_pspace'_inv[wp]: 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 (wp getObject_obj_at_tcb | simp)+ apply (clarsimp simp: valid_mdb'_def) apply (drule obj_at_ko_at') apply clarsimp @@ -3010,13 +3431,13 @@ lemma threadSet_runnable_sch_act: \\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], + in use_valid [OF _ threadSet_nosch], rule refl) apply (frule_tac P1="(=) (ksCurThread s)" - in use_valid [OF _ threadSet.ct], + in use_valid [OF _ threadSet_ct], rule refl) apply (frule_tac P1="(=) (ksCurDomain s)" - in use_valid [OF _ threadSet.cur_domain], + in use_valid [OF _ threadSet_cd], rule refl) apply (case_tac "ksSchedulerAction b", simp_all add: sch_act_simple_def ct_in_state'_def pred_tcb_at'_def) @@ -3040,28 +3461,25 @@ lemma threadSet_runnable_sch_act: 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) \ - (p \ t \ P (pred_tcb_at' proj Q p s))\ - threadSet f t - \\_ s. P (pred_tcb_at' proj Q p s)\" - unfolding threadSet_def - apply (wpsimp wp: set_tcb'.setObject_wp set_tcb'.getObject_wp) - apply (case_tac "p = t"; clarsimp) - apply (subst pred_tcb_at'_set_obj'_iff, assumption) - apply (clarsimp simp: obj_at'_def) - apply (subst pred_tcb_at'_set_obj'_distinct, assumption, assumption) - apply (clarsimp simp: obj_at'_def) + "\\s. tcb_at' t s \ (if p = t + then obj_at' (\tcb. P (proj (tcb_to_itcb' (f tcb)))) t s + else pred_tcb_at' proj P p s)\ + threadSet f t \\_. pred_tcb_at' proj P p\" + apply (rule hoare_chain) + apply (rule threadSet_obj_at'_really_strongest) + prefer 2 + apply (simp add: pred_tcb_at'_def) + apply (clarsimp split: if_splits simp: pred_tcb_at'_def o_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 +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 \ @@ -3084,90 +3502,12 @@ lemma threadSet_sch_act_wf: apply (wp threadSet_pred_tcb_at_state threadSet_tcbDomain_triv' | clarsimp)+ done -definition - isScActive :: "machine_word \ kernel_state \ bool" -where - "isScActive scPtr s' \ pred_map (\sc. 0 < scRefillMax sc) (scs_of' s') scPtr" - -abbreviation - "ct_isSchedulable \ ct_active' - and (\s. pred_map (\tcb. \ tcbInReleaseQueue tcb) (tcbs_of' s) (ksCurThread s)) - and (\s. pred_map (\scPtr. isScActive scPtr s) (tcbSCs_of s) (ksCurThread s))" - -definition - isSchedulable_bool :: "machine_word \ kernel_state \ bool" -where - "isSchedulable_bool tcbPtr s' - \ pred_map (\tcb. runnable' (tcbState tcb) \ \(tcbInReleaseQueue tcb)) (tcbs_of' s') tcbPtr - \ pred_map (\scPtr. isScActive scPtr s') (tcbSCs_of s') tcbPtr" - -lemma isSchedulable_wp: - "\\s. \t. isSchedulable_bool tcbPtr s = t \ tcb_at' tcbPtr s \ P t s\ isSchedulable tcbPtr \P\" - apply (clarsimp simp: isSchedulable_def) - apply (rule bind_wp[OF _ getObject_tcb_sp]) - apply (wpsimp simp: hoare_vcg_if_lift2 obj_at_def is_tcb inReleaseQueue_def wp: threadGet_wp) - apply (rule conjI) - apply (fastforce simp: isSchedulable_bool_def isScActive_def obj_at'_def projectKOs - pred_tcb_at'_def pred_map_simps in_opt_map_eq - split: option.splits) - apply (clarsimp simp: isSchedulable_bool_def isScActive_def obj_at'_def projectKOs - pred_tcb_at'_def pred_map_simps in_opt_map_eq vs_all_heap_simps - split: option.splits) - by argo - -lemma isSchedulable_sp: - "\P\ isSchedulable tcbPtr \\rv. (\s. rv = isSchedulable_bool tcbPtr s) and P\" - by (wpsimp wp: isSchedulable_wp) - - lemma rescheduleRequired_sch_act'[wp]: "\\\ - rescheduleRequired + rescheduleRequired \\rv s. sch_act_wf (ksSchedulerAction s) s\" - by (wpsimp simp: rescheduleRequired_def wp: isSchedulable_wp) - -lemma rescheduleRequired_weak_sch_act_wf[wp]: - "\\\ - rescheduleRequired - \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: rescheduleRequired_def setSchedulerAction_def) - apply (wp hoare_TrueI | simp add: weak_sch_act_wf_def)+ - done - -lemma sts_weak_sch_act_wf[wp]: - "\\s. weak_sch_act_wf (ksSchedulerAction s) s - \ (ksSchedulerAction s = SwitchToThread t \ runnable' st)\ - setThreadState st t - \\_ s. weak_sch_act_wf (ksSchedulerAction s) s\" - unfolding setThreadState_def scheduleTCB_def - apply (wpsimp wp: hoare_vcg_if_lift2 hoare_vcg_imp_lift hoare_vcg_all_lift - threadSet_pred_tcb_at_state threadSet_tcbDomain_triv - isSchedulable_inv - hoare_pre_cont[where f="isSchedulable x" and P="\rv _. rv" for x] - hoare_pre_cont[where f="isSchedulable x" and P="\rv _. \rv" for x] - simp: weak_sch_act_wf_def) - done - -lemma threadSet_isSchedulable_bool_nochange: - "\\s. runnable' st \ isSchedulable_bool t s\ - threadSet (tcbState_update (\_. st)) t - \\_. isSchedulable_bool t\" - unfolding isSchedulable_bool_def threadSet_def - apply (rule bind_wp[OF _ getObject_tcb_sp]) - apply (wpsimp wp: setObject_tcb_wp simp: pred_map_def obj_at'_def opt_map_def projectKOs) - apply (fastforce simp: pred_map_def projectKOs isScActive_def elim!: opt_mapE) - done - -lemma threadSet_isSchedulable_bool: - "\\s. runnable' st - \ pred_map (\tcb. \(tcbInReleaseQueue tcb)) (tcbs_of' s) t - \ pred_map (\scPtr. isScActive scPtr s) (tcbSCs_of s) t\ - threadSet (tcbState_update (\_. st)) t - \\_. isSchedulable_bool t\" - unfolding isSchedulable_bool_def threadSet_def - apply (rule bind_wp[OF _ getObject_tcb_sp]) - apply (wpsimp wp: setObject_tcb_wp simp: pred_map_def obj_at'_def opt_map_def projectKOs) - apply (fastforce simp: pred_map_def projectKOs isScActive_def elim!: opt_mapE) + apply (simp add: rescheduleRequired_def) + apply (wp | wpc | simp)+ done lemma setObject_queued_pred_tcb_at'[wp]: @@ -3201,7 +3541,7 @@ lemma threadSet_queued_sch_act_wf[wp]: apply (wp hoare_vcg_conj_lift) apply (simp add: threadSet_def) apply (wp hoare_weak_lift_imp) - apply wps + apply (wps setObject_sa_unchanged) 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)+ @@ -3233,51 +3573,51 @@ lemma tcbSchedDequeue_sch_act_wf[wp]: 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 - \ \ pred_map (\tcb. runnable' (tcbState tcb)) (tcbs_of' s) t) - \ (sch_act_wf (ksSchedulerAction s) s)\ - scheduleTCB t \\_ s. sch_act_wf (ksSchedulerAction s) s\" - apply (simp add: scheduleTCB_def) - by (wpsimp wp: isSchedulable_wp simp: isSchedulable_bool_def pred_map_def opt_map_Some) +crunch tcbSchedDequeue + for nosch: "\s. P (ksSchedulerAction s)" 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) + apply (wp | simp)+ prefer 2 apply assumption apply (case_tac "runnable' st") - apply (wpsimp wp: hoare_drop_imps threadSet_runnable_sch_act) + apply ((wp threadSet_runnable_sch_act hoare_drop_imps | simp)+)[1] 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 projectKOs pred_map_def elim!: opt_mapE) + (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 projectKOs) apply (simp only: imp_conv_disj) - apply (wpsimp wp: threadSet_pred_tcb_at_state threadSet_sch_act_wf hoare_vcg_disj_lift) + apply (wp threadSet_pred_tcb_at_state threadSet_sch_act_wf + hoare_vcg_disj_lift|simp)+ 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) + apply wp + apply simp prefer 2 apply assumption apply (case_tac "runnable' st") - apply (wpsimp wp: hoare_drop_imps threadSet_runnable_sch_act) + apply (rule_tac P'="\s. sch_act_wf (ksSchedulerAction s) s" + in hoare_pre_imp, simp) + apply ((wp hoare_drop_imps threadSet_runnable_sch_act | simp)+)[1] 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 projectKOs pred_map_def elim!: opt_mapE) + (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 projectKOs) 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) + apply (rule hoare_pre) + apply (wp threadSet_pred_tcb_at_state threadSet_sch_act_wf + hoare_vcg_disj_lift|simp)+ + apply (auto simp: sch_act_simple_def) done lemma sbn_sch_act': @@ -3298,33 +3638,31 @@ lemma sch_act_simple_lift: \sch_act_simple\ f \\rv. sch_act_simple\" by (simp add: sch_act_simple_def) assumption -lemma rescheduleRequired_sch_act_simple_True[wp]: - "\\\ rescheduleRequired \\rv. sch_act_simple\" - by (wpsimp simp: rescheduleRequired_def) - -crunch scheduleTCB - for sch_act_simple[wp]: sch_act_simple - (wp: crunch_wps hoare_vcg_if_lift2) +lemma rescheduleRequired_sch_act_simple[wp]: + "\sch_act_simple\ rescheduleRequired \\rv. sch_act_simple\" + apply (simp add: rescheduleRequired_def) + apply (wp | wpc | simp)+ + done crunch tcbSchedDequeue for no_sa[wp]: "\s. P (ksSchedulerAction s)" lemma sts_sch_act_simple[wp]: "\sch_act_simple\ setThreadState st t \\rv. sch_act_simple\" - apply (clarsimp simp: setThreadState_def) - by (wpsimp simp: sch_act_simple_def) + apply (simp add: setThreadState_def) + apply (wp hoare_drop_imps | rule sch_act_simple_lift | simp)+ + done 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) + apply (simp add: threadSet_def getObject_def setObject_def + loadObject_default_def + split_def projectKO_def2 alignCheck_assert + magnitudeCheck_assert updateObject_default_def) + apply (intro oblivious_bind, simp_all) done lemma tcbSchedEnqueue_sch_act[wp]: @@ -3342,15 +3680,20 @@ lemma tcbSchedEnqueue_weak_sch_act[wp]: apply (wp setQueue_sch_act threadSet_weak_sch_act_wf | clarsimp)+ done +lemma threadGet_wp: + "\\s. \tcb. ko_at' tcb t s \ P (f tcb) s\ threadGet f t \P\" + apply (simp add: threadGet_def) + apply (wp getObject_tcb_wp) + apply (clarsimp simp: obj_at'_def) + done + lemma threadGet_const: "\\s. tcb_at' t s \ obj_at' (P \ f) t s\ threadGet f t \\rv s. P (rv)\" - apply (simp add: threadGet_getObject) + apply (simp add: threadGet_def liftM_def) apply (wp getObject_tcb_wp) apply (clarsimp simp: obj_at'_def) done -context begin interpretation Arch . (*FIXME: arch_split*) - schematic_goal l2BitmapSize_def': (* arch specific consequence *) "l2BitmapSize = numeral ?X" by (simp add: l2BitmapSize_def wordBits_def word_size numPriorities_def) @@ -3543,7 +3886,7 @@ lemma addToBitmap_valid_bitmapQ: lemma threadGet_const_tcb_at: "\\s. tcb_at' t s \ obj_at' (P s \ f) t s\ threadGet f t \\rv s. P s rv \" - apply (simp add: threadGet_getObject) + apply (simp add: threadGet_def liftM_def) apply (wp getObject_tcb_wp) apply (clarsimp simp: obj_at'_def) done @@ -3552,7 +3895,7 @@ lemma threadGet_const_tcb_at_imp_lift: "\\s. tcb_at' t s \ obj_at' (P s \ f) t s \ obj_at' (Q s \ f) t s \ threadGet f t \\rv s. P s rv \ Q s rv \" - apply (simp add: threadGet_getObject) + apply (simp add: threadGet_def liftM_def) apply (wp getObject_tcb_wp) apply (clarsimp simp: obj_at'_def) done @@ -3615,304 +3958,36 @@ lemma rescheduleRequired_bitmapQ_no_L2_orphans_sch_act_simple: apply (wp, fastforce) done -lemma scheduleTCB_bitmapQ_sch_act_simple: - "\valid_bitmapQ and sch_act_simple\ - scheduleTCB tcbPtr - \\_. valid_bitmapQ \" - by (wpsimp simp: scheduleTCB_def - wp: rescheduleRequired_valid_bitmapQ_sch_act_simple isSchedulable_inv - hoare_vcg_if_lift2 hoare_drop_imps) - lemma sts_valid_bitmapQ_sch_act_simple: "\valid_bitmapQ and sch_act_simple\ setThreadState st t \\_. valid_bitmapQ \" - apply (simp add: setThreadState_def pred_conj_def) - by (wpsimp wp: threadSet_valid_bitmapQ scheduleTCB_bitmapQ_sch_act_simple) - -lemma scheduleTCB_bitmapQ_no_L2_orphans_sch_act_simple: - "\bitmapQ_no_L2_orphans and sch_act_simple\ - scheduleTCB tcbPtr - \\_. bitmapQ_no_L2_orphans \" - by (wpsimp simp: scheduleTCB_def - wp: rescheduleRequired_bitmapQ_no_L2_orphans_sch_act_simple isSchedulable_inv - hoare_vcg_if_lift2 hoare_drop_imps) + apply (simp add: setThreadState_def) + apply (wp rescheduleRequired_valid_bitmapQ_sch_act_simple + threadSet_valid_bitmapQ [THEN hoare_strengthen_post]) + apply (clarsimp simp: sch_act_simple_def inQ_def)+ + done lemma sts_valid_bitmapQ_no_L2_orphans_sch_act_simple: - "\ bitmapQ_no_L2_orphans and sch_act_simple\ - setThreadState st t - \\_. bitmapQ_no_L2_orphans \" - apply (simp add: setThreadState_def pred_conj_def) - by (wpsimp wp: threadSet_valid_bitmapQ_no_L2_orphans - scheduleTCB_bitmapQ_no_L2_orphans_sch_act_simple) - -lemma scheduleTCB_bitmapQ_no_L1_orphans_sch_act_simple: - "\bitmapQ_no_L1_orphans and sch_act_simple\ - scheduleTCB tcbPtr - \\_. bitmapQ_no_L1_orphans \" - by (wpsimp simp: scheduleTCB_def - wp: rescheduleRequired_bitmapQ_no_L1_orphans_sch_act_simple isSchedulable_inv - hoare_vcg_if_lift2 hoare_drop_imps) + "\bitmapQ_no_L2_orphans and sch_act_simple\ + setThreadState st t + \\_. bitmapQ_no_L2_orphans\" + apply (simp add: setThreadState_def) + apply (wp rescheduleRequired_bitmapQ_no_L2_orphans_sch_act_simple + threadSet_valid_bitmapQ_no_L2_orphans [THEN hoare_strengthen_post]) + apply (clarsimp simp: sch_act_simple_def inQ_def)+ + done lemma sts_valid_bitmapQ_no_L1_orphans_sch_act_simple: "\bitmapQ_no_L1_orphans and sch_act_simple\ setThreadState st t \\_. bitmapQ_no_L1_orphans \" - apply (simp add: setThreadState_def pred_conj_def) - by (wpsimp wp: threadSet_valid_bitmapQ_no_L1_orphans - scheduleTCB_bitmapQ_no_L1_orphans_sch_act_simple) - -lemma scheduleTCB_valid_queues: - "\Invariants_H.valid_queues\ - scheduleTCB tcbPtr - \\_. Invariants_H.valid_queues\" - apply (clarsimp simp: scheduleTCB_def getCurThread_def getSchedulerAction_def) - apply (intro bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp wp: isSchedulable_inv) - apply (rule hoare_when_cases; (solves \wpsimp\)?) - by (wpsimp simp: scheduleTCB_def sch_act_simple_def - wp: rescheduleRequired_valid_queues_sch_act_simple hoare_vcg_if_lift2 - hoare_drop_imps) - -lemma sts_valid_queues[wp]: - "setThreadState st t \valid_queues\" - apply (simp add: setThreadState_def pred_conj_def) - apply (wpsimp wp: threadSet_valid_queues scheduleTCB_valid_queues) - apply (clarsimp simp: inQ_def) - done - -lemma sbn_valid_queues: - "setBoundNotification ntfn t \Invariants_H.valid_queues\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_queues) - by (clarsimp simp: sch_act_simple_def Invariants_H.valid_queues_def valid_queues_no_bitmap_def - inQ_def)+ - -lemma addToBitmap_valid_queues'[wp]: - "\ valid_queues' \ addToBitmap d p \\_. valid_queues' \" - unfolding valid_queues'_def addToBitmap_def - modifyReadyQueuesL1Bitmap_def modifyReadyQueuesL2Bitmap_def - getReadyQueuesL1Bitmap_def getReadyQueuesL2Bitmap_def - by (wp, simp) - -lemma tcbSchedEnqueue_valid_queues'[wp]: - "tcbSchedEnqueue t \valid_queues'\" - apply (simp add: tcbSchedEnqueue_def) - apply (rule hoare_pre) - apply (rule_tac Q'="\rv. valid_queues' and obj_at' (\obj. tcbQueued obj = rv) t" - in bind_wp) - apply (rename_tac queued) - apply (case_tac queued; simp_all add: unless_def when_def) - apply (wp threadSet_valid_queues' setQueue_valid_queues' | simp)+ - apply (subst conj_commute, wp) - apply (rule hoare_pre_post, assumption) - apply (clarsimp simp: addToBitmap_def modifyReadyQueuesL1Bitmap_def modifyReadyQueuesL2Bitmap_def - getReadyQueuesL1Bitmap_def getReadyQueuesL2Bitmap_def) - apply wp - apply fastforce - apply wp - apply (subst conj_commute) - apply clarsimp - apply (rule_tac Q'="\rv. valid_queues' - and obj_at' (\obj. \ tcbQueued obj) t - and obj_at' (\obj. tcbPriority obj = prio) t - and obj_at' (\obj. tcbDomain obj = tdom) t - and (\s. t \ set (ksReadyQueues s (tdom, prio)))" - in hoare_post_imp) - apply (clarsimp simp: valid_queues'_def obj_at'_def projectKOs inQ_def) - apply (wp setQueue_valid_queues' | simp | simp add: setQueue_def)+ - apply (wp getObject_tcb_wp | simp add: threadGet_getObject)+ - apply (clarsimp simp: obj_at'_def inQ_def projectKOs valid_queues'_def) - apply (wp getObject_tcb_wp | simp add: threadGet_getObject)+ - apply (clarsimp simp: obj_at'_def) - done - -lemma rescheduleRequired_valid_queues'[wp]: - "rescheduleRequired \valid_queues'\" - apply (simp add: rescheduleRequired_def) - apply (wpsimp wp: isSchedulable_inv hoare_vcg_if_lift2) - done - -lemma tcbSchedEnqueue_sch_act_sane[wp]: - "tcbSchedEnqueue t \sch_act_sane\" - apply (clarsimp simp: tcbSchedEnqueue_def sch_act_sane_def) - by (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') - -lemma rescheduleRequired_valid_release_queue[wp]: - "rescheduleRequired \valid_release_queue\" - apply (simp add: rescheduleRequired_def getSchedulerAction_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule_tac Q'="\_. valid_release_queue" in bind_wp_fwd - ; (solves \wpsimp simp: valid_release_queue_def\)?) - done - -lemma rescheduleRequired_valid_release_queue'[wp]: - "rescheduleRequired \valid_release_queue'\" - apply (simp add: rescheduleRequired_def getSchedulerAction_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule_tac Q'="\_. valid_release_queue'" in bind_wp_fwd - ; (solves \wpsimp simp: valid_release_queue'_def\)?) - done - -lemma setThreadState_valid_queues'[wp]: - "\\s. valid_queues' s\ setThreadState st t \\rv. valid_queues'\" - apply (simp add: setThreadState_def scheduleTCB_def) - apply (rule bind_wp_fwd_skip) - apply (wp threadSet_valid_queues') - apply (clarsimp simp: inQ_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (clarsimp simp: getSchedulerAction_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp wp: isSchedulable_inv) - apply (rule hoare_when_cases; wpsimp simp: weak_sch_act_wf_def) - done - -lemma setThreadState_valid_release_queue[wp]: - "setThreadState st t \valid_release_queue\" - apply (simp add: setThreadState_def scheduleTCB_def) - apply (rule bind_wp_fwd_skip) - apply (wp threadSet_valid_release_queue) - using valid_release_queue_def apply simp - apply (rule bind_wp_fwd_skip, wpsimp) - apply (clarsimp simp: getSchedulerAction_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp wp: isSchedulable_inv) - apply (rule hoare_when_cases) - apply clarsimp - apply wpsimp - done - -lemma setThreadState_valid_release_queue'[wp]: - "setThreadState st t \valid_release_queue'\" - apply (simp add: setThreadState_def scheduleTCB_def) - apply (rule bind_wp_fwd_skip) - apply (wp threadSet_valid_release_queue') - apply (fastforce simp: obj_at'_def valid_release_queue'_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (clarsimp simp: getSchedulerAction_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp wp: isSchedulable_inv) - apply (rule hoare_when_cases) - apply clarsimp - apply wpsimp - done - -lemma setBoundNotification_valid_queues'[wp]: - "\\s. valid_queues' s\ setBoundNotification ntfn t \\rv. valid_queues'\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_queues') - apply (fastforce simp: inQ_def obj_at'_def pred_tcb_at'_def) - done - -lemma setBoundNotification_valid_release_queue[wp]: - "setBoundNotification ntfn t \valid_release_queue\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_release_queue) - apply (fastforce simp: inQ_def obj_at'_def pred_tcb_at'_def) - done - -lemma setBoundNotification_valid_release_queues[wp]: - "setBoundNotification ntfn t \valid_release_queue'\" - apply (simp add: setBoundNotification_def) - apply (wp threadSet_valid_release_queue') - apply (fastforce simp: inQ_def obj_at'_def pred_tcb_at'_def valid_release_queue'_def) - done - -lemma setThreadState_valid_objs'[wp]: - "\ valid_tcb_state' st and valid_objs' \ setThreadState st t \ \_. valid_objs' \" - apply (simp add: setThreadState_def pred_conj_def) - apply (wpsimp wp: threadSet_valid_objs') - apply (clarsimp simp: valid_tcb'_tcbState_update) - done - -crunch addToBitmap - for ksPSpace[wp]: "\s. P (ksPSpace s ptr = opt)" - -lemma addToBitmap_valid_tcb'[wp]: - "addToBitmap tdom prio \valid_tcb' tcb\" - by (wpsimp simp: addToBitmap_def getReadyQueuesL2Bitmap_def getReadyQueuesL1Bitmap_def - modifyReadyQueuesL2Bitmap_def modifyReadyQueuesL1Bitmap_def - update_valid_tcb') - -lemma addToBitmap_valid_tcbs'[wp]: - "addToBitmap tdom prio \valid_tcbs'\" - unfolding valid_tcbs'_def - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_imp_lift') - done - -crunch setQueue - for valid_tcb'[wp]: "\s. valid_tcb' tcb s" - and ksPSpace[wp]: "\s. P (ksPSpace s ptr = opt)" - -lemma tcbSchedEnqueue_valid_tcb'[wp]: - "tcbSchedEnqueue thread \valid_tcb' tcb\" - apply (clarsimp simp: tcbSchedEnqueue_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (clarsimp simp: unless_def when_def) - apply (rule bind_wp_fwd_skip, wpsimp)+ - apply (wpsimp wp: threadSet_valid_tcb') - done - -lemma tcbSchedEnqueue_valid_tcbs'[wp]: - "tcbSchedEnqueue thread \valid_tcbs'\" - apply (clarsimp simp: tcbSchedEnqueue_def setQueue_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (clarsimp simp: unless_def when_def) - apply (rule bind_wp_fwd_skip, wpsimp simp: valid_tcbs'_def wp: update_valid_tcb')+ - apply (wpsimp wp: threadSet_valid_tcbs') - done - -lemma setSchedulerAction_valid_tcbs'[wp]: - "setSchedulerAction sa \valid_tcbs'\" - unfolding valid_tcbs'_def - apply (wpsimp wp: hoare_vcg_all_lift update_valid_tcb') - done - -lemma rescheduleRequired_valid_tcb'[wp]: - "rescheduleRequired \valid_tcb' tcb\" - apply (clarsimp simp: rescheduleRequired_def) - apply (rule bind_wp_fwd_skip, wpsimp wp: update_valid_tcb' isSchedulable_wp)+ - apply (wpsimp wp: update_valid_tcb') - done - -lemma rescheduleRequired_valid_tcbs'[wp]: - "rescheduleRequired \valid_tcbs'\" - apply (clarsimp simp: rescheduleRequired_def) - apply (rule bind_wp_fwd_skip, wpsimp wp: update_valid_tcb' isSchedulable_wp)+ - apply (wpsimp wp: update_valid_tcb') - done - -crunch scheduleTCB - for valid_tcbs'[wp]: valid_tcbs' - (wp: crunch_wps simp: crunch_simps) - -lemma setThreadState_valid_tcbs'[wp]: - "\ valid_tcb_state' st and 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) - done - -lemma rescheduleRequired_ksQ: - "\\s. sch_act_simple s \ P (ksReadyQueues s)\ - rescheduleRequired - \\_ s. P (ksReadyQueues s)\" - including no_pre - apply (simp add: rescheduleRequired_def sch_act_simple_def) - apply (rule_tac Q'="\rv s. (rv = ResumeCurrentThread \ rv = ChooseNewThread) - \ P (ksReadyQueues s)" in bind_wp) - apply wpsimp - apply (case_tac x; simp) - apply wp + apply (simp add: setThreadState_def) + apply (wp rescheduleRequired_bitmapQ_no_L1_orphans_sch_act_simple + threadSet_valid_bitmapQ_no_L1_orphans [THEN hoare_strengthen_post]) + apply (clarsimp simp: sch_act_simple_def inQ_def)+ done -lemma scheduleTCB_ksQ: - "\\s. P (ksReadyQueues s)\ - scheduleTCB tcbPtr - \\_ s. P (ksReadyQueues s)\" - by (wpsimp simp: scheduleTCB_def sch_act_simple_def - wp: isSchedulable_inv rescheduleRequired_ksQ hoare_vcg_if_lift2 isSchedulable_wp) - lemma setSchedulerAction_ksQ[wp]: "\\s. P (ksReadyQueues s)\ setSchedulerAction act \\_ s. P (ksReadyQueues s)\" by (wp, simp) @@ -4081,16 +4156,14 @@ lemma getMRs_corres: (tcb_at t and pspace_aligned and pspace_distinct) \ (thread_get (arch_tcb_get_registers o tcb_arch) t) (asUser t (mapM getRegister ARM_H.msgRegisters))" - unfolding arch_tcb_get_registers_def - - apply (subst thread_get_as_user) + apply (subst thread_get_registers) apply (rule asUser_corres') apply (subst mapM_gets) apply (simp add: getRegister_def) apply (simp add: S ARM_H.msgRegisters_def msg_registers_def) done show ?thesis - apply (case_tac mi, simp add: get_mrs_def getMRs_def mirel split del: if_split) + apply (case_tac mi, simp add: get_mrs_def getMRs_def split del: if_split) apply (case_tac buf) apply (rule corres_guard_imp) apply (rule corres_split [where R = "\_. \" and R' = "\_. \", OF T]) @@ -4276,10 +4349,10 @@ proof - od) (take (unat n) msgRegisters))" apply (rule corres_guard_imp) - apply (rule_tac S=Id in corres_mapM, simp+) - apply (rule corres_split_eqr[OF asUser_getRegister_corres asUser_setRegister_corres]) - apply (wp | clarsimp simp: msg_registers_def msgRegisters_def)+ - done + apply (rule_tac S=Id in corres_mapM, simp+) + apply (rule corres_split_eqr[OF asUser_getRegister_corres asUser_setRegister_corres]) + apply (wp | clarsimp simp: msg_registers_def msgRegisters_def)+ + done have wordSize[simp]: "of_nat wordSize = 4" by (simp add: wordSize_def wordBits_def word_size) @@ -4457,22 +4530,20 @@ lemma lookupIPCBuffer_corres: (tcb_at' t and invs') (lookup_ipc_buffer w t) (lookupIPCBuffer w t)" using lookupIPCBuffer_corres' - by (rule corres_guard_imp, auto simp: invs'_def) + by (rule corres_guard_imp, auto simp: invs'_def valid_state'_def) -crunch lookupIPCBuffer - for inv[wp]: P - (wp: crunch_wps) -end +crunch lookupIPCBuffer + for inv[wp]: P -crunch scheduleTCB, possibleSwitchTo - for pred_tcb_at'[wp]: "\s. P' (pred_tcb_at' proj P t s)" - (wp: crunch_wps simp: crunch_simps) +crunch rescheduleRequired + for pred_tcb_at'[wp]: "pred_tcb_at' proj P t" lemma setThreadState_st_tcb': "\\\ setThreadState st t \\rv. st_tcb_at' (\s. s = st) t\" apply (simp add: setThreadState_def) - by (wpsimp wp: threadSet_pred_tcb_at_state) + apply (wp threadSet_pred_tcb_at_state | simp add: if_apply_def2)+ + done lemma setThreadState_st_tcb: "\\s. P st\ setThreadState st t \\rv. st_tcb_at' P t\" @@ -4500,7 +4571,6 @@ lemma setBoundNotification_bound_tcb: crunch rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification for ct'[wp]: "\s. P (ksCurThread s)" - (wp: crunch_wps simp: crunch_simps) lemma ct_in_state'_decomp: assumes x: "\\s. t = (ksCurThread s)\ f \\rv s. t = (ksCurThread s)\" @@ -4522,19 +4592,22 @@ lemma ct_in_state'_set: apply clarsimp done -crunch setQueue, scheduleTCB, tcbSchedDequeue +crunch setQueue, rescheduleRequired, 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)\ + "\valid_idle' and valid_pspace' 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) + apply (wpsimp wp: threadSet_idle' simp: idle_tcb'_def) + done lemma sbn_valid_idle'[wp]: - "\valid_idle' and (\s. t = ksIdleThread s \ \bound ntfn)\ + "\valid_idle' and valid_pspace' and + (\s. t = ksIdleThread s \ \bound ntfn)\ setBoundNotification ntfn t \\rv. valid_idle'\" apply (simp add: setBoundNotification_def) @@ -4543,7 +4616,7 @@ lemma sbn_valid_idle'[wp]: lemma gts_sp': "\P\ getThreadState t \\rv. st_tcb_at' (\st. st = rv) t and P\" - apply (simp add: getThreadState_def threadGet_getObject) + apply (simp add: getThreadState_def threadGet_def) apply wp apply (simp add: o_def pred_tcb_at'_def) apply (wp getObject_tcb_wp) @@ -4552,7 +4625,7 @@ lemma gts_sp': lemma gbn_sp': "\P\ getBoundNotification t \\rv. bound_tcb_at' (\st. st = rv) t and P\" - apply (simp add: getBoundNotification_def threadGet_getObject) + apply (simp add: getBoundNotification_def threadGet_def) apply wp apply (simp add: o_def pred_tcb_at'_def) apply (wp getObject_tcb_wp) @@ -4593,131 +4666,73 @@ lemma tcbSchedDequeue_pred_tcb_at'[wp]: apply (clarsimp simp: obj_at'_def) done -lemma tcbReleaseRemove_pred_tcb_at'[wp]: - "tcbReleaseRemove t \\s. P' (pred_tcb_at' proj P t' s)\" - apply (rule_tac P=P' in P_bool_lift) - unfolding tcbReleaseRemove_def - apply (wp threadSet_pred_tcb_no_state - | clarsimp simp: tcb_to_itcb'_def setReleaseQueue_def - setReprogramTimer_def getReleaseQueue_def)+ - done - -crunch tcbReleaseRemove - for weak_sch_act_wf[wp]: "\s. weak_sch_act_wf (ksSchedulerAction s) s" - lemma sts_st_tcb': "\if t = t' then K (P st) else st_tcb_at' P t\ setThreadState st t' \\_. st_tcb_at' P t\" - by (cases "t = t'" - ; wpsimp wp: threadSet_pred_tcb_at_state simp: setThreadState_def) - -lemma sts_bound_tcb_at'[wp]: - "setThreadState st t' \bound_tcb_at' P t\" - apply (clarsimp simp: setThreadState_def) - by (cases "t = t'" - ; wpsimp wp: threadSet_pred_tcb_at_state - simp: pred_tcb_at'_def)+ - -lemma sts_bound_sc_tcb_at'[wp]: - "setThreadState st t' \bound_sc_tcb_at' P t\" - apply (clarsimp simp: setThreadState_def) - by (cases "t = t'" - ; wpsimp wp: threadSet_pred_tcb_at_state - simp: pred_tcb_at'_def)+ - -lemma sts_bound_yt_tcb_at'[wp]: - "setThreadState st t' \bound_yt_tcb_at' P t\" - apply (clarsimp simp: setThreadState_def) - by (cases "t = t'"; - wpsimp wp: threadSet_pred_tcb_at_state - simp: pred_tcb_at'_def) - -lemma sbn_st_tcb'[wp]: - "setBoundNotification ntfn t' \st_tcb_at' P t\" apply (cases "t = t'", - simp_all add: setBoundNotification_def + simp_all add: setThreadState_def split del: if_split) apply ((wp threadSet_pred_tcb_at_state | simp)+)[1] - apply (wp threadSet_obj_at'_really_strongest | simp add: pred_tcb_at'_def)+ + apply (wp threadSet_obj_at'_really_strongest + | simp add: pred_tcb_at'_def)+ done -context begin interpretation Arch . +lemma sts_bound_tcb_at': + "\bound_tcb_at' P t\ + setThreadState st t' + \\_. bound_tcb_at' P t\" + apply (cases "t = t'", + simp_all add: setThreadState_def + split del: if_split) + apply ((wp threadSet_pred_tcb_at_state | simp)+)[1] + apply (wp threadSet_obj_at'_really_strongest + | simp add: pred_tcb_at'_def)+ + done -crunch scheduleTCB, setThreadState - for cte_wp_at'[wp]: "\s. Q (cte_wp_at' P p s)" - and ksInterruptState[wp]: "\s. P (ksInterruptState s)" - (wp: hoare_when_weak_wp crunch_wps) +lemma sbn_st_tcb': + "\st_tcb_at' P t\ + setBoundNotification ntfn t' + \\_. st_tcb_at' P t\" + apply (cases "t = t'", + simp_all add: setBoundNotification_def + split del: if_split) + apply ((wp threadSet_pred_tcb_at_state | simp)+)[1] + apply (wp threadSet_obj_at'_really_strongest + | simp add: pred_tcb_at'_def)+ + done -lemma sts_ctes_wp_at[wp]: - "setThreadState st p \\s. P (cte_wp_at' Q p' s)\" - apply (clarsimp simp: setThreadState_def) - by (wpsimp wp: threadSet_cte_wp_at') +crunch rescheduleRequired, tcbSchedDequeue, setThreadState, setBoundNotification + for typ_at'[wp]: "\s. P (typ_at' T p s)" -lemmas setThreadState_cap_to'[wp] - = ex_cte_cap_to'_pres [OF sts_ctes_wp_at setThreadState_ksInterruptState] +lemmas setThreadState_typ_ats[wp] = typ_at_lifts [OF setThreadState_typ_at'] +lemmas setBoundNotification_typ_ats[wp] = typ_at_lifts [OF setBoundNotification_typ_at'] crunch setThreadState, setBoundNotification for aligned'[wp]: pspace_aligned' and distinct'[wp]: pspace_distinct' - and cte_wp_at'[wp]: "\s. Q (cte_wp_at' P p s)" - (wp: hoare_when_weak_wp crunch_wps) + and cte_wp_at'[wp]: "cte_wp_at' P p" + (wp: hoare_when_weak_wp) crunch rescheduleRequired - for refs_of'[wp]: "\s. P (state_refs_of' s)" - (wp: threadSet_state_refs_of' crunch_wps) - -crunch scheduleTCB - for state_refs_of'[wp]: "\s. P (state_refs_of' s)" - -abbreviation tcb_non_st_state_refs_of' :: - "kernel_state \ obj_ref \ (obj_ref \ reftype) set" - where - "tcb_non_st_state_refs_of' s t \ - {r \ state_refs_of' s t. snd r = TCBBound \ snd r = TCBSchedContext \ snd r = TCBYieldTo}" - -lemma state_refs_of'_helper2[simp]: - "tcb_non_st_state_refs_of' s t - = {r \ state_refs_of' s t. snd r = TCBBound} - \ {r \ state_refs_of' s t. snd r = TCBSchedContext} - \ {r \ state_refs_of' s t. snd r = TCBYieldTo}" - by fastforce + for refs_of'[wp]: "\s. P (state_refs_of' s)" + (wp: threadSet_state_refs_of') lemma setThreadState_state_refs_of'[wp]: "\\s. P ((state_refs_of' s) (t := tcb_st_refs_of' st - \ tcb_non_st_state_refs_of' s t))\ - setThreadState st t + \ {r \ state_refs_of' s t. snd r = TCBBound}))\ + setThreadState st t \\rv s. P (state_refs_of' s)\" - apply (clarsimp simp: setThreadState_def) - apply (wpsimp wp: threadSet_state_refs_of') - apply simp - apply force+ - by (metis Un_assoc) + by (simp add: setThreadState_def fun_upd_def + | wp threadSet_state_refs_of')+ lemma setBoundNotification_state_refs_of'[wp]: - "\\s. P ((state_refs_of' s) (t := (case ntfn of None \ {} | Some new \ {(new, TCBBound)}) - \ {r \ state_refs_of' s t. snd r \ TCBBound}))\ - setBoundNotification ntfn t + "\\s. P ((state_refs_of' s) (t := tcb_bound_refs' ntfn + \ {r \ state_refs_of' s t. snd r \ TCBBound}))\ + setBoundNotification ntfn t \\rv s. P (state_refs_of' s)\" - apply (clarsimp simp: setBoundNotification_def) - apply (wpsimp wp: threadSet_state_refs_of' - [where f'=id and h'=id and i'=id and F="tcbBoundNotification_update (\_. ntfn)"] - simp: get_refs_def) - apply simp - apply simp - apply simp - apply (prop_tac "{r \ state_refs_of' s t. snd r \ TCBBound} - = {r \ state_refs_of' s t. snd r \ TCBBound \ snd r \ TCBSchedContext - \ snd r \ TCBYieldTo} - \ {r \ state_refs_of' s t. snd r = TCBSchedContext} - \ {r \ state_refs_of' s t. snd r = TCBYieldTo}") - apply fastforce - by (metis id_def Un_ac(1) Un_ac(4)) - -lemma setBoundNotification_list_refs_of_replies'[wp]: - "setBoundNotification ntfn t \\s. P (list_refs_of_replies' s)\" - unfolding setBoundNotification_def - by wpsimp + by (simp add: setBoundNotification_def Un_commute fun_upd_def + | wp threadSet_state_refs_of' )+ lemma sts_cur_tcb'[wp]: "\cur_tcb'\ setThreadState st t \\rv. cur_tcb'\" @@ -4798,14 +4813,17 @@ lemma getTCB_wp: apply (clarsimp simp: obj_at'_def) done -lemma rescheduleRequired_iflive'[wp]: - "rescheduleRequired \if_live_then_nonz_cap'\" - apply (simp add: rescheduleRequired_def) - apply (wpsimp wp: isSchedulable_wp) - apply (erule if_live_then_nonz_capE') - apply (fastforce simp: isSchedulable_bool_def pred_map_def - ko_wp_at'_def obj_at'_def projectKO_eq projectKO_tcb - elim!: opt_mapE) +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') + apply (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 projectKOs ko_wp_at'_def) done lemma tcbQueueRemove_ex_nonz_cap_to'[wp]: @@ -4878,15 +4896,13 @@ lemma sts_iflive'[wp]: \ pspace_aligned' s \ pspace_distinct' s\ setThreadState st t \\rv. if_live_then_nonz_cap'\" - apply (simp add: setThreadState_def scheduleTCB_def rescheduleRequired_def - getCurThread_def getSchedulerAction_def) - apply (rule_tac Q'="\rv. if_live_then_nonz_cap'" in bind_wp_fwd) + apply (simp add: setThreadState_def setQueue_def) + apply wpsimp + apply (rule_tac Q'="\rv. if_live_then_nonz_cap' and pspace_aligned' and pspace_distinct'" + in hoare_post_imp) + apply clarsimp apply (wpsimp wp: threadSet_iflive') - apply fastforce+ - apply (intro bind_wp[OF _ gets_sp] - bind_wp[OF _ isSchedulable_sp]) - apply (rule hoare_when_cases; (solves \wpsimp\)?) - apply (wpsimp wp: isSchedulable_inv hoare_vcg_if_lift2 hoare_drop_imps) + apply fastforce done lemma sbn_iflive'[wp]: @@ -4900,23 +4916,7 @@ lemma sbn_iflive'[wp]: apply auto done -crunch addToBitmap - for if_unsafe_then_cap'[wp]: if_unsafe_then_cap' - -lemma setThreadState_if_unsafe_then_cap'[wp]: - "setThreadState st p \if_unsafe_then_cap'\" - apply (clarsimp simp: setThreadState_def scheduleTCB_def rescheduleRequired_def when_def) - apply (rule bind_wp_fwd_skip) - apply (rule threadSet_ifunsafe'T) - apply (clarsimp simp: tcb_cte_cases_def) - apply (wpsimp simp: tcbSchedEnqueue_def) - apply (rule threadSet_ifunsafe'T) - apply (clarsimp simp: tcb_cte_cases_def) - apply (wpsimp simp: setQueue_def - wp: isSchedulable_inv hoare_vcg_if_lift2 hoare_drop_imps)+ - done - -crunch setBoundNotification +crunch setThreadState, setBoundNotification for ifunsafe'[wp]: "if_unsafe_then_cap'" lemma st_tcb_ex_cap'': @@ -4933,10 +4933,10 @@ lemma bound_tcb_ex_cap'': elim!: ko_wp_at'_weakenE if_live_then_nonz_capE') -crunch setThreadState +crunch setThreadState, setBoundNotification for arch'[wp]: "\s. P (ksArchState s)" and it'[wp]: "\s. P (ksIdleThread s)" - (wp: getObject_tcb_inv crunch_wps + (wp: getObject_inv_tcb simp: updateObject_default_def unless_def crunch_simps) crunch removeFromBitmap @@ -4944,7 +4944,9 @@ crunch removeFromBitmap lemma sts_ctes_of [wp]: "\\s. P (ctes_of s)\ setThreadState st t \\rv s. P (ctes_of s)\" - by wpsimp + apply (simp add: setThreadState_def) + apply (wp threadSet_ctes_ofT | simp add: tcb_cte_cases_def)+ + done lemma sbn_ctes_of [wp]: "\\s. P (ctes_of s)\ setBoundNotification ntfn t \\rv s. P (ctes_of s)\" @@ -4955,13 +4957,13 @@ lemma sbn_ctes_of [wp]: crunch setThreadState, setBoundNotification for ksInterruptState[wp]: "\s. P (ksInterruptState s)" and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" - (simp: unless_def crunch_simps wp: setObject_ksPSpace_only updateObject_default_inv crunch_wps) + (simp: unless_def crunch_simps wp: setObject_ksPSpace_only updateObject_default_inv) lemmas setThreadState_irq_handlers[wp] = valid_irq_handlers_lift'' [OF sts_ctes_of setThreadState_ksInterruptState] lemmas setBoundNotification_irq_handlers[wp] - = valid_irq_handlers_lift'' [OF sbn_ctes_of setBoundNotification.ksInterruptState] + = valid_irq_handlers_lift'' [OF sbn_ctes_of setBoundNotification_ksInterruptState] lemma sts_global_reds' [wp]: "\valid_global_refs'\ setThreadState st t \\_. valid_global_refs'\" @@ -4974,7 +4976,6 @@ lemma sbn_global_reds' [wp]: crunch setThreadState, setBoundNotification for irq_states' [wp]: valid_irq_states' and pde_mappings' [wp]: valid_pde_mappings' - (wp: crunch_wps) lemma addToBitmap_ksMachine[wp]: "\\s. P (ksMachineState s)\ addToBitmap d p \\rv s. P (ksMachineState s)\" @@ -4993,7 +4994,6 @@ lemma tcbSchedEnqueue_ksMachine[wp]: crunch setThreadState, setBoundNotification for ksMachine[wp]: "\s. P (ksMachineState s)" and pspace_domain_valid[wp]: "pspace_domain_valid" - (wp: crunch_wps) lemma setThreadState_vms'[wp]: "\valid_machine_state'\ setThreadState F t \\rv. valid_machine_state'\" @@ -5040,7 +5040,7 @@ lemma tcbSchedEnqueue_ct_not_inQ: apply (rule_tac P'="\s. ksSchedulerAction s = ResumeCurrentThread \ obj_at' (Not \ tcbQueued) (ksCurThread s) s \ ksCurThread s \ t" in hoare_pre_imp, clarsimp) - apply (rule hoare_convert_imp [OF threadSet.ksSchedulerAction]) + apply (rule hoare_convert_imp [OF threadSet_nosch]) apply (rule hoare_weaken_pre) apply (wps setObject_ct_inv) apply (rule threadSet_obj_at'_strongish) @@ -5067,7 +5067,7 @@ lemma tcbSchedAppend_ct_not_inQ: apply (rule_tac P'="\s. ksSchedulerAction s = ResumeCurrentThread \ obj_at' (Not \ tcbQueued) (ksCurThread s) s \ ksCurThread s \ t" in hoare_pre_imp, clarsimp) - apply (rule hoare_convert_imp [OF threadSet.ksSchedulerAction]) + apply (rule hoare_convert_imp [OF threadSet_nosch]) apply (rule hoare_weaken_pre) apply (wps setObject_ct_inv) apply (rule threadSet_obj_at'_strongish) @@ -5084,11 +5084,11 @@ lemma tcbSchedAppend_ct_not_inQ: done qed -lemma setSchedulerAction_direct[wp]: +lemma setSchedulerAction_direct: "\\\ setSchedulerAction sa \\_ s. ksSchedulerAction s = sa\" by (wpsimp simp: setSchedulerAction_def) -lemma rescheduleRequired_ct_not_inQ[wp]: +lemma rescheduleRequired_ct_not_inQ: "\\\ rescheduleRequired \\_. ct_not_inQ\" apply (simp add: rescheduleRequired_def ct_not_inQ_def) apply (rule_tac Q'="\_ s. ksSchedulerAction s = ChooseNewThread" @@ -5096,34 +5096,31 @@ lemma rescheduleRequired_ct_not_inQ[wp]: apply (wp setSchedulerAction_direct) 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) - -crunch tcbSchedEnqueue, tcbSchedAppend, tcbSchedDequeue +crunch tcbSchedEnqueue + for nosch[wp]: "\s. P (ksSchedulerAction s)" + (simp: unless_def) +crunch tcbSchedAppend for nosch[wp]: "\s. P (ksSchedulerAction s)" (simp: unless_def) lemma rescheduleRequired_sa_cnt[wp]: "\\s. True \ rescheduleRequired \\_ s. ksSchedulerAction s = ChooseNewThread \" unfolding rescheduleRequired_def setSchedulerAction_def - by (wpsimp wp: hoare_vcg_if_lift2) + by wpsimp lemma possibleSwitchTo_ct_not_inQ: "\ct_not_inQ and (\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t)\ possibleSwitchTo t \\_. ct_not_inQ\" apply (simp add: possibleSwitchTo_def curDomain_def) - apply (wpsimp wp: rescheduleRequired_ct_not_inQ tcbSchedEnqueue_ct_not_inQ threadGet_wp - simp: inReleaseQueue_def + apply (wpsimp wp: hoare_weak_lift_imp rescheduleRequired_ct_not_inQ tcbSchedEnqueue_ct_not_inQ + threadGet_wp | (rule hoare_post_imp[OF _ rescheduleRequired_sa_cnt], fastforce))+ - apply (fastforce simp: obj_at'_def) done 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 (rule hoare_convert_imp [OF threadSet_nosch]) apply (simp add: threadSet_def) apply (wp) apply (wps setObject_ct_inv) @@ -5142,7 +5139,7 @@ lemma threadSet_tcbState_update_ct_not_inQ[wp]: 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 (rule hoare_convert_imp [OF threadSet_nosch]) apply (simp add: threadSet_def) apply (wp) apply (wps setObject_ct_inv) @@ -5164,7 +5161,10 @@ lemma setThreadState_ct_not_inQ: (is "\?PRE\ _ \_\") including no_pre apply (simp add: setThreadState_def) - by (wpsimp wp: threadSet_tcbState_update_ct_not_inQ) + apply (wp rescheduleRequired_ct_not_inQ) + apply (rule_tac Q'="\_. ?PRE" in hoare_post_imp, clarsimp) + apply (wp) + done lemma setBoundNotification_ct_not_inQ: "\ct_not_inQ\ setBoundNotification ntfn t \\_. ct_not_inQ\" @@ -5181,7 +5181,7 @@ lemma tcbSchedDequeue_ct_not_inQ[wp]: \ct_not_inQ and (\_. \tcb. \tcbQueued (F tcb))\ threadSet F t \\_. ct_not_inQ\" apply (simp add: ct_not_inQ_def) - apply (wp hoare_convert_imp [OF threadSet.ksSchedulerAction]) + apply (wp hoare_convert_imp [OF threadSet_nosch]) apply (simp add: threadSet_def) apply (wp) apply (wps setObject_ct_inv) @@ -5246,20 +5246,21 @@ lemma setSchedulerAction_spec: 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) +lemma rescheduleRequired_ksCurDomain[wp]: + "\ \s. P (ksCurDomain s) \ rescheduleRequired \\_ s. P (ksCurDomain s) \" + apply (simp add: rescheduleRequired_def) + apply wpsimp + done + +lemma rescheduleRequired_ksDomSchedule[wp]: + "\ \s. P (ksDomSchedule s) \ rescheduleRequired \\_ s. P (ksDomSchedule s) \" + by (simp add: rescheduleRequired_def) wpsimp 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'\" @@ -5267,16 +5268,39 @@ lemma setThreadState_ct_idle_or_in_cur_domain'[wp]: apply (wp threadSet_ct_idle_or_in_cur_domain' hoare_drop_imps | simp)+ done +lemma setThreadState_ksCurDomain[wp]: + "\ \s. P (ksCurDomain s) \ setThreadState st tptr \\_ s. P (ksCurDomain s) \" + apply (simp add: setThreadState_def) + apply wpsimp + done + +lemma setThreadState_ksDomSchedule[wp]: + "\ \s. P (ksDomSchedule s) \ setThreadState st tptr \\_ s. P (ksDomSchedule s) \" + apply (simp add: setThreadState_def) + apply wpsimp + done + 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 +lemma setBoundNotification_ksCurDomain[wp]: + "\ \s. P (ksCurDomain s) \ setBoundNotification st tptr \\_ s. P (ksCurDomain s) \" + apply (simp add: setBoundNotification_def) + apply wpsimp + done + +lemma setBoundNotification_ksDomSchedule[wp]: + "\ \s. P (ksDomSchedule s) \ setBoundNotification st tptr \\_ s. P (ksDomSchedule s) \" + apply (simp add: setBoundNotification_def) + apply wpsimp + done + crunch rescheduleRequired, setBoundNotification, setThreadState for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - (wp: crunch_wps) lemma sts_utr[wp]: "\untyped_ranges_zero'\ setThreadState st t \\_. untyped_ranges_zero'\" @@ -5685,46 +5709,6 @@ lemma sts_invs_minor': apply (frule tcb_in_valid_state', clarsimp+) by (cases st; simp add: valid_tcb_state'_def split: Structures_H.thread_state.split_asm) -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 sts_invs_minor': - "\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 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 - simp: cteCaps_of_def o_def pred_tcb_at'_eq_commute) - apply (intro conjI impI) - 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 projectKO_eq projectKO_tcb) - 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'\ - 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 - simp: cteCaps_of_def o_def) - by metis - lemma sts_cap_to'[wp]: "\ex_nonz_cap_to' p\ setThreadState st t \\rv. ex_nonz_cap_to' p\" by (wp ex_nonz_cap_to_pres') @@ -5743,17 +5727,6 @@ lemmas isTS_defs = isRestart_def isInactive_def isIdleThreadState_def -(* FIXME: replace `sts_st_tcb_at'_cases`, which is missing the `tcb_at'` precondition. *) -lemma setThreadState_st_tcb_at'_cases: - "\\s. tcb_at' t s \ - (t = t' \ P st) \ - (t \ t' \ st_tcb_at' P t' s)\ - setThreadState st t - \\_. st_tcb_at' P t'\" - unfolding setThreadState_def - apply (wpsimp wp: scheduleTCB_pred_tcb_at' threadSet_pred_tcb_at_state) - done - lemma sts_st_tcb_at'_cases: "\\s. ((t = t') \ (P ts \ tcb_at' t' s)) \ ((t \ t') \ st_tcb_at' P t' s)\ setThreadState ts t @@ -5762,13 +5735,6 @@ lemma sts_st_tcb_at'_cases: apply fastforce done -lemma sts_st_tcb_at'_cases_strong: - "\\s. tcb_at' t s \ (t = t' \ P (P' ts)) \ (t \ t' \ P (st_tcb_at' P' t' s))\ - setThreadState ts t - \\rv s. P (st_tcb_at' P' t' s) \" - unfolding setThreadState_def - by (wpsimp wp: scheduleTCB_pred_tcb_at' threadSet_pred_tcb_at_state) - lemma threadSet_ct_running': "(\tcb. tcbState (f tcb) = tcbState tcb) \ \ct_running'\ threadSet f t \\rv. ct_running'\" @@ -5862,7 +5828,7 @@ proof - show ?thesis apply (wp dmo_invs' no_irq_storeWord no_irq) - apply (clarsimp simp: storeWord_def invs'_def) + apply (clarsimp simp: storeWord_def invs'_def valid_state'_def) apply (clarsimp simp: valid_machine_state'_def pointerInUserData_def assert_def simpler_modify_def fail_def bind_def return_def pageBits_def aligned_offset_ignore @@ -5921,542 +5887,156 @@ lemma asUser_irq_handlers': apply (wpsimp wp: threadSet_irq_handlers' [OF all_tcbI, OF ball_tcb_cte_casesI] select_f_inv) done -lemma archTcbUpdate_aux2: "(\tcb. tcb\ tcbArch := f (tcbArch tcb)\) = tcbArch_update f" - by (rule ext, case_tac tcb, simp) - -(* FIXME: rename. VER-1331 *) -lemma threadSet_obj_at'_simple_strongest: - "\\s. tcb_at' t s \ - (t = t' \ P (obj_at' (\tcb. Q (f tcb)) t s)) \ - (t \ t' \ P (obj_at' Q t' s))\ - threadSet f t - \\_ s. P (obj_at' (Q :: tcb \ bool) t' s)\" - unfolding threadSet_def - apply (wpsimp wp: set_tcb'.setObject_obj_at'_strongest set_tcb'.getObject_wp) - apply (case_tac "t = t'"; clarsimp simp: obj_at'_def) - done - -(* Used as the "side condition template" for the `*_obj_at'_only_st_qd_ft` family of - `crunch`-able lemmas. Needs to keep the assumption about `f` separate from the hoare - triple so as to not pollute the side conditions that `crunch` will add to the final - lemma. *) -lemma threadSet_obj_at'_only_st_qd_ft: - assumes "(\upd tcb. Q (tcbState_update upd tcb) = Q tcb) \ - (\upd tcb. Q (tcbQueued_update upd tcb) = Q tcb) \ - (\upd tcb. Q (tcbFault_update upd tcb) = Q tcb) \ - (\tcb. Q (f tcb) = Q tcb)" - shows - "\\s. P (obj_at' Q t' s) \ - (\upd tcb. Q (tcbState_update upd tcb) = Q tcb) \ - (\upd tcb. Q (tcbQueued_update upd tcb) = Q tcb) \ - (\upd tcb. Q (tcbFault_update upd tcb) = Q tcb)\ - threadSet f t - \\_ s. P (obj_at' Q t' s)\" - apply (wpsimp wp: threadSet_obj_at'_simple_strongest simp: assms) - done +(* the brave can try to move this up to near setObject_update_TCB_corres' *) -crunch scheduleTCB - for obj_at'_only_st_qd_ft: "\s. P (obj_at' (Q :: tcb \ bool) t s)" - (simp: crunch_simps wp: crunch_wps) +definition non_exst_same :: "Structures_H.tcb \ Structures_H.tcb \ bool" +where + "non_exst_same tcb tcb' \ \d p ts. tcb' = tcb\tcbDomain := d, tcbPriority := p, tcbTimeSlice := ts\" -(* FIXME: Proved outside of `crunch` because without the `[where P=P]` constraint, the - postcondition unifies with the precondition in a wonderfully exponential way. VER-1337 *) -lemma setThreadState_obj_at'_only_st_qd_ft: - "\\s. P (obj_at' Q t' s) \ - (\upd tcb. Q (tcbState_update upd tcb) = Q tcb) \ - (\upd tcb. Q (tcbQueued_update upd tcb) = Q tcb) \ - (\upd tcb. Q (tcbFault_update upd tcb) = Q tcb)\ - setThreadState st t - \\_ s. P (obj_at' Q t' s)\" - unfolding setThreadState_def - apply (wpsimp wp: scheduleTCB_obj_at'_only_st_qd_ft threadSet_obj_at'_only_st_qd_ft[where P=P]) - done +fun non_exst_same' :: "Structures_H.kernel_object \ Structures_H.kernel_object \ bool" +where + "non_exst_same' (KOTCB tcb) (KOTCB tcb') = non_exst_same tcb tcb'" | + "non_exst_same' _ _ = True" -crunch addToBitmap, setQueue - for ko_wp_at'[wp]: "\s. P (ko_wp_at' Q p s)" +lemma non_exst_same_prio_upd[simp]: + "non_exst_same tcb (tcbPriority_update f tcb)" + by (cases tcb, simp add: non_exst_same_def) -lemma tcbSchedEnqueue_tcb_obj_at'_no_change: - assumes [simp]: "\tcb. Q (tcbQueued_update (\_. True) tcb) = Q tcb" - shows "tcbSchedEnqueue t \\s. P (obj_at' Q t' s)\" - unfolding tcbSchedEnqueue_def - apply (wpsimp wp: threadSet_obj_at'_simple_strongest hoare_vcg_imp_lift threadGet_wp) - apply (clarsimp simp: obj_at'_def) - done +lemma non_exst_same_timeSlice_upd[simp]: + "non_exst_same tcb (tcbTimeSlice_update f tcb)" + by (cases tcb, simp add: non_exst_same_def) -lemma setThreadState_tcb_obj_at'_no_change: - assumes [simp]: "\tcb. Q (tcbState_update (\_. st) tcb) = Q tcb" - "\tcb. Q (tcbQueued_update (\_. True) tcb) = Q tcb" - shows "setThreadState st t \\s. P (obj_at' Q t' s)\" - unfolding setThreadState_def scheduleTCB_def rescheduleRequired_def - apply (wpsimp wp: tcbSchedEnqueue_tcb_obj_at'_no_change hoare_vcg_if_lift2 isSchedulable_inv - hoare_vcg_imp_lift threadSet_obj_at'_simple_strongest - hoare_pre_cont[where f="isSchedulable x" and P="\rv _. rv" for x] - hoare_pre_cont[where f="isSchedulable x" and P="\rv _. \rv" for x]) - done - -lemma setThreadState_oa: - "setThreadState st t - \\s. P (obj_at' (\tcb. Q (tcbCTable tcb) (tcbVTable tcb) (tcbIPCBufferFrame tcb) - (tcbFaultHandler tcb) (tcbTimeoutHandler tcb) (tcbDomain tcb) - (tcbMCP tcb) (tcbPriority tcb) (tcbQueued tcb) (tcbInReleaseQueue tcb) - (tcbFault tcb)) - t' s) \" - unfolding setThreadState_def scheduleTCB_def rescheduleRequired_def tcbSchedEnqueue_def - apply (wpsimp wp: threadSet_obj_at'_simple_strongest hoare_vcg_imp_lift hoare_vcg_if_lift2 - threadGet_obj_at'_field isSchedulable_inv - hoare_pre_cont[where f="isSchedulable x" and P="\rv _. rv" for x] - hoare_pre_cont[where f="isSchedulable x" and P="\rv _. \rv" for x]) - done - -lemma getThreadState_only_rv_wp[wp]: - "\\s. tcb_at' t s \ st_tcb_at' P t s\ - getThreadState t - \\rv _. P rv\" - apply (wpsimp wp: gts_wp') - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - done +lemma non_exst_same_domain_upd[simp]: + "non_exst_same tcb (tcbDomain_update f tcb)" + by (cases tcb, simp add: non_exst_same_def) -lemma getThreadState_only_state_wp[wp]: - "\\s. tcb_at' t s \ P s\ - getThreadState t - \\_. P\" - apply (wpsimp wp: gts_wp') - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) +lemma set_eobject_corres': + assumes e: "etcb_relation etcb tcb'" + assumes z: "\s. obj_at' P ptr s + \ map_to_ctes ((ksPSpace s) (ptr \ KOTCB tcb')) = map_to_ctes (ksPSpace s)" + shows + "corres dc + (tcb_at ptr and is_etcb_at ptr) + (obj_at' (\ko. non_exst_same ko tcb') ptr and obj_at' P ptr + and obj_at' (\tcb. (tcbDomain tcb \ tcbDomain tcb' \ tcbPriority tcb \ tcbPriority tcb') + \ \ tcbQueued tcb) ptr) + (set_eobject ptr etcb) (setObject ptr tcb')" + apply (rule corres_no_failI) + apply (rule no_fail_pre) + apply wp + apply (clarsimp simp: obj_at'_def) + apply (unfold set_eobject_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 projectKOs + updateObject_default_def in_magnitude_check objBits_simps') + apply (clarsimp simp add: state_relation_def z) + apply (clarsimp simp add: obj_at_def is_etcb_at_def) + apply (simp only: pspace_relation_def dom_fun_upd2 simp_thms) + apply (elim conjE) + apply (frule bspec, erule domI) + apply (rule conjI) + apply (rule ballI, drule(1) bspec) + apply (drule domD) + apply (clarsimp simp: is_other_obj_relation_type) + apply (drule(1) bspec) + apply (clarsimp simp: non_exst_same_def) + apply (case_tac bb; simp) + apply (clarsimp simp: obj_at'_def other_obj_relation_def tcb_relation_cut_def cte_relation_def + tcb_relation_def projectKOs + split: if_split_asm)+ + apply (clarsimp simp: aobj_relation_cuts_def split: ARM_A.arch_kernel_obj.splits) + apply (rename_tac arch_kernel_obj obj d p ts) + apply (case_tac arch_kernel_obj; simp) + apply (clarsimp simp: pte_relation_def pde_relation_def is_tcb_def + split: if_split_asm)+ + apply (extract_conjunct \match conclusion in "ekheap_relation _ _" \ -\) + apply (simp only: ekheap_relation_def dom_fun_upd2 simp_thms) + apply (frule bspec, erule domI) + apply (rule ballI, drule(1) bspec) + apply (drule domD) + apply (clarsimp simp: obj_at'_def) + apply (insert e) + apply (clarsimp simp: other_obj_relation_def etcb_relation_def is_other_obj_relation_type + split: Structures_A.kernel_object.splits kernel_object.splits arch_kernel_obj.splits) + apply (frule in_ready_q_tcbQueued_eq[where t=ptr]) + apply (rename_tac s' conctcb' abstcb exttcb) + apply (clarsimp simp: ready_queues_relation_def Let_def) + apply (prop_tac "(tcbSchedNexts_of s')(ptr := tcbSchedNext tcb') = tcbSchedNexts_of s'") + apply (fastforce simp: opt_map_def obj_at'_def projectKOs non_exst_same_def split: option.splits) + apply (prop_tac "(tcbSchedPrevs_of s')(ptr := tcbSchedPrev tcb') = tcbSchedPrevs_of s'") + apply (fastforce simp: opt_map_def obj_at'_def projectKOs non_exst_same_def split: option.splits) + apply (clarsimp simp: ready_queue_relation_def opt_map_def opt_pred_def obj_at'_def projectKOs + inQ_def non_exst_same_def + split: option.splits) + apply metis done -(* FIXME: replace tcbSchedEnqueue_not_st. VER-1333 *) -lemma tcbSchedEnqueue_obj_at': - "\\s. tcb_at' t s \ - (t = t' \ P (obj_at' (\tcb. Q (tcb\tcbQueued := True\)) t' s)) \ - (t \ t' \ P (obj_at' Q t' s))\ - tcbSchedEnqueue t - \\_ s. P (obj_at' Q t' s)\" - unfolding tcbSchedEnqueue_def - apply (wpsimp wp: threadSet_obj_at'_simple_strongest hoare_vcg_imp_lift hoare_vcg_if_lift2 - threadGet_obj_at'_field) - apply (case_tac "t = t'"; clarsimp) - apply normalise_obj_at' - apply (case_tac "tcbQueued ko"; clarsimp) - apply (prop_tac "tcbQueued_update (\_. True) ko = ko") - apply (case_tac ko; clarsimp) +lemma set_eobject_corres: + assumes tcbs: "non_exst_same tcb' tcbu'" + assumes e: "etcb_relation etcb tcb' \ etcb_relation etcbu tcbu'" + assumes tables': "\(getF, v) \ ran tcb_cte_cases. getF tcbu' = getF tcb'" + assumes r: "r () ()" + shows + "corres r + (tcb_at add and (\s. ekheap s add = Some etcb)) + (ko_at' tcb' add + and obj_at' (\tcb. (tcbDomain tcb \ tcbDomain tcbu' \ tcbPriority tcb \ tcbPriority tcbu') + \ \ tcbQueued tcb) add) + (set_eobject add etcbu) (setObject add tcbu')" + apply (rule_tac F="non_exst_same tcb' tcbu' \ etcb_relation etcbu tcbu'" in corres_req) + apply (clarsimp simp: state_relation_def obj_at_def obj_at'_def) + apply (frule(1) pspace_relation_absD) + apply (clarsimp simp: projectKOs other_obj_relation_def ekheap_relation_def e tcbs) + apply (drule bspec, erule domI) + apply (clarsimp simp: e) + apply (erule conjE) + apply (rule corres_guard_imp) + apply (rule corres_rel_imp) + apply (rule set_eobject_corres'[where P="(=) tcb'"]) + apply simp + defer + apply (simp add: r) + apply (fastforce simp: is_etcb_at_def elim!: obj_at_weakenE) + apply (subst(asm) eq_commute) + apply (clarsimp simp: obj_at'_def) + apply (clarsimp simp: projectKOs obj_at'_def objBits_simps) + apply (subst map_to_ctes_upd_tcb, assumption+) + apply (simp add: ps_clear_def3 field_simps objBits_defs mask_def) + apply (subst if_not_P) + apply (fastforce dest: bspec [OF tables', OF ranI]) apply simp done -lemma getCurSc_corres: - "corres (=) \ \ (gets cur_sc) (getCurSc)" - unfolding getCurSc_def - apply (rule corres_gets_trivial) - by (clarsimp simp: state_relation_def) - -crunch getScTime, scActive - for inv[wp]: P - (wp: crunch_wps) - -lemma threadSet_empty_tcbSchedContext_valid_tcbs'[wp]: - "threadSet (tcbSchedContext_update Map.empty) t \valid_tcbs'\" - by (wp threadSet_valid_tcbs') (simp add: valid_tcb'_def valid_tcbs'_def tcb_cte_cases_def) - -lemma threadSet_vrq_wp: - "\valid_release_queue and - (\s. tptr \ set (ksReleaseQueue s) \ obj_at' (\obj. tcbInReleaseQueue (f obj)) tptr s)\ - threadSet f tptr - \\_. valid_release_queue\" - apply (clarsimp simp: valid_release_queue_def) - apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - by (case_tac "x=tptr"; simp) - -lemma threadSet_vrq_inv: - "\valid_release_queue and - (\s. (\obj. tcbInReleaseQueue (f obj) = tcbInReleaseQueue obj))\ - threadSet f tptr - \\_. valid_release_queue\" - apply (clarsimp simp: valid_release_queue_def) - by (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - -lemma threadSet_vrq'_inv: - "\valid_release_queue' and - (\s. (\obj. tcbInReleaseQueue (f obj) = tcbInReleaseQueue obj))\ - threadSet f tptr - \\_. valid_release_queue'\" - apply (clarsimp simp: valid_release_queue'_def) - by (wpsimp wp: threadSet_obj_at'_simple_strongest hoare_vcg_imp_lift' hoare_vcg_all_lift) - -lemma threadSet_enqueue_vrq: - "\(\s. \a. a \ set (ksReleaseQueue s) \ a\t \ obj_at' tcbInReleaseQueue a s) - and tcb_at' t\ - threadSet (tcbInReleaseQueue_update (\_. True)) t - \\_. valid_release_queue\" - apply (clarsimp simp: valid_release_queue_def) - apply (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift) - by (case_tac "x=t"; simp) - -lemma threadSet_enqueue_vrq': - "\(\s. \a. obj_at' tcbInReleaseQueue a s \ a\t \ a \ set (ksReleaseQueue s)) - and tcb_at' t - and (\s. t \ set (ksReleaseQueue s))\ - threadSet (tcbInReleaseQueue_update (\_. True)) t - \\_. valid_release_queue'\" - apply (clarsimp simp: valid_release_queue'_def) - apply (wpsimp wp: hoare_vcg_imp_lift hoare_vcg_all_lift threadSet_obj_at'_simple_strongest) - by (case_tac "x=t"; fastforce) - -lemma thread_set_empty_tcb_sched_context_weaker_valid_sched_action[wp]: - "thread_set (tcb_sched_context_update Map.empty) tcbPtr \weaker_valid_sched_action\" - apply (simp only: thread_set_def) - apply (wpsimp wp: set_object_wp) - apply (clarsimp simp: weaker_valid_sched_action_def pred_tcb_at_def) - apply (auto simp: is_tcb_def get_tcb_def obj_at_def map_project_def tcbs_of_kh_def opt_map_def - pred_map_def map_join_def tcb_scps_of_tcbs_def sc_refill_cfgs_of_scs_def - split: option.splits Structures_A.kernel_object.splits) - done - -end - -lemma setReleaseQueue_ksReleaseQueue[wp]: - "\\_. P qs\ setReleaseQueue qs \\_ s. P (ksReleaseQueue s)\" - by (wpsimp simp: setReleaseQueue_def) - -lemma setReleaseQueue_pred_tcb_at'[wp]: - "setReleaseQueue qs \\s. P (pred_tcb_at' proj P' t' s)\" - by (wpsimp simp: setReleaseQueue_def) - -crunch tcbReleaseDequeue - for valid_pspace'[wp]: valid_pspace' - and state_refs_of'[wp]: "\s. P (state_refs_of' s)" - and list_refs_of_replies'[wp]: "\s. P (list_refs_of_replies' s)" - 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 valid_irq_states'[wp]: valid_irq_states' - 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 gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - and valid_machine_state'[wp]: valid_machine_state' - (simp: crunch_simps wp: crunch_wps) - -crunch tcbReleaseDequeue - for cur_tcb'[wp]: cur_tcb' - (simp: crunch_simps cur_tcb'_def wp: crunch_wps threadSet_cur ignore: threadSet) - -crunch tcbReleaseRemove - 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 ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - and list_refs_of_replies[wp]: "\s. sym_refs (list_refs_of_replies' s)" - and state_refs_of'[wp]: "\s. sym_refs (state_refs_of' s)" - 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 sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - and interrupt_state[wp]: "\s. P (ksInterruptState s)" - and valid_irq_state'[wp]: valid_irq_states' - 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 gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" - and ctes_of[wp]: "\s. P (ctes_of s)" - and ksCurThread[wp]: "\s. P (ksCurThread s)" - and ksMachineState[wp]: "\s. P (ksMachineState s)" - and valid_pde_mappings'[wp]: valid_pde_mappings' - and reply_projs[wp]: "\s. P (replyNexts_of s) (replyPrevs_of s) (replyTCBs_of s) (replySCs_of s)" - (wp: crunch_wps simp: crunch_simps tcb_cte_cases_def) - -global_interpretation tcbReleaseRemove: typ_at_all_props' "tcbReleaseRemove tptr" - by typ_at_props' - -lemma tcbInReleaseQueue_update_tcb_cte_cases: - "(a, b) \ ran tcb_cte_cases \ a (tcbInReleaseQueue_update f tcb) = a tcb" - unfolding tcb_cte_cases_def - by (case_tac tcb; fastforce simp: tcbInReleaseQueue_update_def) - -lemma tcbInReleaseQueue_update_ctes_of[wp]: - "threadSet (tcbInReleaseQueue_update f) x \\s. P (ctes_of s)\" - by (wpsimp wp: threadSet_ctes_ofT simp: tcbInReleaseQueue_update_tcb_cte_cases) - -crunch tcbReleaseDequeue - for ctes_of[wp]: "\s. P (ctes_of s)" - and valid_idle'[wp]: valid_idle' - and valid_irq_handlers'[wp]: valid_irq_handlers' - and valid_pde_mappings'[wp]: valid_pde_mappings' - and ct_idle_or_in_cur_domain'[wp]: ct_idle_or_in_cur_domain' - and if_unsafe_then_cap'[wp]: if_unsafe_then_cap' - (ignore: threadSet - simp: crunch_simps tcbInReleaseQueue_update_tcb_cte_cases - wp: crunch_wps threadSet_idle' threadSet_irq_handlers' threadSet_ct_idle_or_in_cur_domain' - threadSet_ifunsafe'T) - -lemma tcbReleaseDequeue_valid_objs'[wp]: - "tcbReleaseDequeue \valid_objs'\" - unfolding tcbReleaseDequeue_def - by (wpsimp simp: setReprogramTimer_def setReleaseQueue_def wp: threadSet_valid_objs') - -lemma tcbReleaseDequeue_sch_act_wf[wp]: - "tcbReleaseDequeue \\s. sch_act_wf (ksSchedulerAction s) s\" - unfolding tcbReleaseDequeue_def - by (wpsimp simp: setReprogramTimer_def setReleaseQueue_def wp: threadSet_sch_act) - -lemma tcbReleaseDequeue_if_live_then_nonz_cap'[wp]: - "tcbReleaseDequeue \if_live_then_nonz_cap'\" - unfolding tcbReleaseDequeue_def - apply (wpsimp simp: setReprogramTimer_def setReleaseQueue_def tcbInReleaseQueue_update_tcb_cte_cases - wp: threadSet_iflive'T) - by auto - -lemma tcbReleaseDequeue_ct_not_inQ[wp]: - "tcbReleaseDequeue \ct_not_inQ\" - unfolding tcbReleaseDequeue_def - by (wpsimp simp: setReprogramTimer_def setReleaseQueue_def wp: threadSet_not_inQ) - -lemma tcbReleaseDequeue_valid_queues[wp]: - "tcbReleaseDequeue \valid_queues\" - unfolding tcbReleaseDequeue_def - apply (wpsimp simp: setReprogramTimer_def setReleaseQueue_def wp: threadSet_valid_queues) - by (auto simp: valid_queues_def valid_queues_no_bitmap_def valid_bitmapQ_def bitmapQ_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def inQ_def) - -lemma tcbReleaseDequeue_valid_queues'[wp]: - "tcbReleaseDequeue \valid_queues'\" - unfolding tcbReleaseDequeue_def - apply (wpsimp simp: setReprogramTimer_def setReleaseQueue_def wp: threadSet_valid_queues') - by (auto simp: valid_queues'_def valid_queues_no_bitmap_def valid_bitmapQ_def bitmapQ_def - bitmapQ_no_L2_orphans_def bitmapQ_no_L1_orphans_def inQ_def) - -lemma tcbReleaseDequeue_valid_release_queue[wp]: - "\valid_release_queue and (\s. distinct (ksReleaseQueue s))\ - tcbReleaseDequeue - \\_. valid_release_queue\" - unfolding tcbReleaseDequeue_def - apply (wpsimp simp: setReprogramTimer_def setReleaseQueue_def wp: threadSet_valid_release_queue) - apply (clarsimp simp: valid_release_queue_def) - by (case_tac "ksReleaseQueue s"; simp) - -lemma tcbReleaseDequeue_valid_release_queue'[wp]: - "\valid_release_queue' and (\s. ksReleaseQueue s \ [])\ - tcbReleaseDequeue - \\_. valid_release_queue'\" - unfolding tcbReleaseDequeue_def - apply (wpsimp simp: setReprogramTimer_def setReleaseQueue_def wp: threadSet_valid_release_queue') - apply (clarsimp simp: valid_release_queue'_def split: list.splits) - by (metis list.exhaust_sel set_ConsD) - -lemma tcbReleaseDequeue_invs'[wp]: - "\invs' - and (\s. ksReleaseQueue s \ []) - and distinct_release_queue\ - tcbReleaseDequeue - \\_. invs'\" - by (wpsimp simp: invs'_def valid_dom_schedule'_def - wp: valid_irq_node_lift irqs_masked_lift untyped_ranges_zero_lift - cteCaps_of_ctes_of_lift) - -lemma tcbReleaseDequeue_ksCurThread[wp]: - "\\s. P (hd (ksReleaseQueue s)) (ksCurThread s)\ - tcbReleaseDequeue - \\r s. P r (ksCurThread s)\" - unfolding tcbReleaseDequeue_def - by (wpsimp simp: setReprogramTimer_def setReleaseQueue_def) - -lemma tcbReleaseDequeue_runnable'[wp]: - "\\s. st_tcb_at' runnable' (hd (ksReleaseQueue s)) s\ - tcbReleaseDequeue - \\r s. st_tcb_at' runnable' r s\" - unfolding tcbReleaseDequeue_def - by (wpsimp simp: setReprogramTimer_def wp: threadSet_pred_tcb_no_state) - -lemma tcbReleaseRemove_if_unsafe_then_cap'[wp]: - "tcbReleaseRemove tcbPtr \if_unsafe_then_cap'\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def) - apply (wpsimp wp: threadSet_ifunsafe') - done - -lemma tcbReleaseRemove_valid_machine_state'[wp]: - "tcbReleaseRemove tcbPtr \valid_machine_state'\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def) - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_disj_lift) - done - -lemma tcbReleaseRemove_ct_idle_or_in_cur_domain'[wp]: - "tcbReleaseRemove tcbPtr \ct_idle_or_in_cur_domain'\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def) - apply (wpsimp wp: threadSet_ct_idle_or_in_cur_domain' hoare_vcg_imp_lift' hoare_vcg_disj_lift) - done - -crunch setReprogramTimer - for valid_queues[wp]: valid_queues - and ksReleaseQueue[wp]: "\s. P (ksReleaseQueue s)" - -lemma tcbReleaseRemove_valid_queues_no_bitmap: - "\valid_queues\ - tcbReleaseRemove tcbPtr - \\_. valid_queues_no_bitmap\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp wp: threadSet_valid_queues_no_bitmap_new) - apply (clarsimp simp: valid_queues_no_bitmap_def valid_queues_def) - apply (fastforce simp: obj_at'_def inQ_def) - done - -crunch setReleaseQueue, setReprogramTimer - for valid_bitmapQ[wp]: valid_bitmapQ - and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans - and bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans - (simp: crunch_simps valid_bitmapQ_def bitmapQ_def bitmapQ_no_L2_orphans_def - bitmapQ_no_L1_orphans_def) - -crunch tcbReleaseRemove - for valid_bitmapQ[wp]: valid_bitmapQ - and bitmapQ_no_L2_orphans[wp]: bitmapQ_no_L2_orphans - and bitmapQ_no_L1_orphans[wp]: bitmapQ_no_L1_orphans - -lemma setReleaseQueue_obj_at'[wp]: - "setReleaseQueue Q \\s. R (obj_at' P t s)\" - unfolding setReleaseQueue_def by wpsimp - -crunch setReleaseQueue - for ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" - -lemma setReleaseQueue_valid_queues_no_bitmap[wp]: - "setReleaseQueue Q \valid_queues_no_bitmap\" - unfolding valid_queues_no_bitmap_def - by (wpsimp wp: hoare_vcg_imp_lift' hoare_vcg_all_lift hoare_vcg_ball_lift2) - -crunch tcbReleaseRemove - for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' p" - (wp: threadSet_cap_to simp: tcb_cte_cases_def) - -lemma tcbReleaseRemove_valid_queues: - "tcbReleaseRemove tcbPtr \valid_queues\" - apply (wpsimp wp: tcbReleaseRemove_valid_queues_no_bitmap tcbReleaseRemove_valid_bitmapQ - simp: valid_queues_def) - done - -crunch setReleaseQueue, setReprogramTimer - for valid_queues'[wp]: valid_queues' - (simp: valid_queues'_def) - -lemma tcbReleaseRemove_valid_queues'[wp]: - "tcbReleaseRemove tcbPtr \valid_queues'\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp wp: threadSet_valid_queues') - apply (clarsimp simp: valid_queues'_def inQ_def) - done - -crunch setReprogramTimer - for valid_release_queue[wp]: valid_release_queue - and valid_release_queue'[wp]: valid_release_queue' - -lemma tcbReleaseRemove_valid_release_queue[wp]: - "tcbReleaseRemove tcbPtr \valid_release_queue\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp wp: threadSet_valid_release_queue) - apply (clarsimp simp: valid_release_queue_def) - done - -lemma tcbReleaseRemove_valid_release_queue'[wp]: - "tcbReleaseRemove tcbPtr \valid_release_queue'\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp wp: threadSet_valid_release_queue') - apply (clarsimp simp: valid_release_queue'_def obj_at'_def) - done - -crunch setReprogramTimer - for valid_objs'[wp]: valid_objs' - and sch_act_wf[wp]: "\s. sch_act_wf (ksSchedulerAction s) s" - and if_live_then_nonz_cap'[wp]: if_live_then_nonz_cap' - and valid_mdb'[wp]: valid_mdb' - and ct_not_inQ[wp]: ct_not_inQ - (simp: valid_mdb'_def) - -lemma tcbReleaseRemove_valid_objs'[wp]: - "tcbReleaseRemove tcbPtr \valid_objs'\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp wp: threadSet_valid_objs') - done - -lemma tcbReleaseRemove_valid_mdb'[wp]: - "tcbReleaseRemove tcbPtr \valid_mdb'\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule_tac Q'="\_. valid_mdb'" in bind_wp_fwd) - apply wpsimp - apply (clarsimp simp: valid_mdb'_def) - apply (wpsimp wp: setObject_tcb_mdb' getObject_tcb_wp simp: threadSet_def) - apply (fastforce simp: obj_at'_def projectKOs tcb_cte_cases_def) - done - -lemma tcbReleaseRemove_sch_act_wf[wp]: - "tcbReleaseRemove tcbPtr \\s. sch_act_wf (ksSchedulerAction s) s\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (wpsimp wp: threadSet_sch_act) - done - -lemma tcbReleaseRemove_if_live_then_nonz_cap'[wp]: - "\\s. if_live_then_nonz_cap' s\ - tcbReleaseRemove tptr - \\_. if_live_then_nonz_cap'\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp wp: threadSet_iflive' setSchedContext_iflive' threadGet_wp) - apply (fastforce simp: obj_at'_def projectKOs) - done - -lemma tcbReleaseRemove_valid_idle'[wp]: - "tcbReleaseRemove tcbPtr \valid_idle'\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (wpsimp wp: threadSet_idle') - done - -lemma tcbReleaseRemove_ct_not_inQ[wp]: - "tcbReleaseRemove tcbPtr \ct_not_inQ\" - apply (clarsimp simp: tcbReleaseRemove_def getReleaseQueue_def setReleaseQueue_def) - apply (rule bind_wp[OF _ gets_sp]) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp wp: threadSet_not_inQ) - done - -lemma 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 cur_tcb_lift - untyped_ranges_zero_lift tcbReleaseRemove_valid_queues valid_replies'_lift - simp: cteCaps_of_def o_def) +lemma ethread_set_corresT: + assumes x: "\tcb'. non_exst_same tcb' (f' tcb')" + assumes z: "\tcb. \(getF, setF) \ ran tcb_cte_cases. getF (f' tcb) = getF tcb" + assumes e: "\etcb tcb'. etcb_relation etcb tcb' \ etcb_relation (f etcb) (f' tcb')" + shows + "corres dc + (tcb_at t and valid_etcbs) + (tcb_at' t + and obj_at' (\tcb. (tcbDomain tcb \ tcbDomain (f' tcb) + \ tcbPriority tcb \ tcbPriority (f' tcb)) + \ \ tcbQueued tcb) t) + (ethread_set f t) (threadSet f' t)" + apply (simp add: ethread_set_def threadSet_def bind_assoc) + apply (rule corres_guard_imp) + apply (rule corres_split[OF corres_get_etcb set_eobject_corres]) + apply (rule x) + apply (erule e) + apply (simp add: z)+ + apply (wp getObject_tcb_wp)+ + apply clarsimp + apply (simp add: valid_etcbs_def tcb_at_st_tcb_at[symmetric]) + apply (force simp: tcb_at_def get_etcb_def obj_at_def) + apply (clarsimp simp: obj_at'_def) done -crunch tcbReleaseRemove, tcbSchedDequeue - for sch_act_simple[wp]: sch_act_simple - and ksIdleThread[wp]: "\s. P (ksIdleThread s)" - (wp: crunch_wps simp: crunch_simps sch_act_simple_def) - -lemma tcbInReleaseQueue_update_st_tcb_at'[wp]: - "threadSet (tcbInReleaseQueue_update b) t \\s. Q (st_tcb_at' P t' s)\" - apply (wpsimp wp: threadSet_wp) - apply (cases "t=t'") - apply (fastforce simp: obj_at_simps st_tcb_at'_def ps_clear_def) - apply (erule back_subst[where P=Q]) - apply (fastforce simp: obj_at_simps st_tcb_at'_def ps_clear_def) - done +lemmas ethread_set_corres = + ethread_set_corresT [OF _ all_tcbI, OF _ ball_tcb_cte_casesI] -crunch tcbReleaseEnqueue - for st_tcb_at'[wp]: "\s. Q (st_tcb_at' P tptr s)" - (wp: mapM_wp_inv ignore: threadSet) +lemma archTcbUpdate_aux2: "(\tcb. tcb\ tcbArch := f (tcbArch tcb)\) = tcbArch_update f" + by (rule ext, case_tac tcb, simp) end +end diff --git a/proof/refine/ARM/Tcb_R.thy b/proof/refine/ARM/Tcb_R.thy index 8ff36f6915..5a2291d9ac 100644 --- a/proof/refine/ARM/Tcb_R.thy +++ b/proof/refine/ARM/Tcb_R.thy @@ -8,7 +8,7 @@ theory Tcb_R imports CNodeInv_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma asUser_setNextPC_corres: "corres dc (tcb_at t and invs) (tcb_at' t and invs') @@ -24,255 +24,243 @@ lemma activateIdleThread_corres: (arch_activate_idle_thread t) (activateIdleThread t)" by (simp add: arch_activate_idle_thread_def activateIdleThread_def) -lemma gts_st_tcb': - "\tcb_at' t\ getThreadState t \\rv. st_tcb_at' (\st. st = rv) t\" - apply (rule hoare_weaken_pre) - apply (rule hoare_post_imp[where Q'="\rv s. \rv'. rv = rv' \ st_tcb_at' (\st. st = rv') t s"]) - apply simp - apply (wp hoare_vcg_ex_lift) - apply (clarsimp simp add: pred_tcb_at'_def obj_at'_def) - done - -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 projectKO_sc) - lemma activateThread_corres: - "corres dc (invs and ct_in_state activatable) (invs' and ct_in_state' activatable' and sch_act_simple) + "corres dc (invs and ct_in_state activatable) (invs' and ct_in_state' activatable') activate_thread activateThread" supply subst_all [simp del] - apply add_cur_tcb' apply (simp add: activate_thread_def activateThread_def) apply (rule corres_guard_imp) apply (rule corres_split_eqr[OF getCurThread_corres]) - apply (rule corres_split[OF get_tcb_yield_to_corres]) - apply (rule corres_split[OF corres_when]) - apply clarsimp - apply (rule schedContextCompleteYieldTo_corres) - apply (rule_tac R="\ts s. (activatable ts) \ invs s \ st_tcb_at ((=) ts) thread s" - and R'="\ts s. (activatable' ts) \ invs' s \ st_tcb_at' (\ts'. ts' = ts) thread s" - in corres_split[OF getThreadState_corres]) - apply (rule_tac F="idle rv \ runnable rv" in corres_req, clarsimp) - apply (rule_tac F="idle' rv' \ runnable' rv'" in corres_req, clarsimp) - apply (case_tac rv, simp_all add: isRunning_def isRestart_def, safe, simp_all)[1] - apply (rule corres_guard_imp) - apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) - apply (rule corres_split_nor[OF asUser_setNextPC_corres]) - apply (rule setThreadState_corres, simp) - apply (rule_tac Q'="\_. invs and tcb_at thread" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply wpsimp - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated]) - apply (fastforce simp: invs'_def dest: invs'_valid_tcbs') - apply wp+ - apply (clarsimp simp: st_tcb_at_tcb_at) - apply fastforce - apply (rule corres_guard_imp) - apply (rule activateIdleThread_corres) - apply (clarsimp elim!: st_tcb_weakenE) - apply (clarsimp elim!: pred_tcb'_weakenE) - apply (wp gts_st_tcb gts_st_tcb' gts_st_tcb_at complete_yield_to_invs)+ - apply (wpsimp wp: schedContextCompleteYieldTo_invs' hoare_drop_imp) - apply (wp gts_st_tcb gts_st_tcb' gts_st_tcb_at complete_yield_to_invs - get_tcb_obj_ref_wp threadGet_wp)+ - apply (clarsimp simp: ct_in_state_def tcb_at_invs invs_def valid_state_def valid_pspace_def + apply (rule_tac R="\ts s. valid_tcb_state ts s \ (idle ts \ runnable ts) + \ invs s \ st_tcb_at ((=) ts) thread s" + and R'="\ts s. valid_tcb_state' ts s \ (idle' ts \ runnable' ts) + \ invs' s \ st_tcb_at' (\ts'. ts' = ts) thread s" + in corres_split[OF getThreadState_corres]) + apply (rule_tac F="idle rv \ runnable rv" in corres_req, simp) + apply (rule_tac F="idle' rv' \ runnable' rv'" in corres_req, simp) + apply (case_tac rv, simp_all add: + isRunning_def isRestart_def, + safe, simp_all)[1] + apply (rule corres_guard_imp) + apply (rule corres_split_eqr[OF asUser_getRestartPC_corres]) + apply (rule corres_split_nor[OF asUser_setNextPC_corres]) + apply (rule setThreadState_corres) + apply (simp | wp weak_sch_act_wf_lift_linear)+ + apply (clarsimp simp: st_tcb_at_tcb_at invs_distinct) + apply fastforce + apply (rule corres_guard_imp) + apply (rule activateIdleThread_corres) + apply (clarsimp elim!: st_tcb_weakenE) + apply (clarsimp elim!: pred_tcb'_weakenE) + apply (wp gts_st_tcb gts_st_tcb' gts_st_tcb_at)+ + apply (clarsimp simp: ct_in_state_def tcb_at_invs invs_distinct invs_psp_aligned elim!: st_tcb_weakenE) - apply (fastforce simp: ct_in_state'_def pred_tcb_at'_def obj_at'_def - elim!: pred_tcb'_weakenE) + apply (clarsimp simp: tcb_at_invs' ct_in_state'_def + elim!: pred_tcb'_weakenE) done + 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 - apply (simp add: bind_assoc update_sk_obj_ref_def) + apply (simp add: bind_notification_def bindNotification_def) apply (rule corres_guard_imp) 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 setBoundNotification_corres) - apply wp+ - by auto + apply (wp)+ + apply auto + done + abbreviation "ct_idle' \ ct_in_state' idle'" -lemma activate_invs': - "activateThread \invs'\" - apply (simp add: activateThread_def) - apply (wpsimp wp: activateIdle_invs' sts_invs_minor' schedContextCompleteYieldTo_invs' - hoare_vcg_imp_lift') - by (fastforce simp: pred_tcb_at'_def obj_at'_real_def ko_wp_at'_def sch_act_simple_def) - -declare not_psubset_eq[dest!] (* FIXME: remove, not a good dest rule *) - -crunch schedContextResume - for tcb_at'[wp]: "\s. P (tcb_at' t s)" - (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\ - 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) +lemma gts_st_tcb': + "\tcb_at' t\ getThreadState t \\rv. st_tcb_at' (\st. st = rv) t\" + apply (rule hoare_weaken_pre) + apply (rule hoare_post_imp[where Q'="\rv s. \rv'. rv = rv' \ st_tcb_at' (\st. st = rv') t s"]) + apply simp + apply (wp hoare_vcg_ex_lift) + apply (clarsimp simp add: pred_tcb_at'_def obj_at'_def) done -crunch cancel_ipc - for valid_sched_action[wp]: valid_sched_action - (wp: crunch_wps ignore: set_object thread_set update_sched_context) +lemma activateIdle_invs: + "\invs' and ct_idle'\ + activateIdleThread thread + \\rv. invs' and ct_idle'\" + by (simp add: activateIdleThread_def) -crunch cancel_ipc - for sc_tcb_sc_at[wp]: "sc_tcb_sc_at P t" - (wp: crunch_wps) +lemma activate_invs': + "\invs' and sch_act_simple and ct_in_state' activatable'\ + activateThread + \\rv. invs' and (ct_running' or ct_idle')\" + apply (simp add: activateThread_def) + apply (rule bind_wp) + apply (rule_tac Q'="\state s. invs' s \ sch_act_simple s + \ st_tcb_at' (\st. st = state) thread s + \ thread = ksCurThread s + \ (runnable' state \ idle' state)" in bind_wp) + apply (case_tac rv, simp_all add: isTS_defs hoare_pre_cont + split del: if_splits cong: if_cong) + apply (wp) + apply (clarsimp simp: ct_in_state'_def) + apply (rule_tac Q'="\rv. invs' and ct_idle'" in hoare_post_imp, simp) + apply (wp activateIdle_invs) + apply (clarsimp simp: ct_in_state'_def) + apply (rule_tac Q'="\rv. invs' and ct_running' and sch_act_simple" + in hoare_post_imp, simp) + apply (rule hoare_weaken_pre) + apply (wp ct_in_state'_set asUser_ct sts_invs_minor' + | wp (once) sch_act_simple_lift)+ + apply (rule_tac Q'="\_. st_tcb_at' runnable' thread + and sch_act_simple and invs' + and (\s. thread = ksCurThread s)" + in hoare_post_imp, clarsimp) + apply (wp sch_act_simple_lift)+ + apply (clarsimp simp: valid_idle'_def invs'_def valid_state'_def + pred_tcb_at'_def obj_at'_def idle_tcb'_def + elim!: pred_tcb'_weakenE) + apply (wp gts_st_tcb')+ + apply (clarsimp simp: tcb_at_invs' ct_in_state'_def + pred_disj_def) + done + +crunch activateIdleThread + for nosch[wp]: "\s. P (ksSchedulerAction s)" + (ignore: setNextPC) + +declare not_psubset_eq[dest!] + +lemma setThreadState_runnable_simp: + "runnable' ts \ setThreadState ts t = + threadSet (tcbState_update (\x. ts)) t" + apply (simp add: setThreadState_def isRunnable_def isStopped_def liftM_def) + apply (subst bind_return[symmetric], rule bind_cong[OF refl]) + apply (drule use_valid[OF _ threadSet_pred_tcb_at_state[where proj="itcbState" and p=t and P="(=) ts"]]) + apply simp + apply (subst bind_known_operation_eq) + apply wp+ + apply clarsimp + apply (subst eq_commute, erule conjI[OF _ refl]) + apply (rule empty_fail_getThreadState) + apply (simp add: getCurThread_def getSchedulerAction_def exec_gets) + apply (auto simp: when_def split: Structures_H.thread_state.split) + done + +lemma activate_sch_act: + "\ct_in_state' activatable' and (\s. P (ksSchedulerAction s))\ + activateThread \\rv s. P (ksSchedulerAction s)\" + apply (simp add: activateThread_def getCurThread_def + cong: if_cong Structures_H.thread_state.case_cong) + apply (rule bind_wp [OF _ gets_sp]) + apply (rule bind_wp[where Q'="\st s. (runnable' or idle') st + \ P (ksSchedulerAction s)"]) + apply (rule hoare_pre) + apply (wp | wpc | simp add: setThreadState_runnable_simp)+ + apply (clarsimp simp: ct_in_state'_def cur_tcb'_def pred_tcb_at' + elim!: pred_tcb'_weakenE) + done + +lemma runnable_tsr: + "thread_state_relation ts ts' \ runnable' ts' = runnable ts" + by (case_tac ts, auto) + +lemma idle_tsr: + "thread_state_relation ts ts' \ idle' ts' = idle ts" + by (case_tac ts, auto) + +crunch cancelIPC + for cur[wp]: cur_tcb' + (wp: crunch_wps simp: crunch_simps o_def) + +crunch setupReplyMaster + for cur[wp]: cur_tcb' + (wp: crunch_wps simp: crunch_simps) + +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 + +lemma setupReplyMaster_weak_sch_act_wf[wp]: + "\\s. weak_sch_act_wf (ksSchedulerAction s) s\ + setupReplyMaster thread + \\rv s. weak_sch_act_wf (ksSchedulerAction s) s\" + apply (simp add: setupReplyMaster_def) + apply (wp) + apply (rule_tac Q'="\_ s. weak_sch_act_wf (ksSchedulerAction s) s" + in hoare_post_imp, clarsimp) + apply (wp)+ + apply assumption + done + +crunch setup_reply_master, Tcb_A.restart, arch_post_modify_registers + for pspace_aligned[wp]: "pspace_aligned :: det_ext state \ _" + and pspace_distinct[wp]: "pspace_distinct :: det_ext state \ _" + (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)" - apply (simp add: Tcb_A.restart_def Thread_H.restart_def test_possible_switch_to_def - get_tcb_obj_ref_def) + "corres dc (einvs and tcb_at t) (invs' and tcb_at' t and ex_nonz_cap_to' t) + (Tcb_A.restart t) (ThreadDecls_H.restart t)" + apply (simp add: Tcb_A.restart_def Thread_H.restart_def) apply (simp add: isStopped_def2 liftM_def) apply (rule corres_guard_imp) apply (rule corres_split[OF getThreadState_corres]) - apply (rule corres_split[OF threadGet_corres[where r="(=)"]]) - apply (clarsimp simp: tcb_relation_def) - apply (rename_tac scOpt) - apply (rule corres_when2) - apply (simp add: idle_tsr runnable_tsr) - apply (rule corres_split_nor[OF cancel_ipc_corres]) - apply (rule corres_split_nor[OF setThreadState_corres]) - apply (clarsimp simp: thread_state_relation_def) - apply (simp only:) - apply (rule corres_split [OF ifCondRefillUnblockCheck_corres]) - apply (simp add: maybeM_when, fold dc_def) - apply (rule corres_split[OF corres_when2]) - apply clarsimp - apply (rule schedContextResume_corres) - apply (rule corres_split[OF isSchedulable_corres]) - apply (rule corres_when2 [OF _ possibleSwitchTo_corres]; (solves simp)?) - apply (wpsimp wp: is_schedulable_wp isSchedulable_wp)+ - apply (rule_tac Q'="\rv. invs and valid_sched_action and active_scs_valid and tcb_at t" - in hoare_strengthen_post) - apply (wpsimp wp: sched_context_resume_valid_sched_action) - apply fastforce - 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 (rule_tac Q'="\rv. invs and valid_ready_qs and valid_release_q - and current_time_bounded - and (\s. \scp. scOpt = Some scp \ sc_not_in_release_q scp s) - and active_scs_valid and valid_sched_action - and scheduler_act_not t and bound_sc_tcb_at ((=) scOpt) t" - in hoare_strengthen_post) - apply (wpsimp simp: if_cond_refill_unblock_check_def - wp: refill_unblock_check_valid_release_q - refill_unblock_check_active_scs_valid) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply (intro conjI; clarsimp) - apply (clarsimp simp: pred_tcb_at_tcb_at) - apply (subst (asm) sym_refs_bound_sc_tcb_iff_sc_tcb_sc_at[OF eq_commute refl]) - apply fastforce - apply (fastforce simp: sc_at_pred_n_def obj_at_def - sym_refs_bound_sc_tcb_iff_sc_tcb_sc_at[OF eq_commute refl]) - apply fastforce - apply (wpsimp simp: ifCondRefillUnblockCheck_def - wp: refillUnblockCheck_invs') - apply (rule_tac Q'="\rv. invs and valid_ready_qs and valid_release_q - and current_time_bounded - and (\s. \scp. scOpt = Some scp \ sc_not_in_release_q scp s) - and active_scs_valid and valid_sched_action - and scheduler_act_not t and bound_sc_tcb_at ((=) scOpt) t" - in hoare_strengthen_post) - apply (wpsimp wp: sts_invs_minor set_thread_state_valid_sched_action - set_thread_state_valid_ready_qs set_thread_state_valid_release_q) - apply (case_tac scOpt; clarsimp) - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def) - apply (rule context_conjI) - apply (clarsimp simp: valid_objs_def) - apply (drule_tac x=t in bspec, clarsimp simp: pred_tcb_at_def obj_at_def) - apply (clarsimp simp: valid_obj_def valid_tcb_def pred_tcb_at_def obj_at_def valid_bound_obj_def - dest!: sym[of "Some _"]) - apply (clarsimp simp: obj_at_def opt_map_red opt_pred_def is_sc_obj) - apply (rule_tac Q'="\rv. invs' and tcb_at' t" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: invs'_def valid_pspace'_def o_def) - apply (wpsimp wp: setThreadState_Restart_invs' hoare_drop_imps) - apply (rule_tac Q'="\rv. invs and valid_sched and valid_sched_action and tcb_at t - and current_time_bounded - and (\s. \scp. scOpt = Some scp \ sc_not_in_release_q scp s) - and fault_tcb_at ((=) None) t and bound_sc_tcb_at ((=) scOpt) t - and st_tcb_at (\st'. tcb_st_refs_of st' = {}) t - and scheduler_act_not t and ex_nonz_cap_to t" - 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" - in hoare_strengthen_post) - apply wpsimp - apply (fastforce simp: invs'_def sch_act_wf_weak valid_pspace'_def - elim: pred_tcb'_weakenE)[1] - apply (wpsimp wp: gts_wp gts_wp' thread_get_wp')+ - apply (prop_tac "scheduler_act_not t s") - apply (fastforce elim: valid_sched_scheduler_act_not simp: pred_tcb_at_def obj_at_def) - apply (clarsimp simp: pred_tcb_at_def obj_at_def is_tcb - valid_sched_def invs_def valid_state_def valid_pspace_def) - apply (drule sym_refs_inv_tcb_scps) - apply (prop_tac "heap_ref_eq scp t (tcb_scps_of s)") - apply (clarsimp simp: vs_all_heap_simps) - apply (clarsimp simp: heap_refs_inv_def2) - apply (clarsimp simp: vs_all_heap_simps) - apply (drule valid_release_q_not_in_release_q_not_runnable) - apply (fastforce simp: pred_tcb_at_def obj_at_def o_def) - apply clarsimp + apply (clarsimp simp add: runnable_tsr idle_tsr when_def) + apply (rule corres_split_nor[OF cancel_ipc_corres]) + apply (rule corres_split_nor[OF setupReplyMaster_corres]) + apply (rule corres_split_nor[OF setThreadState_corres], simp) + apply (rule corres_split[OF tcbSchedEnqueue_corres possibleSwitchTo_corres]) + apply (wp set_thread_state_runnable_weak_valid_sched_action sts_st_tcb_at' + sts_st_tcb' sts_valid_objs' + | clarsimp simp: valid_tcb_state'_def | strengthen valid_objs'_valid_tcbs')+ + apply (rule_tac Q'="\rv. valid_sched and cur_tcb and pspace_aligned and pspace_distinct" + in hoare_strengthen_post) + apply wp + apply (fastforce simp: valid_sched_def valid_sched_action_def) + apply (rule_tac Q'="\rv. invs' and ex_nonz_cap_to' t" in hoare_strengthen_post) + apply wp + apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak valid_pspace'_def + valid_tcb_state'_def) + apply wp+ + apply (simp add: valid_sched_def invs_def tcb_at_is_etcb_at invs_psp_aligned invs_distinct) apply clarsimp done -crunch schedContextResume, ifCondRefillUnblockCheck - for ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - and ksCurThread[wp]: "\s. P (ksCurThread 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'\" - unfolding restart_def - apply (simp add: isStopped_def2) - apply (wp setThreadState_nonqueued_state_update isSchedulable_wp - cancelIPC_simple setThreadState_st_tcb sch_act_simple_lift) - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated]) - apply wpsimp - apply (clarsimp simp: isSchedulable_bool_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 elim: isSchedulable_bool_runnableE) - apply (wpsimp wp: ifCondRefillUnblockCheck_invs' hoare_vcg_imp_lift') - apply (wpsimp wp: setThreadState_nonqueued_state_update setThreadState_st_tcb - hoare_vcg_if_lift2) - apply clarsimp - apply wp+ + apply (simp add: restart_def isStopped_def2) + apply (wp setThreadState_nonqueued_state_update + cancelIPC_simple setThreadState_st_tcb + | wp (once) sch_act_simple_lift)+ + apply (wp hoare_convert_imp) + apply (wp setThreadState_nonqueued_state_update + setThreadState_st_tcb) + apply (clarsimp) + apply (wp hoare_convert_imp)[1] + apply (clarsimp) + apply (wp)+ apply (clarsimp simp: comp_def) - apply (rule hoare_strengthen_post[OF gts_sp']) + apply (rule hoare_strengthen_post, rule gts_sp') prefer 2 apply assumption - apply (clarsimp simp: pred_tcb_at' invs'_def ct_in_state'_def) + apply (clarsimp simp: pred_tcb_at' invs'_def valid_state'_def + ct_in_state'_def) + apply (fastforce simp: pred_tcb_at'_def obj_at'_def) done -crunch "ThreadDecls_H.restart" - for tcb'[wp]: "tcb_at' t" - (wp: crunch_wps whileM_inv simp: crunch_simps) +lemma restart_tcb'[wp]: + "\tcb_at' t'\ ThreadDecls_H.restart t \\rv. tcb_at' t'\" + apply (simp add: restart_def isStopped_def2) + apply wpsimp + done lemma no_fail_setRegister: "no_fail \ (setRegister r v)" by (simp add: setRegister_def) @@ -283,14 +271,17 @@ lemma updateRestartPC_ex_nonz_cap_to'[wp]: apply (rule asUser_cap_to') done -crunch suspend - for cap_to': "ex_nonz_cap_to' p" - (wp: crunch_wps simp: crunch_simps) +lemma suspend_cap_to'[wp]: + "\ex_nonz_cap_to' p\ suspend t \\rv. ex_nonz_cap_to' p\" + apply (simp add: suspend_def) + apply (wp threadSet_cap_to' | simp)+ + done declare det_getRegister[simp] declare det_setRegister[simp] -lemma no_fail_getRegister[wp]: "no_fail \ (getRegister r)" +lemma + no_fail_getRegister[wp]: "no_fail \ (getRegister r)" by (simp add: getRegister_def) lemma invokeTCB_ReadRegisters_corres: @@ -314,12 +305,19 @@ lemma invokeTCB_ReadRegisters_corres: apply simp apply (rule no_fail_mapM) apply (simp add: no_fail_getRegister) - apply (wp suspend_invs)+ - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_idle_def + apply wp+ + apply (clarsimp simp: invs_def valid_state_def valid_pspace_def dest!: idle_no_ex_cap) - apply (clarsimp simp: invs'_def dest!: global'_no_ex_cap) + apply (clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) done +crunch asUser + for sch_act_simple[wp]: "sch_act_simple" + (rule: sch_act_simple_lift) + +lemma einvs_valid_etcbs: "einvs s \ valid_etcbs s" + by (clarsimp simp: valid_sched_def) + lemma asUser_postModifyRegisters_corres: "corres dc \ (tcb_at' t) (arch_post_modify_registers ct t) @@ -330,37 +328,49 @@ lemma asUser_postModifyRegisters_corres: 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) + 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 - and current_time_bounded) - (invs' and tcb_at' dest and ex_nonz_cap_to' dest) - (invoke_tcb (tcb_invocation.WriteRegisters dest resume values arch)) - (invokeTCB (tcbinvocation.WriteRegisters dest resume values arch'))" + "corres (dc \ (=)) (einvs and tcb_at dest and ex_nonz_cap_to dest) + (invs' and sch_act_simple and tcb_at' dest and ex_nonz_cap_to' dest) + (invoke_tcb (tcb_invocation.WriteRegisters dest resume values arch)) + (invokeTCB (tcbinvocation.WriteRegisters dest resume values arch'))" apply (simp add: invokeTCB_def performTransfer_def arch_get_sanitise_register_info_def frameRegisters_def gpRegisters_def getSanitiseRegisterInfo_def sanitiseRegister_def sanitise_register_def) - apply (rule corres_underlying_split[rotated 2, OF gets_sp getCurThread_sp]) - apply (corresKsimp corres: getCurThread_corres) - apply (rule corres_split_skip; (solves wpsimp)?) - apply (corresKsimp corres: asUser_corres - simp: zipWithM_mapM getRestartPC_def setNextPC_def - wp: no_fail_mapM no_fail_setRegister) - apply (rule corres_split_skip; (solves wpsimp)?) - apply (corresKsimp corres: asUser_postModifyRegisters_corres[simplified]) - apply (rule_tac Q="\_. einvs" and Q'="\_. invs'" in corres_underlying_split[rotated 2]) - 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 (corresKsimp corres: restart_corres) - apply (corresKsimp corres: rescheduleRequired_corres) - apply fastforce + apply (rule corres_guard_imp) + apply (rule corres_split[OF getCurThread_corres]) + apply (rule corres_split_nor) + apply (rule asUser_corres) + apply (simp add: zipWithM_mapM getRestartPC_def setNextPC_def) + apply (rule corres_Id, simp+) + apply (wpsimp wp: no_fail_mapM no_fail_setRegister)+ + apply (rule corres_split_nor[OF asUser_postModifyRegisters_corres[simplified]]) + apply (rule corres_split_nor[OF corres_when[OF refl restart_corres]]) + apply (rule corres_split_nor[OF corres_when[OF refl rescheduleRequired_corres]]) + apply (rule_tac P=\ and P'=\ in corres_inst) + apply simp + apply (wp+)[2] + apply ((wp hoare_weak_lift_imp restart_invs' + | strengthen valid_sched_weak_strg einvs_valid_etcbs + invs_weak_sch_act_wf + valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct + valid_sched_valid_queues valid_objs'_valid_tcbs' invs_valid_objs' + | clarsimp simp: invs_def valid_state_def valid_sched_def invs'_def valid_state'_def + dest!: global'_no_ex_cap idle_no_ex_cap)+)[2] + apply (rule_tac Q'="\_. einvs and tcb_at dest and ex_nonz_cap_to dest" in hoare_strengthen_post[rotated]) + apply (fastforce simp: invs_def valid_sched_weak_strg valid_sched_def valid_state_def dest!: idle_no_ex_cap) + prefer 2 + apply (rule_tac Q'="\_. invs' and tcb_at' dest and ex_nonz_cap_to' dest" in hoare_strengthen_post[rotated]) + apply (fastforce simp: sch_act_wf_weak invs'_def valid_state'_def dest!: global'_no_ex_cap) + apply (wp | clarsimp)+ done +crunch suspend + for it[wp]: "\s. P (ksIdleThread s)" + lemma tcbSchedDequeue_ResumeCurrentThread_imp_notct[wp]: "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ tcbSchedDequeue t @@ -375,23 +385,11 @@ lemma updateRestartPC_ResumeCurrentThread_imp_notct[wp]: apply (wp hoare_convert_imp) done -lemma schedContextCancelYieldTo_ResumeCurrentThread_imp_notct[wp]: - "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - schedContextCancelYieldTo t - \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - by (wp hoare_convert_imp) - -lemma tcbReleaseRemove_ResumeCurrentThread_imp_notct[wp]: - "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ - tcbReleaseRemove t - \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - by (wp hoare_convert_imp) - lemma suspend_ResumeCurrentThread_imp_notct[wp]: "\\s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\ suspend t \\rv s. ksSchedulerAction s = ResumeCurrentThread \ ksCurThread s \ t'\" - by (wpsimp simp: suspend_def wp_del: getThreadState_only_state_wp) + by (wpsimp simp: suspend_def) crunch restart, suspend for cur_tcb'[wp]: cur_tcb' @@ -400,7 +398,7 @@ crunch restart, suspend 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) + ex_nonz_cap_to dest) (invs' and sch_act_simple and tcb_at' dest and tcb_at' src and ex_nonz_cap_to' src and ex_nonz_cap_to' dest) (invoke_tcb (tcb_invocation.CopyRegisters dest src susp resume frames ints arch)) @@ -467,89 +465,75 @@ proof - apply (rule corres_when[OF refl]) apply (rule R[OF refl refl]) apply (simp add: gpRegisters_def) - apply (rule corres_split_eqr [OF getCurThread_corres]) + apply (rule corres_split_eqr[OF getCurThread_corres]) apply (rule corres_split_nor[OF asUser_postModifyRegisters_corres[simplified]]) apply (rule corres_split[OF corres_when[OF refl rescheduleRequired_corres]]) apply (rule_tac P=\ and P'=\ in corres_inst) apply simp apply (solves \wp hoare_weak_lift_imp\)+ - apply (rule_tac Q'="\_. einvs and tcb_at dest" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: invs_def valid_sched_weak_strg valid_sched_def valid_state_def - valid_pspace_def) + apply (rule_tac Q'="\_. einvs and tcb_at dest" in hoare_post_imp) + apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_sched_weak_strg valid_sched_def) prefer 2 - apply (rule_tac Q'="\_. invs' and tcb_at' dest" in hoare_strengthen_post[rotated]) - apply (clarsimp simp: invs'_def valid_pspace'_def) - apply ((wp mapM_x_wp' hoare_weak_lift_imp | simp)+)[4] - apply ((wp hoare_weak_lift_imp restart_invs' restart_valid_sched | wpc | clarsimp simp: if_apply_def2)+)[2] - apply (rule_tac Q'="\_. einvs and tcb_at dest and tcb_at src and ex_nonz_cap_to dest - and simple_sched_action and current_time_bounded" - in hoare_strengthen_post[rotated]) - 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' - suspend_valid_sched - | simp add: if_apply_def2)+ - apply (fastforce simp: invs_def valid_state_def valid_pspace_def valid_idle_def + apply (rule_tac Q'="\_. invs' and tcb_at' dest" in hoare_post_imp) + apply (fastforce simp: invs'_def valid_state'_def invs_weak_sch_act_wf cur_tcb'_def) + apply ((wp mapM_x_wp' hoare_weak_lift_imp | (simp add: cur_tcb'_def[symmetric])+)+)[8] + apply ((wp hoare_weak_lift_imp restart_invs' | wpc | clarsimp simp: if_apply_def2)+)[2] + apply (wp suspend_nonz_cap_to_tcb hoare_weak_lift_imp | simp add: if_apply_def2)+ + apply (fastforce simp: invs_def valid_state_def valid_pspace_def dest!: idle_no_ex_cap) - apply (fastforce simp: invs'_def dest!: global'_no_ex_cap) - done + by (fastforce simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) qed lemma readreg_invs': - "\invs' and tcb_at' src and ex_nonz_cap_to' src\ + "\invs' and sch_act_simple 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 + | clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap)+ +crunch getSanitiseRegisterInfo + for invs'[wp]: invs' + +crunch getSanitiseRegisterInfo + for ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' d" + and it'[wp]: "\s. P (ksIdleThread s)" + and tcb_at'[wp]: "tcb_at' a" + + lemma writereg_invs': - "\invs' and tcb_at' dest and ex_nonz_cap_to' dest\ + "\invs' and sch_act_simple and tcb_at' dest and ex_nonz_cap_to' dest\ invokeTCB (tcbinvocation.WriteRegisters dest resume values arch) \\rv. invs'\" by (simp add: invokeTCB_def performTransfer_def | wp restart_invs' | rule conjI | clarsimp - | clarsimp simp: invs'_def + | clarsimp simp: invs'_def valid_state'_def 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\ + "\invs' and sch_act_simple 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\" - 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) + supply if_weak_cong[cong] + apply (simp add: invokeTCB_def performTransfer_def if_apply_def2) + apply (wp mapM_x_wp' restart_invs' | simp)+ + apply (rule conjI) + apply (wp | clarsimp)+ + by (fastforce simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) lemma copyreg_invs': - "\invs' and tcb_at' src and + "\invs' and sch_act_simple 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) -lemma isRunnable_corres': - "t = t' \ - corres (\ts runn. runnable ts = runn) - (tcb_at t and pspace_aligned and pspace_distinct) \ - (get_thread_state t) (isRunnable t')" - apply (rule_tac Q="tcb_at' t" in corres_cross_add_guard) - apply (fastforce dest!: state_relationD elim!: tcb_at_cross) +lemma isRunnable_corres: + "corres (\ts runn. runnable ts = runn) + (tcb_at t and pspace_aligned and pspace_distinct) \ + (get_thread_state t) (isRunnable t)" apply (simp add: isRunnable_def) apply (subst bind_return[symmetric]) - apply (rule corres_guard_imp) - apply (rule corres_split[OF getThreadState_corres'], clarsimp) - apply (case_tac rv, clarsimp+) - apply (wp hoare_TrueI)+ - apply auto - done - -lemma isBlocked_corres: - "corres (\ts blocked. ipc_queued_thread_state ts = blocked) (tcb_at t) (tcb_at' t) - (get_thread_state t) (isBlocked t)" - apply (simp add: isBlocked_def) - apply (subst bind_return[symmetric]) apply (rule corres_guard_imp) apply (rule corres_split[OF getThreadState_corres]) apply (case_tac rv, clarsimp+) @@ -565,7 +549,7 @@ lemma tcbSchedDequeue_not_queued: 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)+ + apply (wp tg_sp' [where P=\, simplified] | simp)+ done lemma threadSet_ct_in_state': @@ -584,18 +568,16 @@ lemma tcbSchedDequeue_ct_in_state'[wp]: 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" +lemma valid_tcb'_tcbPriority_update: "\valid_tcb' tcb s; f (tcbPriority tcb) \ maxPriority \ \ valid_tcb' (tcbPriority_update f tcb) s" apply (simp add: valid_tcb'_def tcb_cte_cases_def) done lemma threadSet_valid_objs_tcbPriority_update: - "\valid_objs' and (\_. prio \ maxPriority)\ - threadSetPriority t prio + "\valid_objs' and (\_. x \ maxPriority)\ + threadSet (tcbPriority_update (\_. x)) t \\_. valid_objs'\" including no_pre - apply (simp add: threadSetPriority_def threadSet_def) + apply (simp add: threadSet_def) apply wp prefer 2 apply (rule getObject_tcb_sp) @@ -611,395 +593,69 @@ 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 only: tcbEPAppend_def tcbEPDequeue_def) - apply (wp tcbEPFindIndex_wp) - apply (rule conjI) - apply (clarsimp simp: valid_ntfn'_def split: option.split) - apply (clarsimp simp: valid_ntfn'_def simp del: imp_disjL dest!: findIndex_member) - apply (intro conjI; clarsimp?) - apply (fastforce dest: in_set_takeD in_set_dropD) - apply (fastforce dest: in_set_dropD) - apply (fastforce dest: in_set_dropD) - apply (fastforce dest: in_set_dropD) - apply (fastforce dest: in_set_takeD) - apply (clarsimp simp: Int_Un_distrib set_take_disj_set_drop_if_distinct) - apply (rule disjoint_subset_both[OF set_take_subset set_drop_subset]) - apply (simp add: Int_commute) - apply (fastforce dest: in_set_takeD) - apply (clarsimp simp: Int_Un_distrib set_take_disj_set_drop_if_distinct) - apply (fastforce dest: in_set_takeD in_set_dropD) - apply (clarsimp split: option.split) - apply (rename_tac ys zs i j tcb tcba tptr) - apply (case_tac ys; clarsimp) - done - -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_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_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 set_ep_minor_invs': - "\invs' and obj_at' (\ep. ep_q_refs_of' ep = ep_q_refs_of' val) ptr - 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) - done - -lemma getEpQueue_wp[wp]: "\\s. ep \ IdleEP \ P (epQueue ep) s\ getEpQueue ep \P\" - unfolding getEpQueue_def by wpsimp auto - -lemma updateEpQueue_triv: "ep \ IdleEP \ updateEpQueue ep (epQueue ep) = ep" - by (cases ep; clarsimp simp: updateEpQueue_def) +crunch tcbSchedDequeue + for cur[wp]: cur_tcb' -lemma updateEPQueue_IdleEP[simp]: "(updateEpQueue ep qs = IdleEP) = (ep = IdleEP)" - by (cases ep; simp add: updateEpQueue_def) +crunch tcbSchedDequeue + for st_tcb_at'[wp]: "\s. P (st_tcb_at' st tcbPtr s)" -lemma reorderEp_invs': - "\invs' and st_tcb_at' (\st. epBlocked st = Some ntfnPtr) tptr\ - reorderEp ntfnPtr tptr - \\rv. invs'\" - apply (simp only: reorderEp_def) - apply (subst bind_assoc[symmetric, where m="tcbEPDequeue tptr _"]) - apply (wp set_ep_minor_invs') - apply (simp add: pred_conj_def live_ntfn'_def) - apply (wpsimp wp: getEndpoint_wp tcbEPAppend_valid_ep' tcbEPAppend_rv_wf' tcbEPAppend_rv_wf'' - tcbEPDequeue_valid_ep' tcbEPDequeue_rv_wf' tcbEPDequeue_rv_wf'')+ - apply (frule ep_ko_at_valid_objs_valid_ep', fastforce) - apply (clarsimp simp: updateEpQueue_triv sym_refs_asrt_def valid_ep'_def pred_tcb_at'_def - obj_at'_def projectKO_eq projectKO_tcb projectKO_ep) - apply (frule_tac ko=obj and p=tptr in sym_refs_ko_atD'[rotated]) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb) - apply (case_tac "tcbState obj"; clarsimp simp: epBlocked_def split: ntfn.splits if_splits) - apply (auto simp: invs'_def if_live_then_nonz_cap'_def - refs_of_rev' get_refs_def ko_wp_at'_def obj_at'_def projectKO_eq projectKO_tcb - split: option.splits) - done - -lemma threadSetPriority_invs': - "\invs' and obj_at' (Not \ tcbQueued) t and K (p \ maxPriority)\ - threadSetPriority t p - \\_. invs'\" - apply (rule hoare_gen_asm) - apply (wpsimp wp: threadSet_invs_trivial simp: threadSetPriority_def) - by (fastforce simp: tcb_cte_cases_def invs'_def inQ_def obj_at'_def - valid_queues_def valid_queues_no_bitmap_def valid_release_queue'_def)+ - -crunch reorderEp, threadSetPriority - for st_tcb_at'[wp]: "st_tcb_at' P t" - (wp: crunch_wps threadSet_st_tcb_at2) - -lemma threadSetPriority_onRunning_invs': - "\\s. invs' s \ ready_qs_runnable s \ ct_active' s \ p \ maxPriority\ - threadSetPriority_onRunning t p - \\_. invs'\" - apply (simp only: threadSetPriority_onRunning_def) - apply (wpsimp wp: hoare_vcg_const_imp_lift rescheduleRequired_invs' hoare_vcg_all_lift) - apply (wpsimp wp: threadGet_wp threadSetPriority_invs' tcbSchedDequeue_not_queued)+ - apply (drule invs_queues') - apply (fastforce simp: ready_qs_runnable_def valid_queues'_def inQ_def - obj_at'_def ct_in_state'_def runnable_eq_active') - done - -lemma runnable'_case_thread_state_If: - "(case rv of Structures_H.thread_state.Running \ threadSetPriority_onRunning t x - | Structures_H.thread_state.Restart \ threadSetPriority_onRunning t x - | _ \ P) = - (if runnable' rv then threadSetPriority_onRunning t x else P)" - by (cases rv; clarsimp) - -lemma setP_invs': - "\\s. invs' s \ ready_qs_runnable s \ ct_active' s \ p \ maxPriority\ - setPriority t p - \\rv. invs'\" - apply (simp add: setPriority_def runnable'_case_thread_state_If) - apply (wpsimp wp: threadSetPriority_onRunning_invs' threadSetPriority_invs' reorderEp_invs' - reorderNtfn_invs' gts_wp' hoare_vcg_all_lift hoare_vcg_const_imp_lift) - apply (drule invs_queues') - apply (fastforce simp: ready_qs_runnable_def valid_queues'_def inQ_def - pred_tcb_at'_def obj_at'_def projectKO_eq) - done - -lemma reorder_ntfn_corres: - "ntfn = ntfn' \ corres dc (invs and st_tcb_at (\st. ntfn_blocked st = Some ntfn) t) - (invs' and st_tcb_at' (\st. ntfnBlocked st = Some ntfn) t) - (reorder_ntfn ntfn t) (reorderNtfn ntfn' t)" - apply add_sym_refs - apply (clarsimp simp: reorder_ntfn_def reorderNtfn_def) - apply (rule corres_stateAssert_assume) - apply (rule corres_guard_imp) - apply (rule corres_split) - apply (rule getNotification_corres) - apply (rule corres_assert_opt_assume_l) - apply (rule corres_assert_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 (rule tcb_ep_dequeue_rv_wf') - apply (rule tcbEPDequeue_rv_wf') - 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=ntfn']) - apply (clarsimp simp: valid_obj_def valid_ntfn_def) - apply (frule invs_sym_refs) - apply (drule_tac p=t in sym_refs_ko_atD[rotated]) - apply (simp add: obj_at_def) - apply clarsimp - apply (clarsimp simp: refs_of_rev obj_at_def get_ntfn_queue_def is_tcb_def is_ntfn_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=ntfn']) - 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 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) +lemma sp_corres2: + "corres dc + (valid_etcbs and weak_valid_sched_action and cur_tcb and tcb_at t + and valid_queues and pspace_aligned and pspace_distinct) + (tcb_at' t and (\s. weak_sch_act_wf (ksSchedulerAction s) s) + and valid_objs' and (\_. x \ maxPriority) and sym_heap_sched_pointers and valid_sched_pointers) + (set_priority t x) (setPriority t x)" + apply (simp add: setPriority_def set_priority_def thread_set_priority_def) + apply (rule stronger_corres_guard_imp) + apply (rule corres_split[OF tcbSchedDequeue_corres], simp) + apply (rule corres_split[OF ethread_set_corres], simp_all)[1] + apply (simp add: etcb_relation_def) + apply (rule corres_split[OF isRunnable_corres]) + apply (erule corres_when) + apply(rule corres_split[OF getCurThread_corres]) + apply (wp corres_if; clarsimp) + apply (rule rescheduleRequired_corres) + apply (rule possibleSwitchTo_corres) + apply ((clarsimp + | wp hoare_weak_lift_imp hoare_vcg_if_lift hoare_wp_combs gts_wp + isRunnable_wp)+)[4] + apply (wp hoare_vcg_imp_lift' hoare_vcg_if_lift hoare_vcg_all_lift + ethread_set_not_queued_valid_queues + | strengthen valid_queues_in_correct_ready_q valid_queues_ready_qs_distinct)+ + apply ((wp hoare_vcg_imp_lift' hoare_vcg_all_lift + isRunnable_wp threadSet_pred_tcb_no_state + threadSet_valid_objs_tcbPriority_update threadSet_sched_pointers + threadSet_valid_sched_pointers tcb_dequeue_not_queued tcbSchedDequeue_not_queued + threadSet_weak_sch_act_wf + | simp add: etcb_relation_def + | strengthen valid_objs'_valid_tcbs' + obj_at'_weakenE[where P="Not \ tcbQueued"] + | wps)+) + apply (force simp: valid_etcbs_def tcb_at_st_tcb_at[symmetric] state_relation_def + dest: pspace_relation_tcb_at intro: st_tcb_at_opeqI) + apply clarsimp done -lemma reorder_ep_corres: - "a = a' \ corres dc (invs and st_tcb_at (\st. ep_blocked st = Some a) t) - (invs' and st_tcb_at' (\st. epBlocked st = Some a) t) - (reorder_ep a t) (reorderEp a' t)" - apply add_sym_refs - apply (clarsimp simp: reorder_ep_def reorderEp_def) - apply (rule corres_stateAssert_assume) - apply (rule corres_guard_imp) - apply (rule corres_split) - apply (rule getEndpoint_corres) - apply (rename_tac ep ep') - apply (rule_tac F="ep \ Structures_A.endpoint.IdleEP" in corres_gen_asm) - apply (rule_tac r'="(=)" in corres_split) - apply (rule corres_trivial) - apply (case_tac ep; clarsimp simp: get_ep_queue_def getEpQueue_def ep_relation_def) - apply clarsimp - apply (rule corres_split) - apply (rule tcbEPDequeue_corres) - apply clarsimp - apply (rule corres_split) - apply clarsimp - apply (rule tcbEPAppend_corres) - apply (rule setEndpoint_corres) - apply (case_tac ep; clarsimp simp: ep_relation_def updateEpQueue_def) - apply wp - apply wp - apply (rule tcb_ep_dequeue_rv_wf') - apply (rule tcbEPDequeue_rv_wf') - apply clarsimp - apply (wpsimp simp: get_ep_queue_def) - apply (wpsimp simp: getEpQueue_def) - apply (wp get_simple_ko_wp) - apply (wp getEndpoint_wp) - apply (clarsimp simp: pred_tcb_at_def obj_at_def ep_blocked_def) - apply (frule invs_valid_objs) - apply (erule (1) valid_objsE[where x=t]) - apply (clarsimp simp: valid_obj_def valid_tcb_def ) - apply (prop_tac "ep_at a' s") - apply (clarsimp simp: valid_tcb_state_def split: Structures_A.thread_state.splits) - apply (clarsimp simp: obj_at_def) - apply (frule invs_valid_objs) - apply (erule (1) valid_objsE[where x=a']) - apply (clarsimp simp: valid_obj_def valid_ep_def) - apply (frule invs_sym_refs) - apply (drule_tac p=t in sym_refs_ko_atD[rotated]) - apply (simp add: obj_at_def) - apply (fastforce simp: obj_at_def is_tcb_def split: if_splits Structures_A.thread_state.splits) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def projectKO_eq projectKO_tcb epBlocked_def) - apply (frule invs_valid_objs') - apply (erule (1) valid_objsE'[where x=t]) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def) - apply (prop_tac "ep_at' a' s") - apply (clarsimp simp: valid_tcb_state'_def obj_at'_def projectKO_eq projectKO_ep - split: thread_state.splits) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_ep) - apply (frule invs_valid_objs') - apply (erule (1) valid_objsE'[where x=a']) - apply (clarsimp simp: valid_obj'_def valid_ep'_def) - apply (drule_tac p=t and ko=obj in sym_refs_ko_atD'[rotated]) - apply (clarsimp simp: obj_at'_def projectKO_eq projectKO_tcb) - apply (fastforce simp: refs_of_rev' ko_wp_at'_def obj_at'_def projectKO_eq projectKO_tcb - split: thread_state.splits if_splits endpoint.splits) - apply (clarsimp simp: sym_refs_asrt_def) - done - -lemma threadSetPriority_valid_tcbs'[wp]: - "\valid_tcbs' and K (prio \ maxPriority)\ - threadSet (tcbPriority_update (\_. prio)) t - \\_. valid_tcbs'\" - apply (wp threadSet_valid_tcbs') - apply (fastforce simp: valid_tcbs'_def valid_tcb'_def tcb_cte_cases_def - obj_at'_def projectKO_eq projectKO_tcb) - done - -lemma threadSetPriority_onRunning_corres: - "corres dc (valid_pspace and weak_valid_sched_action and active_scs_valid - and tcb_at 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)" - 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 corres_split) - apply (rule getCurThread_corres) - apply (rule corres_if) - apply clarsimp - apply (rule corres_split_nor) - apply (rule tcbSchedDequeue_corres) - apply (rule corres_split_nor) - apply (rule threadset_corresT) - apply (clarsimp simp: tcb_relation_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def) - apply (rule corres_split_nor) - apply (rule tcbSchedEnqueue_corres) - apply (rule rescheduleRequired_corres) - apply wp - apply wp - apply (wpsimp wp: thread_set_weak_valid_sched_action) - apply (wpsimp wp: threadSet_valid_queues_no_state threadSet_valid_queues'_no_state - threadSet_valid_release_queue threadSet_valid_release_queue') - apply wp - apply (rule_tac Q'="\_ s. tcb_at' t s \ valid_tcbs' s \ - valid_queues s \ valid_queues' s \ - valid_release_queue s \ valid_release_queue' s \ - (\d p. t \ set (ksReadyQueues s (d,p)))" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: valid_release_queue'_def obj_at'_def) - apply (wp tcbSchedDequeue_nonq tcbSchedDequeue_valid_queues hoare_vcg_all_lift) - apply (rule threadset_corresT) - apply (clarsimp simp: tcb_relation_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def) - apply wp - apply wp - apply (frule state_relation_pspace_relation) - apply (clarsimp simp: invs'_def valid_pspace_def pspace_relation_def - obj_at_def is_tcb_def obj_at'_def projectKO_eq projectKO_tcb) - apply (drule_tac x=t in bspec) - apply clarsimp - apply (clarsimp simp: other_obj_relation_def) - apply (drule state_relation_ready_queues_relation) - apply (fastforce simp: tcb_relation_def ready_queues_relation_def - obj_at'_def projectKO_eq projectKO_tcb inQ_def - valid_queues_def valid_queues'_def valid_queues_no_bitmap_def) - apply clarsimp - apply (frule invs'_valid_tcbs') - apply (clarsimp simp: invs'_def valid_tcbs'_def - valid_tcb'_def obj_at'_def projectKO_eq projectKO_tcb) - apply (wpsimp wp: thread_get_exs_valid simp: thread_get_def tcb_at_def)+ - done - -lemma setPriority: - "corres dc (einvs and tcb_at t) (invs' and tcb_at' t and (\_. prio \ maxPriority)) - (set_priority t prio) (setPriority t prio)" - apply (simp add: setPriority_def set_priority_def runnable'_case_thread_state_If) - apply (rule stronger_corres_guard_imp) - apply (rule_tac r'=thread_state_relation in corres_split) - apply (rule getThreadState_corres) - apply (rule corres_if) - apply (case_tac rv; simp add: thread_state_relation_def) - apply (rule threadSetPriority_onRunning_corres) - apply (rule corres_split) - apply (wpsimp wp: threadset_corresT simp: thread_set_priority_def threadSetPriority_def) - apply (clarsimp simp: tcb_relation_def) - apply (clarsimp simp: tcb_cap_cases_def) - apply (clarsimp simp: tcb_cte_cases_def) - apply (rule corres_split) - apply (clarsimp simp: maybeM_def case_option_If2 split del: if_split) - apply (rule corres_if) - apply (case_tac rv; simp add: ep_blocked_def epBlocked_def) - apply (rule reorder_ep_corres) - apply (case_tac rv; simp add: ep_blocked_def epBlocked_def) - apply clarsimp - apply (clarsimp simp: maybeM_def case_option_If2 split del: if_split) - apply (rule corres_if) - apply (case_tac rv; simp add: ntfn_blocked_def ntfnBlocked_def) - apply (rule reorder_ntfn_corres) - apply (case_tac rv; simp add: ntfn_blocked_def ntfnBlocked_def) - apply (rule corres_trivial, clarsimp) - apply (wpsimp wp: hoare_vcg_const_imp_lift simp: if_fun_split) - apply (wpsimp wp: hoare_vcg_const_imp_lift reorderEp_invs' simp: if_fun_split) - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_all_lift simp: if_fun_split) - apply (subgoal_tac "ep_blocked rv = epBlocked rv' \ ntfn_blocked rv = ntfnBlocked rv'") - apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_vcg_all_lift - threadSet_valid_objs_tcbPriority_update threadSetPriority_invs' - simp: if_fun_split) - apply (case_tac rv; simp add: ep_blocked_def epBlocked_def ntfn_blocked_def ntfnBlocked_def) - apply (wp gts_wp) - apply (wp gts_wp') - apply (fastforce simp: pred_tcb_at_def obj_at_def) - apply (drule ready_qs_runnable_cross; clarsimp simp: ready_qs_runnable_def) - apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) - apply (fastforce simp: invs'_def pred_tcb_at'_def obj_at'_def projectKO_eq projectKO_tcb - dest!: valid_queues_not_runnable_not_queued) +lemma setPriority_corres: + "corres dc + (einvs and tcb_at t) + (invs' and tcb_at' t and valid_objs' and (\_. x \ maxPriority)) + (set_priority t x) (setPriority t x)" + apply (rule corres_guard_imp) + apply (rule sp_corres2) + apply (simp add: valid_sched_def valid_sched_action_def invs_psp_aligned invs_distinct invs_def) + apply (clarsimp simp: invs'_def valid_state'_def sch_act_wf_weak) done -lemma setMCPriority_corres: "corres dc (tcb_at t) (tcb_at' t) (set_mcpriority t mcp) (setMCPriority t mcp)" +lemma setMCPriority_corres: + "corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ + (set_mcpriority t x) (setMCPriority t x)" apply (rule corres_guard_imp) apply (clarsimp simp: setMCPriority_def set_mcpriority_def) apply (rule threadset_corresT) - by (clarsimp simp: tcb_relation_def tcb_cap_cases_tcb_mcpriority tcb_cte_cases_def)+ + by (clarsimp simp: tcb_relation_def tcb_cap_cases_tcb_mcpriority + tcb_cte_cases_def cteSizeBits_def exst_same_def)+ definition "out_rel fn fn' v v' \ @@ -1011,15 +667,18 @@ definition lemma out_corresT: assumes x: "\tcb v. \(getF, setF)\ran tcb_cap_cases. getF (fn v tcb) = getF tcb" assumes y: "\v. \tcb. \(getF, setF)\ran tcb_cte_cases. getF (fn' v tcb) = getF tcb" + assumes sched_pointers: "\tcb v. tcbSchedPrev (fn' v tcb) = tcbSchedPrev tcb" + "\tcb v. tcbSchedNext (fn' v tcb) = tcbSchedNext tcb" + assumes flag: "\tcb v. tcbQueued (fn' v tcb) = tcbQueued tcb" + assumes e: "\tcb v. exst_same tcb (fn' v tcb)" shows "out_rel fn fn' v v' \ corres dc (tcb_at t and pspace_aligned and pspace_distinct) \ (option_update_thread t fn v) (case_option (return ()) (\x. threadSet (fn' x) t) v')" - apply (case_tac v, simp_all add: out_rel_def - option_update_thread_def) - apply (clarsimp simp add: threadset_corresT [OF _ x y]) + apply (case_tac v, simp_all add: out_rel_def option_update_thread_def) + apply (clarsimp simp: threadset_corresT [OF _ x y sched_pointers flag e]) done lemmas out_corres = out_corresT [OF _ all_tcbI, OF ball_tcb_cap_casesI ball_tcb_cte_casesI] @@ -1065,13 +724,15 @@ lemma setP_invs': crunch setPriority, setMCPriority 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) + (simp: crunch_simps) + +lemmas setPriority_typ_ats [wp] = typ_at_lifts [OF setPriority_typ_at'] + +crunch setPriority, setMCPriority + for valid_cap[wp]: "valid_cap' c" + (wp: getObject_inv_tcb) + -global_interpretation setPriority: typ_at_all_props' "setPriority t prio" - by typ_at_props' -global_interpretation setMCPriority: typ_at_all_props' "setMCPriority t prio" - by typ_at_props' definition newroot_rel :: "(cap \ cslot_ptr) option \ (capability \ machine_word) option \ bool" where @@ -1091,8 +752,6 @@ termination recursive apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) - lemma cte_map_tcb_0: "cte_map (t, tcb_cnode_index 0) = t" by (simp add: cte_map_def tcb_cnode_index_def) @@ -1116,7 +775,7 @@ lemma sameObject_corres2: apply (case_tac d'; simp) apply (rename_tac arch_cap) apply clarsimp - apply (case_tac d, (simp_all split: arch_cap.split)[13]) + apply (case_tac d, (simp_all split: arch_cap.split)[11]) apply (rename_tac arch_capa) apply (clarsimp simp add: ARM_H.sameObjectAs_def Let_def) apply (intro conjI impI) @@ -1165,24 +824,32 @@ defs lemma checkCapAt_cteInsert_corres: "cap_relation new_cap newCap \ corres dc (einvs and cte_wp_at (\c. c = cap.NullCap) (target, ref) - and cte_at slot and K (is_cnode_or_valid_arch new_cap \ is_ep_cap new_cap) - and K (is_pt_cap new_cap \ is_pd_cap new_cap \ cap_asid new_cap \ None) - and (\s. is_ep_cap new_cap - \ cte_wp_at (\c. c = new_cap \ c = cap.NullCap) src_slot s) - and cte_wp_at (\c. obj_refs c = obj_refs new_cap - \ table_cap_ref c = table_cap_ref new_cap \ - pt_pd_asid c = pt_pd_asid new_cap) src_slot) + and cte_at slot and K (is_cnode_or_valid_arch new_cap + \ (is_pt_cap new_cap \ is_pd_cap new_cap + \ cap_asid new_cap \ None)) + and cte_wp_at (\c. obj_refs c = obj_refs new_cap + \ table_cap_ref c = table_cap_ref new_cap \ + pt_pd_asid c = pt_pd_asid new_cap) src_slot) (invs' and cte_wp_at' (\cte. cteCap cte = NullCap) (cte_map (target, ref)) - and valid_cap' newCap) + and valid_cap' newCap) (check_cap_at new_cap src_slot (check_cap_at (cap.ThreadCap target) slot (cap_insert new_cap src_slot (target, ref)))) (checkCapAt newCap (cte_map src_slot) (checkCapAt (ThreadCap target) (cte_map slot) (assertDerived (cte_map src_slot) newCap (cteInsert newCap (cte_map src_slot) (cte_map (target, ref))))))" - (is "_ \ corres _ (?pre1) (?pre2) _ _") apply (rule corres_guard_imp) - apply (rule_tac P="?pre1" and P'="?pre2" in checkCapAt_corres, assumption) + apply (rule_tac P="cte_wp_at (\c. c = cap.NullCap) (target, ref) and + cte_at slot and + cte_wp_at (\c. obj_refs c = obj_refs new_cap + \ table_cap_ref c = table_cap_ref new_cap \ pt_pd_asid c = pt_pd_asid new_cap) src_slot + and einvs and K (is_cnode_or_valid_arch new_cap + \ (is_pt_cap new_cap \ is_pd_cap new_cap + \ cap_asid new_cap \ None))" + and + P'="cte_wp_at' (\c. cteCap c = NullCap) (cte_map (target, ref)) + and invs' and valid_cap' newCap" + in checkCapAt_corres, assumption) apply (rule checkCapAt_weak_corres, simp) apply (unfold assertDerived_def)[1] apply (rule corres_stateAssert_implied [where P'=\]) @@ -1208,9 +875,21 @@ lemma checkCapAt_cteInsert_corres: apply (clarsimp simp: cap_master_cap_simps is_cnode_or_valid_arch_def is_cap_simps is_valid_vtable_root_def dest!: cap_master_cap_eqDs) - apply (erule disjE) - apply (erule(1) checked_insert_is_derived) - apply (fastforce simp: is_derived_def is_cap_simps same_object_as_def cte_wp_at_caps_of_state)+ + apply (erule(1) checked_insert_is_derived) + apply simp + apply simp + apply fastforce + apply (clarsimp simp: cte_wp_at_caps_of_state) + apply clarsimp + apply fastforce + done + +lemma capBadgeNone_masters: + "capMasterCap cap = capMasterCap cap' + \ (capBadge cap = None) = (capBadge cap' = None)" + apply (rule master_eqI) + apply (auto simp add: capBadge_def capMasterCap_def isCap_simps + split: capability.split) done definition @@ -1230,6 +909,7 @@ lemmas pt_pd_asid'_simps [simp] = lemma checked_insert_tcb_invs'[wp]: "\invs' and cte_wp_at' (\cte. cteCap cte = NullCap) slot and valid_cap' new_cap + and K (capBadge new_cap = None) and K (slot \ cte_refs' (ThreadCap target) 0) and K (\ isReplyCap new_cap \ \ isIRQControlCap new_cap)\ checkCapAt new_cap src_slot @@ -1248,12 +928,13 @@ lemma checked_insert_tcb_invs'[wp]: ex_cte_cap_to'_cteCap) apply (erule sameObjectAsE)+ apply (clarsimp simp: badge_derived'_def) + apply (frule capBadgeNone_masters, simp) apply (rule conjI) apply (rule_tac x=slot' in exI) - apply fastforce + subgoal by fastforce apply (clarsimp simp: isCap_simps cteCaps_of_def) apply (erule(1) valid_irq_handlers_ctes_ofD) - apply (clarsimp simp: invs'_def) + apply (clarsimp simp: invs'_def valid_state'_def) done lemma checkCap_inv: @@ -1280,8 +961,11 @@ lemma isValidVTableRootD: "isValidVTableRoot cap \ isArchObjectCap cap \ isPageDirectoryCap (capCap cap) \ capPDMappedASID (capCap cap) \ None" - by (simp add: isValidVTableRoot_def isCap_simps - split: capability.split_asm arch_capability.split_asm option.split_asm) + by (simp add: isValidVTableRoot_def + ARM_H.isValidVTableRoot_def + isCap_simps + split: capability.split_asm arch_capability.split_asm + option.split_asm) lemma assertDerived_wp: "\P and (\s. cte_wp_at' (is_derived' (ctes_of s) slot cap o cteCap) slot s)\ f \Q\ \ @@ -1308,9 +992,7 @@ lemma setMCPriority_invs': unfolding setMCPriority_def apply (rule hoare_gen_asm) apply (rule hoare_pre) - apply (wp threadSet_invs_trivial, (clarsimp simp: inQ_def)+) - apply (clarsimp dest!: invs_valid_release_queue' simp: valid_release_queue'_def obj_at'_def) - done + by (wp threadSet_invs_trivial, (clarsimp simp: inQ_def)+) lemma valid_tcb'_tcbMCP_update: "\valid_tcb' tcb s \ f (tcbMCP tcb) \ maxPriority\ \ valid_tcb' (tcbMCP_update f tcb) s" @@ -1332,9 +1014,9 @@ lemma setMCPriority_valid_objs'[wp]: apply (simp add: projectKOs) apply (simp add: valid_obj'_def) apply (subgoal_tac "tcb_at' t s") - apply simp - apply (rule valid_tcb'_tcbMCP_update) - apply (fastforce simp: obj_at'_def)+ + apply simp + apply (rule valid_tcb'_tcbMCP_update) + apply (fastforce simp: obj_at'_def)+ done crunch setMCPriority @@ -1345,125 +1027,124 @@ abbreviation "valid_option_prio \ case_option True (\(p, auth). p definition valid_tcb_invocation :: "tcbinvocation \ bool" where "valid_tcb_invocation i \ case i of - ThreadControlSched _ _ _ p mcp _ \ valid_option_prio p \ valid_option_prio mcp + ThreadControl _ _ _ mcp p _ _ _ \ valid_option_prio p \ valid_option_prio mcp | _ \ True" lemma threadcontrol_corres_helper1: - "thread_set (tcb_ipc_buffer_update f) tptr \weak_valid_sched_action\" - by (wpsimp wp: thread_set_weak_valid_sched_action) - -lemma threadcontrol_corres_helper2: - "is_aligned a msg_align_bits \ - \invs' and (\s. sch_act_wf (ksSchedulerAction s) s) and tcb_at' t\ - threadSet (tcbIPCBuffer_update (\_. a)) t - \\_ s. Invariants_H.valid_queues s \ valid_queues' s \ weak_sch_act_wf (ksSchedulerAction s) s\" - by (wp threadSet_invs_trivial threadSet_sch_act - | strengthen invs_valid_queues' invs_queues sch_act_wf_weak - | clarsimp dest!: invs_valid_release_queue' simp: inQ_def valid_release_queue'_def obj_at'_def)+ + "\ einvs and simple_sched_action\ + thread_set (tcb_ipc_buffer_update f) a + \\x. weak_valid_sched_action and valid_etcbs\" + apply (rule hoare_pre) + apply (simp add: thread_set_def set_object_def get_object_def) + apply wp + apply (simp | intro impI | elim exE conjE)+ + apply (frule get_tcb_SomeD) + apply (erule ssubst) + apply (clarsimp simp add: weak_valid_sched_action_def valid_etcbs_2_def st_tcb_at_kh_def + get_tcb_def obj_at_kh_def obj_at_def is_etcb_at'_def valid_sched_def valid_sched_action_def) + apply (erule_tac x=a in allE)+ + apply (clarsimp simp: is_tcb_def) + done + +lemma thread_set_ipc_weak_valid_sched_action: + "\ einvs and simple_sched_action\ + thread_set (tcb_ipc_buffer_update f) a + \\x. weak_valid_sched_action\" + apply (rule hoare_pre) + apply (simp add: thread_set_def) + apply (wp set_object_wp) + apply (simp | intro impI | elim exE conjE)+ + apply (frule get_tcb_SomeD) + apply (erule ssubst) + apply (clarsimp simp add: weak_valid_sched_action_def valid_etcbs_2_def st_tcb_at_kh_def + get_tcb_def obj_at_kh_def obj_at_def is_etcb_at'_def valid_sched_def valid_sched_action_def) + done lemma threadcontrol_corres_helper3: - "\ einvs and simple_sched_action\ - check_cap_at aaa (ab, ba) (check_cap_at (cap.ThreadCap a) slot (cap_insert aaa (ab, ba) (a, tcb_cnode_index 4))) - \\_. weak_valid_sched_action \" - apply (wp check_cap_inv | simp add:)+ - by (clarsimp simp: weak_valid_sched_action_def get_tcb_def obj_at_def valid_sched_def - valid_sched_action_def) + "\einvs and simple_sched_action\ + check_cap_at cap p (check_cap_at (cap.ThreadCap cap') slot (cap_insert cap p (t, tcb_cnode_index 4))) + \\_ s. weak_valid_sched_action s \ in_correct_ready_q s \ ready_qs_distinct s \ valid_etcbs s + \ pspace_aligned s \ pspace_distinct s\" + apply (wpsimp + | strengthen valid_sched_valid_queues valid_queues_in_correct_ready_q + valid_sched_weak_strg[rule_format] valid_queues_ready_qs_distinct)+ + apply (wpsimp wp: check_cap_inv) + apply (fastforce simp: valid_sched_def) + done lemma threadcontrol_corres_helper4: "isArchObjectCap ac \ - \invs' and (\s. sch_act_wf (ksSchedulerAction s) s) - and cte_wp_at' (\cte. cteCap cte = capability.NullCap) (cte_map (a, tcb_cnode_index 4)) - and valid_cap' ac \ + \invs' and cte_wp_at' (\cte. cteCap cte = capability.NullCap) (cte_map (a, tcb_cnode_index 4)) + and valid_cap' ac\ checkCapAt ac (cte_map (ab, ba)) (checkCapAt (capability.ThreadCap a) (cte_map slot) (assertDerived (cte_map (ab, ba)) ac (cteInsert ac (cte_map (ab, ba)) (cte_map (a, tcb_cnode_index 4))))) - \\_. Invariants_H.valid_queues and valid_queues' and (\s. weak_sch_act_wf (ksSchedulerAction s) s)\" - apply (wpsimp | strengthen invs_valid_queues' invs_queues sch_act_wf_weak)+ - apply (wp checkCap_inv assertDerived_wp_weak)+ - apply (case_tac ac; - clarsimp simp: capBadge_def isArchObjectCap_def isNotificationCap_def isEndpointCap_def - isReplyCap_def isIRQControlCap_def tcb_cnode_index_def cte_map_def cte_wp_at'_def - cte_level_bits_def) - done + \\_ s. sym_heap_sched_pointers s \ valid_sched_pointers s \ valid_tcbs' s\" + apply (wpsimp wp: + | strengthen invs_sym_heap_sched_pointers invs_valid_sched_pointers + invs_valid_objs' valid_objs'_valid_tcbs')+ + by (case_tac ac; + clarsimp simp: capBadge_def isCap_simps tcb_cnode_index_def cte_map_def cte_wp_at'_def + cte_level_bits_def) lemma threadSet_invs_trivialT2: - assumes x: "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" - assumes z: "\tcb. tcbState (F tcb) = tcbState tcb" - assumes a: "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" - assumes s: "\tcb. tcbSchedContext (F tcb) = tcbSchedContext tcb" - assumes y: "\tcb. tcbYieldTo (F tcb) = tcbYieldTo tcb" - assumes v: "\tcb. tcbDomain tcb \ maxDomain \ tcbDomain (F tcb) \ maxDomain" - assumes u: "\tcb. tcbPriority tcb \ maxPriority \ tcbPriority (F tcb) \ maxPriority" - assumes b: "\tcb. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" + assumes + "\tcb. \(getF,setF) \ ran tcb_cte_cases. getF (F tcb) = getF tcb" + "\tcb. tcbState (F tcb) = tcbState tcb" + "\tcb. tcbBoundNotification (F tcb) = tcbBoundNotification tcb" + "\tcb. tcbSchedPrev (F tcb) = tcbSchedPrev tcb" + "\tcb. tcbSchedNext (F tcb) = tcbSchedNext tcb" + "\tcb. tcbQueued (F tcb) = tcbQueued tcb" + "\tcb. tcbDomain (F tcb) = tcbDomain tcb" + "\tcb. tcbPriority (F tcb) = tcbPriority tcb" + "\tcb. tcbDomain tcb \ maxDomain \ tcbDomain (F tcb) \ maxDomain" + "\tcb. tcbPriority tcb \ maxPriority \ tcbPriority (F tcb) \ maxPriority" + "\tcb. tcbMCP tcb \ maxPriority \ tcbMCP (F tcb) \ maxPriority" shows - "\\s. invs' s - \ (\tcb. is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits) - \ tcb_at' t s - \ (\d p. (\tcb. inQ d p tcb \ \ inQ d p (F tcb)) \ t \ set (ksReadyQueues s (d, p))) - \ (\ko d p. ko_at' ko t s \ inQ d p (F ko) \ \ inQ d p ko \ t \ set (ksReadyQueues s (d, p))) - \ ((\tcb. tcbInReleaseQueue tcb \ \ tcbInReleaseQueue (F tcb)) \ t \ set (ksReleaseQueue s)) - \ (\ko. ko_at' ko t s \ tcbInReleaseQueue (F ko) \ \ tcbInReleaseQueue ko \ t \ set (ksReleaseQueue s)) - \ ((\tcb. \ tcbQueued tcb \ tcbQueued (F tcb)) \ ex_nonz_cap_to' t s)\ - threadSet F t - \\rv. invs'\" -proof - - note threadSet_sch_actT_P[where P=False, simplified] - have r: "\tcb. tcb_st_refs_of' (tcbState (F tcb)) = tcb_st_refs_of' (tcbState tcb) \ - valid_tcb_state' (tcbState (F tcb)) = valid_tcb_state' (tcbState tcb)" - by (auto simp: z) - show ?thesis - apply (simp add: invs'_def split del: if_split) - apply (rule hoare_pre) - apply (rule hoare_gen_asm [where P="(\tcb. is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits)"]) - apply (wp x v u b - threadSet_valid_pspace'T - threadSet_sch_actT_P[where P=False, simplified] - threadSet_valid_queues threadSet_valid_release_queue - threadSet_state_refs_of'T[where f'=id] - threadSet_iflive'T - threadSet_ifunsafe'T - threadSet_idle'T - threadSet_global_refsT - irqs_masked_lift - valid_irq_node_lift - valid_irq_handlers_lift'' - threadSet_ctes_ofT - threadSet_not_inQ - threadSet_ct_idle_or_in_cur_domain' - threadSet_valid_dom_schedule' - threadSet_valid_queues' threadSet_valid_release_queue' - threadSet_cur - untyped_ranges_zero_lift - | clarsimp simp: r y z a s cteCaps_of_def | rule refl)+ - apply (clarsimp simp: obj_at'_def projectKOs pred_tcb_at'_def valid_release_queue'_def) - apply (clarsimp simp: cur_tcb'_def valid_irq_node'_def valid_queues'_def o_def) - by (intro conjI; fastforce) -qed - -lemma threadSet_valid_queues'_no_state2: - "\ \tcb. tcbQueued tcb = tcbQueued (f tcb); - \tcb. tcbState tcb = tcbState (f tcb); - \tcb. tcbPriority tcb = tcbPriority (f tcb); - \tcb. tcbDomain tcb = tcbDomain (f tcb) \ - \ \valid_queues'\ threadSet f t \\_. valid_queues'\" - apply (simp add: valid_queues'_def threadSet_def obj_at'_real_def - split del: if_split) - apply (simp only: imp_conv_disj) - apply (wp hoare_vcg_all_lift hoare_vcg_disj_lift) - apply (wp setObject_ko_wp_at | simp add: objBits_simps')+ - apply (wp getObject_tcb_wp updateObject_default_inv - | simp split del: if_split)+ - apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs - objBits_simps addToQs_def - split del: if_split cong: if_cong) - apply (fastforce simp: projectKOs inQ_def split: if_split_asm) - done + "\\s. invs' s \ (\tcb. is_aligned (tcbIPCBuffer (F tcb)) msg_align_bits)\ + threadSet F t + \\_. invs'\" + apply (simp add: invs'_def valid_state'_def) + 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 + valid_irq_handlers_lift'' + threadSet_ctes_ofT + threadSet_valid_dom_schedule' + untyped_ranges_zero_lift + sym_heap_sched_pointers_lift threadSet_valid_sched_pointers + threadSet_tcbSchedPrevs_of threadSet_tcbSchedNexts_of + threadSet_sch_actT_P[where P=False, simplified] + threadSet_state_refs_of'T[where f'=id] + threadSet_idle'T + threadSet_not_inQ + threadSet_ct_idle_or_in_cur_domain' + threadSet_cur + | clarsimp simp: assms cteCaps_of_def | rule refl)+ + apply (clarsimp simp: o_def) + by (auto simp: obj_at'_def) lemma getThreadBufferSlot_dom_tcb_cte_cases: "\\\ getThreadBufferSlot a \\rv s. rv \ (+) a ` dom tcb_cte_cases\" by (wpsimp simp: tcb_cte_cases_def getThreadBufferSlot_def locateSlot_conv cte_level_bits_def tcbIPCBufferSlot_def) +lemma tcb_at'_cteInsert[wp]: + "\\s. tcb_at' (ksCurThread s) s\ cteInsert t x y \\_ s. tcb_at' (ksCurThread s) s\" + by (rule hoare_weaken_pre, wps cteInsert_ct, wp, simp) + +lemma tcb_at'_asUser[wp]: + "\\s. tcb_at' (ksCurThread s) s\ asUser a (setTCBIPCBuffer b) \\_ s. tcb_at' (ksCurThread s) s\" + by (rule hoare_weaken_pre, wps asUser_typ_ats(1), wp, simp) + +lemma tcb_at'_threadSet[wp]: + "\\s. tcb_at' (ksCurThread s) s\ threadSet (tcbIPCBuffer_update (\_. b)) a \\_ s. tcb_at' (ksCurThread s) s\" + by (rule hoare_weaken_pre, wps threadSet_tcb', wp, simp) + lemma cteDelete_it [wp]: "\\s. P (ksIdleThread s)\ cteDelete slot e \\_ s. P (ksIdleThread s)\" by (rule cteDelete_preservation) (wp | clarsimp)+ @@ -1476,12 +1157,489 @@ lemma valid_tcb_ipc_buffer_update: \ (\tcb. valid_tcb' tcb s \ valid_tcb' (tcbIPCBuffer_update (\_. buf) tcb) s)" by (simp add: valid_tcb'_def tcb_cte_cases_def) +lemma threadSet_invs_tcbIPCBuffer_update: + "\\s. invs' s \ (\tcb. is_aligned (tcbIPCBuffer (tcbIPCBuffer_update f tcb)) msg_align_bits)\ + threadSet (tcbIPCBuffer_update f) t + \\_. invs'\" + by (wp threadSet_invs_trivialT2; simp add: tcb_cte_cases_def cteSizeBits_def) + +lemma transferCaps_corres: + assumes x: "newroot_rel e e'" + assumes y: "newroot_rel f f'" + assumes z: "(case g of None \ g' = None + | Some (vptr, g'') \ \g'''. g' = Some (vptr, g''') + \ newroot_rel g'' g''')" + assumes sl: "{e, f, option_map undefined g} \ {None} \ sl' = cte_map slot" + shows + "corres (dc \ (=)) + (einvs and simple_sched_action and tcb_at a and + (\s. {e, f, option_map undefined g} \ {None} \ cte_at slot s) and + case_option \ (valid_cap o fst) e and + case_option \ (cte_at o snd) e and + case_option \ (no_cap_to_obj_dr_emp o fst) e and + K (case_option True (is_cnode_cap o fst) e) and + case_option \ (valid_cap o fst) f and + case_option \ (cte_at o snd) f and + case_option \ (no_cap_to_obj_dr_emp o fst) f and + K (case_option True (is_valid_vtable_root o fst) f) + and case_option \ (case_option \ (cte_at o snd) o snd) g + and case_option \ (case_option \ (no_cap_to_obj_dr_emp o fst) o snd) g + and case_option \ (case_option \ (valid_cap o fst) o snd) g + and K (case_option True ((\v. is_aligned v msg_align_bits) o fst) g) + and K (case_option True (\v. case_option True ((swp valid_ipc_buffer_cap (fst v) + and is_arch_cap and is_cnode_or_valid_arch) o fst) (snd v)) g) + and (\s. case_option True (\(pr, auth). mcpriority_tcb_at (\m. pr \ m) auth s) p_auth) \ \only set prio \ mcp\ + and (\s. case_option True (\(mcp, auth). mcpriority_tcb_at (\m. mcp \ m) auth s) mcp_auth) \ \only set mcp \ prev_mcp\) + (invs' and sch_act_simple and case_option \ (valid_cap' o fst) e' and + (\s. {e', f', option_map undefined g'} \ {None} \ cte_at' (cte_map slot) s) and + K (case_option True (isCNodeCap o fst) e') and + case_option \ (valid_cap' o fst) f' and + K (case_option True (isValidVTableRoot o fst) f') and + K (case_option True ((\v. is_aligned v msg_align_bits) o fst) g') and + K (case_option True (case_option True (isArchObjectCap o fst) o snd) g') and + case_option \ (case_option \ (valid_cap' o fst) o snd) g' and + tcb_at' a and ex_nonz_cap_to' a and K (valid_option_prio p_auth \ valid_option_prio mcp_auth) and + (\s. case_option True (\(pr, auth). mcpriority_tcb_at' ((\) pr) auth s) p_auth) and + (\s. case_option True (\(m, auth). mcpriority_tcb_at' ((\) m) auth s) mcp_auth)) + (invoke_tcb (tcb_invocation.ThreadControl a slot (option_map to_bl b') mcp_auth p_auth e f g)) + (invokeTCB (tcbinvocation.ThreadControl a sl' b' mcp_auth p_auth e' f' g'))" +proof - + have P: "\t v. corres dc + (tcb_at t and pspace_aligned and pspace_distinct) + \ + (option_update_thread t (tcb_fault_handler_update o (%x _. x)) + (option_map to_bl v)) + (case v of None \ return () + | Some x \ threadSet (tcbFaultHandler_update (%_. x)) t)" + apply (rule out_corres, simp_all add: exst_same_def) + apply (case_tac v, simp_all add: out_rel_def) + apply (safe, case_tac tcb', simp add: tcb_relation_def split: option.split) + done + have R: "\t v. corres dc + (tcb_at t and pspace_aligned and pspace_distinct) + \ + (option_update_thread t (tcb_ipc_buffer_update o (%x _. x)) v) + (case v of None \ return () + | Some x \ threadSet (tcbIPCBuffer_update (%_. x)) t)" + apply (rule out_corres, simp_all add: exst_same_def) + apply (case_tac v, simp_all add: out_rel_def) + apply (safe, case_tac tcb', simp add: tcb_relation_def) + done + have S: "\t x. corres dc (einvs and tcb_at t) (invs' and tcb_at' t and valid_objs' and K (valid_option_prio p_auth)) + (case_option (return ()) (\(p, auth). set_priority t p) p_auth) + (case_option (return ()) (\p'. setPriority t (fst p')) p_auth)" + apply (case_tac p_auth; clarsimp simp: setPriority_corres) + done + have S': "\t x. corres dc + (tcb_at t and pspace_aligned and pspace_distinct) + \ + (case_option (return ()) (\(mcp, auth). set_mcpriority t mcp) mcp_auth) + (case_option (return ()) (\mcp'. setMCPriority t (fst mcp')) mcp_auth)" + apply(case_tac mcp_auth; clarsimp simp: setMCPriority_corres) + done + have T: "\x x' ref getfn target. + \ newroot_rel x x'; getfn = return (cte_map (target, ref)); + x \ None \ {e, f, option_map undefined g} \ {None} \ \ + corres (dc \ dc) + + (einvs and simple_sched_action and cte_at (target, ref) and emptyable (target, ref) and + (\s. \(sl, c) \ (case x of None \ {} | Some (c, sl) \ {(sl, c), (slot, c)}). + cte_at sl s \ no_cap_to_obj_dr_emp c s \ valid_cap c s) + and K (case x of None \ True + | Some (c, sl) \ is_cnode_or_valid_arch c)) + (invs' and sch_act_simple and cte_at' (cte_map (target, ref)) and + (\s. \cp \ (case x' of None \ {} | Some (c, sl) \ {c}). s \' cp)) + (case x of None \ returnOk () + | Some pr \ case_prod (\new_cap src_slot. + doE cap_delete (target, ref); + liftE $ check_cap_at new_cap src_slot $ + check_cap_at (cap.ThreadCap target) slot $ + cap_insert new_cap src_slot (target, ref) + odE) pr) + (case x' of + None \ returnOk () + | Some pr \ (\(newCap, srcSlot). + do slot \ getfn; + doE uu \ cteDelete slot True; + liftE (checkCapAt newCap srcSlot + (checkCapAt (capability.ThreadCap target) sl' + (assertDerived srcSlot newCap (cteInsert newCap srcSlot slot)))) + odE + od) pr)" + apply (case_tac "x = None") + apply (simp add: newroot_rel_def returnOk_def) + apply (drule(1) mp, drule mp [OF sl]) + apply (clarsimp simp add: newroot_rel_def returnOk_def split_def) + apply (rule corres_gen_asm) + apply (rule corres_guard_imp) + apply (rule corres_split_norE[OF cteDelete_corres]) + apply (simp del: dc_simp) + apply (erule checkCapAt_cteInsert_corres) + apply (fold validE_R_def) + apply (wp cap_delete_deletes cap_delete_cte_at cap_delete_valid_cap + | strengthen use_no_cap_to_obj_asid_strg)+ + apply (wp cteDelete_invs' cteDelete_deletes) + apply (clarsimp dest!: is_cnode_or_valid_arch_cap_asid) + apply clarsimp + done + have U2: "getThreadBufferSlot a = return (cte_map (a, tcb_cnode_index 4))" + by (simp add: getThreadBufferSlot_def locateSlot_conv + cte_map_def tcb_cnode_index_def tcbIPCBufferSlot_def + cte_level_bits_def) + have T2: "corres (dc \ dc) + (einvs and simple_sched_action and tcb_at a and + (\s. \(sl, c) \ (case g of None \ {} | Some (x, v) \ {(slot, cap.NullCap)} \ + (case v of None \ {} | Some (c, sl) \ {(sl, c), (slot, c)})). + cte_at sl s \ no_cap_to_obj_dr_emp c s \ valid_cap c s) + and K (case g of None \ True | Some (x, v) \ (case v of + None \ True | Some (c, sl) \ is_cnode_or_valid_arch c + \ is_arch_cap c + \ valid_ipc_buffer_cap c x + \ is_aligned x msg_align_bits))) + (invs' and sch_act_simple and tcb_at' a and + (\s. \cp \ (case g' of None \ {} | Some (x, v) \ (case v of + None \ {} | Some (c, sl) \ {c})). s \' cp) and + K (case g' of None \ True | Some (x, v) \ is_aligned x msg_align_bits + \ (case v of None \ True | Some (ac, _) \ isArchObjectCap ac)) ) + (case_option (returnOk ()) + (case_prod + (\ptr frame. + doE cap_delete (a, tcb_cnode_index 4); + do y \ thread_set (tcb_ipc_buffer_update (\_. ptr)) a; + y \ case_option (return ()) + (case_prod + (\new_cap src_slot. + check_cap_at new_cap src_slot $ + check_cap_at (cap.ThreadCap a) slot $ + cap_insert new_cap src_slot (a, tcb_cnode_index 4))) + frame; + cur \ gets cur_thread; + liftE $ when (cur = a) (reschedule_required) + od + odE)) + g) + (case_option (returnOk ()) + (\(ptr, frame). + do bufferSlot \ getThreadBufferSlot a; + doE y \ cteDelete bufferSlot True; + do y \ threadSet (tcbIPCBuffer_update (\_. ptr)) a; + y \ (case_option (return ()) + (case_prod + (\newCap srcSlot. + checkCapAt newCap srcSlot $ + checkCapAt + (capability.ThreadCap a) + sl' $ + assertDerived srcSlot newCap $ + cteInsert newCap srcSlot bufferSlot)) + frame); + cur \ getCurThread; + liftE $ when (cur = a) rescheduleRequired + od odE od) + g')" (is "corres _ ?T2_pre ?T2_pre' _ _") + using z sl + apply - + apply (rule corres_guard_imp[where P=P and P'=P' + and Q="P and cte_at (a, tcb_cnode_index 4)" + and Q'="P' and cte_at' (cte_map (a, cap))" for P P' a cap]) + apply (cases g) + apply (simp, simp add: returnOk_def) + apply (clarsimp simp: liftME_def[symmetric] U2 liftE_bindE) + apply (case_tac b, simp_all add: newroot_rel_def) + apply (rule corres_guard_imp) + apply (rule corres_split_norE) + apply (rule cteDelete_corres) + apply (rule_tac F="is_aligned aa msg_align_bits" in corres_gen_asm2) + apply (rule corres_split_nor) + apply (rule threadset_corres, + (simp add: tcb_relation_def), (simp add: exst_same_def)+)[1] + apply (rule corres_split[OF getCurThread_corres], clarsimp) + apply (rule corres_when[OF refl rescheduleRequired_corres]) + apply (wpsimp wp: gct_wp)+ + apply (strengthen valid_queues_ready_qs_distinct) + apply (wpsimp wp: thread_set_ipc_weak_valid_sched_action thread_set_valid_queues + hoare_drop_imp) + apply clarsimp + apply (strengthen valid_objs'_valid_tcbs' invs_valid_objs')+ + apply (wpsimp wp: threadSet_sched_pointers threadSet_valid_sched_pointers hoare_drop_imp + threadSet_invs_tcbIPCBuffer_update) + apply (clarsimp simp: pred_conj_def) + apply (strengthen einvs_valid_etcbs valid_queues_in_correct_ready_q + valid_sched_valid_queues invs_psp_aligned invs_distinct)+ + apply wp + apply (clarsimp simp: pred_conj_def) + apply (strengthen invs_sym_heap_sched_pointers invs_valid_sched_pointers + valid_objs'_valid_tcbs' invs_valid_objs') + apply (wpsimp wp: cteDelete_invs' hoare_vcg_conj_lift) + apply (fastforce simp: emptyable_def) + apply fastforce + apply clarsimp + apply (rule corres_guard_imp) + apply (rule corres_split_norE[OF cteDelete_corres]) + apply (rule_tac F="is_aligned aa msg_align_bits" + in corres_gen_asm) + apply (rule_tac F="isArchObjectCap ac" in corres_gen_asm2) + apply (rule corres_split_nor) + apply (rule threadset_corres, + simp add: tcb_relation_def, (simp add: exst_same_def)+) + apply (rule corres_split) + apply (erule checkCapAt_cteInsert_corres) + apply (rule corres_split[OF getCurThread_corres], clarsimp) + apply (rule corres_when[OF refl rescheduleRequired_corres]) + apply (wp gct_wp)+ + apply (wp hoare_drop_imp threadcontrol_corres_helper3)[1] + apply (wp hoare_drop_imp threadcontrol_corres_helper4)[1] + apply (wp thread_set_tcb_ipc_buffer_cap_cleared_invs + thread_set_cte_wp_at_trivial thread_set_not_state_valid_sched + | simp add: ran_tcb_cap_cases)+ + apply (wp threadSet_invs_trivial + threadSet_cte_wp_at' | simp)+ + apply (wp cap_delete_deletes cap_delete_cte_at + cap_delete_valid_cap cteDelete_deletes + cteDelete_invs' + | strengthen use_no_cap_to_obj_asid_strg invs_psp_aligned invs_distinct + | clarsimp simp: inQ_def)+ + apply (clarsimp simp: cte_wp_at_caps_of_state + dest!: is_cnode_or_valid_arch_cap_asid) + apply (fastforce simp: emptyable_def) + apply (clarsimp simp: inQ_def) + apply (clarsimp simp: obj_at_def is_tcb) + apply (rule cte_wp_at_tcbI, simp, fastforce, simp) + apply (clarsimp simp: cte_map_def tcb_cnode_index_def obj_at'_def projectKOs objBits_simps) + apply (erule(2) cte_wp_at_tcbI', fastforce simp: objBits_defs cte_level_bits_def, simp) + done + have U: "getThreadCSpaceRoot a = return (cte_map (a, tcb_cnode_index 0))" + apply (clarsimp simp add: getThreadCSpaceRoot) + apply (simp add: cte_map_def tcb_cnode_index_def + cte_level_bits_def word_bits_def) + done + have V: "getThreadVSpaceRoot a = return (cte_map (a, tcb_cnode_index 1))" + apply (clarsimp simp add: getThreadVSpaceRoot) + apply (simp add: cte_map_def tcb_cnode_index_def to_bl_1 objBits_defs + cte_level_bits_def word_bits_def) + done + have X: "\x P Q R M. (\y. x = Some y \ \P y\ M y \Q\,\R\) + \ \case_option (Q ()) P x\ case_option (returnOk ()) M x \Q\,\R\" + by (case_tac x, simp_all, wp) + have Y: "\x P Q M. (\y. x = Some y \ \P y\ M y \Q\,-) + \ \case_option (Q ()) P x\ case_option (returnOk ()) M x \Q\,-" + by (case_tac x, simp_all, wp) + have Z: "\P f R Q x. \P\ f \\rv. Q and R\ \ \P\ f \\rv. case_option Q (\y. R) x\" + apply (rule hoare_post_imp) + defer + apply assumption + apply (case_tac x, simp_all) + done + have A: "\x P Q M. (\y. x = Some y \ \P y\ M y \Q\) + \ \case_option (Q ()) P x\ case_option (return ()) M x \Q\" + by (case_tac x, simp_all, wp) + have B: "\t v. \invs' and tcb_at' t\ threadSet (tcbFaultHandler_update v) t \\rv. invs'\" + by (wp threadSet_invs_trivial | clarsimp simp: inQ_def)+ + note stuff = Z B out_invs_trivial hoare_case_option_wp + hoare_vcg_const_Ball_lift hoare_vcg_const_Ball_liftE_R + cap_delete_deletes cap_delete_valid_cap out_valid_objs + cap_insert_objs + cteDelete_deletes cteDelete_sch_act_simple + out_valid_cap out_cte_at out_tcb_valid out_emptyable + CSpaceInv_AI.cap_insert_valid_cap cap_insert_cte_at cap_delete_cte_at + cap_delete_tcb cteDelete_invs' checkCap_inv [where P="valid_cap' c0" for c0] + check_cap_inv[where P="tcb_at p0" for p0] checkCap_inv [where P="tcb_at' p0" for p0] + check_cap_inv[where P="cte_at p0" for p0] checkCap_inv [where P="cte_at' p0" for p0] + check_cap_inv[where P="valid_cap c" for c] checkCap_inv [where P="valid_cap' c" for c] + check_cap_inv[where P="tcb_cap_valid c p1" for c p1] + check_cap_inv[where P=valid_sched] + check_cap_inv[where P=simple_sched_action] + checkCap_inv [where P=sch_act_simple] + out_no_cap_to_trivial [OF ball_tcb_cap_casesI] + checked_insert_no_cap_to + note if_cong [cong] option.case_cong [cong] + \ \This proof is quite fragile and was written when bind_wp was added to the wp set later + in the theory dependencies, and so was matched with before alternatives. We re-add it here to + create a similar environment and avoid needing to rework the proof.\ + note bind_wp[wp] + show ?thesis + apply (simp add: invokeTCB_def liftE_bindE) + apply (simp only: eq_commute[where a= "a"]) + apply (rule corres_guard_imp) + apply (rule corres_split_nor[OF P]) + apply (rule corres_split_nor[OF S', simplified]) + apply (rule corres_split_norE[OF T [OF x U], simplified]) + apply (rule corres_split_norE[OF T [OF y V], simplified]) + apply (rule corres_split_norE) + apply (rule T2[simplified]) + apply (rule corres_split_nor[OF S, simplified]) + apply (rule corres_returnOkTT, simp) + apply wp + apply wp + apply (wpsimp wp: hoare_vcg_const_imp_liftE_R hoare_vcg_const_imp_lift + hoare_vcg_all_liftE_R hoare_vcg_all_lift + as_user_invs thread_set_ipc_tcb_cap_valid + thread_set_tcb_ipc_buffer_cap_cleared_invs + thread_set_cte_wp_at_trivial + thread_set_valid_cap + reschedule_preserves_valid_sched + check_cap_inv[where P=valid_sched] (* from stuff *) + check_cap_inv[where P="tcb_at p0" for p0] + thread_set_not_state_valid_sched + check_cap_inv[where P=simple_sched_action] + cap_delete_deletes hoare_drop_imps + cap_delete_valid_cap + simp: ran_tcb_cap_cases + | strengthen simple_sched_action_sched_act_not)+ + apply (strengthen use_no_cap_to_obj_asid_strg) + apply (wpsimp wp: cap_delete_cte_at cap_delete_valid_cap) + apply (wpsimp wp: hoare_vcg_const_imp_lift hoare_drop_imps hoare_vcg_all_lift + threadSet_invs_tcbIPCBuffer_update threadSet_cte_wp_at' + | strengthen simple_sched_action_sched_act_not)+ + apply ((wpsimp wp: stuff hoare_vcg_all_liftE_R hoare_vcg_all_lift + hoare_vcg_const_imp_liftE_R hoare_vcg_const_imp_lift + threadSet_valid_objs' thread_set_not_state_valid_sched + thread_set_tcb_ipc_buffer_cap_cleared_invs thread_set_cte_wp_at_trivial + thread_set_no_cap_to_trivial getThreadBufferSlot_dom_tcb_cte_cases + assertDerived_wp_weak threadSet_cap_to' out_pred_tcb_at_preserved + checkCap_wp assertDerived_wp_weak cap_insert_objs' + | simp add: ran_tcb_cap_cases split_def U V + emptyable_def + | strengthen tcb_cap_always_valid_strg + tcb_at_invs + use_no_cap_to_obj_asid_strg + | (erule exE, clarsimp simp: word_bits_def) | wp (once) hoare_drop_imps)+) + apply (strengthen valid_tcb_ipc_buffer_update) + apply (strengthen invs_valid_objs' invs_pspace_aligned' invs_pspace_distinct') + apply (wpsimp wp: cteDelete_invs' hoare_vcg_imp_lift' hoare_vcg_all_lift) + apply wpsimp + apply wpsimp + apply (clarsimp cong: imp_cong conj_cong simp: emptyable_def) + apply (rule_tac Q'="\_. ?T2_pre" in hoare_strengthen_postE_R[simplified validE_R_def, rotated]) + (* beginning to deal with is_nondevice_page_cap *) + apply (clarsimp simp: emptyable_def is_nondevice_page_cap_simps is_cap_simps + is_cnode_or_valid_arch_def obj_ref_none_no_asid cap_asid_def + cong: conj_cong imp_cong + split: option.split_asm) + (* newly added proof scripts for dealing with is_nondevice_page_cap *) + apply (simp add: case_bool_If valid_ipc_buffer_cap_def is_nondevice_page_cap_arch_def + split: arch_cap.splits if_splits) + (* is_nondevice_page_cap discharged *) + apply ((wp stuff checkCap_wp assertDerived_wp_weak cap_insert_objs' + | simp add: ran_tcb_cap_cases split_def U V emptyable_def + | wpc | strengthen tcb_cap_always_valid_strg use_no_cap_to_obj_asid_strg)+)[1] + apply (clarsimp cong: imp_cong conj_cong) + apply (rule_tac Q'="\_. ?T2_pre' and (\s. valid_option_prio p_auth)" + in hoare_strengthen_postE_R[simplified validE_R_def, rotated]) + apply (case_tac g'; clarsimp simp: isCap_simps ; clarsimp elim: invs_valid_objs' cong:imp_cong) + apply (wp add: stuff hoare_vcg_all_liftE_R hoare_vcg_all_lift + hoare_vcg_const_imp_liftE_R hoare_vcg_const_imp_lift setMCPriority_invs' + threadSet_valid_objs' thread_set_not_state_valid_sched setP_invs' + typ_at_lifts [OF setPriority_typ_at'] + typ_at_lifts [OF setMCPriority_typ_at'] + threadSet_cap_to' out_pred_tcb_at_preserved assertDerived_wp + del: cteInsert_invs + | simp add: ran_tcb_cap_cases split_def U V + emptyable_def + | wpc | strengthen tcb_cap_always_valid_strg + use_no_cap_to_obj_asid_strg invs_psp_aligned invs_distinct + | wp add: sch_act_simple_lift hoare_drop_imps del: cteInsert_invs + | (erule exE, clarsimp simp: word_bits_def))+ + (* the last two subgoals *) + apply (clarsimp simp: tcb_at_cte_at_0 tcb_at_cte_at_1[simplified] tcb_at_st_tcb_at[symmetric] + tcb_cap_valid_def is_cnode_or_valid_arch_def invs_valid_objs emptyable_def + obj_ref_none_no_asid no_cap_to_obj_with_diff_ref_Null is_valid_vtable_root_def + is_cap_simps cap_asid_def vs_cap_ref_def arch_cap_fun_lift_def + cong: conj_cong imp_cong + split: option.split_asm) + by (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def objBits_defs + cte_map_tcb_0 cte_map_tcb_1[simplified] tcb_at_cte_at' cte_at_tcb_at_16' + isCap_simps domIff valid_tcb'_def tcb_cte_cases_def + split: option.split_asm + dest!: isValidVTableRootD) +qed + +lemma isReplyCapD: + "isReplyCap cap \ \ptr master grant. cap = capability.ReplyCap ptr master grant" + by (simp add: isCap_simps) + +lemmas threadSet_ipcbuffer_trivial + = threadSet_invs_trivial[where F="tcbIPCBuffer_update F'" for F', + simplified inQ_def, simplified] + +crunch setPriority, setMCPriority + for cap_to'[wp]: "ex_nonz_cap_to' a" + (simp: crunch_simps) + +lemma cteInsert_sa_simple[wp]: + "\sch_act_simple\ cteInsert newCap srcSlot destSlot \\_. sch_act_simple\" + by (simp add: sch_act_simple_def, wp) + +lemma tc_invs': + "\invs' and sch_act_simple and tcb_at' a and ex_nonz_cap_to' a and + K (valid_option_prio d \ valid_option_prio mcp) and + case_option \ (valid_cap' o fst) e' and + K (case_option True (isCNodeCap o fst) e') and + case_option \ (valid_cap' o fst) f' and + K (case_option True (isValidVTableRoot o fst) f') and + case_option \ (valid_cap') (case_option None (case_option None (Some o fst) o snd) g) and + K (case_option True isArchObjectCap (case_option None (case_option None (Some o fst) o snd) g)) + and K (case_option True (swp is_aligned msg_align_bits o fst) g) \ + invokeTCB (tcbinvocation.ThreadControl a sl b' mcp d e' f' g) + \\rv. invs'\" (is "\?PRE\ _ \_\") + apply (rule hoare_gen_asm) + apply (simp add: split_def invokeTCB_def getThreadCSpaceRoot getThreadVSpaceRoot + getThreadBufferSlot_def locateSlot_conv + cong: option.case_cong) + apply (simp only: eq_commute[where a="a"]) + apply (rule hoare_walk_assmsE) + apply (clarsimp simp: pred_conj_def option.splits [where P="\x. x s" for s]) + apply ((wp case_option_wp threadSet_invs_trivial hoare_weak_lift_imp + hoare_vcg_all_lift threadSet_cap_to' | clarsimp simp: inQ_def)+)[2] + apply (rule hoare_walk_assmsE) + apply (clarsimp simp: pred_conj_def option.splits [where P="\x. x s" for s]) + apply ((wp case_option_wp threadSet_invs_trivial hoare_weak_lift_imp setMCPriority_invs' + typ_at_lifts[OF setMCPriority_typ_at'] + hoare_vcg_all_lift threadSet_cap_to' | clarsimp simp: inQ_def)+)[2] + apply (wp add: setP_invs' hoare_weak_lift_imp hoare_vcg_all_lift)+ + apply (rule case_option_wp_None_return[OF setP_invs'[simplified pred_conj_assoc]]) + apply clarsimp + apply wpfix + apply assumption + apply (rule case_option_wp_None_returnOk) + apply (wpsimp wp: hoare_weak_lift_imp hoare_vcg_all_lift + checkCap_inv[where P="tcb_at' t" for t] assertDerived_wp_weak + threadSet_invs_trivial2 threadSet_tcb' hoare_vcg_all_lift threadSet_cte_wp_at')+ + apply (wpsimp wp: hoare_weak_lift_impE_R cteDelete_deletes + hoare_vcg_all_liftE_R hoare_vcg_conj_liftE1 hoare_vcg_const_imp_liftE_R hoare_vcg_propE_R + cteDelete_invs' cteDelete_invs' cteDelete_typ_at'_lifts)+ + apply (assumption | clarsimp cong: conj_cong imp_cong | (rule case_option_wp_None_returnOk) + | wpsimp wp: hoare_weak_lift_imp hoare_vcg_all_lift checkCap_inv[where P="tcb_at' t" for t] assertDerived_wp_weak + hoare_vcg_imp_lift' hoare_vcg_all_lift checkCap_inv[where P="tcb_at' t" for t] + checkCap_inv[where P="valid_cap' c" for c] checkCap_inv[where P=sch_act_simple] + hoare_vcg_const_imp_liftE_R assertDerived_wp_weak hoare_weak_lift_impE_R cteDelete_deletes + hoare_vcg_all_liftE_R hoare_vcg_conj_liftE1 hoare_vcg_const_imp_liftE_R hoare_vcg_propE_R + cteDelete_invs' cteDelete_typ_at'_lifts cteDelete_sch_act_simple)+ + apply (clarsimp simp: tcb_cte_cases_def cte_level_bits_def objBits_defs tcbIPCBufferSlot_def) + by (auto dest!: isCapDs isReplyCapD isValidVTableRootD simp: isCap_simps) + +lemma setSchedulerAction_invs'[wp]: + "\invs' and sch_act_wf sa + and (\s. sa = ResumeCurrentThread + \ obj_at' (Not \ tcbQueued) (ksCurThread s) s) + and (\s. sa = ResumeCurrentThread + \ ksCurThread s = ksIdleThread s \ tcb_in_cur_domain' (ksCurThread s) s)\ + setSchedulerAction sa + \\rv. invs'\" + apply (simp add: setSchedulerAction_def) + apply wp + apply (clarsimp simp add: invs'_def valid_state'_def valid_irq_node'_def + valid_queues_def bitmapQ_defs cur_tcb'_def + ct_not_inQ_def) + apply (simp add: ct_idle_or_in_cur_domain'_def) + done + end consts copyregsets_map :: "arch_copy_register_sets \ Arch.copy_register_sets" -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec tcbinv_relation :: "tcb_invocation \ tcbinvocation \ bool" @@ -1492,18 +1650,15 @@ where = (x = tcbinvocation.WriteRegisters a b c (copyregsets_map d))" | "tcbinv_relation (tcb_invocation.CopyRegisters a b c d e f g) x = (x = tcbinvocation.CopyRegisters a b c d e f (copyregsets_map g))" -| "tcbinv_relation (tcb_invocation.ThreadControlCaps t slot fault_h time_h croot vroot ipcb) x - = (\sl' fault_h' time_h' croot' vroot' ipcb'. - ({fault_h, time_h, croot, vroot, option_map undefined ipcb} \ {None} \ sl' = cte_map slot) \ - newroot_rel fault_h fault_h' \ newroot_rel time_h time_h' \ - newroot_rel croot croot' \ newroot_rel vroot vroot' \ - (case ipcb of None \ ipcb' = None - | Some (vptr, g'') \ \g'''. ipcb' = Some (vptr, g''') \ newroot_rel g'' g''') \ - (x = tcbinvocation.ThreadControlCaps t sl' fault_h' time_h' croot' vroot' ipcb'))" -| "tcbinv_relation (tcb_invocation.ThreadControlSched t sl sc_fault_h mcp prio sc_opt) x - = (\sl' sc_fault_h'. - newroot_rel sc_fault_h sc_fault_h'\ (sc_fault_h \ None \ sl' = cte_map sl) \ - x = tcbinvocation.ThreadControlSched t sl' sc_fault_h' mcp prio sc_opt)" +| "tcbinv_relation (tcb_invocation.ThreadControl a sl flt_ep mcp prio croot vroot buf) x + = (\flt_ep' croot' vroot' sl' buf'. flt_ep = option_map to_bl flt_ep' \ + newroot_rel croot croot' \ newroot_rel vroot vroot' \ + ({croot, vroot, option_map undefined buf} \ {None} + \ sl' = cte_map sl) \ + (case buf of None \ buf' = None + | Some (vptr, g'') \ \g'''. buf' = Some (vptr, g''') + \ newroot_rel g'' g''') \ + x = tcbinvocation.ThreadControl a sl' flt_ep' mcp prio croot' vroot' buf')" | "tcbinv_relation (tcb_invocation.Suspend a) x = (x = tcbinvocation.Suspend a)" | "tcbinv_relation (tcb_invocation.Resume a) x @@ -1520,30 +1675,21 @@ where = (tcb_at' t and ex_nonz_cap_to' t)" | "tcb_inv_wf' (tcbinvocation.Resume t) = (tcb_at' t and ex_nonz_cap_to' t)" -| "tcb_inv_wf' (tcbinvocation.ThreadControlCaps t slot fault_h time_h croot vroot ipcb) - = (tcb_at' t and ex_nonz_cap_to' t and - case_option \ (valid_cap' o fst) fault_h and - case_option \ (valid_cap' o fst) time_h and - case_option \ (valid_cap' o fst) croot and - K (case_option True (isCNodeCap o fst) croot) and - case_option \ (valid_cap' o fst) vroot and - K (case_option True (isValidVTableRoot o fst) vroot) and - K (case_option True (isValidFaultHandler o fst) fault_h) and - K (case_option True (isValidFaultHandler o fst) time_h) and - K (case_option True ((\v. is_aligned v msg_align_bits) o fst) ipcb) and - K (case_option True (case_option True (isArchObjectCap o fst) o snd) ipcb) and - case_option \ (case_option \ (valid_cap' o fst) o snd) ipcb and - (\s. {fault_h, time_h, croot, vroot, option_map undefined ipcb} \ {None} \ - cte_at' slot s))" -| "tcb_inv_wf' (tcbinvocation.ThreadControlSched t slot sc_fault_h mcp_auth p_auth sc_opt) +| "tcb_inv_wf' (tcbinvocation.ThreadControl t sl fe mcp p croot vroot buf) = (tcb_at' t and ex_nonz_cap_to' t and - case_option \ (valid_cap' o fst) sc_fault_h and - K (case_option True (isValidFaultHandler o fst) sc_fault_h) and - (\s. sc_fault_h \ None \ cte_at' slot s) and - K (valid_option_prio p_auth \ valid_option_prio mcp_auth) and - (\s. case_option True (\(pr, auth). mcpriority_tcb_at' ((\) pr) auth s) p_auth) and - (\s. case_option True (\(m, auth). mcpriority_tcb_at' ((\) m) auth s) mcp_auth) and - case_option \ (\sc_opt'. case_option \ (\p. sc_at' p and ex_nonz_cap_to' p) sc_opt') sc_opt)" + K (valid_option_prio p \ valid_option_prio mcp) and + case_option \ (valid_cap' o fst) croot and + K (case_option True (isCNodeCap o fst) croot) and + case_option \ (valid_cap' o fst) vroot and + K (case_option True (isValidVTableRoot o fst) vroot) and + case_option \ (case_option \ (valid_cap' o fst) o snd) buf and + case_option \ (case_option \ (cte_at' o snd) o snd) buf and + K (case_option True (swp is_aligned msg_align_bits o fst) buf) and + K (case_option True (case_option True (isArchObjectCap o fst) o snd) buf) and + (\s. {croot, vroot, option_map undefined buf} \ {None} + \ cte_at' sl s) and + (\s. case_option True (\(pr, auth). mcpriority_tcb_at' ((\) pr) auth s) p) and + (\s. case_option True (\(m, auth). mcpriority_tcb_at' ((\) m) auth s) mcp))" | "tcb_inv_wf' (tcbinvocation.ReadRegisters src susp n arch) = (tcb_at' src and ex_nonz_cap_to' src)" | "tcb_inv_wf' (tcbinvocation.WriteRegisters dest resume values arch) @@ -1561,961 +1707,50 @@ where | "tcb_inv_wf' (tcbinvocation.SetTLSBase ref w) = (tcb_at' ref and ex_nonz_cap_to' ref)" -lemma installTCBCap_corres_helper: - "n \ {0,1,3,4} \ - (if n = 0 then withoutPreemption $ getThreadCSpaceRoot target - else if n = 1 then withoutPreemption $ getThreadVSpaceRoot target - else if n = 3 then withoutPreemption $ getThreadFaultHandlerSlot target - else if n = 4 then withoutPreemption $ getThreadTimeoutHandlerSlot target - else haskell_fail []) = returnOk (cte_map (target, tcb_cnode_index n))" - by (auto simp: getThreadFaultHandlerSlot_def getThreadVSpaceRoot_def getThreadCSpaceRoot_def - getThreadTimeoutHandlerSlot_def locateSlotTCB_def locateSlot_conv returnOk_def - return_def liftE_def bind_def tcbFaultHandlerSlot_def tcbTimeoutHandlerSlot_def - tcbCTableSlot_def tcbVTableSlot_def tcb_cnode_index_def cte_map_def to_bl_def) - -lemma installTCBCap_corres: - "\ newroot_rel slot_opt slot_opt'; slot_opt \ None \ slot' = cte_map slot; n \ {0,1,3,4} \ \ - corres (dc \ dc) - (\s. einvs s \ valid_machine_time s \ simple_sched_action s - \ cte_at (target, tcb_cnode_index n) s \ current_time_bounded s \ - (\new_cap src_slot. - slot_opt = Some (new_cap, src_slot) \ - (is_cnode_or_valid_arch new_cap \ valid_fault_handler new_cap) \ - (new_cap \ cap.NullCap \ - s \ new_cap \ - (is_ep_cap new_cap \ (target,tcb_cnode_index n) \ src_slot \ - cte_wp_at valid_fault_handler (target, tcb_cnode_index n) s \ - cte_wp_at ((=) new_cap) src_slot s) \ - no_cap_to_obj_dr_emp new_cap s \ - cte_at src_slot s \ cte_at slot s))) - (\s. invs' s \ sch_act_simple s \ cte_at' (cte_map (target, tcb_cnode_index n)) s \ - (\newCap srcSlot. - slot_opt' = Some (newCap, srcSlot) \ - newCap \ NullCap \ - valid_cap' newCap s)) - (install_tcb_cap target slot n slot_opt) - (installTCBCap target slot' n slot_opt')" - apply (simp only: install_tcb_cap_def installTCBCap_def - installTCBCap_corres_helper unlessE_whenE) - apply (case_tac slot_opt; clarsimp simp: newroot_rel_def corres_returnOk) - apply (rule corres_guard_imp) - apply (rule corres_split_norE) - apply (rule cteDelete_corres) - apply (rule corres_whenE) - apply fastforce - apply clarsimp - apply (rule checkCapAt_cteInsert_corres) - apply simp - apply simp - apply ((wp cap_delete_valid_sched cap_delete_deletes_fh cap_delete_deletes cap_delete_cte_at - cap_delete_valid_cap cteDelete_invs' cteDelete_deletes hoare_vcg_const_imp_liftE_R - | strengthen use_no_cap_to_obj_asid_strg)+) - apply (fastforce simp: is_cap_simps valid_fault_handler_def - is_cnode_or_valid_arch_def cte_wp_at_def)+ - done - -lemma installTCBCap_invs': - "\\s. invs' s \ (\newCap srcSlot. slot_opt = Some (newCap,srcSlot) \ - sch_act_simple s \ valid_cap' newCap s \ - \ isReplyCap newCap \ \ isIRQControlCap newCap)\ - installTCBCap target slot n slot_opt - \\rv. invs'\" - apply (simp only: installTCBCap_def tcbCTableSlot_def tcbVTableSlot_def tcbFaultHandlerSlot_def - getThreadCSpaceRoot_def getThreadVSpaceRoot_def getThreadFaultHandlerSlot_def) - apply (wpsimp split_del: if_split - wp: checked_insert_tcb_invs cteDelete_invs' - cteDelete_deletes hoare_vcg_const_imp_liftE_R hoare_vcg_if_lift_ER - simp: locateSlotBasic_def maybe_def returnOk_bindE - getThreadTimeoutHandlerSlot_def locateSlotTCB_def)+ - apply (auto simp: objBits_def objBitsKO_def cteSizeBits_def tcbTimeoutHandlerSlot_def) - done - -lemma installThreadBuffer_invs': - "\\s. invs' s \ (\newCap srcSlot. slot_opt = Some (newCap,srcSlot) \ - sch_act_simple s \ tcb_at' target s \ - is_aligned newCap msg_align_bits \ - (\x. (\y. srcSlot = Some (x, y)) \ - valid_cap' x s \ capBadge x = None \ - \ isReplyCap x \ \ isIRQControlCap x))\ - installThreadBuffer target slot slot_opt - \\rv. invs'\" - unfolding installThreadBuffer_def maybe_def returnOk_bindE - apply (wpsimp wp: hoare_weak_lift_imp hoare_vcg_all_lift threadSet_invs_trivial2) - apply (wpsimp wp: threadSet_cte_wp_at'T) - apply (clarsimp simp: tcbIPCBuffer_update_def) - apply (case_tac tcb; fastforce simp: tcb_cte_cases_def) - apply wpsimp+ - apply (wpsimp wp: cteDelete_invs' cteDelete_deletes getThreadBufferSlot_inv - getThreadBufferSlot_dom_tcb_cte_cases hoare_vcg_const_imp_liftE_R - hoare_vcg_all_liftE_R hoare_vcg_imp_lift hoare_vcg_all_lift)+ - done - -crunch installTCBCap - for tcb_at'[wp]: "tcb_at' a" - and cte_at'[wp]: "cte_at' p" - (wp: crunch_wps checkCap_inv assertDerived_wp_weak simp: crunch_simps) - -lemma installTCBCap_valid_cap'[wp]: - "installTCBCap pa pb pc pd \valid_cap' c\" - unfolding getThreadTimeoutHandlerSlot_def getThreadFaultHandlerSlot_def - getThreadVSpaceRoot_def getThreadCSpaceRoot_def installTCBCap_def - by (wpsimp wp: checkCap_inv crunch_wps assertDerived_wp_weak | intro conjI)+ - -lemma cteInsert_sa_simple[wp]: - "cteInsert newCap srcSlot destSlot \sch_act_simple\" - by (simp add: sch_act_simple_def, wp) - -lemma installTCBCap_sch_act_simple: - "\invs' and sch_act_simple and tcb_at' a\ - installTCBCap a sl n sl_opt - \\rv. sch_act_simple\" - unfolding getThreadTimeoutHandlerSlot_def getThreadFaultHandlerSlot_def - getThreadVSpaceRoot_def getThreadCSpaceRoot_def installTCBCap_def - by (wpsimp wp: checkCap_inv assertDerived_wp_weak cteDelete_sch_act_simple | rule conjI)+ - -lemma is_aligned_tcb_ipc_buffer_update: - "is_aligned aa msg_align_bits \ - valid_tcb a tcb s \ valid_tcb a (tcb\tcb_ipc_buffer := aa\) s" - by (clarsimp simp: valid_tcb_def ran_tcb_cap_cases valid_ipc_buffer_cap_def - split: cap.splits arch_cap.splits bool.splits) - -lemma is_aligned_tcbIPCBuffer_update: - "is_aligned aa msg_align_bits \ - valid_tcb' tcb s \ valid_tcb' (tcbIPCBuffer_update (\_. aa) tcb) s" - by (clarsimp simp: valid_tcb'_def tcb_cte_cases_def) - -lemma checkCap_inv2: - assumes x: "\P\ f \Q\" - shows "\P and Q ()\ checkCapAt cap slot f \Q\" - unfolding checkCapAt_def - by (wp x getCTE_wp', clarsimp) - -crunch cteInsert - for valid_release_queue[wp]: "valid_release_queue" - and valid_release_queue'[wp]: "valid_release_queue'" - and valid_queues'[wp]: "valid_queues'" - (wp: crunch_wps simp: crunch_simps) - -lemma installThreadBuffer_corres_helper: - "getThreadBufferSlot a = return (cte_map (a, tcb_cnode_index 2))" - by (simp add: getThreadBufferSlot_def locateSlot_conv cte_map_def - cte_level_bits_def tcb_cnode_index_def tcbIPCBufferSlot_def) - -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" - shows "corres (dc \ dc) - (einvs and valid_machine_time and simple_sched_action and tcb_at a - and (case_option \ (\(_,sl). cte_at slot and current_time_bounded and - (case_option \ (\(newCap,srcSlot). cte_at srcSlot and valid_cap newCap and - no_cap_to_obj_dr_emp newCap) sl)) g) - and K (case_option True (\(x,v). - case_option True (\(c,sl). is_cnode_or_valid_arch c \ is_arch_cap c \ - is_aligned x msg_align_bits \ - valid_ipc_buffer_cap c x) v) g)) - (invs' and sch_act_simple and tcb_at' a - and (case_option \ (\(_,sl). - (case_option \ (\(newCap,srcSlot). valid_cap' newCap) sl)) g') - and K (case_option True (\(x, v). is_aligned x msg_align_bits \ - (case_option True (\(ac, _). isArchObjectCap ac) v)) g')) - (install_tcb_frame_cap a slot g) - (installThreadBuffer a sl' g')" - using assms - apply - - apply (simp only: install_tcb_frame_cap_def installThreadBuffer_def K_def) - apply (rule corres_gen_asm2) - apply (rule corres_guard_imp[where P=P and P'=P' and Q="P and cte_at (a, tcb_cnode_index 2)" - and Q'="P' and cte_at' (cte_map (a, cap))" for P P' a cap]) - apply (cases g, simp add: returnOk_def) - apply (clarsimp simp: installThreadBuffer_corres_helper bind_liftE_distrib liftE_bindE) - apply (rule corres_guard_imp) - apply (rule corres_split_norE) - apply (rule cteDelete_corres) - apply (rule_tac F="is_aligned aa msg_align_bits" in corres_gen_asm2) - apply (rule corres_split_nor) - apply (rule threadset_corres; simp add: tcb_relation_def) - apply (rule corres_split_nor) - apply (simp only: case_option_If2) - apply (rule corres_if3) - apply (clarsimp simp: newroot_rel_def split: if_splits) - apply (clarsimp simp: newroot_rel_def) - apply wpfix - apply (erule checkCapAt_cteInsert_corres) - apply (rule_tac P=\ and P'=\ in corres_inst, clarsimp) - 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 pspace_aligned and pspace_distinct" - in hoare_strengthen_post[rotated], fastforce) - apply wp - apply (rule_tac Q'="\_. valid_objs' and valid_release_queue_iff - and valid_queues and valid_queues'" - in hoare_strengthen_post[rotated], fastforce) - apply wp - apply (wpsimp wp: check_cap_inv2 cap_insert_ct) - apply (wpsimp wp: checkCap_inv2 assertDerived_wp_weak) - apply (clarsimp simp: option.case_eq_if if_fun_split) - apply (wpsimp simp: ran_tcb_cap_cases - wp: hoare_vcg_all_lift hoare_vcg_const_imp_lift - 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) - 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_valid_release_queue - threadSet_valid_release_queue' threadSet_valid_queues threadSet_valid_queues') - apply ((wp cap_delete_deletes cap_delete_valid_sched cap_delete_cte_at cap_delete_deletes_fh - hoare_vcg_const_imp_liftE_R hoare_vcg_all_liftE_R hoare_vcg_disj_lift_R - | 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)+)[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) - (cte_map (a, tcb_cnode_index 2)) s" - in hoare_strengthen_postE[rotated]) - apply (clarsimp simp: valid_pspace'_def is_aligned_tcbIPCBuffer_update - valid_release_queue_def valid_release_queue'_def obj_at'_def invs'_def) - apply assumption - apply (wp cteDelete_invs' cteDelete_deletes hoare_vcg_const_imp_liftE_R) - apply (fastforce simp: tcb_ep_slot_cte_wp_ats cte_wp_at_caps_of_state - valid_fault_handler_def is_cap_simps valid_ipc_buffer_cap_def - dest: is_cnode_or_valid_arch_cap_asid - split: arch_cap.splits bool.splits option.splits) - apply (fastforce split: option.splits) - apply (fastforce simp: obj_at_def is_tcb intro: cte_wp_at_tcbI) - apply (fastforce simp: cte_map_def tcb_cnode_index_def obj_at'_def - projectKOs cte_level_bits_def objBits_simps cte_wp_at_tcbI') - done - -lemma tcb_at_cte_at'_0: "tcb_at' a s \ cte_at' (cte_map (a, tcb_cnode_index 0)) s" - apply (clarsimp simp: obj_at'_def projectKO_def fail_def return_def projectKO_tcb oassert_opt_def - split: option.splits) - apply (rule_tac ptr'=a in cte_wp_at_tcbI'; simp add: objBitsKO_def) - apply (simp add: cte_map_def tcb_cnode_index_def cte_level_bits_def) - done - -lemma tcb_at_cte_at'_1: "tcb_at' a s \ cte_at' (cte_map (a, tcb_cnode_index (Suc 0))) s" - apply (clarsimp simp: obj_at'_def projectKO_def fail_def return_def projectKO_tcb oassert_opt_def - split: option.splits) - apply (rule_tac ptr'=a in cte_wp_at_tcbI'; simp add: objBitsKO_def) - apply (simp add: cte_map_def tcb_cnode_index_def cte_level_bits_def of_bl_def) - done - -lemma tcb_at_cte_at'_3: "tcb_at' a s \ cte_at' (cte_map (a, tcb_cnode_index 3)) s" - apply (clarsimp simp: obj_at'_def projectKO_def fail_def return_def projectKO_tcb oassert_opt_def - split: option.splits) - apply (rule_tac ptr'=a in cte_wp_at_tcbI'; simp add: objBitsKO_def) - apply (simp add: cte_map_def tcb_cnode_index_def cte_level_bits_def) - done - -lemma tcb_at_cte_at'_4: "tcb_at' a s \ cte_at' (cte_map (a, tcb_cnode_index 4)) s" - apply (clarsimp simp: obj_at'_def projectKO_def fail_def return_def projectKO_tcb oassert_opt_def - split: option.splits) - apply (rule_tac ptr'=a in cte_wp_at_tcbI'; simp add: objBitsKO_def) - apply (simp add: cte_map_def tcb_cnode_index_def cte_level_bits_def) - done - -lemma tc_corres_caps: - fixes t slot fault_h time_h croot vroot ipcb sl' fault_h' time_h' croot' vroot' ipcb' - defines "tc_caps_inv \ tcb_invocation.ThreadControlCaps t slot fault_h time_h croot vroot ipcb" - defines "tc_caps_inv' \ tcbinvocation.ThreadControlCaps t sl' fault_h' time_h' croot' vroot' ipcb'" - assumes "tcbinv_relation tc_caps_inv tc_caps_inv'" - defines "valid_tcap c \ case_option \ (valid_cap o fst) c and - case_option \ (real_cte_at o snd) c and - case_option \ (no_cap_to_obj_dr_emp o fst) c" - shows - "corres (dc \ (=)) - (einvs and valid_machine_time and simple_sched_action and active_scs_valid - and tcb_at t and tcb_inv_wf tc_caps_inv and current_time_bounded) - (invs' and sch_act_simple and tcb_inv_wf' tc_caps_inv') - (invoke_tcb tc_caps_inv) - (invokeTCB tc_caps_inv')" - using assms - apply - - apply (simp add: invokeTCB_def liftE_bindE) - apply (rule corres_guard_imp) - apply (rule corres_split_norE, (rule installTCBCap_corres; clarsimp))+ - apply (rule corres_split_norE) - apply (rule installThreadBuffer_corres; clarsimp) - apply (rule corres_trivial, clarsimp simp: returnOk_def) - apply wpsimp+ - apply (wpsimp wp: install_tcb_cap_invs hoare_case_option_wpR) - apply (wpsimp wp: installTCBCap_invs' installTCBCap_sch_act_simple hoare_case_option_wpR) - apply ((wp hoare_case_option_wpR hoare_vcg_all_liftE_R hoare_vcg_const_imp_liftE_R - install_tcb_cap_invs install_tcb_cap_cte_at install_tcb_cap_cte_wp_at_ep - | strengthen tcb_cap_always_valid_strg)+)[1] - apply (wp installTCBCap_invs' installTCBCap_sch_act_simple - hoare_case_option_wpR hoare_vcg_all_liftE_R hoare_vcg_const_imp_liftE_R) - apply ((wp hoare_case_option_wpR hoare_vcg_all_liftE_R hoare_vcg_const_imp_liftE_R - install_tcb_cap_invs install_tcb_cap_cte_at install_tcb_cap_cte_wp_at_ep - | strengthen tcb_cap_always_valid_strg)+)[1] - apply (wp installTCBCap_invs' installTCBCap_sch_act_simple - hoare_case_option_wpR hoare_vcg_all_liftE_R hoare_vcg_const_imp_liftE_R) - apply ((wp hoare_case_option_wpR hoare_vcg_all_liftE_R hoare_vcg_const_imp_liftE_R - install_tcb_cap_invs install_tcb_cap_cte_at install_tcb_cap_cte_wp_at_ep - | strengthen tcb_cap_always_valid_strg)+)[1] - apply (wp installTCBCap_invs' installTCBCap_sch_act_simple - hoare_case_option_wpR hoare_vcg_all_liftE_R hoare_vcg_const_imp_liftE_R) - apply ((clarsimp simp: tcb_at_cte_at_0 tcb_at_cte_at_1[simplified] tcb_at_cte_at_3 tcb_at_cte_at_4 - tcb_cap_valid_def tcb_at_st_tcb_at[symmetric] is_nondevice_page_cap_def - is_nondevice_page_cap_arch_def is_cnode_or_valid_arch_def is_cap_simps - is_valid_vtable_root_def valid_ipc_buffer_cap tcb_ep_slot_cte_wp_at - cte_wp_at_disj cte_wp_at_eq_simp real_cte_at_cte real_cte_at_not_tcb_at - split: option.split - | intro conjI | fastforce simp: valid_fault_handler_def)+)[1] - apply (clarsimp simp: tcb_at_cte_at'_0 tcb_at_cte_at'_1 tcb_at_cte_at'_3 - tcb_at_cte_at'_4 isCap_simps case_option_If2 - isValidFaultHandler_def isValidVTableRoot_def | intro conjI)+ - done - -lemma sched_context_resume_weak_valid_sched_action: - "\\s. weak_valid_sched_action s \ - (\ya. sc_tcb_sc_at ((=) (Some ya)) scp s \ scheduler_act_not ya s)\ - sched_context_resume scp - \\_. weak_valid_sched_action\" - unfolding sched_context_resume_def - by (wpsimp wp: postpone_weak_valid_sched_action thread_get_wp' is_schedulable_wp') - -crunch sched_context_resume - for sc_at_ppred[wp]: "sc_at_ppred n P ptr" - (wp: crunch_wps) - -lemma setSchedContext_scTCB_update_valid_refills[wp]: - "\ko_at' sc ptr and valid_refills' ptr'\ - setSchedContext ptr (scTCB_update f sc) - \\_. valid_refills' ptr'\" - apply (wpsimp wp: set_sc'.set_wp) - by (clarsimp simp: valid_refills'_def obj_at_simps opt_map_red opt_pred_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)" - apply (simp only: sched_context_bind_tcb_def schedContextBindTCB_def) - apply (rule stronger_corres_guard_imp) - apply clarsimp - apply (rule corres_symb_exec_r') - apply (rule corres_split_nor) - apply (clarsimp simp: set_tcb_obj_ref_thread_set sc_relation_def) - apply (rule threadset_corres; clarsimp simp: tcb_relation_def) - apply (rule corres_split_nor) - apply (rule_tac f'="scTCB_update (\_. Some t)" - in update_sc_no_reply_stack_update_ko_at'_corres; clarsimp?) - apply (clarsimp simp: sc_relation_def) - apply (clarsimp simp: objBits_def objBitsKO_def) - apply (rule corres_split[OF ifCondRefillUnblockCheck_corres]) - apply (rule corres_split_nor) - apply (rule schedContextResume_corres) - apply (rule corres_split_eqr) - apply (rule isSchedulable_corres) - apply (rule corres_when, simp) - apply (rule corres_split_nor) - apply (rule tcbSchedEnqueue_corres) - apply (rule rescheduleRequired_corres) - apply wp - apply wp - apply (wpsimp simp: is_schedulable_def) - apply (wpsimp wp: threadGet_wp getTCB_wp simp: isSchedulable_def 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" - in hoare_strengthen_post[rotated], fastforce) - 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 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" - 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 - wp: refill_unblock_check_valid_release_q - refill_unblock_check_valid_sched_action - refill_unblock_check_active_scs_valid) - apply (rule_tac Q'="\_. invs'" in hoare_strengthen_post[rotated], fastforce) - apply wpsimp - apply (rule_tac Q'="\_. valid_objs and pspace_aligned and pspace_distinct and - (\s. sym_refs (state_refs_of s)) and - valid_ready_qs and valid_release_q and active_scs_valid and - sc_tcb_sc_at (\sc. sc \ None) ptr and - (\s. (weak_valid_sched_action s \ current_time_bounded s \ - (\ya. sc_tcb_sc_at ((=) (Some ya)) ptr s \ - not_in_release_q ya s \ scheduler_act_not ya s)) \ - active_scs_valid s \ - sc_tcb_sc_at ((=) (Some t)) ptr s \ - bound_sc_tcb_at (\a. a = Some ptr) t s)" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: sc_tcb_sc_at_def obj_at_def is_sc_obj invs_def valid_state_def - valid_pspace_def option.case_eq_if opt_map_red opt_pred_def) - apply (drule (1) valid_sched_context_size_objsI) - apply clarsimp - apply (clarsimp simp: pred_tcb_at_def obj_at_def vs_all_heap_simps option.case_eq_if - opt_map_red) - apply (rename_tac sc ta tcb tcb') - 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 valid_ioports_lift - update_sched_context_iflive_update update_sched_context_refs_of_update - update_sched_context_cur_sc_tcb_None update_sched_context_valid_idle - simp: invs'_def valid_pspace_def - | rule hoare_vcg_conj_lift update_sched_context_wp)+)[2] - apply (clarsimp simp: pred_conj_def) - apply ((wp set_tcb_sched_context_valid_ready_qs - set_tcb_sched_context_valid_release_q_not_queued - 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_valid_queues threadSet_valid_queues' - threadSet_iflive' threadSet_not_inQ threadSet_ifunsafe'T threadSet_idle'T - threadSet_sch_actT_P[where P=False, simplified] threadSet_ctes_ofT threadSet_mdb' - threadSet_valid_release_queue threadSet_valid_release_queue' 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' - | clarsimp simp: tcb_cte_cases_def cteCaps_of_def - | rule hoare_vcg_conj_lift threadSet_wp refl)+ - apply (clarsimp simp: invs_def valid_state_def valid_pspace_def valid_sched_def) - apply (intro conjI impI allI; (solves clarsimp)?) - apply (fastforce simp: valid_obj_def obj_at_def sc_at_ppred_def is_sc_obj_def) - apply (clarsimp simp: valid_sched_context_def obj_at_def pred_tcb_at_def is_tcb_def) - apply (fastforce simp: obj_at_def pred_tcb_at_def sc_at_ppred_def - tcb_st_refs_of_def state_refs_of_def - elim: delta_sym_refs split: if_splits) - apply (fastforce simp: tcb_at_kh_simps pred_map_eq_def - dest!: valid_ready_qs_no_sc_not_queued) - apply (fastforce simp: tcb_at_kh_simps pred_map_eq_def - elim!: valid_release_q_no_sc_not_in_release_q) - apply (fastforce simp: sc_at_pred_def sc_at_ppred_def obj_at_def bound_sc_tcb_at_def - split: if_splits) - apply (clarsimp simp: weak_valid_sched_action_def simple_sched_action_def) - apply (fastforce simp: tcb_at_kh_simps pred_map_eq_def sc_tcb_sc_at_def obj_at_def - elim!: valid_release_q_no_sc_not_in_release_q) - apply (clarsimp simp: sc_at_ppred_def obj_at_def bound_sc_tcb_at_def) - apply (clarsimp simp: sc_at_ppred_def obj_at_def bound_sc_tcb_at_def) - apply (subgoal_tac "obj_at' (\sc. scTCB sc = None) ptr s'") - apply (subgoal_tac "bound_sc_tcb_at' ((=) None) t s'") - apply (subgoal_tac "ptr \ idle_sc_ptr") - apply (clarsimp simp: invs'_def valid_pspace'_def pred_tcb_at'_def - sc_at_ppred_def obj_at'_def projectKO_eq projectKO_tcb projectKO_sc) - apply (intro conjI allI impI; (solves \clarsimp simp: inQ_def comp_def\)?) - apply (clarsimp simp: valid_tcb'_def tcb_cte_cases_def obj_at'_def projectKO_eq) - apply (fastforce simp: valid_obj'_def valid_sched_context'_def tcb_cte_cases_def - obj_at'_def projectKO_eq projectKO_sc projectKO_tcb) - apply (fastforce elim: valid_objs_sizeE'[OF valid_objs'_valid_objs_size'] - simp: objBits_def objBitsKO_def valid_obj_size'_def - valid_sched_context_size'_def) - apply (fastforce elim: ex_cap_to'_after_update simp: ko_wp_at'_def tcb_cte_cases_def) - apply (fastforce elim: ex_cap_to'_after_update simp: ko_wp_at'_def tcb_cte_cases_def) - apply (clarsimp simp: valid_release_queue'_def obj_at'_def projectKO_eq projectKO_tcb) - apply (clarsimp simp: valid_release_queue'_def obj_at'_def projectKO_eq projectKO_tcb) - apply (clarsimp simp: untyped_ranges_zero_inv_def cteCaps_of_def comp_def) - apply simp - apply (fastforce simp: invs'_def dest: global'_sc_no_ex_cap) - 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) - apply (drule_tac x=t in bspec; clarsimp simp: other_obj_relation_def tcb_relation_def projectKOs) - apply (fastforce elim: tcb_at_cross) - apply (clarsimp simp: sc_relation_def state_relation_def invs_def valid_state_def valid_pspace_def) - apply (subgoal_tac "sc_at' ptr s'") - apply (clarsimp simp: obj_at_def sc_at_pred_n_def obj_at'_def projectKOs pspace_relation_def) - apply (drule_tac x=ptr in bspec; clarsimp simp: sc_relation_def split: if_splits) - apply (fastforce simp: sc_at_pred_n_def obj_at_def is_sc_obj_def valid_obj_def elim!: sc_at_cross) - done - -schematic_goal finaliseSlot'_def: - "finaliseSlot' a b = ?X" - by (rule ext) simp - -lemma cteDelete_fh_lift: - assumes A: "\x. \Q\ emptySlot target x \\_. P\" - and B: "\x. \R\ cancelAllIPC x \\_. Q\" - and C: "\s. (P and invs' and L) s \ Q s \ R s" - shows "\P and invs' and cte_wp_at' (isValidFaultHandler \ cteCap) target and L\ - cteDelete target True - \\_. P\" - apply (wpsimp wp: A simp: cteDelete_def) - prefer 2 - apply assumption - apply (subst finaliseSlot_def) - apply (subst finaliseSlot'_def) - apply (rule bindE_wp_fwd) - apply (subst liftE_validE) - apply (rule getCTE_sp) - apply (clarsimp split del: if_split) - apply (rule_tac Q="P and invs' and L and cte_wp_at' (\c. c = cte) target - and K (isValidFaultHandler (cteCap cte))" in hoare_pre(2)) - apply (case_tac "cteCap cte"; clarsimp simp: isValidFaultHandler_def split: bool.splits) - apply (wpsimp simp: C)+ - apply (rule hoare_FalseE) - apply (rule hoare_FalseE) - apply (rule hoare_FalseE) - apply (wpsimp wp: B isFinal simp: capRemovable_def finaliseCap_def isEndpointCap_def)+ - apply (fastforce simp: C cte_wp_at'_def final_matters'_def capRemovable_def invs'_def)+ - done - -lemma installTCBCap_fh_ex_nonz_cap_to': - "\\s. ex_nonz_cap_to' p s \ invs' s \ \ep_at' p s \ - cte_wp_at' (isValidFaultHandler \ cteCap) (cte_map (target, tcb_cnode_index 3)) s\ - installTCBCap target slot 3 slot_opt - \\rv. ex_nonz_cap_to' p\" - unfolding installTCBCap_def getThreadFaultHandlerSlot_def locateSlotTCB_def locateSlotBasic_def - apply (case_tac slot_opt; clarsimp) - apply wpsimp - apply (rule validE_valid) - apply (rule bindE_wp_fwd) - apply (rule liftE_wp[OF hoare_return_sp]) - apply (rule valid_validE) - apply (rule hoare_gen_asm) - apply (clarsimp simp: objBits_def objBitsKO_def) - apply (wpsimp wp: checkCap_wp assertDerived_wp_weak cteInsert_cap_to' split_del: if_splits) - apply (rule_tac Q'="\_ s. cte_wp_at' (\c. cteCap c = capability.NullCap) - (target + 2 ^ cteSizeBits * tcbFaultHandlerSlot) s \ - ex_nonz_cap_to' p s" in hoare_strengthen_postE) - apply (rule hoare_vcg_conj_liftE1[OF _ valid_validE]) - apply (wpsimp wp: cteDelete_deletes) - apply (rule cteDelete_fh_lift) - apply (wpsimp wp: hoare_vcg_ex_lift emptySlot_cte_wp_cap_other simp: ex_nonz_cap_to'_def) - apply (wpsimp wp: hoare_vcg_ex_lift) - apply (clarsimp simp: ex_nonz_cap_to'_def) - apply (rule_tac x=cref in exI) - apply clarsimp - apply (prop_tac "\ ep_at' p s \ cte_wp_at' (isValidFaultHandler \ cteCap) - (target + 2 ^ cteSizeBits * tcbFaultHandlerSlot) s") - apply assumption - apply (clarsimp simp: cte_wp_at_ctes_of) - apply (prop_tac "s \' (cteCap cte)") - apply fastforce - apply (prop_tac "\ isEndpointCap (cteCap cte)") - apply (fastforce simp: valid_cap'_def isCap_simps) - apply (case_tac "cteCap cte"; clarsimp simp: isValidFaultHandler_def isEndpointCap_def) - apply (wpsimp wp: cteDelete_deletes)+ - apply (clarsimp simp: comp_def cte_map_def tcb_cnode_index_def - 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" - (wp: crunch_wps simp: crunch_simps inQ_def) - -lemma setMCPriority_ex_nonz_cap_to'[wp]: - "setMCPriority param_a param_b \ex_nonz_cap_to' p\" - by (wpsimp wp: threadSet_cap_to' simp: setMCPriority_def) - -lemma mapTCBPtr_threadGet: "mapTCBPtr t f = threadGet f t" - by (clarsimp simp: mapTCBPtr_def threadGet_getObject) - -lemma monadic_rewrite_bind_unbind: - "monadic_rewrite False True (tcb_at t) - (case sc_opt of None \ return () - | Some None \ maybe_sched_context_unbind_tcb t - | Some (Some sc_ptr) \ maybe_sched_context_bind_tcb sc_ptr t) - (do y <- get_tcb_obj_ref tcb_sched_context t; - case sc_opt of None \ return () - | Some None \ case y of None \ return () - | Some x \ sched_context_unbind_tcb x - | Some (Some sc_ptr) \ when (y \ Some sc_ptr) $ sched_context_bind_tcb sc_ptr t - od)" - apply (case_tac sc_opt; clarsimp) - apply (clarsimp simp: monadic_rewrite_def bind_def get_tcb_obj_ref_def thread_get_def - gets_the_def get_tcb_def gets_def get_def obj_at_def is_tcb_def) - apply (case_tac ko; clarsimp simp: return_def) - apply (case_tac a; clarsimp simp: maybeM_def maybe_sched_context_unbind_tcb_def - maybe_sched_context_bind_tcb_def monadic_rewrite_def) - done - -defs tcs_cross_asrt1_def: - "tcs_cross_asrt1 t sc_opt \ - \s. sym_refs (state_refs_of' s) \ - cte_wp_at' (isValidFaultHandler \ cteCap) (cte_map (t, tcb_cnode_index 3)) s \ - (\x. sc_opt = Some (Some x) \ bound_sc_tcb_at' (\sc. sc = None) t s \ - obj_at' (\sc. scTCB sc = None) x s)" - -defs tcs_cross_asrt2_def: - "tcs_cross_asrt2 \ \s. ready_qs_runnable s \ ct_active' s \ - bound_sc_tcb_at' bound (ksCurThread s) s" - -crunch setPriority, setMCPriority - for ksCurThread[wp]: "\s. P (ksCurThread s)" - and cur_tcb'[wp]: cur_tcb' - (wp: crunch_wps cur_tcb_lift) - -crunch schedContextYieldTo, schedContextCompleteYieldTo - for tcb_at'[wp]: "tcb_at' tcbPtr" - (wp: crunch_wps) - -lemma schedContextUnbindTCB_corres': - "corres dc (invs and valid_sched and sc_tcb_sc_at ((\) None) scp) invs' - (sched_context_unbind_tcb scp) (schedContextUnbindTCB scp)" - apply (rule corres_cross_add_guard[where Q="obj_at' (\sc. \y. scTCB sc = Some y) scp"]) - apply (fastforce elim: sc_tcb_sc_at_bound_cross dest!: state_relation_pspace_relation - simp: invs_def valid_state_def valid_pspace_def) - - apply (simp add: neq_None_bound) - apply (rule schedContextUnbindTCB_corres[simplified]) - done - -lemma tc_corres_sched: - fixes t slot sc_fault_h p_auth mcp_auth sc_opt sl' sc_fault_h' sc_opt' - defines "tc_inv_sched \ tcb_invocation.ThreadControlSched t slot sc_fault_h mcp_auth p_auth sc_opt" - defines "tc_inv_sched' \ ThreadControlSched t sl' sc_fault_h' mcp_auth p_auth sc_opt'" - assumes "tcbinv_relation tc_inv_sched tc_inv_sched'" - shows - "corres (dc \ (=)) - (einvs and valid_machine_time and simple_sched_action and tcb_inv_wf tc_inv_sched - and ct_released and ct_active and ct_not_in_release_q and current_time_bounded) - (invs' and sch_act_simple and tcb_inv_wf' tc_inv_sched') - (invoke_tcb tc_inv_sched) - (invokeTCB tc_inv_sched')" - using assms - apply - - apply add_sym_refs - apply add_valid_idle' - apply add_cur_tcb' - apply (simp add: invokeTCB_def liftE_bindE bind_assoc maybeM_def) - apply (rule corres_stateAssertE_add_assertion) - apply (rule corres_stateAssertE_add_assertion[rotated]) - apply (clarsimp simp: valid_idle'_asrt_def) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split_norE) - apply (rule installTCBCap_corres; clarsimp) - apply (rule corres_split_nor) - apply (rule_tac P=\ and P'=\ in corres_option_split; clarsimp) - apply (rule setMCPriority_corres) - apply (rule corres_stateAssert_add_assertion) - apply (rule stronger_corres_guard_imp) - apply (rule corres_split_nor) - apply (rule_tac P=\ and P'=\ in corres_option_split; clarsimp) - apply wpfix - apply (rule setPriority) - apply (simp add: bind_assoc[symmetric]) - apply (rule corres_split_nor) - apply (rule monadic_rewrite_corres_l[OF monadic_rewrite_bind_unbind]) - apply (rule corres_split_eqr) - apply (simp only: mapTCBPtr_threadGet get_tcb_obj_ref_def) - apply (rule threadGet_corres, clarsimp simp: tcb_relation_def) - apply (rule_tac P=\ and P'=\ in corres_option_split; clarsimp) - apply (rule corres_option_split; clarsimp?) - apply (rule_tac P=\ and P'=\ in corres_option_split; clarsimp) - apply (rule schedContextUnbindTCB_corres') - apply (rule corres_when[OF _ schedContextBindTCB_corres], fastforce) - apply (wp get_tcb_obj_ref_wp) - apply (wpsimp wp: getTCB_wp simp: mapTCBPtr_def) - apply (clarsimp simp: returnOk_def) - apply (rule_tac P=\ in hoare_TrueI) - apply (rule hoare_TrueI) - apply (rule_tac Q'="\_ s. invs s \ valid_machine_time s \ valid_sched s - \ simple_sched_action s \ current_time_bounded s \ - tcb_at t s \ ex_nonz_cap_to t s \ - (\scPtr. sc_opt = Some (Some scPtr) \ - ex_nonz_cap_to scPtr s \ - sc_tcb_sc_at ((=) None) scPtr s \ - bound_sc_tcb_at ((=) None) t s)" - in hoare_strengthen_post[rotated]) - apply (clarsimp simp: obj_at_def split: option.splits) - apply (frule invs_valid_objs) - apply (frule valid_sched_active_scs_valid) - apply (erule (1) valid_objsE) - apply (clarsimp simp: valid_obj_def valid_tcb_def obj_at_def is_sc_obj_def - invs_def valid_state_def valid_pspace_def) - apply (clarsimp split: Structures_A.kernel_object.splits) - apply (drule (2) bound_sc_tcb_bound_sc_at[where tcbptr=t]) - apply (clarsimp simp: pred_tcb_at_def obj_at_def) - apply (clarsimp simp: sc_at_ppred_def obj_at_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], fastforce split: option.split) - apply (wpsimp wp: setP_invs' hoare_vcg_all_lift hoare_vcg_const_imp_lift) - apply clarsimp - apply (prop_tac "ct_active s \ ct_released s", erule conjunct1) - 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 assumption - apply (fastforce elim: ready_qs_runnable_cross ct_active_cross split: option.splits) - apply (clarsimp simp: tcs_cross_asrt2_def) - apply (intro conjI) - apply (fastforce elim: ready_qs_runnable_cross) - apply (fastforce elim: ct_active_cross) - apply (prop_tac "cur_tcb s", fastforce) - apply (frule cur_tcb_cross) - apply fastforce - apply fastforce - apply fastforce - apply (fastforce elim: ct_released_cross_weak[simplified]) - apply (rule_tac Q'="\_. invs" in hoare_post_add) - apply (clarsimp simp: invs_cur case_option_If2 if_fun_split - cong: conj_cong imp_cong split del: if_split) - apply (wpsimp wp: hoare_vcg_all_lift hoare_vcg_const_imp_lift) - apply (rule_tac Q'="\_. invs'" in hoare_post_add) - apply (clarsimp simp: invs_queues invs_queues' case_option_If2 if_fun_split - cong: conj_cong imp_cong split del: if_split) - apply (rule_tac f="ksCurThread" in hoare_lift_Pf3) - apply (wpsimp wp: setMCPriority_invs' hoare_vcg_all_lift hoare_vcg_const_imp_lift) - apply wpsimp - apply (rule_tac Q'="\_ s. einvs s \ valid_machine_time s \ simple_sched_action s \ tcb_at t s - \ ex_nonz_cap_to t s \ ct_active s \ ct_released s - \ ct_not_in_release_q s \ current_time_bounded s \ - (\scp. sc_opt = Some (Some scp) \ ex_nonz_cap_to scp s \ - sc_tcb_sc_at ((=) None) scp s \ - bound_sc_tcb_at ((=) None) t s)" - and E'="\_. \" in hoare_strengthen_postE[rotated], fastforce split: option.splits, simp) - apply (rule hoare_vcg_conj_elimE) - apply wp - apply (wp install_tcb_cap_invs install_tcb_cap_ex_nonz_cap_to - 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) \ - (\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) - apply (wp installTCBCap_invs' installTCBCap_fh_ex_nonz_cap_to' - hoare_vcg_all_lift hoare_vcg_const_imp_lift) - apply (prop_tac "(not ep_at t) s") - apply (clarsimp simp: pred_neg_def obj_at_def is_tcb_def is_ep_def) - apply (clarsimp split: Structures_A.kernel_object.splits) - apply (fastforce simp: tcb_cap_valid_def pred_tcb_at_def pred_neg_def - sc_at_ppred_def obj_at_def is_ep_def is_tcb_def - elim: cte_wp_at_weakenE dest: tcb_ep_slot_cte_wp_ats) - 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: tcs_cross_asrt1_def) - apply (intro conjI impI allI) - apply (drule (1) tcb_ep_slot_cte_wp_ats) - apply (drule_tac p="(t, tcb_cnode_index 3)" in cte_wp_at_norm) - apply (fastforce simp: valid_fault_handler_def has_handler_rights_def - isValidFaultHandler_def is_cap_simps cte_wp_at'_def - dest!: pspace_relation_cte_wp_at[rotated]) - apply (subgoal_tac "tcb_at' t s'") - apply (clarsimp simp: state_relation_def pspace_relation_def invs_def valid_state_def - 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: other_obj_relation_def tcb_relation_def projectKOs) - apply (fastforce elim: 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 (fastforce elim: sc_at_cross) - done - -lemmas threadSet_ipcbuffer_trivial - = threadSet_invs_trivial[where F="tcbIPCBuffer_update F'" for F', - simplified inQ_def, simplified] - -lemma tc_caps_invs': - "\invs' and sch_act_simple and tcb_inv_wf' (ThreadControlCaps t sl fault_h time_h croot vroot ipcb)\ - invokeTCB (ThreadControlCaps t sl fault_h time_h croot vroot ipcb) - \\_. invs'\" - apply (simp add: split_def invokeTCB_def getThreadCSpaceRoot getThreadVSpaceRoot - getThreadBufferSlot_def locateSlot_conv - cong: option.case_cong) - apply (wpsimp wp: hoare_vcg_all_lift hoare_weak_lift_imp setP_invs' setMCPriority_invs' - installTCBCap_invs' installThreadBuffer_invs' installTCBCap_sch_act_simple) - apply (clarsimp cong: conj_cong) - apply (intro conjI; intro allI impI; clarsimp; - fastforce simp: isValidFaultHandler_def isCap_simps isValidVTableRoot_def) - 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\ - schedContextBindTCB scPtr tcbPtr - \\_. invs'\" - apply (simp add: schedContextBindTCB_def) - apply (subst bind_assoc[symmetric, where m="threadSet _ _"]) - apply (rule bind_wp)+ - apply wpsimp - apply (wpsimp wp: isSchedulable_wp) - apply (clarsimp simp: isSchedulable_bool_runnableE) - apply (wp (once) hoare_drop_imps) - apply (wp hoare_vcg_imp_lift') - apply (wp hoare_drop_imps) - 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' - threadSet_cap_to threadSet_ifunsafe'T threadSet_ctes_ofT - threadSet_valid_queues_new threadSet_valid_queues' threadSet_valid_release_queue - threadSet_valid_release_queue' untyped_ranges_zero_lift valid_irq_node_lift - valid_irq_handlers_lift'' hoare_vcg_const_imp_lift hoare_vcg_imp_lift' - threadSet_valid_replies' - | clarsimp simp: tcb_cte_cases_def cteCaps_of_def)+ - apply (clarsimp simp: invs'_def valid_pspace'_def valid_dom_schedule'_def) - by (fastforce simp: pred_tcb_at'_def obj_at'_def projectKOs - objBits_def objBitsKO_def valid_tcb'_def tcb_cte_cases_def comp_def - valid_obj'_def valid_sched_context'_def valid_sched_context_size'_def - valid_release_queue'_def inQ_def cteCaps_of_def - elim: ps_clear_domE split: if_splits) - -lemma threadSetPriority_bound_sc_tcb_at' [wp]: - "threadSetPriority tptr prio \\s. Q (bound_sc_tcb_at' P t s)\" - by (wpsimp wp: threadSet_pred_tcb_no_state simp: threadSetPriority_def) - -crunch setPriority - for sc_tcb_sc_at'[wp]: "\s. Q (obj_at' (\sc. P (scTCB sc)) p s)" - and bound_sc_tcb_at'[wp]: "\s. Q (bound_sc_tcb_at' P t s)" - and ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - (wp: crunch_wps) - -crunch setMCPriority - for sc_tcb_sc_at'[wp]: "\s. Q (obj_at' (\sc. P (scTCB sc)) p s)" - and bound_sc_tcb_at'[wp]: "\s. Q (bound_sc_tcb_at' P t s)" - and st_tcb_at'[wp]: "\s. Q (st_tcb_at' P t s)" - and ksSchedulerAction[wp]: "\s. P (ksSchedulerAction s)" - and ksReadyQueues[wp]: "\s. P (ksReadyQueues s)" - (wp: crunch_wps threadSet_pred_tcb_no_state) - -crunch finaliseCap, capSwapForDelete - for ksCurThread[wp]: "\s. P (ksCurThread s)" - (simp: crunch_simps wp: crunch_wps getObject_inv cteDelete_preservation) - -lemma updateRefillHd_sc_tcb_sc_at'[wp]: - "updateRefillHd scp f \\s. Q (obj_at' (\sc. P (scTCB sc)) p s)\" - apply (wpsimp simp: updateRefillHd_def wp: updateSchedContext_wp) - by (clarsimp simp: obj_at'_def ps_clear_upd projectKOs opt_map_red objBits_simps) - -lemma refillPopHead_sc_tcb_sc_at'[wp]: - "refillPopHead scp \\s. Q (obj_at' (\sc. P (scTCB sc)) p s)\" - apply (wpsimp simp: refillPopHead_def wp: updateSchedContext_wp) - by (clarsimp simp: obj_at'_def ps_clear_upd projectKOs opt_map_red objBits_simps) - -crunch cteInsert, emptySlot, cancelAllIPC - for sc_tcb_sc_at'[wp]: "\s. Q (obj_at' (\sc. P (scTCB sc)) p s)" - (wp: crunch_wps simp: crunch_simps ignore: updateRefillHd) - -lemma installTCBCap_fh_sc_tcb_sc_at': - "\\s. Q (obj_at' (\sc. P (scTCB sc)) p s) \ invs' s \ tcb_at' target s \ - cte_wp_at' (isValidFaultHandler \ cteCap) (cte_map (target, tcb_cnode_index 3)) s\ - installTCBCap target slot 3 slot_opt - \\_ s. Q (obj_at' (\sc. P (scTCB sc)) p s)\" - by (wpsimp wp: checkCap_inv assertDerived_wp cteDelete_fh_lift - simp: installTCBCap_def locateSlotTCB_def locateSlotBasic_def tcbFaultHandlerSlot_def - getThreadFaultHandlerSlot_def cte_level_bits_def cte_map_def - tcb_cnode_index_def objBits_defs objBits_def objBitsKO_def) - -lemma installTCBCap_fh_bound_sc_tcb_at': - "\\s. bound_sc_tcb_at' P t s \ invs' s \ tcb_at' target s \ - cte_wp_at' (isValidFaultHandler \ cteCap) (cte_map (target, tcb_cnode_index 3)) s\ - installTCBCap target slot 3 slot_opt - \\_ s. bound_sc_tcb_at' P t s\" - by (wpsimp wp: checkCap_inv assertDerived_wp cteDelete_fh_lift hoare_vcg_const_imp_lift - simp: installTCBCap_def locateSlotTCB_def locateSlotBasic_def tcbFaultHandlerSlot_def - getThreadFaultHandlerSlot_def cte_level_bits_def cte_map_def - tcb_cnode_index_def objBits_defs objBits_def objBitsKO_def) - -lemma installTCBCap_ksCurThread[wp]: - "installTCBCap target slot n slot_opt \\s. P (ksCurThread s)\" - by (wpsimp wp: checkCap_inv assertDerived_wp cteDelete_preservation split_del: if_split - simp: installTCBCap_def getThreadFaultHandlerSlot_def getThreadTimeoutHandlerSlot_def) - -lemma tc_sched_invs': - "\invs' and sch_act_simple and tcb_inv_wf' (ThreadControlSched t sl sc_fault_h mcp pri sc_opt)\ - invokeTCB (ThreadControlSched t sl sc_fault_h mcp pri sc_opt) - \\_. invs'\" - apply (simp add: invokeTCB_def) - apply (wpsimp wp: schedContextUnbindTCB_invs' schedContextBindTCB_invs') - apply (wpsimp wp: getTCB_wp simp: mapTCBPtr_def) - apply (rule_tac Q'="\rv s. invs' s \ ex_nonz_cap_to' t 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 \ - bound_sc_tcb_at' (\sc. sc = None) t s \ - bound_sc_tcb_at' bound (ksCurThread s) s)" - in hoare_strengthen_post[rotated]) - apply (fastforce simp: pred_tcb_at'_def obj_at'_def projectKOs) - apply (rule hoare_lift_Pf3[where f=ksCurThread]) - apply (wpsimp wp: setP_invs' hoare_vcg_all_lift hoare_vcg_const_imp_lift) - apply wpsimp - apply wpsimp - apply (clarsimp simp: tcs_cross_asrt2_def) - apply (wp (once) hoare_drop_imps) - apply (wpsimp wp: setMCPriority_invs' hoare_vcg_all_lift hoare_vcg_const_imp_lift) - apply (wpsimp wp: installTCBCap_invs' installTCBCap_fh_ex_nonz_cap_to' - installTCBCap_fh_bound_sc_tcb_at' installTCBCap_fh_sc_tcb_sc_at' - hoare_vcg_all_lift hoare_vcg_ball_lift2 hoare_vcg_const_imp_lift) - apply (wpsimp simp: stateAssertE_def)+ - apply (clarsimp cong: conj_cong) - apply (subgoal_tac "sc_opt = Some None \ bound_sc_tcb_at' (\a. a \ Some idle_sc_ptr) t s") - apply (fastforce simp: tcs_cross_asrt1_def comp_def isValidFaultHandler_def - isCap_simps pred_tcb_at'_def obj_at'_def projectKOs) - apply (clarsimp simp: invs'_def valid_idle'_def - pred_tcb_at'_def obj_at'_def tcs_cross_asrt1_def valid_idle'_asrt_def) - apply (frule_tac p=t and ko="ko :: tcb" for ko in sym_refs_ko_atD'[rotated]) - apply (auto simp: ko_wp_at'_def obj_at'_def projectKOs valid_idle'_def dest!: global'_no_ex_cap) - done - -lemma setSchedulerAction_invs'[wp]: - "\invs' and sch_act_wf sa\ - setSchedulerAction sa - \\_. invs'\" - apply (simp add: setSchedulerAction_def) - apply wp - apply (clarsimp simp add: invs'_def valid_irq_node'_def valid_dom_schedule'_def - valid_queues_def valid_queues_no_bitmap_def bitmapQ_defs cur_tcb'_def - ct_not_inQ_def valid_release_queue_def valid_release_queue'_def) - done - lemma invokeTCB_corres: "tcbinv_relation ti ti' \ corres (dc \ (=)) - (einvs and valid_machine_time and simple_sched_action and Tcb_AI.tcb_inv_wf ti - and current_time_bounded and ct_released and ct_active and ct_not_in_release_q) + (einvs and simple_sched_action and Tcb_AI.tcb_inv_wf ti) (invs' and sch_act_simple and tcb_inv_wf' ti') (invoke_tcb ti) (invokeTCB ti')" apply (case_tac ti, simp_all only: tcbinv_relation.simps valid_tcb_invocation_def) - apply (rule corres_guard_imp[OF invokeTCB_WriteRegisters_corres], fastforce+)[1] - apply (rule corres_guard_imp[OF invokeTCB_ReadRegisters_corres], simp+)[1] - apply (rule corres_guard_imp[OF invokeTCB_CopyRegisters_corres], fastforce+)[1] - apply (clarsimp simp del: invoke_tcb.simps) - apply (rule corres_guard_imp[OF tc_corres_caps]; clarsimp) + apply (rule corres_guard_imp [OF invokeTCB_WriteRegisters_corres], simp+)[1] + apply (rule corres_guard_imp [OF invokeTCB_ReadRegisters_corres], simp+)[1] + apply (rule corres_guard_imp [OF invokeTCB_CopyRegisters_corres], simp+)[1] apply (clarsimp simp del: invoke_tcb.simps) - apply (rename_tac word a b sc_fault_h mcp prio sc_opt sl' sc_fault_h') - apply (rule corres_guard_imp[OF tc_corres_sched]; clarsimp) - apply (clarsimp simp: invokeTCB_def liftM_def[symmetric] o_def dc_def[symmetric]) - apply (rule corres_guard_imp[OF suspend_corres]; clarsimp) - apply (clarsimp simp: invokeTCB_def liftM_def[symmetric] o_def dc_def[symmetric]) - apply (rule corres_guard_imp[OF restart_corres]; clarsimp) - apply (clarsimp simp: invokeTCB_def) + apply (rename_tac word one t2 mcp t3 t4 t5 t6 t7 t8 t9 t10 t11) + apply (rule_tac F="is_aligned word 5" in corres_req) + apply (clarsimp simp add: is_aligned_weaken [OF tcb_aligned]) + apply (rule corres_guard_imp [OF transferCaps_corres], clarsimp+) + apply (clarsimp simp: is_cnode_or_valid_arch_def + split: option.split option.split_asm) + apply clarsimp + apply (auto split: option.split_asm simp: newroot_rel_def)[1] + apply (simp add: invokeTCB_def liftM_def[symmetric] + o_def dc_def[symmetric]) + apply (rule corres_guard_imp [OF suspend_corres], simp+) + apply (simp add: invokeTCB_def liftM_def[symmetric] + o_def dc_def[symmetric]) + apply (rule corres_guard_imp [OF restart_corres], simp+) + apply (simp add:invokeTCB_def) apply (rename_tac option) - apply (case_tac option - ; clarsimp simp: liftM_def[symmetric] o_def dc_def[symmetric]) - apply (rule corres_guard_imp[OF unbindNotification_corres]; clarsimp) - apply (rule corres_guard_imp[OF bindNotification_corres] - ; clarsimp simp: obj_at'_def obj_at_def is_ntfn_def) - apply (clarsimp simp: invokeTCB_def tlsBaseRegister_def) + apply (case_tac option) + apply simp + apply (rule corres_guard_imp) + apply (rule corres_split[OF unbindNotification_corres]) + apply (rule corres_trivial, simp) + apply wp+ + apply (clarsimp) + apply clarsimp + apply simp + apply (rule corres_guard_imp) + apply (rule corres_split[OF bindNotification_corres]) + apply (rule corres_trivial, simp) + apply wp+ + apply clarsimp + apply (clarsimp simp: obj_at_def is_ntfn) + apply (clarsimp simp: obj_at'_def projectKOs) + apply (simp add: invokeTCB_def tlsBaseRegister_def) apply (rule corres_guard_imp) apply (rule corres_split[OF TcbAcc_R.asUser_setRegister_corres]) apply (rule corres_split[OF Bits_R.getCurThread_corres]) @@ -2523,10 +1758,9 @@ lemma invokeTCB_corres: apply simp apply (rule TcbAcc_R.rescheduleRequired_corres) apply (rule corres_trivial, simp) - apply (solves \wpsimp wp: hoare_drop_imp\)+ - apply (clarsimp simp: invs_valid_tcbs valid_sched_weak_strg invs_psp_aligned - valid_sched_active_scs_valid) - apply (clarsimp simp: invs_valid_queues' invs_queues invs'_valid_tcbs' invs_valid_release_queue) + apply (wpsimp wp: hoare_drop_imp)+ + apply (fastforce dest: valid_sched_valid_queues simp: valid_sched_weak_strg einvs_valid_etcbs) + apply fastforce done lemma tcbBoundNotification_caps_safe[simp]: @@ -2534,6 +1768,17 @@ lemma tcbBoundNotification_caps_safe[simp]: getF (tcbBoundNotification_update (\_. Some ntfnptr) tcb) = getF tcb" by (case_tac tcb, simp add: tcb_cte_cases_def) +lemma valid_bound_ntfn_lift: + assumes P: "\P T p. \\s. P (typ_at' T p s)\ f \\rv s. P (typ_at' T p s)\" + shows "\\s. valid_bound_ntfn' a s\ f \\rv s. valid_bound_ntfn' a s\" + apply (simp add: valid_bound_ntfn'_def, case_tac a, simp_all) + apply (wp typ_at_lifts[OF P])+ + done + +crunch setBoundNotification + for sym_heap_sched_pointers[wp]: sym_heap_sched_pointers + (ignore: threadSet wp: threadSet_sched_pointers) + lemma bindNotification_invs': "\bound_tcb_at' ((=) None) tcbptr and ex_nonz_cap_to' ntfnptr @@ -2542,16 +1787,33 @@ lemma bindNotification_invs': and invs'\ bindNotification tcbptr ntfnptr \\_. invs'\" - unfolding bindNotification_def invs'_def valid_dom_schedule'_def + including no_pre + apply (simp add: bindNotification_def invs'_def valid_state'_def) apply (rule bind_wp[OF _ get_ntfn_sp']) - apply (wpsimp wp: set_ntfn_valid_pspace' sbn_sch_act' sbn_valid_queues valid_irq_node_lift - setBoundNotification_ct_not_inQ valid_bound_ntfn_lift - untyped_ranges_zero_lift irqs_masked_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 (rule hoare_pre) + apply (wp set_ntfn_valid_pspace' sbn_sch_act' valid_irq_node_lift + setBoundNotification_ct_not_inQ valid_bound_ntfn_lift + untyped_ranges_zero_lift + | clarsimp dest!: global'_no_ex_cap simp: cteCaps_of_def)+ + apply (clarsimp simp: valid_pspace'_def) + apply (cases "tcbptr = ntfnptr") + apply (clarsimp dest!: pred_tcb_at' simp: obj_at'_def projectKOs) + apply (clarsimp simp: pred_tcb_at' conj_comms o_def) + apply (subst delta_sym_refs, assumption) + apply (fastforce simp: ntfn_q_refs_of'_def obj_at'_def projectKOs + dest!: symreftype_inverse' + split: ntfn.splits if_split_asm) + apply (clarsimp split: if_split_asm) + apply (fastforce simp: tcb_st_refs_of'_def + dest!: bound_tcb_at_state_refs_ofD' + split: if_split_asm thread_state.splits) + apply (fastforce simp: obj_at'_def projectKOs state_refs_of'_def + dest!: symreftype_inverse') + apply (clarsimp simp: valid_pspace'_def) + apply (frule_tac P="\k. k=ntfn" in obj_at_valid_objs', simp) + apply (clarsimp simp: valid_obj'_def projectKOs valid_ntfn'_def obj_at'_def + dest!: pred_tcb_at' + split: ntfn.splits) done lemma tcbntfn_invs': @@ -2570,20 +1832,22 @@ lemma setTLSBase_invs'[wp]: by (wpsimp simp: invokeTCB_def) lemma tcbinv_invs': - "\invs' and sch_act_simple and tcb_inv_wf' ti\ + "\invs' and sch_act_simple and ct_in_state' runnable' and tcb_inv_wf' ti\ invokeTCB ti \\rv. invs'\" - apply (case_tac ti; simp only:) - apply (simp add: invokeTCB_def) - apply wp - apply (clarsimp simp: invs'_def - dest!: global'_no_ex_cap) + apply (case_tac ti, simp_all only:) apply (simp add: invokeTCB_def) - apply (wp restart_invs') - apply (clarsimp simp: invs'_def + apply wp + apply (clarsimp simp: invs'_def valid_state'_def dest!: global'_no_ex_cap) - apply (wpsimp wp: tc_caps_invs' tc_sched_invs' writereg_invs' readreg_invs' - copyreg_invs' tcbntfn_invs')+ + apply (simp add: invokeTCB_def) + apply (wp restart_invs') + apply (clarsimp simp: invs'_def valid_state'_def + dest!: global'_no_ex_cap) + apply (wp tc_invs') + apply (clarsimp split: option.split dest!: isCapDs) + apply (wp writereg_invs' readreg_invs' copyreg_invs' tcbntfn_invs' + | simp)+ done declare assertDerived_wp [wp] @@ -2721,21 +1985,19 @@ lemma decodeSetPriority_corres: "\ cap_relation cap cap'; is_thread_cap cap; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras' \ \ corres (ser \ tcbinv_relation) - (cur_tcb and (\s. \x \ set extras. s \ (fst x))) + (cur_tcb and valid_etcbs and (pspace_aligned and pspace_distinct and (\s. \x \ set extras. s \ (fst x)))) (invs' and (\s. \x \ set extras'. s \' (fst x))) (decode_set_priority args cap slot extras) (decodeSetPriority args cap' extras')" apply (cases args; cases extras; cases extras'; - clarsimp simp: decode_set_priority_def decodeSetPriority_def emptyTCSched_def) + clarsimp simp: decode_set_priority_def decodeSetPriority_def) apply (rename_tac auth_cap auth_slot auth_path rest auth_cap' rest') apply (rule corres_split_eqrE) - apply (case_tac auth_cap; clarsimp simp: corres_returnOk) + apply corresKsimp apply (rule corres_splitEE[OF checkPrio_corres]) apply (rule corres_returnOkTT) apply (clarsimp simp: newroot_rel_def elim!: is_thread_cap.elims(2)) - apply wpsimp+ - apply (wpsimp simp: valid_cap_def valid_cap'_def)+ - done + by (wpsimp simp: valid_cap_def valid_cap'_def)+ lemma decodeSetMCPriority_corres: "\ cap_relation cap cap'; is_thread_cap cap; @@ -2746,20 +2008,18 @@ lemma decodeSetMCPriority_corres: (decode_set_mcpriority args cap slot extras) (decodeSetMCPriority args cap' extras')" apply (cases args; cases extras; cases extras'; - clarsimp simp: decode_set_mcpriority_def decodeSetMCPriority_def emptyTCSched_def) + clarsimp simp: decode_set_mcpriority_def decodeSetMCPriority_def) apply (rename_tac auth_cap auth_slot auth_path rest auth_cap' rest') apply (rule corres_split_eqrE) - apply (case_tac auth_cap; clarsimp simp: corres_returnOk) + apply corresKsimp apply (rule corres_splitEE[OF checkPrio_corres]) apply (rule corres_returnOkTT) apply (clarsimp simp: newroot_rel_def elim!: is_thread_cap.elims(2)) - apply wpsimp+ - apply (wpsimp simp: valid_cap_def valid_cap'_def)+ - done + by (wpsimp simp: valid_cap_def valid_cap'_def)+ lemma getMCP_sp: "\P\ threadGet tcbMCP t \\rv. mcpriority_tcb_at' (\st. st = rv) t and P\" - apply (simp add: threadGet_getObject) + apply (simp add: threadGet_def) apply wp apply (simp add: o_def pred_tcb_at'_def) apply (wp getObject_tcb_wp) @@ -2796,26 +2056,16 @@ lemma checkPrio_lt_ct_weak: apply (clarsimp simp: pred_tcb_at'_def obj_at'_def) by (rule le_ucast_ucast_le) simp -lemma checkPrio_lt_ct_weak': - "\P\ checkPrio prio auth \\rv s. P s \ mcpriority_tcb_at' (\mcp. ucast prio \ mcp) auth s\, -" - apply (wpsimp wp: hoare_vcg_conj_liftE1) - apply (wpsimp wp: checkPrio_inv) - apply (wpsimp wp: checkPrio_lt_ct_weak)+ - done - -crunch checkPrio - for tcb_at'[wp]: "tcb_at' t" - and ex_nonz_cap_to'[wp]: "ex_nonz_cap_to' t" - lemma decodeSetPriority_wf[wp]: "\invs' and tcb_at' t and ex_nonz_cap_to' t \ - decodeSetPriority args (ThreadCap t) extras - \tcb_inv_wf'\,-" + decodeSetPriority args (ThreadCap t) extras \tcb_inv_wf'\,-" unfolding decodeSetPriority_def - apply (wpsimp wp: checkPrio_lt_ct_weak simp: emptyTCSched_def) - apply (clarsimp simp: maxPriority_def numPriorities_def emptyTCSched_def) + apply (rule hoare_pre) + apply (wp checkPrio_lt_ct_weak | wpc | simp | wp (once) checkPrio_inv)+ + apply (clarsimp simp: maxPriority_def numPriorities_def) using max_word_max [of \UCAST(32 \ 8) x\ for x] - by (simp add: max_word_mask numeral_eq_Suc mask_Suc) + apply (simp add: max_word_mask numeral_eq_Suc mask_Suc) + done lemma decodeSetPriority_inv[wp]: "\P\ decodeSetPriority args cap extras \\rv. P\" @@ -2828,13 +2078,14 @@ lemma decodeSetPriority_inv[wp]: lemma decodeSetMCPriority_wf[wp]: "\invs' and tcb_at' t and ex_nonz_cap_to' t \ - decodeSetMCPriority args (ThreadCap t) extras - \tcb_inv_wf'\,-" + decodeSetMCPriority args (ThreadCap t) extras \tcb_inv_wf'\,-" unfolding decodeSetMCPriority_def Let_def - apply (wpsimp wp: checkPrio_lt_ct_weak simp: emptyTCSched_def) - apply (clarsimp simp: maxPriority_def numPriorities_def emptyTCSched_def) + apply (rule hoare_pre) + apply (wp checkPrio_lt_ct_weak | wpc | simp | wp (once) checkPrio_inv)+ + apply (clarsimp simp: maxPriority_def numPriorities_def) using max_word_max [of \UCAST(32 \ 8) x\ for x] - by (simp add: max_word_mask numeral_eq_Suc mask_Suc) + apply (simp add: max_word_mask numeral_eq_Suc mask_Suc) + done lemma decodeSetMCPriority_inv[wp]: "\P\ decodeSetMCPriority args cap extras \\rv. P\" @@ -2845,114 +2096,40 @@ lemma decodeSetMCPriority_inv[wp]: | wpcw)+ done -lemma decodeSetSchedParams_wf: - "\invs' and tcb_at' t and ex_nonz_cap_to' t and cte_at' slot - and (\s. \x \ set extras. real_cte_at' (snd x) s - \ s \' fst x \ (\y \ zobj_refs' (fst x). ex_nonz_cap_to' y s))\ - decodeSetSchedParams args (ThreadCap t) slot extras +lemma decodeSetSchedParams_wf[wp]: + "\invs' and tcb_at' t and ex_nonz_cap_to' t \ + decodeSetSchedParams args (ThreadCap t) extras \tcb_inv_wf'\,-" - unfolding decodeSetSchedParams_def scReleased_def refillReady_def scActive_def isBlocked_def - apply (cases args; cases extras; clarsimp; (solves \wpsimp wp: checkPrio_inv\)?) - apply (clarsimp split: list.splits; safe; (solves \wpsimp wp: checkPrio_inv\)?) - apply (clarsimp simp: validE_R_def) - apply (rule bindE_wp_fwd_skip, wpsimp wp: checkPrio_inv) - apply (rule bindE_wp[OF _ checkPrio_lt_ct_weak'[unfolded validE_R_def]])+ - apply (wpsimp wp: checkPrio_lt_ct_weak gts_wp' threadGet_wp) - apply (clarsimp simp: maxPriority_def numPriorities_def pred_tcb_at'_def obj_at'_def projectKOs) + unfolding decodeSetSchedParams_def + apply (wpsimp wp: checkPrio_lt_ct_weak | wp (once) checkPrio_inv)+ + apply (clarsimp simp: maxPriority_def numPriorities_def) using max_word_max [of \UCAST(32 \ 8) x\ for x] - apply (auto simp: max_word_mask numeral_eq_Suc mask_Suc) - done - -(* FIXME RT: There's probably a way to avoid this using cap.case_eq_if and corres_if, but it - doesn't seem easy to do in a nice way. This lemma is used to "keep" the cap type - information all the way through to the final WP proofs. *) -lemma corres_case_cap_null_sc: - assumes "cap_relation cp cp'" - "cp = cap.NullCap \ corres_underlying sr nf nf' rr Pnul Pnul' case_nul case_nul'" - "\sc_ptr n. cp = cap.SchedContextCap sc_ptr n \ - corres_underlying sr nf nf' rr (Psc sc_ptr n) (Psc' sc_ptr n) (case_sc sc_ptr n) - (case_sc' sc_ptr (min_sched_context_bits + n))" - "\cp \ cap.NullCap; \cap.is_SchedContextCap cp\ \ - corres_underlying sr nf nf' rr Pother Pother' case_other case_other'" - shows "corres_underlying sr nf nf' rr - (\s. (cp = cap.NullCap \ Pnul s) - \ (\sc_ptr n. cp = cap.SchedContextCap sc_ptr n \ Psc sc_ptr n s) - \ (\cap.is_SchedContextCap cp \ cp \ cap.NullCap \ Pother s)) - (\s. (cp' = NullCap \ Pnul' s) - \ (\sc_ptr n. cp = cap.SchedContextCap sc_ptr n \ Psc' sc_ptr n s) - \ (\cap.is_SchedContextCap cp \ cp \ cap.NullCap \ Pother' s)) - (case cp of cap.NullCap \ case_nul - | cap.SchedContextCap sc_ptr n \ case_sc sc_ptr n - | _ \ case_other) - (case cp' of capability.NullCap \ case_nul' - | capability.SchedContextCap sc_ptr n \ case_sc' sc_ptr n - | _ \ case_other')" - apply (insert assms) - apply (case_tac cp; clarsimp) + apply (simp add: max_word_mask numeral_eq_Suc mask_Suc) done lemma decodeSetSchedParams_corres: - "\ cap_relation cap cap'; is_thread_cap cap; slot' = cte_map slot; + "\ cap_relation cap cap'; is_thread_cap cap; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras' \ \ corres (ser \ tcbinv_relation) - (invs and valid_sched and (\s. s \ cap \ (\x \ set extras. s \ (fst x)))) - (invs' and (\s. s \' cap' \ (\x \ set extras'. s \' (fst x)))) + (cur_tcb and valid_etcbs and + (pspace_aligned and pspace_distinct and (\s. \x \ set extras. s \ (fst x)))) + (invs' and (\s. \x \ set extras'. s \' (fst x))) (decode_set_sched_params args cap slot extras) - (decodeSetSchedParams args cap' slot' extras')" - apply (clarsimp simp: is_cap_simps) - apply (simp add: decode_set_sched_params_def decodeSetSchedParams_def decode_update_sc_def - check_handler_ep_def unlessE_whenE) + (decodeSetSchedParams args cap' extras')" + apply (simp add: decode_set_sched_params_def decodeSetSchedParams_def) apply (cases "length args < 2") apply (clarsimp split: list.split) - apply (cases "length extras < 3") + apply (cases "length extras < 1") apply (clarsimp split: list.split simp: list_all2_Cons2) apply (clarsimp simp: list_all2_Cons1 neq_Nil_conv val_le_length_Cons linorder_not_less) - apply (case_tac cap; clarsimp) - apply (rule corres_split_eqrE[THEN corres_guard_imp]) - apply (clarsimp split: cap.splits - ; intro conjI impI allI - ; fastforce intro: corres_returnOkTT) - apply (rule corres_split_norE[OF checkPrio_corres]) - apply (rule corres_split_norE[OF checkPrio_corres]) - apply (rule corres_split_eqrE) - apply (rule corres_case_cap_null_sc[where Pother=\ and Pother'=\] - ; clarsimp - ; (wpfix add: capability.sel)?) - apply (clarsimp simp: getCurThread_def) - apply (rule corres_split_liftEE[OF corres_gets_trivial]) - apply (clarsimp simp: state_relation_def) - apply (rule whenE_throwError_corres; clarsimp) - apply (rule corres_returnOkTT, simp) - apply wpsimp - apply wpsimp - apply (clarsimp simp: get_tcb_obj_ref_def) - apply (rule corres_split_eqrE) - apply clarsimp - apply (rule threadGet_corres) - apply (clarsimp simp: tcb_relation_def) - apply (rule whenE_throwError_corres; clarsimp) - apply (rule corres_split_liftEE[OF get_sc_corres]) - apply (rule whenE_throwError_corres; clarsimp simp: sc_relation_def) - apply (rule corres_split_liftEE[OF is_blocked_corres]) - apply (rule corres_split_liftEE[OF get_sc_released_corres]) - apply (rule whenE_throwError_corres; clarsimp) - apply (rule corres_returnOkTT, simp) - apply (wpsimp simp: is_blocked_def)+ - apply (wpsimp wp: thread_get_wp' threadGet_wp)+ - apply (clarsimp simp: bindE_assoc) - apply (rule whenE_throwError_corres; simp add: cap_rel_valid_fh) - apply (rule corres_returnOkTT) - apply (clarsimp simp: newroot_rel_def) - apply (wpsimp wp: check_prio_inv checkPrio_inv)+ - 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 projectKOs) - apply (rename_tac obj) - apply (case_tac obj; clarsimp) - apply (erule invs_valid_objs') - apply (clarsimp simp: obj_at'_def) + apply (rule corres_split_eqrE) + apply corresKsimp + apply (rule corres_split_norE[OF checkPrio_corres]) + apply (rule corres_splitEE[OF checkPrio_corres]) + apply (rule corres_returnOkTT) + apply (clarsimp simp: newroot_rel_def elim!: is_thread_cap.elims(2)) + apply (wpsimp wp: check_prio_inv checkPrio_inv + simp: valid_cap_def valid_cap'_def)+ done lemma checkValidIPCBuffer_corres: @@ -2960,7 +2137,9 @@ lemma checkValidIPCBuffer_corres: corres (ser \ dc) \ \ (check_valid_ipc_buffer vptr cap) (checkValidIPCBuffer vptr cap')" - apply (simp add: check_valid_ipc_buffer_def checkValidIPCBuffer_def + apply (simp add: check_valid_ipc_buffer_def + checkValidIPCBuffer_def + ARM_H.checkValidIPCBuffer_def unlessE_def Let_def split: cap_relation_split_asm arch_cap.split_asm bool.splits) apply (simp add: capTransferDataSize_def msgMaxLength_def @@ -2975,7 +2154,9 @@ lemma checkValidIPCBuffer_ArchObject_wp: "\\s. isArchObjectCap cap \ is_aligned x msg_align_bits \ P s\ checkValidIPCBuffer x cap \\rv s. P s\,-" - apply (simp add: checkValidIPCBuffer_def whenE_def unlessE_def + apply (simp add: checkValidIPCBuffer_def + ARM_H.checkValidIPCBuffer_def + whenE_def unlessE_def cong: capability.case_cong arch_capability.case_cong split del: if_split) @@ -2993,21 +2174,22 @@ lemma decodeSetIPCBuffer_corres: (\s. invs' s \ (\x \ set extras'. cte_at' (snd x) s)) (decode_set_ipc_buffer args cap slot extras) (decodeSetIPCBuffer args cap' (cte_map slot) extras')" - apply (simp add: decode_set_ipc_buffer_def decodeSetIPCBuffer_def) + apply (simp add: decode_set_ipc_buffer_def decodeSetIPCBuffer_def + split del: if_split) apply (cases args) apply simp apply (cases extras) apply simp - apply (clarsimp simp: list_all2_Cons1 liftME_def[symmetric] is_cap_simps) - apply (clarsimp simp: returnOk_def newroot_rel_def emptyTCCaps_def) + apply (clarsimp simp: list_all2_Cons1 liftME_def[symmetric] + is_cap_simps + split del: if_split) + apply (clarsimp simp add: returnOk_def newroot_rel_def) apply (rule corres_guard_imp) apply (rule corres_splitEE) apply (rule deriveCap_corres; simp) - apply (simp add: o_def newroot_rel_def dc_def[symmetric]) - apply (rule corres_rel_imp) - apply (erule checkValidIPCBuffer_corres) - apply (simp add: dc_def) - apply wpsimp+ + apply (simp add: o_def newroot_rel_def split_def dc_def[symmetric]) + apply (erule checkValidIPCBuffer_corres) + apply (wp hoareE_TrueI | simp)+ apply fastforce done @@ -3016,7 +2198,7 @@ lemma decodeSetIPC_wf[wp]: and (\s. \v \ set extras. s \' fst v \ cte_at' (snd v) s)\ decodeSetIPCBuffer args (ThreadCap t) slot extras \tcb_inv_wf'\,-" - apply (simp add: decodeSetIPCBuffer_def Let_def whenE_def emptyTCCaps_def + apply (simp add: decodeSetIPCBuffer_def Let_def whenE_def split del: if_split cong: list.case_cong prod.case_cong) apply (rule hoare_pre) apply (wp | wpc | simp)+ @@ -3027,14 +2209,14 @@ lemma decodeSetIPC_wf[wp]: done lemma decodeSetIPCBuffer_is_tc[wp]: - "\\\ decodeSetIPCBuffer args cap slot extras \\rv s. isThreadControlCaps rv\,-" - apply (simp add: decodeSetIPCBuffer_def Let_def emptyTCCaps_def + "\\\ decodeSetIPCBuffer args cap slot extras \\rv s. isThreadControl rv\,-" + apply (simp add: decodeSetIPCBuffer_def Let_def split del: if_split cong: list.case_cong prod.case_cong) apply (rule hoare_pre) apply (wp | wpc)+ - apply (simp only: isThreadControlCaps_def tcbinvocation.simps) + apply (simp only: isThreadControl_def tcbinvocation.simps) apply wp+ - apply (clarsimp simp: isThreadControlCaps_def) + apply (clarsimp simp: isThreadControl_def) done crunch decodeSetIPCBuffer @@ -3074,54 +2256,56 @@ lemma cap_CNode_case_throw: = (doE unlessE (isCNodeCap cap) (throw x); m odE)" by (cases cap, simp_all add: isCap_simps unlessE_def) -lemma decodeCVSpace_corres: +lemma decodeSetSpace_corres: notes if_cong [cong] shows - "\cap_relation cap cap'; - list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras'; - is_thread_cap cap\ \ - corres (ser \ (\abs_inv conc_inv. tcbinv_relation abs_inv conc_inv)) - (invs and valid_cap cap and (\s. \x \ set extras. cte_at (snd x) s)) - (invs' and valid_cap' cap' and (\s. \x \ set extras'. cte_at' (snd x) s)) - (decode_cv_space args cap slot extras) - (decodeCVSpace args cap' (cte_map slot) extras')" - apply (simp add: decode_cv_space_def decodeCVSpace_def + "\ cap_relation cap cap'; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras'; + is_thread_cap cap \ \ + corres (ser \ tcbinv_relation) + (invs and valid_cap cap and (\s. \x \ set extras. cte_at (snd x) s)) + (invs' and valid_cap' cap' and (\s. \x \ set extras'. cte_at' (snd x) s)) + (decode_set_space args cap slot extras) + (decodeSetSpace args cap' (cte_map slot) extras')" + apply (simp add: decode_set_space_def decodeSetSpace_def Let_def split del: if_split) - apply (cases "2 \ length args \ 2 \ length extras'") + apply (cases "3 \ length args \ 2 \ length extras'") apply (clarsimp simp: val_le_length_Cons list_all2_Cons2 split del: if_split) - apply (simp add: liftE_bindE liftM_def cap_CNode_case_throw - unlessE_throwError_returnOk unlessE_whenE + apply (simp add: liftE_bindE liftM_def unlessE_whenE getThreadCSpaceRoot getThreadVSpaceRoot split del: if_split) apply (rule corres_guard_imp) apply (rule corres_split[OF slotCapLongRunningDelete_corres]) apply (clarsimp simp: is_cap_simps get_tcb_ctable_ptr_def cte_map_tcb_0) apply (rule corres_split[OF slotCapLongRunningDelete_corres]) - apply (clarsimp simp: is_cap_simps get_tcb_vtable_ptr_def cte_map_tcb_1[simplified]) + apply (clarsimp simp: is_cap_simps get_tcb_vtable_ptr_def cte_map_tcb_1[simplified] objBits_defs) apply (rule corres_split_norE) apply (rule corres_whenE) apply simp apply (rule corres_trivial, simp) apply simp - apply (simp(no_asm) add: bindE_assoc + apply (simp(no_asm) add: split_def unlessE_throwError_returnOk + bindE_assoc cap_CNode_case_throw unlessE_whenE split del: if_split) - apply (rule corres_splitEE[OF deriveCap_corres]) - apply (fastforce dest: list_all2_nthD2[where p=0] simp: cap_map_update_data) - apply (fastforce dest: list_all2_nthD2[where p=0]) + apply (rule corres_splitEE) + apply (rule deriveCap_corres) + apply (clarsimp simp: cap_map_update_data) + apply simp apply (rule corres_split_norE) apply (rule corres_whenE) apply simp apply (rule corres_trivial, simp) apply simp - apply (rule corres_splitEE[OF deriveCap_corres]) - apply (clarsimp simp: cap_map_update_data) + apply (rule corres_splitEE) + apply (rule deriveCap_corres) + apply (fastforce dest: list_all2_nthD2[where p=0] simp: cap_map_update_data) apply simp apply (rule corres_split_norE) + apply (unfold unlessE_whenE) apply (rule corres_whenE) apply (case_tac vroot_cap', simp_all add: - is_valid_vtable_root_def + is_valid_vtable_root_def isValidVTableRoot_def ARM_H.isValidVTableRoot_def)[1] apply (rename_tac arch_cap) apply (clarsimp, case_tac arch_cap, simp_all)[1] @@ -3146,74 +2330,12 @@ lemma decodeCVSpace_corres: apply (clarsimp split: list.split) done -lemma decode_cv_space_is_ThreadControlCaps[wp]: - "\\\ - decode_cv_space args cap slot excaps - \\rv s. tcb_invocation.is_ThreadControlCaps rv\, -" - apply (clarsimp simp: decode_cv_space_def returnOk_def validE_R_def) - apply (rule bindE_wp_fwd_skip, wpsimp)+ - apply (clarsimp simp: return_def validE_def valid_def) - done - -lemma decodeSetSpace_corres: - "\cap_relation cap cap'; - list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras'; - is_thread_cap cap\ \ - corres (ser \ tcbinv_relation) - (invs and valid_cap cap and (\s. \x \ set extras. cte_at (snd x) s)) - (invs' and valid_cap' cap' and (\s. \x \ set extras'. cte_at' (snd x) s)) - (decode_set_space args cap slot extras) - (decodeSetSpace args cap' (cte_map slot) extras')" - apply (simp add: decode_set_space_def decodeSetSpace_def check_handler_ep_def unlessE_whenE) - apply (cases "\ (2 \ length args \ 3 \ length extras')") - apply (clarsimp dest!: list_all2_lengthD split: list.split) - apply fastforce - apply (clarsimp simp: val_le_length_Cons list_all2_Cons2 - split del: if_split) - apply (rule corres_guard_imp) - apply (rule corres_splitEE[OF decodeCVSpace_corres]) - apply blast - apply fastforce+ - apply (rename_tac abs_space conc_space) - apply (rule_tac F="tcb_invocation.is_ThreadControlCaps abs_space" in corres_gen_asm) - apply clarsimp - apply (intro conjI impI; simp add: cap_rel_valid_fh) - apply (prop_tac "newroot_rel (tc_new_croot abs_space) (tcCapsCRoot conc_space)") - apply (case_tac abs_space; clarsimp) - apply (prop_tac "newroot_rel (tc_new_vroot abs_space) (tcCapsVRoot conc_space)") - apply (case_tac abs_space; clarsimp) - apply (rule corres_returnOkTT) - apply (clarsimp simp: returnOk_def newroot_rel_def is_cap_simps list_all2_conv_all_nth) - apply wp+ - apply fastforce+ - done - -lemma decodeCVSpace_wf[wp]: - "\invs' and tcb_at' t and ex_nonz_cap_to' t and cte_at' slot - and (\s. \x \ set extras. s \' fst x \ cte_at' (snd x) s \ t \ snd x \ t + 16 \ snd x)\ - decodeCVSpace args (ThreadCap t) slot extras - \tcb_inv_wf'\,-" - apply (simp add: decodeCVSpace_def Let_def split_def - unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot - cap_CNode_case_throw - split del: if_split cong: if_cong list.case_cong) - apply (rule hoare_pre) - apply (wp - | simp add: o_def split_def - split del: if_split - | wpc - | rule hoare_drop_imps)+ - apply (clarsimp simp del: length_greater_0_conv - split del: if_split) - apply (simp del: length_greater_0_conv add: valid_updateCapDataI) - done - lemma decodeSetSpace_wf[wp]: "\invs' and tcb_at' t and ex_nonz_cap_to' t and cte_at' slot and (\s. \x \ set extras. s \' fst x \ cte_at' (snd x) s \ t \ snd x \ t + 16 \ snd x)\ decodeSetSpace args (ThreadCap t) slot extras \tcb_inv_wf'\,-" - apply (simp add: decodeSetSpace_def decodeCVSpace_def Let_def split_def + apply (simp add: decodeSetSpace_def Let_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot cap_CNode_case_throw split del: if_split cong: if_cong list.case_cong) @@ -3228,20 +2350,9 @@ lemma decodeSetSpace_wf[wp]: apply (simp del: length_greater_0_conv add: valid_updateCapDataI) done -lemma decodeCVSpace_inv[wp]: - "decodeCVSpace args cap slot extras \P\" - apply (simp add: decodeCVSpace_def Let_def split_def - unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot - split del: if_split cong: if_cong list.case_cong) - apply (rule hoare_pre) - apply (wp hoare_drop_imps - | simp add: o_def split_def split del: if_split - | wpcw)+ - done - lemma decodeSetSpace_inv[wp]: "\P\ decodeSetSpace args cap slot extras \\rv. P\" - apply (simp add: decodeSetSpace_def decodeCVSpace_def Let_def split_def + apply (simp add: decodeSetSpace_def Let_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot split del: if_split cong: if_cong list.case_cong) apply (rule hoare_pre) @@ -3250,44 +2361,20 @@ lemma decodeSetSpace_inv[wp]: | wpcw)+ done -lemma decodeCVSpace_is_tc[wp]: - "\\\ decodeCVSpace args cap slot extras \\rv s. isThreadControlCaps rv\,-" - apply (simp add: decodeCVSpace_def Let_def split_def - unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot - split del: if_split cong: list.case_cong) - apply (rule hoare_pre) - apply (wp hoare_drop_imps - | simp only: isThreadControlCaps_def tcbinvocation.simps - | wpcw)+ - apply simp - done - lemma decodeSetSpace_is_tc[wp]: - "\\\ decodeSetSpace args cap slot extras \\rv s. isThreadControlCaps rv\,-" + "\\\ decodeSetSpace args cap slot extras \\rv s. isThreadControl rv\,-" apply (simp add: decodeSetSpace_def Let_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot split del: if_split cong: list.case_cong) apply (rule hoare_pre) apply (wp hoare_drop_imps - | simp only: isThreadControlCaps_def tcbinvocation.simps - | wpcw)+ - apply simp - done - -lemma decodeCVSpace_tc_target[wp]: - "\\s. P (capTCBPtr cap)\ decodeCVSpace args cap slot extras \\rv s. P (tcCapsTarget rv)\,-" - apply (simp add: decodeCVSpace_def Let_def split_def - unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot - split del: if_split cong: list.case_cong) - apply (rule hoare_pre) - apply (wp hoare_drop_imps - | simp only: tcbinvocation.sel + | simp only: isThreadControl_def tcbinvocation.simps | wpcw)+ apply simp done lemma decodeSetSpace_tc_target[wp]: - "\\s. P (capTCBPtr cap)\ decodeSetSpace args cap slot extras \\rv s. P (tcCapsTarget rv)\,-" + "\\s. P (capTCBPtr cap)\ decodeSetSpace args cap slot extras \\rv s. P (tcThread rv)\,-" apply (simp add: decodeSetSpace_def Let_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot split del: if_split cong: list.case_cong) @@ -3298,18 +2385,8 @@ lemma decodeSetSpace_tc_target[wp]: apply simp done -lemma decodeCVSpace_tc_slot[wp]: - "\\s. P slot\ decodeCVSpace args cap slot extras \\rv s. P (tcCapsSlot rv)\,-" - apply (simp add: decodeCVSpace_def split_def unlessE_def - getThreadVSpaceRoot getThreadCSpaceRoot - cong: list.case_cong) - apply (rule hoare_pre) - apply (wp hoare_drop_imps | wpcw | simp only: tcbinvocation.sel)+ - apply simp - done - lemma decodeSetSpace_tc_slot[wp]: - "\\s. P slot\ decodeSetSpace args cap slot extras \\rv s. P (tcCapsSlot rv)\,-" + "\\s. P slot\ decodeSetSpace args cap slot extras \\rv s. P (tcThreadCapSlot rv)\,-" apply (simp add: decodeSetSpace_def split_def unlessE_def getThreadVSpaceRoot getThreadCSpaceRoot cong: list.case_cong) @@ -3321,52 +2398,40 @@ lemma decodeSetSpace_tc_slot[wp]: lemma decodeTCBConfigure_corres: notes if_cong [cong] option.case_cong [cong] shows - "\cap_relation cap cap'; - list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras'; - is_thread_cap cap\ \ - corres (ser \ tcbinv_relation) - (einvs and valid_cap cap and (\s. \x \ set extras. cte_at (snd x) s)) - (invs' and valid_cap' cap' and (\s. \x \ set extras'. cte_at' (snd x) s)) + "\ cap_relation cap cap'; list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras'; + is_thread_cap cap \ \ + corres (ser \ tcbinv_relation) (einvs and valid_cap cap and (\s. \x \ set extras. cte_at (snd x) s)) + (invs' and valid_cap' cap' and (\s. \x \ set extras'. cte_at' (snd x) s)) (decode_tcb_configure args cap slot extras) (decodeTCBConfigure args cap' (cte_map slot) extras')" apply (clarsimp simp add: decode_tcb_configure_def decodeTCBConfigure_def) + apply (cases "length args < 4") apply (clarsimp split: list.split) apply (cases "length extras < 3") - apply (clarsimp split: list.split simp: list_all2_Cons2) - apply (clarsimp simp: linorder_not_less val_le_length_Cons list_all2_Cons1 priorityBits_def) + apply (clarsimp split: list.split simp: list_all2_Cons2) + apply (clarsimp simp: linorder_not_less val_le_length_Cons list_all2_Cons1 + priorityBits_def) apply (rule corres_guard_imp) apply (rule corres_splitEE) apply (rule decodeSetIPCBuffer_corres; simp) apply (rule corres_splitEE) - apply (rule decodeCVSpace_corres; simp) - apply (rule_tac F="tcb_invocation.is_ThreadControlCaps set_params" in corres_gen_asm) - apply (rule_tac F="tcb_invocation.is_ThreadControlCaps set_space" in corres_gen_asm) - apply (rule_tac F="tcCapsSlot setSpace = cte_map slot" in corres_gen_asm2) + apply (rule decodeSetSpace_corres; simp) + apply (rule_tac F="tcb_invocation.is_ThreadControl set_params" in corres_gen_asm) + apply (rule_tac F="tcb_invocation.is_ThreadControl set_space" in corres_gen_asm) + apply (rule_tac F="tcThreadCapSlot setSpace = cte_map slot" in corres_gen_asm2) apply (rule corres_trivial) - apply (clarsimp simp: returnOk_def is_cap_simps newroot_rel_def - tcb_invocation.is_ThreadControlCaps_def) - apply (wpsimp simp: invs_def valid_sched_def)+ + apply (clarsimp simp: tcb_invocation.is_ThreadControl_def returnOk_def is_cap_simps) + apply (wp | simp add: invs_def valid_sched_def)+ done lemma isThreadControl_def2: - "isThreadControlCaps tinv = (\a b c d e f g. tinv = ThreadControlCaps a b c d e f g)" - by (cases tinv, simp_all add: isThreadControlCaps_def) - -lemma decodeCVSpaceSome[wp]: - "\\\ decodeCVSpace xs cap y zs - \\rv s. tcCapsCRoot rv \ None\,-" - apply (simp add: decodeCVSpace_def split_def cap_CNode_case_throw - cong: list.case_cong if_cong del: not_None_eq) - apply (rule hoare_pre) - apply (wp hoare_drop_imps | wpcw - | simp only: tcbinvocation.sel option.simps)+ - apply simp - done + "isThreadControl tinv = (\a b c d e f g h. tinv = ThreadControl a b c d e f g h)" + by (cases tinv, simp_all add: isThreadControl_def) lemma decodeSetSpaceSome[wp]: "\\\ decodeSetSpace xs cap y zs - \\rv s. tcCapsCRoot rv \ None\,-" - apply (simp add: decodeSetSpace_def decodeCVSpace_def split_def cap_CNode_case_throw + \\rv s. tcNewCRoot rv \ None\,-" + apply (simp add: decodeSetSpace_def split_def cap_CNode_case_throw cong: list.case_cong if_cong del: not_None_eq) apply (rule hoare_pre) apply (wp hoare_drop_imps | wpcw @@ -3384,8 +2449,8 @@ lemma decodeTCBConf_wf[wp]: apply (rule hoare_pre) apply (wp | wpc)+ apply (rule_tac Q'="\setSpace s. tcb_inv_wf' setSpace s \ tcb_inv_wf' setIPCParams s - \ isThreadControlCaps setSpace \ isThreadControlCaps setIPCParams - \ tcCapsTarget setSpace = t \ tcCapsCRoot setSpace \ None" + \ isThreadControl setSpace \ isThreadControl setIPCParams + \ tcThread setSpace = t \ tcNewCRoot setSpace \ None" in hoare_strengthen_postE_R) apply wp apply (clarsimp simp: isThreadControl_def2 cong: option.case_cong) @@ -3455,7 +2520,7 @@ notes if_cong[cong] shows apply (wp | simp add: whenE_def split del: if_split)+ apply (wp | wpc | simp)+ 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 dest: hd_in_set)+ done lemma decodeUnbindNotification_corres: @@ -3481,19 +2546,7 @@ lemma decodeSetTLSBase_corres: (decode_set_tls_base w (cap.ThreadCap t)) (decodeSetTLSBase w (capability.ThreadCap t))" by (clarsimp simp: decode_set_tls_base_def decodeSetTLSBase_def returnOk_def - split: list.split) - -lemma decodeSetTimeoutEndpoint_corres: - "list_all2 (\(c, sl) (c', sl'). cap_relation c c' \ sl' = cte_map sl) extras extras' \ - corres (ser \ tcbinv_relation) (tcb_at t) (tcb_at' t) - (decode_set_timeout_ep (cap.ThreadCap t) slot extras) - (decodeSetTimeoutEndpoint (capability.ThreadCap t) (cte_map slot) extras')" - apply (clarsimp simp: decode_set_timeout_ep_def decodeSetTimeoutEndpoint_def) - apply (cases extras; cases extras'; clarsimp) - apply (fastforce simp: check_handler_ep_def unlessE_def returnOk_def bindE_def - newroot_rel_def emptyTCCaps_def throwError_def - dest: cap_rel_valid_fh) - done + split: list.split) lemma decodeTCBInvocation_corres: "\ c = Structures_A.ThreadCap t; cap_relation c c'; @@ -3522,16 +2575,16 @@ lemma decodeTCBInvocation_corres: corres_guard_imp[OF decodeSetSpace_corres] corres_guard_imp[OF decodeBindNotification_corres] corres_guard_imp[OF decodeUnbindNotification_corres] - corres_guard_imp[OF decodeSetTLSBase_corres] - corres_guard_imp[OF decodeSetTimeoutEndpoint_corres], - simp_all add: valid_cap_simps valid_cap_simps' invs_def valid_sched_def) + corres_guard_imp[OF decodeSetTLSBase_corres], + simp_all add: valid_cap_simps valid_cap_simps' invs_def valid_state_def + valid_pspace_def valid_sched_def) apply (auto simp: list_all2_map1 list_all2_map2 elim!: list_all2_mono) done crunch decodeTCBInvocation - for inv[wp]: P - (simp: crunch_simps wp: crunch_wps) + for inv[wp]: P +(simp: crunch_simps) lemma real_cte_at_not_tcb_at': "real_cte_at' x s \ \ tcb_at' x s" @@ -3550,9 +2603,9 @@ lemma decodeBindNotification_wf: apply (rule hoare_pre) apply (wp getNotification_wp getObject_tcb_wp | wpc - | simp add: threadGet_getObject getBoundNotification_def)+ + | simp add: threadGet_def getBoundNotification_def)+ apply (fastforce simp: valid_cap'_def[where c="capability.ThreadCap t"] - is_ntfn invs_def valid_pspace'_def + is_ntfn invs_def valid_state'_def valid_pspace'_def projectKOs null_def pred_tcb_at'_def obj_at'_def dest!: global'_no_ex_cap hd_in_set) done @@ -3562,7 +2615,7 @@ lemma decodeUnbindNotification_wf: decodeUnbindNotification (capability.ThreadCap t) \tcb_inv_wf'\,-" apply (simp add: decodeUnbindNotification_def) - apply (wp getObject_tcb_wp | wpc | simp add: threadGet_getObject getBoundNotification_def)+ + apply (wp getObject_tcb_wp | wpc | simp add: threadGet_def getBoundNotification_def)+ apply (auto simp: obj_at'_def pred_tcb_at'_def) done @@ -3574,36 +2627,37 @@ lemma decodeSetTLSBase_wf: cong: list.case_cong) by wpsimp -lemma decodeSetTimeoutEndpoint_wf[wp]: - "\invs' and tcb_at' t and ex_nonz_cap_to' t and cte_at' slot - and (\s. \x \ set extras. s \' fst x \ cte_at' (snd x) s)\ - decodeSetTimeoutEndpoint (ThreadCap t) slot extras - \tcb_inv_wf'\,-" - apply (simp add: decodeSetTimeoutEndpoint_def emptyTCCaps_def - cong: list.case_cong) - apply wpsimp - done - lemma decodeTCBInv_wf: "\invs' and tcb_at' t and cte_at' slot and ex_nonz_cap_to' t and (\s. \x \ set extras. real_cte_at' (snd x) s \ s \' fst x \ (\y \ zobj_refs' (fst x). ex_nonz_cap_to' y s))\ - decodeTCBInvocation label args (capability.ThreadCap t) slot extras + decodeTCBInvocation label args (capability.ThreadCap t) slot extras \tcb_inv_wf'\,-" apply (simp add: decodeTCBInvocation_def Let_def cong: if_cong gen_invocation_labels.case_cong split del: if_split) apply (rule hoare_pre) apply (wpc, (wp decodeTCBConf_wf decodeReadReg_wf decodeWriteReg_wf decodeSetTLSBase_wf - decodeCopyReg_wf decodeBindNotification_wf decodeUnbindNotification_wf - decodeSetSchedParams_wf)+) + decodeCopyReg_wf decodeBindNotification_wf decodeUnbindNotification_wf)+) apply (clarsimp simp: real_cte_at') apply (fastforce simp: real_cte_at_not_tcb_at' objBits_defs) done crunch getThreadBufferSlot, setPriority, setMCPriority for irq_states'[wp]: valid_irq_states' - (simp: crunch_simps wp: crunch_wps) + (simp: crunch_simps) +lemma inv_tcb_IRQInactive: + "\valid_irq_states'\ invokeTCB tcb_inv + -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + including classic_wp_pre + apply (simp add: invokeTCB_def) + apply (rule hoare_pre) + apply (wpc | + wp withoutPreemption_R cteDelete_IRQInactive checkCap_inv + hoare_vcg_const_imp_liftE_R cteDelete_irq_states' + hoare_vcg_const_imp_lift | + simp add: split_def)+ + done end diff --git a/proof/refine/ARM/Untyped_R.thy b/proof/refine/ARM/Untyped_R.thy index cbaac7a76d..5592f4b2eb 100644 --- a/proof/refine/ARM/Untyped_R.thy +++ b/proof/refine/ARM/Untyped_R.thy @@ -9,7 +9,7 @@ theory Untyped_R imports Detype_R Invocations_R InterruptAcc_R begin -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) primrec untypinv_relation :: "Invocations_A.untyped_invocation \ @@ -35,8 +35,6 @@ where \ distinct (slot # slots) \ (ty = APIObjectType ArchTypes_H.CapTableObject \ us > 0) \ (ty = APIObjectType ArchTypes_H.Untyped \ minUntypedSizeBits \ us \ us \ maxUntypedSizeBits) - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ (\slot \ set slots. cte_wp_at' (\c. cteCap c = NullCap) slot s) \ (\slot \ set slots. ex_cte_cap_to' slot s) \ sch_act_simple s \ 0 < length slots @@ -196,12 +194,12 @@ next apply (simp add: returnOk_def APIType_map2_def toEnum_def enum_apiobject_type enum_object_type) apply (intro conjI impI) - apply (subgoal_tac "unat v - 7 > 5") + apply (subgoal_tac "unat v - 5 > 5") apply (simp add: arch_data_to_obj_type_def) apply simp - apply (subgoal_tac "\n. unat v = n + 7") + apply (subgoal_tac "\n. unat v = n + 5") apply (clarsimp simp: arch_data_to_obj_type_def returnOk_def) - apply (rule_tac x="unat v - 7" in exI) + apply (rule_tac x="unat v - 5" in exI) apply arith done have S: "\x (y :: ('g :: len) word) (z :: 'g word) bits. \ bits < len_of TYPE('g); x < 2 ^ bits \ \ toEnum x = (of_nat x :: 'g word)" @@ -248,7 +246,8 @@ next pageBits_def pdBits_def ptBits_def) apply (rename_tac apiobject_type) apply (case_tac apiobject_type) - apply (simp_all add:apiGetObjectSize_def objBits_simps' slot_bits_def pdeBits_def pteBits_def) + apply (simp_all add:apiGetObjectSize_def tcbBlockSizeBits_def epSizeBits_def + ntfnSizeBits_def slot_bits_def cteSizeBits_def pdeBits_def pteBits_def) done obtain if_res where if_res_def: "\reset. if_res reset = (if reset then 0 else idx)" by auto @@ -295,14 +294,14 @@ next apply (clarsimp simp: fromAPIType_def) apply (rule whenE_throwError_corres, simp) apply (clarsimp simp: fromAPIType_def) - apply (rule whenE_throwError_corres, simp) - apply (clarsimp simp: fromAPIType_def min_sched_context_bits_def minSchedContextBits_def) - apply (rule_tac r' = "\cap cap'. cap_relation cap cap'" in corres_splitEE[OF corres_if]) - apply simp + apply (rule_tac r' = "\cap cap'. cap_relation cap cap'" + in corres_splitEE) + apply (rule corres_if, simp) apply (rule corres_returnOkTT) apply (rule crel) apply simp - apply (rule corres_splitEE[OF lookupSlotForCNodeOp_corres]) + apply (rule corres_splitEE) + apply (rule lookupSlotForCNodeOp_corres) apply (rule crel) apply simp apply simp @@ -454,101 +453,98 @@ lemma ctes_of_ko: (\ptr\capRange cap. \optr ko. ksPSpace s optr = Some ko \ ptr \ obj_range' optr ko)" apply (case_tac cap) - \ \TCB case\ - apply (simp_all add: isCap_simps capRange_def) - apply (clarsimp simp: valid_cap'_def obj_at'_def) - apply (intro exI conjI, assumption) - apply (clarsimp simp: projectKO_eq objBits_def obj_range'_def - dest!: projectKO_opt_tcbD simp: objBitsKO_def) - \ \NTFN case\ - apply (clarsimp simp: valid_cap'_def obj_at'_def) - apply (intro exI conjI, assumption) - apply (clarsimp simp: projectKO_eq objBits_def obj_range'_def projectKO_ntfn objBitsKO_def) - \ \EP case\ + \ \TCB case\ + apply (simp_all add: isCap_simps capRange_def) apply (clarsimp simp: valid_cap'_def obj_at'_def) apply (intro exI conjI, assumption) - apply (clarsimp simp: projectKO_eq objBits_def obj_range'_def projectKO_ep objBitsKO_def) - \ \Zombie case\ - apply (rename_tac word zombie_type nat) - apply (case_tac zombie_type) - apply (clarsimp simp: valid_cap'_def obj_at'_def) + apply (clarsimp simp: projectKO_eq objBits_def obj_range'_def + dest!: projectKO_opt_tcbD simp: objBitsKO_def) + \ \NTFN case\ + apply (clarsimp simp: valid_cap'_def obj_at'_def) + apply (intro exI conjI, assumption) + apply (clarsimp simp: projectKO_eq objBits_def + obj_range'_def projectKO_ntfn objBitsKO_def) + \ \EP case\ + apply (clarsimp simp: valid_cap'_def obj_at'_def) + apply (intro exI conjI, assumption) + apply (clarsimp simp: projectKO_eq objBits_def + obj_range'_def projectKO_ep objBitsKO_def) + \ \Zombie case\ + apply (rename_tac word zombie_type nat) + apply (case_tac zombie_type) + apply (clarsimp simp: valid_cap'_def obj_at'_def) + apply (intro exI conjI, assumption) + apply (clarsimp simp: projectKO_eq objBits_simps' obj_range'_def dest!:projectKO_opt_tcbD) + apply (clarsimp simp: valid_cap'_def obj_at'_def capAligned_def + objBits_simps' projectKOs) + apply (frule_tac ptr=ptr and sz=4 in nasty_range [where 'a=32, folded word_bits_def], simp+) + apply clarsimp + apply (drule_tac x=idx in spec) + apply (clarsimp simp: less_mask_eq) + apply (fastforce simp: obj_range'_def projectKOs objBits_simps' field_simps)[1] + \ \Arch cases\ + apply (rename_tac arch_capability) + apply (case_tac arch_capability) + \ \ASID case\ + apply (clarsimp simp: valid_cap'_def typ_at'_def ko_wp_at'_def) apply (intro exI conjI, assumption) - apply (clarsimp simp: projectKO_eq objBits_simps' obj_range'_def dest!:projectKO_opt_tcbD) - apply (clarsimp simp: valid_cap'_def obj_at'_def capAligned_def objBits_simps' projectKOs) - apply (frule_tac ptr=ptr and sz=4 in nasty_range [where 'a=32, folded word_bits_def], simp+) - apply clarsimp - apply (drule_tac x=idx in spec) - apply (clarsimp simp: less_mask_eq) - apply (fastforce simp: obj_range'_def projectKOs objBits_simps' field_simps)[1] - \ \Arch cases\ - apply (rename_tac arch_capability) - apply (case_tac arch_capability) - \ \ASID case\ - apply (clarsimp simp: valid_cap'_def typ_at'_def ko_wp_at'_def) - apply (intro exI conjI, assumption) - apply (clarsimp simp: obj_range'_def archObjSize_def objBitsKO_def) - apply (case_tac ko, simp+)[1] - apply (rename_tac arch_kernel_object) - apply (case_tac arch_kernel_object - ; simp add: archObjSize_def asid_low_bits_def pageBits_def) - apply simp - apply simp - apply simp - \ \Page case\ - apply (rename_tac word vmrights vmpage_size option) - apply (clarsimp simp: valid_cap'_def typ_at'_def ko_wp_at'_def capAligned_def) - apply (frule_tac ptr = ptr and sz = "pageBits" - in nasty_range [where 'a=32, folded word_bits_def]) - apply assumption - apply (simp add: pbfs_atleast_pageBits)+ - apply (clarsimp,drule_tac x = idx in spec,clarsimp) - apply (intro exI conjI,assumption) - apply (clarsimp simp: obj_range'_def) - apply (case_tac ko, simp_all split: if_splits - , (simp add: objBitsKO_def archObjSize_def field_simps shiftl_t2n)+)[1] - \ \PT case\ - apply (rename_tac word option) - apply (clarsimp simp: valid_cap'_def obj_at'_def pageBits_def pteBits_def asid_bits_def - page_table_at'_def typ_at'_def ko_wp_at'_def) - apply (frule_tac ptr=ptr and sz=2 - in nasty_range[where 'a=32 and bz="ptBits", folded word_bits_def, + apply (clarsimp simp: obj_range'_def archObjSize_def objBitsKO_def) + apply (case_tac ko, simp+)[1] + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object; + simp add: archObjSize_def asid_low_bits_def pageBits_def) + apply simp + \ \Page case\ + apply (rename_tac word vmrights vmpage_size option) + apply (clarsimp simp: valid_cap'_def typ_at'_def ko_wp_at'_def capAligned_def) + apply (frule_tac ptr = ptr and sz = "pageBits" in nasty_range [where 'a=32, folded word_bits_def]) + apply assumption + apply (simp add: pbfs_atleast_pageBits)+ + apply (clarsimp,drule_tac x = idx in spec,clarsimp) + apply (intro exI conjI,assumption) + apply (clarsimp simp: obj_range'_def) + apply (case_tac ko, simp_all split: if_splits, + (simp add: objBitsKO_def archObjSize_def field_simps shiftl_t2n)+)[1] + \ \PT case\ + apply (rename_tac word option) + apply (clarsimp simp: valid_cap'_def obj_at'_def pageBits_def pteBits_def asid_bits_def + page_table_at'_def typ_at'_def ko_wp_at'_def) + apply (frule_tac ptr=ptr and sz=2 in + nasty_range[where 'a=32 and bz="ptBits", folded word_bits_def, simplified pageBits_def word_bits_def, simplified,rotated]) - apply (clarsimp simp add: ptBits_def pteBits_def)+ - apply (drule_tac x=idx in spec) - apply clarsimp - apply (intro exI conjI,assumption) - apply (clarsimp simp: obj_range'_def) - apply (case_tac ko; simp) - apply (rename_tac arch_kernel_object) - apply (case_tac arch_kernel_object; simp) - apply (simp add: objBitsKO_def archObjSize_def field_simps shiftl_t2n ptBits_def pteBits_def) - \ \PD case\ - apply (clarsimp simp: valid_cap'_def obj_at'_def pageBits_def pdBits_def page_directory_at'_def - typ_at'_def ko_wp_at'_def) - apply (frule_tac ptr=ptr and sz=2 - in nasty_range[where 'a=32 and bz="pdBits", folded word_bits_def,rotated, - simplified pdBits_def pageBits_def word_bits_def, simplified]) - apply (clarsimp simp add: pdBits_def pdeBits_def)+ - apply (drule_tac x="idx" in spec) - apply clarsimp - apply (intro exI conjI, assumption) - apply (clarsimp simp: obj_range'_def objBitsKO_def field_simps) - apply (case_tac ko; simp) - apply (rename_tac arch_kernel_object) - apply (case_tac arch_kernel_object; simp) - apply (simp add: field_simps archObjSize_def shiftl_t2n pdBits_def pdeBits_def) - \ \Reply case\ - apply (clarsimp simp: valid_cap'_def obj_at'_def) - apply (fastforce simp: obj_range'_def projectKOs objBits_simps' field_simps) - \ \CNode case\ - apply (clarsimp simp: valid_cap'_def obj_at'_def capAligned_def objBits_simps' projectKOs) - apply (frule_tac ptr=ptr and sz=4 in nasty_range [where 'a=32, folded word_bits_def], simp+) + apply (clarsimp simp add: ptBits_def pteBits_def)+ + apply (drule_tac x=idx in spec) + apply clarsimp + apply (intro exI conjI,assumption) + apply (clarsimp simp: obj_range'_def) + apply (case_tac ko; simp) + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object; simp) + apply (simp add: objBitsKO_def archObjSize_def field_simps shiftl_t2n + ptBits_def pteBits_def) + \ \PD case\ + apply (clarsimp simp: valid_cap'_def obj_at'_def pageBits_def pdBits_def + page_directory_at'_def typ_at'_def ko_wp_at'_def) + apply (frule_tac ptr=ptr and sz=2 in + nasty_range[where 'a=32 and bz="pdBits", folded word_bits_def,rotated, + simplified pdBits_def pageBits_def word_bits_def, simplified]) + apply (clarsimp simp add: pdBits_def pdeBits_def)+ + apply (drule_tac x="idx" in spec) apply clarsimp - apply (drule_tac x=idx in spec) - apply (clarsimp simp: less_mask_eq) - apply (fastforce simp: obj_range'_def projectKOs objBits_simps' field_simps) - \ \SchedContext case\ - apply (fastforce simp: valid_cap'_def ko_wp_at'_def obj_range'_def) + apply (intro exI conjI, assumption) + apply (clarsimp simp: obj_range'_def objBitsKO_def field_simps) + apply (case_tac ko; simp) + apply (rename_tac arch_kernel_object) + apply (case_tac arch_kernel_object; simp) + apply (simp add: field_simps archObjSize_def shiftl_t2n pdBits_def pdeBits_def) + \ \CNode case\ + apply (clarsimp simp: valid_cap'_def obj_at'_def capAligned_def + objBits_simps' projectKOs) + apply (frule_tac ptr=ptr and sz=4 in nasty_range [where 'a=32, folded word_bits_def], simp+) + apply clarsimp + apply (drule_tac x=idx in spec) + apply (clarsimp simp: less_mask_eq) + apply (fastforce simp: obj_range'_def projectKOs objBits_simps' field_simps)[1] done lemma untypedCap_descendants_range': @@ -614,7 +610,6 @@ lemma untypedCap_descendants_range': apply (clarsimp simp: ko_wp_at'_def simp del: usableUntypedRange.simps untypedRange.simps) apply (frule(1) pspace_alignedD') apply (frule(1) pspace_distinctD') - apply (frule(1) pspace_boundedD') apply (erule(1) impE) apply (clarsimp simp del: usableUntypedRange.simps untypedRange.simps) apply blast @@ -717,7 +712,7 @@ lemma cte_cap_in_untyped_range: apply (clarsimp dest!: isCapDs) apply (rule_tac x=x in notemptyI) apply (simp add: subsetD [OF cte_refs_capRange]) - apply (clarsimp simp: invs'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def) apply (frule_tac p=cref and p'=crefa in untyped_mdbD', assumption) apply (simp_all add: isUntypedCap_def) apply (frule valid_capAligned) @@ -725,7 +720,7 @@ lemma cte_cap_in_untyped_range: apply (case_tac cap; simp) apply blast apply (case_tac cap; simp) - apply (clarsimp simp: invs'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def) + apply (clarsimp simp: invs'_def valid_state'_def valid_pspace'_def valid_mdb'_def valid_mdb_ctes_def) done lemma cap_case_CNodeCap_True_throw: @@ -888,11 +883,10 @@ lemma decodeUntyped_wf[wp]: apply (simp add:empty_descendants_range_in') apply (clarsimp simp:image_def isCap_simps nullPointer_def word_size field_simps) apply (intro conjI) - apply (clarsimp simp: image_def isCap_simps nullPointer_def word_size field_simps) - apply (drule_tac x=x in spec)+ - apply simp - apply (clarsimp simp: APIType_capBits_def) - apply (clarsimp simp: APIType_capBits_def sc_size_bounds_def) + apply (clarsimp simp: image_def isCap_simps nullPointer_def word_size field_simps) + apply (drule_tac x=x in spec)+ + apply simp + apply (clarsimp simp: APIType_capBits_def) apply clarsimp apply (clarsimp simp: image_def getFreeRef_def cte_level_bits_def objBits_simps' field_simps) apply (clarsimp simp: of_nat_shiftR word_le_nat_alt) @@ -900,11 +894,10 @@ lemma decodeUntyped_wf[wp]: and bits = "(APIType_capBits (toEnum (unat (args ! 0))) (unat (args ! 1)))" in range_cover_stuff[where w=w and sz=sz and rv = idx,rotated -1]; simp?) apply (intro conjI; clarsimp simp add: image_def word_size) - apply (clarsimp simp: image_def isCap_simps nullPointer_def word_size field_simps) - apply (drule_tac x=x in spec)+ - apply simp - apply (clarsimp simp: APIType_capBits_def) - apply (clarsimp simp: APIType_capBits_def sc_size_bounds_def) + apply (clarsimp simp: image_def isCap_simps nullPointer_def word_size field_simps) + apply (drule_tac x=x in spec)+ + apply simp + apply (clarsimp simp: APIType_capBits_def) done lemma getCTE_known_cap: @@ -1000,7 +993,7 @@ locale mdb_insert_again = context mdb_insert_again begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemmas parent = mdb_ptr_parent.m_p lemmas site = mdb_ptr_site.m_p @@ -1339,14 +1332,13 @@ lemma in_getCTE2: declare wrap_ext_op_det_ext_ext_def[simp] lemma do_ext_op_update_cdt_list_symb_exec_l': - "corres_underlying {(s::det_state, s'). f (kheap s) s'} nf nf' dc P P' (create_cap_ext p z a) (return x)" + "corres_underlying {(s::det_state, s'). f (kheap s) (ekheap s) s'} nf nf' dc P P' (create_cap_ext p z a) (return x)" apply (simp add: corres_underlying_def create_cap_ext_def update_cdt_list_def set_cdt_list_def bind_def put_def get_def gets_def return_def) done crunch updateMDB, updateNewFreeIndex for it'[wp]: "\s. P (ksIdleThread s)" - and ksIdleSC[wp]: "\s. P (ksIdleSC s)" and ups'[wp]: "\s. P (gsUserPages s)" and cns'[wp]: "\s. P (gsCNodes s)" and ksDomainTime[wp]: "\s. P (ksDomainTime s)" @@ -1354,18 +1346,11 @@ crunch updateMDB, updateNewFreeIndex and ksWorkUnitsCompleted[wp]: "\s. P (ksWorkUnitsCompleted s)" and ksMachineState[wp]: "\s. P (ksMachineState s)" and ksArchState[wp]: "\s. P (ksArchState s)" - and ksConsumedTime[wp]: "\s. P (ksConsumedTime s)" - and ksCurrentTime[wp]: "\s. P (ksCurTime s)" - and ksCurSc[wp]: "\s. P (ksCurSc s)" - and ksReprogramTimer[wp]: "\s. P (ksReprogramTimer s)" - crunch insertNewCap for ksInterrupt[wp]: "\s. P (ksInterruptState s)" and nosch[wp]: "\s. P (ksSchedulerAction s)" and norq[wp]: "\s. P (ksReadyQueues s)" - and norlq[wp]: "\s. P (ksReleaseQueue s)" and ksIdleThread[wp]: "\s. P (ksIdleThread s)" - and ksIdleSC[wp]: "\s. P (ksIdleSC s)" and ksDomSchedule[wp]: "\s. P (ksDomSchedule s)" and ksCurDomain[wp]: "\s. P (ksCurDomain s)" and ksCurThread[wp]: "\s. P (ksCurThread s)" @@ -1389,7 +1374,7 @@ crunch create_cap_ext and work_units_completed[wp]: "\s. P (work_units_completed s)" (ignore_del: create_cap_ext) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateNewFreeIndex_noop_psp_corres: "corres_underlying {(s, s'). pspace_relations (ekheap s) (kheap s) (ksPSpace s')} False True @@ -1404,13 +1389,9 @@ lemma updateNewFreeIndex_noop_psp_corres: | simp add: updateTrackedFreeIndex_def getSlotCap_def)+ done -crunch updateMDB, updateNewFreeIndex - for sc_replies_of'[wp]: "\s. P (replies_of' s) (scs_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] @@ -1460,7 +1441,6 @@ shows apply ((wp | simp)+)[1] apply (wp updateMDB_ctes_of_cases | simp add: o_def split del: if_split)+ - apply (intro conjI; (solves \simp add: state_relation_def\)?) apply (clarsimp simp: cdt_relation_def cte_wp_at_ctes_of split del: if_split cong: if_cong simp del: id_apply) apply (subst if_not_P, erule(1) valid_mdbD3') @@ -1553,7 +1533,7 @@ shows apply(simp only: cdt_list_relation_def valid_mdb_def2) apply(subgoal_tac "finite_depth (cdt s)") prefer 2 - apply(simp add: finite_depth valid_mdb_def2[simplified]) + apply(simp add: finite_depth valid_mdb_def2[simplified,symmetric]) apply(intro impI allI) apply(subgoal_tac "mdb_insert_abs (cdt s) p (a, b)") prefer 2 @@ -1641,6 +1621,18 @@ lemma setCTE_cteCaps_of[wp]: apply (clarsimp elim!: rsubst[where P=P] intro!: ext) done +lemma insertNewCap_wps[wp]: + "\pspace_aligned'\ insertNewCap parent slot cap \\rv. pspace_aligned'\" + "\pspace_distinct'\ insertNewCap parent slot cap \\rv. pspace_distinct'\" + "\\s. P ((cteCaps_of s)(slot \ cap))\ + insertNewCap parent slot cap + \\rv s. P (cteCaps_of s)\" + apply (simp_all add: insertNewCap_def) + apply (wp hoare_drop_imps + | simp add: o_def)+ + apply (clarsimp elim!: rsubst[where P=P] intro!: ext) + done + definition apitype_of :: "cap \ apiobject_type option" where "apitype_of c \ case c of @@ -1700,7 +1692,7 @@ locale mdb_insert_again_all = mdb_insert_again_child + fixes n' defines "n' \ modify_map n (mdbNext parent_node) (cteMDBNode_update (mdbPrev_update (\a. site)))" begin -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma no_0_n' [simp]: "no_0 n'" using no_0_n by (simp add: n'_def) @@ -2648,6 +2640,19 @@ lemma dist_z [simp]: apply auto done +lemma reply_masters_rvk_fb_m: + "reply_masters_rvk_fb m" + using valid by auto + +lemma reply_masters_rvk_fb_n[simp]: + "reply_masters_rvk_fb n'" + using reply_masters_rvk_fb_m + apply (simp add: reply_masters_rvk_fb_def n'_def ball_ran_modify_map_eq + n_def fun_upd_def[symmetric]) + apply (rule ball_ran_fun_updI, assumption) + apply clarsimp + done + lemma valid_n': "untypedRange c' \ usableUntypedRange parent_cap = {} \ valid_mdb_ctes n'" by auto @@ -2661,7 +2666,7 @@ lemma caps_overlap_reserved'_D: apply (erule(2) impE) apply fastforce done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma insertNewCap_valid_mdb: "\valid_mdb' and valid_objs' and K (slot \ p) and caps_overlap_reserved' (untypedRange cap) and @@ -2702,12 +2707,7 @@ lemma no_default_zombie: "cap_relation (default_cap tp p sz d) cap \ \isZombie cap" by (cases tp, auto simp: isCap_simps) -end - -global_interpretation updateNewFreeIndex: typ_at_all_props' "updateNewFreeIndex slot" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas updateNewFreeIndex_typ_ats[wp] = typ_at_lifts[OF updateNewFreeIndex_typ_at'] lemma updateNewFreeIndex_valid_objs[wp]: "\valid_objs'\ updateNewFreeIndex slot \\_. valid_objs'\" @@ -2893,8 +2893,6 @@ lemma inv_untyped_corres_helper1: lemma createNewCaps_valid_pspace_extras: "\(\s. n \ 0 \ ptr \ 0 \ range_cover ptr sz (APIType_capBits ty us) n - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ pspace_no_overlap' ptr sz s \ valid_pspace' s \ caps_no_overlap'' ptr sz s \ caps_overlap_reserved' {ptr .. ptr + of_nat n * 2 ^ APIType_capBits ty us - 1} s @@ -2903,8 +2901,6 @@ lemma createNewCaps_valid_pspace_extras: createNewCaps ty ptr n us d \\rv. pspace_aligned'\" "\(\s. n \ 0 \ ptr \ 0 \ range_cover ptr sz (APIType_capBits ty us) n - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ pspace_no_overlap' ptr sz s \ valid_pspace' s \ caps_no_overlap'' ptr sz s \ caps_overlap_reserved' {ptr .. ptr + of_nat n * 2 ^ APIType_capBits ty us - 1} s @@ -2913,8 +2909,6 @@ lemma createNewCaps_valid_pspace_extras: createNewCaps ty ptr n us d \\rv. pspace_distinct'\" "\(\s. n \ 0 \ ptr \ 0 \ range_cover ptr sz (APIType_capBits ty us) n - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ pspace_no_overlap' ptr sz s \ valid_pspace' s \ caps_no_overlap'' ptr sz s \ caps_overlap_reserved' {ptr .. ptr + of_nat n * 2 ^ APIType_capBits ty us - 1} s @@ -2923,8 +2917,6 @@ lemma createNewCaps_valid_pspace_extras: createNewCaps ty ptr n us d \\rv. valid_mdb'\" "\(\s. n \ 0 \ ptr \ 0 \ range_cover ptr sz (APIType_capBits ty us) n - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ pspace_no_overlap' ptr sz s \ valid_pspace' s \ caps_no_overlap'' ptr sz s \ caps_overlap_reserved' {ptr .. ptr + of_nat n * 2 ^ APIType_capBits ty us - 1} s @@ -2953,8 +2945,7 @@ declare map_snd_zip_prefix[simp] declare word_unat_power [symmetric, simp del] lemma createNewCaps_range_helper: - "\\s. range_cover ptr sz (APIType_capBits tp us) n \ 0 < n - \ (tp = APIObjectType SchedContextObject \ sc_size_bounds us)\ + "\\s. range_cover ptr sz (APIType_capBits tp us) n \ 0 < n\ createNewCaps tp ptr n us d \\rv s. \capfn. rv = map capfn (map (\p. ptr_add ptr (p * 2 ^ (APIType_capBits tp us))) @@ -2970,7 +2961,6 @@ lemma createNewCaps_range_helper: apply (cases tp, simp_all split del: if_split) apply (rename_tac apiobject_type) apply (case_tac apiobject_type, simp_all split del: if_split) - \\Untyped\ apply (rule hoare_pre, wp) apply (frule range_cover_not_zero[rotated -1],simp) apply (clarsimp simp: APIType_capBits_def objBits_simps archObjSize_def ptr_add_def o_def) @@ -2978,28 +2968,33 @@ lemma createNewCaps_range_helper: apply unat_arith apply (clarsimp simp: o_def fromIntegral_def toInteger_nat fromInteger_nat) apply fastforce - \\TCB\ - apply (rule hoare_pre, wp createObjects_ret2) - apply (wpsimp simp: curDomain_def) + apply (rule hoare_pre,wp createObjects_ret2) apply (clarsimp simp: APIType_capBits_def word_bits_def - objBits_simps archObjSize_def ptr_add_def o_def) + objBits_simps archObjSize_def ptr_add_def o_def) apply (fastforce simp: objBitsKO_def objBits_def) - \\other APIObjectType\ - apply ((rule hoare_pre, wp createObjects_ret2, - clarsimp simp: APIType_capBits_def word_bits_def - objBits_simps archObjSize_def ptr_add_def o_def, - fastforce simp: objBitsKO_def objBits_def scBits_simps)+)[5] - \\Arch objects\ - by (wp createObjects_ret2 - | clarsimp simp: APIType_capBits_def objBits_if_dev archObjSize_def word_bits_def - pdBits_def pageBits_def ptBits_def pteBits_def pdeBits_def - split del: if_split - | simp add: objBits_simps - | (rule exI, fastforce))+ + apply (rule hoare_pre,wp createObjects_ret2) + apply (clarsimp simp: APIType_capBits_def word_bits_def + objBits_simps archObjSize_def ptr_add_def o_def) + apply (fastforce simp: objBitsKO_def objBits_def) + apply (rule hoare_pre,wp createObjects_ret2) + apply (clarsimp simp: APIType_capBits_def word_bits_def + objBits_simps archObjSize_def ptr_add_def o_def) + apply (fastforce simp: objBitsKO_def objBits_def) + apply (rule hoare_pre,wp createObjects_ret2) + apply (clarsimp simp: APIType_capBits_def word_bits_def + objBits_simps archObjSize_def ptr_add_def o_def) + apply (fastforce simp: objBitsKO_def objBits_def) + apply (wp createObjects_ret2 + | clarsimp simp: APIType_capBits_def objBits_if_dev archObjSize_def + word_bits_def pdBits_def pageBits_def ptBits_def + pteBits_def pdeBits_def + split del: if_split + | simp add: objBits_simps + | (rule exI, fastforce))+ + done lemma createNewCaps_range_helper2: - "\\s. range_cover ptr sz (APIType_capBits tp us) n \ 0 < n - \ (tp = APIObjectType SchedContextObject \ sc_size_bounds us)\ + "\\s. range_cover ptr sz (APIType_capBits tp us) n \ 0 < n\ createNewCaps tp ptr n us d \\rv s. \cp \ set rv. capRange cp \ {} \ capRange cp \ {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1}\" apply (rule hoare_assume_pre) @@ -3021,7 +3016,6 @@ lemma createNewCaps_range_helper2: apply (erule of_nat_mono_maybe[rotated]) apply (drule (1) range_cover.range_cover_n_less ) apply (clarsimp) - apply (thin_tac "tp = _ \ _") apply (erule impE) apply (simp add:range_cover_def) apply (rule is_aligned_no_overflow) @@ -3032,8 +3026,7 @@ lemma createNewCaps_range_helper2: lemma createNewCaps_children: "\\s. cap = UntypedCap d (ptr && ~~ mask sz) sz idx - \ range_cover ptr sz (APIType_capBits tp us) n \ 0 < n - \ (tp = APIObjectType SchedContextObject \ sc_size_bounds us)\ + \ range_cover ptr sz (APIType_capBits tp us) n \ 0 < n\ createNewCaps tp ptr n us d \\rv s. \y \ set rv. (sameRegionAs cap y)\" apply (rule hoare_assume_pre) @@ -3061,9 +3054,7 @@ lemmas makeObjectKO_simp = makeObjectKO_def[split_simps ARM_H.object_type.split lemma createNewCaps_descendants_range': "\\s. descendants_range' p q (ctes_of s) \ range_cover ptr sz (APIType_capBits ty us) n \ n \ 0 \ - (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ pspace_no_overlap' ptr sz s\ + pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createNewCaps ty ptr n us d \ \rv s. descendants_range' p q (ctes_of s)\" apply (clarsimp simp:descendants_range'_def2 descendants_range_in'_def2) @@ -3093,10 +3084,8 @@ lemma caps_overlap_reserved'_def2: done lemma createNewCaps_caps_overlap_reserved': - "\\s. caps_overlap_reserved' S s \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ + "\\s. caps_overlap_reserved' S s \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ 0 < n \ - (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ range_cover ptr sz (APIType_capBits ty us) n\ createNewCaps ty ptr n us d \\rv s. caps_overlap_reserved' S s\" @@ -3108,9 +3097,7 @@ lemma createNewCaps_caps_overlap_reserved': lemma createNewCaps_caps_overlap_reserved_ret': "\\s. caps_overlap_reserved' {ptr..ptr + of_nat n * 2 ^ APIType_capBits ty us - 1} s \ - pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s \ pspace_no_overlap' ptr sz s \ - (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ + pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ 0 < n \ range_cover ptr sz (APIType_capBits ty us) n\ createNewCaps ty ptr n us d \\rv s. \y\set rv. caps_overlap_reserved' (capRange y) s\" @@ -3125,15 +3112,14 @@ lemma createNewCaps_caps_overlap_reserved_ret': apply (drule(1) range_cover_subset) apply simp apply (clarsimp simp: ptr_add_def capRange_def - simp del: atLeastAtMost_simps) + simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff) done lemma createNewCaps_descendants_range_ret': "\\s. (range_cover ptr sz (APIType_capBits ty us) n \ 0 < n) - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ descendants_range_in' {ptr..ptr + of_nat n * 2^(APIType_capBits ty us) - 1} cref (ctes_of s)\ createNewCaps ty ptr n us d \ \rv s. \y\set rv. descendants_range' y cref (ctes_of s)\" @@ -3154,11 +3140,9 @@ lemma createNewCaps_descendants_range_ret': lemma createNewCaps_parent_helper: "\\s. cte_wp_at' (\cte. cteCap cte = UntypedCap d (ptr && ~~ mask sz) sz idx) p s - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s \ (ty = APIObjectType ArchTypes_H.CapTableObject \ 0 < us) - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ range_cover ptr sz (APIType_capBits ty us) n \ 0 < n \ createNewCaps ty ptr n us d \\rv. cte_wp_at' (\cte. isUntypedCap (cteCap cte) \ @@ -3182,7 +3166,6 @@ lemma createNewCaps_valid_cap': range_cover ptr sz (APIType_capBits ty us) n \ (ty = APIObjectType ArchTypes_H.CapTableObject \ 0 < us) \ (ty = APIObjectType apiobject_type.Untyped \ minUntypedSizeBits \ us \ us \ maxUntypedSizeBits) \ - (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ sc_size_bounds us) \ ptr \ 0 \ createNewCaps ty ptr n us d \\r s. \cap\set r. s \' cap\" @@ -3197,8 +3180,7 @@ lemma dmo_ctes_of[wp]: by (simp add: doMachineOp_def split_def | wp)+ lemma createNewCaps_ranges: - "\\s. range_cover ptr sz (APIType_capBits ty us) n \ 0 (ty = APIObjectType SchedContextObject \ sc_size_bounds us)\ + "\\s. range_cover ptr sz (APIType_capBits ty us) n \ 0 createNewCaps ty ptr n us d \\rv s. distinct_sets (map capRange rv)\" apply (rule hoare_assume_pre) @@ -3224,8 +3206,7 @@ lemma createNewCaps_ranges: done lemma createNewCaps_ranges': - "\\s. range_cover ptr sz (APIType_capBits ty us) n \ 0 < n - \ (ty = APIObjectType SchedContextObject \ sc_size_bounds us)\ + "\\s. range_cover ptr sz (APIType_capBits ty us) n \ 0 < n\ createNewCaps ty ptr n us d \\rv s. distinct_sets (map capRange (map snd (zip xs rv)))\" apply (rule hoare_strengthen_post) @@ -3249,23 +3230,22 @@ lemma retype_region_caps_overlap_reserved: {ptr..ptr + of_nat n * 2^obj_bits_api (APIType_map2 (Inr ao')) us - 1} and (\s. \slot. cte_wp_at (\c. up_aligned_area ptr sz \ cap_range c \ cap_is_device c = dev) slot s) and K (APIType_map2 (Inr ao') = Structures_A.apiobject_type.CapTableObject \ 0 < us) and - K (ao' = APIObjectType SchedContextObject \ sc_size_bounds us) and K (range_cover ptr sz (obj_bits_api (APIType_map2 (Inr ao')) us) n) and K (S \ {ptr..ptr + of_nat n * 2 ^ obj_bits_api (APIType_map2 (Inr ao')) us - 1})\ retype_region ptr n us (APIType_map2 (Inr ao')) dev \\rv s. caps_overlap_reserved S s\" apply (rule hoare_gen_asm)+ - apply (simp (no_asm) add: caps_overlap_reserved_def2) + apply (simp (no_asm) add:caps_overlap_reserved_def2) apply (rule hoare_pre) apply (wp retype_region_caps_of) - apply (simp add: sc_size_bounds_def untyped_max_bits_def maxUntypedSizeBits_def sc_const_eq(3))+ - apply (simp add: caps_overlap_reserved_def2) - apply (intro conjI, simp+) + apply simp+ + apply (simp add:caps_overlap_reserved_def2) + apply (intro conjI,simp+) apply clarsimp apply (drule bspec) apply simp+ - apply (erule (1) disjoint_subset2) + apply (erule(1) disjoint_subset2) done lemma retype_region_caps_overlap_reserved_ret: @@ -3275,7 +3255,6 @@ lemma retype_region_caps_overlap_reserved_ret: {ptr..ptr + of_nat n * 2^obj_bits_api (APIType_map2 (Inr ao')) us - 1} and (\s. \slot. cte_wp_at (\c. up_aligned_area ptr sz \ cap_range c \ cap_is_device c = dev) slot s) and K (APIType_map2 (Inr ao') = Structures_A.apiobject_type.CapTableObject \ 0 < us) and - K (ao' = APIObjectType SchedContextObject \ sc_size_bounds us) and K (range_cover ptr sz (obj_bits_api (APIType_map2 (Inr ao')) us) n)\ retype_region ptr n us (APIType_map2 (Inr ao')) dev \\rv s. \y\set rv. caps_overlap_reserved (untyped_range (default_cap @@ -3297,9 +3276,6 @@ lemma retype_region_caps_overlap_reserved_ret: apply (clarsimp)+ done -crunch updateCap, updateFreeIndex - for sc_at'_n[wp]: "sc_at'_n n p" - lemma updateFreeIndex_pspace_no_overlap': "\\s. pspace_no_overlap' ptr sz s \ valid_pspace' s \ cte_wp_at' (isUntypedCap o cteCap) src s\ @@ -3307,7 +3283,7 @@ lemma updateFreeIndex_pspace_no_overlap': \\r s. pspace_no_overlap' ptr sz s\" apply (simp add: updateFreeIndex_def getSlotCap_def updateTrackedFreeIndex_def) apply (rule hoare_pre) - apply (wp getCTE_wp' | wp (once) pspace_no_overlap'_lift2 + apply (wp getCTE_wp' | wp (once) pspace_no_overlap'_lift | simp)+ apply (clarsimp simp:valid_pspace'_def pspace_no_overlap'_def) done @@ -3381,20 +3357,24 @@ lemma updateFreeIndex_updateCap_caps_no_overlap'': apply (clarsimp simp:caps_no_overlap''_def) apply (wp updateCap_ctes_of_wp) apply (clarsimp simp: modify_map_def ran_def cte_wp_at_ctes_of - simp del: atLeastAtMost_simps) + simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex) apply (case_tac "a = src") - apply (clarsimp simp del: atLeastAtMost_simps) + apply (clarsimp simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex) apply (erule subsetD[rotated]) apply (elim allE impE) apply fastforce apply (clarsimp simp:isCap_simps) apply (erule subset_trans) apply (clarsimp simp:isCap_simps) - apply clarsimp + apply (clarsimp simp del: atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex) + apply (erule subsetD[rotated]) apply (elim allE impE) - prefer 2 + prefer 2 apply assumption - apply fastforce+ + apply fastforce+ done lemma updateFreeIndex_caps_no_overlap'': @@ -3568,14 +3548,15 @@ lemma updateFreeIndex_valid_pspace_no_overlap': descendants_of' src (ctes_of s) = {}\ updateFreeIndex src idx \\r s. valid_pspace' s\" + apply (clarsimp simp:valid_pspace'_def updateFreeIndex_def updateTrackedFreeIndex_def) apply (rule hoare_pre) apply (rule hoare_vcg_conj_lift) apply (clarsimp simp:updateCap_def getSlotCap_def) apply (wp getCTE_wp | simp)+ - apply (wpsimp wp: updateFreeIndex_mdb_simple' getCTE_wp' valid_replies'_lift - simp: getSlotCap_def)+ + apply (wp updateFreeIndex_mdb_simple' getCTE_wp' + | simp add: getSlotCap_def)+ apply (clarsimp simp:cte_wp_at_ctes_of valid_pspace'_def) apply (case_tac cte,simp add:isCap_simps) apply (frule(1) ctes_of_valid_cap') @@ -3606,7 +3587,7 @@ lemma updateFreeIndex_clear_invs': \ descendants_of' src (ctes_of s) = {}\ updateFreeIndex src idx \\r s. invs' s\" - apply (clarsimp simp:invs'_def valid_dom_schedule'_def) + apply (clarsimp simp:invs'_def valid_state'_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 valid_queues_lift @@ -3634,7 +3615,6 @@ lemma updateFreeIndex_clear_invs': apply (frule(1) valid_global_refsD_with_objSize) apply clarsimp apply (intro conjI allI impI) - apply (clarsimp simp: opt_map_def comp_def) apply (clarsimp simp: modify_map_def cteCaps_of_def ifunsafe'_def3 split:if_splits) apply (drule_tac x=src in spec) apply (clarsimp simp:isCap_simps) @@ -3658,18 +3638,21 @@ lemma cte_wp_at_pspace_no_overlapI': apply (case_tac cte,clarsimp) apply (frule ctes_of_valid_cap') apply (simp add:invs_valid_objs') - apply (clarsimp simp:valid_cap'_def invs'_def valid_pspace'_def + apply (clarsimp simp:valid_cap'_def invs'_def valid_state'_def valid_pspace'_def valid_untyped'_def simp del:usableUntypedRange.simps) apply (unfold pspace_no_overlap'_def) apply (intro allI impI) apply (unfold ko_wp_at'_def) - apply (clarsimp simp del: atLeastAtMost_simps usableUntypedRange.simps) + apply (clarsimp simp del: atLeastAtMost_iff + atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff usableUntypedRange.simps) apply (drule spec)+ apply (frule(1) pspace_distinctD') apply (frule(1) pspace_alignedD') - apply (frule(1) pspace_boundedD') apply (erule(1) impE)+ - apply (clarsimp simp: obj_range'_def simp del: atLeastAtMost_simps usableUntypedRange.simps) + apply (clarsimp simp: obj_range'_def simp del: atLeastAtMost_iff + atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff usableUntypedRange.simps) apply (erule disjoint_subset2[rotated]) apply (frule(1) le_mask_le_2p) apply (clarsimp simp:p_assoc_help) @@ -3765,7 +3748,7 @@ lemma descendants_range_ex_cte': invs' s';ctes_of s' p = Some cte;isUntypedCap (cteCap cte)\ \ q \ S" apply (frule invs_valid_objs') apply (frule invs_mdb') - apply (clarsimp simp: invs'_def) + apply (clarsimp simp:invs'_def valid_state'_def) apply (clarsimp simp: ex_cte_cap_to'_def cte_wp_at_ctes_of) apply (frule_tac cte = "cte" in valid_global_refsD') apply simp @@ -3884,7 +3867,7 @@ lemma cte_wp_at': "cte_wp_at' (\cte. cteCap cte = capability.UntypedCap "\x\set slots. ex_cte_cap_wp_to' (\_. True) x s" using vui by (auto simp: cte_wp_at_ctes_of) -interpretation Arch . (*FIXME: arch_split*) +interpretation Arch . (*FIXME: arch-split*) lemma idx_cases: "((\ reset \ idx \ unat (ptr - (ptr && ~~ mask sz))) \ reset \ ptr = ptr && ~~ mask sz)" @@ -3973,7 +3956,7 @@ lemma caps_no_overlap'[simp]: "caps_no_overlap'' ptr sz s" lemma cref_inv: "cref \ usable_range" apply (insert misc cte_wp_at') apply (drule if_unsafe_then_capD') - apply (simp add: invs'_def) + apply (simp add: invs'_def valid_state'_def) apply simp apply (erule ex_cte_no_overlap') done @@ -4028,19 +4011,26 @@ lemma idx_le_new_offs: end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) + +lemma valid_sched_etcbs[elim!]: "valid_sched_2 queues ekh sa cdom kh ct it \ valid_etcbs_2 ekh kh" + by (simp add: valid_sched_def) crunch deleteObjects for ksIdleThread[wp]: "\s. P (ksIdleThread s)" - and ksCurDomain[wp]: "\s. P (ksCurDomain s)" - and irq_node[wp]: "\s. P (irq_node' s)" - (simp: crunch_simps wp: hoare_drop_imps unless_wp) + (simp: crunch_simps wp: hoare_drop_imps unless_wp ignore: freeMemory) +crunch deleteObjects + for ksCurDomain[wp]: "\s. P (ksCurDomain s)" + (simp: crunch_simps wp: hoare_drop_imps unless_wp ignore: freeMemory) +crunch deleteObjects + for irq_node[wp]: "\s. P (irq_node' s)" + (simp: crunch_simps wp: hoare_drop_imps unless_wp ignore: freeMemory) lemma deleteObjects_ksCurThread[wp]: "\\s. P (ksCurThread s)\ deleteObjects ptr sz \\_ s. P (ksCurThread s)\" - apply (simp add: deleteObjects_def3) - apply (wp | simp add: doMachineOp_def split_def)+ - done +apply (simp add: deleteObjects_def3) +apply (wp | simp add: doMachineOp_def split_def)+ +done lemma deleteObjects_ct_active': "\invs' and sch_act_simple and ct_active' @@ -4051,10 +4041,10 @@ lemma deleteObjects_ct_active': \\_. ct_active'\" apply (simp add: ct_in_state'_def) apply (rule hoare_pre) - apply wps - apply (wp deleteObjects_st_tcb_at') + apply wps + apply (wp deleteObjects_st_tcb_at') apply (auto simp: ct_in_state'_def elim: pred_tcb'_weakenE) - done +done defs cNodeOverlap_def: "cNodeOverlap \ \cns inRange. \p n. cns p = Some n @@ -4179,34 +4169,35 @@ lemma ex_tupI: "P (fst x) (snd x) \ \a b. P a b" by blast -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) (* mostly stuff about PPtr/fromPPtr, which seems pretty soft *) lemma resetUntypedCap_corres: "untypinv_relation ui ui' \ corres (dc \ dc) - (invs and valid_machine_time and schact_is_rct - and valid_untyped_inv_wcap ui (Some (cap.UntypedCap dev ptr sz idx)) and ct_active and einvs - and (\_. \ptr_base ptr' ty us slots dev'. ui = Invocations_A.Retype slot True - ptr_base ptr' ty us slots dev)) - (invs' and valid_untyped_inv_wcap' ui' (Some (UntypedCap dev ptr sz idx)) and ct_active') - (reset_untyped_cap slot) - (resetUntypedCap (cte_map slot))" + (einvs and schact_is_rct and ct_active + and valid_untyped_inv_wcap ui (Some (cap.UntypedCap dev ptr sz idx)) + and (\_. \ptr_base ptr' ty us slots dev'. + ui = Invocations_A.Retype slot True ptr_base ptr' ty us slots dev)) + (invs' and valid_untyped_inv_wcap' ui' (Some (UntypedCap dev ptr sz idx)) and ct_active') + (reset_untyped_cap slot) (resetUntypedCap (cte_map slot))" apply (rule corres_gen_asm, clarsimp) apply (simp add: reset_untyped_cap_def resetUntypedCap_def - liftE_bindE cong: if_cong) + liftE_bindE) apply (rule corres_guard_imp) - apply (rule corres_split[OF getSlotCap_corres], simp) + apply (rule corres_split[OF getSlotCap_corres]) + apply simp apply (rule_tac F="cap = cap.UntypedCap dev ptr sz idx \ (\s. s \ cap)" in corres_gen_asm) apply (clarsimp simp: bits_of_def free_index_of_def unlessE_def split del: if_split) apply (rule corres_if[OF refl]) apply (rule corres_returnOk[where P=\ and P'=\], simp) - apply (simp split del: if_split) - apply (rule corres_split[OF deleteObjects_corres]) - apply (clarsimp simp add: valid_cap_def cap_aligned_def) - apply (clarsimp simp add: valid_cap_def cap_aligned_def untyped_min_bits_def) + apply (simp add: liftE_bindE bits_of_def split del: if_split) + apply (rule corres_split) + apply (rule deleteObjects_corres) + apply (clarsimp simp: valid_cap_def cap_aligned_def) + apply (clarsimp simp: valid_cap_def cap_aligned_def untyped_min_bits_def) apply (rule corres_if) apply simp apply (simp add: bits_of_def shiftL_nat) @@ -4226,7 +4217,6 @@ lemma resetUntypedCap_corres: o_def rev_map del: capFreeIndex_update.simps) apply (rule_tac P="\x. valid_objs and pspace_aligned and pspace_distinct - and cur_sc_tcb and valid_machine_time and active_scs_valid and pspace_no_overlap {ptr .. ptr + 2 ^ sz - 1} and cte_wp_at (\a. is_untyped_cap a \ obj_ref_of a = ptr \ cap_bits a = sz \ cap_is_device a = dev) slot" @@ -4241,7 +4231,8 @@ lemma resetUntypedCap_corres: apply (simp add: shiftL_nat getFreeRef_def shiftl_t2n mult.commute) apply simp apply wp - apply (rule corres_split_nor[OF updateFreeIndex_corres]) + apply (rule corres_split_nor) + apply (rule updateFreeIndex_corres) apply simp apply (simp add: getFreeRef_def getFreeIndex_def free_index_of_def) apply clarify @@ -4260,42 +4251,19 @@ lemma resetUntypedCap_corres: apply (erule order_less_le_trans; simp) apply simp apply (rule preemptionPoint_corres) - apply (wpsimp wp: update_untyped_cap_valid_objs) - apply (strengthen valid_pspace_valid_objs' - | wpsimp wp: updateFreeIndex_valid_pspace_no_overlap')+ - apply (wpsimp wp: hoare_vcg_ex_lift doMachineOp_psp_no_overlap)+ - apply (fastforce intro: valid_untyped_pspace_no_overlap - simp: cte_wp_at_caps_of_state valid_cap_def cap_aligned_def) - apply simp + apply wp+ + apply (clarsimp simp: cte_wp_at_caps_of_state) apply (clarsimp simp: getFreeRef_def valid_pspace'_def cte_wp_at_ctes_of valid_cap_def cap_aligned_def) - apply (rule conjI impI) - apply (erule aligned_add_aligned) - apply (rule is_aligned_weaken) - apply (rule is_aligned_mult_triv2) - apply (simp add: Kernel_Config.resetChunkBits_def) - apply (simp add: untyped_min_bits_def) - apply (clarsimp simp: getFreeIndex_def getFreeRef_def) - apply (subst is_aligned_weaken[OF is_aligned_mult_triv2]) - apply (simp add: Kernel_Config.resetChunkBits_def minUntypedSizeBits_def) - apply (subst unat_mult_simple) - apply (subst unat_of_nat_eq) - apply (rule order_less_trans[rotated], - rule_tac n=sz in power_strict_increasing; simp add: word_bits_def) - apply (erule order_less_le_trans; simp) - apply (subst unat_p2) - apply (simp add: Kernel_Config.resetChunkBits_def) - apply (rule order_less_trans[rotated], - rule_tac n=sz in power_strict_increasing; simp add: word_bits_def) - apply (subst unat_of_nat_eq) - apply (rule order_less_trans[rotated], - rule_tac n=sz in power_strict_increasing; simp add: word_bits_def) - apply (erule order_less_le_trans; simp) - apply simp - apply simp + apply (erule aligned_add_aligned) + apply (rule is_aligned_weaken) + apply (rule is_aligned_mult_triv2) + apply (simp add: Kernel_Config.resetChunkBits_def) + apply (simp add: untyped_min_bits_def) apply (rule hoare_pre) + apply simp apply (strengthen imp_consequent) - apply (wp set_cap_cte_wp_at + apply (wp preemption_point_inv set_cap_cte_wp_at update_untyped_cap_valid_objs set_cap_no_overlap | simp)+ apply (clarsimp simp: exI cte_wp_at_caps_of_state) @@ -4310,7 +4278,7 @@ lemma resetUntypedCap_corres: updateFreeIndex_descendants_of2 doMachineOp_psp_no_overlap updateFreeIndex_cte_wp_at - pspace_no_overlap'_lift2 + pspace_no_overlap'_lift preemptionPoint_inv hoare_vcg_ex_lift | simp)+ @@ -4334,14 +4302,15 @@ lemma resetUntypedCap_corres: apply simp apply simp apply (simp add: if_apply_def2) - apply (strengthen invs_valid_objs invs_psp_aligned invs_distinct invs_cur_sc_tcb) + apply (strengthen invs_valid_objs invs_psp_aligned invs_distinct) apply (wp hoare_vcg_const_imp_lift) apply (simp add: if_apply_def2) - apply (strengthen invs_pspace_aligned' invs_pspace_distinct' invs_valid_pspace') + apply (strengthen invs_pspace_aligned' invs_pspace_distinct' + invs_valid_pspace') apply (wp hoare_vcg_const_imp_lift deleteObjects_cte_wp_at'[where p="cte_map slot"] deleteObjects_invs'[where p="cte_map slot"] deleteObjects_descendants[where p="cte_map slot"] - | simp)+ + | simp)+ apply (wp get_cap_wp getCTE_wp' | simp add: getSlotCap_def)+ apply (clarsimp simp: cte_wp_at_caps_of_state descendants_range_def2) apply (cases slot) @@ -4353,7 +4322,8 @@ lemma resetUntypedCap_corres: apply (frule if_unsafe_then_capD[OF caps_of_state_cteD], clarsimp+) apply (drule(1) ex_cte_cap_protects[OF _ caps_of_state_cteD empty_descendants_range_in _ order_refl], clarsimp+) - subgoal by (auto simp: valid_sched_def) + apply (intro conjI impI; auto)[1] + apply (clarsimp simp: cte_wp_at_ctes_of descendants_range'_def2 empty_descendants_range_in') apply (frule cte_wp_at_valid_objs_valid_cap'[OF ctes_of_cte_wpD], clarsimp+) @@ -4414,7 +4384,7 @@ lemma ex_cte_cap_wp_to_irq_state_independent_H[simp]: "irq_state_independent_H (ex_cte_cap_wp_to' P slot)" by (simp add: ex_cte_cap_wp_to'_def) -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) lemma updateFreeIndex_ctes_of: "\\s. P (modify_map (ctes_of s) ptr (cteCap_update (capFreeIndex_update (\_. idx))))\ @@ -4515,7 +4485,7 @@ lemma resetUntypedCap_invs_etc: hoare_vcg_const_Ball_lift updateFreeIndex_descendants_of2 sch_act_simple_lift - pspace_no_overlap'_lift2 + pspace_no_overlap'_lift doMachineOp_psp_no_overlap updateFreeIndex_ctes_of updateFreeIndex_cte_wp_at @@ -4532,25 +4502,25 @@ lemma resetUntypedCap_invs_etc: in mapME_x_validE_nth) apply (rule hoare_pre) apply simp - apply (wpsimp wp: preemptionPoint_invs - updateFreeIndex_clear_invs' - hoare_vcg_ex_lift - updateFreeIndex_descendants_of2 - updateFreeIndex_ctes_of - updateFreeIndex_cte_wp_at - doMachineOp_psp_no_overlap - hoare_vcg_ex_lift hoare_vcg_const_Ball_lift - pspace_no_overlap'_lift[OF preemptionPoint_inv] - pspace_no_overlap'_lift preemptionPoint_inv - updateFreeIndex_ct_in_state[unfolded ct_in_state'_def] + apply (wp preemptionPoint_invs + updateFreeIndex_clear_invs' + hoare_vcg_ex_lift + updateFreeIndex_descendants_of2 + updateFreeIndex_ctes_of + updateFreeIndex_cte_wp_at + doMachineOp_psp_no_overlap + hoare_vcg_ex_lift hoare_vcg_const_Ball_lift + pspace_no_overlap'_lift[OF preemptionPoint_inv] + pspace_no_overlap'_lift + updateFreeIndex_ct_in_state[unfolded ct_in_state'_def] | strengthen invs_pspace_aligned' invs_pspace_distinct' - | simp add: ct_in_state'_def getCurrentTime_independent_H_def ex_cte_cap_wp_to'_def - time_state_independent_H_def sch_act_simple_def + | simp add: ct_in_state'_def + sch_act_simple_def | rule hoare_vcg_conj_liftE_R | wp (once) preemptionPoint_inv | wps | wp (once) ex_cte_cap_to'_pres)+ - apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps ex_cte_cap_wp_to'_def + apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps conj_comms) apply (subgoal_tac "getFreeIndex ptr (rev [ptr , ptr + 2 ^ resetChunkBits .e. getFreeRef ptr idx - 1] ! i) @@ -4636,7 +4606,7 @@ lemma (in range_cover) funky_aligned: apply simp done -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) defs archOverlap_def: "archOverlap \ \_ _. False" @@ -4644,7 +4614,7 @@ defs archOverlap_def: 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) + (einvs and valid_untyped_inv ui and ct_active and schact_is_rct) (invs' and valid_untyped_inv' ui' and ct_active') (invoke_untyped ui) (invokeUntyped ui')" apply (cases ui) @@ -4663,7 +4633,7 @@ lemma inv_untyped_corres': (cte_map cref) reset ptr_base ptr ao' us (map cte_map slots) dev" assume invs: "invs (s :: det_state)" "ct_active s" "valid_list s" "valid_sched s" - "schact_is_rct s" "valid_machine_time s" + "schact_is_rct s" and invs': "invs' s'" "ct_active' s'" and sr: "(s, s') \ state_relation" and vui: "valid_untyped_inv_wcap ?ui (Some (cap.UntypedCap dev (ptr && ~~ mask sz) sz idx)) s" @@ -4696,7 +4666,6 @@ lemma inv_untyped_corres': apply (cases ao') apply (simp_all add: obj_bits_api_def slot_bits_def arch_kobj_size_def default_arch_object_def APIType_map2_def untyped_min_bits_def minUntypedSizeBits_def - min_sched_context_bits_def split: apiobject_type.splits) done @@ -4774,8 +4743,8 @@ lemma inv_untyped_corres': apply (clarsimp simp:range_cover_def) done - note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps - usableUntypedRange.simps + note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex usableUntypedRange.simps have vc'[simp] : "s' \' capability.UntypedCap dev (ptr && ~~ mask sz) sz idx" using vui' invs' @@ -4827,7 +4796,7 @@ lemma inv_untyped_corres': have maxDomain:"ksCurDomain s' \ maxDomain" using invs' - by (simp add:invs'_def) + by (simp add:invs'_def valid_state'_def) have sz_mask_less: "unat (ptr && mask sz) < 2 ^ sz" @@ -4898,7 +4867,6 @@ lemma inv_untyped_corres': apply simp+ apply (simp add: insertNewCaps_def) apply (rule corres_split_retype_createNewCaps[where sz = sz,OF corres_rel_imp]) - apply (clarsimp simp: mapM_x_def) apply (rule inv_untyped_corres_helper1) apply simp apply simp @@ -4947,7 +4915,7 @@ lemma inv_untyped_corres': set_cap_cte_wp_at | strengthen exI[where x=cref])+ apply (clarsimp simp:conj_comms ball_conj_distrib simp del:capFreeIndex_update.simps) - apply (strengthen invs_pspace_aligned' invs_pspace_distinct' invs_pspace_bounded' + apply (strengthen invs_pspace_aligned' invs_pspace_distinct' invs_valid_pspace' invs_arch_state' imp_consequent[where Q = "(\x. x \ cte_map ` set slots)"] | clarsimp simp: conj_comms simp del: capFreeIndex_update.simps)+ @@ -4961,11 +4929,10 @@ lemma inv_untyped_corres': invs_valid_pspace invs_arch_state invs_psp_aligned invs_distinct) apply (clarsimp simp:conj_comms ball_conj_distrib ex_in_conv) - apply (rule validE_R_validE, rule_tac Q'="\_ s. valid_list s \ invs s \ ct_active s + apply (rule validE_R_validE, rule_tac Q'="\_ s. valid_etcbs s \ valid_list s \ invs s \ ct_active s \ valid_untyped_inv_wcap ui (Some (cap.UntypedCap dev (ptr && ~~ mask sz) sz (if reset then 0 else idx))) s \ (reset \ pspace_no_overlap {ptr && ~~ mask sz..(ptr && ~~ mask sz) + 2 ^ sz - 1} s) - \ scheduler_action s = resume_cur_thread " in hoare_strengthen_postE_R) apply (simp add: whenE_def, wp) apply (rule validE_validE_R, rule hoare_strengthen_postE, rule reset_untyped_cap_invs_etc, auto)[1] @@ -4995,7 +4962,7 @@ lemma inv_untyped_corres': atLeastatMost_subset_iff[where b=x and d=x for x] word_and_le2) apply (intro conjI impI) - apply (clarsimp simp: scBits_simps) + (* offs *) apply (drule(1) invoke_untyped_proofs.idx_le_new_offs) apply simp @@ -5023,7 +4990,7 @@ lemma inv_untyped_corres': invokeUntyped_proofs.ps_no_overlap' invokeUntyped_proofs.descendants_range if_split[where P="\v. v \ getFreeIndex x y" for x y] - empty_descendants_range_in' invs_pspace_bounded' + empty_descendants_range_in' invs_pspace_aligned' invs_pspace_distinct' invs_ksCurDomain_maxDomain' cong: if_cong) @@ -5050,7 +5017,7 @@ lemma inv_untyped_corres': apply (clarsimp simp only: pred_conj_def invs ui if_apply_def2) apply (strengthen vui) apply (cut_tac vui invs invs') - apply (clarsimp simp: cte_wp_at_caps_of_state schact_is_rct_def) + apply (clarsimp simp: cte_wp_at_caps_of_state valid_sched_etcbs schact_is_rct_def) apply (cut_tac vui' invs') apply (clarsimp simp: ui cte_wp_at_ctes_of if_apply_def2 ui') done @@ -5067,8 +5034,12 @@ crunch doMachineOp (wp: crunch_wps) +crunch set_thread_state + for irq_node[wp]: "\s. P (interrupt_irq_node s)" +crunch setQueue + for ctes_of[wp]: "\s. P (ctes_of s)" crunch setQueue - for cte_wp_at[wp]: "cte_wp_at' P p" + for cte_wp_at[wp]: "cte_wp_at' P p" (simp: cte_wp_at_ctes_of) lemma sts_valid_untyped_inv': @@ -5086,9 +5057,7 @@ crunch invokeUntyped crunch insertNewCap for 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' - (wp: crunch_wps valid_replies'_lift) + (wp: crunch_wps) lemma insertNewCap_valid_pspace': "\\s. valid_pspace' s \ s \' cap @@ -5099,7 +5068,8 @@ lemma insertNewCap_valid_pspace': insertNewCap parent slot cap \\rv. valid_pspace'\" apply (simp add: valid_pspace'_def) - apply (wpsimp wp: insertNewCap_valid_mdb) + apply (wp insertNewCap_valid_mdb) + apply simp_all done crunch insertNewCap @@ -5115,19 +5085,15 @@ crunch insertNewCap for norqL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" (wp: crunch_wps) crunch insertNewCap - for state_refs_of'[wp]: "\s. P (state_refs_of' s)" + for ct[wp]: "\s. P (ksCurThread s)" + (wp: crunch_wps) +crunch insertNewCap + for state_refs_of'[wp]: "\s. P (state_refs_of' s)" (wp: crunch_wps) crunch updateNewFreeIndex - for if_unsafe_then_cap'[wp]: "if_unsafe_then_cap'" - -lemma insertNewCap_list_refs_of_replies'[wp]: - "insertNewCap parent slot cap \\s. P (list_refs_of_replies' s)\" - apply (clarsimp simp: insertNewCap_def) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (rule bind_wp_fwd_skip, wpsimp) - apply (wpsimp wp: getCTE_wp) - apply (clarsimp simp: opt_map_def list_refs_of_reply'_def o_def split: option.splits) - done + for cteCaps[wp]: "\s. P (cteCaps_of s)" +crunch updateNewFreeIndex + for if_unsafe_then_cap'[wp]: "if_unsafe_then_cap'" lemma insertNewCap_ifunsafe'[wp]: "\if_unsafe_then_cap' and ex_cte_cap_to' slot\ @@ -5246,7 +5212,11 @@ crunch insertNewCap (wp: crunch_wps) crunch insertNewCap - for tcbState_inv[wp]: "obj_at' (\tcb. P (tcbState tcb)) t" + for ct_not_inQ[wp]: "ct_not_inQ" + (wp: crunch_wps) + +crunch insertNewCap + for tcbState_inv[wp]: "obj_at' (\tcb. P (tcbState tcb)) t" (wp: crunch_simps hoare_drop_imps) crunch insertNewCap for tcbDomain_inv[wp]: "obj_at' (\tcb. P (tcbDomain tcb)) t" @@ -5268,11 +5238,6 @@ crunch insertNewCap for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" (wp: crunch_simps hoare_drop_imps) -crunch insertNewCap - for valid_release_queue[wp]: "valid_release_queue" - and valid_release_queue'[wp]: "valid_release_queue'" - (wp: crunch_wps) - lemma capRange_subset_capBits: "capAligned cap \ capAligned cap' \ capRange cap \ capRange cap' @@ -5327,11 +5292,12 @@ lemma insertNewCap_invs': and K (\ isZombie cap) and (\s. descendants_range' cap parent (ctes_of s)) and caps_overlap_reserved' (untypedRange cap) and ex_cte_cap_to' slot + and (\s. ksIdleThread s \ capRange cap) and (\s. \irq. cap = IRQHandlerCap irq \ irq_issued' irq s)\ insertNewCap parent slot cap \\rv. invs'\" apply (rule insertNewCap_nullcap) - apply (simp add: invs'_def valid_dom_schedule'_def) + apply (simp add: invs'_def valid_state'_def) apply (rule hoare_pre) apply (wp insertNewCap_valid_pspace' sch_act_wf_lift cur_tcb_lift tcb_in_cur_domain'_lift valid_bitmaps_lift @@ -5365,6 +5331,7 @@ lemma zipWithM_x_insertNewCap_invs'': \ (\tup \ set ls. \ isZombie (snd tup)) \ (\tup \ set ls. ex_cte_cap_to' (fst tup) s) \ (\tup \ set ls. descendants_range' (snd tup) parent (ctes_of s)) + \ (\tup \ set ls. ksIdleThread s \ capRange (snd tup)) \ (\tup \ set ls. caps_overlap_reserved' (capRange (snd tup)) s) \ distinct_sets (map capRange (map snd ls)) \ (\irq. IRQHandlerCap irq \ set (map snd ls) \ irq_issued' irq s) @@ -5390,19 +5357,21 @@ lemma zipWithM_x_insertNewCap_invs'': lemma createNewCaps_not_isZombie[wp]: "\\\ createNewCaps ty ptr bits sz d \\rv s. (\cap \ set rv. \ isZombie cap)\" - apply (simp add: createNewCaps_def toAPIType_def + apply (simp add: createNewCaps_def toAPIType_def ARM_H.toAPIType_def + createNewCaps_def split del: if_split cong: option.case_cong if_cong apiobject_type.case_cong ARM_H.object_type.case_cong) - apply (wp undefined_valid | wpc | simp add: isCap_simps)+ + apply (rule hoare_pre) + apply (wp undefined_valid | wpc + | simp add: isCap_simps)+ + apply auto? done lemma createNewCaps_cap_to': "\\s. ex_cte_cap_to' p s \ 0 < n \ range_cover ptr sz (APIType_capBits ty us) n - \ pspace_aligned' s \ pspace_distinct' s \ pspace_bounded' s - \ (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) + \ pspace_aligned' s \ pspace_distinct' s \ pspace_no_overlap' ptr sz s\ createNewCaps ty ptr n us d \\rv. ex_cte_cap_to' p\" @@ -5413,13 +5382,25 @@ lemma createNewCaps_cap_to': apply fastforce done +crunch copyGlobalMappings + for it[wp]: "\s. P (ksIdleThread s)" + (wp: mapM_x_wp' ignore: clearMemory) + +lemma createNewCaps_idlethread[wp]: + "\\s. P (ksIdleThread s)\ createNewCaps tp ptr sz us d \\rv s. P (ksIdleThread s)\" + apply (simp add: createNewCaps_def toAPIType_def + split: ARM_H.object_type.split + apiobject_type.split) + apply safe + apply (wp mapM_x_wp' | simp)+ + done + lemma createNewCaps_idlethread_ranges[wp]: "\\s. 0 < n \ range_cover ptr sz (APIType_capBits tp us) n - \ ksIdleThread s \ {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1} - \ (tp = APIObjectType SchedContextObject \ sc_size_bounds us)\ + \ ksIdleThread s \ {ptr .. (ptr && ~~ mask sz) + 2 ^ sz - 1}\ createNewCaps tp ptr n us d \\rv s. \cap\set rv. ksIdleThread s \ capRange cap\" - apply (rule hoare_as_subst [OF createNewCaps_it]) + apply (rule hoare_as_subst [OF createNewCaps_idlethread]) apply (rule hoare_assume_pre) apply (rule hoare_chain, rule createNewCaps_range_helper2) apply fastforce @@ -5435,11 +5416,11 @@ lemma createNewCaps_IRQHandler[wp]: apply (wp | wpc | simp add: image_def | rule hoare_pre_cont)+ done +crunch updateCap + for ksIdleThread[wp]: "\s. P (ksIdleThread s)" + lemma createNewCaps_ct_active': - "\ct_active' and pspace_aligned' and pspace_distinct' and pspace_bounded' and pspace_no_overlap' ptr sz and - K (range_cover ptr sz (APIType_capBits ty us) n \ 0 < n \ - (ty = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us))\ + "\ct_active' and pspace_aligned' and pspace_distinct' and pspace_no_overlap' ptr sz and K (range_cover ptr sz (APIType_capBits ty us) n \ 0 < n)\ createNewCaps ty ptr n us d \\_. ct_active'\" apply (simp add: ct_in_state'_def) @@ -5465,8 +5446,6 @@ lemma invokeUntyped_invs'': assumes createNew_Q: "\tp ptr n us sz dev. \\s. Q s \ range_cover ptr sz (APIType_capBits tp us) n \ (tp = APIObjectType ArchTypes_H.apiobject_type.CapTableObject \ 0 < us) - \ (tp = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject - \ sc_size_bounds us) \ 0 < n \ valid_pspace' s \ pspace_no_overlap' ptr sz s\ createNewCaps tp ptr n us dev \\_. Q\" assumes set_free_Q[wp]: "\slot idx. \invs' and Q\ updateFreeIndex slot idx \\_.Q\" @@ -5506,7 +5485,6 @@ lemma invokeUntyped_invs'': and slots: "cref \ set slots" "distinct slots" "slots \ []" and tps: "tp = APIObjectType ArchTypes_H.apiobject_type.CapTableObject \ 0 < us" "tp = APIObjectType ArchTypes_H.apiobject_type.Untyped \ minUntypedSizeBits \ us \ us \ maxUntypedSizeBits" - "tp = APIObjectType ArchTypes_H.apiobject_type.SchedContextObject \ sc_size_bounds us" using vui by (clarsimp simp: ui cte_wp_at_ctes_of)+ @@ -5527,8 +5505,8 @@ lemma invokeUntyped_invs'': apply (clarsimp simp:range_cover_def) done - note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_simps - usableUntypedRange.simps + note blah[simp del] = untyped_range.simps usable_untyped_range.simps atLeastAtMost_iff atLeastatMost_subset_iff atLeastLessThan_iff + Int_atLeastAtMost atLeastatMost_empty_iff split_paired_Ex usableUntypedRange.simps note descendants_range[simp] = invokeUntyped_proofs.descendants_range[OF pf] note ps_no_overlap'[simp] = invokeUntyped_proofs.ps_no_overlap'[OF pf] note caps_no_overlap'[simp] = invokeUntyped_proofs.caps_no_overlap'[OF pf] @@ -5603,7 +5581,7 @@ lemma invokeUntyped_invs'': apply (clarsimp simp: slots) apply (clarsimp simp:conj_comms ball_conj_distrib pred_conj_def simp del:capFreeIndex_update.simps) - apply (strengthen invs_pspace_aligned' invs_pspace_distinct' invs_pspace_bounded' + apply (strengthen invs_pspace_aligned' invs_pspace_distinct' invs_valid_pspace' invs_arch_state' imp_consequent[where Q = "(\x. x \ set slots)"] | clarsimp simp: conj_comms simp del: capFreeIndex_update.simps)+ @@ -5633,9 +5611,8 @@ lemma invokeUntyped_invs'': apply (erule is_aligned_weaken[OF range_cover.funky_aligned]) apply (simp add: APIType_capBits_def objBits_simps' minUntypedSizeBits_def split: object_type.split apiobject_type.split)[1] - apply (clarsimp simp: sc_size_bounds_def minSchedContextBits_def) apply (cases reset) - apply (clarsimp simp: sc_size_bounds_def minSchedContextBits_def) + apply clarsimp apply (clarsimp simp: invokeUntyped_proofs.ps_no_overlap') apply (drule invs_valid_global') apply (clarsimp simp: valid_global_refs'_def cte_at_valid_cap_sizes_0) @@ -5646,7 +5623,10 @@ lemma invokeUntyped_invs'': apply (simp add: blah word_and_le2) apply (rule order_trans, erule invokeUntyped_proofs.subset_stuff) apply (simp add: blah word_and_le2) - done + apply (frule valid_global_refsD2', clarsimp) + apply (clarsimp simp: global_refs'_def) + apply (erule notE, erule subsetD[rotated], simp add: blah word_and_le2) + done qed lemma invokeUntyped_invs'[wp]: @@ -5664,29 +5644,23 @@ lemma resetUntypedCap_st_tcb_at': "\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) = {})\ - resetUntypedCap slot - \\_. st_tcb_at' P t\" + resetUntypedCap slot + \\_. st_tcb_at' P t\" + apply (rule hoare_name_pre_state) apply (clarsimp simp: cte_wp_at_ctes_of isCap_simps) - apply (rule_tac - Q="\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) - \ ct_active' s - \ sch_act_simple s - \ (descendants_of' slot (ctes_of s) = {})" - in hoare_weaken_pre[rotated]) - apply (clarsimp simp: cte_wp_at'_def) - apply (subst hoare_ex_all[symmetric])+ - apply (clarsimp simp: resetUntypedCap_def) - apply (wpsimp wp: unlessE_wp deleteObjects_st_tcb_at'[where p=slot] mapME_x_inv_wp - preemptionPoint_inv hoare_drop_imps getSlotCap_wp) + apply (simp add: resetUntypedCap_def) + apply (rule hoare_pre) + apply (wp mapME_x_inv_wp preemptionPoint_inv + deleteObjects_st_tcb_at'[where p=slot] getSlotCap_wp + | simp add: unless_def + | wp (once) hoare_drop_imps)+ apply (clarsimp simp: cte_wp_at_ctes_of) + apply (strengthen refl) apply (rule exI, strengthen refl) apply (frule cte_wp_at_valid_objs_valid_cap'[OF ctes_of_cte_wpD], clarsimp+) apply (clarsimp simp: valid_cap_simps' capAligned_def empty_descendants_range_in' - descendants_range'_def2 - elim!: pred_tcb'_weakenE) + descendants_range'_def2 + elim!: pred_tcb'_weakenE) done lemma inv_untyp_st_tcb_at'[wp]: @@ -5725,5 +5699,24 @@ crunch deleteObjects, updateFreeIndex (wp: doMachineOp_irq_states' crunch_wps simp: freeMemory_def no_irq_storeWord unless_def) +lemma resetUntypedCap_IRQInactive: + "\valid_irq_states'\ + resetUntypedCap slot + \\_ _. True\, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + (is "\?P\ resetUntypedCap slot \?Q\,\?E\") + apply (simp add: resetUntypedCap_def) + apply (rule hoare_pre) + apply (wp mapME_x_inv_wp[where P=valid_irq_states' and E="?E", THEN hoare_strengthen_postE] + doMachineOp_irq_states' preemptionPoint_inv hoare_drop_imps + | simp add: no_irq_clearMemory if_apply_def2)+ + done + +lemma inv_untyped_IRQInactive: + "\valid_irq_states'\ invokeUntyped ui + -, \\rv s. intStateIRQTable (ksInterruptState s) rv \ irqstate.IRQInactive\" + apply (simp add: invokeUntyped_def) + apply (wpsimp wp: resetUntypedCap_IRQInactive) + done + end end diff --git a/proof/refine/ARM/VSpace_R.thy b/proof/refine/ARM/VSpace_R.thy index 05e30ec0f8..248c38f66c 100644 --- a/proof/refine/ARM/VSpace_R.thy +++ b/proof/refine/ARM/VSpace_R.thy @@ -1,5 +1,4 @@ (* - * Copyright 2022, Proofcraft Pty Ltd * Copyright 2014, General Dynamics C4 Systems * * SPDX-License-Identifier: GPL-2.0-only @@ -12,16 +11,14 @@ theory VSpace_R imports TcbAcc_R begin +context Arch begin global_naming ARM (*FIXME: arch-split*) -context Arch begin global_naming ARM (*FIXME: arch_split*) - -(*FIXME: move to ainvs*) lemmas store_pte_typ_ats[wp] = store_pte_typ_ats abs_atyp_at_lifts[OF store_pte_typ_at] lemmas store_pde_typ_ats[wp] = store_pde_typ_ats abs_atyp_at_lifts[OF store_pde_typ_at] end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition "pd_at_asid' pd asid \ \s. \ap pool. @@ -64,8 +61,8 @@ lemma findPDForASIDAssert_pd_at_wp: done crunch findPDForASIDAssert - for inv[wp]: "P" - (simp: const_def crunch_simps wp: crunch_wps ignore_del: getObject) + for inv[wp]: "P" + (simp: const_def crunch_simps wp: loadObject_default_inv crunch_wps ignore_del: getObject) lemma pspace_relation_pd: assumes p: "pspace_relation (kheap a) (ksPSpace c)" @@ -82,7 +79,7 @@ lemma pspace_relation_pd: apply (drule_tac x="ucast y" in spec, clarsimp) apply (simp add: ucast_ucast_mask iffD2 [OF mask_eq_iff_w2p] word_size) apply (clarsimp simp add: pde_relation_def) - apply (drule(2) aligned_distinct_pde_atI', simp) + apply (drule(2) aligned_distinct_pde_atI') apply (erule obj_at'_weakenE) apply simp done @@ -119,7 +116,7 @@ lemma find_pd_for_asid_eq_helper: apply (drule ucast_up_inj, simp) apply (simp add: find_pd_for_asid_def bind_assoc word_neq_0_conv[symmetric] liftE_bindE) - apply (simp add: exec_gets liftE_bindE bind_assoc gets_the_def + apply (simp add: exec_gets liftE_bindE bind_assoc get_asid_pool_def get_object_def) apply (simp add: mask_asid_low_bits_ucast_ucast) apply (drule ucast_up_inj, simp) @@ -142,8 +139,9 @@ lemma find_pd_for_asid_assert_eq: cong: bind_apply_cong) apply (clarsimp split: Structures_A.kernel_object.splits arch_kernel_obj.splits if_split_asm) - apply (simp add: get_pde_def get_pd_def get_object_def gets_the_def - bind_assoc pd_bits_def pdBits_def pdeBits_def pageBits_def) + apply (simp add: get_pde_def get_pd_def get_object_def + bind_assoc is_aligned_neg_mask_eq + pd_bits_def pdBits_def pdeBits_def pageBits_def) apply (simp add: exec_gets) done @@ -165,7 +163,8 @@ lemma find_pd_for_asid_valids: apply (simp_all add: validE_def validE_R_def validE_E_def valid_def split: sum.split) apply (auto simp: returnOk_def return_def pdeBits_def - pde_at_def pd_bits_def pdBits_def pageBits_def + pde_at_def pd_bits_def pdBits_def + pageBits_def is_aligned_neg_mask_eq dest!: find_pd_for_asid_eq_helper elim!: is_aligned_weaken) done @@ -228,7 +227,7 @@ lemma findPDForASIDAssert_corres: apply (clarsimp split: Structures_A.kernel_object.splits arch_kernel_obj.splits if_split_asm) apply (simp add: get_pde_def exs_valid_def bind_def return_def - get_pd_def get_object_def simpler_gets_def gets_the_def) + get_pd_def get_object_def simpler_gets_def) apply wp apply simp apply (simp add: get_pde_def get_pd_def) @@ -240,8 +239,9 @@ lemma findPDForASIDAssert_corres: apply simp apply (clarsimp simp: state_relation_def) apply (erule(3) pspace_relation_pd) - apply (simp add: pde_at_def pd_bits_def pdBits_def pdeBits_def pageBits_def) - apply (wp find_pd_for_asid_valids[where pd=pd])+ + apply (simp add: pde_at_def pd_bits_def pdBits_def + is_aligned_neg_mask_eq pdeBits_def pageBits_def) + apply (wp find_pd_for_asid_valids[where pd=pd])+ apply (clarsimp simp: word_neq_0_conv valid_vspace_objs_def) apply simp done @@ -597,6 +597,8 @@ lemma invalidate_tlb_by_asid_corres_ex: apply simp+ done +crunch do_machine_op + for valid_global_objs[wp]: "valid_global_objs" lemma state_relation_asid_map: "(s, s') \ state_relation \ armKSASIDMap (ksArchState s') = arm_asid_map (arch_state s)" by (simp add: state_relation_def arch_state_relation_def) @@ -801,10 +803,21 @@ lemma invalidateASIDEntry_corres: apply simp done +crunch invalidateASID + for aligned'[wp]: "pspace_aligned'" +crunch invalidateASID + for distinct'[wp]: "pspace_distinct'" + +lemma invalidateASID_cur' [wp]: + "\cur_tcb'\ invalidateASID x \\_. cur_tcb'\" + by (simp add: invalidateASID_def|wp)+ + crunch invalidateASIDEntry - for aligned' [wp]: pspace_aligned' - and distinct' [wp]: pspace_distinct' - and cur' [wp]: cur_tcb' + for aligned'[wp]: pspace_aligned' +crunch invalidateASIDEntry + for distinct'[wp]: pspace_distinct' +crunch invalidateASIDEntry + for cur'[wp]: cur_tcb' lemma invalidateASID_valid_arch_state [wp]: "\valid_arch_state'\ invalidateASIDEntry x \\_. valid_arch_state'\" @@ -818,12 +831,12 @@ lemma invalidateASID_valid_arch_state [wp]: done crunch deleteASID - for no_0_obj'[wp]: "no_0_obj'" - (simp: crunch_simps wp: crunch_wps getObject_inv) + for no_0_obj'[wp]: "no_0_obj'" + (simp: crunch_simps wp: crunch_wps getObject_inv loadObject_default_inv) lemma deleteASID_corres: "corres dc - (invs and K (asid \ mask asid_bits \ asid \ 0)) + (invs and valid_etcbs and K (asid \ mask asid_bits \ asid \ 0)) (pspace_aligned' and pspace_distinct' and no_0_obj' and valid_arch_state' and cur_tcb') (delete_asid asid pd) (deleteASID asid pd)" @@ -834,7 +847,7 @@ lemma deleteASID_corres: apply (rule_tac P="\s. asid_high_bits_of asid \ dom (asidTable o ucast) \ asid_pool_at (the ((asidTable o ucast) (asid_high_bits_of asid))) s" and P'="pspace_aligned' and pspace_distinct'" and - Q="invs and K (asid \ mask asid_bits \ asid \ 0) and + Q="invs and valid_etcbs and K (asid \ mask asid_bits \ asid \ 0) and (\s. arm_asid_table (arch_state s) = asidTable \ ucast)" in corres_split) apply (simp add: dom_def) @@ -842,7 +855,8 @@ lemma deleteASID_corres: apply (rule corres_when, simp add: mask_asid_low_bits_ucast_ucast) apply (rule corres_split[OF flushSpace_corres[where pd=pd]]) apply (rule corres_split[OF invalidateASIDEntry_corres[where pd=pd]]) - apply (rule_tac P="asid_pool_at (the (asidTable (ucast (asid_high_bits_of asid))))" + apply (rule_tac P="asid_pool_at (the (asidTable (ucast (asid_high_bits_of asid)))) + and valid_etcbs" and P'="pspace_aligned' and pspace_distinct'" in corres_split) apply (simp del: fun_upd_apply) @@ -898,8 +912,10 @@ lemma valid_arch_state_unmap_strg': apply (auto simp: ran_def split: if_split_asm) done -crunch invalidateASIDEntry, flushSpace - for armKSASIDTable_inv[wp]: "\s. P (armKSASIDTable (ksArchState s))" +crunch invalidateASIDEntry + for armKSASIDTable_inv[wp]: "\s. P (armKSASIDTable (ksArchState s))" +crunch flushSpace + for armKSASIDTable_inv[wp]: "\s. P (armKSASIDTable (ksArchState s))" lemma deleteASIDPool_corres: "corres dc @@ -980,7 +996,7 @@ lemma deleteASIDPool_corres: mask_eq_iff_w2p asid_low_bits_def word_size) apply (rule_tac f="\a. a && mask n" for n in arg_cong) apply (rule shiftr_eq_mask_eq) - apply (simp add: is_aligned_add_helper) + apply (simp add: is_aligned_add_helper is_aligned_neg_mask_eq) apply clarsimp apply (subgoal_tac "base \ base + xa") apply (simp add: valid_vs_lookup_def asid_high_bits_of_def) @@ -1086,23 +1102,23 @@ proof - done qed -crunch armv_contextSwitch, setVMRoot, setVMRootForFlush - 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: hoare_drop_imps simp: crunch_simps) +crunch armv_contextSwitch + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (simp: crunch_simps) -end +crunch setVMRoot + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (simp: crunch_simps) -sublocale Arch < setVMRoot: typ_at_all_props' "setVMRoot tcb" - by typ_at_props' +lemmas setVMRoot_typ_ats [wp] = typ_at_lifts [OF setVMRoot_typ_at'] -sublocale Arch < loadHWASID: typ_at_all_props' "loadHWASID asid" - by typ_at_props' +lemmas loadHWASID_typ_ats [wp] = typ_at_lifts [OF loadHWASID_inv] -sublocale Arch < setVMRootForFlush: typ_at_all_props' "setVMRootForFlush pd asid" - by typ_at_props' +crunch setVMRootForFlush + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: hoare_drop_imps) -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas setVMRootForFlush_typ_ats' [wp] = typ_at_lifts [OF setVMRootForFlush_typ_at'] crunch setVMRootForFlush for aligned'[wp]: pspace_aligned' @@ -1317,29 +1333,22 @@ lemma flushPage_corres: | clarsimp simp: cur_tcb_def [symmetric] cur_tcb'_def [symmetric])+ done -crunch flushTable, flushPage - for typ_at' [wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" +crunch flushTable + for typ_at'[wp]: "\s. P (typ_at' T p s)" (wp: crunch_wps) -end - -sublocale Arch < flushTable: typ_at_all_props' "flushTable pd asid vptr" - by typ_at_props' - -sublocale Arch < flushPage: typ_at_all_props' "flushPage arg1 pd asid vptr" - by typ_at_props' - -sublocale Arch < findPDForASID: typ_at_all_props' "findPDForASID asid" - by typ_at_props' +lemmas flushTable_typ_ats' [wp] = typ_at_lifts [OF flushTable_typ_at'] -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas findPDForASID_typ_ats' [wp] = typ_at_lifts [OF findPDForASID_inv] crunch unmapPageTable for aligned'[wp]: "pspace_aligned'" - and distinct'[wp]: "pspace_distinct'" (simp: crunch_simps - wp: crunch_wps getObject_inv) + wp: crunch_wps getObject_inv loadObject_default_inv) +crunch unmapPageTable + for distinct'[wp]: "pspace_distinct'" + (simp: crunch_simps + wp: crunch_wps getObject_inv loadObject_default_inv) lemma pageTableMapped_corres: "corres (=) (valid_arch_state and valid_vspace_objs and pspace_aligned @@ -1362,11 +1371,17 @@ lemma pageTableMapped_corres: done crunch pageTableMapped - for inv[wp]: "P" + for inv[wp]: "P" + (wp: loadObject_default_inv) + +crunch storePDE, storePTE + for no_0_obj'[wp]: no_0_obj' + and valid_arch'[wp]: valid_arch_state' + and cur_tcb'[wp]: cur_tcb' lemma unmapPageTable_corres: "corres dc - (invs and page_table_at pt and + (invs and valid_etcbs and page_table_at pt and K (0 < asid \ is_aligned vptr 20 \ asid \ mask asid_bits)) (valid_arch_state' and pspace_aligned' and pspace_distinct' and no_0_obj' and cur_tcb' and valid_objs') @@ -1399,15 +1414,25 @@ lemma unmapPageTable_corres: done crunch flushPage - for valid_objs'[wp]: "valid_objs'" + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps hoare_drop_imps) + +lemmas flushPage_typ_ats' [wp] = typ_at_lifts [OF flushPage_typ_at'] + +crunch flushPage + for valid_objs'[wp]: "valid_objs'" (wp: crunch_wps hoare_drop_imps simp: crunch_simps) crunch lookupPTSlot - for inv: "P" + for inv: "P" + (wp: loadObject_default_inv) crunch unmapPage - for aligned' [wp]: pspace_aligned' - and distinct' [wp]: pspace_distinct' + for aligned'[wp]: pspace_aligned' + (wp: crunch_wps simp: crunch_simps) + +crunch unmapPage + for distinct'[wp]: pspace_distinct' (wp: crunch_wps simp: crunch_simps) lemma corres_split_strengthen_ftE: @@ -1459,8 +1484,8 @@ lemma checkMappingPPtr_corres: done crunch checkMappingPPtr - for inv[wp]: "P" - (wp: crunch_wps simp: crunch_simps) + for inv[wp]: "P" + (wp: crunch_wps loadObject_default_inv simp: crunch_simps) lemma store_pte_pd_at_asid[wp]: "\vspace_at_asid asid pd\ @@ -1471,7 +1496,7 @@ lemma store_pte_pd_at_asid[wp]: done lemma unmapPage_corres: - "corres dc (invs and + "corres dc (invs and valid_etcbs and K (valid_unmap sz (asid,vptr) \ vptr < kernel_base \ asid \ mask asid_bits)) (valid_objs' and valid_arch_state' and pspace_aligned' and pspace_distinct' and no_0_obj' and cur_tcb') @@ -1491,7 +1516,7 @@ lemma unmapPage_corres: and (\\ (lookup_pd_slot pd vptr && ~~ mask pd_bits)) and valid_arch_state and valid_vspace_objs and equal_kernel_mappings - and pspace_aligned and valid_global_objs and + and pspace_aligned and valid_global_objs and valid_etcbs and K (valid_unmap sz (asid,vptr) )" and P'="pspace_aligned' and pspace_distinct'" in corres_inst) apply clarsimp @@ -1523,13 +1548,14 @@ lemma unmapPage_corres: apply (simp add: is_aligned_mask[symmetric]) apply (rule corres_split_strengthen_ftE[OF checkMappingPPtr_corres]) apply (simp add: largePagePTEOffsets_def pteBits_def) - apply (rule corres_split[OF corres_mapM]) + apply (rule corres_split) + apply (rule corres_mapM) prefer 7 apply (rule order_refl) apply simp apply simp apply clarsimp - apply (rule_tac P="(\s. \x\set [0, 4 .e. 0x3C]. pte_at (x + pa) s) and pspace_aligned" + apply (rule_tac P="(\s. \x\set [0, 4 .e. 0x3C]. pte_at (x + pa) s) and pspace_aligned and valid_etcbs" and P'="pspace_aligned' and pspace_distinct'" in corres_guard_imp) apply (rule storePTE_corres', simp add:pte_relation_aligned_def) @@ -1572,7 +1598,7 @@ lemma unmapPage_corres: in corres_gen_asm) apply (simp add: is_aligned_mask[symmetric]) apply (rule corres_split) - apply (rule_tac P="page_directory_at pd and pspace_aligned + apply (rule_tac P="page_directory_at pd and pspace_aligned and valid_etcbs and K (valid_unmap sz (asid, vptr))" in corres_mapM [where r=dc], simp, simp) prefer 5 @@ -1849,7 +1875,7 @@ crunch unmapPage lemma corres_store_pde_with_invalid_tail: "\slot \set ys. \ is_aligned (slot >> 2) (pde_align' ab) - \corres dc ((\s. \y\ set ys. pde_at y s) and pspace_aligned) + \corres dc ((\s. \y\ set ys. pde_at y s) and pspace_aligned and valid_etcbs) (pspace_aligned' and pspace_distinct') (mapM (swp store_pde ARM_A.pde.InvalidPDE) ys) (mapM (swp storePDE ab) ys)" @@ -1872,7 +1898,7 @@ lemma corres_store_pde_with_invalid_tail: lemma corres_store_pte_with_invalid_tail: "\slot\ set ys. \ is_aligned (slot >> 2) (pte_align' aa) - \ corres dc ((\s. \y\set ys. pte_at y s) and pspace_aligned) + \ corres dc ((\s. \y\set ys. pte_at y s) and pspace_aligned and valid_etcbs) (pspace_aligned' and pspace_distinct') (mapM (swp store_pte ARM_A.pte.InvalidPTE) ys) (mapM (swp storePTE aa) ys)" @@ -1931,7 +1957,8 @@ lemma pdeCheckIfMapped_corres: done crunch do_machine_op, store_pte - for valid_asid_map[wp]: "valid_asid_map" + for unique_table_refs[wp]: "\s. (unique_table_refs (caps_of_state s))" + and valid_asid_map[wp]: "valid_asid_map" lemma set_cap_pd_at_asid [wp]: "\vspace_at_asid asid pd\ set_cap t st \\rv. vspace_at_asid asid pd\" @@ -2045,17 +2072,12 @@ lemma set_mi_tcb' [wp]: "\ tcb_at' t \ setMessageInfo receiver msg \\rv. tcb_at' t\" by (simp add: setMessageInfo_def) wp -end - -crunch setMRs - for typ_at'[wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - (simp: crunch_simps wp: crunch_wps) -global_interpretation setMRs: typ_at_all_props' "setMRs thread buffer data" - by typ_at_props' +lemma setMRs_typ_at': + "\\s. P (typ_at' T p s)\ setMRs receiver recv_buf mrs \\rv s. P (typ_at' T p s)\" + by (simp add: setMRs_def zipWithM_x_mapM split_def, wp crunch_wps) -context begin interpretation Arch . (*FIXME: arch_split*) +lemmas setMRs_typ_at_lifts[wp] = typ_at_lifts [OF setMRs_typ_at'] lemma set_mrs_invs'[wp]: "\ invs' and tcb_at' receiver \ setMRs receiver recv_buf mrs \\rv. invs' \" @@ -2076,7 +2098,7 @@ lemma same_refs_vs_cap_ref_eq: lemma performPageInvocation_corres: assumes "page_invocation_map pgi pgi'" - shows "corres (=) (invs and valid_page_inv pgi) + shows "corres (=) (invs and valid_etcbs and valid_page_inv pgi) (invs' and valid_page_inv' pgi' and (\s. vs_valid_duplicates' (ksPSpace s))) (perform_page_invocation pgi) (performPageInvocation pgi')" proof - @@ -2085,7 +2107,6 @@ proof - (\c. caps_of_state s p = Some c \ P s \ Q s c)" by blast show ?thesis - apply add_cur_tcb' using assms apply (cases pgi) apply (rename_tac word cap prod sum) @@ -2094,7 +2115,7 @@ proof - page_invocation_map_def) apply (rule corres_guard_imp) apply (rule_tac R="\_. invs and (valid_page_map_inv word cap (a,b) sum) - and (\s. caps_of_state s (a,b) = Some cap)" + and valid_etcbs and (\s. caps_of_state s (a,b) = Some cap)" and R'="\_. invs' and valid_slots' m' and pspace_aligned' and valid_slots_duplicated' m' and pspace_distinct' and (\s. vs_valid_duplicates' (ksPSpace s))" in corres_split) apply (erule updateCap_same_master) @@ -2320,7 +2341,7 @@ definition and K (isPageTableCap cap)" lemma clear_page_table_corres: - "corres dc (pspace_aligned and page_table_at p) + "corres dc (pspace_aligned and page_table_at p and valid_etcbs) (pspace_aligned' and pspace_distinct') (mapM_x (swp store_pte ARM_A.InvalidPTE) [p , p + 4 .e. p + 2 ^ ptBits - 1]) @@ -2338,7 +2359,7 @@ lemma clear_page_table_corres: mapM_x_mapM liftM_def[symmetric]) apply (rule corres_guard_imp, rule_tac r'=dc and S="(=)" - and Q="\xs s. \x \ set xs. pte_at x s \ pspace_aligned s" + and Q="\xs s. \x \ set xs. pte_at x s \ pspace_aligned s \ valid_etcbs s" and Q'="\xs. pspace_aligned' and pspace_distinct'" in corres_mapM_list_all2, simp_all) apply (rule corres_guard_imp, rule storePTE_corres') @@ -2353,25 +2374,17 @@ lemma clear_page_table_corres: done crunch unmapPageTable - for typ_at' [wp]: "\s. P (typ_at' T p s)" - and sc_at'_n[wp]: "\s. P (sc_at'_n n p s)" - -end - -sublocale Arch < unmapPageTable: typ_at_all_props' "unmapPageTable asid vaddr pt" - by typ_at_props' - -context begin interpretation Arch . (*FIXME: arch_split*) + for typ_at'[wp]: "\s. P (typ_at' T p s)" +lemmas unmapPageTable_typ_ats[wp] = typ_at_lifts[OF unmapPageTable_typ_at'] lemma performPageTableInvocation_corres: "page_table_invocation_map pti pti' \ corres dc - (invs and valid_pti pti) + (invs and valid_etcbs and valid_pti pti) (invs' and valid_pti' pti') (perform_page_table_invocation pti) (performPageTableInvocation pti')" (is "?mp \ corres dc ?P ?P' ?f ?g") - apply add_cur_tcb' apply (simp add: perform_page_table_invocation_def performPageTableInvocation_def) apply (cases pti) apply (clarsimp simp: page_table_invocation_map_def) @@ -2447,7 +2460,7 @@ definition lemma performASIDPoolInvocation_corres: "ap' = asid_pool_invocation_map ap \ corres dc - (valid_objs and pspace_aligned and pspace_distinct and valid_apinv ap) + (valid_objs and pspace_aligned and pspace_distinct and valid_apinv ap and valid_etcbs) (pspace_aligned' and pspace_distinct' and valid_apinv' ap') (perform_asid_pool_invocation ap) (performASIDPoolInvocation ap')" @@ -2459,7 +2472,7 @@ lemma performASIDPoolInvocation_corres: apply simp apply (rule_tac F="\p asid. rv = Structures_A.ArchObjectCap (ARM_A.PageDirectoryCap p asid)" in corres_gen_asm) apply clarsimp - apply (rule_tac Q="valid_objs and pspace_aligned and pspace_distinct and asid_pool_at word2 and + apply (rule_tac Q="valid_objs and pspace_aligned and pspace_distinct and asid_pool_at word2 and valid_etcbs and cte_wp_at (\c. cap_master_cap c = cap_master_cap (cap.ArchObjectCap (arch_cap.PageDirectoryCap p asid))) (a,b)" in corres_split) @@ -2508,7 +2521,23 @@ lemma storeHWASID_invs: apply fastforce apply (simp add: storeHWASID_def) apply (wp findPDForASIDAssert_pd_at_wp) - apply (clarsimp simp: invs'_def valid_arch_state'_def valid_dom_schedule'_def + apply (clarsimp simp: invs'_def valid_state'_def valid_arch_state'_def + valid_global_refs'_def global_refs'_def valid_machine_state'_def + ct_not_inQ_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) + done + +lemma storeHWASID_invs_no_cicd': + "\invs_no_cicd' and + (\s. armKSASIDMap (ksArchState s) asid = None \ + armKSHWASIDTable (ksArchState s) hw_asid = None)\ + storeHWASID asid hw_asid + \\x. invs_no_cicd'\" + apply (rule hoare_add_post) + apply (rule storeHWASID_valid_arch') + apply (fastforce simp: all_invs_but_ct_idle_or_in_cur_domain'_def) + apply (simp add: storeHWASID_def) + apply (wp findPDForASIDAssert_pd_at_wp) + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def valid_arch_state'_def valid_global_refs'_def global_refs'_def valid_machine_state'_def ct_not_inQ_def ct_idle_or_in_cur_domain'_def tcb_in_cur_domain'_def) done @@ -2522,9 +2551,9 @@ lemma findFreeHWASID_invs: doMachineOp_def split_def cong: option.case_cong) apply (wp findPDForASIDAssert_pd_at_wp | wpc)+ - apply (clarsimp simp: invs'_def valid_arch_state'_def + apply (clarsimp simp: invs'_def valid_state'_def valid_arch_state'_def valid_global_refs'_def global_refs'_def valid_machine_state'_def - ct_not_inQ_def valid_dom_schedule'_def + ct_not_inQ_def split del: if_split) apply (intro conjI) apply (fastforce dest: no_irq_use [OF no_irq_invalidateLocalTLB_ASID]) @@ -2536,6 +2565,29 @@ lemma findFreeHWASID_invs: apply clarsimp done +lemma findFreeHWASID_invs_no_cicd': + "\invs_no_cicd'\ findFreeHWASID \\asid. invs_no_cicd'\" + apply (rule hoare_add_post) + apply (rule findFreeHWASID_valid_arch) + apply (fastforce simp: all_invs_but_ct_idle_or_in_cur_domain'_def) + apply (simp add: findFreeHWASID_def invalidateHWASIDEntry_def invalidateASID_def + doMachineOp_def split_def + cong: option.case_cong) + apply (wp findPDForASIDAssert_pd_at_wp | wpc)+ + apply (clarsimp simp: all_invs_but_ct_idle_or_in_cur_domain'_def valid_state'_def valid_arch_state'_def + valid_global_refs'_def global_refs'_def valid_machine_state'_def + ct_not_inQ_def + split del: if_split) + apply (intro conjI) + apply (fastforce dest: no_irq_use [OF no_irq_invalidateLocalTLB_ASID]) + apply clarsimp + apply (drule_tac x=p in spec) + apply (drule use_valid) + apply (rule_tac p=p in invalidateLocalTLB_ASID_underlying_memory) + apply blast + apply clarsimp + done + lemma getHWASID_invs [wp]: "\invs'\ getHWASID asid \\hw_asid. invs'\" apply (simp add: getHWASID_def) @@ -2543,6 +2595,13 @@ lemma getHWASID_invs [wp]: apply simp done +lemma getHWASID_invs_no_cicd': + "\invs_no_cicd'\ getHWASID asid \\hw_asid. invs_no_cicd'\" + apply (simp add: getHWASID_def) + apply (wp storeHWASID_invs_no_cicd' findFreeHWASID_invs_no_cicd'|wpc)+ + apply simp + done + lemmas armv_ctxt_sw_defs = armv_contextSwitch_HWASID_def setHardwareASID_def setCurrentPD_def writeTTBR0_def writeTTBR0Ptr_def set_current_pd_def isb_def dsb_def @@ -2562,9 +2621,21 @@ lemma armv_contextSwitch_invs [wp]: apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" in use_valid) apply (simp add: machine_op_lift_def machine_rest_lift_def split_def armv_ctxt_sw_defs + writeTTBR0Ptr_def | wp)+ done +lemma armv_contextSwitch_invs_no_cicd': + "\invs_no_cicd'\ armv_contextSwitch pd asid \\rv. invs_no_cicd'\" + apply (simp add: armv_contextSwitch_def armv_contextSwitch_HWASID_def setCurrentPD_to_abs) + apply (wp dmo_invs_no_cicd' no_irq_setHardwareASID no_irq_set_current_pd no_irq) + apply (rule hoare_post_imp[rotated], rule getHWASID_invs_no_cicd') + apply clarsimp + apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" + in use_valid) + apply (clarsimp simp: machine_op_lift_def machine_rest_lift_def split_def armv_ctxt_sw_defs | wp)+ + done + lemma dmo_setCurrentPD_invs'[wp]: "\invs'\ doMachineOp (setCurrentPD addr) \\rv. invs'\" apply (wpsimp wp: dmo_invs' no_irq_set_current_pd no_irq simp: setCurrentPD_to_abs) @@ -2574,25 +2645,50 @@ lemma dmo_setCurrentPD_invs'[wp]: machine_rest_lift_def split_def | wp)+ done +lemma dmo_setCurrentPD_invs_no_cicd': + "\invs_no_cicd'\ doMachineOp (setCurrentPD addr) \\rv. invs_no_cicd'\" + apply (wpsimp wp: dmo_invs_no_cicd' no_irq_set_current_pd no_irq simp: setCurrentPD_to_abs) + apply (drule_tac Q="\_ m'. underlying_memory m' p = underlying_memory m p" + in use_valid) + apply (clarsimp simp: set_current_pd_def machine_op_lift_def writeTTBR0_def dsb_def isb_def + machine_rest_lift_def split_def | wp)+ + done + crunch setVMRoot - for invs[wp]: "invs'" + for invs[wp]: "invs'" (wp: crunch_wps simp: crunch_simps ignore: doMachineOp) crunch setVMRoot - for nosch[wp]: "\s. P (ksSchedulerAction s)" + for invs_no_cicd': "invs_no_cicd'" + (wp: crunch_wps dmo_setCurrentPD_invs_no_cicd' simp: crunch_simps ignore: doMachineOp) + +crunch setVMRoot + for nosch[wp]: "\s. P (ksSchedulerAction s)" (wp: crunch_wps getObject_inv simp: crunch_simps loadObject_default_def) +crunch findPDForASID + for it'[wp]: "\s. P (ksIdleThread s)" + (simp: crunch_simps loadObject_default_def wp: getObject_inv) + crunch deleteASIDPool - for it'[wp]: "\s. P (ksIdleThread s)" + for it'[wp]: "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def wp: getObject_inv mapM_wp') crunch lookupPTSlot for it'[wp]: "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def wp: getObject_inv) +crunch storePTE + for it'[wp]: "\s. P (ksIdleThread s)" + (simp: crunch_simps updateObject_default_def wp: setObject_idle') + +crunch storePDE + for it'[wp]: "\s. P (ksIdleThread s)" + (simp: crunch_simps updateObject_default_def wp: setObject_idle') + crunch flushTable - for it'[wp]: "\s. P (ksIdleThread s)" + for it'[wp]: "\s. P (ksIdleThread s)" (simp: crunch_simps loadObject_default_def wp: setObject_idle' hoare_drop_imps mapM_wp') @@ -2609,30 +2705,54 @@ lemma valid_slots_lift': apply (rule hoare_pre, wp hoare_vcg_const_Ball_lift t valid_pde_lift' valid_pte_lift', simp)+ done -crunch performPageTableInvocation, performPageDirectoryInvocation, - performPageInvocation, performASIDPoolInvocation - 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 getASID_wp) +crunch performPageTableInvocation + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) -end +crunch performPageDirectoryInvocation + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) + +crunch performPageInvocation + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: crunch_wps) -sublocale Arch < performPageTableInvocation: typ_at_all_props' "performPageTableInvocation i" - by typ_at_props' +crunch performASIDPoolInvocation + for typ_at'[wp]: "\s. P (typ_at' T p s)" + (wp: getObject_cte_inv getASID_wp) -sublocale Arch < performPageDirectoryInvocation: typ_at_all_props' "performPageDirectoryInvocation i" - by typ_at_props' +lemmas performPageTableInvocation_typ_ats' [wp] = + typ_at_lifts [OF performPageTableInvocation_typ_at'] -sublocale Arch < performPageInvocation: typ_at_all_props' "performPageInvocation i" - by typ_at_props' +lemmas performPageDirectoryInvocation_typ_ats' [wp] = + typ_at_lifts [OF performPageDirectoryInvocation_typ_at'] -sublocale Arch < performASIDPoolInvocation: typ_at_all_props' "performASIDPoolInvocation i" - by typ_at_props' +lemmas performPageInvocation_typ_ats' [wp] = + typ_at_lifts [OF performPageInvocation_typ_at'] -sublocale Arch < unmapPage: typ_at_all_props' "unmapPage magnitude asid vptr ptr" - by typ_at_props' +lemmas performASIDPoolInvocation_typ_ats' [wp] = + typ_at_lifts [OF performASIDPoolInvocation_typ_at'] -context begin interpretation Arch . (*FIXME: arch_split*) +lemma storePDE_pred_tcb_at' [wp]: + "\pred_tcb_at' proj P t\ storePDE p pde \\_. pred_tcb_at' proj P t\" + apply (simp add: storePDE_def pred_tcb_at'_def) + apply (rule obj_at_setObject2) + apply (clarsimp simp add: updateObject_default_def in_monad) + done + +lemma storePTE_pred_tcb_at' [wp]: + "\pred_tcb_at' proj P t\ storePTE p pte \\_. pred_tcb_at' proj P t\" + apply (simp add: storePTE_def pred_tcb_at'_def) + apply (rule obj_at_setObject2) + apply (clarsimp simp add: updateObject_default_def in_monad) + done + +lemma setASID_pred_tcb_at' [wp]: + "\pred_tcb_at' proj P t\ setObject p (ap::asidpool) \\_. pred_tcb_at' proj P t\" + apply (simp add: pred_tcb_at'_def) + apply (rule obj_at_setObject2) + apply (clarsimp simp add: updateObject_default_def in_monad) + done lemma dmo_ct[wp]: "\\s. P (ksCurThread s)\ doMachineOp m \\rv s. P (ksCurThread s)\" @@ -2641,6 +2761,33 @@ lemma dmo_ct[wp]: apply clarsimp done +lemma storePDE_valid_mdb [wp]: + "\valid_mdb'\ storePDE p pde \\rv. valid_mdb'\" + by (simp add: valid_mdb'_def) wp + +crunch storePDE + for nosch[wp]: "\s. P (ksSchedulerAction s)" + (simp: updateObject_default_def ignore_del: setObject) + +crunch storePDE + for ksQ[wp]: "\s. P (ksReadyQueues s)" + (simp: updateObject_default_def) + +lemma storePDE_inQ[wp]: + "\\s. P (obj_at' (inQ d p) t s)\ storePDE ptr pde \\rv s. P (obj_at' (inQ d p) t s)\" + apply (simp add: obj_at'_real_def storePDE_def) + apply (wp setObject_ko_wp_at | simp add: objBits_simps archObjSize_def pdeBits_def)+ + apply (clarsimp simp: projectKOs obj_at'_def ko_wp_at'_def) + done + +crunch storePDE + for norqL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + (simp: updateObject_default_def) + +crunch storePDE + for norqL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (simp: updateObject_default_def) + lemma storePDE_state_refs' [wp]: "\\s. P (state_refs_of' s)\ storePDE p pde \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: storePDE_def) @@ -2661,6 +2808,46 @@ lemma storePDE_iflive [wp]: apply (auto simp: updateObject_default_def in_monad projectKOs pdeBits_def) done +lemma setObject_pde_ksInt [wp]: + "\\s. P (ksInterruptState s)\ setObject p (pde::pde) \\_. \s. P (ksInterruptState s)\" + by (wp setObject_ksInterrupt updateObject_default_inv|simp)+ + +crunch storePDE + for ksInterruptState[wp]: "\s. P (ksInterruptState s)" + +lemma storePDE_ifunsafe [wp]: + "\if_unsafe_then_cap'\ storePDE p pde \\rv. if_unsafe_then_cap'\" + apply (simp add: storePDE_def) + apply (rule hoare_pre) + apply (rule setObject_ifunsafe' [where P=\], simp) + apply (auto simp: updateObject_default_def in_monad projectKOs)[2] + apply wp + apply simp + done + +method valid_idle'_setObject uses simp = + simp add: valid_idle'_def, rule hoare_lift_Pf [where f="ksIdleThread"]; wpsimp?; + (wpsimp wp: obj_at_setObject2[where P="idle_tcb'", simplified] hoare_drop_imp + simp: simp + | clarsimp dest!: updateObject_default_result)+ + +lemma storePDE_idle [wp]: + "\valid_idle'\ storePDE p pde \\rv. valid_idle'\" by (valid_idle'_setObject simp: storePDE_def) + +crunch storePDE + for arch'[wp]: "\s. P (ksArchState s)" + and cur'[wp]: "\s. P (ksCurThread s)" + +lemma storePDE_irq_states' [wp]: + "\valid_irq_states'\ storePDE pde p \\_. valid_irq_states'\" + apply (simp add: storePDE_def) + apply (wpsimp wp: valid_irq_states_lift' dmo_lift' no_irq_storeWord setObject_ksMachine + updateObject_default_inv) + done + +crunch storePDE + for no_0_obj'[wp]: no_0_obj' + lemma storePDE_pde_mappings'[wp]: "\valid_pde_mappings' and K (valid_pde_mapping' (p && mask pdBits) pde)\ storePDE p pde @@ -2673,16 +2860,97 @@ lemma storePDE_pde_mappings'[wp]: apply (wp setObject_ko_wp_at) apply simp apply (simp add: objBits_simps archObjSize_def) + apply (simp add: pdeBits_def) apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) apply assumption done +lemma storePDE_vms'[wp]: + "\valid_machine_state'\ storePDE p pde \\_. valid_machine_state'\" + apply (simp add: storePDE_def valid_machine_state'_def pointerInUserData_def + pointerInDeviceData_def) + apply (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv + hoare_vcg_all_lift hoare_vcg_disj_lift | simp)+ + done + +crunch storePDE + for pspace_domain_valid[wp]: "pspace_domain_valid" + +lemma storePDE_ct_not_inQ[wp]: + "\ct_not_inQ\ storePDE p pde \\_. ct_not_inQ\" + apply (rule ct_not_inQ_lift [OF storePDE_nosch]) + apply (simp add: storePDE_def) + apply (rule hoare_weaken_pre) + apply (wps setObject_PDE_ct) + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_default_def in_monad)+ + done + +lemma setObject_pde_cur_domain[wp]: + "\\s. P (ksCurDomain s)\ setObject t (v::pde) \\rv s. P (ksCurDomain s)\" + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setObject_pde_ksDomSchedule[wp]: + "\\s. P (ksDomSchedule s)\ setObject t (v::pde) \\rv s. P (ksDomSchedule s)\" + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma storePDE_cur_domain[wp]: + "\\s. P (ksCurDomain s)\ storePDE p pde \\rv s. P (ksCurDomain s)\" +by (simp add: storePDE_def) wp + +lemma storePDE_ksDomSchedule[wp]: + "\\s. P (ksDomSchedule s)\ storePDE p pde \\rv s. P (ksDomSchedule s)\" +by (simp add: storePDE_def) wp + +lemma storePDE_tcb_obj_at'[wp]: + "\obj_at' (P::tcb \ bool) t\ storePDE p pde \\_. obj_at' P t\" + apply (simp add: storePDE_def) + apply (rule obj_at_setObject2) + apply (clarsimp simp add: updateObject_default_def in_monad) + done + +lemma storePDE_tcb_in_cur_domain'[wp]: + "\tcb_in_cur_domain' t\ storePDE p pde \\_. tcb_in_cur_domain' t\" + by (wp tcb_in_cur_domain'_lift) + +lemma storePDE_ct_idle_or_in_cur_domain'[wp]: + "\ct_idle_or_in_cur_domain'\ storePDE p pde \\_. ct_idle_or_in_cur_domain'\" + by (wp ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift) + +lemma setObject_pte_ksDomScheduleIdx [wp]: + "\\s. P (ksDomScheduleIdx s)\ setObject p (pte::pte) \\_. \s. P (ksDomScheduleIdx s)\" + by (wp updateObject_default_inv|simp add:setObject_def | wpc)+ + +lemma setObject_pde_ksDomScheduleIdx [wp]: + "\\s. P (ksDomScheduleIdx s)\ setObject p (pde::pde) \\_. \s. P (ksDomScheduleIdx s)\" + by (wp updateObject_default_inv|simp add:setObject_def | wpc)+ + +crunch storePTE, storePDE + for ksDomScheduleIdx[wp]: "\s. P (ksDomScheduleIdx s)" + and gsMaxObjectSize[wp]: "\s. P (gsMaxObjectSize s)" + and gsUntypedZeroRanges[wp]: "\s. P (gsUntypedZeroRanges s)" + (wp: setObject_ksPSpace_only updateObject_default_inv simp: o_def) + +lemma storePTE_tcbs_of'[wp]: + "storePTE c (pte::pte) \\s. P' (tcbs_of' s)\" + unfolding storePTE_def + by setObject_easy_cases + +lemma storePDE_tcbs_of'[wp]: + "storePDE c (pde::pde) \\s. P' (tcbs_of' s)\" + unfolding storePDE_def + by setObject_easy_cases + lemma storePDE_invs[wp]: "\invs' and valid_pde' pde and (\s. valid_pde_mapping' (p && mask pdBits) pde)\ storePDE p pde \\_. invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (simp add: invs'_def valid_state'_def valid_pspace'_def) apply (rule hoare_pre) apply (wp sch_act_wf_lift valid_global_refs_lift' irqs_masked_lift @@ -2693,6 +2961,33 @@ lemma storePDE_invs[wp]: apply clarsimp done +lemma storePTE_valid_mdb [wp]: + "\valid_mdb'\ storePTE p pte \\rv. valid_mdb'\" + by (simp add: valid_mdb'_def) wp + +crunch storePTE + for nosch[wp]: "\s. P (ksSchedulerAction s)" + (simp: updateObject_default_def ignore_del: setObject) + +crunch storePTE + for ksQ[wp]: "\s. P (ksReadyQueues s)" + (simp: updateObject_default_def) + +lemma storePTE_inQ[wp]: + "\\s. P (obj_at' (inQ d p) t s)\ storePTE ptr pde \\rv s. P (obj_at' (inQ d p) t s)\" + apply (simp add: obj_at'_real_def storePTE_def) + apply (wp setObject_ko_wp_at | simp add: objBits_simps archObjSize_def pteBits_def)+ + apply (clarsimp simp: projectKOs obj_at'_def ko_wp_at'_def) + done + +crunch storePTE + for norqL1[wp]: "\s. P (ksReadyQueuesL1Bitmap s)" + (simp: updateObject_default_def) + +crunch storePTE + for norqL2[wp]: "\s. P (ksReadyQueuesL2Bitmap s)" + (simp: updateObject_default_def) + lemma storePTE_state_refs' [wp]: "\\s. P (state_refs_of' s)\ storePTE p pte \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: storePTE_def) @@ -2713,6 +3008,52 @@ lemma storePTE_iflive [wp]: apply (auto simp: updateObject_default_def in_monad projectKOs pteBits_def) done +lemma setObject_pte_ksInt [wp]: + "\\s. P (ksInterruptState s)\ setObject p (pte::pte) \\_. \s. P (ksInterruptState s)\" + by (wp setObject_ksInterrupt updateObject_default_inv|simp)+ + +crunch storePTE + for ksInt'[wp]: "\s. P (ksInterruptState s)" + +lemma storePTE_ifunsafe [wp]: + "\if_unsafe_then_cap'\ storePTE p pte \\rv. if_unsafe_then_cap'\" + apply (simp add: storePTE_def) + apply (rule hoare_pre) + apply (rule setObject_ifunsafe' [where P=\], simp) + apply (auto simp: updateObject_default_def in_monad projectKOs)[2] + apply wp + apply simp + done + +lemma storePTE_idle [wp]: + "\valid_idle'\ storePTE p pte \\rv. valid_idle'\" by (valid_idle'_setObject simp: storePTE_def) + +crunch storePTE + for arch'[wp]: "\s. P (ksArchState s)" + and cur'[wp]: "\s. P (ksCurThread s)" + +lemma storePTE_irq_states' [wp]: + "\valid_irq_states'\ storePTE pte p \\_. valid_irq_states'\" + apply (simp add: storePTE_def) + apply (wpsimp wp: valid_irq_states_lift' dmo_lift' no_irq_storeWord setObject_ksMachine + updateObject_default_inv) + done + +lemma storePTE_valid_objs [wp]: + "\valid_objs' and valid_pte' pte\ storePTE p pte \\_. valid_objs'\" + apply (simp add: storePTE_def doMachineOp_def split_def) + apply (rule hoare_pre) + apply (wp hoare_drop_imps|wpc|simp)+ + apply (rule setObject_valid_objs') + prefer 2 + apply assumption + apply (clarsimp simp: updateObject_default_def in_monad) + apply (clarsimp simp: valid_obj'_def) + done + +crunch storePTE + for no_0_obj'[wp]: no_0_obj' + lemma storePTE_pde_mappings'[wp]: "\valid_pde_mappings'\ storePTE p pte \\rv. valid_pde_mappings'\" apply (wp valid_pde_mappings_lift') @@ -2722,9 +3063,66 @@ lemma storePTE_pde_mappings'[wp]: apply assumption done +lemma storePTE_vms'[wp]: + "\valid_machine_state'\ storePTE p pde \\_. valid_machine_state'\" + apply (simp add: storePTE_def valid_machine_state'_def pointerInUserData_def + pointerInDeviceData_def) + apply (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv + hoare_vcg_all_lift hoare_vcg_disj_lift | simp)+ + done + +crunch storePTE + for pspace_domain_valid[wp]: "pspace_domain_valid" + +lemma storePTE_ct_not_inQ[wp]: + "\ct_not_inQ\ storePTE p pte \\_. ct_not_inQ\" + apply (rule ct_not_inQ_lift [OF storePTE_nosch]) + apply (simp add: storePTE_def) + apply (rule hoare_weaken_pre) + apply (wps setObject_pte_ct) + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_default_def in_monad)+ + done + +lemma setObject_pte_cur_domain[wp]: + "\\s. P (ksCurDomain s)\ setObject t (v::pte) \\rv s. P (ksCurDomain s)\" + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setObject_pte_ksDomSchedule[wp]: + "\\s. P (ksDomSchedule s)\ setObject t (v::pte) \\rv s. P (ksDomSchedule s)\" + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma storePTE_cur_domain[wp]: + "\\s. P (ksCurDomain s)\ storePTE p pde \\rv s. P (ksCurDomain s)\" + by (simp add: storePTE_def) wp + +lemma storePTE_ksDomSchedule[wp]: + "\\s. P (ksDomSchedule s)\ storePTE p pde \\rv s. P (ksDomSchedule s)\" + by (simp add: storePTE_def) wp + + +lemma storePTE_tcb_obj_at'[wp]: + "\obj_at' (P::tcb \ bool) t\ storePTE p pte \\_. obj_at' P t\" + apply (simp add: storePTE_def) + apply (rule obj_at_setObject2) + apply (clarsimp simp add: updateObject_default_def in_monad) + done + +lemma storePTE_tcb_in_cur_domain'[wp]: + "\tcb_in_cur_domain' t\ storePTE p pte \\_. tcb_in_cur_domain' t\" + by (wp tcb_in_cur_domain'_lift) + +lemma storePTE_ct_idle_or_in_cur_domain'[wp]: + "\ct_idle_or_in_cur_domain'\ storePTE p pte \\_. ct_idle_or_in_cur_domain'\" + by (wp ct_idle_or_in_cur_domain'_lift hoare_vcg_disj_lift) + lemma storePTE_invs [wp]: "\invs' and valid_pte' pte\ storePTE p pte \\_. invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (simp add: invs'_def valid_state'_def valid_pspace'_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 @@ -2744,6 +3142,37 @@ lemma setASIDPool_valid_objs [wp]: apply (clarsimp simp: valid_obj'_def) done +lemma setASIDPool_valid_mdb [wp]: + "\valid_mdb'\ setObject p (ap::asidpool) \\rv. valid_mdb'\" + by (simp add: valid_mdb'_def) wp + +lemma setASIDPool_nosch [wp]: + "\\s. P (ksSchedulerAction s)\ setObject p (ap::asidpool) \\rv s. P (ksSchedulerAction s)\" + by (wp setObject_nosch updateObject_default_inv|simp)+ + +lemma setASIDPool_ksQ [wp]: + "\\s. P (ksReadyQueues s)\ setObject p (ap::asidpool) \\rv s. P (ksReadyQueues s)\" + by (wp setObject_qs updateObject_default_inv|simp)+ + +lemma setASIDPool_inQ[wp]: + "\\s. P (obj_at' (inQ d p) t s)\ + setObject ptr (ap::asidpool) + \\rv s. P (obj_at' (inQ d p) t s)\" + apply (simp add: obj_at'_real_def) + apply (wp setObject_ko_wp_at + | simp add: objBits_simps archObjSize_def)+ + apply (simp add: pageBits_def) + apply (clarsimp simp: obj_at'_def ko_wp_at'_def projectKOs) + done + +lemma setASIDPool_qsL1 [wp]: + "\\s. P (ksReadyQueuesL1Bitmap s)\ setObject p (ap::asidpool) \\rv s. P (ksReadyQueuesL1Bitmap s)\" + by (wp setObject_qs updateObject_default_inv|simp)+ + +lemma setASIDPool_qsL2 [wp]: + "\\s. P (ksReadyQueuesL2Bitmap s)\ setObject p (ap::asidpool) \\rv s. P (ksReadyQueuesL2Bitmap s)\" + by (wp setObject_qs updateObject_default_inv|simp)+ + lemma setASIDPool_state_refs' [wp]: "\\s. P (state_refs_of' s)\ setObject p (ap::asidpool) \\rv s. P (state_refs_of' s)\" apply (clarsimp simp: setObject_def valid_def in_monad split_def @@ -2762,14 +3191,107 @@ lemma setASIDPool_iflive [wp]: apply (auto simp: updateObject_default_def in_monad projectKOs pageBits_def) done +lemma setASIDPool_ksInt [wp]: + "\\s. P (ksInterruptState s)\ setObject p (ap::asidpool) \\_. \s. P (ksInterruptState s)\" + by (wp setObject_ksInterrupt updateObject_default_inv|simp)+ + +lemma setASIDPool_ifunsafe [wp]: + "\if_unsafe_then_cap'\ setObject p (ap::asidpool) \\rv. if_unsafe_then_cap'\" + apply (rule hoare_pre) + apply (rule setObject_ifunsafe' [where P=\], simp) + apply (auto simp: updateObject_default_def in_monad projectKOs)[2] + apply wp + apply simp + done + +lemma setASIDPool_it' [wp]: + "\\s. P (ksIdleThread s)\ setObject p (ap::asidpool) \\_. \s. P (ksIdleThread s)\" + by (wp setObject_it updateObject_default_inv|simp)+ + +lemma setASIDPool_idle [wp]: + "\valid_idle'\ setObject p (ap::asidpool) \\rv. valid_idle'\" by valid_idle'_setObject + +lemma setASIDPool_irq_states' [wp]: + "\valid_irq_states'\ setObject p (ap::asidpool) \\_. valid_irq_states'\" + apply (rule hoare_pre) + apply (rule hoare_use_eq [where f=ksInterruptState, OF setObject_ksInterrupt]) + apply (simp, rule updateObject_default_inv) + apply (rule hoare_use_eq [where f=ksMachineState, OF setObject_ksMachine]) + apply (simp, rule updateObject_default_inv) + apply wp + apply assumption + done + lemma setObject_asidpool_mappings'[wp]: "\valid_pde_mappings'\ setObject p (ap::asidpool) \\rv. valid_pde_mappings'\" apply (wp valid_pde_mappings_lift') + apply (rule obj_at_setObject2) + apply (clarsimp dest!: updateObject_default_result) + apply assumption + done + +lemma setASIDPool_vms'[wp]: + "\valid_machine_state'\ setObject p (ap::asidpool) \\_. valid_machine_state'\" + apply (simp add: valid_machine_state'_def pointerInUserData_def pointerInDeviceData_def) + apply (wp setObject_typ_at_inv setObject_ksMachine updateObject_default_inv + hoare_vcg_all_lift hoare_vcg_disj_lift | simp)+ + done + +lemma setASIDPool_ct_not_inQ[wp]: + "\ct_not_inQ\ setObject p (ap::asidpool) \\_. ct_not_inQ\" + apply (rule ct_not_inQ_lift [OF setObject_nosch]) + apply (simp add: updateObject_default_def | wp)+ + apply (rule hoare_weaken_pre) + apply (wps setObject_ASID_ct) + apply (rule obj_at_setObject2) + apply (clarsimp simp: updateObject_default_def in_monad)+ + done + +lemma setObject_asidpool_cur'[wp]: + "\\s. P (ksCurThread s)\ setObject p (ap::asidpool) \\rv s. P (ksCurThread s)\" + apply (simp add: setObject_def) + apply (wp | wpc | simp add: updateObject_default_def)+ + done + +lemma setObject_asidpool_cur_domain[wp]: + "\\s. P (ksCurDomain s)\ setObject p (ap::asidpool) \\rv s. P (ksCurDomain s)\" + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setObject_asidpool_ksDomSchedule[wp]: + "\\s. P (ksDomSchedule s)\ setObject p (ap::asidpool) \\rv s. P (ksDomSchedule s)\" + apply (simp add: setObject_def split_def) + apply (wp updateObject_default_inv | simp)+ + done + +lemma setObject_tcb_obj_at'[wp]: + "\obj_at' (P::tcb \ bool) t\ setObject p (ap::asidpool) \\_. obj_at' P t\" + apply (rule obj_at_setObject2) + apply (clarsimp simp add: updateObject_default_def in_monad) + done + +lemma setObject_asidpool_tcb_in_cur_domain'[wp]: + "\tcb_in_cur_domain' t\ setObject p (ap::asidpool) \\_. tcb_in_cur_domain' t\" + by (wp tcb_in_cur_domain'_lift) + +lemma setObject_asidpool_ct_idle_or_in_cur_domain'[wp]: + "\ct_idle_or_in_cur_domain'\ setObject p (ap::asidpool) \\_. ct_idle_or_in_cur_domain'\" + apply (rule ct_idle_or_in_cur_domain'_lift) + apply (wp hoare_vcg_disj_lift)+ done +lemma setObject_ap_ksDomScheduleIdx [wp]: + "\\s. P (ksDomScheduleIdx s)\ setObject p (ap::asidpool) \\_. \s. P (ksDomScheduleIdx s)\" + by (wp updateObject_default_inv|simp add:setObject_def | wpc)+ + +lemma setObject_asidpool_tcbs_of'[wp]: + "setObject c (asidpool::asidpool) \\s. P' (tcbs_of' s)\" + by setObject_easy_cases + lemma setASIDPool_invs [wp]: "\invs' and valid_asid_pool' ap\ setObject p (ap::asidpool) \\_. invs'\" - apply (simp add: invs'_def valid_pspace'_def valid_dom_schedule'_def) + apply (simp add: invs'_def valid_state'_def valid_pspace'_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 @@ -2852,10 +3374,6 @@ crunch unmapPageTable crunch_wps simp: crunch_simps setCurrentPD_to_abs) -crunch unmapPageTable - for sc_at'_n[wp]: "sc_at'_n n p" - (simp: crunch_simps wp: crunch_wps) - lemma perform_pti_invs [wp]: "\invs' and valid_pti' pti\ performPageTableInvocation pti \\_. invs'\" apply (clarsimp simp: performPageTableInvocation_def getSlotCap_def @@ -2876,6 +3394,9 @@ lemma perform_pti_invs [wp]: apply (clarsimp simp: cte_wp_at_ctes_of valid_pti'_def) done +crunch setVMRootForFlush + for invs'[wp]: "invs'" + lemma mapM_storePTE_invs: "\invs' and valid_pte' pte\ mapM (swp storePTE pte) ps \\xa. invs'\" apply (rule hoare_post_imp) @@ -2902,6 +3423,12 @@ crunch unmapPage for cte_wp_at': "\s. P (cte_wp_at' P' p s)" (wp: crunch_wps simp: crunch_simps) +lemmas unmapPage_typ_ats [wp] = typ_at_lifts [OF unmapPage_typ_at'] + +crunch lookupPTSlot + for inv: P + (wp: crunch_wps simp: crunch_simps) + lemma flushPage_invs' [wp]: "\invs'\ flushPage sz pd asid vptr \\_. invs'\" apply (simp add: flushPage_def) @@ -2935,8 +3462,8 @@ lemma perform_pt_invs [wp]: "\invs' and valid_page_inv' pt\ performPageInvocation pt \\_. invs'\" apply (simp add: performPageInvocation_def) apply (cases pt) - apply (clarsimp simp: cur_tcb'_asrt_def) - apply ((wp dmo_invs' hoare_vcg_all_lift setVMRootForFlush_invs' | simp add: cur_tcb'_def)+)[2] + apply clarsimp + apply ((wp dmo_invs' hoare_vcg_all_lift setVMRootForFlush_invs' | simp add: tcb_at_invs')+)[2] apply (rule hoare_pre_imp[of _ \], assumption) apply (clarsimp simp: valid_def disj_commute[of "pointerInUserData p s" for p s]) @@ -3013,46 +3540,10 @@ lemma isPDCap_PD : "isPDCap (ArchObjectCap (PageDirectoryCap r m))" by (simp add: isPDCap_def) -lemma lookupIPCBuffer_valid_ipc_buffer [wp]: - "\valid_objs'\ lookupIPCBuffer b t \case_option \ valid_ipc_buffer_ptr'\" - unfolding lookupIPCBuffer_def ARM_H.lookupIPCBuffer_def - apply (simp add: Let_def getSlotCap_def getThreadBufferSlot_def - locateSlot_conv threadGet_getObject) - apply (wp getCTE_wp getObject_tcb_wp | wpc)+ - apply (clarsimp simp del: imp_disjL) - apply (drule obj_at_ko_at') - apply (clarsimp simp del: imp_disjL) - apply (rule_tac x = ko in exI) - apply (frule ko_at_cte_ipcbuffer) - apply (clarsimp simp: cte_wp_at_ctes_of simp del: imp_disjL) - apply (rename_tac d ref rghts sz mapdata) - apply (clarsimp simp: valid_ipc_buffer_ptr'_def) - apply (frule (1) ko_at_valid_objs') - apply (clarsimp simp: projectKO_opts_defs split: kernel_object.split_asm) - apply (clarsimp simp: valid_obj'_def valid_tcb'_def - isCap_simps cte_level_bits_def field_simps) - apply (drule bspec [OF _ ranI [where a = "0x20"]]) - apply simp - apply (clarsimp simp: valid_cap'_def) - apply (rule conjI) - apply (rule aligned_add_aligned) - apply (clarsimp simp: capAligned_def) - apply assumption - apply (erule is_aligned_andI1) - apply (case_tac sz; simp add: msg_align_bits) - apply (clarsimp simp: capAligned_def) - apply (drule_tac x = "(tcbIPCBuffer ko && mask (pageBitsForSize sz)) >> pageBits" in spec) - apply (subst(asm) mult.commute mult.left_commute, subst(asm) shiftl_t2n[symmetric]) - apply (simp add: shiftr_shiftl1) - apply (subst (asm) mask_out_add_aligned) - apply (erule is_aligned_weaken [OF _ pbfs_atleast_pageBits]) - apply (erule mp) - apply (rule shiftr_less_t2n) - apply (clarsimp simp: pbfs_atleast_pageBits) - apply (rule and_mask_less') - apply (simp add: word_bits_conv) - done end +lemma cteCaps_of_ctes_of_lift: + "(\P. \\s. P (ctes_of s)\ f \\_ s. P (ctes_of s)\) \ \\s. P (cteCaps_of s) \ f \\_ s. P (cteCaps_of s)\" + unfolding cteCaps_of_def . end diff --git a/proof/refine/ARM/orphanage/Orphanage.thy b/proof/refine/ARM/orphanage/Orphanage.thy index b4a61208b5..efe187dda3 100644 --- a/proof/refine/ARM/orphanage/Orphanage.thy +++ b/proof/refine/ARM/orphanage/Orphanage.thy @@ -14,7 +14,7 @@ text \ or about to be switched to, or be in a scheduling queue. \ -(*FIXME: arch_split: move up? *) +(*FIXME: arch-split: move up? *) context Arch begin requalify_facts @@ -30,7 +30,7 @@ requalify_facts end end -context begin interpretation Arch . (*FIXME: arch_split*) +context begin interpretation Arch . (*FIXME: arch-split*) definition is_active_thread_state :: "thread_state \ bool" @@ -1058,7 +1058,7 @@ crunch cteInsert, setExtraBadge, setMessageInfo, transferCaps, copyMRs, crunch doIPCTransfer, setMRs, setEndpoint for ksReadyQueues [wp]: "\s. P (ksReadyQueues s)" and no_orphans [wp]: "no_orphans" - (wp: transferCapsToSlots_pres1 crunch_wps no_orphans_lift updateObject_default_inv) + (wp: no_orphans_lift updateObject_default_inv) lemma sendIPC_no_orphans [wp]: "\\s. no_orphans s \ valid_objs' s \ sch_act_wf (ksSchedulerAction s) s\ @@ -1797,11 +1797,11 @@ lemma invokeIRQControl_no_orphans [wp]: apply (wp | clarsimp)+ done -lemma invokeIRQHandler_no_orphans [wp]: +lemma arch_invokeIRQHandler_no_orphans[wp]: "\ \s. no_orphans s \ invs' s \ - invokeIRQHandler i + ARM_H.invokeIRQHandler i \ \reply s. no_orphans s \" - apply (cases i, simp_all add: invokeIRQHandler_def) + apply (cases i, simp_all add: ARM_H.invokeIRQHandler_def) apply (wp | clarsimp | fastforce)+ done @@ -1939,7 +1939,7 @@ lemma setDomain_no_orphans [wp]: apply (fastforce simp: tcb_at_typ_at' is_active_tcb_ptr_runnable') done -crunch InterruptDecls_H.invokeIRQHandler +crunch invokeIRQHandler for no_orphans[wp]: no_orphans lemma performInvocation_no_orphans [wp]: